diff --git a/.gitignore b/.gitignore index 3518ea0..f22a934 100644 --- a/.gitignore +++ b/.gitignore @@ -1,10 +1,224 @@ -# Exclude binary files +# Prerequisites +*.d + +# Object files *.o -*.so +*.ko +*.obj +*.elf + +# Linker output +*.ilk +*.map +*.exp + +# Precompiled Headers +*.gch +*.pch + +# Libraries +*.lib *.a -*.mod +*.la +*.lo + +# Shared objects (inc. Windows DLLs) +*.dll +*.so +*.so.* +*.dylib + +# Executables *.exe -**/__pycache__ -doc/* -build*/* -include/version.h +*.out +*.app +*.i*86 +*.x86_64 +*.hex + +# Debug files +*.dSYM/ +*.su +*.idb +*.pdb + +# Kernel Module Compile Results +*.mod* +*.cmd +.tmp_versions/ +modules.order +Module.symvers +Mkfile.old +dkms.conf + +# Byte-compiled / optimized / DLL files +__pycache__/ +*.py[cod] +*$py.class + +# C extensions +*.so + +# Distribution / packaging +.Python +build/ +develop-eggs/ +dist/ +downloads/ +eggs/ +.eggs/ +lib/ +lib64/ +parts/ +sdist/ +var/ +wheels/ +share/python-wheels/ +*.egg-info/ +.installed.cfg +*.egg +MANIFEST + +# PyInstaller +# Usually these files are written by a python script from a template +# before PyInstaller builds the exe, so as to inject date/other infos into it. +*.manifest +*.spec + +# Installer logs +pip-log.txt +pip-delete-this-directory.txt + +# Unit test / coverage reports +htmlcov/ +.tox/ +.nox/ +.coverage +.coverage.* +.cache +nosetests.xml +coverage.xml +*.cover +*.py,cover +.hypothesis/ +.pytest_cache/ +cover/ + +# Translations +*.mo +*.pot + +# Django stuff: +*.log +local_settings.py +db.sqlite3 +db.sqlite3-journal + +# Flask stuff: +instance/ +.webassets-cache + +# Scrapy stuff: +.scrapy + +# Sphinx documentation +docs/_build/ + +# PyBuilder +.pybuilder/ +target/ + +# Jupyter Notebook +.ipynb_checkpoints + +# IPython +profile_default/ +ipython_config.py + +# pyenv +# For a library or package, you might want to ignore these files since the code is +# intended to run in multiple environments; otherwise, check them in: +# .python-version + +# pipenv +# According to pypa/pipenv#598, it is recommended to include Pipfile.lock in version control. +# However, in case of collaboration, if having platform-specific dependencies or dependencies +# having no cross-platform support, pipenv may install dependencies that don't work, or not +# install all needed dependencies. +#Pipfile.lock + +# poetry +# Similar to Pipfile.lock, it is generally recommended to include poetry.lock in version control. +# This is especially recommended for binary packages to ensure reproducibility, and is more +# commonly ignored for libraries. +# https://python-poetry.org/docs/basic-usage/#commit-your-poetrylock-file-to-version-control +#poetry.lock + +# pdm +# Similar to Pipfile.lock, it is generally recommended to include pdm.lock in version control. +#pdm.lock +# pdm stores project-wide configurations in .pdm.toml, but it is recommended to not include it +# in version control. +# https://pdm.fming.dev/latest/usage/project/#working-with-version-control +.pdm.toml +.pdm-python +.pdm-build/ + +# PEP 582; used by e.g. github.com/David-OConnor/pyflow and github.com/pdm-project/pdm +__pypackages__/ + +# Celery stuff +celerybeat-schedule +celerybeat.pid + +# SageMath parsed files +*.sage.py + +# Environments +.env +.venv +env/ +venv/ +ENV/ +env.bak/ +venv.bak/ + +# Spyder project settings +.spyderproject +.spyproject + +# Rope project settings +.ropeproject + +# mkdocs documentation +/site + +# mypy +.mypy_cache/ +.dmypy.json +dmypy.json + +# Pyre type checker +.pyre/ + +# pytype static type analyzer +.pytype/ + +# Cython debug symbols +cython_debug/ + +# PyCharm +# JetBrains specific template is maintained in a separate JetBrains.gitignore that can +# be found at https://github.com/github/gitignore/blob/main/Global/JetBrains.gitignore +# and can be added to the global gitignore or merged into this file. For a more nuclear +# option (not recommended) you can uncomment the following to ignore the entire idea folder. +.idea/ + +# VSCode +.vscode/ + +# Custom build options file +custom.cmake + +# Build directories +*build*/ diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index bccb030..b1a3889 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -56,11 +56,11 @@ cmake-config-nvidia: before_script: - export NVARCH=`uname -s`_`uname -m` - export NVCOMPILERS=/opt/nvidia/hpc_sdk - - export PATH=$NVCOMPILERS/$NVARCH/2023/compilers/bin:$PATH + - export PATH=$NVCOMPILERS/$NVARCH/2024/compilers/bin:$PATH script: - mkdir build_nvidia - cd build_nvidia - - cmake -DCMAKE_C_COMPILER=`which nvc` -DCMAKE_CXX_COMPILER=`which nvcc` -DCMAKE_Fortran_COMPILER=`which nvfortran` -DCMAKE_BUILD_TYPE=RELEASE -DHDF5_ROOT=/opt/nvidia/hdf5-1.12.2 .. + - cmake -DCMAKE_C_COMPILER=`which nvc` -DCMAKE_CXX_COMPILER=`which nvcc` -DCMAKE_Fortran_COMPILER=`which nvfortran` -DCMAKE_BUILD_TYPE=RELEASE -DWITH_HDF5=FALSE .. artifacts: paths: - build_nvidia @@ -87,10 +87,11 @@ compile-C: script: - cd build - make C_test_programs - - make utility_programs + - make openmmpol_utils artifacts: paths: - build/bin + - build/app only: - pushes - schedules @@ -130,10 +131,11 @@ compile-C-intel: script: - cd build_intel - make C_test_programs - - make utility_programs + - make openmmpol_utils artifacts: paths: - build_intel/bin + - build_intel/app only: - schedules @@ -177,10 +179,11 @@ compile-C-nvidia: script: - cd build_nvidia - make C_test_programs - - make utility_programs + - make openmmpol_utils artifacts: paths: - build_nvidia/bin + - build_nvidia/app only: - schedules diff --git a/CMakeLists.txt b/CMakeLists.txt index 4d6ac4d..bd63559 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,273 +1,174 @@ -cmake_minimum_required(VERSION 3.17) -project(openMMPol) -enable_language(Fortran) -enable_testing() - -set(CMAKE_Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/mod) -set(CMAKE_LIBRARY_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/lib) -set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin) - -set(DEFAULT_BUILD_TYPE "RELEASE") -if(NOT CMAKE_BUILD_TYPE) - set(CMAKE_BUILD_TYPE "${DEFAULT_BUILD_TYPE}" CACHE - STRING "Choose the type of build." FORCE) - set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS - "DEBUG" "RELEASE") +cmake_minimum_required(VERSION 3.18...3.29) +# Load modules +set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${CMAKE_CURRENT_SOURCE_DIR}/cmake/") +include(CMakePrintHelpers) +include(BuildUtils) +include(GetGitVersion) + +# Get git version +get_git_version(OMMP_VERSION OMMP_COMMIT OMMP_VERSION_INTERNAL) + +# Define project +project( + openmmpol + LANGUAGES Fortran C CXX + VERSION ${OMMP_VERSION} + DESCRIPTION "Modern Fortran library for polarizable QM/MM simulations, version commit: ${OMMP_COMMIT}" +) +include(GNUInstallDirs) + +add_subdirectory("config") +get_config_arguments() + +set( + lib-deps + "OpenMP::OpenMP_Fortran" + "LAPACK::LAPACK" + "cjson" + "OpenSSL::SSL" +) + +if(NOT TARGET OpenMP::OpenMP_Fortran) + find_package(OpenMP REQUIRED COMPONENTS Fortran) endif() -add_compile_options($<$:-O3> - $<$:-g> - $<$:-O0>) -if(${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") - add_compile_options($<$:> - $<$:-Og> - $<$:-fsanitize=address> - $<$:-pg> - $<$:-fprofile-arcs> - $<$:-ftest-coverage>) - add_link_options($<$:-coverage> - $<$:-fsanitize=address>) +if(NOT TARGET LAPACK::LAPACK) + find_package(LAPACK REQUIRED) endif() -include_directories(include) # Directory for .h files +if(WITH_HDF5) + list(APPEND lib-deps hdf5::hdf5_fortran) -# Create the define version.h needed for tracking version -# of the library. -find_package(Git REQUIRED) -execute_process(COMMAND ${GIT_EXECUTABLE} -C ${CMAKE_SOURCE_DIR} rev-parse OUTPUT_QUIET ERROR_QUIET RESULT_VARIABLE CMAKE_SOURCE_DIR_IS_GIT) + if(NOT TARGET hdf5::hdf5_fortran) + find_package(HDF5 COMPONENTS Fortran) + endif() -if (CMAKE_SOURCE_DIR_IS_GIT EQUAL 0) - message(NOTICE "Version read from git repository information.") - execute_process(COMMAND ${GIT_EXECUTABLE} describe --tags --dirty - COMMAND sed "s/-/+r/;s/-/./g" - OUTPUT_VARIABLE OMMP_VERSION) - string(STRIP ${OMMP_VERSION} OMMP_VERSION) -else() - if(NOT EXISTS ${CMAKE_SOURCE_DIR}/include/version.h) - set(OMMP_VERSION "unknown-nogit") - message(DEPRECATION "Your source folder is not a git repository, so an accurate tracking of version cannot be performed. Version name is \"${OMMP_VERSION}\". We strongly recommend to install OpenMMPol from a git repository to have a proper version identifier needed for reproducing results.") - else() - message(NOTICE "Version read from ${CMAKE_SOURCE_DIR}/include/version.h") - execute_process(COMMAND echo \#include \"version.h\"\n_OMMP_VERSION - COMMAND ${CMAKE_C_COMPILER} -E -P -I${CMAKE_SOURCE_DIR}/include - - COMMAND tr -d \" - OUTPUT_VARIABLE OMMP_VERSION) - endif() endif() -file(WRITE ${CMAKE_BINARY_DIR}/include/version.h "#define _OMMP_VERSION \"${OMMP_VERSION}\"") -configure_file(${CMAKE_SOURCE_DIR}/include/_openmmpol_const.h ${CMAKE_BINARY_DIR}/include/openmmpol_const.h) -file(COPY ${CMAKE_SOURCE_DIR}/include/openmmpol.h DESTINATION ${CMAKE_BINARY_DIR}/include/) -include_directories(${CMAKE_BINARY_DIR}/include) # Directory for .h files -message(NOTICE "Version string ${OMMP_VERSION}") - -set(LIBRARY_SRC - src/mod_adjacency_mat.f90 - src/mod_bonded.f90 - src/mod_constants.f90 - src/mod_c_interface.f90 - src/mod_electrostatics.f90 - src/mod_geomgrad.f90 - src/mod_inputloader.f90 - src/mod_interface.f90 - src/mod_io.f90 - src/mod_iohdf5.f90 - src/mod_jacobian_mat.f90 - src/mod_link_atom.f90 - src/mod_memory.f90 - src/mod_mmpol.f90 - src/mod_neighbors_list.f90 - src/mod_nonbonded.f90 - src/mod_polarization.f90 - src/mod_prm.f90 - src/mod_profiling.f90 - src/mod_qm_helper.f90 - src/mod_solvers.f90 - src/mod_topology.f90 - src/mod_utils.f90 - src/rotate_multipoles.f90 - src/smartinput.c) - -# Enable preprocessor for Fortran -set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -cpp") - -find_package(LAPACK REQUIRED COMPONENTS Fortran) -find_package(OpenMP REQUIRED COMPONENTS Fortran) -find_package(HDF5 COMPONENTS Fortran) -find_package(cJSON REQUIRED) -find_package(OpenSSL REQUIRED) - -if(NOT PYTHON) - add_library(openmmpol SHARED ${LIBRARY_SRC}) - - # LAPACK - target_link_libraries(openmmpol ${LAPACK_LIBRARIES}) - # cmake 3.22 exposes BLA_SIZEOF_INTEGER - - #OpenMP - if(OpenMP_Fortran_FOUND) - include_directories(SYSTEM ${OpenMP_Fortran_INCLUDE_DIRS}) - target_link_libraries(openmmpol OpenMP::OpenMP_Fortran) - endif() - - # HDF5 - if (HDF5_FOUND) - include_directories( SYSTEM ${HDF5_INCLUDE_DIRS}) - target_link_libraries(openmmpol ${HDF5_Fortran_LIBRARIES}) - set(CMAKE_REQUIRED_INCLUDES ${HDF5_INCLUDE_DIRS}) - set(CMAKE_REQUIRED_LIBRARIES ${HDF5_Fortran_LIBRARIES}) - include(CheckFortranSourceCompiles) - check_fortran_source_compiles("program test_hdf5; use hdf5; integer(hid_t) :: test; integer(kind=4) :: eflag; call h5open_f(eflag); end" - HDF5_WORKS SRC_EXT .f90) - if (HDF5_WORKS) - add_definitions(-DUSE_HDF5) - endif() - endif() - - # cJSON - if(cJSON_FOUND) - include_directories( SYSTEM ${CJSON_INCLUDE_DIR}) - target_link_libraries(openmmpol ${CJSON_LIBRARIES}) - endif() - - # openssl - if(OpenSSL_FOUND) - include_directories( SYSTEM ${OPENSSL_INCLUDE_DIR}) - target_link_libraries(openmmpol ${OPENSSL_LIBRARIES}) - endif() - - - # cmake 3.18 is needed for this - #set_source_files_properties(src/mod_interface.f90 src/mod_io.f90 src/mod_memory.f90 PROPERTIES Fortran_PREPROCESS ON) - if(${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -std=f2008ts -fno-realloc-lhs -fall-intrinsics") - target_compile_options(openmmpol PRIVATE -Wall -Wextra -pedantic) # Very strict check on code - #target_compile_options(openmmpol PRIVATE -Wall -Wextra -pedantic -std=f2003 -fno-realloc-lhs) # Very strict check on code - target_compile_options(openmmpol PRIVATE $<$:-g -Wconversion>) - if(${CMAKE_BUILD_TYPE} STREQUAL "DEBUG") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -Warray-temporaries -fimplicit-none -fbacktrace -ffpe-trap=invalid,zero,overflow,underflow -finit-real=nan -ffree-line-length-0 -fcheck=all") - endif() - target_link_libraries(openmmpol stdc++) - endif() - target_compile_options(openmmpol PRIVATE -fPIC) # Generate position independent code, for library +if(NOT TARGET cjson) + find_package(cJSON REQUIRED) endif() -set(TEST_PROGRAMS - test_timing - test_SI_init - test_SI_potential - test_SI_geomgrad - test_SI_geomgrad_num) - -set(UTILITY_PROGRAMS - ommp_xyz2mmp) - -if (HDF5_WORKS) - set(UTILITY_PROGRAMS - ${UTILITY_PROGRAMS} - ommp_pp) - - set(TEST_PROGRAMS - ${TEST_PROGRAMS} - test_init_hdf5 - test_potential_hdf5) -endif () - -if(NOT PYTHON) - set(UTILITY_EXE) - foreach( exe ${UTILITY_PROGRAMS} ) - add_executable(${exe} src/${exe}.c) - target_compile_options(${exe} PRIVATE -Wall -Wextra -pedantic) - set_property(TARGET ${exe} PROPERTY C_STANDARD 99) - target_link_libraries(${exe} openmmpol) - set(UTILITY_EXE - ${UTILITY_EXE} - ${exe}) - endforeach() - add_custom_target(utility_programs DEPENDS ${UTILITY_PROGRAMS}) - - set(TEST_LANG - C - F03) - foreach( lang ${TEST_LANG} ) - set(TEST_EXE) - foreach( exe ${TEST_PROGRAMS} ) - if (${lang} STREQUAL "C") - if(NOT EXISTS ${CMAKE_SOURCE_DIR}/src/test_programs/${lang}/${exe}.c) - continue () - endif () - - add_executable(${lang}_${exe} src/test_programs/${lang}/${exe}.c) - target_compile_options(${lang}_${exe} PRIVATE -Wall -Wextra -pedantic) - set_property(TARGET ${lang}_${exe} PROPERTY C_STANDARD 99) - endif() - if (${lang} STREQUAL "F03") - if(NOT EXISTS ${CMAKE_SOURCE_DIR}/src/test_programs/${lang}/${exe}.f90) - continue () - endif () - - add_executable(${lang}_${exe} src/test_programs/${lang}/${exe}.f90) - if(${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") - target_compile_options(${lang}_${exe} PRIVATE -Wall -Wextra -pedantic -std=f2003) - endif () - endif() - - target_link_libraries(${lang}_${exe} openmmpol) - set(TEST_EXE - ${TEST_EXE} - ${lang}_${exe}) - endforeach() - add_custom_target(${lang}_test_programs DEPENDS ${TEST_EXE}) - endforeach() +if(NOT TARGET OpenSSL::SSL) + find_package(OpenSSL REQUIRED) endif() -# Python -option(PYTHON "Build python module (Generally you want to use ./setup.py build_ext for this)" OFF) -if (PYTHON) - #python - find_package(pybind11 CONFIG REQUIRED) - add_library(openmmpol_static STATIC - ${LIBRARY_SRC}) - if(${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") - target_compile_options(openmmpol_static PRIVATE -Wall -Wextra -pedantic -std=f2008ts -fno-realloc-lhs) - target_compile_options(openmmpol_static PRIVATE -fall-intrinsics) # This is only needed for a sizeof function - endif() - #set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -cpp") - target_compile_options(openmmpol_static PRIVATE -fPIC) - target_link_libraries(openmmpol_static OpenMP::OpenMP_Fortran) - target_link_libraries(openmmpol_static ${LAPACK_LIBRARIES}) - if (HDF5_WORKS) - target_link_libraries(openmmpol_static ${HDF5_Fortran_LIBRARIES}) - add_definitions(-DUSE_HDF5) - endif() - target_link_libraries(openmmpol_static ${CJSON_LIBRARIES}) - target_link_libraries(openmmpol_static ${OPENSSL_LIBRARIES}) - - pybind11_add_module(pyopenmmpol MODULE src/pyommp_interface.cpp) - target_compile_definitions(pyopenmmpol PRIVATE VERSION_INFO=${OMMP_VERSION}) - target_link_libraries(pyopenmmpol PRIVATE openmmpol_static) - - set_target_properties(pyopenmmpol PROPERTIES LIBRARY_OUTPUT_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY}) - set_target_properties(pyopenmmpol PROPERTIES OUTPUT_NAME pyopenmmpol) +find_package(Python COMPONENTS Interpreter Development REQUIRED) + +setup_build_type() +load_toolchain_settings() +setup_global_compiler_flags() + +# Collect sources of the project +set(srcs) +add_subdirectory("src") + +# Explicitly require CMake to preprocess all sources; +# this is necessary for some generators +set_source_files_properties( + ${srcs} + PROPERTIES Fortran_PREPROCESS ON +) + +# Setup main library target +add_library( + ${PROJECT_NAME} + SHARED + "${srcs}" +) + +set_target_properties( + ${PROJECT_NAME} + PROPERTIES + POSITION_INDEPENDENT_CODE TRUE + OUTPUT_NAME ${PROJECT_NAME} + VERSION ${PROJECT_VERSION} + SOVERSION ${PROJECT_VERSION_MAJOR} + Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/mod +) + +target_include_directories( + ${PROJECT_NAME} + PUBLIC + $ + $ + $ + $ +) + +target_link_libraries( + ${PROJECT_NAME} + PUBLIC + "${lib-deps}" +) + +# Add executables +add_subdirectory("app") + +# Install targets 1 +install( + TARGETS + ${PROJECT_NAME} + EXPORT + ${PROJECT_NAME}-targets + LIBRARY DESTINATION ${CMAKE_INSTALL_PREFIX}/lib + INCLUDES DESTINATION ${CMAKE_INSTALL_PREFIX}/include + RUNTIME DESTINATION ${CMAKE_INSTALL_PREFIX}/bin + ARCHIVE DESTINATION ${CMAKE_INSTALL_PREFIX}/lib +) + +# Install targets 2 +install( + EXPORT + ${PROJECT_NAME}-targets + NAMESPACE + ${PROJECT_NAME}:: + DESTINATION ${CMAKE_INSTALL_PREFIX}/lib/cmake/${PROJECT_NAME} +) + +# Install CMake config files +install(FILES ${CMAKE_CURRENT_BINARY_DIR}/openmmpol-config.cmake + ${CMAKE_CURRENT_BINARY_DIR}/openmmpol-config-version.cmake + DESTINATION ${CMAKE_INSTALL_PREFIX}/lib/cmake/${PROJECT_NAME} + ) + +# Install the Fortran .mod +install(FILES ${CMAKE_CURRENT_BINARY_DIR}/mod/ommp_interface.mod + DESTINATION ${CMAKE_INSTALL_PREFIX}/lib/) + +# Install the headers +install( + DIRECTORY + ${CMAKE_CURRENT_BINARY_DIR}/include/ + DESTINATION ${CMAKE_INSTALL_PREFIX}/include +) + +# Install binaries +install( + FILES + ${CMAKE_CURRENT_BINARY_DIR}/app/ommp_pp + ${CMAKE_CURRENT_BINARY_DIR}/app/ommp_xyz2mmp + DESTINATION ${CMAKE_INSTALL_PREFIX}/bin + PERMISSIONS WORLD_EXECUTE +) + +# Python interface +if(WITH_PYTHON) + message("-- Building with Python interface") + add_subdirectory("pythonapi") endif() -if(NOT PYTHON) - include(GNUInstallDirs) - install(TARGETS openmmpol ${UTILITY_EXE} - LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}/openMMPol-${OMMP_VERSION} - RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}/openMMPol-${OMMP_VERSION}) - install(TARGETS ${UTILITY_EXE}) - install(FILES ${CMAKE_BINARY_DIR}/include/openmmpol.h ${CMAKE_BINARY_DIR}/mod/ommp_interface.mod - DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}/openMMPol-${OMMP_VERSION}) - - configure_file(${CMAKE_SOURCE_DIR}/cmake/openmmpol-config.cmake.in - ${CMAKE_BINARY_DIR}/cmake/openmmpol-config.cmake @ONLY) - configure_file(${CMAKE_SOURCE_DIR}/cmake/openmmpol-config-version.cmake.in - ${CMAKE_BINARY_DIR}/cmake/openmmpol-config-version.cmake @ONLY) - - install(FILES ${CMAKE_BINARY_DIR}/cmake/openmmpol-config.cmake - ${CMAKE_BINARY_DIR}/cmake/openmmpol-config-version.cmake - DESTINATION ${CMAKE_INSTALL_LIBDIR}/openMMPol-${OMMP_VERSION}) -endif() # Tests -include(tests/CMakeLists.txt) +if(WITH_TESTS) + message("-- Building with tests") + enable_testing() + # Currently, the test language is set here. + # TODO: add an option to config.cmake to alternate between C and F03 + set(TESTLANG "C" + CACHE STRING + "Language to be used for the test suite, + the very same test programs are implemented in C99 (C) + and Fortran2003 (F03).") + include(tests/CMakeLists.txt) +endif() + diff --git a/DOC.md b/DOC.md index 0774f58..6b16b21 100644 --- a/DOC.md +++ b/DOC.md @@ -1,11 +1,11 @@ project: openMMPol src_dir: ./src output_dir: ./doc -summary: A library to interface quantum chemical software with atomistic polarizable embeddinge +summary: A library to interface quantum chemical software with atomistic polarizable embedding author: Molecolab -author_description: Mennucci's research group in Pisa. +author_description: Mennucci research group in Pisa. email: benedetta.mennucci@unipi.it -fpp_extensions: f90 +fpp_extensions: F90 preprocess: true predocmark: > media_dir: ./doc/media diff --git a/Dockerfile b/Dockerfile index 00ecb48..8ff379c 100644 --- a/Dockerfile +++ b/Dockerfile @@ -39,22 +39,22 @@ RUN curl https://yum.repos.intel.com/intel-gpg-keys/GPG-PUB-KEY-INTEL-SW-PRODUCT RUN rpm --import intel.key RUN zypper --non-interactive --gpg-auto-import-keys install intel-basekit \ intel-hpckit -#RUN wget https://github.com/HDFGroup/hdf5/archive/refs/tags/hdf5-1_12_2.tar.gz; \ -# tar xvf hdf5-1_12_2.tar.gz; \ -# rm hdf5-1_12_2.tar.gz; \ -# cd hdf5-hdf5-1_12_2; \ -# source /opt/intel/oneapi/setvars.sh; \ -# CC=icx CXX=icpx FC=ifort ./configure --prefix /opt/intel/hdf5-1.12.2 --enable-fortran --enable-build-mode=production --enable-shared; \ -# make; make install; \ -# cd -; rm -rf hdf5-1_12_2.tar.gz; +RUN wget https://github.com/HDFGroup/hdf5/archive/refs/tags/hdf5-1_12_2.tar.gz; \ + tar xvf hdf5-1_12_2.tar.gz; \ + rm hdf5-1_12_2.tar.gz; \ + cd hdf5-hdf5-1_12_2; \ + source /opt/intel/oneapi/setvars.sh; \ + CC=icx CXX=icpx FC=ifort ./configure --prefix /opt/intel/hdf5-1.12.2 --enable-fortran --enable-build-mode=production --enable-shared; \ + make; make install; \ + cd -; rm -rf hdf5-1_12_2.tar.gz; # NVCompilers suite RUN zypper --non-interactive addrepo https://developer.download.nvidia.com/hpc-sdk/sles/nvhpc.repo RUN zypper --non-interactive --gpg-auto-import-keys --no-gpg-checks install nvhpc -#RUN wget https://github.com/HDFGroup/hdf5/archive/refs/tags/hdf5-1_12_2.tar.gz; \ -# tar xvf hdf5-1_12_2.tar.gz; \ -# rm hdf5-1_12_2.tar.gz; \ -# cd hdf5-hdf5-1_12_2; \ -# export PATH=/opt/nvidia/hpc_sdk/`uname -s`_`uname -m`/2022/compilers/bin:$PATH; \ -# CC=nvc CXX=nvcc FC=nvfortran ./configure --prefix /opt/nvidia/hdf5-1.12.2 --enable-fortran --enable-build-mode=production --enable-shared; \ -# make; make install; \ -# cd -; rm -rf hdf5-1_12_2.tar.gz; +RUN wget https://github.com/HDFGroup/hdf5/archive/refs/tags/hdf5-1_12_2.tar.gz; \ + tar xvf hdf5-1_12_2.tar.gz; \ + rm hdf5-1_12_2.tar.gz; \ + cd hdf5-hdf5-1_12_2; \ + export PATH=/opt/nvidia/hpc_sdk/`uname -s`_`uname -m`/2024/compilers/bin:$PATH; \ + CC=nvc CXX=nvcc FC=nvfortran ./configure --prefix /opt/nvidia/hdf5-1.12.2 --enable-fortran --enable-build-mode=production --enable-shared; \ + make; make install; \ + cd -; rm -rf hdf5-1_12_2.tar.gz; diff --git a/app/CMakeLists.txt b/app/CMakeLists.txt new file mode 100644 index 0000000..62ef3b9 --- /dev/null +++ b/app/CMakeLists.txt @@ -0,0 +1,8 @@ +add_executable(ommp_pp "${CMAKE_CURRENT_SOURCE_DIR}/ommp_pp.c") +target_link_libraries(ommp_pp openmmpol) + +add_executable(ommp_xyz2mmp "${CMAKE_CURRENT_SOURCE_DIR}/ommp_xyz2mmp.c") +target_link_libraries(ommp_xyz2mmp openmmpol) + +# CI custom targets; do not touch +add_custom_target(openmmpol_utils DEPENDS ommp_xyz2mmp ommp_pp) diff --git a/src/ommp_pp.c b/app/ommp_pp.c similarity index 79% rename from src/ommp_pp.c rename to app/ommp_pp.c index e6dbd79..4c2bcac 100644 --- a/src/ommp_pp.c +++ b/app/ommp_pp.c @@ -4,24 +4,28 @@ #include "openmmpol.h" -int main(int argc, char **argv){ - if(argc != 3){ +int main(int argc, char **argv) +{ + if (argc != 3) + { printf("Syntax expected\n"); printf(" $ ommp_pp \n"); return 0; } - + ommp_set_verbose(OMMP_VERBOSE_LOW); OMMP_SYSTEM_PRT my_system; OMMP_QM_HELPER_PRT my_qmh; ommp_smartinput(argv[1], &my_system, &my_qmh); - if(my_qmh != NULL){ + if (my_qmh != NULL) + { printf("Only MM part of the system could be saved in HDF5 format, please remove all the section referring to QM.\n"); return 1; } ommp_save_as_hdf5(my_system, argv[2], "system"); - if(my_system != NULL) ommp_terminate(my_system); - + if (my_system != NULL) + ommp_terminate(my_system); + return 0; } diff --git a/src/ommp_xyz2mmp.c b/app/ommp_xyz2mmp.c similarity index 85% rename from src/ommp_xyz2mmp.c rename to app/ommp_xyz2mmp.c index c76b2a9..1153641 100644 --- a/src/ommp_xyz2mmp.c +++ b/app/ommp_xyz2mmp.c @@ -4,19 +4,21 @@ #include "openmmpol.h" -int main(int argc, char **argv){ - if(argc != 4){ +int main(int argc, char **argv) +{ + if (argc != 4) + { printf("Syntax expected\n"); printf(" $ xyz2mmp \n"); return 0; } - + ommp_set_verbose(OMMP_VERBOSE_DEBUG); OMMP_SYSTEM_PRT my_system = ommp_init_xyz(argv[1], argv[2]); - + ommp_save_mmp(my_system, argv[3], 3); - + ommp_terminate(my_system); - + return 0; } diff --git a/cmake/BuildUtils.cmake b/cmake/BuildUtils.cmake new file mode 100644 index 0000000..167f4a8 --- /dev/null +++ b/cmake/BuildUtils.cmake @@ -0,0 +1,127 @@ +# Borrowed from https://github.com/dftbplus/dftbplus/blob/main/cmake/DftbPlusUtils.cmake + +# Loads build settings +macro (get_config_arguments) + +# Find custom config file; if not found, use global + if(NOT DEFINED BUILD_CONFIG_FILE) + if(DEFINED ENV{OPENMMPOL_BUILD_CONFIG_FILE} + AND NOT "$ENV{OPENMMPOL_BUILD_CONFIG_FILE}" STREQUAL "") + set(BUILD_CONFIG_FILE "$ENV{OPENMMPOL_BUILD_CONFIG_FILE}") + else() + set(BUILD_CONFIG_FILE "${CMAKE_SOURCE_DIR}/config.cmake") + endif() + endif() + message(STATUS "Reading global build config file: ${BUILD_CONFIG_FILE}") + include(${BUILD_CONFIG_FILE}) + +endmacro() + +# Sets up the build type. +function (setup_build_type) + + set(default_build_type "RelWithDebInfo") + get_property(_multiConfig GLOBAL PROPERTY GENERATOR_IS_MULTI_CONFIG) + if(_multiConfig) + set(CMAKE_CONFIGURATION_TYPES "Debug;Release;RelWithDebInfo;Coverage") + message(STATUS "Build type: Multi-Config (build type selected at the build step)") + else() + if(NOT CMAKE_BUILD_TYPE) + message(STATUS "Build type: ${default_build_type} (default single-config)") + set(CMAKE_BUILD_TYPE "${default_build_type}" CACHE STRING "Build type" FORCE) + set_property(CACHE CMAKE_BUILD_TYPE PROPERTY HELPSTRING "Choose the type of build") + set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS + "Debug" "Release" "RelWithDebInfo" "Coverage") + else() + message(STATUS "Build type: ${CMAKE_BUILD_TYPE} (manually selected single-config)") + endif() + endif() + +endfunction() + + +# Tries to guess which toolchain to load based on the environment. +# +# Args: +# toolchain [out]: Name of the selected toolchain or undefined if it could not be selected +# +function(guess_toolchain toolchain) + + if("${CMAKE_Fortran_COMPILER_ID}|${CMAKE_C_COMPILER_ID}" STREQUAL "GNU|GNU") + set(_toolchain "gnu") + elseif("${CMAKE_Fortran_COMPILER_ID}" MATCHES "Intel|IntelLLVM" + AND "${CMAKE_C_COMPILER_ID}" MATCHES "Intel|IntelLLVM") + set(_toolchain "intel") + # elseif("${CMAKE_Fortran_COMPILER_ID}|${CMAKE_C_COMPILER_ID}" STREQUAL "NAG|GNU") + # set(_toolchain "nag") + # TODO: add toolchains for other compilers? + else() + set(_toolchain "generic") + endif() + + set(${toolchain} "${_toolchain}" PARENT_SCOPE) + +endfunction() + + +# Loads toolchain settings. +# +macro(load_toolchain_settings) + + if(NOT DEFINED TOOLCHAIN_FILE AND NOT "$ENV{OPENMMPOL_TOOLCHAIN_FILE}" STREQUAL "") + set(TOOLCHAIN_FILE "$ENV{OPENMMPOL_TOOLCHAIN_FILE}") + endif() + if(NOT DEFINED TOOLCHAIN AND NOT "$ENV{OPENMMPOL_TOOLCHAIN}" STREQUAL "") + set(TOOLCHAIN "$ENV{OPENMMPOL_TOOLCHAIN}") + endif() + if(NOT DEFINED TOOLCHAIN_FILE OR TOOLCHAIN_FILE STREQUAL "") + if(NOT DEFINED TOOLCHAIN OR TOOLCHAIN STREQUAL "") + guess_toolchain(TOOLCHAIN) + endif() + set(TOOLCHAIN_FILE ${CMAKE_CURRENT_SOURCE_DIR}/toolchain/${TOOLCHAIN}.cmake) + endif() + message(STATUS "Reading build environment specific toolchain file: ${TOOLCHAIN_FILE}") + include(${TOOLCHAIN_FILE}) +endmacro() + + +# Sets up the global compiler flags +# +macro(setup_global_compiler_flags) + + if(CMAKE_BUILD_TYPE) + set(_buildtypes ${CMAKE_BUILD_TYPE}) + else() + set(_buildtypes ${CMAKE_CONFIGURATION_TYPES}) + endif() + foreach(_buildtype IN LISTS _buildtypes) + foreach (lang IN ITEMS Fortran C CXX) + string(TOUPPER "${_buildtype}" _buildtype_upper) + set(CMAKE_${lang}_FLAGS " ${${lang}_FLAGS}") + add_preprocessor_flags(CMAKE_${lang}_FLAGS) + set(CMAKE_${lang}_FLAGS_${_buildtype_upper} " ${${lang}_FLAGS_${_buildtype_upper}}") + + message(STATUS "Flags for ${lang}-compiler (build type: ${_buildtype}): " + "${CMAKE_${lang}_FLAGS} ${CMAKE_${lang}_FLAGS_${_buildtype_upper}}") + endforeach() + endforeach() + unset(_buildtypes) + unset(_buildtype) + unset(_buildtype_upper) +endmacro() + +function (add_preprocessor_flags flaglist) + + set(_flaglist "${${flaglist}}") + + if (WITH_HDF5) + set(_flaglist "-DUSE_HDF5 ${_flaglist}") + endif() + + if (WITH_I8) + set(_flaglist "-DUSE_I8 ${_flaglist}") + endif() + + set(${flaglist} ${_flaglist} PARENT_SCOPE) + +endfunction() \ No newline at end of file diff --git a/cmake/GetGitVersion.cmake b/cmake/GetGitVersion.cmake new file mode 100644 index 0000000..4b3c5a3 --- /dev/null +++ b/cmake/GetGitVersion.cmake @@ -0,0 +1,69 @@ + +# Adapted from Chromium source code: +# https://chromium.googlesource.com/external/github.com/google/benchmark/+/refs/tags/v1.4.1/cmake/GetGitVersion.cmake +# +# +# - Returns a version string from Git tags +# +# This function inspects the annotated git tags for the project and returns +# CMake version format compliant string and an abbreviated commit hash as +# two variables. +# +# get_git_version( ) +# +# - Example +# +# include(GetGitVersion) +# get_git_version(GIT_VERSION GIT_COMMIT) +# +# Requires CMake 2.8.11+ + +find_package(Git) +if(__get_git_version) + return() +endif() +set(__get_git_version INCLUDED) +function(get_git_version var1 var2 var3) + if(GIT_EXECUTABLE) + + # 1. git describe --tags | sed "s/\-/./g" | rev | cut -d"." -f2- | rev | tr -d "\n" + execute_process(COMMAND ${GIT_EXECUTABLE} describe --tags + COMMAND sed "s/\-/./g" + COMMAND rev + COMMAND cut -d "." -f2- + COMMAND rev + COMMAND tr -d "\n" + WORKING_DIRECTORY ${CMAKE_SOURCE_DIR} + RESULT_VARIABLE status + OUTPUT_VARIABLE GIT_VERSION + ERROR_QUIET) + + execute_process(COMMAND ${GIT_EXECUTABLE} log --pretty=format:'%h' -n 1 + COMMAND tr -d "\n" + WORKING_DIRECTORY ${CMAKE_SOURCE_DIR} + RESULT_VARIABLE status + OUTPUT_VARIABLE GIT_COMMIT + ERROR_QUIET + ) + + # 2. git describe --tags --dirty | sed "s/-/+r/;s/-/./g" | tr -d "\n" + execute_process(COMMAND ${GIT_EXECUTABLE} describe --tags --dirty + COMMAND sed "s/-/+r/;s/-/./g" + COMMAND tr -d "\n" + WORKING_DIRECTORY ${CMAKE_SOURCE_DIR} + RESULT_VARIABLE status + OUTPUT_VARIABLE GIT_VERSION_INTERNAL + ERROR_QUIET + ) + + else() + set(GIT_VERSION "0.0.0.0") + set(GIT_COMMIT "notfound") + set(GIT_VERSION_INTERNAL "0.0.0") + endif() + + message(VERBOSE "-- git Version: ${GIT_VERSION}, commit: ${GIT_COMMIT}") + set(${var1} ${GIT_VERSION} PARENT_SCOPE) + set(${var2} ${GIT_COMMIT} PARENT_SCOPE) + set(${var3} ${GIT_VERSION_INTERNAL} PARENT_SCOPE) +endfunction() diff --git a/cmake/openmmpol-config-version.cmake.in b/cmake/openmmpol-config-version.cmake.in deleted file mode 100644 index db4a340..0000000 --- a/cmake/openmmpol-config-version.cmake.in +++ /dev/null @@ -1,7 +0,0 @@ -set(PACKAGE_VERSION "@OMMP_VERSION@") -if(NOT "${PACKAGE_FIND_VERSION}" VERSION_GREATER "@OMMP_VERSION@") - set(PACKAGE_VERSION_COMPATIBLE 1) # compatible with older - if("${PACKAGE_FIND_VERSION}" VERSION_EQUAL "@OMMP_VERSION@") - set(PACKAGE_VERSION_EXACT 1) # exact match for this version - endif() -endif() diff --git a/cmake/openmmpol-config.cmake.in b/cmake/openmmpol-config.cmake.in deleted file mode 100644 index cd39c5c..0000000 --- a/cmake/openmmpol-config.cmake.in +++ /dev/null @@ -1,8 +0,0 @@ -# Compute installation prefix relative to this file. -get_filename_component(_prefix @CMAKE_INSTALL_PREFIX@ ABSOLUTE) - -# Report other information. -include(GNUInstallDirs) -set(OPENMMPOL_INCLUDE_DIRS "${_prefix}/include/openMMPol-@OMMP_VERSION@") -set(OPENMMPOL_LIBRARIES "${_prefix}/${CMAKE_INSTALL_LIBDIR}/openMMPol-@OMMP_VERSION@/libopenmmpol.so") -set(OPENMMPOL_FOUND) diff --git a/config.cmake b/config.cmake new file mode 100644 index 0000000..fb1d926 --- /dev/null +++ b/config.cmake @@ -0,0 +1,8 @@ +# HDF5 input +option(WITH_HDF5 "Whether to use HDF5" TRUE) + +# Python interface +option(WITH_PYTHON "Whether Python interface should be built and installed" FALSE) + +# Tests +option(WITH_TESTS "Whether tests should be compiled" TRUE) diff --git a/config/CMakeLists.txt b/config/CMakeLists.txt new file mode 100644 index 0000000..43a64a0 --- /dev/null +++ b/config/CMakeLists.txt @@ -0,0 +1,39 @@ +include(CMakePackageConfigHelpers) + +# Set build type as CMake does not provide defaults +if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) + set( + CMAKE_BUILD_TYPE "RelWithDebInfo" + CACHE STRING "Build type to be used." + FORCE + ) + message( + STATUS + "Setting build type to '${CMAKE_BUILD_TYPE}' as none was specified." + ) +endif() + +configure_file(openmmpol-config.cmake.in ${CMAKE_BINARY_DIR}/openmmpol-config.cmake @ONLY) + +configure_file( + openmmpol_const.h.in + ${CMAKE_BINARY_DIR}/openmmpol_const.h + @ONLY +) + +configure_file( + version.h.in + ${CMAKE_BINARY_DIR}/version.h + @ONLY +) + +# Header file manipulation +file(COPY ${CMAKE_SOURCE_DIR}/include/openmmpol.h DESTINATION ${CMAKE_BINARY_DIR}/include) +file(COPY ${CMAKE_SOURCE_DIR}/include/f_cart_components.h DESTINATION ${CMAKE_BINARY_DIR}/include) + +write_basic_package_version_file( + "${CMAKE_BINARY_DIR}/${PROJECT_NAME}-config-version.cmake" + VERSION "${PROJECT_VERSION}" + COMPATIBILITY AnyNewerVersion +) + diff --git a/config/openmmpol-config.cmake.in b/config/openmmpol-config.cmake.in new file mode 100644 index 0000000..ae6bc2e --- /dev/null +++ b/config/openmmpol-config.cmake.in @@ -0,0 +1,12 @@ +include(CMakeFindDependencyMacro) + +find_dependency(OpenMP REQUIRED COMPONENTS Fortran) +find_dependency(LAPACK REQUIRED) +find_dependency(cJSON REQUIRED) +find_dependency(OpenSSL REQUIRED) + +if(@WITH_HDF5@) + find_dependency(HDF5 REQUIRED COMPONENTS Fortran) +endif() + +include("${CMAKE_CURRENT_LIST_DIR}/openmmpol-targets.cmake") \ No newline at end of file diff --git a/include/_openmmpol_const.h b/config/openmmpol_const.h.in similarity index 71% rename from include/_openmmpol_const.h rename to config/openmmpol_const.h.in index 1c56365..dfc3ac5 100644 --- a/include/_openmmpol_const.h +++ b/config/openmmpol_const.h.in @@ -2,14 +2,14 @@ #define _OPENMMPOL_CONST #define OMMP_VERBOSE_DEBUG 3 -#define OMMP_VERBOSE_HIGH 2 -#define OMMP_VERBOSE_LOW 1 +#define OMMP_VERBOSE_HIGH 2 +#define OMMP_VERBOSE_LOW 1 #define OMMP_VERBOSE_NONE 0 #define OMMP_VERBOSE_DEFAULT OMMP_VERBOSE_LOW #define OMMP_FF_AMOEBA 1 -#define OMMP_FF_WANG_AL 0 -#define OMMP_FF_WANG_DL 0 +#define OMMP_FF_WANG_AL 0 +#define OMMP_FF_WANG_DL 0 #define OMMP_FF_AMBER 0 #define OMMP_FF_UNKNOWN -1 @@ -27,15 +27,15 @@ #define OMMP_AMOEBA_D 1 #define OMMP_AMOEBA_P 2 -#define OMMP_AU2KCALMOL 627.5096080306 +#define OMMP_AU2KCALMOL 627.5096080306 #define OMMP_FORT_AU2KCALMOL 627.5096080306_rp -#define OMMP_KCALMOL2AU 1.59360109742136e-3 +#define OMMP_KCALMOL2AU 1.59360109742136e-3 #define OMMP_FORT_KCALMOL2AU 1.59360109742136e-3_rp -#define OMMP_ANG2AU 1.8897261245650 +#define OMMP_ANG2AU 1.8897261245650 #define OMMP_FORT_ANG2AU 1.8897261245650_rp -#define OMMP_VERSION_STRING "${OMMP_VERSION}" +#define OMMP_VERSION_STRING "@OMMP_VERSION_INTERNAL@" -#define OMMP_DEFAULT_LA_DIST 1.1*OMMP_ANG2AU +#define OMMP_DEFAULT_LA_DIST 1.1 * OMMP_ANG2AU #define OMMP_DEFAULT_LA_N_EEL_REMOVE 2 #define OMMP_DEFAULT_NL_CUTOFF -1.0 diff --git a/config/version.h.in b/config/version.h.in new file mode 100644 index 0000000..00853df --- /dev/null +++ b/config/version.h.in @@ -0,0 +1 @@ +#define _OMMP_VERSION "@OMMP_VERSION_INTERNAL@" \ No newline at end of file diff --git a/include/openmmpol.h b/include/openmmpol.h index 259ad9a..684359c 100644 --- a/include/openmmpol.h +++ b/include/openmmpol.h @@ -3,152 +3,151 @@ #include #include -//#include +// #include #include -typedef void* OMMP_SYSTEM_PRT; -typedef void* OMMP_QM_HELPER_PRT; +typedef void *OMMP_SYSTEM_PRT; +typedef void *OMMP_QM_HELPER_PRT; #ifdef __cplusplus -extern "C" { +extern "C" +{ #endif -extern OMMP_SYSTEM_PRT ommp_init_mmp(const char *); -extern OMMP_SYSTEM_PRT ommp_init_xyz(const char *, const char *); -extern void ommp_set_default_solver(OMMP_SYSTEM_PRT, int32_t); -extern void ommp_set_default_matv(OMMP_SYSTEM_PRT, int32_t); -extern void ommp_save_mmp(OMMP_SYSTEM_PRT, const char *, int32_t); -extern void ommp_set_frozen_atoms(OMMP_SYSTEM_PRT, int32_t, const int32_t *); -extern void ommp_turn_pol_off(OMMP_SYSTEM_PRT, int32_t, const int32_t *); -extern void ommp_terminate(OMMP_SYSTEM_PRT); -#ifdef USE_HDF5 -extern void ommp_save_as_hdf5(OMMP_SYSTEM_PRT, const char *, const char *); -extern void ommp_checkpoint(OMMP_SYSTEM_PRT, const char *, const char *); -extern OMMP_SYSTEM_PRT ommp_init_hdf5(const char *, const char *); -#endif -extern void ommp_set_verbose(int32_t); -extern void ommp_set_outputfile(const char *); -extern void ommp_close_outputfile(void); -extern void ommp_message(const char *, int32_t, const char *); -extern void ommp_fatal(const char *); -extern void ommp_time_pull(const char *); -extern void ommp_time_push(); -extern void ommp_print_summary(OMMP_SYSTEM_PRT); -extern void ommp_print_summary_to_file(OMMP_SYSTEM_PRT, const char *); - -extern double ommp_get_polelec_energy(OMMP_SYSTEM_PRT); -extern double ommp_get_fixedelec_energy(OMMP_SYSTEM_PRT); -extern void ommp_set_external_field(OMMP_SYSTEM_PRT, const double *, int32_t, int32_t); -extern void ommp_set_external_field_nomm(OMMP_SYSTEM_PRT, const double *, int32_t, int32_t); - -extern void ommp_potential_mmpol2ext(OMMP_SYSTEM_PRT, int32_t, const double *, double *); -extern void ommp_potential_mm2ext(OMMP_SYSTEM_PRT, int32_t, const double *, double *); -extern void ommp_potential_pol2ext(OMMP_SYSTEM_PRT, int32_t, const double *, double *); -extern void ommp_field_mmpol2ext(OMMP_SYSTEM_PRT, int32_t, const double *, double *); -extern void ommp_field_mm2ext(OMMP_SYSTEM_PRT, int32_t, const double *, double *); -extern void ommp_field_pol2ext(OMMP_SYSTEM_PRT, int32_t, const double *, double *); - -extern double ommp_get_vdw_energy(OMMP_SYSTEM_PRT); -extern double ommp_get_bond_energy(OMMP_SYSTEM_PRT); -extern double ommp_get_angle_energy(OMMP_SYSTEM_PRT); -extern double ommp_get_angtor_energy(OMMP_SYSTEM_PRT); -extern double ommp_get_strtor_energy(OMMP_SYSTEM_PRT); -extern double ommp_get_strbnd_energy(OMMP_SYSTEM_PRT); -extern double ommp_get_opb_energy(OMMP_SYSTEM_PRT); -extern double ommp_get_pitors_energy(OMMP_SYSTEM_PRT); -extern double ommp_get_torsion_energy(OMMP_SYSTEM_PRT); -extern double ommp_get_imptorsion_energy(OMMP_SYSTEM_PRT); -extern double ommp_get_tortor_energy(OMMP_SYSTEM_PRT); -extern double ommp_get_urey_energy(OMMP_SYSTEM_PRT); -extern double ommp_get_full_bnd_energy(OMMP_SYSTEM_PRT); -extern double ommp_get_full_ele_energy(OMMP_SYSTEM_PRT); -extern double ommp_get_full_energy(OMMP_SYSTEM_PRT); - -extern bool ommp_ff_is_amoeba(OMMP_SYSTEM_PRT); - -extern int32_t ommp_get_n_ipd(OMMP_SYSTEM_PRT); -extern int32_t ommp_get_ld_cart(OMMP_SYSTEM_PRT); -extern int32_t ommp_get_mm_atoms(OMMP_SYSTEM_PRT); -extern int32_t ommp_get_pol_atoms(OMMP_SYSTEM_PRT); - -extern double *ommp_get_cmm(OMMP_SYSTEM_PRT); -extern int32_t *ommp_get_zmm(OMMP_SYSTEM_PRT); -extern int32_t *ommp_get_attypemm(OMMP_SYSTEM_PRT); -extern double *ommp_get_cpol(OMMP_SYSTEM_PRT); -extern double *ommp_get_q(OMMP_SYSTEM_PRT); -extern double *ommp_get_ipd(OMMP_SYSTEM_PRT); -extern int32_t *ommp_get_polar_mm(OMMP_SYSTEM_PRT); - -extern bool ommp_use_frozen(OMMP_SYSTEM_PRT); -extern bool *ommp_get_frozen(OMMP_SYSTEM_PRT); - -extern bool ommp_use_linkatoms(OMMP_SYSTEM_PRT); - -extern void ommp_update_coordinates(OMMP_SYSTEM_PRT, const double *); - -extern void ommp_full_geomgrad(OMMP_SYSTEM_PRT, double *); -extern void ommp_full_bnd_geomgrad(OMMP_SYSTEM_PRT, double *); -extern void ommp_fixedelec_geomgrad(OMMP_SYSTEM_PRT, double *); -extern void ommp_polelec_geomgrad(OMMP_SYSTEM_PRT, double *); -extern void ommp_rotation_geomgrad(OMMP_SYSTEM_PRT, const double *, const double *, double *); -extern void ommp_vdw_geomgrad(OMMP_SYSTEM_PRT, double *); -extern void ommp_bond_geomgrad(OMMP_SYSTEM_PRT, double *); -extern void ommp_angle_geomgrad(OMMP_SYSTEM_PRT, double *); -extern void ommp_strbnd_geomgrad(OMMP_SYSTEM_PRT, double *); -extern void ommp_urey_geomgrad(OMMP_SYSTEM_PRT, double *); -extern void ommp_torsion_geomgrad(OMMP_SYSTEM_PRT, double *); -extern void ommp_imptorsion_geomgrad(OMMP_SYSTEM_PRT, double *); -extern void ommp_angtor_geomgrad(OMMP_SYSTEM_PRT, double *); -extern void ommp_opb_geomgrad(OMMP_SYSTEM_PRT, double *); -extern void ommp_strtor_geomgrad(OMMP_SYSTEM_PRT, double *); -extern void ommp_tortor_geomgrad(OMMP_SYSTEM_PRT, double *); -extern void ommp_pitors_geomgrad(OMMP_SYSTEM_PRT, double *); - -extern OMMP_QM_HELPER_PRT ommp_init_qm_helper(int32_t, const double *, const double *, const int32_t *); -extern void ommp_terminate_qm_helper(OMMP_QM_HELPER_PRT); -extern void ommp_qm_helper_set_frozen_atoms(OMMP_QM_HELPER_PRT, int32_t, const int32_t *); -extern void ommp_qm_helper_update_coord(OMMP_QM_HELPER_PRT, const double *); - -extern void ommp_prepare_qm_ele_ene(OMMP_SYSTEM_PRT, OMMP_QM_HELPER_PRT); -extern void ommp_prepare_qm_ele_grd(OMMP_SYSTEM_PRT, OMMP_QM_HELPER_PRT); -extern double *ommp_qm_helper_get_V_m2n(OMMP_QM_HELPER_PRT); -extern double *ommp_qm_helper_get_V_p2n(OMMP_QM_HELPER_PRT); -extern double *ommp_qm_helper_get_E_m2n(OMMP_QM_HELPER_PRT); -extern double *ommp_qm_helper_get_E_p2n(OMMP_QM_HELPER_PRT); -extern double *ommp_qm_helper_get_E_n2p(OMMP_QM_HELPER_PRT); -extern double *ommp_qm_helper_get_G_n2p(OMMP_QM_HELPER_PRT); -extern double *ommp_qm_helper_get_E_n2m(OMMP_QM_HELPER_PRT); -extern double *ommp_qm_helper_get_G_n2m(OMMP_QM_HELPER_PRT); -extern double *ommp_qm_helper_get_H_n2m(OMMP_QM_HELPER_PRT); -extern double *ommp_qm_helper_get_cqm(OMMP_QM_HELPER_PRT); -extern int32_t ommp_qm_helper_get_npol(OMMP_QM_HELPER_PRT); -extern int32_t ommp_qm_helper_get_nmm(OMMP_QM_HELPER_PRT); -extern int32_t ommp_qm_helper_get_qm_atoms(OMMP_QM_HELPER_PRT); -extern bool *ommp_qm_helper_get_frozen(OMMP_QM_HELPER_PRT); -extern bool ommp_qm_helper_use_frozen(OMMP_QM_HELPER_PRT); -extern void ommp_qm_helper_init_vdw_prm(OMMP_QM_HELPER_PRT, const char *); -extern void ommp_qm_helper_set_attype(OMMP_QM_HELPER_PRT, const int32_t *); -extern void ommp_qm_helper_init_vdw(OMMP_QM_HELPER_PRT, const double *, const double *, - const double *, const char *, const char *, - const char *, const char *, const char *); -extern double ommp_qm_helper_vdw_energy(OMMP_QM_HELPER_PRT, OMMP_SYSTEM_PRT); -extern void ommp_qm_helper_vdw_geomgrad(OMMP_QM_HELPER_PRT, OMMP_SYSTEM_PRT, - double *, double *); -extern void ommp_qm_helper_link_atom_geomgrad(OMMP_QM_HELPER_PRT, OMMP_SYSTEM_PRT, - double *, double *, const double *); -extern bool ommp_qm_helper_use_nonbonded(OMMP_QM_HELPER_PRT); - -extern void ommp_qm_helper_init_link_atom(OMMP_QM_HELPER_PRT, OMMP_SYSTEM_PRT); -extern int32_t ommp_create_link_atom(OMMP_QM_HELPER_PRT, OMMP_SYSTEM_PRT, - int32_t, int32_t, int32_t, const char *, - double, int32_t); -extern void ommp_get_link_atom_coordinates(OMMP_SYSTEM_PRT, int32_t, double *); -extern void ommp_update_link_atoms_position(OMMP_QM_HELPER_PRT, OMMP_SYSTEM_PRT); - -extern void ommp_smartinput(const char *, OMMP_SYSTEM_PRT *, OMMP_QM_HELPER_PRT *); -extern void ommp_smartinput_cpstr(const char *, char *, char **); -extern OMMP_SYSTEM_PRT ommp_system_from_qm_helper(OMMP_QM_HELPER_PRT, const char *); -extern void ommp_set_vdw_cutoff(OMMP_SYSTEM_PRT, double); + extern OMMP_SYSTEM_PRT ommp_init_mmp(const char *); + extern OMMP_SYSTEM_PRT ommp_init_xyz(const char *, const char *); + extern void ommp_set_default_solver(OMMP_SYSTEM_PRT, int32_t); + extern void ommp_set_default_matv(OMMP_SYSTEM_PRT, int32_t); + extern void ommp_save_mmp(OMMP_SYSTEM_PRT, const char *, int32_t); + extern void ommp_set_frozen_atoms(OMMP_SYSTEM_PRT, int32_t, const int32_t *); + extern void ommp_turn_pol_off(OMMP_SYSTEM_PRT, int32_t, const int32_t *); + extern void ommp_terminate(OMMP_SYSTEM_PRT); + extern void ommp_save_as_hdf5(OMMP_SYSTEM_PRT, const char *, const char *); + extern void ommp_checkpoint(OMMP_SYSTEM_PRT, const char *, const char *); + extern OMMP_SYSTEM_PRT ommp_init_hdf5(const char *, const char *); + extern void ommp_set_verbose(int32_t); + extern void ommp_set_outputfile(const char *); + extern void ommp_close_outputfile(void); + extern void ommp_message(const char *, int32_t, const char *); + extern void ommp_fatal(const char *); + extern void ommp_time_pull(const char *); + extern void ommp_time_push(); + extern void ommp_print_summary(OMMP_SYSTEM_PRT); + extern void ommp_print_summary_to_file(OMMP_SYSTEM_PRT, const char *); + + extern double ommp_get_polelec_energy(OMMP_SYSTEM_PRT); + extern double ommp_get_fixedelec_energy(OMMP_SYSTEM_PRT); + extern void ommp_set_external_field(OMMP_SYSTEM_PRT, const double *, int32_t, int32_t); + extern void ommp_set_external_field_nomm(OMMP_SYSTEM_PRT, const double *, int32_t, int32_t); + + extern void ommp_potential_mmpol2ext(OMMP_SYSTEM_PRT, int32_t, const double *, double *); + extern void ommp_potential_mm2ext(OMMP_SYSTEM_PRT, int32_t, const double *, double *); + extern void ommp_potential_pol2ext(OMMP_SYSTEM_PRT, int32_t, const double *, double *); + extern void ommp_field_mmpol2ext(OMMP_SYSTEM_PRT, int32_t, const double *, double *); + extern void ommp_field_mm2ext(OMMP_SYSTEM_PRT, int32_t, const double *, double *); + extern void ommp_field_pol2ext(OMMP_SYSTEM_PRT, int32_t, const double *, double *); + + extern double ommp_get_vdw_energy(OMMP_SYSTEM_PRT); + extern double ommp_get_bond_energy(OMMP_SYSTEM_PRT); + extern double ommp_get_angle_energy(OMMP_SYSTEM_PRT); + extern double ommp_get_angtor_energy(OMMP_SYSTEM_PRT); + extern double ommp_get_strtor_energy(OMMP_SYSTEM_PRT); + extern double ommp_get_strbnd_energy(OMMP_SYSTEM_PRT); + extern double ommp_get_opb_energy(OMMP_SYSTEM_PRT); + extern double ommp_get_pitors_energy(OMMP_SYSTEM_PRT); + extern double ommp_get_torsion_energy(OMMP_SYSTEM_PRT); + extern double ommp_get_imptorsion_energy(OMMP_SYSTEM_PRT); + extern double ommp_get_tortor_energy(OMMP_SYSTEM_PRT); + extern double ommp_get_urey_energy(OMMP_SYSTEM_PRT); + extern double ommp_get_full_bnd_energy(OMMP_SYSTEM_PRT); + extern double ommp_get_full_ele_energy(OMMP_SYSTEM_PRT); + extern double ommp_get_full_energy(OMMP_SYSTEM_PRT); + + extern bool ommp_ff_is_amoeba(OMMP_SYSTEM_PRT); + + extern int32_t ommp_get_n_ipd(OMMP_SYSTEM_PRT); + extern int32_t ommp_get_ld_cart(OMMP_SYSTEM_PRT); + extern int32_t ommp_get_mm_atoms(OMMP_SYSTEM_PRT); + extern int32_t ommp_get_pol_atoms(OMMP_SYSTEM_PRT); + + extern double *ommp_get_cmm(OMMP_SYSTEM_PRT); + extern int32_t *ommp_get_zmm(OMMP_SYSTEM_PRT); + extern int32_t *ommp_get_attypemm(OMMP_SYSTEM_PRT); + extern double *ommp_get_cpol(OMMP_SYSTEM_PRT); + extern double *ommp_get_q(OMMP_SYSTEM_PRT); + extern double *ommp_get_ipd(OMMP_SYSTEM_PRT); + extern int32_t *ommp_get_polar_mm(OMMP_SYSTEM_PRT); + + extern bool ommp_use_frozen(OMMP_SYSTEM_PRT); + extern bool *ommp_get_frozen(OMMP_SYSTEM_PRT); + + extern bool ommp_use_linkatoms(OMMP_SYSTEM_PRT); + + extern void ommp_update_coordinates(OMMP_SYSTEM_PRT, const double *); + + extern void ommp_full_geomgrad(OMMP_SYSTEM_PRT, double *); + extern void ommp_full_bnd_geomgrad(OMMP_SYSTEM_PRT, double *); + extern void ommp_fixedelec_geomgrad(OMMP_SYSTEM_PRT, double *); + extern void ommp_polelec_geomgrad(OMMP_SYSTEM_PRT, double *); + extern void ommp_rotation_geomgrad(OMMP_SYSTEM_PRT, const double *, const double *, double *); + extern void ommp_vdw_geomgrad(OMMP_SYSTEM_PRT, double *); + extern void ommp_bond_geomgrad(OMMP_SYSTEM_PRT, double *); + extern void ommp_angle_geomgrad(OMMP_SYSTEM_PRT, double *); + extern void ommp_strbnd_geomgrad(OMMP_SYSTEM_PRT, double *); + extern void ommp_urey_geomgrad(OMMP_SYSTEM_PRT, double *); + extern void ommp_torsion_geomgrad(OMMP_SYSTEM_PRT, double *); + extern void ommp_imptorsion_geomgrad(OMMP_SYSTEM_PRT, double *); + extern void ommp_angtor_geomgrad(OMMP_SYSTEM_PRT, double *); + extern void ommp_opb_geomgrad(OMMP_SYSTEM_PRT, double *); + extern void ommp_strtor_geomgrad(OMMP_SYSTEM_PRT, double *); + extern void ommp_tortor_geomgrad(OMMP_SYSTEM_PRT, double *); + extern void ommp_pitors_geomgrad(OMMP_SYSTEM_PRT, double *); + + extern OMMP_QM_HELPER_PRT ommp_init_qm_helper(int32_t, const double *, const double *, const int32_t *); + extern void ommp_terminate_qm_helper(OMMP_QM_HELPER_PRT); + extern void ommp_qm_helper_set_frozen_atoms(OMMP_QM_HELPER_PRT, int32_t, const int32_t *); + extern void ommp_qm_helper_update_coord(OMMP_QM_HELPER_PRT, const double *); + + extern void ommp_prepare_qm_ele_ene(OMMP_SYSTEM_PRT, OMMP_QM_HELPER_PRT); + extern void ommp_prepare_qm_ele_grd(OMMP_SYSTEM_PRT, OMMP_QM_HELPER_PRT); + extern double *ommp_qm_helper_get_V_m2n(OMMP_QM_HELPER_PRT); + extern double *ommp_qm_helper_get_V_p2n(OMMP_QM_HELPER_PRT); + extern double *ommp_qm_helper_get_E_m2n(OMMP_QM_HELPER_PRT); + extern double *ommp_qm_helper_get_E_p2n(OMMP_QM_HELPER_PRT); + extern double *ommp_qm_helper_get_E_n2p(OMMP_QM_HELPER_PRT); + extern double *ommp_qm_helper_get_G_n2p(OMMP_QM_HELPER_PRT); + extern double *ommp_qm_helper_get_E_n2m(OMMP_QM_HELPER_PRT); + extern double *ommp_qm_helper_get_G_n2m(OMMP_QM_HELPER_PRT); + extern double *ommp_qm_helper_get_H_n2m(OMMP_QM_HELPER_PRT); + extern double *ommp_qm_helper_get_cqm(OMMP_QM_HELPER_PRT); + extern int32_t ommp_qm_helper_get_npol(OMMP_QM_HELPER_PRT); + extern int32_t ommp_qm_helper_get_nmm(OMMP_QM_HELPER_PRT); + extern int32_t ommp_qm_helper_get_qm_atoms(OMMP_QM_HELPER_PRT); + extern bool *ommp_qm_helper_get_frozen(OMMP_QM_HELPER_PRT); + extern bool ommp_qm_helper_use_frozen(OMMP_QM_HELPER_PRT); + extern void ommp_qm_helper_init_vdw_prm(OMMP_QM_HELPER_PRT, const char *); + extern void ommp_qm_helper_set_attype(OMMP_QM_HELPER_PRT, const int32_t *); + extern void ommp_qm_helper_init_vdw(OMMP_QM_HELPER_PRT, const double *, const double *, + const double *, const char *, const char *, + const char *, const char *, const char *); + extern double ommp_qm_helper_vdw_energy(OMMP_QM_HELPER_PRT, OMMP_SYSTEM_PRT); + extern void ommp_qm_helper_vdw_geomgrad(OMMP_QM_HELPER_PRT, OMMP_SYSTEM_PRT, + double *, double *); + extern void ommp_qm_helper_link_atom_geomgrad(OMMP_QM_HELPER_PRT, OMMP_SYSTEM_PRT, + double *, double *, const double *); + extern bool ommp_qm_helper_use_nonbonded(OMMP_QM_HELPER_PRT); + + extern void ommp_qm_helper_init_link_atom(OMMP_QM_HELPER_PRT, OMMP_SYSTEM_PRT); + extern int32_t ommp_create_link_atom(OMMP_QM_HELPER_PRT, OMMP_SYSTEM_PRT, + int32_t, int32_t, int32_t, const char *, + double, int32_t); + extern void ommp_get_link_atom_coordinates(OMMP_SYSTEM_PRT, int32_t, double *); + extern void ommp_update_link_atoms_position(OMMP_QM_HELPER_PRT, OMMP_SYSTEM_PRT); + + extern void ommp_smartinput(const char *, OMMP_SYSTEM_PRT *, OMMP_QM_HELPER_PRT *); + extern void ommp_smartinput_cpstr(const char *, char *, char **); + extern OMMP_SYSTEM_PRT ommp_system_from_qm_helper(OMMP_QM_HELPER_PRT, const char *); + extern void ommp_set_vdw_cutoff(OMMP_SYSTEM_PRT, double); #ifdef __cplusplus } #endif diff --git a/pyproject.toml b/pyproject.toml deleted file mode 100644 index 00a0184..0000000 --- a/pyproject.toml +++ /dev/null @@ -1,27 +0,0 @@ -[project] -name = "pyopenmmpol" -dynamic = ["version"] -authors = [ - {name = "Mattia Bondanza", email = "mattia.bondanza@unipi.it"}, - {name = "Filippo Lipparini", email = "filippo.lipparini@unipi.it"}, - {name = "Benedetta Mennucci", email = "benedetta.mennucci@unipi.it"}, -] -description = "Python interface of OpenMMPol library" -requires-python = ">=3.7" -license = {text = "LGPL v3"} -classifiers = [ - "Programming Language :: Python :: 3", -] -dependencies = [ - "numpy >= 1.17" -] -[project.urls] -"Homepage" = "https://github.com/Molecolab-Pisa/OpenMMPol" -"Bug Tracker" = "https://github.com/Molecolab-Pisa/OpenMMPol/issues" - -[build-system] -requires = ["setuptools", - "setuptools-scm", - "cmake >= 3.17"] -build-backend = "setuptools.build_meta" - diff --git a/pythonapi/CMakeLists.txt b/pythonapi/CMakeLists.txt new file mode 100644 index 0000000..a07f147 --- /dev/null +++ b/pythonapi/CMakeLists.txt @@ -0,0 +1,12 @@ +find_package(pybind11 CONFIG REQUIRED) +add_subdirectory("pyopenmmpol") + +file(COPY ${CMAKE_CURRENT_SOURCE_DIR}/pyproject.toml DESTINATION ${CMAKE_CURRENT_BINARY_DIR}) +set(prefix ${CMAKE_BINARY_DIR}/${CMAKE_INSTALL_PREFIX}) +set(cmake-command " + execute_process( + COMMAND ${Python_EXECUTABLE} -m pip install . + WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}) +") + +install(CODE "${cmake-command}") \ No newline at end of file diff --git a/pythonapi/build/lib/pyopenmmpol/__init__.py b/pythonapi/build/lib/pyopenmmpol/__init__.py new file mode 100644 index 0000000..af72ee7 --- /dev/null +++ b/pythonapi/build/lib/pyopenmmpol/__init__.py @@ -0,0 +1,3 @@ +from .__pyopenmmpol import * + +del __pyopenmmpol diff --git a/pythonapi/pyopenmmpol.egg-info/PKG-INFO b/pythonapi/pyopenmmpol.egg-info/PKG-INFO new file mode 100644 index 0000000..d4514b6 --- /dev/null +++ b/pythonapi/pyopenmmpol.egg-info/PKG-INFO @@ -0,0 +1,11 @@ +Metadata-Version: 2.1 +Name: pyopenmmpol +Version: 0.0.0 +Summary: Python interface of OpenMMPol library +Author-email: Mattia Bondanza , Filippo Lipparini , Benedetta Mennucci +License: LGPL v3 +Project-URL: Bug Tracker, https://github.com/Molecolab-Pisa/OpenMMPol/issues +Project-URL: Homepage, https://github.com/Molecolab-Pisa/OpenMMPol +Classifier: Programming Language :: Python :: 3 +Requires-Python: >=3.7 +Requires-Dist: numpy>=1.17 diff --git a/pythonapi/pyopenmmpol.egg-info/SOURCES.txt b/pythonapi/pyopenmmpol.egg-info/SOURCES.txt new file mode 100644 index 0000000..df87191 --- /dev/null +++ b/pythonapi/pyopenmmpol.egg-info/SOURCES.txt @@ -0,0 +1,11 @@ +CMakeLists.txt +pyproject.toml +./pyopenmmpol/__init__.py +pyopenmmpol/CMakeLists.txt +pyopenmmpol/__init__.py +pyopenmmpol/pyommp_interface.cpp +pyopenmmpol.egg-info/PKG-INFO +pyopenmmpol.egg-info/SOURCES.txt +pyopenmmpol.egg-info/dependency_links.txt +pyopenmmpol.egg-info/requires.txt +pyopenmmpol.egg-info/top_level.txt \ No newline at end of file diff --git a/pythonapi/pyopenmmpol.egg-info/dependency_links.txt b/pythonapi/pyopenmmpol.egg-info/dependency_links.txt new file mode 100644 index 0000000..8b13789 --- /dev/null +++ b/pythonapi/pyopenmmpol.egg-info/dependency_links.txt @@ -0,0 +1 @@ + diff --git a/pythonapi/pyopenmmpol.egg-info/requires.txt b/pythonapi/pyopenmmpol.egg-info/requires.txt new file mode 100644 index 0000000..0348de3 --- /dev/null +++ b/pythonapi/pyopenmmpol.egg-info/requires.txt @@ -0,0 +1 @@ +numpy>=1.17 diff --git a/pythonapi/pyopenmmpol.egg-info/top_level.txt b/pythonapi/pyopenmmpol.egg-info/top_level.txt new file mode 100644 index 0000000..16ab75e --- /dev/null +++ b/pythonapi/pyopenmmpol.egg-info/top_level.txt @@ -0,0 +1 @@ +pyopenmmpol diff --git a/pythonapi/pyopenmmpol/CMakeLists.txt b/pythonapi/pyopenmmpol/CMakeLists.txt new file mode 100644 index 0000000..90efe81 --- /dev/null +++ b/pythonapi/pyopenmmpol/CMakeLists.txt @@ -0,0 +1,18 @@ +pybind11_add_module("py${PROJECT_NAME}" + MODULE + pyommp_interface.cpp + ) + +set_target_properties( + "py${PROJECT_NAME}" + PROPERTIES + POSITION_INDEPENDENT_CODE TRUE + OUTPUT_NAME "__py${PROJECT_NAME}" + VERSION "${PROJECT_VERSION}" + SOVERSION "${PROJECT_VERSION_MAJOR}" + ) + +target_link_libraries("py${PROJECT_NAME}" PUBLIC "${PROJECT_NAME}") + +file(COPY ${CMAKE_CURRENT_SOURCE_DIR}/__init__.py DESTINATION ${CMAKE_CURRENT_BINARY_DIR}) +configure_file(__version__.py.in ${CMAKE_CURRENT_BINARY_DIR}/__version__.py @ONLY) \ No newline at end of file diff --git a/pythonapi/pyopenmmpol/__init__.py b/pythonapi/pyopenmmpol/__init__.py new file mode 100644 index 0000000..ffdf6f0 --- /dev/null +++ b/pythonapi/pyopenmmpol/__init__.py @@ -0,0 +1,2 @@ +from .__pyopenmmpol import * +del __pyopenmmpol diff --git a/pythonapi/pyopenmmpol/__version__.py.in b/pythonapi/pyopenmmpol/__version__.py.in new file mode 100644 index 0000000..9513e8a --- /dev/null +++ b/pythonapi/pyopenmmpol/__version__.py.in @@ -0,0 +1 @@ +__version__ = "@OMMP_VERSION_INTERNAL@" \ No newline at end of file diff --git a/pythonapi/pyopenmmpol/pyommp_interface.cpp b/pythonapi/pyopenmmpol/pyommp_interface.cpp new file mode 100644 index 0000000..46c101b --- /dev/null +++ b/pythonapi/pyopenmmpol/pyommp_interface.cpp @@ -0,0 +1,1769 @@ +#include "openmmpol.h" +#include +#include +#include +#include + +namespace py = pybind11; + +std::map solvers{ + {"none", OMMP_SOLVER_NONE}, + {"default", OMMP_SOLVER_DEFAULT}, + {"conjugate gradient", OMMP_SOLVER_CG}, + {"cg", OMMP_SOLVER_CG}, + {"inversion", OMMP_SOLVER_INVERSION}, + {"diis", OMMP_SOLVER_DIIS}}; + +std::map matvs{ + {"none", OMMP_MATV_NONE}, + {"default", OMMP_MATV_DEFAULT}, + {"incore", OMMP_MATV_INCORE}, + {"direct", OMMP_MATV_DIRECT}}; + +std::map verbosity{ + {"none", OMMP_VERBOSE_NONE}, + {"low", OMMP_VERBOSE_LOW}, + {"high", OMMP_VERBOSE_HIGH}, + {"debug", OMMP_VERBOSE_DEBUG}}; + +typedef typename py::array_t py_ciarray; +typedef typename py::array_t py_cdarray; +typedef typename py::array_t py_cbarray; + +int getMaxValue(py_ciarray inputArray) +{ + if (inputArray.ndim() != 1) + { + throw py::value_error("maximum can only be computed on 1-dimensional array."); + } + if (inputArray.size() == 0) + { + throw py::value_error("input array is empty"); + } + + const int *ptr = inputArray.data(); + int size = inputArray.size(); + int maxVal = ptr[0]; + + for (int i = 1; i < size; i++) + { + if (ptr[i] > maxVal) + { + maxVal = ptr[i]; + } + } + + return maxVal; +} + +int getMinValue(py_ciarray inputArray) +{ + if (inputArray.ndim() != 1) + { + throw py::value_error("maximum can only be computed on 1-dimensional array."); + } + if (inputArray.size() == 0) + { + throw py::value_error("input array is empty"); + } + + const int *ptr = inputArray.data(); + int size = inputArray.size(); + int minVal = ptr[0]; + + for (int i = 1; i < size; i++) + { + if (ptr[i] < minVal) + { + minVal = ptr[i]; + } + } + + return minVal; +} + +double getMaxValue(py_cdarray inputArray) +{ + if (inputArray.ndim() != 1) + { + throw py::value_error("maximum can only be computed on 1-dimensional array."); + } + if (inputArray.size() == 0) + { + throw py::value_error("input array is empty"); + } + + const double *ptr = inputArray.data(); + int size = inputArray.size(); + double maxVal = ptr[0]; + + for (int i = 1; i < size; i++) + { + if (ptr[i] > maxVal) + { + maxVal = ptr[i]; + } + } + + return maxVal; +} + +double getMinValue(py_cdarray inputArray) +{ + if (inputArray.ndim() != 1) + { + throw py::value_error("maximum can only be computed on 1-dimensional array."); + } + if (inputArray.size() == 0) + { + throw py::value_error("input array is empty"); + } + + const double *ptr = inputArray.data(); + int size = inputArray.size(); + double minVal = ptr[0]; + + for (int i = 1; i < size; i++) + { + if (ptr[i] < minVal) + { + minVal = ptr[i]; + } + } + + return minVal; +} + +class OMMPSystem; + +class OMMPQmHelper +{ +public: + OMMPQmHelper(); + OMMPQmHelper(OMMP_QM_HELPER_PRT); + OMMPQmHelper(py_cdarray, py_cdarray, py_ciarray); + ~OMMPQmHelper(); + OMMP_QM_HELPER_PRT get_handler(void); + void set_frozen_atoms(py_ciarray frozen); + void update_coord(py_cdarray qmc); + void update_link_atoms_position(OMMPSystem &s); + void init_vdw_prm(std::string prmfile); + void set_attype(py_ciarray qm_attype); + void init_vdw(py_cdarray eps, py_cdarray rad, py_cdarray fac, + std::string vdw_type, std::string radius_rule, + std::string radius_size, std::string radius_type, + std::string eps_rule); + double vdw_energy(OMMPSystem &s); + std::map vdw_geomgrad(OMMPSystem &s); + std::map link_atom_geomgrad(OMMPSystem &s, py_cdarray old_qmg); + void prepare_qm_ele_ene(OMMPSystem &s); + void prepare_qm_ele_grd(OMMPSystem &s); + int32_t get_qm_atoms(void); + int32_t get_npol(void); + int32_t get_nmm(void); + py_cdarray get_cqm(void); + py_cdarray get_E_n2p(void); + py_cdarray get_G_n2p(void); + py_cdarray get_E_n2m(void); + py_cdarray get_G_n2m(void); + py_cdarray get_H_n2m(void); + py_cdarray get_V_m2n(void); + py_cdarray get_E_m2n(void); + py_cdarray get_V_p2n(void); + py_cdarray get_E_p2n(void); + bool get_use_nonbonded(void); + py_cbarray get_frozen(); + bool get_use_frozen(void); + +private: + OMMP_QM_HELPER_PRT handler; +}; + +class OMMPSystem +{ +public: + OMMPSystem() + { + handler = nullptr; + } + + OMMPSystem(OMMP_SYSTEM_PRT s) + { + handler = s; + } + + OMMPSystem(std::string mmp_filename) + { + handler = ommp_init_mmp(mmp_filename.c_str()); + } + + OMMPSystem(std::string xyz_filename, std::string prm_filename) + { + handler = ommp_init_xyz(xyz_filename.c_str(), prm_filename.c_str()); + } + + ~OMMPSystem() + { + if (is_init()) + ommp_terminate(handler); + handler = nullptr; + return; + } + + bool is_init() + { + return handler != nullptr; + } + + void print_summary(std::string outfile = "") + { + if (outfile.empty()) + ommp_print_summary(handler); + else + ommp_print_summary_to_file(handler, + outfile.c_str()); + return; + } + + void save_mmp(std::string outfile, int version = 3) + { + ommp_save_mmp(handler, outfile.c_str(), version); + return; + } + + void set_frozen_atoms(py_ciarray frozen) + { + if (frozen.ndim() != 1) + { + throw py::value_error("frozen should be shaped [:]"); + } + if (getMinValue(frozen) < 1) + { + throw py::value_error("Atom index are 1-based, so they should all be grater than 0"); + } + + ommp_set_frozen_atoms(handler, frozen.shape(0), frozen.data()); + } + + void turn_pol_off(py_ciarray nopol) + { + if (nopol.ndim() != 1) + { + throw py::value_error("nopol should be shaped [:]"); + } + if (getMinValue(nopol) < 1) + { + throw py::value_error("Atom index are 1-based, so they should all be grater than 0"); + } + + ommp_turn_pol_off(handler, nopol.shape(0), nopol.data()); + } + + int get_n_ipd() + { + return ommp_get_n_ipd(handler); + } + + int get_pol_atoms() + { + return ommp_get_pol_atoms(handler); + } + + int get_mm_atoms() + { + return ommp_get_mm_atoms(handler); + } + + int get_ld_cart() + { + return ommp_get_ld_cart(handler); + } + + bool is_amoeba() + { + return ommp_ff_is_amoeba(handler); + } + + bool use_frozen() + { + return ommp_use_frozen(handler); + } + + bool use_linkatoms() + { + return ommp_use_linkatoms(handler); + } + + py_cdarray get_ipd() + { + double *mem = ommp_get_ipd(handler); + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 3, + {get_n_ipd(), get_pol_atoms(), 3}, + {get_pol_atoms() * 3 * sizeof(double), 3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray get_cmm() + { + double *mem = ommp_get_cmm(handler); + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_ciarray get_zmm() + { + int32_t *mem = ommp_get_zmm(handler); + py::buffer_info bufinfo(mem, sizeof(int32_t), + py::format_descriptor::format(), + 1, + {get_mm_atoms()}, + {sizeof(int32_t)}); + return py_ciarray(bufinfo); + } + + py_cdarray get_cpol() + { + double *mem = ommp_get_cpol(handler); + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_pol_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray get_q() + { + double *mem = ommp_get_q(handler); + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), get_ld_cart()}, + {get_ld_cart() * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray get_static_charges() + { + double *mem = ommp_get_q(handler); + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 1, + {get_mm_atoms()}, + {get_ld_cart() * sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray get_static_dipoles() + { + if (!is_amoeba()) + return py::none(); + + double *mem = ommp_get_q(handler); + py::buffer_info bufinfo(&(mem[1]), sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {get_ld_cart() * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray get_static_quadrupoles() + { + if (!is_amoeba()) + return py::none(); + + double *mem = ommp_get_q(handler); + py::buffer_info bufinfo(&(mem[4]), sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 6}, + {get_ld_cart() * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_ciarray get_polar_mm() + { + int32_t *mem = ommp_get_polar_mm(handler); + py::buffer_info bufinfo(mem, sizeof(int), + py::format_descriptor::format(), + 1, + {get_pol_atoms()}, + {sizeof(int)}); + return py_cdarray(bufinfo); + } + + py_cbarray get_frozen() + { + bool *mem = ommp_get_frozen(handler); + py::buffer_info bufinfo(mem, sizeof(bool), + py::format_descriptor::format(), + 1, + {get_mm_atoms()}, + {sizeof(bool)}); + return py_cbarray(bufinfo); + } + + py_cdarray potential_pol2ext(py_cdarray cext) + { + if (cext.ndim() != 2 || + cext.shape(1) != 3) + { + throw py::value_error("cext should be shaped [:, 3]"); + } + double *mem = new double[cext.shape(0)]; + for (int i = 0; i < cext.shape(0); i++) + mem[i] = 0.0; + + ommp_potential_pol2ext(handler, cext.shape(0), cext.data(), mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 1, + {cext.shape(0)}, + {sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray potential_mm2ext(py_cdarray cext) + { + if (cext.ndim() != 2 || + cext.shape(1) != 3) + { + throw py::value_error("cext should be shaped [:, 3]"); + } + double *mem = new double[cext.shape(0)]; + for (int i = 0; i < cext.shape(0); i++) + mem[i] = 0.0; + + ommp_potential_mm2ext(handler, cext.shape(0), cext.data(), mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 1, + {cext.shape(0)}, + {sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray potential_mmpol2ext(py_cdarray cext) + { + if (cext.ndim() != 2 || + cext.shape(1) != 3) + { + throw py::value_error("cext should be shaped [:, 3]"); + } + double *mem = new double[cext.shape(0)]; + for (int i = 0; i < cext.shape(0); i++) + mem[i] = 0.0; + + ommp_potential_mmpol2ext(handler, cext.shape(0), cext.data(), mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 1, + {cext.shape(0)}, + {sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray field_mmpol2ext(py_cdarray cext) + { + if (cext.ndim() != 2 || + cext.shape(1) != 3) + { + throw py::value_error("cext should be shaped [:, 3]"); + } + + int n = cext.shape(0); + double *mem = new double[n * 3]; + for (int i = 0; i < n * 3; i++) + mem[i] = 0.0; + + ommp_field_mmpol2ext(handler, cext.shape(0), cext.data(), mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {n, 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray field_mm2ext(py_cdarray cext) + { + if (cext.ndim() != 2 || + cext.shape(1) != 3) + { + throw py::value_error("cext should be shaped [:, 3]"); + } + + int n = cext.shape(0); + double *mem = new double[n * 3]; + for (int i = 0; i < n * 3; i++) + mem[i] = 0.0; + + ommp_field_mm2ext(handler, cext.shape(0), cext.data(), mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {n, 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray field_pol2ext(py_cdarray cext) + { + if (cext.ndim() != 2 || + cext.shape(1) != 3) + { + throw py::value_error("cext should be shaped [:, 3]"); + } + + int n = cext.shape(0); + double *mem = new double[n * 3]; + for (int i = 0; i < n * 3; i++) + mem[i] = 0.0; + + ommp_field_pol2ext(handler, cext.shape(0), cext.data(), mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {n, 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + void set_external_field(py_cdarray ext_field, + bool nomm = false, + std::string solver = "none", + std::string matv = "none") + { + if (ext_field.ndim() != 2 || + ext_field.shape(0) != get_pol_atoms() || + ext_field.shape(1) != 3) + { + throw py::value_error("ext_field should be shaped [pol_atoms, 3]"); + } + + if (solvers.find(solver) == solvers.end()) + { + throw py::value_error("Selected solver is not available!"); + } + + if (matvs.find(matv) == matvs.end()) + { + throw py::value_error("Selected matrix-vector method is not available!"); + } + + if (!nomm) + ommp_set_external_field(handler, ext_field.data(), solvers[solver], matvs[matv]); + else + ommp_set_external_field_nomm(handler, ext_field.data(), solvers[solver], matvs[matv]); + return; + } + + void update_coordinates(py_cdarray c) + { + if (c.ndim() != 2 || + c.shape(0) != get_mm_atoms() || + c.shape(1) != 3) + { + throw py::value_error("ext_field should be shaped [mm_atoms, 3]"); + } + + ommp_update_coordinates(handler, c.data()); + return; + } + + void numerical_grad(double (OMMPSystem::*ene_f)(void), double *g, double dd = 1e-5) + { + double *new_c = new double[get_mm_atoms() * 3]; + double *_cmm = ommp_get_cmm(handler); + bool *frozen; + double tmp; + + if (use_frozen()) + frozen = ommp_get_frozen(handler); + + for (int i = 0; i < get_mm_atoms() * 3; i++) + new_c[i] = _cmm[i]; + + for (int i = 0; i < get_mm_atoms() * 3; i++) + { + if (!(use_frozen() && frozen[i / 3])) + { + new_c[i] += dd; + ommp_update_coordinates(handler, new_c); + tmp = (this->*ene_f)(); + + new_c[i] -= 2 * dd; + ommp_update_coordinates(handler, new_c); + g[i] += (tmp - (this->*ene_f)()) / (2 * dd); + + new_c[i] += dd; + ommp_update_coordinates(handler, new_c); + } + } + } + + py_cdarray full_geomgrad(bool numerical = false) + { + double *mem = new double[get_mm_atoms() * 3]; + + if (!numerical) + ommp_full_geomgrad(handler, mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray rotation_geomgrad(py_cdarray E, py_cdarray Egrd) + { + double *mem = new double[get_mm_atoms() * 3]; + for (int i = 0; i < get_mm_atoms() * 3; i++) + mem[i] = 0.0; + + ommp_rotation_geomgrad(handler, E.data(), Egrd.data(), mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray fixedelec_geomgrad(bool numerical = false) + { + double *mem = new double[get_mm_atoms() * 3]; + for (int i = 0; i < get_mm_atoms() * 3; i++) + mem[i] = 0.0; + + if (numerical) + numerical_grad(&OMMPSystem::get_fixedelec_energy, mem); + else + ommp_fixedelec_geomgrad(handler, mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray polelec_geomgrad(bool numerical = false) + { + double *mem = new double[get_mm_atoms() * 3]; + for (int i = 0; i < get_mm_atoms() * 3; i++) + mem[i] = 0.0; + + if (numerical) + numerical_grad(&OMMPSystem::get_polelec_energy, mem); + else + ommp_polelec_geomgrad(handler, mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray vdw_geomgrad(bool numerical = false) + { + double *mem = new double[get_mm_atoms() * 3]; + for (int i = 0; i < get_mm_atoms() * 3; i++) + mem[i] = 0.0; + + if (numerical) + numerical_grad(&OMMPSystem::get_vdw_energy, mem); + else + ommp_vdw_geomgrad(handler, mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray bond_geomgrad(bool numerical = false) + { + double *mem = new double[get_mm_atoms() * 3]; + for (int i = 0; i < get_mm_atoms() * 3; i++) + mem[i] = 0.0; + + if (numerical) + numerical_grad(&OMMPSystem::get_bond_energy, mem); + else + ommp_bond_geomgrad(handler, mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray angle_geomgrad(bool numerical = false) + { + double *mem = new double[get_mm_atoms() * 3]; + for (int i = 0; i < get_mm_atoms() * 3; i++) + mem[i] = 0.0; + + if (numerical) + numerical_grad(&OMMPSystem::get_angle_energy, mem); + else + ommp_angle_geomgrad(handler, mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray strbnd_geomgrad(bool numerical = false) + { + double *mem = new double[get_mm_atoms() * 3]; + for (int i = 0; i < get_mm_atoms() * 3; i++) + mem[i] = 0.0; + + if (numerical) + numerical_grad(&OMMPSystem::get_strbnd_energy, mem); + else + ommp_strbnd_geomgrad(handler, mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray urey_geomgrad(bool numerical = false) + { + double *mem = new double[get_mm_atoms() * 3]; + for (int i = 0; i < get_mm_atoms() * 3; i++) + mem[i] = 0.0; + + if (numerical) + numerical_grad(&OMMPSystem::get_urey_energy, mem); + else + ommp_urey_geomgrad(handler, mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray torsion_geomgrad(bool numerical = false) + { + double *mem = new double[get_mm_atoms() * 3]; + for (int i = 0; i < get_mm_atoms() * 3; i++) + mem[i] = 0.0; + + if (numerical) + numerical_grad(&OMMPSystem::get_torsion_energy, mem); + else + ommp_torsion_geomgrad(handler, mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray imptorsion_geomgrad(bool numerical = false) + { + double *mem = new double[get_mm_atoms() * 3]; + for (int i = 0; i < get_mm_atoms() * 3; i++) + mem[i] = 0.0; + + if (numerical) + numerical_grad(&OMMPSystem::get_imptorsion_energy, mem); + else + ommp_imptorsion_geomgrad(handler, mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray angtor_geomgrad(bool numerical = false) + { + double *mem = new double[get_mm_atoms() * 3]; + for (int i = 0; i < get_mm_atoms() * 3; i++) + mem[i] = 0.0; + + if (numerical) + numerical_grad(&OMMPSystem::get_angtor_energy, mem); + else + ommp_angtor_geomgrad(handler, mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray opb_geomgrad(bool numerical = false) + { + double *mem = new double[get_mm_atoms() * 3]; + for (int i = 0; i < get_mm_atoms() * 3; i++) + mem[i] = 0.0; + + if (numerical) + numerical_grad(&OMMPSystem::get_opb_energy, mem); + else + ommp_opb_geomgrad(handler, mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray strtor_geomgrad(bool numerical = false) + { + double *mem = new double[get_mm_atoms() * 3]; + for (int i = 0; i < get_mm_atoms() * 3; i++) + mem[i] = 0.0; + + if (numerical) + numerical_grad(&OMMPSystem::get_strtor_energy, mem); + else + ommp_strtor_geomgrad(handler, mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray tortor_geomgrad(bool numerical = false) + { + double *mem = new double[get_mm_atoms() * 3]; + for (int i = 0; i < get_mm_atoms() * 3; i++) + mem[i] = 0.0; + + if (numerical) + numerical_grad(&OMMPSystem::get_tortor_energy, mem); + else + ommp_tortor_geomgrad(handler, mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray pitors_geomgrad(bool numerical = false) + { + double *mem = new double[get_mm_atoms() * 3]; + for (int i = 0; i < get_mm_atoms() * 3; i++) + mem[i] = 0.0; + + if (numerical) + numerical_grad(&OMMPSystem::get_pitors_energy, mem); + else + ommp_pitors_geomgrad(handler, mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + py_cdarray full_bnd_geomgrad(bool numerical = false) + { + double *mem = new double[get_mm_atoms() * 3]; + for (int i = 0; i < get_mm_atoms() * 3; i++) + mem[i] = 0.0; + + if (numerical) + numerical_grad(&OMMPSystem::get_full_bnd_energy, mem); + else + ommp_full_bnd_geomgrad(handler, mem); + + py::buffer_info bufinfo(mem, sizeof(double), + py::format_descriptor::format(), + 2, + {get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } + + double get_bond_energy(void) + { + return ommp_get_bond_energy(handler); + } + + double get_angle_energy(void) + { + return ommp_get_angle_energy(handler); + } + + double get_angtor_energy(void) + { + return ommp_get_angtor_energy(handler); + } + + double get_strtor_energy(void) + { + return ommp_get_strtor_energy(handler); + } + + double get_strbnd_energy(void) + { + return ommp_get_strbnd_energy(handler); + } + + double get_opb_energy(void) + { + return ommp_get_opb_energy(handler); + } + + double get_pitors_energy(void) + { + return ommp_get_pitors_energy(handler); + } + + double get_imptorsion_energy(void) + { + return ommp_get_imptorsion_energy(handler); + } + + double get_torsion_energy(void) + { + return ommp_get_torsion_energy(handler); + } + + double get_tortor_energy(void) + { + return ommp_get_tortor_energy(handler); + } + + double get_urey_energy(void) + { + return ommp_get_urey_energy(handler); + } + + double get_polelec_energy(void) + { + return ommp_get_polelec_energy(handler); + } + + double get_fixedelec_energy(void) + { + return ommp_get_fixedelec_energy(handler); + } + + double get_vdw_energy(void) + { + return ommp_get_vdw_energy(handler); + } + + double get_full_ele_energy(void) + { + return ommp_get_full_ele_energy(handler); + } + + double get_full_bnd_energy(void) + { + return ommp_get_full_bnd_energy(handler); + } + + double get_full_energy(void) + { + return ommp_get_full_energy(handler); + } + OMMP_SYSTEM_PRT get_handler(void) + { + return handler; + } + + int32_t create_link_atom(OMMPQmHelper &qm, int imm, int iqm, int ila, + std::string prmfile, + double la_dist = OMMP_DEFAULT_LA_DIST, + int neel_remove = OMMP_DEFAULT_LA_N_EEL_REMOVE) + { + if (imm < 1 || iqm < 1 || ila < 1) + throw py::value_error("Atom index are 1-based, so they should all be grater than 0"); + int nmm = get_mm_atoms(), nqm = qm.get_qm_atoms(); + + if (iqm > nqm || ila > nqm || imm > nmm) + throw py::value_error("Atom index should be inside the topology"); + + return ommp_create_link_atom(qm.get_handler(), handler, imm, iqm, ila, + prmfile.c_str(), la_dist, neel_remove); + } + + py_cdarray get_link_atom_coordinates(int la_idx) + { + double *c = new double[3]; + ommp_get_link_atom_coordinates(handler, la_idx, c); + + py::buffer_info bufinfo(c, sizeof(double), + py::format_descriptor::format(), + 1, + {3}, + {sizeof(double)}); + return py_cdarray(bufinfo); + } + +private: + OMMP_SYSTEM_PRT handler; +}; + +OMMPQmHelper::OMMPQmHelper() +{ + handler = nullptr; +} + +OMMPQmHelper::OMMPQmHelper(OMMP_QM_HELPER_PRT qm) +{ + handler = qm; +} + +OMMPQmHelper::OMMPQmHelper(py_cdarray coord_qm, py_cdarray charge_qm, py_ciarray z_qm) +{ + if (coord_qm.ndim() != 2 || + coord_qm.shape(1) != 3) + { + throw py::value_error("coord_qm should be shaped [:, 3]"); + } + if (charge_qm.ndim() != 1 || + charge_qm.shape(0) != coord_qm.shape(0)) + { + throw py::value_error("charge_qm should be shaped [coord_qm.shape[0]]"); + } + + if (z_qm.ndim() != 1 || + z_qm.shape(0) != z_qm.shape(0)) + { + throw py::value_error("z_qm should be shaped [coord_qm.shape[0]]"); + } + + handler = ommp_init_qm_helper(coord_qm.shape(0), coord_qm.data(), charge_qm.data(), z_qm.data()); +} + +OMMPQmHelper::~OMMPQmHelper() +{ + ommp_terminate_qm_helper(handler); + handler = nullptr; + return; +} + +OMMP_QM_HELPER_PRT OMMPQmHelper::get_handler(void) +{ + return handler; +} + +void OMMPQmHelper::set_frozen_atoms(py_ciarray frozen) +{ + if (frozen.ndim() != 1) + { + throw py::value_error("frozen should be shaped [:]"); + } + if (getMinValue(frozen) < 1) + { + throw py::value_error("Atom index are 1-based, so they should all be grater than 0"); + } + + ommp_qm_helper_set_frozen_atoms(handler, frozen.shape(0), frozen.data()); +} + +void OMMPQmHelper::update_coord(py_cdarray qmc) +{ + if (qmc.ndim() != 2 || + qmc.shape(0) != get_qm_atoms() || qmc.shape(1) != 3) + { + throw py::value_error("QM coordinates should be shaped [n_qm_atoms,3]"); + } + ommp_qm_helper_update_coord(handler, qmc.data()); +} + +void OMMPQmHelper::update_link_atoms_position(OMMPSystem &s) +{ + OMMP_SYSTEM_PRT s_handler = s.get_handler(); + ommp_update_link_atoms_position(handler, s_handler); +} + +void OMMPQmHelper::set_attype(py_ciarray qm_attype) +{ + + if (qm_attype.ndim() != 1 || + qm_attype.shape(0) != get_qm_atoms()) + { + throw py::value_error("QM attype should be shaped [n_qm_atoms]"); + } + + ommp_qm_helper_set_attype(handler, qm_attype.data()); +} + +void OMMPQmHelper::init_vdw_prm(std::string prmfile) +{ + ommp_qm_helper_init_vdw_prm(handler, prmfile.c_str()); +} + +void OMMPQmHelper::init_vdw(py_cdarray eps, py_cdarray rad, py_cdarray fac, + std::string vdw_type, std::string radius_rule, + std::string radius_size, std::string radius_type, + std::string eps_rule) +{ + + if (eps.ndim() != 1 || + eps.shape(0) != get_qm_atoms()) + { + throw py::value_error("eps should be shaped [n_qm_atoms]"); + } + if (rad.ndim() != 1 || + eps.shape(0) != get_qm_atoms()) + { + throw py::value_error("eps should be shaped [n_qm_atoms]"); + } + if (fac.ndim() != 1 || + eps.shape(0) != get_qm_atoms()) + { + throw py::value_error("eps should be shaped [n_qm_atoms]"); + } + + ommp_qm_helper_init_vdw(handler, eps.data(), rad.data(), fac.data(), + vdw_type.c_str(), radius_rule.c_str(), radius_size.c_str(), + radius_type.c_str(), eps_rule.c_str()); +} + +double OMMPQmHelper::vdw_energy(OMMPSystem &s) +{ + OMMP_SYSTEM_PRT s_handler = s.get_handler(); + return ommp_qm_helper_vdw_energy(handler, s_handler); +} + +std::map OMMPQmHelper::vdw_geomgrad(OMMPSystem &s) +{ + OMMP_SYSTEM_PRT s_handler = s.get_handler(); + + double *mmg = new double[s.get_mm_atoms() * 3]; + double *qmg = new double[get_qm_atoms() * 3]; + ommp_qm_helper_vdw_geomgrad(handler, s_handler, qmg, mmg); + + py::buffer_info bufinfo_mm(mmg, sizeof(double), + py::format_descriptor::format(), + 2, + {s.get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + py::buffer_info bufinfo_qm(qmg, sizeof(double), + py::format_descriptor::format(), + 2, + {get_qm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + std::map res{ + {"MM", py_cdarray(bufinfo_mm)}, + {"QM", py_cdarray(bufinfo_qm)}}; + + return res; +} + +std::map OMMPQmHelper::link_atom_geomgrad(OMMPSystem &s, py_cdarray old_qmg) +{ + OMMP_SYSTEM_PRT s_handler = s.get_handler(); + + double *mmg = new double[s.get_mm_atoms() * 3]; + double *qmg = new double[get_qm_atoms() * 3]; + ommp_qm_helper_link_atom_geomgrad(handler, s_handler, qmg, mmg, old_qmg.data()); + py::buffer_info bufinfo_mm(mmg, sizeof(double), + py::format_descriptor::format(), + 2, + {s.get_mm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + py::buffer_info bufinfo_qm(qmg, sizeof(double), + py::format_descriptor::format(), + 2, + {get_qm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + std::map res{ + {"MM", py_cdarray(bufinfo_mm)}, + {"QM", py_cdarray(bufinfo_qm)}}; + + return res; +} + +void OMMPQmHelper::prepare_qm_ele_ene(OMMPSystem &s) +{ + OMMP_SYSTEM_PRT s_handler = s.get_handler(); + ommp_prepare_qm_ele_ene(s_handler, handler); +} + +void OMMPQmHelper::prepare_qm_ele_grd(OMMPSystem &s) +{ + OMMP_SYSTEM_PRT s_handler = s.get_handler(); + ommp_prepare_qm_ele_grd(s_handler, handler); +} + +int32_t OMMPQmHelper::get_qm_atoms(void) +{ + return ommp_qm_helper_get_qm_atoms(handler); +} + +int32_t OMMPQmHelper::get_npol(void) +{ + return ommp_qm_helper_get_npol(handler); +} + +int32_t OMMPQmHelper::get_nmm(void) +{ + return ommp_qm_helper_get_nmm(handler); +} + +py_cdarray OMMPQmHelper::get_cqm(void) +{ + double *memory = ommp_qm_helper_get_cqm(handler); + if (!memory) + { + throw py::attribute_error("cqm cannot be accessed for a memory error"); + } + else + { + py::buffer_info bufinfo(memory, sizeof(double), + py::format_descriptor::format(), + 2, + {get_qm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } +} + +py_cdarray OMMPQmHelper::get_E_n2p(void) +{ + double *memory = ommp_qm_helper_get_E_n2p(handler); + if (!memory) + { + throw py::attribute_error("E_n2p is not available. OMMPQmHelper.prepare_energy() should be called before!"); + } + else + { + py::buffer_info bufinfo(memory, sizeof(double), + py::format_descriptor::format(), + 2, + {get_npol(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } +} + +py_cdarray OMMPQmHelper::get_G_n2p(void) +{ + double *memory = ommp_qm_helper_get_G_n2p(handler); + if (!memory) + { + throw py::attribute_error("G_n2p is not available. OMMPQmHelper.prepare_geomgrad() should be called before!"); + } + else + { + py::buffer_info bufinfo(memory, sizeof(double), + py::format_descriptor::format(), + 2, + {get_npol(), 6}, + {6 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } +} + +py_cdarray OMMPQmHelper::get_E_n2m(void) +{ + double *memory = ommp_qm_helper_get_E_n2m(handler); + if (!memory) + { + throw py::attribute_error("E_n2m is not available. OMMPQmHelper.prepare_geomgrad() should be called before!"); + } + else + { + py::buffer_info bufinfo(memory, sizeof(double), + py::format_descriptor::format(), + 2, + {get_nmm(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } +} + +py_cdarray OMMPQmHelper::get_G_n2m(void) +{ + double *memory = ommp_qm_helper_get_G_n2m(handler); + if (!memory) + { + throw py::attribute_error("G_n2m is not available. OMMPQmHelper.prepare_geomgrad() should be called before!"); + } + else + { + py::buffer_info bufinfo(memory, sizeof(double), + py::format_descriptor::format(), + 2, + {get_nmm(), 6}, + {6 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } +} + +py_cdarray OMMPQmHelper::get_H_n2m(void) +{ + double *memory = ommp_qm_helper_get_H_n2m(handler); + if (!memory) + { + throw py::attribute_error("H_n2m is not available. OMMPQmHelper.prepare_geomgrad() should be called before!"); + } + else + { + py::buffer_info bufinfo(memory, sizeof(double), + py::format_descriptor::format(), + 2, + {get_nmm(), 10}, + {10 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } +} + +py_cdarray OMMPQmHelper::get_V_m2n(void) +{ + double *memory = ommp_qm_helper_get_V_m2n(handler); + if (!memory) + { + throw py::attribute_error("V_m2n is not available. OMMPQmHelper.prepare_energy() should be called before!"); + } + else + { + py::buffer_info bufinfo(memory, sizeof(double), + py::format_descriptor::format(), + 1, + {get_qm_atoms()}, + {sizeof(double)}); + return py_cdarray(bufinfo); + } +} + +py_cdarray OMMPQmHelper::get_E_m2n(void) +{ + double *memory = ommp_qm_helper_get_E_m2n(handler); + if (!memory) + { + throw py::attribute_error("E_m2n is not available. OMMPQmHelper.prepare_geomgrad() should be called before!"); + } + else + { + py::buffer_info bufinfo(memory, sizeof(double), + py::format_descriptor::format(), + 2, + {get_qm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } +} + +py_cdarray OMMPQmHelper::get_V_p2n(void) +{ + double *memory = ommp_qm_helper_get_V_p2n(handler); + if (!memory) + { + throw py::attribute_error("V_p2n is not available. OMMPQmHelper.prepare_energy() should be called before!"); + } + else + { + py::buffer_info bufinfo(memory, sizeof(double), + py::format_descriptor::format(), + 1, + {get_qm_atoms()}, + {sizeof(double)}); + return py_cdarray(bufinfo); + } +} + +py_cdarray OMMPQmHelper::get_E_p2n(void) +{ + double *memory = ommp_qm_helper_get_E_p2n(handler); + if (!memory) + { + throw py::attribute_error("E_p2n is not available. OMMPQmHelper.prepare_geomgrad() should be called before!"); + } + else + { + py::buffer_info bufinfo(memory, sizeof(double), + py::format_descriptor::format(), + 2, + {get_qm_atoms(), 3}, + {3 * sizeof(double), sizeof(double)}); + return py_cdarray(bufinfo); + } +} + +bool OMMPQmHelper::get_use_nonbonded(void) +{ + return ommp_qm_helper_use_nonbonded(handler); +} + +py_cbarray OMMPQmHelper::get_frozen() +{ + bool *mem = ommp_qm_helper_get_frozen(handler); + py::buffer_info bufinfo(mem, sizeof(bool), + py::format_descriptor::format(), + 1, + {get_qm_atoms()}, + {sizeof(bool)}); + return py_cbarray(bufinfo); +} + +bool OMMPQmHelper::get_use_frozen(void) +{ + return ommp_qm_helper_use_frozen(handler); +} + +void set_verbose(int32_t v) +{ + ommp_set_verbose(v); +} + +void time_push(void) +{ + ommp_time_push(); +} + +void time_pull(std::string s) +{ + ommp_time_pull(s.c_str()); +} + +void set_outputfile(std::string of) +{ + ommp_set_outputfile(of.c_str()); +} + +void close_outputfile(void) +{ + ommp_close_outputfile(); +} + +void message(std::string m, int32_t l, std::string p) +{ + ommp_message(m.c_str(), l, p.c_str()); +} + +void fatal(std::string m) +{ + ommp_fatal(m.c_str()); +} + +py::list smartinput(std::string json_file) +{ + OMMP_SYSTEM_PRT s; + OMMP_QM_HELPER_PRT q; + py::list res; + + ommp_smartinput(json_file.c_str(), &s, &q); + OMMPSystem *my_sys = new OMMPSystem(s); + res.append(my_sys); + + if (q != nullptr) + { + OMMPQmHelper *my_qmh = new OMMPQmHelper(q); + res.append(my_qmh); + } + else + { + res.append(py::none()); + } + return res; +} + +PYBIND11_MODULE(__pyopenmmpol, m) +{ + m.def("set_verbose", &set_verbose); + m.def("time_push", &time_push); + m.def("time_pull", &time_pull); + m.def("set_outputfile", &set_outputfile); + m.def("close_outputfile", &close_outputfile); + m.def("message", &message); + m.def("fatal", &fatal); + m.def("smartinput", &smartinput, py::return_value_policy::copy); + m.attr("available_solvers") = solvers; + m.attr("available_matrix_vector") = matvs; + m.attr("verbosity") = verbosity; + m.attr("__version__") = OMMP_VERSION_STRING; + py::class_>(m, "OMMPSystem", "System of OMMP library.") + .def(py::init(), + "pyOpenMMPol creator, takes the path to a .mmp file as input.", + py::arg("mmp_filename")) + .def(py::init(), + "pyOpenMMPol creator, takes the path to a Tinker .xyz and .prm files as input.", + py::arg("xyz_filename"), + py::arg("prm_filename")) + .def("set_frozen_atoms", + &OMMPSystem::set_frozen_atoms, + "Set the atoms of the system that should be frozen (1-based list) that is unable to move.", + py::arg("frozen_list")) + .def("turn_pol_off", + &OMMPSystem::turn_pol_off, + "Turn off polarizabilities of atoms in nopol list.", + py::arg("npol_list")) + .def("print_summary", + &OMMPSystem::print_summary, + "Output a summary of loaded quantites, if outfile is specified, it is printed on file.", + py::arg("outfile") = "") + .def("save_mmp", + &OMMPSystem::save_mmp, + "Save the data of OMMPSystem into a .mmp file (note that some informations are dropped in the process).", + py::arg("outfile"), + py::arg("version") = 3) + .def("potential_mm2ext", + &OMMPSystem::potential_mm2ext, + "Compute the electrostatic potential of the static part of the system to arbitrary coordinates.", + py::arg("coord")) + .def("potential_pol2ext", + &OMMPSystem::potential_pol2ext, + "Compute the electrostatic field of the polarizable part of the system to arbitrary coordinates.", + py::arg("cext")) + .def("potential_mmpol2ext", + &OMMPSystem::potential_mmpol2ext, + "Compute the electrostatic field of the polarizable and static part of the system to arbitrary coordinates.", + py::arg("cext")) + .def("field_mm2ext", + &OMMPSystem::field_mm2ext, + "Compute the electrostatic field of the static part of the system to arbitrary coordinates.", + py::arg("cext")) + .def("field_pol2ext", + &OMMPSystem::field_pol2ext, + "Compute the electrostatic field of the polarizable part of the system to arbitrary coordinates.", + py::arg("cext")) + .def("field_mmpol2ext", + &OMMPSystem::field_mmpol2ext, + "Compute the electrostatic field of the static and polarizable part of the system to arbitrary coordinates.", + py::arg("cext")) + + .def("set_external_field", + &OMMPSystem::set_external_field, + "Set the external electric field and solves the linear system.", + py::arg("external_field"), + py::arg("nomm") = false, + py::arg("solver") = "none", + py::arg("matv") = "none") + + .def("get_bond_energy", &OMMPSystem::get_bond_energy, "Compute the energy of bond stretching") + .def("get_angle_energy", &OMMPSystem::get_angle_energy, "Compute the energy of angle bending") + .def("get_torsion_energy", &OMMPSystem::get_torsion_energy, "Compute the energy of dihedral torsion") + .def("get_imptorsion_energy", &OMMPSystem::get_imptorsion_energy, "Compute the energy of improper torsion") + .def("get_opb_energy", &OMMPSystem::get_opb_energy, "Compute the energy of out-of-plane bending") + .def("get_urey_energy", &OMMPSystem::get_urey_energy, "Compute the energy of Urey-Bradley terms") + .def("get_pitors_energy", &OMMPSystem::get_pitors_energy, "Compute the energy of Pi-system torsion terms") + .def("get_strbnd_energy", &OMMPSystem::get_strbnd_energy, "Compute the energy of stretching-bending couplings") + .def("get_strtor_energy", &OMMPSystem::get_strtor_energy, "Compute the energy of stretching torsion couplings") + .def("get_angtor_energy", &OMMPSystem::get_angtor_energy, "Compute the energy of bending torsion couplings") + .def("get_tortor_energy", &OMMPSystem::get_tortor_energy, "Compute the energy of torsion-torsion cmap") + .def("get_full_bnd_energy", &OMMPSystem::get_full_bnd_energy, "Compute the sum of all bonded components") + .def("get_full_ele_energy", &OMMPSystem::get_full_ele_energy, "Compute the sum of all electrostatic components") + .def("get_full_energy", &OMMPSystem::get_full_energy, "Compute the sum of all energy components") + .def("get_vdw_energy", &OMMPSystem::get_vdw_energy, "Compute the energy of Van der Waals terms") + .def("get_fixedelec_energy", &OMMPSystem::get_fixedelec_energy, "Compute the energy of fixed electrostatics") + .def("get_polelec_energy", &OMMPSystem::get_polelec_energy, "Compute the energy of polarizable electrostatics") + + .def("update_coordinates", + &OMMPSystem::update_coordinates, + "Update system's coordinates.", + py::arg("coord")) + .def("full_geomgrad", + &OMMPSystem::full_geomgrad, + "Compute the geometrical gradients of all the active MM components of the energy.", + py::arg("numerical") = false) + .def("fixedelec_geomgrad", + &OMMPSystem::fixedelec_geomgrad, + "Compute the geometrical gradients of fixed electrostatic energy.", + py::arg("numerical") = false) + .def("polelec_geomgrad", + &OMMPSystem::polelec_geomgrad, + "Compute the geometrical gradients of polarizable electrostatic energy.", + py::arg("numerical") = false) + .def("rotation_geomgrad", + &OMMPSystem::rotation_geomgrad, + "Compute the geometrical gradients on MM atoms due to the rotation of multipoles in an external electric field.", + py::arg("electric_field"), py::arg("electric_field_gradients")) + .def("full_bnd_geomgrad", + &OMMPSystem::full_bnd_geomgrad, + "Compute the geometrical gradients of bonded energy.", + py::arg("numerical") = false) + .def("bond_geomgrad", + &OMMPSystem::bond_geomgrad, + "Compute the geometrical gradients of bond stretching energy.", + py::arg("numerical") = false) + .def("angle_geomgrad", + &OMMPSystem::angle_geomgrad, + "Compute the geometrical gradients of angle bending energy.", + py::arg("numerical") = false) + .def("angtor_geomgrad", + &OMMPSystem::angtor_geomgrad, + "Compute the geometrical gradients of bending-torsion coupling energy.", + py::arg("numerical") = false) + .def("strtor_geomgrad", + &OMMPSystem::strtor_geomgrad, + "Compute the geometrical gradients of stretching-torsion coupling energy.", + py::arg("numerical") = false) + .def("strbnd_geomgrad", + &OMMPSystem::strbnd_geomgrad, + "Compute the geometrical gradients of stretching-bending coupling energy.", + py::arg("numerical") = false) + .def("opb_geomgrad", + &OMMPSystem::opb_geomgrad, + "Compute the geometrical gradients of out-of-plane bending energy.", + py::arg("numerical") = false) + .def("pitors_geomgrad", + &OMMPSystem::pitors_geomgrad, + "Compute the geometrical gradients of pi-torsion energy.", + py::arg("numerical") = false) + .def("torsion_geomgrad", + &OMMPSystem::torsion_geomgrad, + "Compute the geometrical gradients of torsion energy.", + py::arg("numerical") = false) + .def("imptorsion_geomgrad", + &OMMPSystem::imptorsion_geomgrad, + "Compute the geometrical gradients of improper torsion energy.", + py::arg("numerical") = false) + .def("tortor_geomgrad", + &OMMPSystem::tortor_geomgrad, + "Compute the geometrical gradients of torsion-torsion coupling energy.", + py::arg("numerical") = false) + .def("urey_geomgrad", + &OMMPSystem::urey_geomgrad, + "Compute the geometrical gradients of Urey-Bradley energy.", + py::arg("numerical") = false) + .def("vdw_geomgrad", + &OMMPSystem::vdw_geomgrad, + "Compute the geometrical gradients of Van der Waal energy.", + py::arg("numerical") = false) + .def("create_link_atom", + &OMMPSystem::create_link_atom, + "Create a link atom between QM and MM system", + py::arg("OMMP_QM_Helper"), py::arg("i_mm"), py::arg("i_qm"), py::arg("i_la"), + py::arg("prmfile"), + py::arg("la_distance") = OMMP_DEFAULT_LA_DIST, + py::arg("n_eel_remove") = OMMP_DEFAULT_LA_N_EEL_REMOVE) + .def_property_readonly("is_init", &OMMPSystem::is_init, "Flag to check system initialization.") + .def_property_readonly("pol_atoms", &OMMPSystem::get_pol_atoms, "Number of polarizable atoms") + .def_property_readonly("mm_atoms", &OMMPSystem::get_mm_atoms, "Number of atoms") + .def_property_readonly("_ld_cart", &OMMPSystem::get_ld_cart, "Dimension of static site descriptor; 1 for Wang FF, 10 for Amoeba FF.") + .def_property_readonly("n_ipd", &OMMPSystem::get_n_ipd, "Number of induced dipoles sets; 1 for Wang FF, 2 for Amoeba FF.") + .def_property_readonly("is_amoeba", &OMMPSystem::is_amoeba, "Flag for Amoeba FF") + .def_property_readonly("ipd", &OMMPSystem::get_ipd, "Induced dipoles (read only)") + .def_property_readonly("cmm", &OMMPSystem::get_cmm, "Coordinates of atoms (read only) [mm_atoms, 3]") + .def_property_readonly("zmm", &OMMPSystem::get_zmm, "Atomic number of MM atoms (read only) [mm_atoms]") + .def_property_readonly("cpol", &OMMPSystem::get_cpol, "Coordinates of polarizable atoms (read only) [pol_atoms, 3]") + .def_property_readonly("_q", &OMMPSystem::get_q, "Full descriptor of static sites (read only) [mm_atoms, _ld_cart]") + .def_property_readonly("static_charges", &OMMPSystem::get_static_charges, "Static charges (read only) [mm_atoms]") + .def_property_readonly("static_dipoles", &OMMPSystem::get_static_dipoles, "Static dipoles (read only) if is_amoeba [mm_atoms, 3], else None") + .def_property_readonly("static_quadrupoles", &OMMPSystem::get_static_quadrupoles, "Static dipoles (read only) if is_amoeba [mm_atoms, 6], else None") + .def_property_readonly("polar_mm", &OMMPSystem::get_polar_mm, "Index of polarizable atoms in atom list [pol_atoms]") + .def_property_readonly("use_frozen", &OMMPSystem::use_frozen, "Flag to check if frozen atoms are used") + .def_property_readonly("frozen", &OMMPSystem::get_frozen, "Logical array, for each atom True means frozen False means mobile.") + .def_property_readonly("use_linkatoms", &OMMPSystem::use_linkatoms, "Flag to check if link atoms are used"); + + py::class_>(m, "OMMPQmHelper", "Object to handle information about the QM system and simplify the QM/MM interface.") + .def(py::init(), + "OMMPQmHelper creator, takes the coordinates and nuclear charges of QM system as input.", + py::arg("coord_qm"), py::arg("charge_qm"), py::arg("z_qm")) + .def("update_coord", + &OMMPQmHelper::update_coord, + "Update the coordinates of QM atoms", + py::arg("qm_atoms_coordinates")) + .def("set_attype", + &OMMPQmHelper::set_attype, + "Set atomtypes for QM atoms.", + py::arg("qm_attype")) + .def("init_vdw_prm", + &OMMPQmHelper::init_vdw_prm, + "Set the VdW parameters for the QM atoms using a prm forcefield and atomtypes of QM atoms.", + py::arg("prmfile")) + .def("set_frozen_atoms", + &OMMPQmHelper::set_frozen_atoms, + "Set the atoms of the system that should be frozen (1-based list) that is unable to move.", + py::arg("frozen_list")) + .def("init_vdw", + &OMMPQmHelper::init_vdw, + "Set the VdW parameters for the QM atoms, this is needed in geometry optimization and MD to avoid clashes between QM and MM atoms", + py::arg("eps"), + py::arg("rad"), + py::arg("fac"), + py::arg("vdw_type") = "buffered-14-7", + py::arg("radius_rule") = "cubic-mean", + py::arg("radius_size") = "diameter", + py::arg("radius_type") = "r-min", + py::arg("eps_rule") = "hhg") + .def("vdw_geomgrad", + &OMMPQmHelper::vdw_geomgrad, + "Compute the geometrical gradients of VdW interaction between QM and MM parts of the system", + py::arg("OMMP_system")) + .def("vdw_energy", + &OMMPQmHelper::vdw_energy, + "Compute the VdW interaction energy between QM and MM parts of the system", + py::arg("OMMP_system")) + .def("link_atom_geomgrad", + &OMMPQmHelper::link_atom_geomgrad, + "Compute the geometrical gradients of link atoms contribution to energy on QM and MM parts of the system", + py::arg("OMMP_system"), py::arg("old_qm_grad")) + .def("update_link_atoms_position", + &OMMPQmHelper::update_link_atoms_position, + "Update the positions of all link atoms") + .def("prepare_qm_ele_ene", + &OMMPQmHelper::prepare_qm_ele_ene, + "Prepeare the quantities available in helper for a single point SCF calculation (electric field of nuclei at polarizable sites, potential of MM system (polarizable and static) at nuclei) with the MM system passed as argument.", + py::arg("OMMP_system")) + .def("prepare_qm_ele_grd", + &OMMPQmHelper::prepare_qm_ele_grd, + "Prepeare the quantities available in helper for a gradients SCF calculation (electric field gradients of nuclei at polarizable sites, electric field of MM system (polarizable and static) at nuclei, electric field, gradients and Hessian of nuclei at static sites) with the MM system passed as argument.", + py::arg("OMMP_system")) + .def_property_readonly("use_nonbonded", &OMMPQmHelper::get_use_nonbonded, "Flag for enable/disable usage of QM-MM VdW potential") + .def_property_readonly("cqm", &OMMPQmHelper::get_cqm, "Get the coordinates of QM nuclei") + .def_property_readonly("E_n2p", &OMMPQmHelper::get_E_n2p, "Electric field of nuclei at polarizable sites") + .def_property_readonly("G_n2p", &OMMPQmHelper::get_G_n2p, "Electric field gradients of nuclei at polarizable sites") + .def_property_readonly("V_m2n", &OMMPQmHelper::get_V_m2n, "Electrostatic potential of MM system (static part) at QM nuclei") + .def_property_readonly("V_p2n", &OMMPQmHelper::get_V_p2n, "Electrostatic potential of MM system (polarizable part) at QM nuclei") + .def_property_readonly("E_m2n", &OMMPQmHelper::get_E_m2n, "Electric field of MM system (static part) at QM nuclei") + .def_property_readonly("E_p2n", &OMMPQmHelper::get_E_p2n, "Electric field of MM system (polarizable part) at QM nuclei") + .def_property_readonly("E_n2m", &OMMPQmHelper::get_E_n2m, "Electric field of MM system at QM nuclei") + .def_property_readonly("G_n2m", &OMMPQmHelper::get_G_n2m, "Electric field gradients of MM system at QM nuclei") + .def_property_readonly("H_n2m", &OMMPQmHelper::get_H_n2m, "Electric field Hessian of MM system at QM nuclei") + .def_property_readonly("frozen", &OMMPQmHelper::get_frozen, "Logical array, for each atom True means frozen False means mobile.") + .def_property_readonly("use_frozen", &OMMPQmHelper::get_use_frozen, "If frozen atoms are used or not."); +} diff --git a/pythonapi/pyproject.toml b/pythonapi/pyproject.toml new file mode 100644 index 0000000..5e2a55b --- /dev/null +++ b/pythonapi/pyproject.toml @@ -0,0 +1,50 @@ +[project] +name = "pyopenmmpol" +description = "Python interface of OpenMMPol library" + +authors = [ + {name = "Mattia Bondanza", email = "mattia.bondanza@unipi.it"}, + {name = "Filippo Lipparini", email = "filippo.lipparini@unipi.it"}, + {name = "Benedetta Mennucci", email = "benedetta.mennucci@unipi.it"}, +] +license = {text = "LGPL v3"} + +classifiers = [ + "Programming Language :: Python :: 3", +] + +dependencies = [ + "numpy >= 1.17", +] + +dynamic = [ + "version", +] + +requires-python = ">=3.7" + +[project.urls] +"Homepage" = "https://github.com/Molecolab-Pisa/OpenMMPol" +"Bug Tracker" = "https://github.com/Molecolab-Pisa/OpenMMPol/issues" + +[build-system] +build-backend = "hatchling.build" +requires = [ + "hatchling>=1.4.1", +] + +[tool.hatch.build.targets.wheel] +packages = ["pyopenmmpol"] + +[tool.hatch.build.targets.sdist] +exclude = [ + "build", +] + +[tool.hatch.build] +include = [ + "pyopenmmpol/*.so", +] + +[tool.hatch.version] +path = "pyopenmmpol/__version__.py" \ No newline at end of file diff --git a/setup.py b/setup.py deleted file mode 100644 index 43bd145..0000000 --- a/setup.py +++ /dev/null @@ -1,78 +0,0 @@ -import os -import sys -import subprocess -from pathlib import Path -from setuptools import Extension, setup -from setuptools.command.build_ext import build_ext - -class CMakeExtension(Extension): - def __init__(self, name, sourcedir=""): - Extension.__init__(self, name, sources=[]) - self.sourcedir = os.path.abspath(sourcedir) - -class CMakeBuild(build_ext): - def build_extension(self, ext): - extdir = os.path.abspath(os.path.dirname(self.get_ext_fullpath(ext.name))) - if not extdir.endswith(os.path.sep): - extdir += os.path.sep - - cfg = "DEBUG" if self.debug else "RELEASE" - - build_args = [] - cmake_args = [ - "-DCMAKE_LIBRARY_OUTPUT_DIRECTORY={}".format(extdir), - "-DCMAKE_BUILD_TYPE={}".format(cfg) - ] - cmake_args += ["-DPYTHON=ON"] - - if not os.path.exists(self.build_temp): - os.makedirs(self.build_temp) - - subprocess.check_call( - ["cmake", ext.sourcedir] + cmake_args, cwd=self.build_temp - ) - subprocess.check_call( - ["cmake", "--build", "."] + build_args, cwd=self.build_temp - ) - # Move from build temp to final position - for ext in self.extensions: - self.move_output(ext) - - def move_output(self, ext): - build_temp = Path(self.build_temp).resolve() - dest_path = Path(self.get_ext_fullpath(ext.name)).resolve() - source_path = build_temp / "lib" / self.get_ext_filename(ext.name) - dest_directory = dest_path.parents[0] - dest_directory.mkdir(parents=True, exist_ok=True) - self.copy_file(source_path, dest_path) - -if not os.path.isfile("src/pyommp_interface.cpp"): - raise RuntimeError("Running setup.py is only supported " - "from top level of repository as './setup.py '") -def ommp_v(version): - return str(version.tag) - -def ommp_local_v(version): - if (version.distance is not None and version.distance > 0) or version.dirty: - lv = '+' - else: - lv = '' - if version.distance is not None and version.distance > 0: - lv += "r{:d}.{:s}".format(version.distance, version.node) - if version.dirty: - lv += '.dirty' - elif version.dirty: - lv += 'dirty' - return lv - -setup( - name="pyopenmmpol", - ext_modules=[CMakeExtension("pyopenmmpol")], - cmdclass={"build_ext": CMakeBuild}, - use_scm_version = { - "root": "./", - "relative_to": __file__, - "version_scheme": ommp_v, - "local_scheme": ommp_local_v, - }, -) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt new file mode 100644 index 0000000..fc28eaa --- /dev/null +++ b/src/CMakeLists.txt @@ -0,0 +1,33 @@ +set(dir "${CMAKE_CURRENT_SOURCE_DIR}") + +list( + APPEND srcs + "${dir}/mod_iohdf5.F90" + "${dir}/mod_adjacency_mat.F90" + "${dir}/mod_bonded.F90" + "${dir}/mod_c_interface.F90" + "${dir}/mod_constants.F90" + "${dir}/mod_electrostatics.F90" + "${dir}/mod_geomgrad.F90" + "${dir}/mod_inputloader.F90" + "${dir}/mod_interface.F90" + "${dir}/mod_io.F90" + "${dir}/mod_jacobian_mat.F90" + "${dir}/mod_link_atom.F90" + "${dir}/mod_memory.F90" + "${dir}/mod_mmpol.F90" + "${dir}/mod_neighbors_list.F90" + "${dir}/mod_nonbonded.F90" + "${dir}/mod_polarization.F90" + "${dir}/mod_prm.F90" + "${dir}/mod_profiling.F90" + "${dir}/mod_qm_helper.F90" + "${dir}/mod_solvers.F90" + "${dir}/mod_topology.F90" + "${dir}/mod_utils.F90" + "${dir}/rotate_multipoles.F90" + "${dir}/smartinput.c" +) + +set(srcs "${srcs}" PARENT_SCOPE) + diff --git a/src/mod_adjacency_mat.F90 b/src/mod_adjacency_mat.F90 new file mode 100644 index 0000000..25dcad5 --- /dev/null +++ b/src/mod_adjacency_mat.F90 @@ -0,0 +1,537 @@ +module mod_adjacency_mat + !! This module is used to efficiently handle the topological problem of + !! finding all the atom pairs in the molecule separated by exactly n bonds. + !! To do so the molecule is tought as an undirected unweighted graph, + !! represented in memory with a boolean adjacency matrix. Since this matrix + !! is sparse and symmetric, it is effeciently represented in the Yale format + !! (sometime referred as compressed sparse row, CSR) omitting the value + !! array. + !! + !! From the adjacency matrix \(\mathbb{C}_1\), the matrix containing the atom + !! pairs separated by exactly n bonds are computed according the following + !! recoursive formula: + !! \[\mathbb{C}_n := \mathbb{C}_{n-1} \cdot \mathbb{C}_1 - (\mathbb{C}_{n-1} + !! + \mathbb{C}_{n-2});\] + !! Note that in this context since we are manipulating boolean matrices, + !! the product is replaced by logical and, sum by logical or, and - by + !! logical and not. To apply this recursive definition, we also assume that + !! \(\mathbb C_0 := \mathbb 1\). + !! + !! The module contains all the routines needed to perform such operations, + !! including the linear scaling multiplication between sparse matrices. + + use mod_memory, only: ip + + implicit none + private + + type yale_sparse + !! Describe a square boolean sparse matrix n x n. + !! Indices of non-zero elements in the i-th row are contained in + !! the array ci(ri(i):ri(i+1)). + integer(ip) :: n + !! Dimension of the matrix + integer(ip), allocatable :: ri(:) + !! Row index vector, always dimensioned n+1 + integer(ip), allocatable :: ci(:) + !! Column index vector, dimension number of non-zero elements + end type yale_sparse + + public :: yale_sparse + public :: adj_mat_from_conn, build_conn_upto_n, matfree, matcpy, & + reallocate_mat, reverse_grp_tab, & + compress_list, compress_data + +contains + + subroutine matcpy(f, t) + !! Copy boolean sparse matrix in yale format f to t. + implicit none + type(yale_sparse), intent(in) :: f + !! Matrix to copy + type(yale_sparse), intent(out) :: t + !! Destination matrix + + allocate(t%ri(size(f%ri))) + allocate(t%ci(size(f%ci))) + + t%n = f%n + t%ri = f%ri + t%ci = f%ci + end subroutine matcpy + + subroutine matfree(m) + !! Deallocate a boolean sparse matrix (in Yale format) + implicit none + + type(yale_sparse), intent(inout) :: m !! Matrix to free + + if(allocated(m%ri)) deallocate(m%ri) + if(allocated(m%ci)) deallocate(m%ci) + m%n=0_ip + end subroutine matfree + + subroutine adj_mat_from_conn(i12, sparse) + !! Create adjacency matrix \(\mathbb C_1\) from connectivity lists. + !! Array i12 and n12 contain the connectivity list in the following + !! format: i12(0:n(j),j) contains the index of all the atoms connected + !! to atom with index j. + + use mod_utils, only: sort_ivec_inplace + use mod_memory, only: mallocate, mfree + implicit none + + integer(ip), intent(inout) :: i12(:,:) + !! Indices of connected atoms for each atom in the molecule + type(yale_sparse), intent(out) :: sparse + !! Adjacency matrix in Yale format (\(\mathbb C_1\)) + + integer(ip) :: i, j, n, m + integer(ip), allocatable :: nnz(:) + + n = size(i12, 2) + m = size(i12, 1) + call mallocate('adj_mat_from_conn [nnz]', n, nnz) + + !$omp parallel do default(shared) & + !$omp private(j,i) + do i=1, n + ! Count the number of non-zero elements and move them to the left + nnz(i) = 0 + do j=1, m + if(i12(j,i) /= 0) then + nnz(i) = nnz(i) + 1 + i12(nnz(i),i) = i12(j,i) + end if + end do + call sort_ivec_inplace(i12(1:nnz(i),i)) + end do + + call compress_list(n, i12, nnz, sparse) + + call mfree('adj_mat_from_conn [nnz]', nnz) + + end subroutine adj_mat_from_conn + + subroutine reallocate_mat(m, nnz) + !! Reshape a boolean sparse matrix in Yale format to accomodate a + !! larger number of non-zero elements or to trim unused non-zero + !! elements after a guess allocation. + + implicit none + + type(yale_sparse), intent(inout) :: m + !! Matrix to be reshaped + integer(ip), intent(in) :: nnz + !! New shape for the matrix + + integer(ip), allocatable :: tmp(:) + + if(nnz == 0) then + ! The matrix is empty, just allocate empty ci + deallocate(m%ci) + allocate(m%ci(0)) + else + allocate(tmp(nnz)) + if(size(m%ci) > nnz) then + ! We are shrinking the matrix + tmp = m%ci(1:nnz) + else + ! We are enlarging the matrix + tmp(1:size(m%ci)) = m%ci + end if + + deallocate(m%ci) + allocate(m%ci(nnz)) + m%ci = tmp + deallocate(tmp) + end if + end subroutine reallocate_mat + + subroutine mat_mult2(sp1, sp2, res) + !! Performs the operation \(res := sp1 \cdot sp2\) on boolean + !! sparse matrices; product correspond to logical and while sum + !! correspond to logical or. + !! This subroutine is just for test pourposes as it performs the + !! matrix product without exploiting the sparsity, and therefore + !! with an unfavorable scaling \(\mathcal O(n^2)\). + implicit none + + type(yale_sparse), intent(in) :: sp1, sp2 + !! Input matrices (sparse boolean matrices in Yale format) + type(yale_sparse), intent(out) :: res + !! Output matrix (sparse boolean matrices in Yale format) + + integer(ip) :: ic, ir, m1, n1, k, nnz, res_nnz + + res%n = sp1%n + allocate(res%ri(res%n+1)) + + ! This is just a guess, it could be increased later + nnz = max(size(sp1%ci), size(sp2%ci)) + res_nnz = nnz + allocate(res%ci(res_nnz)) + + res%ri(1) = 1 + do ir = 1, sp1%n + m1 = sp1%ri(ir) + n1 = sp1%ri(ir+1) - 1 + + res%ri(ir+1) = res%ri(ir) + + do ic = 1, sp2%n + do k = sp2%ri(ic), sp2%ri(ic+1)-1 + if(any(sp1%ci(m1:n1) == sp2%ci(k))) then + res%ci(res%ri(ir+1)) = ic + res%ri(ir+1) = res%ri(ir+1) + 1 + + if(res%ri(ir+1) > res_nnz) then + res_nnz = res_nnz + nnz + call reallocate_mat(res, res_nnz) + endif + + exit + end if + end do + end do + end do + + ! Trim the output vector + nnz = res%ri(res%n+1) - 1 + call reallocate_mat(res, nnz) + end subroutine + + subroutine mat_mult(sp1, sp2, res) + !! Performs the operation \(res := sp1 \cdot sp2\) on boolean + !! sparse matrices; product correspond to logical and while sum + !! correspond to logical or. + !! This subroutine is the one actually used in the code; It performs + !! matrix product exploiting the sparsity, and therefore + !! with a scaling \(\mathcal O(n)\). + implicit none + + type(yale_sparse), intent(in) :: sp1, sp2 + !! Input matrices (sparse boolean matrices in Yale format) + type(yale_sparse), intent(out) :: res + !! Output matrix (sparse boolean matrices in Yale format) + + integer(ip) :: ic, ir, k, nnz, res_nnz + + res%n = sp1%n + allocate(res%ri(res%n+1)) + + ! This is just a guess, it could be increased later + nnz = max(size(sp1%ci), size(sp2%ci)) + res_nnz = nnz + allocate(res%ci(res_nnz)) + + res%ri(1) = 1 + do ir = 1, sp1%n + res%ri(ir+1) = res%ri(ir) + do k = sp1%ri(ir), sp1%ri(ir+1) - 1 + do ic = sp2%ri(sp1%ci(k)), sp2%ri(sp1%ci(k)+1)-1 + ! ir -> sp2%ci(ic) + if(.not. any(res%ci(res%ri(ir):res%ri(ir+1)-1) == sp2%ci(ic))) then + res%ci(res%ri(ir+1)) = sp2%ci(ic) + res%ri(ir+1) = res%ri(ir+1) + 1 + + if(res%ri(ir+1) > res_nnz) then + res_nnz = res_nnz + nnz + call reallocate_mat(res, res_nnz) + endif + end if + end do + end do + end do + + ! Trim the output vector + nnz = res%ri(res%n+1) - 1 + call reallocate_mat(res, nnz) + + end subroutine + + subroutine mat_andnot(sp1, sp2, res) + !! Performs the operation \(res := sp1 \land \neg sp2\) on + !! boolean sparse matrices. + + implicit none + + type(yale_sparse), intent(in) :: sp1, sp2 + !! Input matrices (sparse boolean matrices in Yale format) + type(yale_sparse), intent(out) :: res + !! Output matrix (sparse boolean matrices in Yale format) + + integer(ip) :: ic, ir, ic2_1, ic2_2, nnz + + res%n = sp1%n + allocate(res%ri(res%n+1)) + !! Worst case scenario, nnz(res) will be nnz(sp1) + allocate(res%ci(sp1%ri(sp1%n+1))) + + res%ri(1) = 1 + do ir = 1, sp1%n + res%ri(ir+1) = res%ri(ir) + do ic = sp1%ri(ir), sp1%ri(ir+1) - 1 + ic2_1 = sp2%ri(ir) + ic2_2 = sp2%ri(ir+1) - 1 + if(.not. any(sp2%ci(ic2_1:ic2_2) == sp1%ci(ic))) then + res%ci(res%ri(ir+1)) = sp1%ci(ic) + res%ri(ir+1) = res%ri(ir+1) + 1 + end if + end do + end do + + ! Trim the output vector + nnz = res%ri(res%n+1) - 1 + call reallocate_mat(res, nnz) + + end subroutine + + subroutine sparse_identity(n, res) + !! Create an identity matrix (boolean sparse, represented in + !! Yale format) of dimension \(n\). + implicit none + + integer(ip), intent(in) :: n + !! Rank of the output matrix + type(yale_sparse), intent(out) :: res + !! Output matrix + + integer(ip) :: i + + res%n = n + allocate(res%ci(res%n)) + allocate(res%ri(res%n+1)) + + !$omp parallel do + do i = 1, n + res%ci(i) = i + res%ri(i) = i + end do + res%ri(n+1) = n+1 + + end subroutine sparse_identity + + subroutine build_conn_upto_n(adj, n, res, start_id) + !! Build connectivity matrices up to \(\mathbb C_n\) + !! starting from \(\mathbb C_1\). Results are stored in an + !! array of boolean sparse matrix in Yale format in such a way that + !! \(res(n) := \mathbb C_n\); since FORTRAN is 1-based the useless + !! \(\mathbb C_0\) is not stored. + implicit none + + type(yale_sparse), intent(in) :: adj + !! Adjacency matrix in Yale format + integer(ip), intent(in) :: n + !! Maximum level of connectivity that should be computed + type(yale_sparse), intent(out), allocatable :: res(:) + !! Results connectivity matrices + logical :: start_id + !! Specifies if the first matrix allocated res(1) should be the + !! identity (true) or the adjacency (false). + + integer(ip) :: i, adj_idx + type(yale_sparse) :: tmp, id + + if(start_id) then + allocate(res(n+1)) + call sparse_identity(adj%n, res(1)) + adj_idx = 2 + else + allocate(res(n)) + adj_idx = 1 + end if + call matcpy(adj, res(adj_idx)) + + do i=adj_idx+1, adj_idx+n-1 + if(size(res(i-1)%ci) == 0) then + ! Create a null matrix + res(i)%n = res(i-1)%n + allocate(res(i)%ri(res(i)%n+1)) + res(i)%ri = 1 + allocate(res(i)%ci(0)) + else + call mat_mult(res(i-1), res(adj_idx), res(i)) + !call matcpy(res(i-1), res(i)) + call mat_andnot(res(i), res(i-1), tmp) + if(i == adj_idx+1) then + call sparse_identity(adj%n, id) + call mat_andnot(tmp, id, res(i)) + if(start_id) then + call matcpy(id, res(1)) + end if + call matfree(id) + else + call mat_andnot(tmp, res(i-2), res(i)) + end if + end if + end do + call matfree(tmp) + end subroutine build_conn_upto_n + + subroutine reverse_grp_tab(a2g, g2a, ng_in) + use mod_memory, only: mallocate, mfree + !! Takes as argument an array of group index for each + !! atom, and create a list of atms in each group using the + !! sparse matrix format (saved as Yale format). + !! This is used by cell lists, polarization group etc. + + implicit none + + integer(ip), intent(in) :: a2g(:) + !! Index of polarization group for each MM atom + type(yale_sparse), intent(out) :: g2a + !! Indices of atoms included in each polarization group; + !! Atom indeces for the n-th group are found at + !! pg2mm%ci(pg2mm%ri(n):pg2mm%ri(n+1)-1) + integer(ip), intent(in), optional :: ng_in + !! Number of groups if it is not provided in input it is + !! assumed that the number of group equals the largest group + !! index, that is no empty groups are present after the one + !! with the largest index. + + integer(ip) :: i, j, na, ng, ig + integer(ip), allocatable :: uc_data(:, :), g_dim(:) + + na = size(a2g) + if(present(ng_in)) then + ng = ng_in + else + ng = maxval(a2g) + end if + + ! Find largest group + call mallocate('reverse_grp_tab [g_dim]', ng, g_dim) + g_dim = 0 + + + do i=1, na + g_dim(a2g(i)) = g_dim(a2g(i)) + 1 + end do + + ! Struct for uncompressed data + call mallocate('reverse_grp_tab [uc_data]', maxval(g_dim), ng, uc_data) + ! First invert in an uncompressed structure + uc_data = 0 + g_dim = 0 + + do i=1, na + ig = a2g(i) + g_dim(ig) = g_dim(ig) + 1 + uc_data(g_dim(ig),ig) = i + end do + + ! Compress the list + !g2a%n = ng + !if(.not. allocated(g2a%ri)) & + ! call mallocate('reverse_grp_tab [ri]', ng+1, g2a%ri) + !if(.not. allocated(g2a%ci)) & + ! call mallocate('reverse_grp_tab [ci]', na, g2a%ci) + !g2a%ri(1) = 1 + !do i=1, ng + ! g2a%ri(i+1) = g2a%ri(i) + g_dim(i) - 1 + ! g2a%ci(g2a%ri(i):g2a%ri(i+1)-1) = uc_data(1:g_dim(i)-1,i) + !end do + call compress_list(ng, uc_data, g_dim, g2a) + + ! Free temporary mem + call mfree('reverse_grp_tab [uc_data]', uc_data) + call mfree('reverse_grp_tab [g_dim]', g_dim) + + end subroutine reverse_grp_tab + + subroutine compress_list(n, uc_list, nit, s) + !! This subroutine takes as input a sparse matrix (rank [n]) in an + !! uncompressed yale format [uc_list], as a rectangular + !! matrix ([n] x max_el_per_row) and the actual number of items + !! [nit] for each row (remaining + !! elements are not considered) and compress in a Yale format + !! sparse matrix [s]. + !! The task is parallelized to handle large matrices. + + use mod_memory, only: mallocate, mfree + + implicit none + + integer(ip), intent(in) :: n + !! Rank of matrix + integer(ip), intent(in) :: uc_list(:,:) + !! Uncompressed list/boolean sparse matrix + integer(ip), intent(in) :: nit(n) + !! Number of elements for each row of [uc_list] + type(yale_sparse), intent(out) :: s + !! Output sparse matrix + + integer(ip), allocatable :: idx(:) + !! Indices where a certain row begins (RI) + integer(ip) :: nnz + !! Number of non-zero elements + + integer(ip) :: i, j + + if(n == 0) then + s%n = 0 + if(allocated(s%ri)) call mfree('compress_list [ri]', s%ri) + call mallocate('compress_list [ri]', 1, s%ri) + s%ri = 1 + if(allocated(s%ci)) call mfree('compress_list [ci]', s%ci) + call mallocate('compress_list [ci]', 0, s%ci) + return + end if + + call mallocate('compress_list [idx]', n, idx) + idx(1) = 1 + do i=1, n-1 + idx(i+1) = idx(i) + nit(i) + end do + nnz = idx(n) + nit(n) + + s%n = n + if(allocated(s%ri)) call mfree('compress_list [ri]', s%ri) + call mallocate('compress_list [ri]', n+1, s%ri) + if(allocated(s%ci)) call mfree('compress_list [ci]', s%ci) + call mallocate('compress_list [ci]', nnz-1, s%ci) + + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j) + do i=1, n + s%ri(i)=idx(i) + do j=0, nit(i)-1 + s%ci(idx(i)+j) = uc_list(j+1,i) + end do + end do + s%ri(n+1) = nnz + end subroutine + + subroutine compress_data(s, uc_data, c_data) + !! Compress the data in uc_data to the same Yale sparse + !! format described in s + + use mod_memory, only: mallocate, rp + + implicit none + + type(yale_sparse), intent(in) :: s + !! Input Yale format binary matrix/sparse list + real(rp), intent(in) :: uc_data(:,:) + !! Uncompressed data in input + real(rp), allocatable, intent(out) :: c_data(:) + !! Compressed data in output + + integer(ip) :: nnz, n, i, j0, j + + n = s%n + nnz = size(s%ci) + call mallocate('compress_data [c_data]', nnz, c_data) + + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,j0) + do i=1, s%n + j0 = s%ri(i) - 1 + do j=s%ri(i), s%ri(i+1)-1 + c_data(j) = uc_data(j-j0, i) + end do + end do + end subroutine + +end module mod_adjacency_mat diff --git a/src/mod_adjacency_mat.f90 b/src/mod_adjacency_mat.f90 deleted file mode 100644 index 93077fd..0000000 --- a/src/mod_adjacency_mat.f90 +++ /dev/null @@ -1,537 +0,0 @@ -module mod_adjacency_mat - !! This module is used to efficiently handle the topological problem of - !! finding all the atom pairs in the molecule separated by exactly n bonds. - !! To do so the molecule is tought as an undirected unweighted graph, - !! represented in memory with a boolean adjacency matrix. Since this matrix - !! is sparse and symmetric, it is effeciently represented in the Yale format - !! (sometime referred as compressed sparse row, CSR) omitting the value - !! array. - !! - !! From the adjacency matrix \(\mathbb{C}_1\), the matrix containing the atom - !! pairs separated by exactly n bonds are computed according the following - !! recoursive formula: - !! \[\mathbb{C}_n := \mathbb{C}_{n-1} \cdot \mathbb{C}_1 - (\mathbb{C}_{n-1} - !! + \mathbb{C}_{n-2});\] - !! Note that in this context since we are manipulating boolean matrices, - !! the product is replaced by logical and, sum by logical or, and - by - !! logical and not. To apply this recursive definition, we also assume that - !! \(\mathbb C_0 := \mathbb 1\). - !! - !! The module contains all the routines needed to perform such operations, - !! including the linear scaling multiplication between sparse matrices. - - use mod_memory, only: ip - - implicit none - private - - type yale_sparse - !! Describe a square boolean sparse matrix n x n. - !! Indices of non-zero elements in the i-th row are contained in - !! the array ci(ri(i):ri(i+1)). - integer(ip) :: n - !! Dimension of the matrix - integer(ip), allocatable :: ri(:) - !! Row index vector, always dimensioned n+1 - integer(ip), allocatable :: ci(:) - !! Column index vector, dimension number of non-zero elements - end type yale_sparse - - public :: yale_sparse - public :: adj_mat_from_conn, build_conn_upto_n, matfree, matcpy, & - reallocate_mat, reverse_grp_tab, & - compress_list, compress_data - - contains - - subroutine matcpy(f, t) - !! Copy boolean sparse matrix in yale format f to t. - implicit none - type(yale_sparse), intent(in) :: f - !! Matrix to copy - type(yale_sparse), intent(out) :: t - !! Destination matrix - - allocate(t%ri(size(f%ri))) - allocate(t%ci(size(f%ci))) - - t%n = f%n - t%ri = f%ri - t%ci = f%ci - end subroutine matcpy - - subroutine matfree(m) - !! Deallocate a boolean sparse matrix (in Yale format) - implicit none - - type(yale_sparse), intent(inout) :: m !! Matrix to free - - if(allocated(m%ri)) deallocate(m%ri) - if(allocated(m%ci)) deallocate(m%ci) - m%n=0_ip - end subroutine matfree - - subroutine adj_mat_from_conn(i12, sparse) - !! Create adjacency matrix \(\mathbb C_1\) from connectivity lists. - !! Array i12 and n12 contain the connectivity list in the following - !! format: i12(0:n(j),j) contains the index of all the atoms connected - !! to atom with index j. - - use mod_utils, only: sort_ivec_inplace - use mod_memory, only: mallocate, mfree - implicit none - - integer(ip), intent(inout) :: i12(:,:) - !! Indices of connected atoms for each atom in the molecule - type(yale_sparse), intent(out) :: sparse - !! Adjacency matrix in Yale format (\(\mathbb C_1\)) - - integer(ip) :: i, j, n, m - integer(ip), allocatable :: nnz(:) - - n = size(i12, 2) - m = size(i12, 1) - call mallocate('adj_mat_from_conn [nnz]', n, nnz) - - !$omp parallel do default(shared) & - !$omp private(j,i) - do i=1, n - ! Count the number of non-zero elements and move them to the left - nnz(i) = 0 - do j=1, m - if(i12(j,i) /= 0) then - nnz(i) = nnz(i) + 1 - i12(nnz(i),i) = i12(j,i) - end if - end do - call sort_ivec_inplace(i12(1:nnz(i),i)) - end do - - call compress_list(n, i12, nnz, sparse) - - call mfree('adj_mat_from_conn [nnz]', nnz) - - end subroutine adj_mat_from_conn - - subroutine reallocate_mat(m, nnz) - !! Reshape a boolean sparse matrix in Yale format to accomodate a - !! larger number of non-zero elements or to trim unused non-zero - !! elements after a guess allocation. - - implicit none - - type(yale_sparse), intent(inout) :: m - !! Matrix to be reshaped - integer(ip), intent(in) :: nnz - !! New shape for the matrix - - integer(ip), allocatable :: tmp(:) - - if(nnz == 0) then - ! The matrix is empty, just allocate empty ci - deallocate(m%ci) - allocate(m%ci(0)) - else - allocate(tmp(nnz)) - if(size(m%ci) > nnz) then - ! We are shrinking the matrix - tmp = m%ci(1:nnz) - else - ! We are enlarging the matrix - tmp(1:size(m%ci)) = m%ci - end if - - deallocate(m%ci) - allocate(m%ci(nnz)) - m%ci = tmp - deallocate(tmp) - end if - end subroutine reallocate_mat - - subroutine mat_mult2(sp1, sp2, res) - !! Performs the operation \(res := sp1 \cdot sp2\) on boolean - !! sparse matrices; product correspond to logical and while sum - !! correspond to logical or. - !! This subroutine is just for test pourposes as it performs the - !! matrix product without exploiting the sparsity, and therefore - !! with an unfavorable scaling \(\mathcal O(n^2)\). - implicit none - - type(yale_sparse), intent(in) :: sp1, sp2 - !! Input matrices (sparse boolean matrices in Yale format) - type(yale_sparse), intent(out) :: res - !! Output matrix (sparse boolean matrices in Yale format) - - integer(ip) :: ic, ir, m1, n1, k, nnz, res_nnz - - res%n = sp1%n - allocate(res%ri(res%n+1)) - - ! This is just a guess, it could be increased later - nnz = max(size(sp1%ci), size(sp2%ci)) - res_nnz = nnz - allocate(res%ci(res_nnz)) - - res%ri(1) = 1 - do ir = 1, sp1%n - m1 = sp1%ri(ir) - n1 = sp1%ri(ir+1) - 1 - - res%ri(ir+1) = res%ri(ir) - - do ic = 1, sp2%n - do k = sp2%ri(ic), sp2%ri(ic+1)-1 - if(any(sp1%ci(m1:n1) == sp2%ci(k))) then - res%ci(res%ri(ir+1)) = ic - res%ri(ir+1) = res%ri(ir+1) + 1 - - if(res%ri(ir+1) > res_nnz) then - res_nnz = res_nnz + nnz - call reallocate_mat(res, res_nnz) - endif - - exit - end if - end do - end do - end do - - ! Trim the output vector - nnz = res%ri(res%n+1) - 1 - call reallocate_mat(res, nnz) - end subroutine - - subroutine mat_mult(sp1, sp2, res) - !! Performs the operation \(res := sp1 \cdot sp2\) on boolean - !! sparse matrices; product correspond to logical and while sum - !! correspond to logical or. - !! This subroutine is the one actually used in the code; It performs - !! matrix product exploiting the sparsity, and therefore - !! with a scaling \(\mathcal O(n)\). - implicit none - - type(yale_sparse), intent(in) :: sp1, sp2 - !! Input matrices (sparse boolean matrices in Yale format) - type(yale_sparse), intent(out) :: res - !! Output matrix (sparse boolean matrices in Yale format) - - integer(ip) :: ic, ir, k, nnz, res_nnz - - res%n = sp1%n - allocate(res%ri(res%n+1)) - - ! This is just a guess, it could be increased later - nnz = max(size(sp1%ci), size(sp2%ci)) - res_nnz = nnz - allocate(res%ci(res_nnz)) - - res%ri(1) = 1 - do ir = 1, sp1%n - res%ri(ir+1) = res%ri(ir) - do k = sp1%ri(ir), sp1%ri(ir+1) - 1 - do ic = sp2%ri(sp1%ci(k)), sp2%ri(sp1%ci(k)+1)-1 - ! ir -> sp2%ci(ic) - if(.not. any(res%ci(res%ri(ir):res%ri(ir+1)-1) == sp2%ci(ic))) then - res%ci(res%ri(ir+1)) = sp2%ci(ic) - res%ri(ir+1) = res%ri(ir+1) + 1 - - if(res%ri(ir+1) > res_nnz) then - res_nnz = res_nnz + nnz - call reallocate_mat(res, res_nnz) - endif - end if - end do - end do - end do - - ! Trim the output vector - nnz = res%ri(res%n+1) - 1 - call reallocate_mat(res, nnz) - - end subroutine - - subroutine mat_andnot(sp1, sp2, res) - !! Performs the operation \(res := sp1 \land \neg sp2\) on - !! boolean sparse matrices. - - implicit none - - type(yale_sparse), intent(in) :: sp1, sp2 - !! Input matrices (sparse boolean matrices in Yale format) - type(yale_sparse), intent(out) :: res - !! Output matrix (sparse boolean matrices in Yale format) - - integer(ip) :: ic, ir, ic2_1, ic2_2, nnz - - res%n = sp1%n - allocate(res%ri(res%n+1)) - !! Worst case scenario, nnz(res) will be nnz(sp1) - allocate(res%ci(sp1%ri(sp1%n+1))) - - res%ri(1) = 1 - do ir = 1, sp1%n - res%ri(ir+1) = res%ri(ir) - do ic = sp1%ri(ir), sp1%ri(ir+1) - 1 - ic2_1 = sp2%ri(ir) - ic2_2 = sp2%ri(ir+1) - 1 - if(.not. any(sp2%ci(ic2_1:ic2_2) == sp1%ci(ic))) then - res%ci(res%ri(ir+1)) = sp1%ci(ic) - res%ri(ir+1) = res%ri(ir+1) + 1 - end if - end do - end do - - ! Trim the output vector - nnz = res%ri(res%n+1) - 1 - call reallocate_mat(res, nnz) - - end subroutine - - subroutine sparse_identity(n, res) - !! Create an identity matrix (boolean sparse, represented in - !! Yale format) of dimension \(n\). - implicit none - - integer(ip), intent(in) :: n - !! Rank of the output matrix - type(yale_sparse), intent(out) :: res - !! Output matrix - - integer(ip) :: i - - res%n = n - allocate(res%ci(res%n)) - allocate(res%ri(res%n+1)) - - !$omp parallel do - do i = 1, n - res%ci(i) = i - res%ri(i) = i - end do - res%ri(n+1) = n+1 - - end subroutine sparse_identity - - subroutine build_conn_upto_n(adj, n, res, start_id) - !! Build connectivity matrices up to \(\mathbb C_n\) - !! starting from \(\mathbb C_1\). Results are stored in an - !! array of boolean sparse matrix in Yale format in such a way that - !! \(res(n) := \mathbb C_n\); since FORTRAN is 1-based the useless - !! \(\mathbb C_0\) is not stored. - implicit none - - type(yale_sparse), intent(in) :: adj - !! Adjacency matrix in Yale format - integer(ip), intent(in) :: n - !! Maximum level of connectivity that should be computed - type(yale_sparse), intent(out), allocatable :: res(:) - !! Results connectivity matrices - logical :: start_id - !! Specifies if the first matrix allocated res(1) should be the - !! identity (true) or the adjacency (false). - - integer(ip) :: i, adj_idx - type(yale_sparse) :: tmp, id - - if(start_id) then - allocate(res(n+1)) - call sparse_identity(adj%n, res(1)) - adj_idx = 2 - else - allocate(res(n)) - adj_idx = 1 - end if - call matcpy(adj, res(adj_idx)) - - do i=adj_idx+1, adj_idx+n-1 - if(size(res(i-1)%ci) == 0) then - ! Create a null matrix - res(i)%n = res(i-1)%n - allocate(res(i)%ri(res(i)%n+1)) - res(i)%ri = 1 - allocate(res(i)%ci(0)) - else - call mat_mult(res(i-1), res(adj_idx), res(i)) - !call matcpy(res(i-1), res(i)) - call mat_andnot(res(i), res(i-1), tmp) - if(i == adj_idx+1) then - call sparse_identity(adj%n, id) - call mat_andnot(tmp, id, res(i)) - if(start_id) then - call matcpy(id, res(1)) - end if - call matfree(id) - else - call mat_andnot(tmp, res(i-2), res(i)) - end if - end if - end do - call matfree(tmp) - end subroutine build_conn_upto_n - - subroutine reverse_grp_tab(a2g, g2a, ng_in) - use mod_memory, only: mallocate, mfree - !! Takes as argument an array of group index for each - !! atom, and create a list of atms in each group using the - !! sparse matrix format (saved as Yale format). - !! This is used by cell lists, polarization group etc. - - implicit none - - integer(ip), intent(in) :: a2g(:) - !! Index of polarization group for each MM atom - type(yale_sparse), intent(out) :: g2a - !! Indices of atoms included in each polarization group; - !! Atom indeces for the n-th group are found at - !! pg2mm%ci(pg2mm%ri(n):pg2mm%ri(n+1)-1) - integer(ip), intent(in), optional :: ng_in - !! Number of groups if it is not provided in input it is - !! assumed that the number of group equals the largest group - !! index, that is no empty groups are present after the one - !! with the largest index. - - integer(ip) :: i, j, na, ng, ig - integer(ip), allocatable :: uc_data(:, :), g_dim(:) - - na = size(a2g) - if(present(ng_in)) then - ng = ng_in - else - ng = maxval(a2g) - end if - - ! Find largest group - call mallocate('reverse_grp_tab [g_dim]', ng, g_dim) - g_dim = 0 - - - do i=1, na - g_dim(a2g(i)) = g_dim(a2g(i)) + 1 - end do - - ! Struct for uncompressed data - call mallocate('reverse_grp_tab [uc_data]', maxval(g_dim), ng, uc_data) - ! First invert in an uncompressed structure - uc_data = 0 - g_dim = 0 - - do i=1, na - ig = a2g(i) - g_dim(ig) = g_dim(ig) + 1 - uc_data(g_dim(ig),ig) = i - end do - - ! Compress the list - !g2a%n = ng - !if(.not. allocated(g2a%ri)) & - ! call mallocate('reverse_grp_tab [ri]', ng+1, g2a%ri) - !if(.not. allocated(g2a%ci)) & - ! call mallocate('reverse_grp_tab [ci]', na, g2a%ci) - !g2a%ri(1) = 1 - !do i=1, ng - ! g2a%ri(i+1) = g2a%ri(i) + g_dim(i) - 1 - ! g2a%ci(g2a%ri(i):g2a%ri(i+1)-1) = uc_data(1:g_dim(i)-1,i) - !end do - call compress_list(ng, uc_data, g_dim, g2a) - - ! Free temporary mem - call mfree('reverse_grp_tab [uc_data]', uc_data) - call mfree('reverse_grp_tab [g_dim]', g_dim) - - end subroutine reverse_grp_tab - - subroutine compress_list(n, uc_list, nit, s) - !! This subroutine takes as input a sparse matrix (rank [n]) in an - !! uncompressed yale format [uc_list], as a rectangular - !! matrix ([n] x max_el_per_row) and the actual number of items - !! [nit] for each row (remaining - !! elements are not considered) and compress in a Yale format - !! sparse matrix [s]. - !! The task is parallelized to handle large matrices. - - use mod_memory, only: mallocate, mfree - - implicit none - - integer(ip), intent(in) :: n - !! Rank of matrix - integer(ip), intent(in) :: uc_list(:,:) - !! Uncompressed list/boolean sparse matrix - integer(ip), intent(in) :: nit(n) - !! Number of elements for each row of [uc_list] - type(yale_sparse), intent(out) :: s - !! Output sparse matrix - - integer(ip), allocatable :: idx(:) - !! Indices where a certain row begins (RI) - integer(ip) :: nnz - !! Number of non-zero elements - - integer(ip) :: i, j - - if(n == 0) then - s%n = 0 - if(allocated(s%ri)) call mfree('compress_list [ri]', s%ri) - call mallocate('compress_list [ri]', 1, s%ri) - s%ri = 1 - if(allocated(s%ci)) call mfree('compress_list [ci]', s%ci) - call mallocate('compress_list [ci]', 0, s%ci) - return - end if - - call mallocate('compress_list [idx]', n, idx) - idx(1) = 1 - do i=1, n-1 - idx(i+1) = idx(i) + nit(i) - end do - nnz = idx(n) + nit(n) - - s%n = n - if(allocated(s%ri)) call mfree('compress_list [ri]', s%ri) - call mallocate('compress_list [ri]', n+1, s%ri) - if(allocated(s%ci)) call mfree('compress_list [ci]', s%ci) - call mallocate('compress_list [ci]', nnz-1, s%ci) - - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j) - do i=1, n - s%ri(i)=idx(i) - do j=0, nit(i)-1 - s%ci(idx(i)+j) = uc_list(j+1,i) - end do - end do - s%ri(n+1) = nnz - end subroutine - - subroutine compress_data(s, uc_data, c_data) - !! Compress the data in uc_data to the same Yale sparse - !! format described in s - - use mod_memory, only: mallocate, rp - - implicit none - - type(yale_sparse), intent(in) :: s - !! Input Yale format binary matrix/sparse list - real(rp), intent(in) :: uc_data(:,:) - !! Uncompressed data in input - real(rp), allocatable, intent(out) :: c_data(:) - !! Compressed data in output - - integer(ip) :: nnz, n, i, j0, j - - n = s%n - nnz = size(s%ci) - call mallocate('compress_data [c_data]', nnz, c_data) - - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,j0) - do i=1, s%n - j0 = s%ri(i) - 1 - do j=s%ri(i), s%ri(i+1)-1 - c_data(j) = uc_data(j-j0, i) - end do - end do - end subroutine - -end module mod_adjacency_mat diff --git a/src/mod_bonded.F90 b/src/mod_bonded.F90 new file mode 100644 index 0000000..fba61c3 --- /dev/null +++ b/src/mod_bonded.F90 @@ -0,0 +1,2903 @@ +module mod_bonded + !! Module to handle the bonded part of the FF, it closely follows the + !! AMOEBA functional form. + + use mod_memory, only: ip, rp, lp + use mod_topology, only: ommp_topology_type + use mod_io, only: fatal_error + + implicit none + private + + ! Those constants are used as shorthand for the type of angle parameter + ! that is used for a certain term. They consider two aspects: the functional + ! form that could be a simple armonic constaint on the angle or something + ! more involved (as the \testit{in-plane}) angle); the second aspects is + ! the hydrogen-environment that is the introduction of different force + ! constatns when the central atom is connected to a different number of + ! hydrogen atoms. + integer(ip), parameter, public :: OMMP_ANG_SIMPLE = 0 + !! Simple angle with no difference for hydrogen environments + integer(ip), parameter, public :: OMMP_ANG_H0 = 1 + !! Simple angle with two different hydrogen environments + integer(ip), parameter, public :: OMMP_ANG_H1 = 2 + !! Simple angle with three different hydrogen environments + integer(ip), parameter, public :: OMMP_ANG_H2 = 3 + !! Simple angle with four different hydrogen environments + integer(ip), parameter, public :: OMMP_ANG_INPLANE = 4 + !! In-plane angle with no difference for hydrogen environments + integer(ip), parameter, public :: OMMP_ANG_INPLANE_H0 = 5 + !! In-plane angle with two different hydrogen environments + integer(ip), parameter, public :: OMMP_ANG_INPLANE_H1 = 6 + !! In-plane angle with three different hydrogen environments + + type ommp_bonded_type + type(ommp_topology_type), pointer :: top + !! Data structure for topology + + ! Bond + integer(ip) :: nbond + !! Number of bond terms in the potential energy function + integer(ip), allocatable :: bondat(:,:) + !! Atoms involved in the ith bond term + real(rp) :: bond_cubic, bond_quartic + !! 3rd and 4th order terms coefficients, corresponding to + !! \(k^{(2)}\) and \(k^{(3)}\) + real(rp), allocatable :: kbond(:) + !! Force constants for bond terms + real(rp), allocatable :: l0bond(:) + !! Equilibrium lengths for bonds + logical(lp) :: use_bond = .false. + !! Flag to enable the calculation of bond terms in potential + !! energy function + + ! Angle + integer(ip) :: nangle + !! Number of angle terms in the potential energy function + integer(ip), allocatable :: angleat(:,:) + !! Atoms involved in the ith angle term + integer(ip), allocatable :: anglety(:) + !! Type of function to be used for ith angle term + integer(ip), allocatable :: angauxat(:) + !! Auxiliary atom to be used in calculaton of ith angle term + real(rp) :: angle_cubic, angle_quartic, angle_pentic, angle_sextic + !! Coefficients for 3rd to 6th order terms corresponding to + !! \(k^{(3)}\) ... \(k^{(6)}\). + real(rp), allocatable :: kangle(:) + !! Force constants for the ith angle term + real(rp), allocatable :: eqangle(:) + !! Equilibrium angle for the ith angle term + logical(lp) :: use_angle = .false. + !! Flag to enable the calculation of angle terms in potential energy + !! function + + ! Stretch-Bend + integer(ip) :: nstrbnd + !! Number of stretching-bending coupling terms in potential energy function + integer(ip), allocatable :: strbndat(:,:) + !! Atoms involved in the ith stretching-bending term + real(rp), allocatable :: strbndk1(:), strbndk2(:) + !! Force constants for the ith stretching-bending term (\(k_1\) and \(k_2\)) + real(rp), allocatable :: strbndthet0(:) + !! Equilibrium angle for the ith stretching-bending term + real(rp), allocatable :: strbndl10(:), strbndl20(:) + !! Equilibrium distances for the ith stretching-bending term + logical(lp) :: use_strbnd = .false. + !! Flag to enable calculation of stretching-bending coupling terms in + !! potential energy function + + ! Angle-Torsion coupling + integer(ip) :: nangtor + integer(ip), allocatable :: angtorat(:,:), angtor_t(:), angtor_a(:,:) + real(rp), allocatable :: angtork(:,:) + logical(lp) :: use_angtor = .false. + + ! Bond-Torsion coupling + integer(ip) :: nstrtor + integer(ip), allocatable :: strtorat(:,:), strtor_t(:), strtor_b(:,:) + real(rp), allocatable :: strtork(:,:) + logical(lp) :: use_strtor = .false. + + ! Urey-Bradley + integer(ip) :: nurey + !! Number of Urey-Bradley terms in potential energy function + integer(ip), allocatable :: ureyat(:,:) + !! Atoms involved in ith Urey-Bradley term + real(rp) :: urey_cubic, urey_quartic + !! 3rd and 4th order constants for U-B potential ( + !! \(k^{(3)}\) and \(k^{(4)}\)) + real(rp), allocatable :: kurey(:) + !! Force constants for U-B terms + real(rp), allocatable :: l0urey(:) + !! Equilibrium distance for U-B potentials + logical(lp) :: use_urey = .false. + !! Flag to enable calculation of U-B terms in the potential energy function + + ! Out-of-Plane Bending + integer(ip) :: nopb + !! Number of out-of-plane bending function in potential energy func. + integer(ip), allocatable :: opbat(:,:) + !! Atoms involved in ith oop bending function + real(rp) :: opb_cubic=0.0, opb_quartic=0.0, opb_pentic=0.0, opb_sextic=0.0 + !! Coefficients for 3rd to 6th order terms corresponding to + !! \(k^{(3)}\) ... \(k^{(6)}\) for out-of-plane bending. + real(rp), allocatable :: kopb(:) + !! Force constants for ith out-of plane bending + logical(lp) :: use_opb = .false. + !! Flag to enable out-of-plane bending calculation + + ! Pi-torsion + integer(ip) :: npitors + integer(ip), allocatable :: pitorsat(:,:) + real(rp), allocatable :: kpitors(:) + logical(lp) :: use_pitors = .false. + + ! Torsion + integer(ip) :: ntorsion + integer(ip), allocatable :: torsionat(:,:), torsn(:,:) + real(rp), allocatable :: torsamp(:,:), torsphase(:,:) + logical(lp) :: use_torsion = .false. + + ! Imporoper Torsion + integer(ip) :: nimptorsion + integer(ip), allocatable :: imptorsionat(:,:), imptorsn(:,:) + real(rp), allocatable :: imptorsamp(:,:), imptorsphase(:,:) + logical(lp) :: use_imptorsion = .false. + + ! Torsion-torsion coupling (cmap) + integer(ip) :: ntortor + integer(ip), allocatable :: tortorat(:,:), tortorprm(:), ttmap_shape(:,:) + real(rp), allocatable :: ttmap_ang1(:), ttmap_ang2(:), ttmap_v(:), & + ttmap_vx(:), ttmap_vy(:), ttmap_vxy(:) + logical(lp) :: use_tortor = .false. + end type ommp_bonded_type + + public :: ommp_bonded_type + public :: bond_init, bond_potential, bond_geomgrad, bond_terminate + public :: angle_init, angle_potential, angle_geomgrad, angle_terminate + public :: urey_init, urey_potential, urey_geomgrad, urey_terminate + public :: strbnd_init, strbnd_potential, strbnd_geomgrad, strbnd_terminate + public :: opb_init, opb_potential, opb_geomgrad, opb_terminate + public :: pitors_init, pitors_potential, pitors_geomgrad, pitors_terminate + public :: torsion_init, torsion_potential, torsion_geomgrad, & + torsion_terminate + public :: imptorsion_init, imptorsion_potential, imptorsion_geomgrad, & + imptorsion_terminate + public :: tortor_init, tortor_potential, tortor_geomgrad, & + tortor_terminate, tortor_newmap + public :: strtor_init, strtor_potential, strtor_geomgrad, strtor_terminate + public :: angtor_init, angtor_potential, angtor_geomgrad, angtor_terminate + public :: bonded_terminate + +contains + + subroutine bond_init(bds, n) + !! Initialize array used in calculation of bond stratching terms of + !! potential energy + + use mod_memory, only: mallocate + + implicit none + + type(ommp_bonded_type) :: bds + ! Bonded potential data structure + integer(ip) :: n + !! Number of bond stretching functions in the potential + !! energy of the system + + if( n < 1 ) return + bds%use_bond = .true. + + call mallocate('bond_init [bondat]', 2, n, bds%bondat) + call mallocate('bond_init [kbond]', n, bds%kbond) + call mallocate('bond_init [l0bond]', n, bds%l0bond) + + bds%nbond = n + bds%bond_cubic = 0.0_rp + bds%bond_quartic = 0.0_rp + + end subroutine bond_init + + subroutine bond_potential(bds, V) + !! Compute the bond-stretching terms of the potential energy. + !! They are computed according to the general formula adopted in AMOEBA + !! Force Field: + !! \[U_{bond} = \sum_i k_i \Delta l_i^2 \large(1 + k^{(3)}\Delta l_i + + !! k^{(4)}\Delta l_i^2 \large)\] + !! \[\Delta l_i = l_i - l^{(eq)}_i\] + + use mod_constants, only : eps_rp + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: V + !! Bond potential, result will be added to V + + integer :: i + logical(lp) :: use_cubic, use_quartic + real(rp) :: dr(3), l, dl, dl2 + + use_cubic = (abs(bds%bond_cubic) > eps_rp) + use_quartic = (abs(bds%bond_quartic) > eps_rp) + + if(.not. bds%use_bond) return + + if(.not. use_cubic .and. .not. use_quartic) then + ! This is just a regular harmonic potential + !$omp parallel do default(shared) schedule(static) & + !$omp private(i,dr,l,dl) reduction(+:v) + do i=1, bds%nbond + dr = bds%top%cmm(:,bds%bondat(1,i)) - & + bds%top%cmm(:,bds%bondat(2,i)) + l = sqrt(dot_product(dr, dr)) + dl = l - bds%l0bond(i) + + V = V + bds%kbond(i) * dl * dl + end do + else + !$omp parallel do default(shared) schedule(static) & + !$omp private(i,dr,l,dl,dl2) reduction(+:v) + do i=1, bds%nbond + dr = bds%top%cmm(:,bds%bondat(1,i)) - & + bds%top%cmm(:,bds%bondat(2,i)) + l = sqrt(dot_product(dr, dr)) + dl = l - bds%l0bond(i) + dl2 = dl * dl + + V = V + bds%kbond(i)*dl2 * & + (1.0_rp + bds%bond_cubic*dl + bds%bond_quartic*dl2) + end do + end if + + end subroutine bond_potential + + subroutine bond_geomgrad(bds, grad) + use mod_constants, only : eps_rp + use mod_jacobian_mat, only: Rij_jacobian + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + !! Bonded potential data structure + real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) + !! Gradients of bond stretching terms of potential energy + + integer :: i, ia, ib + logical(lp) :: use_cubic, use_quartic + logical :: sk_a, sk_b + real(rp) :: ca(3), cb(3), J_a(3), J_b(3), l, dl, g + + use_cubic = (abs(bds%bond_cubic) > eps_rp) + use_quartic = (abs(bds%bond_quartic) > eps_rp) + + if(.not. bds%use_bond) return + + if(.not. use_cubic .and. .not. use_quartic) then + ! This is just a regular harmonic potential + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,ia,ib,sk_a,sk_b,ca,cb,dl,l,g,J_a,J_b) + do i=1, bds%nbond + ia = bds%bondat(1,i) + ib = bds%bondat(2,i) + + if(bds%top%use_frozen) then + sk_a = bds%top%frozen(ia) + sk_b = bds%top%frozen(ib) + if(sk_a .and. sk_b) cycle + else + sk_a = .false. + sk_b = .false. + end if + + ca = bds%top%cmm(:,ia) + cb = bds%top%cmm(:,ib) + + call Rij_jacobian(ca, cb, l, J_a, J_b) + dl = l - bds%l0bond(i) + + g = 2 * bds%kbond(i) * dl + + if(.not. sk_a) then + !$omp atomic update + grad(1,ia) = grad(1,ia) + J_a(1) * g + !$omp atomic update + grad(2,ia) = grad(2,ia) + J_a(2) * g + !$omp atomic update + grad(3,ia) = grad(3,ia) + J_a(3) * g + end if + + if(.not. sk_b) then + !$omp atomic update + grad(1,ib) = grad(1,ib) + J_b(1) * g + !$omp atomic update + grad(2,ib) = grad(2,ib) + J_b(2) * g + !$omp atomic update + grad(3,ib) = grad(3,ib) + J_b(3) * g + end if + end do + else + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,ia,ib,sk_a,sk_b,ca,cb,dl,l,g,J_a,J_b) + do i=1, bds%nbond + ia = bds%bondat(1,i) + ib = bds%bondat(2,i) + + if(bds%top%use_frozen) then + sk_a = bds%top%frozen(ia) + sk_b = bds%top%frozen(ib) + if(sk_a .and. sk_b) cycle + else + sk_a = .false. + sk_b = .false. + end if + + ca = bds%top%cmm(:,ia) + cb = bds%top%cmm(:,ib) + + call Rij_jacobian(ca, cb, l, J_a, J_b) + dl = l - bds%l0bond(i) + + g = 2 * bds%kbond(i) * dl * (1.0_rp + 3.0/2.0*bds%bond_cubic*dl & + + 2.0*bds%bond_quartic*dl**2) + + if(.not. sk_a) then + !$omp atomic update + grad(1,ia) = grad(1,ia) + J_a(1) * g + !$omp atomic update + grad(2,ia) = grad(2,ia) + J_a(2) * g + !$omp atomic update + grad(3,ia) = grad(3,ia) + J_a(3) * g + end if + + if(.not. sk_b) then + !$omp atomic update + grad(1,ib) = grad(1,ib) + J_b(1) * g + !$omp atomic update + grad(2,ib) = grad(2,ib) + J_b(2) * g + !$omp atomic update + grad(3,ib) = grad(3,ib) + J_b(3) * g + end if + end do + end if + + end subroutine bond_geomgrad + + subroutine angle_init(bds, n) + !! Initialize arrays used in calculation of angle bending functions + + use mod_memory, only: mallocate + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + integer(ip) :: n + !! Number of angle bending functions in the potential + !! energy of the system + + if( n < 1 ) return + bds%use_angle = .true. + + call mallocate('angle_init [angleat]', 3, n, bds%angleat) + call mallocate('angle_init [anglety]', n, bds%anglety) + call mallocate('angle_init [angauxat]', n, bds%angauxat) + call mallocate('angle_init [kangle]', n, bds%kangle) + call mallocate('angle_init [eqangle]', n, bds%eqangle) + + bds%nangle = n + bds%angauxat = 0 + bds%angle_cubic = 0.0_rp + bds%angle_quartic = 0.0_rp + bds%angle_pentic = 0.0_rp + bds%angle_sextic = 0.0_rp + + end subroutine angle_init + + subroutine angle_potential(bds, V) + !! Compute angle-bending terms of the potential energy function. + !! Simple angle terms are computed according to the formula: + !! \[U_{angle} = \sum_i k_i \Delta \theta_i^2 \large(1 + + !! \sum_{j=1}^4 k^{(j+2)} \Delta \theta_i^j \large)\] + !! \[\Delta \theta_i = \theta_i - \theta^{(eq)}_i\] + !! Out-of plane angle are more complex. First, central atom has to be + !! a trigonal center, the other two atoms together with the auxliary + !! atom (that is the remaining one connected to the trigonal center) + !! define the projection plane. During the first run the auxiliary atom + !! is found and saved. + !! Then, the trigonal center is projected on the plane defined by the + !! other three atoms, and the angle is the one defined by the projection + !! (which is the vertex, and the other two atoms -- the auxiliary is + !! excluded). Then the same formula used for simple angle terms is used. + use mod_constants, only: eps_rp + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: V + !! Bond potential, result will be added to V + + integer(ip) :: i + real(rp) :: l1, l2, dr1(3), dr2(3), thet, d_theta + real(rp), dimension(3) :: v_dist, plv1, plv2, pln, a, b, c, prj_b, aux + + if(.not. bds%use_angle) return + + !$omp parallel do default(shared) schedule(static) reduction(+:V) & + !$omp private(i,dr1,dr2,l1,l2,thet,d_theta,a,b,c,aux,plv1,plv2,pln,v_dist,prj_b) + do i=1, bds%nangle + if(abs(bds%kangle(i)) < eps_rp) cycle + if(bds%anglety(i) == OMMP_ANG_SIMPLE .or. & + bds%anglety(i) == OMMP_ANG_H0 .or. & + bds%anglety(i) == OMMP_ANG_H1 .or. & + bds%anglety(i) == OMMP_ANG_H2) then + dr1 = bds%top%cmm(:, bds%angleat(1,i)) - bds%top%cmm(:, bds%angleat(2,i)) + dr2 = bds%top%cmm(:, bds%angleat(3,i)) - bds%top%cmm(:, bds%angleat(2,i)) + l1 = sqrt(dot_product(dr1, dr1)) + l2 = sqrt(dot_product(dr2, dr2)) + + thet = acos(dot_product(dr1, dr2)/(l1*l2)) + + d_theta = thet-bds%eqangle(i) + + V = V + bds%kangle(i) * d_theta**2 * (1.0 + bds%angle_cubic*d_theta & + + bds%angle_quartic*d_theta**2 + bds%angle_pentic*d_theta**3 & + + bds%angle_sextic*d_theta**4) + + else if(bds%anglety(i) == OMMP_ANG_INPLANE .or. & + bds%anglety(i) == OMMP_ANG_INPLANE_H0 .or. & + bds%anglety(i) == OMMP_ANG_INPLANE_H1) then + + a = bds%top%cmm(:, bds%angleat(1,i)) + b = bds%top%cmm(:, bds%angleat(2,i)) !! Trigonal center + c = bds%top%cmm(:, bds%angleat(3,i)) + + aux = bds%top%cmm(:, bds%angauxat(i)) + plv1 = a - aux + plv2 = c - aux + pln(1) = plv1(2)*plv2(3) - plv1(3)*plv2(2) + pln(2) = plv1(3)*plv2(1) - plv1(1)*plv2(3) + pln(3) = plv1(1)*plv2(2) - plv1(2)*plv2(1) + !! Normal vector of the projection plane + pln = pln / sqrt(dot_product(pln, pln)) + + v_dist = b - aux + prj_b = b - dot_product(v_dist, pln) * pln + + dr1 = bds%top%cmm(:, bds%angleat(1,i)) - prj_b + dr2 = bds%top%cmm(:, bds%angleat(3,i)) - prj_b + l1 = sqrt(dot_product(dr1, dr1)) + l2 = sqrt(dot_product(dr2, dr2)) + + thet = acos(dot_product(dr1, dr2)/(l1*l2)) + + d_theta = thet-bds%eqangle(i) + + V = V + bds%kangle(i) * d_theta**2 * (1.0 + bds%angle_cubic*d_theta & + + bds%angle_quartic*d_theta**2 + bds%angle_pentic*d_theta**3 & + + bds%angle_sextic*d_theta**4) + end if + end do + end subroutine angle_potential + + subroutine angle_geomgrad(bds, grad) + use mod_jacobian_mat, only: simple_angle_jacobian, & + inplane_angle_jacobian + use mod_constants, only: eps_rp + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + !! Bonded potential data structure + real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) + !! Gradients of bond stretching terms of potential energy + + real(rp) :: a(3), b(3), c(3), Ja(3), Jb(3), Jc(3), Jx(3), g, thet, & + d_theta, aux(3) + integer(ip) :: i + logical :: sk_a, sk_b, sk_c, sk_x + + if(.not. bds%use_angle) return + + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,sk_a,sk_b,sk_c,sk_x,a,b,c,aux,thet,d_theta,g,Ja,Jb,Jc,Jx) + do i=1, bds%nangle + if(abs(bds%kangle(i)) < eps_rp) cycle + if(bds%anglety(i) == OMMP_ANG_SIMPLE .or. & + bds%anglety(i) == OMMP_ANG_H0 .or. & + bds%anglety(i) == OMMP_ANG_H1 .or. & + bds%anglety(i) == OMMP_ANG_H2) then + if(bds%top%use_frozen) then + sk_a = bds%top%frozen(bds%angleat(1,i)) + sk_b = bds%top%frozen(bds%angleat(2,i)) + sk_c = bds%top%frozen(bds%angleat(3,i)) + if(sk_a .and. sk_b .and. sk_c) cycle + else + sk_a = .false. + sk_b = .false. + sk_c = .false. + end if + + a = bds%top%cmm(:, bds%angleat(1,i)) + b = bds%top%cmm(:, bds%angleat(2,i)) + c = bds%top%cmm(:, bds%angleat(3,i)) + call simple_angle_jacobian(a, b, c, thet, Ja, Jb, Jc) + d_theta = thet - bds%eqangle(i) + + g = bds%kangle(i) * d_theta * (2.0 & + + 3.0 * bds%angle_cubic * d_theta & + + 4.0 * bds%angle_quartic * d_theta**2 & + + 5.0 * bds%angle_pentic * d_theta**3 & + + 6.0 * bds%angle_sextic * d_theta**4) + + if(.not. sk_a) then + !$omp atomic update + grad(1,bds%angleat(1,i)) = grad(1,bds%angleat(1,i)) + g * Ja(1) + !$omp atomic update + grad(2,bds%angleat(1,i)) = grad(2,bds%angleat(1,i)) + g * Ja(2) + !$omp atomic update + grad(3,bds%angleat(1,i)) = grad(3,bds%angleat(1,i)) + g * Ja(3) + end if + + if(.not. sk_b) then + !$omp atomic update + grad(1,bds%angleat(2,i)) = grad(1,bds%angleat(2,i)) + g * Jb(1) + !$omp atomic update + grad(2,bds%angleat(2,i)) = grad(2,bds%angleat(2,i)) + g * Jb(2) + !$omp atomic update + grad(3,bds%angleat(2,i)) = grad(3,bds%angleat(2,i)) + g * Jb(3) + end if + + if(.not. sk_c) then + !$omp atomic update + grad(1,bds%angleat(3,i)) = grad(1,bds%angleat(3,i)) + g * Jc(1) + !$omp atomic update + grad(2,bds%angleat(3,i)) = grad(2,bds%angleat(3,i)) + g * Jc(2) + !$omp atomic update + grad(3,bds%angleat(3,i)) = grad(3,bds%angleat(3,i)) + g * Jc(3) + end if + else if(bds%anglety(i) == OMMP_ANG_INPLANE .or. & + bds%anglety(i) == OMMP_ANG_INPLANE_H0 .or. & + bds%anglety(i) == OMMP_ANG_INPLANE_H1) then + + if(bds%top%use_frozen) then + sk_a = bds%top%frozen(bds%angleat(1,i)) + sk_b = bds%top%frozen(bds%angleat(2,i)) + sk_c = bds%top%frozen(bds%angleat(3,i)) + sk_x = bds%top%frozen(bds%angauxat(i)) + if(sk_a .and. sk_b .and. sk_c .and. sk_x) cycle + else + sk_a = .false. + sk_b = .false. + sk_c = .false. + sk_x = .false. + end if + + a = bds%top%cmm(:, bds%angleat(1,i)) + b = bds%top%cmm(:, bds%angleat(2,i)) !! Trigonal center + c = bds%top%cmm(:, bds%angleat(3,i)) + + aux = bds%top%cmm(:, bds%angauxat(i)) + + call inplane_angle_jacobian(a, b, c, aux, thet, Ja, Jb, Jc, Jx) + d_theta = thet - bds%eqangle(i) + g = bds%kangle(i) * d_theta * (2.0 & + + 3.0 * bds%angle_cubic * d_theta & + + 4.0 * bds%angle_quartic * d_theta**2 & + + 5.0 * bds%angle_pentic * d_theta**3 & + + 6.0 * bds%angle_sextic * d_theta**4) + if(.not. sk_a) then + !$omp atomic update + grad(1,bds%angleat(1,i)) = grad(1,bds%angleat(1,i)) + g * Ja(1) + !$omp atomic update + grad(2,bds%angleat(1,i)) = grad(2,bds%angleat(1,i)) + g * Ja(2) + !$omp atomic update + grad(3,bds%angleat(1,i)) = grad(3,bds%angleat(1,i)) + g * Ja(3) + end if + + if(.not. sk_b) then + !$omp atomic update + grad(1,bds%angleat(2,i)) = grad(1,bds%angleat(2,i)) + g * Jb(1) + !$omp atomic update + grad(2,bds%angleat(2,i)) = grad(2,bds%angleat(2,i)) + g * Jb(2) + !$omp atomic update + grad(3,bds%angleat(2,i)) = grad(3,bds%angleat(2,i)) + g * Jb(3) + end if + + if(.not. sk_c) then + !$omp atomic update + grad(1,bds%angleat(3,i)) = grad(1,bds%angleat(3,i)) + g * Jc(1) + !$omp atomic update + grad(2,bds%angleat(3,i)) = grad(2,bds%angleat(3,i)) + g * Jc(2) + !$omp atomic update + grad(3,bds%angleat(3,i)) = grad(3,bds%angleat(3,i)) + g * Jc(3) + end if + + if(.not. sk_x) then + !$omp atomic update + grad(1,bds%angauxat(i)) = grad(1,bds%angauxat(i)) + g * Jx(1) + !$omp atomic update + grad(2,bds%angauxat(i)) = grad(2,bds%angauxat(i)) + g * Jx(2) + !$omp atomic update + grad(3,bds%angauxat(i)) = grad(3,bds%angauxat(i)) + g * Jx(3) + end if + end if + end do + end subroutine angle_geomgrad + + subroutine strbnd_init(bds, n) + !! Initialize arrays for calculation of stretch-bend cross term + !! potential + + use mod_memory, only: mallocate + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + integer(ip) :: n + !! Number of stretch-bend functions in the potential + !! energy of the system + + if( n < 1 ) return + bds%use_strbnd = .true. + + call mallocate('strbnd_init [strbndat]', 3, n, bds%strbndat) + call mallocate('strbnd_init [strbndl10]', n, bds%strbndl10) + call mallocate('strbnd_init [strbndl20]', n, bds%strbndl20) + call mallocate('strbnd_init [strbndthet0]', n, bds%strbndthet0) + call mallocate('strbnd_init [strbndk1]', n, bds%strbndk1) + call mallocate('strbnd_init [strbndk2]', n, bds%strbndk2) + bds%nstrbnd = n + + end subroutine strbnd_init + + subroutine strbnd_potential(bds, V) + !! Compute the stretch-bend cross term potential. + !! Those terms are computed according the following formula: + !! \[U_{bond/angle} = (k_i \Delta l_i + k_j \Delta l_j) + !! \Delta \theta_{ij} \] + !! where \(\theta_{ij}\) is the angle delimited by the bond \(i\) and + !! \(j\). + !! The force constants \(k_i\) and \(k_j\) are explicitely defined in + !! the FF, while the equilibrium values are the same as for stretching + !! and bending terms. + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: V + !! Stretch-bend cross term potential, result will be added to V + + integer(ip) :: i + real(rp) :: d_l1, d_l2, d_thet, dr1(3), dr2(3), l1, l2, thet + + if(.not. bds%use_strbnd) return + + !$omp parallel do default(shared) reduction(+:V) & + !$omp private(i,dr1,l1,l2,d_l1,d_l2,dr2,thet,d_thet) + do i=1, bds%nstrbnd + dr1 = bds%top%cmm(:, bds%strbndat(2,i)) - & + bds%top%cmm(:, bds%strbndat(1,i)) + l1 = norm2(dr1) + d_l1 = l1 - bds%strbndl10(i) + + dr2 = bds%top%cmm(:, bds%strbndat(2,i)) - & + bds%top%cmm(:, bds%strbndat(3,i)) + l2 = norm2(dr2) + d_l2 = l2 - bds%strbndl20(i) + + thet = acos(dot_product(dr1, dr2)/(l1*l2)) + d_thet = thet - bds%strbndthet0(i) + + V = V + (d_l1*bds%strbndk1(i) + d_l2*bds%strbndk2(i)) * d_thet + end do + end subroutine strbnd_potential + + subroutine strbnd_geomgrad(bds, grad) + use mod_jacobian_mat, only: Rij_jacobian, simple_angle_jacobian + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) + !! Gradients of bond stretching terms of potential energy + + integer(ip) :: i, ia, ib, ic + real(rp) :: d_l1, d_l2, d_thet, l1, l2, thet, g1, g2, g3 + real(rp), dimension(3) :: a, b, c, & + J1_a, J1_b, & + J2_b, J2_c, & + J3_a, J3_b, J3_c + logical :: sk_a, sk_b, sk_c + + if(.not. bds%use_strbnd) return + + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,ia,ib,ic,sk_a,sk_b,sk_c,a,b,c,l1,l2,d_l1,d_l2,thet,d_thet) & + !$omp private(J1_a,J1_b,J2_b,J2_c,J3_a,J3_b,J3_c,g1,g2,g3) + do i=1, bds%nstrbnd + ia = bds%strbndat(1,i) + ib = bds%strbndat(2,i) + ic = bds%strbndat(3,i) + + if(bds%top%use_frozen) then + sk_a = bds%top%frozen(ia) + sk_b = bds%top%frozen(ib) + sk_c = bds%top%frozen(ic) + if(sk_a .and. sk_b .and. sk_c) cycle + else + sk_a = .false. + sk_b = .false. + sk_c = .false. + end if + + a = bds%top%cmm(:, ia) + b = bds%top%cmm(:, ib) + c = bds%top%cmm(:, ic) + + call Rij_jacobian(a, b, l1, J1_a, J1_b) + call Rij_jacobian(b, c, l2, J2_b, J2_c) + call simple_angle_jacobian(a, b, c, thet, J3_a, J3_b, J3_c) + + d_l1 = l1 - bds%strbndl10(i) + d_l2 = l2 - bds%strbndl20(i) + d_thet = thet - bds%strbndthet0(i) + + g1 = bds%strbndk1(i) * d_thet + g2 = bds%strbndk2(i) * d_thet + g3 = bds%strbndk1(i) * d_l1 + bds%strbndk2(i) * d_l2 + + if(.not. sk_a) then + !$omp atomic update + grad(1,ia) = grad(1,ia) + J1_a(1) * g1 + J3_a(1) * g3 + !$omp atomic update + grad(2,ia) = grad(2,ia) + J1_a(2) * g1 + J3_a(2) * g3 + !$omp atomic update + grad(3,ia) = grad(3,ia) + J1_a(3) * g1 + J3_a(3) * g3 + end if + + if(.not. sk_b) then + !$omp atomic update + grad(1,ib) = grad(1,ib) + J1_b(1) * g1 + J2_b(1) * g2 + J3_b(1) * g3 + !$omp atomic update + grad(2,ib) = grad(2,ib) + J1_b(2) * g1 + J2_b(2) * g2 + J3_b(2) * g3 + !$omp atomic update + grad(3,ib) = grad(3,ib) + J1_b(3) * g1 + J2_b(3) * g2 + J3_b(3) * g3 + end if + + if(.not. sk_c) then + !$omp atomic update + grad(1,ic) = grad(1,ic) + J2_c(1) * g2 + J3_c(1) * g3 + !$omp atomic update + grad(2,ic) = grad(2,ic) + J2_c(2) * g2 + J3_c(2) * g3 + !$omp atomic update + grad(3,ic) = grad(3,ic) + J2_c(3) * g2 + J3_c(3) * g3 + end if + end do + + end subroutine strbnd_geomgrad + + subroutine urey_init(bds, n) + !! Initialize Urey-Bradley potential arrays + + use mod_memory, only: mallocate + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + integer(ip) :: n + !! Number of Urey-Bradley functions in the potential + !! energy of the system + + if( n < 1 ) return + bds%use_urey = .true. + + call mallocate('urey_init [ureya]', 2, n, bds%ureyat) + call mallocate('urey_init [kurey]', n, bds%kurey) + call mallocate('urey_init [l0urey]', n, bds%l0urey) + bds%nurey = n + bds%urey_cubic = 0.0_rp + bds%urey_quartic = 0.0_rp + + end subroutine urey_init + + subroutine urey_potential(bds, V) + !! Compute the Urey-Bradley potential. + !! This is basically a virtual bond, with its stretching harminic + !! potential that connect two otherwise un-connected bonds. The same + !! potential formula used for normal stretching is used. + + use mod_constants, only : eps_rp + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: V + !! Urey-Bradley potential, result will be added to V + + integer :: i + logical(lp) :: use_cubic, use_quartic + real(rp) :: dr(3), l, dl, dl2 + + if(.not. bds%use_urey) return + + use_cubic = (abs(bds%urey_cubic) > eps_rp) + use_quartic = (abs(bds%urey_quartic) > eps_rp) + + if(.not. use_cubic .and. .not. use_quartic) then + ! This is just a regular harmonic potential + !$omp parallel do default(shared) reduction(+:V) & + !$omp private(i,dr,l,dl) + do i=1, bds%nurey + dr = bds%top%cmm(:,bds%ureyat(1,i)) - & + bds%top%cmm(:,bds%ureyat(2,i)) + l = sqrt(dot_product(dr, dr)) + dl = l - bds%l0urey(i) + V = V + bds%kurey(i) * dl * dl + end do + else + !$omp parallel do default(shared) reduction(+:V) & + !$omp private(i,dr,l,dl,dl2) + do i=1, bds%nurey + dr = bds%top%cmm(:,bds%ureyat(1,i)) - & + bds%top%cmm(:,bds%ureyat(2,i)) + l = sqrt(dot_product(dr, dr)) + dl = l - bds%l0urey(i) + dl2 = dl * dl + + V = V + bds%kurey(i)*dl2 * (1.0_rp + bds%urey_cubic*dl + & + bds%urey_quartic*dl2) + end do + end if + end subroutine urey_potential + + subroutine urey_geomgrad(bds, grad) + use mod_constants, only : eps_rp + use mod_jacobian_mat, only: Rij_jacobian + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + !! Bonded potential data structure + real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) + !! Gradients of bond stretching terms of potential energy + + integer :: i, ia, ib + logical(lp) :: use_cubic, use_quartic + logical :: sk_a, sk_b + real(rp) :: l, dl, J_a(3), J_b(3), g + + if(.not. bds%use_urey) return + + use_cubic = (abs(bds%urey_cubic) > eps_rp) + use_quartic = (abs(bds%urey_quartic) > eps_rp) + + if(.not. use_cubic .and. .not. use_quartic) then + ! This is just a regular harmonic potential + !$omp parallel do default(shared) & + !$omp private(i,ia,ib,sk_a,sk_b,l,dl,g,J_a,J_b) + do i=1, bds%nurey + ia = bds%ureyat(1,i) + ib = bds%ureyat(2,i) + + if(bds%top%use_frozen) then + sk_a = bds%top%frozen(ia) + sk_b = bds%top%frozen(ib) + if(sk_a .and. sk_b) cycle + else + sk_a = .false. + sk_b = .false. + end if + + call Rij_jacobian(bds%top%cmm(:,ia), & + bds%top%cmm(:,ib), & + l, J_a, J_b) + dl = l - bds%l0urey(i) + g = 2 * bds%kurey(i) * dl + + if(.not. sk_a) then + !$omp atomic update + grad(1,ia) = grad(1,ia) + J_a(1) * g + !$omp atomic update + grad(2,ia) = grad(2,ia) + J_a(2) * g + !$omp atomic update + grad(3,ia) = grad(3,ia) + J_a(3) * g + end if + + if(.not. sk_b) then + !$omp atomic update + grad(1,ib) = grad(1,ib) + J_b(1) * g + !$omp atomic update + grad(2,ib) = grad(2,ib) + J_b(2) * g + !$omp atomic update + grad(3,ib) = grad(3,ib) + J_b(3) * g + end if + end do + else + !$omp parallel do default(shared) & + !$omp private(i,ia,ib,sk_a,sk_b,l,dl,g,J_a,J_b) + do i=1, bds%nurey + ia = bds%ureyat(1,i) + ib = bds%ureyat(2,i) + + if(bds%top%use_frozen) then + sk_a = bds%top%frozen(ia) + sk_b = bds%top%frozen(ib) + if(sk_a .and. sk_b) cycle + else + sk_a = .false. + sk_b = .false. + end if + + call Rij_jacobian(bds%top%cmm(:,ia), & + bds%top%cmm(:,ib), & + l, J_a, J_b) + dl = l - bds%l0urey(i) + g = 2 * bds%kurey(i) * dl * (1.0 & + + 3.0/2.0 * bds%urey_cubic*dl & + + 2.0 * bds%urey_quartic*dl**2) + + if(.not. sk_a) then + !$omp atomic update + grad(1,ia) = grad(1,ia) + J_a(1) * g + !$omp atomic update + grad(2,ia) = grad(2,ia) + J_a(2) * g + !$omp atomic update + grad(3,ia) = grad(3,ia) + J_a(3) * g + end if + + if(.not. sk_b) then + !$omp atomic update + grad(1,ib) = grad(1,ib) + J_b(1) * g + !$omp atomic update + grad(2,ib) = grad(2,ib) + J_b(2) * g + !$omp atomic update + grad(3,ib) = grad(3,ib) + J_b(3) * g + end if + end do + end if + end subroutine urey_geomgrad + + subroutine opb_init(bds, n, opbtype) + !! Initialize arrays for out-of-plane bending potential calculation. + !! @todo Currently only Allinger functional form is supported + use mod_io, only: ommp_message + use mod_constants, only: OMMP_VERBOSE_LOW + use mod_memory, only: mallocate + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + integer(ip) :: n + !! Number of out of plane Bending functions in the potential + !! energy of the system + character(len=*) :: opbtype + + select case(opbtype) + case('allinger') + continue + case('w-d-c') + call fatal_error('Out-of-plane bend W-D-C is not implemented') + case default + call ommp_message("Found OPB type: '"//opbtype//"'", OMMP_VERBOSE_LOW) + call fatal_error('Out-of-plane type specified is not understood') + end select + + if( n < 1 ) return + bds%use_opb = .true. + + call mallocate('opb_init [opbat]', 4, n, bds%opbat) + call mallocate('opb_init [kopb]', n, bds%kopb) + bds%nopb = n + + end subroutine opb_init + + subroutine opb_potential(bds, V) + !! Computes the out-of-plane bending potential. + !! With Allinger formula: similarly to in plane angles, here we are + !! considering a trigonal center, where D is the central atom and + !! A, B, C are connected to D. Allinger formula consider the angle + !! between vector \(\vec{AD}\) and the normal vector of plane ABC, + !! using \(\frac{\pi}{2}\) as implicit equilibrium value. The formula + !! for this potential term is: + !! \[U_{out-of-plane} = \sum_i k_i \chi_i^2 \large(1 + + !! \sum_{j=1}^4 k^{(j+2)} \chi_i^j \large) \] + + use mod_constants, only : pi + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: V + !! out-of-plane potential, result will be added to V + real(rp), dimension(3) :: a, b, c, d, plv1, plv2, pln, vad + real(rp) :: lpln, lvad, thet, thet2, thet3, thet4 + integer(ip) :: i + + if(.not. bds%use_opb) return + + !$omp parallel do default(shared) reduction(+:V) & + !$omp private(i,a,b,c,d,plv1,plv2,pln,lpln,vad,lvad,thet,thet2,thet3,thet4) + do i=1, bds%nopb + ! A* -- D -- C + ! | + ! B + a = bds%top%cmm(:,bds%opbat(2,i)) + d = bds%top%cmm(:,bds%opbat(1,i)) + c = bds%top%cmm(:,bds%opbat(3,i)) + b = bds%top%cmm(:,bds%opbat(4,i)) + + ! Compute the normal vector of the plane + plv1 = a - b + plv2 = a - c + pln(1) = plv1(2)*plv2(3) - plv1(3)*plv2(2) + pln(2) = plv1(3)*plv2(1) - plv1(1)*plv2(3) + pln(3) = plv1(1)*plv2(2) - plv1(2)*plv2(1) + lpln = norm2(pln) + + ! Vector from A to D + vad = a - d + lvad = norm2(vad) + + thet = abs(pi/2.0 - acos(dot_product(vad, pln)/(lvad*lpln))) + thet2 = thet*thet + thet3 = thet2*thet + thet4 = thet3*thet + V = V + bds%kopb(i) * thet2 * (1 + bds%opb_cubic*thet & + + bds%opb_quartic*thet2 + bds%opb_pentic*thet3 & + + bds%opb_sextic*thet4) + end do + end subroutine opb_potential + + subroutine opb_geomgrad(bds, grad) + use mod_jacobian_mat, only: opb_angle_jacobian + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) + !! Gradients of bond stretching terms of potential energy + real(rp) :: thet, g, J_a(3), J_b(3), J_c(3), J_d(3) + integer(ip) :: i, ia, ib, ic, id + logical :: sk_a, sk_b, sk_c, sk_d + + if(.not. bds%use_opb) return + + !$omp parallel do default(shared) schedule(dynamic)& + !$omp private(i,ia,ib,ic,id,sk_a,sk_b,sk_c,sk_d,thet,J_a,J_b,J_c,J_d,g) + do i=1, bds%nopb + ia = bds%opbat(2,i) + ib = bds%opbat(4,i) + ic = bds%opbat(3,i) + id = bds%opbat(1,i) + + if(bds%top%use_frozen) then + sk_a = bds%top%frozen(ia) + sk_b = bds%top%frozen(ib) + sk_c = bds%top%frozen(ic) + sk_d = bds%top%frozen(id) + if(sk_a .and. sk_b .and. sk_c .and. sk_d) cycle + else + sk_a = .false. + sk_b = .false. + sk_c = .false. + sk_d = .false. + end if + + call opb_angle_jacobian(bds%top%cmm(:,ia), & + bds%top%cmm(:,ib), & + bds%top%cmm(:,ic), & + bds%top%cmm(:,id), & + thet, J_a, J_b, J_c, J_d) + + g = bds%kopb(i) * thet * (2.0 + 3.0*bds%opb_cubic*thet & + + 4.0*bds%opb_quartic*thet**2 + 5.0*bds%opb_pentic*thet**3 & + + 6.0*bds%opb_sextic*thet**4) + + if(.not. sk_a) then + !$omp atomic update + grad(1,ia) = grad(1,ia) + J_a(1) * g + !$omp atomic update + grad(2,ia) = grad(2,ia) + J_a(2) * g + !$omp atomic update + grad(3,ia) = grad(3,ia) + J_a(3) * g + end if + + if(.not. sk_b) then + !$omp atomic update + grad(1,ib) = grad(1,ib) + J_b(1) * g + !$omp atomic update + grad(2,ib) = grad(2,ib) + J_b(2) * g + !$omp atomic update + grad(3,ib) = grad(3,ib) + J_b(3) * g + end if + + if(.not. sk_c) then + !$omp atomic update + grad(1,ic) = grad(1,ic) + J_c(1) * g + !$omp atomic update + grad(2,ic) = grad(2,ic) + J_c(2) * g + !$omp atomic update + grad(3,ic) = grad(3,ic) + J_c(3) * g + end if + + if(.not. sk_d) then + !$omp atomic update + grad(1,id) = grad(1,id) + J_d(1) * g + !$omp atomic update + grad(2,id) = grad(2,id) + J_d(2) * g + !$omp atomic update + grad(3,id) = grad(3,id) + J_d(3) * g + end if + end do + end subroutine opb_geomgrad + + + subroutine pitors_init(bds, n) + !! Initialize arrays needed to compute pi-torsion potential + + use mod_memory, only: mallocate + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + integer(ip) :: n + !! Number of out of plane pi-torsion functions in the potential + !! enerpgy of the system + + if( n < 1 ) return + + bds%use_pitors = .true. + + call mallocate('pitors_init [pitorsat]', 6, n, bds%pitorsat) + call mallocate('pitors_init [kpitors]', n, bds%kpitors) + bds%npitors = n + + end subroutine pitors_init + + subroutine pitors_potential(bds, V) + !! Compute pi-torsion terms of the potential. + !! This potential is defined on a \(\pi\)-system, and uses the + !! coordinates of six atoms A...F the central "double" bond is A-B, then + !! C and D are connected to A while E and F are connected to B. So two + !! plane ACD and BEF are defined. The potential is computed using the + !! dihedral angle of the normal vector of those two planes, connected + !! by segment A-B (\(\theta\)). + !! The formula used is: + !! \[U_{\pi-torsion} = \sum_i k_i \large(1 + cos(2\theta-\pi) \large)\] + + use mod_constants, only : pi + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: V + !! pi-torsion potential, result will be added to V + real(rp), dimension(3) :: a, b, c, d, e, f, u, t, cd, plv1, plv2, pln1, pln2 + real(rp) :: thet, costhet + integer(ip) :: i + + if(.not. bds%use_pitors) return + + !$omp parallel do default(shared) reduction(+:V) & + !$omp private(i,a,b,c,d,e,f,plv1,plv2,pln1,pln2,t,u,cd,thet,costhet) + do i=1, bds%npitors + ! + ! 2(c) 5(e) a => 1 + ! \ / b => 4 + ! 1(a) -- 4(b) + ! / \ + ! 3(d) 6(f) + + ! Atoms that defines the two planes + a = bds%top%cmm(:,bds%pitorsat(1,i)) + c = bds%top%cmm(:,bds%pitorsat(2,i)) + d = bds%top%cmm(:,bds%pitorsat(3,i)) + + b = bds%top%cmm(:,bds%pitorsat(4,i)) + e = bds%top%cmm(:,bds%pitorsat(5,i)) + f = bds%top%cmm(:,bds%pitorsat(6,i)) + + + ! Compute the normal vector of the first plane + plv1 = d - b + plv2 = c - b + pln1(1) = plv1(2)*plv2(3) - plv1(3)*plv2(2) + pln1(2) = plv1(3)*plv2(1) - plv1(1)*plv2(3) + pln1(3) = plv1(1)*plv2(2) - plv1(2)*plv2(1) + + ! Compute the normal vector of the second plane + plv1 = f - a + plv2 = e - a + pln2(1) = plv1(2)*plv2(3) - plv1(3)*plv2(2) + pln2(2) = plv1(3)*plv2(1) - plv1(1)*plv2(3) + pln2(3) = plv1(1)*plv2(2) - plv1(2)*plv2(1) + + cd = b - a + + t(1) = pln1(2)*cd(3) - pln1(3)*cd(2) + t(2) = pln1(3)*cd(1) - pln1(1)*cd(3) + t(3) = pln1(1)*cd(2) - pln1(2)*cd(1) + t = t / norm2(t) + + u(1) = cd(2)*pln2(3) - cd(3)*pln2(2) + u(2) = cd(3)*pln2(1) - cd(1)*pln2(3) + u(3) = cd(1)*pln2(2) - cd(2)*pln2(1) + u = u / norm2(u) + + costhet = dot_product(u,t) + + thet = acos(costhet) + + V = V + bds%kpitors(i) * (1 + cos(2.0*thet-pi)) + end do + + end subroutine pitors_potential + + subroutine pitors_geomgrad(bds, grad) + use mod_jacobian_mat, only: pitors_angle_jacobian + use mod_constants, only : pi + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) + !! improper torsion potential, result will be added to V + real(rp) :: thet, g, J_a(3), J_b(3), J_c(3), J_d(3), J_e(3), J_f(3) + integer(ip) :: i, ia, ib, ic, id, ie, if_ + logical :: sk_a, sk_b, sk_c, sk_d, sk_e, sk_f + + if(.not. bds%use_pitors) return + + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,ia,ib,ic,id,ie,if_,sk_a,sk_b,sk_c,sk_d,sk_e,sk_f) & + !$omp private(J_a,J_b,J_c,J_d,J_e,J_f,g,thet) + do i=1, bds%npitors + ia = bds%pitorsat(1,i) + ic = bds%pitorsat(2,i) + id = bds%pitorsat(3,i) + ib = bds%pitorsat(4,i) + ie = bds%pitorsat(5,i) + if_ = bds%pitorsat(6,i) + + if(bds%top%use_frozen) then + sk_a = bds%top%frozen(ia) + sk_b = bds%top%frozen(ib) + sk_c = bds%top%frozen(ic) + sk_d = bds%top%frozen(id) + sk_e = bds%top%frozen(ie) + sk_f = bds%top%frozen(if_) + if(sk_a .and. sk_b .and. sk_c .and. sk_d .and. sk_e .and. sk_f) cycle + else + sk_a = .false. + sk_b = .false. + sk_c = .false. + sk_d = .false. + sk_e = .false. + sk_f = .false. + end if + + call pitors_angle_jacobian(bds%top%cmm(:,ia), & + bds%top%cmm(:,ib), & + bds%top%cmm(:,ic), & + bds%top%cmm(:,id), & + bds%top%cmm(:,ie), & + bds%top%cmm(:,if_), & + thet, J_a, J_b, J_c, J_d, J_e, J_f) + + g = -2.0 * bds%kpitors(i) * sin(2.0*thet-pi) + + if(.not. sk_a) then + !$omp atomic update + grad(1,ia) = grad(1,ia) + g * J_a(1) + !$omp atomic update + grad(2,ia) = grad(2,ia) + g * J_a(2) + !$omp atomic update + grad(3,ia) = grad(3,ia) + g * J_a(3) + end if + + if(.not. sk_b) then + !$omp atomic update + grad(1,ib) = grad(1,ib) + g * J_b(1) + !$omp atomic update + grad(2,ib) = grad(2,ib) + g * J_b(2) + !$omp atomic update + grad(3,ib) = grad(3,ib) + g * J_b(3) + end if + + if(.not. sk_c) then + !$omp atomic update + grad(1,ic) = grad(1,ic) + g * J_c(1) + !$omp atomic update + grad(2,ic) = grad(2,ic) + g * J_c(2) + !$omp atomic update + grad(3,ic) = grad(3,ic) + g * J_c(3) + end if + + if(.not. sk_d) then + !$omp atomic update + grad(1,id) = grad(1,id) + g * J_d(1) + !$omp atomic update + grad(2,id) = grad(2,id) + g * J_d(2) + !$omp atomic update + grad(3,id) = grad(3,id) + g * J_d(3) + end if + + if(.not. sk_e) then + !$omp atomic update + grad(1,ie) = grad(1,ie) + g * J_e(1) + !$omp atomic update + grad(2,ie) = grad(2,ie) + g * J_e(2) + !$omp atomic update + grad(3,ie) = grad(3,ie) + g * J_e(3) + end if + + if(.not. sk_f) then + !$omp atomic update + grad(1,if_) = grad(1,if_) + g * J_f(1) + !$omp atomic update + grad(2,if_) = grad(2,if_) + g * J_f(2) + !$omp atomic update + grad(3,if_) = grad(3,if_) + g * J_f(3) + end if + end do + end subroutine pitors_geomgrad + + + subroutine torsion_init(bds, n) + !! Initialize torsion potential arrays + + use mod_memory, only: mallocate + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + integer(ip) :: n + !! Number of torsion functions in the potential + !! energy of the system + + if( n < 1 ) return + bds%use_torsion = .true. + + call mallocate('torsion_init [torsionat]', 4, n, bds%torsionat) + call mallocate('torsion_init [torsamp]', 6, n, bds%torsamp) + call mallocate('torsion_init [torsphase]', 6, n, bds%torsphase) + call mallocate('torsion_init [torsn]', 6, n, bds%torsn) + + bds%ntorsion = n + + end subroutine torsion_init + + subroutine torsion_potential(bds, V) + !! Compute torsion potential + use mod_constants, only: pi, eps_rp + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: V + !! torsion potential, result will be added to V + real(rp) :: thet, costhet + integer(ip) :: i, j + + if(.not. bds%use_torsion) return + + !$omp parallel do default(shared) & + !$omp private(i,costhet,thet,j) reduction(+:V) + do i=1, bds%ntorsion + ! Atoms that defines the dihedral angle + costhet = cos_torsion(bds%top, bds%torsionat(:,i)) + + if(costhet + 1.0 <= eps_rp) then + thet = pi + else if(abs(costhet - 1.0) <= eps_rp) then + thet = 0.0 + else + thet = acos(costhet) + end if + + do j=1, 6 + if(bds%torsn(j,i) < 1) exit + V = V + bds%torsamp(j,i) * (1+cos(real(bds%torsn(j,i))*thet & + - bds%torsphase(j,i))) + end do + end do + + end subroutine torsion_potential + + subroutine torsion_geomgrad(bds, grad) + !! Compute torsion potential + use mod_jacobian_mat, only: torsion_angle_jacobian + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) + !! Gradients of bond stretching terms of potential energy + real(rp) :: thet, g, J_a(3), J_b(3), J_c(3), J_d(3) + integer(ip) :: i, j, ia, ib, ic, id + logical :: sk_a, sk_b, sk_c, sk_d + + if(.not. bds%use_torsion) return + + !$omp parallel do default(shared) & + !$omp private(i,ia,ib,ic,id,sk_a,sk_b,sk_c,sk_d,j,thet,J_a,J_b,J_c,J_d,g) + do i=1, bds%ntorsion + ia = bds%torsionat(1,i) + ib = bds%torsionat(2,i) + ic = bds%torsionat(3,i) + id = bds%torsionat(4,i) + + if(bds%top%use_frozen) then + sk_a = bds%top%frozen(ia) + sk_b = bds%top%frozen(ib) + sk_c = bds%top%frozen(ic) + sk_d = bds%top%frozen(id) + if(sk_a .and. sk_b .and. sk_c .and. sk_d) cycle + else + sk_a = .false. + sk_b = .false. + sk_c = .false. + sk_d = .false. + end if + + call torsion_angle_jacobian(bds%top%cmm(:,ia), & + bds%top%cmm(:,ib), & + bds%top%cmm(:,ic), & + bds%top%cmm(:,id), & + thet, J_a, J_b, J_c, J_d) + + do j=1, 6 + if(bds%torsn(j,i) < 1) exit + g = -real(bds%torsn(j,i)) * sin(real(bds%torsn(j,i))* thet & + - bds%torsphase(j,i)) & + * bds%torsamp(j,i) + if(.not. sk_a) then + !$omp atomic update + grad(1, ia) = grad(1, ia) + J_a(1) * g + !$omp atomic update + grad(2, ia) = grad(2, ia) + J_a(2) * g + !$omp atomic update + grad(3, ia) = grad(3, ia) + J_a(3) * g + end if + if(.not. sk_b) then + !$omp atomic update + grad(1, ib) = grad(1, ib) + J_b(1) * g + !$omp atomic update + grad(2, ib) = grad(2, ib) + J_b(2) * g + !$omp atomic update + grad(3, ib) = grad(3, ib) + J_b(3) * g + end if + if(.not. sk_c) then + !$omp atomic update + grad(1, ic) = grad(1, ic) + J_c(1) * g + !$omp atomic update + grad(2, ic) = grad(2, ic) + J_c(2) * g + !$omp atomic update + grad(3, ic) = grad(3, ic) + J_c(3) * g + end if + if(.not. sk_d) then + !$omp atomic update + grad(1, id) = grad(1, id) + J_d(1) * g + !$omp atomic update + grad(2, id) = grad(2, id) + J_d(2) * g + !$omp atomic update + grad(3, id) = grad(3, id) + J_d(3) * g + end if + end do + end do + + end subroutine torsion_geomgrad + + subroutine imptorsion_potential(bds, V) + !! Compute torsion potential + use mod_constants, only: pi, eps_rp + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: V + !! improper torsion potential, result will be added to V + real(rp) :: thet, costhet + integer(ip) :: i, j + + if(.not. bds%use_imptorsion) return + + do i=1, bds%nimptorsion + ! Atoms that defines the dihedral angle + costhet = cos_torsion(bds%top, bds%imptorsionat(:,i)) + + if(costhet + 1.0 <= eps_rp) then + thet = pi + else + thet = acos(costhet) + end if + + do j=1, 3 + if(bds%imptorsn(j,i) < 1) exit + V = V + bds%imptorsamp(j,i) * (1+cos(real(bds%imptorsn(j,i))*thet & + - bds%imptorsphase(j,i))) + end do + end do + + end subroutine imptorsion_potential + + subroutine imptorsion_geomgrad(bds, grad) + !! Compute torsion potential + use mod_jacobian_mat, only: torsion_angle_jacobian + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: grad(3, bds%top%mm_atoms) + !! improper torsion potential, result will be added to V + real(rp) :: thet, g, J_a(3), J_b(3), J_c(3), J_d(3) + integer(ip) :: i, j, ia, ib, ic, id + logical :: sk_a, sk_b, sk_c, sk_d + + if (.not. bds%use_imptorsion) return + + !$omp parallel do default(shared) & + !$omp private(i, ia, ib, ic, id, sk_a, sk_b, sk_c, sk_d, j, thet, J_a, J_b, J_c, J_d, g) + do i = 1, bds%nimptorsion + ! Atoms that define the dihedral angle + ia = bds%imptorsionat(1, i) + ib = bds%imptorsionat(2, i) + ic = bds%imptorsionat(3, i) + id = bds%imptorsionat(4, i) + + if (bds%top%use_frozen) then + sk_a = bds%top%frozen(ia) + sk_b = bds%top%frozen(ib) + sk_c = bds%top%frozen(ic) + sk_d = bds%top%frozen(id) + if (sk_a .and. sk_b .and. sk_c .and. sk_d) cycle + else + sk_a = .false. + sk_b = .false. + sk_c = .false. + sk_d = .false. + end if + + call torsion_angle_jacobian(bds%top%cmm(:, ia), & + bds%top%cmm(:, ib), & + bds%top%cmm(:, ic), & + bds%top%cmm(:, id), & + thet, J_a, J_b, J_c, J_d) + + do j = 1, 3 + if (bds%imptorsn(j, i) < 1) exit + g = -real(bds%imptorsn(j, i)) * sin(real(bds%imptorsn(j, i)) * thet & + - bds%imptorsphase(j, i)) & + * bds%imptorsamp(j, i) + if (.not. sk_a) then + !$omp atomic update + grad(1, ia) = grad(1, ia) + J_a(1) * g + !$omp atomic update + grad(2, ia) = grad(2, ia) + J_a(2) * g + !$omp atomic update + grad(3, ia) = grad(3, ia) + J_a(3) * g + end if + if (.not. sk_b) then + !$omp atomic update + grad(1, ib) = grad(1, ib) + J_b(1) * g + !$omp atomic update + grad(2, ib) = grad(2, ib) + J_b(2) * g + !$omp atomic update + grad(3, ib) = grad(3, ib) + J_b(3) * g + end if + if (.not. sk_c) then + !$omp atomic update + grad(1, ic) = grad(1, ic) + J_c(1) * g + !$omp atomic update + grad(2, ic) = grad(2, ic) + J_c(2) * g + !$omp atomic update + grad(3, ic) = grad(3, ic) + J_c(3) * g + end if + if (.not. sk_d) then + !$omp atomic update + grad(1, id) = grad(1, id) + J_d(1) * g + !$omp atomic update + grad(2, id) = grad(2, id) + J_d(2) * g + !$omp atomic update + grad(3, id) = grad(3, id) + J_d(3) * g + end if + end do + end do + end subroutine imptorsion_geomgrad + + subroutine imptorsion_init(bds, n) + !! Initialize improper torsion potential arrays + + use mod_memory, only: mallocate + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + integer(ip) :: n + !! Number of improper torsion functions in the potential + !! energy of the system + + if( n < 1 ) return + bds%use_imptorsion = .true. + + call mallocate('imptorsion_init [imptorsionat]', 4, n, bds%imptorsionat) + call mallocate('imptorsion_init [imptorsamp]', 3, n, bds%imptorsamp) + call mallocate('imptorsion_init [imptorsphase]', 3, n, bds%imptorsphase) + call mallocate('imptorsion_init [imptorsn]', 3, n, bds%imptorsn) + + bds%nimptorsion = n + + end subroutine imptorsion_init + + subroutine angtor_init(bds, n) + !! Initialize angle-torsion coupling potential arrays + + use mod_memory, only: mallocate + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + integer(ip) :: n + !! Number of angle torsion coupling functions in the potential + !! energy of the system + + if( n < 1 ) return + bds%use_angtor = .true. + + call mallocate('angtor_init [angtorat]', 4, n, bds%angtorat) + call mallocate('angtor_init [angtork]', 6, n, bds%angtork) + call mallocate('angtor_init [angtor_t]', n, bds%angtor_t) + call mallocate('angtor_init [angtor_a]', 2, n, bds%angtor_a) + + bds%nangtor = n + + end subroutine angtor_init + + subroutine strtor_init(bds, n) + + use mod_memory, only: mallocate + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + integer(ip) :: n + + if( n < 1 ) return + bds%use_strtor = .true. + + call mallocate('strtor_init [strtorat]', 4, n, bds%strtorat) + call mallocate('strtor_init [strtork]', 9, n, bds%strtork) + call mallocate('strtor_init [strtor_t]', n, bds%strtor_t) + call mallocate('strtor_init [strtor_a]', 3, n, bds%strtor_b) + + bds%nstrtor = n + + end subroutine strtor_init + + subroutine angtor_potential(bds, V) + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: V + real(rp) :: thet, costhet, dihef(3), delta_a(2), vat, l1, l2, & + dr1(3), dr2(3), angle1, angle2 + integer(ip) :: i, j, k, ia1, ia2 + + if(.not. bds%use_angtor) return + + !$omp parallel do default(shared) reduction(+:V) & + !$omp private(i,costhet,thet,j,dihef,ia1,ia2,dr1,dr2,l1,l2,angle1,angle2,delta_a,vat,k) + do i=1, bds%nangtor + ! Atoms that defines the dihedral angle + costhet = cos_torsion(bds%top, bds%angtorat(:,i)) + thet = acos(costhet) + do j=1, 3 + dihef(j) = 1.0 + cos(j*thet+bds%torsphase(j,bds%angtor_t(i))) + end do + + ia1 = bds%angtor_a(1,i) + ia2 = bds%angtor_a(2,i) + + dr1 = bds%top%cmm(:, bds%angleat(1,ia1)) - & + bds%top%cmm(:, bds%angleat(2,ia1)) + dr2 = bds%top%cmm(:, bds%angleat(3,ia1)) - & + bds%top%cmm(:, bds%angleat(2,ia1)) + l1 = norm2(dr1) + l2 = norm2(dr2) + angle1 = acos(dot_product(dr1, dr2)/(l1*l2)) + + dr1 = bds%top%cmm(:, bds%angleat(1,ia2)) - & + bds%top%cmm(:, bds%angleat(2,ia2)) + dr2 = bds%top%cmm(:, bds%angleat(3,ia2)) - & + bds%top%cmm(:, bds%angleat(2,ia2)) + l1 = norm2(dr1) + l2 = norm2(dr2) + angle2 = acos(dot_product(dr1, dr2)/(l1*l2)) + + delta_a(1) = angle1 - bds%eqangle(bds%angtor_a(1,i)) + delta_a(2) = angle2 - bds%eqangle(bds%angtor_a(2,i)) + + do j=1,2 + vat = 0.0 + do k=1, 3 + vat = vat + bds%angtork((j-1)*3+k,i) * dihef(k) + end do + V = V + vat * delta_a(j) + end do + end do + + end subroutine angtor_potential + + subroutine angtor_geomgrad(bds, grad) + use mod_jacobian_mat, only: simple_angle_jacobian, torsion_angle_jacobian + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) + !! improper torsion potential, result will be added to V + real(rp) :: thet, gt(3), dihef(3), da1, da2, angle1, angle2, f1, f2, f3, & + Jt_a(3), Jt_b(3), Jt_c(3), Jt_d(3), & + Ja1_a(3), Ja1_b(3), Ja1_c(3), & + Ja2_a(3), Ja2_b(3), Ja2_c(3) + + integer(ip) :: i, j, k, ia1, ia2, & + it_a, it_b, it_c, it_d, & + ia1_a, ia1_b, ia1_c, & + ia2_a, ia2_b, ia2_c + logical :: sk_ta, sk_tb, sk_tc, sk_td, & + sk_1a, sk_1b, sk_1c, & + sk_2a, sk_2b, sk_2c + + if(.not. bds%use_angtor) return + + !$omp parallel do default(shared) & + !$omp private(thet, gt, dihef, da1, da2, angle1, angle2, f1, f2, f3, Jt_a, Jt_b) & + !$omp private(Jt_c, Jt_d, Ja1_a, Ja1_b, Ja1_c) & + !$omp private(Ja2_a, Ja2_b, Ja2_c, i, j, k, ia1, ia2) & + !$omp private(it_a, it_b, it_c, it_d, ia1_a, ia1_b, ia1_c, ia2_a, ia2_b, ia2_c) & + !$omp private(sk_ta, sk_tb, sk_tc, sk_td, sk_1a, sk_1b, sk_1c, sk_2a, sk_2b, sk_2c) + do i=1, bds%nangtor + ! Atoms that define the dihedral angle + it_a = bds%angtorat(1,i) + it_b = bds%angtorat(2,i) + it_c = bds%angtorat(3,i) + it_d = bds%angtorat(4,i) + + ia1 = bds%angtor_a(1,i) + ia1_a = bds%angleat(1,ia1) + ia1_b = bds%angleat(2,ia1) + ia1_c = bds%angleat(3,ia1) + + ia2 = bds%angtor_a(2,i) + ia2_a = bds%angleat(1,ia2) + ia2_b = bds%angleat(2,ia2) + ia2_c = bds%angleat(3,ia2) + + if(bds%top%use_frozen) then + sk_ta = bds%top%frozen(it_a) + sk_tb = bds%top%frozen(it_b) + sk_tc = bds%top%frozen(it_c) + sk_td = bds%top%frozen(it_d) + + sk_1a = bds%top%frozen(ia1_a) + sk_1b = bds%top%frozen(ia1_b) + sk_1c = bds%top%frozen(ia1_c) + + sk_2a = bds%top%frozen(ia2_a) + sk_2b = bds%top%frozen(ia2_b) + sk_2c = bds%top%frozen(ia2_c) + + if(sk_ta .and. sk_tb .and. sk_tc .and. sk_td .and. & + sk_1a .and. sk_1b .and. sk_1c .and. & + sk_2a .and. sk_2b .and. sk_2c) cycle + else + sk_ta = .false. + sk_tb = .false. + sk_tc = .false. + sk_td = .false. + sk_1a = .false. + sk_1b = .false. + sk_1c = .false. + sk_2a = .false. + sk_2b = .false. + sk_2c = .false. + end if + + call torsion_angle_jacobian(bds%top%cmm(:,it_a), & + bds%top%cmm(:,it_b), & + bds%top%cmm(:,it_c), & + bds%top%cmm(:,it_d), & + thet, Jt_a, Jt_b, Jt_c, Jt_d) + do j=1, 3 + gt(j) = -real(j) * sin(j*thet+bds%torsphase(j,bds%angtor_t(i))) + dihef(j) = 1.0 + cos(j*thet+bds%torsphase(j,bds%angtor_t(i))) + end do + + call simple_angle_jacobian(bds%top%cmm(:,ia1_a), & + bds%top%cmm(:,ia1_b), & + bds%top%cmm(:,ia1_c), & + angle1, Ja1_a, Ja1_b, Ja1_c) + + call simple_angle_jacobian(bds%top%cmm(:,ia2_a), & + bds%top%cmm(:,ia2_b), & + bds%top%cmm(:,ia2_c), & + angle2, Ja2_a, Ja2_b, Ja2_c) + + da1 = angle1 - bds%eqangle(ia1) + da2 = angle2 - bds%eqangle(ia2) + + do k = 1, 3 + if(.not.(sk_ta .and. sk_tb .and. sk_tc .and. sk_td)) & + f1 = (bds%angtork(k, i) * da1 + bds%angtork(3+k,i) * da2) * gt(k) + if(.not.(sk_1a .and. sk_1b .and. sk_1c)) & + f2 = bds%angtork(k, i) * dihef(k) + if(.not.(sk_2a .and. sk_2b .and. sk_2c)) & + f3 = bds%angtork(3+k, i) * dihef(k) + + if (.not. sk_ta) then + !$omp atomic update + grad(1, it_a) = grad(1, it_a) + f1 * Jt_a(1) + !$omp atomic update + grad(2, it_a) = grad(2, it_a) + f1 * Jt_a(2) + !$omp atomic update + grad(3, it_a) = grad(3, it_a) + f1 * Jt_a(3) + end if + + if (.not. sk_tb) then + !$omp atomic update + grad(1, it_b) = grad(1, it_b) + f1 * Jt_b(1) + !$omp atomic update + grad(2, it_b) = grad(2, it_b) + f1 * Jt_b(2) + !$omp atomic update + grad(3, it_b) = grad(3, it_b) + f1 * Jt_b(3) + end if + if (.not. sk_tc) then + !$omp atomic update + grad(1, it_c) = grad(1, it_c) + f1 * Jt_c(1) + !$omp atomic update + grad(2, it_c) = grad(2, it_c) + f1 * Jt_c(2) + !$omp atomic update + grad(3, it_c) = grad(3, it_c) + f1 * Jt_c(3) + end if + if (.not. sk_td) then + !$omp atomic update + grad(1, it_d) = grad(1, it_d) + f1 * Jt_d(1) + !$omp atomic update + grad(2, it_d) = grad(2, it_d) + f1 * Jt_d(2) + !$omp atomic update + grad(3, it_d) = grad(3, it_d) + f1 * Jt_d(3) + end if + + if (.not. sk_1a) then + !$omp atomic update + grad(1, ia1_a) = grad(1, ia1_a) + f2 * Ja1_a(1) + !$omp atomic update + grad(2, ia1_a) = grad(2, ia1_a) + f2 * Ja1_a(2) + !$omp atomic update + grad(3, ia1_a) = grad(3, ia1_a) + f2 * Ja1_a(3) + end if + if (.not. sk_1b) then + !$omp atomic update + grad(1, ia1_b) = grad(1, ia1_b) + f2 * Ja1_b(1) + !$omp atomic update + grad(2, ia1_b) = grad(2, ia1_b) + f2 * Ja1_b(2) + !$omp atomic update + grad(3, ia1_b) = grad(3, ia1_b) + f2 * Ja1_b(3) + end if + if (.not. sk_1c) then + !$omp atomic update + grad(1, ia1_c) = grad(1, ia1_c) + f2 * Ja1_c(1) + !$omp atomic update + grad(2, ia1_c) = grad(2, ia1_c) + f2 * Ja1_c(2) + !$omp atomic update + grad(3, ia1_c) = grad(3, ia1_c) + f2 * Ja1_c(3) + end if + + if (.not. sk_2a) then + !$omp atomic update + grad(1, ia2_a) = grad(1, ia2_a) + f3 * Ja2_a(1) + !$omp atomic update + grad(2, ia2_a) = grad(2, ia2_a) + f3 * Ja2_a(2) + !$omp atomic update + grad(3, ia2_a) = grad(3, ia2_a) + f3 * Ja2_a(3) + end if + if (.not. sk_2b) then + !$omp atomic update + grad(1, ia2_b) = grad(1, ia2_b) + f3 * Ja2_b(1) + !$omp atomic update + grad(2, ia2_b) = grad(2, ia2_b) + f3 * Ja2_b(2) + !$omp atomic update + grad(3, ia2_b) = grad(3, ia2_b) + f3 * Ja2_b(3) + end if + if (.not. sk_2c) then + !$omp atomic update + grad(1, ia2_c) = grad(1, ia2_c) + f3 * Ja2_c(1) + !$omp atomic update + grad(2, ia2_c) = grad(2, ia2_c) + f3 * Ja2_c(2) + !$omp atomic update + grad(3, ia2_c) = grad(3, ia2_c) + f3 * Ja2_c(3) + end if + end do + end do + end subroutine angtor_geomgrad + + subroutine strtor_potential(bds, V) + use mod_constants + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: V + real(rp) :: thet, costhet, dihef(3), dr(3), r(3), vst + integer(ip) :: i, j, k, ib1, ib2, ib3 + + if(.not. bds%use_strtor) return + + !$omp parallel do default(shared) reduction(+:V) & + !$omp private(i,costhet,thet,j,dihef,ib1,ib2,ib3,r,dr,vst,k) + do i=1, bds%nstrtor + ! Atoms that defines the dihedral angle + costhet = cos_torsion(bds%top, bds%strtorat(:,i)) + thet = acos(costhet) + do j=1, 3 + dihef(j) = 1.0 + cos(j*thet+bds%torsphase(j,bds%strtor_t(i))) + end do + + ib1 = bds%strtor_b(1,i) + ib2 = bds%strtor_b(2,i) + ib3 = bds%strtor_b(3,i) + r(1) = norm2(bds%top%cmm(:, bds%bondat(1,ib1)) - & + bds%top%cmm(:, bds%bondat(2,ib1))) + r(2) = norm2(bds%top%cmm(:, bds%bondat(1,ib2)) - & + bds%top%cmm(:, bds%bondat(2,ib2))) + r(3) = norm2(bds%top%cmm(:, bds%bondat(1,ib3)) - & + bds%top%cmm(:, bds%bondat(2,ib3))) + dr(1) = r(1) - bds%l0bond(ib1) + dr(2) = r(2) - bds%l0bond(ib2) + dr(3) = r(3) - bds%l0bond(ib3) + + do j=1,3 + vst = 0.0 + do k=1, 3 + vst = vst + bds%strtork((j-1)*3+k,i) * dihef(k) + end do + V = V + vst * dr(j) + end do + end do + + end subroutine strtor_potential + + subroutine strtor_geomgrad(bds, grad) + use mod_jacobian_mat, only: Rij_jacobian, torsion_angle_jacobian + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: grad(3, bds%top%mm_atoms) + !! improper torsion potential, result will be added to V + + real(rp) :: thet, gt(3), dihef(3), dr1, dr2, dr3, r1, r2, r3, & + Jt_a(3), Jt_b(3), Jt_c(3), Jt_d(3), & + Jb1_a(3), Jb1_b(3), & + Jb2_a(3), Jb2_b(3), & + Jb3_a(3), Jb3_b(3) + + integer(ip) :: i, j, k, ib1, ib2, ib3, & + it_a, it_b, it_c, it_d, & + ib1_a, ib1_b, & + ib2_a, ib2_b, & + ib3_a, ib3_b + logical :: sk_ta, sk_tb, sk_tc, sk_td, & + sk_1a, sk_1b, & + sk_2a, sk_2b, & + sk_3a, sk_3b + + if (.not. bds%use_strtor) return + + !$omp parallel do default(shared) & + !$omp private(thet, gt, dihef, dr1, dr2, dr3, r1, r2, r3) & + !$omp private(Jt_a, Jt_b, Jt_c, Jt_d, Jb1_a, Jb1_b, Jb2_a, Jb2_b) & + !$omp private(Jb3_a, Jb3_b, i, j, k, ib1, ib2, ib3, it_a, it_b, it_c, it_d) & + !$omp private(ib1_a, ib1_b, ib2_a, ib2_b, ib3_a, ib3_b, sk_ta, sk_tb, sk_tc, sk_td) & + !$omp private(sk_1a, sk_1b, sk_2a, sk_2b, sk_3a, sk_3b) + do i = 1, bds%nstrtor + ! Atoms that define the dihedral angle + it_a = bds%strtorat(1, i) + it_b = bds%strtorat(2, i) + it_c = bds%strtorat(3, i) + it_d = bds%strtorat(4, i) + + ib1 = bds%strtor_b(1, i) + ib1_a = bds%bondat(1, ib1) + ib1_b = bds%bondat(2, ib1) + + ib2 = bds%strtor_b(2, i) + ib2_a = bds%bondat(1, ib2) + ib2_b = bds%bondat(2, ib2) + + ib3 = bds%strtor_b(3, i) + ib3_a = bds%bondat(1, ib3) + ib3_b = bds%bondat(2, ib3) + + if (bds%top%use_frozen) then + sk_ta = bds%top%frozen(it_a) + sk_tb = bds%top%frozen(it_b) + sk_tc = bds%top%frozen(it_c) + sk_td = bds%top%frozen(it_d) + + sk_1a = bds%top%frozen(ib1_a) + sk_1b = bds%top%frozen(ib1_b) + + sk_2a = bds%top%frozen(ib2_a) + sk_2b = bds%top%frozen(ib2_b) + + sk_3a = bds%top%frozen(ib3_a) + sk_3b = bds%top%frozen(ib3_b) + + if (sk_ta .and. sk_tb .and. sk_tc .and. sk_td .and. & + sk_1a .and. sk_1b .and. & + sk_2a .and. sk_2b .and. & + sk_3a .and. sk_3b) cycle + else + sk_ta = .false. + sk_tb = .false. + sk_tc = .false. + sk_td = .false. + sk_1a = .false. + sk_1b = .false. + sk_2a = .false. + sk_2b = .false. + sk_3a = .false. + sk_3b = .false. + end if + + call torsion_angle_jacobian(bds%top%cmm(:, it_a), & + bds%top%cmm(:, it_b), & + bds%top%cmm(:, it_c), & + bds%top%cmm(:, it_d), & + thet, Jt_a, Jt_b, Jt_c, Jt_d) + do j = 1, 3 + gt(j) = -real(j) * sin(j * thet + bds%torsphase(j, bds%angtor_t(i))) + dihef(j) = 1.0 + cos(j * thet + bds%torsphase(j, bds%angtor_t(i))) + end do + + call Rij_jacobian(bds%top%cmm(:, ib1_a), & + bds%top%cmm(:, ib1_b), & + r1, Jb1_a, Jb1_b) + dr1 = r1 - bds%l0bond(ib1) + + call Rij_jacobian(bds%top%cmm(:, ib2_a), & + bds%top%cmm(:, ib2_b), & + r2, Jb2_a, Jb2_b) + dr2 = r2 - bds%l0bond(ib2) + + call Rij_jacobian(bds%top%cmm(:, ib3_a), & + bds%top%cmm(:, ib3_b), & + r3, Jb3_a, Jb3_b) + dr3 = r3 - bds%l0bond(ib3) + + do k = 1, 3 + if (.not. sk_ta) then + !$omp atomic update + grad(1, it_a) = grad(1, it_a) + bds%strtork(k, i) * dr1 * gt(k) * Jt_a(1) + !$omp atomic update + grad(2, it_a) = grad(2, it_a) + bds%strtork(k, i) * dr1 * gt(k) * Jt_a(2) + !$omp atomic update + grad(3, it_a) = grad(3, it_a) + bds%strtork(k, i) * dr1 * gt(k) * Jt_a(3) + end if + if (.not. sk_tb) then + !$omp atomic update + grad(1, it_b) = grad(1, it_b) + bds%strtork(k, i) * dr1 * gt(k) * Jt_b(1) + !$omp atomic update + grad(2, it_b) = grad(2, it_b) + bds%strtork(k, i) * dr1 * gt(k) * Jt_b(2) + !$omp atomic update + grad(3, it_b) = grad(3, it_b) + bds%strtork(k, i) * dr1 * gt(k) * Jt_b(3) + end if + if (.not. sk_tc) then + !$omp atomic update + grad(1, it_c) = grad(1, it_c) + bds%strtork(k, i) * dr1 * gt(k) * Jt_c(1) + !$omp atomic update + grad(2, it_c) = grad(2, it_c) + bds%strtork(k, i) * dr1 * gt(k) * Jt_c(2) + !$omp atomic update + grad(3, it_c) = grad(3, it_c) + bds%strtork(k, i) * dr1 * gt(k) * Jt_c(3) + end if + if (.not. sk_td) then + !$omp atomic update + grad(1, it_d) = grad(1, it_d) + bds%strtork(k, i) * dr1 * gt(k) * Jt_d(1) + !$omp atomic update + grad(2, it_d) = grad(2, it_d) + bds%strtork(k, i) * dr1 * gt(k) * Jt_d(2) + !$omp atomic update + grad(3, it_d) = grad(3, it_d) + bds%strtork(k, i) * dr1 * gt(k) * Jt_d(3) + end if + if (.not. sk_1a) then + !$omp atomic update + grad(1, ib1_a) = grad(1, ib1_a) + bds%strtork(k, i) * dihef(k) * Jb1_a(1) + !$omp atomic update + grad(2, ib1_a) = grad(2, ib1_a) + bds%strtork(k, i) * dihef(k) * Jb1_a(2) + !$omp atomic update + grad(3, ib1_a) = grad(3, ib1_a) + bds%strtork(k, i) * dihef(k) * Jb1_a(3) + end if + if (.not. sk_1b) then + !$omp atomic update + grad(1, ib1_b) = grad(1, ib1_b) + bds%strtork(k, i) * dihef(k) * Jb1_b(1) + !$omp atomic update + grad(2, ib1_b) = grad(2, ib1_b) + bds%strtork(k, i) * dihef(k) * Jb1_b(2) + !$omp atomic update + grad(3, ib1_b) = grad(3, ib1_b) + bds%strtork(k, i) * dihef(k) * Jb1_b(3) + end if + if (.not. sk_ta) then + !$omp atomic update + grad(1, it_a) = grad(1, it_a) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_a(1) + !$omp atomic update + grad(2, it_a) = grad(2, it_a) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_a(2) + !$omp atomic update + grad(3, it_a) = grad(3, it_a) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_a(3) + end if + if (.not. sk_tb) then + !$omp atomic update + grad(1, it_b) = grad(1, it_b) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_b(1) + !$omp atomic update + grad(2, it_b) = grad(2, it_b) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_b(2) + !$omp atomic update + grad(3, it_b) = grad(3, it_b) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_b(3) + end if + if (.not. sk_tc) then + !$omp atomic update + grad(1, it_c) = grad(1, it_c) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_c(1) + !$omp atomic update + grad(2, it_c) = grad(2, it_c) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_c(2) + !$omp atomic update + grad(3, it_c) = grad(3, it_c) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_c(3) + end if + if (.not. sk_td) then + !$omp atomic update + grad(1, it_d) = grad(1, it_d) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_d(1) + !$omp atomic update + grad(2, it_d) = grad(2, it_d) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_d(2) + !$omp atomic update + grad(3, it_d) = grad(3, it_d) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_d(3) + end if + if (.not. sk_2a) then + !$omp atomic update + grad(1, ib2_a) = grad(1, ib2_a) + bds%strtork(3 + k, i) * dihef(k) * Jb2_a(1) + !$omp atomic update + grad(2, ib2_a) = grad(2, ib2_a) + bds%strtork(3 + k, i) * dihef(k) * Jb2_a(2) + !$omp atomic update + grad(3, ib2_a) = grad(3, ib2_a) + bds%strtork(3 + k, i) * dihef(k) * Jb2_a(3) + end if + if (.not. sk_2b) then + !$omp atomic update + grad(1, ib2_b) = grad(1, ib2_b) + bds%strtork(3 + k, i) * dihef(k) * Jb2_b(1) + !$omp atomic update + grad(2, ib2_b) = grad(2, ib2_b) + bds%strtork(3 + k, i) * dihef(k) * Jb2_b(2) + !$omp atomic update + grad(3, ib2_b) = grad(3, ib2_b) + bds%strtork(3 + k, i) * dihef(k) * Jb2_b(3) + end if + if (.not. sk_ta) then + !$omp atomic update + grad(1, it_a) = grad(1, it_a) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_a(1) + !$omp atomic update + grad(2, it_a) = grad(2, it_a) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_a(2) + !$omp atomic update + grad(3, it_a) = grad(3, it_a) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_a(3) + end if + if (.not. sk_tb) then + !$omp atomic update + grad(1, it_b) = grad(1, it_b) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_b(1) + !$omp atomic update + grad(2, it_b) = grad(2, it_b) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_b(2) + !$omp atomic update + grad(3, it_b) = grad(3, it_b) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_b(3) + end if + if (.not. sk_tc) then + !$omp atomic update + grad(1, it_c) = grad(1, it_c) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_c(1) + !$omp atomic update + grad(2, it_c) = grad(2, it_c) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_c(2) + !$omp atomic update + grad(3, it_c) = grad(3, it_c) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_c(3) + end if + if (.not. sk_td) then + !$omp atomic update + grad(1, it_d) = grad(1, it_d) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_d(1) + !$omp atomic update + grad(2, it_d) = grad(2, it_d) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_d(2) + !$omp atomic update + grad(3, it_d) = grad(3, it_d) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_d(3) + end if + if (.not. sk_3a) then + !$omp atomic update + grad(1, ib3_a) = grad(1, ib3_a) + bds%strtork(6 + k, i) * dihef(k) * Jb3_a(1) + !$omp atomic update + grad(2, ib3_a) = grad(2, ib3_a) + bds%strtork(6 + k, i) * dihef(k) * Jb3_a(2) + !$omp atomic update + grad(3, ib3_a) = grad(3, ib3_a) + bds%strtork(6 + k, i) * dihef(k) * Jb3_a(3) + end if + if (.not. sk_3b) then + !$omp atomic update + grad(1, ib3_b) = grad(1, ib3_b) + bds%strtork(6 + k, i) * dihef(k) * Jb3_b(1) + !$omp atomic update + grad(2, ib3_b) = grad(2, ib3_b) + bds%strtork(6 + k, i) * dihef(k) * Jb3_b(2) + !$omp atomic update + grad(3, ib3_b) = grad(3, ib3_b) + bds%strtork(6 + k, i) * dihef(k) * Jb3_b(3) + end if + end do + end do + end subroutine strtor_geomgrad + + + subroutine tortor_init(bds, n) + !! Initialize torsion-torsion correction potential arrays + + use mod_memory, only: mallocate + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + integer(ip) :: n + !! Number of torsion-torsion 'map' functions in the potential + !! energy of the system + + if( n < 1 ) return + bds%use_tortor = .true. + + call mallocate('torsion_init [tortorprm]', n, bds%tortorprm ) + call mallocate('torsion_init [tortorat]', 5, n, bds%tortorat) + + bds%ntortor = n + + end subroutine tortor_init + + subroutine tortor_newmap(bds, d1, d2, ang1, ang2, v) + !! Store in module memory the data describing a new torsion-torsion + !! map + use mod_memory, only: mallocate, mfree + use mod_utils, only: cyclic_spline + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + integer(ip), intent(in) :: d1, d2 + !! Dimensions of the new map to be saved + real(rp), intent(in) :: ang1(:) + !! Value of torsion1 for the new map + real(rp), intent(in) :: ang2(:) + !! Value of torsion2 for the new map + real(rp), intent(in) :: v(:) + !! Value of potential for the new map + + integer :: i, j, ii + real(rp), allocatable, dimension(:) :: a, b, c, d, dx, dy, dxy, tmpx, tmpy + + real(rp), allocatable :: rtmp(:) + integer(ip), allocatable :: itmp(:,:) + integer(ip) :: n_data, n_map + + if(allocated(bds%ttmap_ang1)) then + ! Reallocate the arrays to make space for the new data + n_data = size(bds%ttmap_ang1) + call mallocate('torstors_newmap [rtmp]', n_data, rtmp) + + rtmp = bds%ttmap_ang1 + call mfree('torstors_newmap [ttmap_ang1]', bds%ttmap_ang1) + call mallocate('torstors_newmap [ttmap_ang1]', & + n_data+d1*d2, bds%ttmap_ang1) + bds%ttmap_ang1(:n_data) = rtmp + + rtmp = bds%ttmap_ang2 + call mfree('torstors_newmap [ttmap_ang2]', bds%ttmap_ang2) + call mallocate('torstors_newmap [ttmap_ang2]', & + n_data+d1*d2, bds%ttmap_ang2) + bds%ttmap_ang2(:n_data) = rtmp + + + call mfree('torstors_newmap [rtmp]', rtmp) + n_data = size(bds%ttmap_v) + call mallocate('torstors_newmap [rtmp]', n_data, rtmp) + + rtmp = bds%ttmap_v + call mfree('torstors_newmap [ttmap_v]', bds%ttmap_v) + call mallocate('torstors_newmap [ttmap_v]', & + n_data+d1*d2, bds%ttmap_v) + bds%ttmap_v(:n_data) = rtmp + + rtmp = bds%ttmap_vx + call mfree('torstors_newmap [ttmap_vx]', bds%ttmap_vx) + call mallocate('torstors_newmap [ttmap_vx]', & + n_data+d1*d2, bds%ttmap_vx) + bds%ttmap_vx(:n_data) = rtmp + + rtmp = bds%ttmap_vy + call mfree('torstors_newmap [ttmap_vy]', bds%ttmap_vy) + call mallocate('torstors_newmap [ttmap_vy]', & + n_data+d1*d2, bds%ttmap_vy) + bds%ttmap_vy(:n_data) = rtmp + + rtmp = bds%ttmap_vxy + call mfree('torstors_newmap [ttmap_vxy]', bds%ttmap_vxy) + call mallocate('torstors_newmap [ttmap_vxy]', & + n_data+d1*d2, bds%ttmap_vxy) + bds%ttmap_vxy(:n_data) = rtmp + call mfree('torstors_newmap [rtmp]', rtmp) + + n_map = size(bds%ttmap_shape, 2) + call mallocate('torstors_newmap [itmp]', 2, n_map, itmp) + itmp = bds%ttmap_shape + call mfree('torstors_newmap [ttmap_shape]', bds%ttmap_shape) + call mallocate('torstors_newmap [ttmap_shape]', & + 2, n_map+1, bds%ttmap_shape) + bds%ttmap_shape(:,:n_map) = itmp + + call mfree('torstors_newmap [itmp]', itmp) + else + ! First allocation, n_data and n_map are just set for consistency + n_data = 0 + n_map = 0 + call mallocate('torstors_newmap [ttmap_ang1]', d1*d2, bds%ttmap_ang1) + call mallocate('torstors_newmap [ttmap_ang2]', d1*d2, bds%ttmap_ang2) + call mallocate('torstors_newmap [ttmap_v]', d1*d2, bds%ttmap_v) + call mallocate('torstors_newmap [ttmap_vx]', d1*d2, bds%ttmap_vx) + call mallocate('torstors_newmap [ttmap_vy]', d1*d2, bds%ttmap_vy) + call mallocate('torstors_newmap [ttmap_vxy]', d1*d2, bds%ttmap_vxy) + call mallocate('torstors_newmap [ttmap_shape]', 2, 1, bds%ttmap_shape) + end if + + call mallocate('tortor_newmap [a]', max(d1,d2), a) + call mallocate('tortor_newmap [b]', max(d1,d2), b) + call mallocate('tortor_newmap [c]', max(d1,d2), c) + call mallocate('tortor_newmap [d]', max(d1,d2), d) + call mallocate('tortor_newmap [dx]', d1*d2, dx) + call mallocate('tortor_newmap [dy]', d1*d2, dy) + call mallocate('tortor_newmap [dxy]', d1*d2, dxy) + + ! This part of the code computes df/dx, df/dy and d^2f/dxdy on the grid. + ! Since we are basically interpolating on a sphere, we extract the + ! coordinate on a meridian, we interpolate it with a cubic spline, and + ! finally we compute the derivative of this curve at the grid intersection + ! The same is done in the second direction. + ! To compute the mixed derivative we apply the same procedure but using + ! the derivative data (basically we apply the procedure used to compute + ! df/dx but using df/dy data instead of actual f values. + do i=1, d2 + call cyclic_spline(d1, ang1((i-1)*d1+1:i*d1), v((i-1)*d1+1:i*d1), & + a(1:d1), b(1:d1), c(1:d1), d(1:d1)) + dx((i-1)*d1+1:i*d1) = b(1:d1) + end do + + ! df/dy since in this direction data are not contiguous, wa allocate + ! temporary arrays + call mallocate('tortor_newmap [tmpx]', d2, tmpx) + call mallocate('tortor_newmap [tmpy]', d2, tmpy) + do i=1, d1 + ii = 1 + do j=i, (d2-1)*d1+i, d2 + tmpx(ii) = ang2(j) + tmpy(ii) = v(j) + ii = ii + 1 + end do + call cyclic_spline(d2, tmpx, tmpy, & + a(1:d2), b(1:d2), c(1:d2), d(1:d2)) + + ii = 1 + do j=i, (d2-1)*d1+i, d2 + dy(j) = b(ii) + ii = ii + 1 + end do + end do + + ! d^2f/dxdy in this case we use df/dx procedure to exploit data contiguity. + do i=1, d2 + call cyclic_spline(d1, ang1((i-1)*d1+1:i*d1), dy((i-1)*d1+1:i*d1), & + a(1:d1), b(1:d1), c(1:d1), d(1:d1)) + dxy((i-1)*d1+1:i*d1) = b(1:d1) + end do + call mfree('tortor_newmap [tmpx]', tmpx) + call mfree('tortor_newmap [tmpy]', tmpy) + + bds%ttmap_ang1(n_data+1:) = ang1 + bds%ttmap_ang2(n_data+1:) = ang2 + bds%ttmap_shape(1,n_map+1) = d1 + bds%ttmap_shape(2,n_map+1) = d2 + bds%ttmap_v(n_data+1:) = v + bds%ttmap_vx(n_data+1:) = dx + bds%ttmap_vy(n_data+1:) = dy + bds%ttmap_vxy(n_data+1:) = dxy + + call mfree('tortor_newmap [a]', a) + call mfree('tortor_newmap [b]', b) + call mfree('tortor_newmap [c]', c) + call mfree('tortor_newmap [d]', d) + call mfree('tortor_newmap [dx]', dx) + call mfree('tortor_newmap [dy]', dy) + call mfree('tortor_newmap [dxy]', dxy) + + end subroutine tortor_newmap + + subroutine tortor_potential(bds, V) + !! Compute torsion potential + + use mod_utils, only: compute_bicubic_interp + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: V + !! torsion potential, result will be added to V + real(rp) :: thetx, thety, vtt, dvttdx, dvttdy + + integer(ip) :: i, j, iprm, ibeg, iend + + if(.not. bds%use_tortor) return + + !$omp parallel do default(shared) reduction(+:V) & + !$omp private(i,iprm,ibeg,j,iend,thetx,thety,vtt,dvttdx,dvttdy) + do i=1, bds%ntortor + ! Atoms that defines the two angles + iprm = bds%tortorprm(i) + ibeg = 1 + do j=1, iprm-1 + ibeg = ibeg + bds%ttmap_shape(1,j)*bds%ttmap_shape(2,j) + end do + iend = ibeg + bds%ttmap_shape(1,iprm)*bds%ttmap_shape(2,iprm) - 1 + + thetx = ang_torsion(bds%top, bds%tortorat(1:4,i)) + thety = ang_torsion(bds%top, bds%tortorat(2:5,i)) + + call compute_bicubic_interp(thetx, thety, vtt, & + dvttdx, dvttdy, & + bds%ttmap_shape(1,iprm), & + bds%ttmap_shape(2,iprm), & + bds%ttmap_ang1(ibeg:iend), & + bds%ttmap_ang2(ibeg:iend), & + bds%ttmap_v(ibeg:iend), & + bds%ttmap_vx(ibeg:iend), & + bds%ttmap_vy(ibeg:iend), & + bds%ttmap_vxy(ibeg:iend)) + + V = V + vtt + end do + + end subroutine tortor_potential + + subroutine tortor_geomgrad(bds, grad) + !! Compute torsion potential + + use mod_utils, only: compute_bicubic_interp + use mod_jacobian_mat, only: torsion_angle_jacobian + + implicit none + + type(ommp_bonded_type), intent(in) :: bds + ! Bonded potential data structure + real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) + !! improper torsion potential, result will be added to V + real(rp) :: thetx, thety, vtt, dvttdx, dvttdy + real(rp), dimension(3) :: J1_a, J1_b, J2_b, J1_c, & + J2_c, J1_d, J2_d, J2_e + + integer(ip) :: i, j, iprm, ibeg, iend, ia, ib, ic, id, ie + logical :: sk_a, sk_b, sk_c, sk_d, sk_e + + if(.not. bds%use_tortor) return + + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,iprm,ibeg,j,iend,ia,ib,ic,id,ie,sk_a,sk_b,sk_c,sk_d,sk_e) & + !$omp private(thetx,thety,J1_a,J1_b,J1_c,J1_d,J2_b,J2_c,J2_d,J2_e,vtt,dvttdx,dvttdy) + do i=1, bds%ntortor + ! Atoms that defines the two angles + iprm = bds%tortorprm(i) + ibeg = 1 + do j=1, iprm-1 + ibeg = ibeg + bds%ttmap_shape(1,j)*bds%ttmap_shape(2,j) + end do + iend = ibeg + bds%ttmap_shape(1,iprm)*bds%ttmap_shape(2,iprm) - 1 + + ia = bds%tortorat(1,i) + ib = bds%tortorat(2,i) + ic = bds%tortorat(3,i) + id = bds%tortorat(4,i) + ie = bds%tortorat(5,i) + + if(bds%top%use_frozen) then + sk_a = bds%top%frozen(ia) + sk_b = bds%top%frozen(ib) + sk_c = bds%top%frozen(ic) + sk_d = bds%top%frozen(id) + sk_e = bds%top%frozen(ie) + if(sk_a .and. sk_b .and. sk_c .and. sk_d .and. sk_e) cycle + else + sk_a = .false. + sk_b = .false. + sk_c = .false. + sk_d = .false. + sk_e = .false. + end if + + call torsion_angle_jacobian(bds%top%cmm(:,ia), & + bds%top%cmm(:,ib), & + bds%top%cmm(:,ic), & + bds%top%cmm(:,id), & + thetx, & + J1_a, J1_b, J1_c, J1_d) + thetx = ang_torsion(bds%top, bds%tortorat(1:4,i)) + + call torsion_angle_jacobian(bds%top%cmm(:,ib), & + bds%top%cmm(:,ic), & + bds%top%cmm(:,id), & + bds%top%cmm(:,ie), & + thety, & + J2_b, J2_c, J2_d, J2_e) + thety = ang_torsion(bds%top, bds%tortorat(2:5,i)) + + call compute_bicubic_interp(thetx, thety, vtt, & + dvttdx, dvttdy, & + bds%ttmap_shape(1,iprm), & + bds%ttmap_shape(2,iprm), & + bds%ttmap_ang1(ibeg:iend), & + bds%ttmap_ang2(ibeg:iend), & + bds%ttmap_v(ibeg:iend), & + bds%ttmap_vx(ibeg:iend), & + bds%ttmap_vy(ibeg:iend), & + bds%ttmap_vxy(ibeg:iend)) + + + if(.not. sk_a) then + !$omp atomic update + grad(1,ia) = grad(1,ia) + J1_a(1) * dvttdx + !$omp atomic update + grad(2,ia) = grad(2,ia) + J1_a(2) * dvttdx + !$omp atomic update + grad(3,ia) = grad(3,ia) + J1_a(3) * dvttdx + end if + if(.not. sk_b) then + !$omp atomic update + grad(1,ib) = grad(1,ib) + J1_b(1) * dvttdx + J2_b(1) * dvttdy + !$omp atomic update + grad(2,ib) = grad(2,ib) + J1_b(2) * dvttdx + J2_b(2) * dvttdy + !$omp atomic update + grad(3,ib) = grad(3,ib) + J1_b(3) * dvttdx + J2_b(3) * dvttdy + end if + if(.not. sk_c) then + !$omp atomic update + grad(1,ic) = grad(1,ic) + J1_c(1) * dvttdx + J2_c(1) * dvttdy + !$omp atomic update + grad(2,ic) = grad(2,ic) + J1_c(2) * dvttdx + J2_c(2) * dvttdy + !$omp atomic update + grad(3,ic) = grad(3,ic) + J1_c(3) * dvttdx + J2_c(3) * dvttdy + end if + if(.not. sk_d) then + !$omp atomic update + grad(1,id) = grad(1,id) + J1_d(1) * dvttdx + J2_d(1) * dvttdy + !$omp atomic update + grad(2,id) = grad(2,id) + J1_d(2) * dvttdx + J2_d(2) * dvttdy + !$omp atomic update + grad(3,id) = grad(3,id) + J1_d(3) * dvttdx + J2_d(3) * dvttdy + end if + if(.not. sk_e) then + !$omp atomic update + grad(1,ie) = grad(1,ie) + J2_e(1) * dvttdy + !$omp atomic update + grad(2,ie) = grad(2,ie) + J2_e(2) * dvttdy + !$omp atomic update + grad(3,ie) = grad(3,ie) + J2_e(3) * dvttdy + end if + end do + + end subroutine tortor_geomgrad + + pure function cos_torsion(top, idx) + !! Compute the cosine of torsional angle between four atoms specified + !! with indices idx + + implicit none + + type(ommp_topology_type), intent(in) :: top + integer(ip), intent(in) :: idx(4) + real(rp) :: cos_torsion + + real(rp), dimension(3) :: a, b, c, d, ab, cd, cb, t, u + + a = top%cmm(:,idx(1)) + b = top%cmm(:,idx(2)) + c = top%cmm(:,idx(3)) + d = top%cmm(:,idx(4)) + + ab = b - a + cd = d - c + cb = b - c + + t(1) = ab(2)*cb(3) - ab(3)*cb(2) + t(2) = ab(3)*cb(1) - ab(1)*cb(3) + t(3) = ab(1)*cb(2) - ab(2)*cb(1) + t = t / norm2(t) + + u(1) = cb(2)*cd(3) - cb(3)*cd(2) + u(2) = cb(3)*cd(1) - cb(1)*cd(3) + u(3) = cb(1)*cd(2) - cb(2)*cd(1) + u = u / norm2(u) + + cos_torsion = dot_product(u,t) + return + + end function + + pure function ang_torsion(top, idx) + !! Compute the torsional angle between four atoms specified + !! with indices idx; results are in range [-pi;pi] + + implicit none + + type(ommp_topology_type), intent(in) :: top + integer(ip), intent(in) :: idx(4) + real(rp) :: cos_torsion, ang_torsion + + real(rp), dimension(3) :: a, b, c, d, ab, cd, cb, t, u + + a = top%cmm(:,idx(1)) + b = top%cmm(:,idx(2)) + c = top%cmm(:,idx(3)) + d = top%cmm(:,idx(4)) + + ab = b - a + cd = d - c + cb = b - c + + t(1) = ab(2)*cb(3) - ab(3)*cb(2) + t(2) = ab(3)*cb(1) - ab(1)*cb(3) + t(3) = ab(1)*cb(2) - ab(2)*cb(1) + t = t / norm2(t) + + u(1) = cb(2)*cd(3) - cb(3)*cd(2) + u(2) = cb(3)*cd(1) - cb(1)*cd(3) + u(3) = cb(1)*cd(2) - cb(2)*cd(1) + u = u / norm2(u) + + cos_torsion = dot_product(u,t) + ang_torsion = acos(cos_torsion) + !if(dot_product(ab, u) > 0) ang_torsion = - ang_torsion + ang_torsion = ang_torsion * sign(1.0_rp, -dot_product(ab,u)) + + end function + + subroutine bonded_terminate(bds) + !! Just terminate every "submodule" in bonded, + !! deallocating arrays and disabling the potential terms + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + + call bond_terminate(bds) + call angle_terminate(bds) + call strbnd_terminate(bds) + call urey_terminate(bds) + call opb_terminate(bds) + call pitors_terminate(bds) + call torsion_terminate(bds) + call imptorsion_terminate(bds) + call tortor_terminate(bds) + call angtor_terminate(bds) + call strtor_terminate(bds) + + end subroutine bonded_terminate + + subroutine bond_terminate(bds) + use mod_memory, only: mfree + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + if( .not. bds%use_bond ) return + + bds%use_bond = .false. + call mfree('bond_terminate [bondat]', bds%bondat) + call mfree('bond_terminate [kbond]', bds%kbond) + call mfree('bond_terminate [l0bond]', bds%l0bond) + + end subroutine bond_terminate + + subroutine angle_terminate(bds) + use mod_memory, only: mfree + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + if( .not. bds%use_angle ) return + + bds%use_angle = .false. + call mfree('angle_terminate [angleat]', bds%angleat) + call mfree('angle_terminate [anglety]', bds%anglety) + call mfree('angle_terminate [angauxat]', bds%angauxat) + call mfree('angle_terminate [kangle]', bds%kangle) + call mfree('angle_terminate [eqangle]', bds%eqangle) + + end subroutine angle_terminate + + subroutine strbnd_terminate(bds) + use mod_memory, only: mfree + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + if( .not. bds%use_strbnd ) return + + bds%use_strbnd = .false. + call mfree('strbnd_terminate [strbndat]', bds%strbndat) + call mfree('strbnd_terminate [strbndl10]', bds%strbndl10) + call mfree('strbnd_terminate [strbndl20]', bds%strbndl20) + call mfree('strbnd_terminate [strbndthet0]', bds%strbndthet0) + call mfree('strbnd_terminate [strbndk1]', bds%strbndk1) + call mfree('strbnd_terminate [strbndk2]', bds%strbndk2) + + end subroutine strbnd_terminate + + subroutine urey_terminate(bds) + use mod_memory, only: mfree + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + if( .not. bds%use_urey ) return + + bds%use_urey = .false. + call mfree('urey_terminate [ureya]', bds%ureyat) + call mfree('urey_terminate [kurey]', bds%kurey) + call mfree('urey_terminate [l0urey]', bds%l0urey) + + end subroutine urey_terminate + + subroutine opb_terminate(bds) + use mod_memory, only: mfree + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + if( .not. bds%use_opb ) return + + bds%use_opb = .false. + call mfree('opb_terminate [opbat]', bds%opbat) + call mfree('opb_terminate [kopb]', bds%kopb) + + end subroutine opb_terminate + + subroutine pitors_terminate(bds) + use mod_memory, only: mfree + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + if( .not. bds%use_pitors ) return + + bds%use_pitors = .false. + call mfree('pitors_terminate [pitorsat]', bds%pitorsat) + call mfree('p_terminate [kpitors]', bds%kpitors) + + end subroutine pitors_terminate + + subroutine torsion_terminate(bds) + use mod_memory, only: mfree + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + if( .not. bds%use_torsion ) return + + bds%use_torsion = .false. + call mfree('torsion_terminate [torsionat]', bds%torsionat) + call mfree('torsion_terminate [torsamp]', bds%torsamp) + call mfree('torsion_terminate [torsphase]', bds%torsphase) + call mfree('torsion_terminate [torsn]', bds%torsn) + + end subroutine torsion_terminate + + subroutine imptorsion_terminate(bds) + use mod_memory, only: mfree + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + if( .not. bds%use_imptorsion ) return + + bds%use_imptorsion = .false. + call mfree('imptorsion_terminate [imptorsionat]', bds%imptorsionat) + call mfree('imptorsion_terminate [imptorsamp]', bds%imptorsamp) + call mfree('imptorsion_terminate [imptorsphase]', bds%imptorsphase) + call mfree('imptorsion_terminate [imptorsn]', bds%imptorsn) + + end subroutine imptorsion_terminate + + subroutine tortor_terminate(bds) + use mod_memory, only: mfree + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + if( .not. bds%use_tortor ) return + + bds%use_tortor = .false. + call mfree('tortor_terminate [tortorprm]', bds%tortorprm ) + call mfree('tortor_terminate [tortorat]', bds%tortorat) + call mfree('tortor_terminate [ttmap_shape]', bds%ttmap_shape) + call mfree('tortor_terminate [ttmap_ang1]', bds%ttmap_ang1) + call mfree('tortor_terminate [ttmap_ang2]', bds%ttmap_ang2) + call mfree('tortor_terminate [ttmap_v]', bds%ttmap_v) + call mfree('tortor_terminate [ttmap_vx]', bds%ttmap_vx) + call mfree('tortor_terminate [ttmap_vy]', bds%ttmap_vy) + call mfree('tortor_terminate [ttmap_vxy]', bds%ttmap_vxy) + + end subroutine tortor_terminate + + subroutine angtor_terminate(bds) + use mod_memory, only: mfree + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + if( .not. bds%use_angtor ) return + + bds%use_angtor = .false. + call mfree('angtor_terminate [angtorat]', bds%angtorat) + call mfree('angtor_terminate [angtork]', bds%angtork) + call mfree('angtor_terminate [angtor_t]', bds%angtor_t) + call mfree('angtor_terminate [angtor_a]', bds%angtor_a) + + end subroutine angtor_terminate + + subroutine strtor_terminate(bds) + use mod_memory, only: mfree + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + ! Bonded potential data structure + if( .not. bds%use_strtor ) return + + bds%use_strtor = .false. + call mfree('strtor_terminate [strtorat]', bds%strtorat) + call mfree('strtor_terminate [strtork]', bds%strtork) + call mfree('strtor_terminate [strtor_t]', bds%strtor_t) + call mfree('strtor_terminate [strtor_b]', bds%strtor_b) + + end subroutine strtor_terminate + +end module mod_bonded diff --git a/src/mod_bonded.f90 b/src/mod_bonded.f90 deleted file mode 100644 index 1b6fc09..0000000 --- a/src/mod_bonded.f90 +++ /dev/null @@ -1,2903 +0,0 @@ -module mod_bonded - !! Module to handle the bonded part of the FF, it closely follows the - !! AMOEBA functional form. - - use mod_memory, only: ip, rp, lp - use mod_topology, only: ommp_topology_type - use mod_io, only: fatal_error - - implicit none - private - - ! Those constants are used as shorthand for the type of angle parameter - ! that is used for a certain term. They consider two aspects: the functional - ! form that could be a simple armonic constaint on the angle or something - ! more involved (as the \testit{in-plane}) angle); the second aspects is - ! the hydrogen-environment that is the introduction of different force - ! constatns when the central atom is connected to a different number of - ! hydrogen atoms. - integer(ip), parameter, public :: OMMP_ANG_SIMPLE = 0 - !! Simple angle with no difference for hydrogen environments - integer(ip), parameter, public :: OMMP_ANG_H0 = 1 - !! Simple angle with two different hydrogen environments - integer(ip), parameter, public :: OMMP_ANG_H1 = 2 - !! Simple angle with three different hydrogen environments - integer(ip), parameter, public :: OMMP_ANG_H2 = 3 - !! Simple angle with four different hydrogen environments - integer(ip), parameter, public :: OMMP_ANG_INPLANE = 4 - !! In-plane angle with no difference for hydrogen environments - integer(ip), parameter, public :: OMMP_ANG_INPLANE_H0 = 5 - !! In-plane angle with two different hydrogen environments - integer(ip), parameter, public :: OMMP_ANG_INPLANE_H1 = 6 - !! In-plane angle with three different hydrogen environments - - type ommp_bonded_type - type(ommp_topology_type), pointer :: top - !! Data structure for topology - - ! Bond - integer(ip) :: nbond - !! Number of bond terms in the potential energy function - integer(ip), allocatable :: bondat(:,:) - !! Atoms involved in the ith bond term - real(rp) :: bond_cubic, bond_quartic - !! 3rd and 4th order terms coefficients, corresponding to - !! \(k^{(2)}\) and \(k^{(3)}\) - real(rp), allocatable :: kbond(:) - !! Force constants for bond terms - real(rp), allocatable :: l0bond(:) - !! Equilibrium lengths for bonds - logical(lp) :: use_bond = .false. - !! Flag to enable the calculation of bond terms in potential - !! energy function - - ! Angle - integer(ip) :: nangle - !! Number of angle terms in the potential energy function - integer(ip), allocatable :: angleat(:,:) - !! Atoms involved in the ith angle term - integer(ip), allocatable :: anglety(:) - !! Type of function to be used for ith angle term - integer(ip), allocatable :: angauxat(:) - !! Auxiliary atom to be used in calculaton of ith angle term - real(rp) :: angle_cubic, angle_quartic, angle_pentic, angle_sextic - !! Coefficients for 3rd to 6th order terms corresponding to - !! \(k^{(3)}\) ... \(k^{(6)}\). - real(rp), allocatable :: kangle(:) - !! Force constants for the ith angle term - real(rp), allocatable :: eqangle(:) - !! Equilibrium angle for the ith angle term - logical(lp) :: use_angle = .false. - !! Flag to enable the calculation of angle terms in potential energy - !! function - - ! Stretch-Bend - integer(ip) :: nstrbnd - !! Number of stretching-bending coupling terms in potential energy function - integer(ip), allocatable :: strbndat(:,:) - !! Atoms involved in the ith stretching-bending term - real(rp), allocatable :: strbndk1(:), strbndk2(:) - !! Force constants for the ith stretching-bending term (\(k_1\) and \(k_2\)) - real(rp), allocatable :: strbndthet0(:) - !! Equilibrium angle for the ith stretching-bending term - real(rp), allocatable :: strbndl10(:), strbndl20(:) - !! Equilibrium distances for the ith stretching-bending term - logical(lp) :: use_strbnd = .false. - !! Flag to enable calculation of stretching-bending coupling terms in - !! potential energy function - - ! Angle-Torsion coupling - integer(ip) :: nangtor - integer(ip), allocatable :: angtorat(:,:), angtor_t(:), angtor_a(:,:) - real(rp), allocatable :: angtork(:,:) - logical(lp) :: use_angtor = .false. - - ! Bond-Torsion coupling - integer(ip) :: nstrtor - integer(ip), allocatable :: strtorat(:,:), strtor_t(:), strtor_b(:,:) - real(rp), allocatable :: strtork(:,:) - logical(lp) :: use_strtor = .false. - - ! Urey-Bradley - integer(ip) :: nurey - !! Number of Urey-Bradley terms in potential energy function - integer(ip), allocatable :: ureyat(:,:) - !! Atoms involved in ith Urey-Bradley term - real(rp) :: urey_cubic, urey_quartic - !! 3rd and 4th order constants for U-B potential ( - !! \(k^{(3)}\) and \(k^{(4)}\)) - real(rp), allocatable :: kurey(:) - !! Force constants for U-B terms - real(rp), allocatable :: l0urey(:) - !! Equilibrium distance for U-B potentials - logical(lp) :: use_urey = .false. - !! Flag to enable calculation of U-B terms in the potential energy function - - ! Out-of-Plane Bending - integer(ip) :: nopb - !! Number of out-of-plane bending function in potential energy func. - integer(ip), allocatable :: opbat(:,:) - !! Atoms involved in ith oop bending function - real(rp) :: opb_cubic=0.0, opb_quartic=0.0, opb_pentic=0.0, opb_sextic=0.0 - !! Coefficients for 3rd to 6th order terms corresponding to - !! \(k^{(3)}\) ... \(k^{(6)}\) for out-of-plane bending. - real(rp), allocatable :: kopb(:) - !! Force constants for ith out-of plane bending - logical(lp) :: use_opb = .false. - !! Flag to enable out-of-plane bending calculation - - ! Pi-torsion - integer(ip) :: npitors - integer(ip), allocatable :: pitorsat(:,:) - real(rp), allocatable :: kpitors(:) - logical(lp) :: use_pitors = .false. - - ! Torsion - integer(ip) :: ntorsion - integer(ip), allocatable :: torsionat(:,:), torsn(:,:) - real(rp), allocatable :: torsamp(:,:), torsphase(:,:) - logical(lp) :: use_torsion = .false. - - ! Imporoper Torsion - integer(ip) :: nimptorsion - integer(ip), allocatable :: imptorsionat(:,:), imptorsn(:,:) - real(rp), allocatable :: imptorsamp(:,:), imptorsphase(:,:) - logical(lp) :: use_imptorsion = .false. - - ! Torsion-torsion coupling (cmap) - integer(ip) :: ntortor - integer(ip), allocatable :: tortorat(:,:), tortorprm(:), ttmap_shape(:,:) - real(rp), allocatable :: ttmap_ang1(:), ttmap_ang2(:), ttmap_v(:), & - ttmap_vx(:), ttmap_vy(:), ttmap_vxy(:) - logical(lp) :: use_tortor = .false. - end type ommp_bonded_type - - public :: ommp_bonded_type - public :: bond_init, bond_potential, bond_geomgrad, bond_terminate - public :: angle_init, angle_potential, angle_geomgrad, angle_terminate - public :: urey_init, urey_potential, urey_geomgrad, urey_terminate - public :: strbnd_init, strbnd_potential, strbnd_geomgrad, strbnd_terminate - public :: opb_init, opb_potential, opb_geomgrad, opb_terminate - public :: pitors_init, pitors_potential, pitors_geomgrad, pitors_terminate - public :: torsion_init, torsion_potential, torsion_geomgrad, & - torsion_terminate - public :: imptorsion_init, imptorsion_potential, imptorsion_geomgrad, & - imptorsion_terminate - public :: tortor_init, tortor_potential, tortor_geomgrad, & - tortor_terminate, tortor_newmap - public :: strtor_init, strtor_potential, strtor_geomgrad, strtor_terminate - public :: angtor_init, angtor_potential, angtor_geomgrad, angtor_terminate - public :: bonded_terminate - - contains - - subroutine bond_init(bds, n) - !! Initialize array used in calculation of bond stratching terms of - !! potential energy - - use mod_memory, only: mallocate - - implicit none - - type(ommp_bonded_type) :: bds - ! Bonded potential data structure - integer(ip) :: n - !! Number of bond stretching functions in the potential - !! energy of the system - - if( n < 1 ) return - bds%use_bond = .true. - - call mallocate('bond_init [bondat]', 2, n, bds%bondat) - call mallocate('bond_init [kbond]', n, bds%kbond) - call mallocate('bond_init [l0bond]', n, bds%l0bond) - - bds%nbond = n - bds%bond_cubic = 0.0_rp - bds%bond_quartic = 0.0_rp - - end subroutine bond_init - - subroutine bond_potential(bds, V) - !! Compute the bond-stretching terms of the potential energy. - !! They are computed according to the general formula adopted in AMOEBA - !! Force Field: - !! \[U_{bond} = \sum_i k_i \Delta l_i^2 \large(1 + k^{(3)}\Delta l_i + - !! k^{(4)}\Delta l_i^2 \large)\] - !! \[\Delta l_i = l_i - l^{(eq)}_i\] - - use mod_constants, only : eps_rp - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: V - !! Bond potential, result will be added to V - - integer :: i - logical(lp) :: use_cubic, use_quartic - real(rp) :: dr(3), l, dl, dl2 - - use_cubic = (abs(bds%bond_cubic) > eps_rp) - use_quartic = (abs(bds%bond_quartic) > eps_rp) - - if(.not. bds%use_bond) return - - if(.not. use_cubic .and. .not. use_quartic) then - ! This is just a regular harmonic potential - !$omp parallel do default(shared) schedule(static) & - !$omp private(i,dr,l,dl) reduction(+:v) - do i=1, bds%nbond - dr = bds%top%cmm(:,bds%bondat(1,i)) - & - bds%top%cmm(:,bds%bondat(2,i)) - l = sqrt(dot_product(dr, dr)) - dl = l - bds%l0bond(i) - - V = V + bds%kbond(i) * dl * dl - end do - else - !$omp parallel do default(shared) schedule(static) & - !$omp private(i,dr,l,dl,dl2) reduction(+:v) - do i=1, bds%nbond - dr = bds%top%cmm(:,bds%bondat(1,i)) - & - bds%top%cmm(:,bds%bondat(2,i)) - l = sqrt(dot_product(dr, dr)) - dl = l - bds%l0bond(i) - dl2 = dl * dl - - V = V + bds%kbond(i)*dl2 * & - (1.0_rp + bds%bond_cubic*dl + bds%bond_quartic*dl2) - end do - end if - - end subroutine bond_potential - - subroutine bond_geomgrad(bds, grad) - use mod_constants, only : eps_rp - use mod_jacobian_mat, only: Rij_jacobian - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - !! Bonded potential data structure - real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) - !! Gradients of bond stretching terms of potential energy - - integer :: i, ia, ib - logical(lp) :: use_cubic, use_quartic - logical :: sk_a, sk_b - real(rp) :: ca(3), cb(3), J_a(3), J_b(3), l, dl, g - - use_cubic = (abs(bds%bond_cubic) > eps_rp) - use_quartic = (abs(bds%bond_quartic) > eps_rp) - - if(.not. bds%use_bond) return - - if(.not. use_cubic .and. .not. use_quartic) then - ! This is just a regular harmonic potential - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,ia,ib,sk_a,sk_b,ca,cb,dl,l,g,J_a,J_b) - do i=1, bds%nbond - ia = bds%bondat(1,i) - ib = bds%bondat(2,i) - - if(bds%top%use_frozen) then - sk_a = bds%top%frozen(ia) - sk_b = bds%top%frozen(ib) - if(sk_a .and. sk_b) cycle - else - sk_a = .false. - sk_b = .false. - end if - - ca = bds%top%cmm(:,ia) - cb = bds%top%cmm(:,ib) - - call Rij_jacobian(ca, cb, l, J_a, J_b) - dl = l - bds%l0bond(i) - - g = 2 * bds%kbond(i) * dl - - if(.not. sk_a) then - !$omp atomic update - grad(1,ia) = grad(1,ia) + J_a(1) * g - !$omp atomic update - grad(2,ia) = grad(2,ia) + J_a(2) * g - !$omp atomic update - grad(3,ia) = grad(3,ia) + J_a(3) * g - end if - - if(.not. sk_b) then - !$omp atomic update - grad(1,ib) = grad(1,ib) + J_b(1) * g - !$omp atomic update - grad(2,ib) = grad(2,ib) + J_b(2) * g - !$omp atomic update - grad(3,ib) = grad(3,ib) + J_b(3) * g - end if - end do - else - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,ia,ib,sk_a,sk_b,ca,cb,dl,l,g,J_a,J_b) - do i=1, bds%nbond - ia = bds%bondat(1,i) - ib = bds%bondat(2,i) - - if(bds%top%use_frozen) then - sk_a = bds%top%frozen(ia) - sk_b = bds%top%frozen(ib) - if(sk_a .and. sk_b) cycle - else - sk_a = .false. - sk_b = .false. - end if - - ca = bds%top%cmm(:,ia) - cb = bds%top%cmm(:,ib) - - call Rij_jacobian(ca, cb, l, J_a, J_b) - dl = l - bds%l0bond(i) - - g = 2 * bds%kbond(i) * dl * (1.0_rp + 3.0/2.0*bds%bond_cubic*dl & - + 2.0*bds%bond_quartic*dl**2) - - if(.not. sk_a) then - !$omp atomic update - grad(1,ia) = grad(1,ia) + J_a(1) * g - !$omp atomic update - grad(2,ia) = grad(2,ia) + J_a(2) * g - !$omp atomic update - grad(3,ia) = grad(3,ia) + J_a(3) * g - end if - - if(.not. sk_b) then - !$omp atomic update - grad(1,ib) = grad(1,ib) + J_b(1) * g - !$omp atomic update - grad(2,ib) = grad(2,ib) + J_b(2) * g - !$omp atomic update - grad(3,ib) = grad(3,ib) + J_b(3) * g - end if - end do - end if - - end subroutine bond_geomgrad - - subroutine angle_init(bds, n) - !! Initialize arrays used in calculation of angle bending functions - - use mod_memory, only: mallocate - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - integer(ip) :: n - !! Number of angle bending functions in the potential - !! energy of the system - - if( n < 1 ) return - bds%use_angle = .true. - - call mallocate('angle_init [angleat]', 3, n, bds%angleat) - call mallocate('angle_init [anglety]', n, bds%anglety) - call mallocate('angle_init [angauxat]', n, bds%angauxat) - call mallocate('angle_init [kangle]', n, bds%kangle) - call mallocate('angle_init [eqangle]', n, bds%eqangle) - - bds%nangle = n - bds%angauxat = 0 - bds%angle_cubic = 0.0_rp - bds%angle_quartic = 0.0_rp - bds%angle_pentic = 0.0_rp - bds%angle_sextic = 0.0_rp - - end subroutine angle_init - - subroutine angle_potential(bds, V) - !! Compute angle-bending terms of the potential energy function. - !! Simple angle terms are computed according to the formula: - !! \[U_{angle} = \sum_i k_i \Delta \theta_i^2 \large(1 + - !! \sum_{j=1}^4 k^{(j+2)} \Delta \theta_i^j \large)\] - !! \[\Delta \theta_i = \theta_i - \theta^{(eq)}_i\] - !! Out-of plane angle are more complex. First, central atom has to be - !! a trigonal center, the other two atoms together with the auxliary - !! atom (that is the remaining one connected to the trigonal center) - !! define the projection plane. During the first run the auxiliary atom - !! is found and saved. - !! Then, the trigonal center is projected on the plane defined by the - !! other three atoms, and the angle is the one defined by the projection - !! (which is the vertex, and the other two atoms -- the auxiliary is - !! excluded). Then the same formula used for simple angle terms is used. - use mod_constants, only: eps_rp - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: V - !! Bond potential, result will be added to V - - integer(ip) :: i - real(rp) :: l1, l2, dr1(3), dr2(3), thet, d_theta - real(rp), dimension(3) :: v_dist, plv1, plv2, pln, a, b, c, prj_b, aux - - if(.not. bds%use_angle) return - - !$omp parallel do default(shared) schedule(static) reduction(+:V) & - !$omp private(i,dr1,dr2,l1,l2,thet,d_theta,a,b,c,aux,plv1,plv2,pln,v_dist,prj_b) - do i=1, bds%nangle - if(abs(bds%kangle(i)) < eps_rp) cycle - if(bds%anglety(i) == OMMP_ANG_SIMPLE .or. & - bds%anglety(i) == OMMP_ANG_H0 .or. & - bds%anglety(i) == OMMP_ANG_H1 .or. & - bds%anglety(i) == OMMP_ANG_H2) then - dr1 = bds%top%cmm(:, bds%angleat(1,i)) - bds%top%cmm(:, bds%angleat(2,i)) - dr2 = bds%top%cmm(:, bds%angleat(3,i)) - bds%top%cmm(:, bds%angleat(2,i)) - l1 = sqrt(dot_product(dr1, dr1)) - l2 = sqrt(dot_product(dr2, dr2)) - - thet = acos(dot_product(dr1, dr2)/(l1*l2)) - - d_theta = thet-bds%eqangle(i) - - V = V + bds%kangle(i) * d_theta**2 * (1.0 + bds%angle_cubic*d_theta & - + bds%angle_quartic*d_theta**2 + bds%angle_pentic*d_theta**3 & - + bds%angle_sextic*d_theta**4) - - else if(bds%anglety(i) == OMMP_ANG_INPLANE .or. & - bds%anglety(i) == OMMP_ANG_INPLANE_H0 .or. & - bds%anglety(i) == OMMP_ANG_INPLANE_H1) then - - a = bds%top%cmm(:, bds%angleat(1,i)) - b = bds%top%cmm(:, bds%angleat(2,i)) !! Trigonal center - c = bds%top%cmm(:, bds%angleat(3,i)) - - aux = bds%top%cmm(:, bds%angauxat(i)) - plv1 = a - aux - plv2 = c - aux - pln(1) = plv1(2)*plv2(3) - plv1(3)*plv2(2) - pln(2) = plv1(3)*plv2(1) - plv1(1)*plv2(3) - pln(3) = plv1(1)*plv2(2) - plv1(2)*plv2(1) - !! Normal vector of the projection plane - pln = pln / sqrt(dot_product(pln, pln)) - - v_dist = b - aux - prj_b = b - dot_product(v_dist, pln) * pln - - dr1 = bds%top%cmm(:, bds%angleat(1,i)) - prj_b - dr2 = bds%top%cmm(:, bds%angleat(3,i)) - prj_b - l1 = sqrt(dot_product(dr1, dr1)) - l2 = sqrt(dot_product(dr2, dr2)) - - thet = acos(dot_product(dr1, dr2)/(l1*l2)) - - d_theta = thet-bds%eqangle(i) - - V = V + bds%kangle(i) * d_theta**2 * (1.0 + bds%angle_cubic*d_theta & - + bds%angle_quartic*d_theta**2 + bds%angle_pentic*d_theta**3 & - + bds%angle_sextic*d_theta**4) - end if - end do - end subroutine angle_potential - - subroutine angle_geomgrad(bds, grad) - use mod_jacobian_mat, only: simple_angle_jacobian, & - inplane_angle_jacobian - use mod_constants, only: eps_rp - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - !! Bonded potential data structure - real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) - !! Gradients of bond stretching terms of potential energy - - real(rp) :: a(3), b(3), c(3), Ja(3), Jb(3), Jc(3), Jx(3), g, thet, & - d_theta, aux(3) - integer(ip) :: i - logical :: sk_a, sk_b, sk_c, sk_x - - if(.not. bds%use_angle) return - - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,sk_a,sk_b,sk_c,sk_x,a,b,c,aux,thet,d_theta,g,Ja,Jb,Jc,Jx) - do i=1, bds%nangle - if(abs(bds%kangle(i)) < eps_rp) cycle - if(bds%anglety(i) == OMMP_ANG_SIMPLE .or. & - bds%anglety(i) == OMMP_ANG_H0 .or. & - bds%anglety(i) == OMMP_ANG_H1 .or. & - bds%anglety(i) == OMMP_ANG_H2) then - if(bds%top%use_frozen) then - sk_a = bds%top%frozen(bds%angleat(1,i)) - sk_b = bds%top%frozen(bds%angleat(2,i)) - sk_c = bds%top%frozen(bds%angleat(3,i)) - if(sk_a .and. sk_b .and. sk_c) cycle - else - sk_a = .false. - sk_b = .false. - sk_c = .false. - end if - - a = bds%top%cmm(:, bds%angleat(1,i)) - b = bds%top%cmm(:, bds%angleat(2,i)) - c = bds%top%cmm(:, bds%angleat(3,i)) - call simple_angle_jacobian(a, b, c, thet, Ja, Jb, Jc) - d_theta = thet - bds%eqangle(i) - - g = bds%kangle(i) * d_theta * (2.0 & - + 3.0 * bds%angle_cubic * d_theta & - + 4.0 * bds%angle_quartic * d_theta**2 & - + 5.0 * bds%angle_pentic * d_theta**3 & - + 6.0 * bds%angle_sextic * d_theta**4) - - if(.not. sk_a) then - !$omp atomic update - grad(1,bds%angleat(1,i)) = grad(1,bds%angleat(1,i)) + g * Ja(1) - !$omp atomic update - grad(2,bds%angleat(1,i)) = grad(2,bds%angleat(1,i)) + g * Ja(2) - !$omp atomic update - grad(3,bds%angleat(1,i)) = grad(3,bds%angleat(1,i)) + g * Ja(3) - end if - - if(.not. sk_b) then - !$omp atomic update - grad(1,bds%angleat(2,i)) = grad(1,bds%angleat(2,i)) + g * Jb(1) - !$omp atomic update - grad(2,bds%angleat(2,i)) = grad(2,bds%angleat(2,i)) + g * Jb(2) - !$omp atomic update - grad(3,bds%angleat(2,i)) = grad(3,bds%angleat(2,i)) + g * Jb(3) - end if - - if(.not. sk_c) then - !$omp atomic update - grad(1,bds%angleat(3,i)) = grad(1,bds%angleat(3,i)) + g * Jc(1) - !$omp atomic update - grad(2,bds%angleat(3,i)) = grad(2,bds%angleat(3,i)) + g * Jc(2) - !$omp atomic update - grad(3,bds%angleat(3,i)) = grad(3,bds%angleat(3,i)) + g * Jc(3) - end if - else if(bds%anglety(i) == OMMP_ANG_INPLANE .or. & - bds%anglety(i) == OMMP_ANG_INPLANE_H0 .or. & - bds%anglety(i) == OMMP_ANG_INPLANE_H1) then - - if(bds%top%use_frozen) then - sk_a = bds%top%frozen(bds%angleat(1,i)) - sk_b = bds%top%frozen(bds%angleat(2,i)) - sk_c = bds%top%frozen(bds%angleat(3,i)) - sk_x = bds%top%frozen(bds%angauxat(i)) - if(sk_a .and. sk_b .and. sk_c .and. sk_x) cycle - else - sk_a = .false. - sk_b = .false. - sk_c = .false. - sk_x = .false. - end if - - a = bds%top%cmm(:, bds%angleat(1,i)) - b = bds%top%cmm(:, bds%angleat(2,i)) !! Trigonal center - c = bds%top%cmm(:, bds%angleat(3,i)) - - aux = bds%top%cmm(:, bds%angauxat(i)) - - call inplane_angle_jacobian(a, b, c, aux, thet, Ja, Jb, Jc, Jx) - d_theta = thet - bds%eqangle(i) - g = bds%kangle(i) * d_theta * (2.0 & - + 3.0 * bds%angle_cubic * d_theta & - + 4.0 * bds%angle_quartic * d_theta**2 & - + 5.0 * bds%angle_pentic * d_theta**3 & - + 6.0 * bds%angle_sextic * d_theta**4) - if(.not. sk_a) then - !$omp atomic update - grad(1,bds%angleat(1,i)) = grad(1,bds%angleat(1,i)) + g * Ja(1) - !$omp atomic update - grad(2,bds%angleat(1,i)) = grad(2,bds%angleat(1,i)) + g * Ja(2) - !$omp atomic update - grad(3,bds%angleat(1,i)) = grad(3,bds%angleat(1,i)) + g * Ja(3) - end if - - if(.not. sk_b) then - !$omp atomic update - grad(1,bds%angleat(2,i)) = grad(1,bds%angleat(2,i)) + g * Jb(1) - !$omp atomic update - grad(2,bds%angleat(2,i)) = grad(2,bds%angleat(2,i)) + g * Jb(2) - !$omp atomic update - grad(3,bds%angleat(2,i)) = grad(3,bds%angleat(2,i)) + g * Jb(3) - end if - - if(.not. sk_c) then - !$omp atomic update - grad(1,bds%angleat(3,i)) = grad(1,bds%angleat(3,i)) + g * Jc(1) - !$omp atomic update - grad(2,bds%angleat(3,i)) = grad(2,bds%angleat(3,i)) + g * Jc(2) - !$omp atomic update - grad(3,bds%angleat(3,i)) = grad(3,bds%angleat(3,i)) + g * Jc(3) - end if - - if(.not. sk_x) then - !$omp atomic update - grad(1,bds%angauxat(i)) = grad(1,bds%angauxat(i)) + g * Jx(1) - !$omp atomic update - grad(2,bds%angauxat(i)) = grad(2,bds%angauxat(i)) + g * Jx(2) - !$omp atomic update - grad(3,bds%angauxat(i)) = grad(3,bds%angauxat(i)) + g * Jx(3) - end if - end if - end do - end subroutine angle_geomgrad - - subroutine strbnd_init(bds, n) - !! Initialize arrays for calculation of stretch-bend cross term - !! potential - - use mod_memory, only: mallocate - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - integer(ip) :: n - !! Number of stretch-bend functions in the potential - !! energy of the system - - if( n < 1 ) return - bds%use_strbnd = .true. - - call mallocate('strbnd_init [strbndat]', 3, n, bds%strbndat) - call mallocate('strbnd_init [strbndl10]', n, bds%strbndl10) - call mallocate('strbnd_init [strbndl20]', n, bds%strbndl20) - call mallocate('strbnd_init [strbndthet0]', n, bds%strbndthet0) - call mallocate('strbnd_init [strbndk1]', n, bds%strbndk1) - call mallocate('strbnd_init [strbndk2]', n, bds%strbndk2) - bds%nstrbnd = n - - end subroutine strbnd_init - - subroutine strbnd_potential(bds, V) - !! Compute the stretch-bend cross term potential. - !! Those terms are computed according the following formula: - !! \[U_{bond/angle} = (k_i \Delta l_i + k_j \Delta l_j) - !! \Delta \theta_{ij} \] - !! where \(\theta_{ij}\) is the angle delimited by the bond \(i\) and - !! \(j\). - !! The force constants \(k_i\) and \(k_j\) are explicitely defined in - !! the FF, while the equilibrium values are the same as for stretching - !! and bending terms. - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: V - !! Stretch-bend cross term potential, result will be added to V - - integer(ip) :: i - real(rp) :: d_l1, d_l2, d_thet, dr1(3), dr2(3), l1, l2, thet - - if(.not. bds%use_strbnd) return - - !$omp parallel do default(shared) reduction(+:V) & - !$omp private(i,dr1,l1,l2,d_l1,d_l2,dr2,thet,d_thet) - do i=1, bds%nstrbnd - dr1 = bds%top%cmm(:, bds%strbndat(2,i)) - & - bds%top%cmm(:, bds%strbndat(1,i)) - l1 = norm2(dr1) - d_l1 = l1 - bds%strbndl10(i) - - dr2 = bds%top%cmm(:, bds%strbndat(2,i)) - & - bds%top%cmm(:, bds%strbndat(3,i)) - l2 = norm2(dr2) - d_l2 = l2 - bds%strbndl20(i) - - thet = acos(dot_product(dr1, dr2)/(l1*l2)) - d_thet = thet - bds%strbndthet0(i) - - V = V + (d_l1*bds%strbndk1(i) + d_l2*bds%strbndk2(i)) * d_thet - end do - end subroutine strbnd_potential - - subroutine strbnd_geomgrad(bds, grad) - use mod_jacobian_mat, only: Rij_jacobian, simple_angle_jacobian - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) - !! Gradients of bond stretching terms of potential energy - - integer(ip) :: i, ia, ib, ic - real(rp) :: d_l1, d_l2, d_thet, l1, l2, thet, g1, g2, g3 - real(rp), dimension(3) :: a, b, c, & - J1_a, J1_b, & - J2_b, J2_c, & - J3_a, J3_b, J3_c - logical :: sk_a, sk_b, sk_c - - if(.not. bds%use_strbnd) return - - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,ia,ib,ic,sk_a,sk_b,sk_c,a,b,c,l1,l2,d_l1,d_l2,thet,d_thet) & - !$omp private(J1_a,J1_b,J2_b,J2_c,J3_a,J3_b,J3_c,g1,g2,g3) - do i=1, bds%nstrbnd - ia = bds%strbndat(1,i) - ib = bds%strbndat(2,i) - ic = bds%strbndat(3,i) - - if(bds%top%use_frozen) then - sk_a = bds%top%frozen(ia) - sk_b = bds%top%frozen(ib) - sk_c = bds%top%frozen(ic) - if(sk_a .and. sk_b .and. sk_c) cycle - else - sk_a = .false. - sk_b = .false. - sk_c = .false. - end if - - a = bds%top%cmm(:, ia) - b = bds%top%cmm(:, ib) - c = bds%top%cmm(:, ic) - - call Rij_jacobian(a, b, l1, J1_a, J1_b) - call Rij_jacobian(b, c, l2, J2_b, J2_c) - call simple_angle_jacobian(a, b, c, thet, J3_a, J3_b, J3_c) - - d_l1 = l1 - bds%strbndl10(i) - d_l2 = l2 - bds%strbndl20(i) - d_thet = thet - bds%strbndthet0(i) - - g1 = bds%strbndk1(i) * d_thet - g2 = bds%strbndk2(i) * d_thet - g3 = bds%strbndk1(i) * d_l1 + bds%strbndk2(i) * d_l2 - - if(.not. sk_a) then - !$omp atomic update - grad(1,ia) = grad(1,ia) + J1_a(1) * g1 + J3_a(1) * g3 - !$omp atomic update - grad(2,ia) = grad(2,ia) + J1_a(2) * g1 + J3_a(2) * g3 - !$omp atomic update - grad(3,ia) = grad(3,ia) + J1_a(3) * g1 + J3_a(3) * g3 - end if - - if(.not. sk_b) then - !$omp atomic update - grad(1,ib) = grad(1,ib) + J1_b(1) * g1 + J2_b(1) * g2 + J3_b(1) * g3 - !$omp atomic update - grad(2,ib) = grad(2,ib) + J1_b(2) * g1 + J2_b(2) * g2 + J3_b(2) * g3 - !$omp atomic update - grad(3,ib) = grad(3,ib) + J1_b(3) * g1 + J2_b(3) * g2 + J3_b(3) * g3 - end if - - if(.not. sk_c) then - !$omp atomic update - grad(1,ic) = grad(1,ic) + J2_c(1) * g2 + J3_c(1) * g3 - !$omp atomic update - grad(2,ic) = grad(2,ic) + J2_c(2) * g2 + J3_c(2) * g3 - !$omp atomic update - grad(3,ic) = grad(3,ic) + J2_c(3) * g2 + J3_c(3) * g3 - end if - end do - - end subroutine strbnd_geomgrad - - subroutine urey_init(bds, n) - !! Initialize Urey-Bradley potential arrays - - use mod_memory, only: mallocate - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - integer(ip) :: n - !! Number of Urey-Bradley functions in the potential - !! energy of the system - - if( n < 1 ) return - bds%use_urey = .true. - - call mallocate('urey_init [ureya]', 2, n, bds%ureyat) - call mallocate('urey_init [kurey]', n, bds%kurey) - call mallocate('urey_init [l0urey]', n, bds%l0urey) - bds%nurey = n - bds%urey_cubic = 0.0_rp - bds%urey_quartic = 0.0_rp - - end subroutine urey_init - - subroutine urey_potential(bds, V) - !! Compute the Urey-Bradley potential. - !! This is basically a virtual bond, with its stretching harminic - !! potential that connect two otherwise un-connected bonds. The same - !! potential formula used for normal stretching is used. - - use mod_constants, only : eps_rp - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: V - !! Urey-Bradley potential, result will be added to V - - integer :: i - logical(lp) :: use_cubic, use_quartic - real(rp) :: dr(3), l, dl, dl2 - - if(.not. bds%use_urey) return - - use_cubic = (abs(bds%urey_cubic) > eps_rp) - use_quartic = (abs(bds%urey_quartic) > eps_rp) - - if(.not. use_cubic .and. .not. use_quartic) then - ! This is just a regular harmonic potential - !$omp parallel do default(shared) reduction(+:V) & - !$omp private(i,dr,l,dl) - do i=1, bds%nurey - dr = bds%top%cmm(:,bds%ureyat(1,i)) - & - bds%top%cmm(:,bds%ureyat(2,i)) - l = sqrt(dot_product(dr, dr)) - dl = l - bds%l0urey(i) - V = V + bds%kurey(i) * dl * dl - end do - else - !$omp parallel do default(shared) reduction(+:V) & - !$omp private(i,dr,l,dl,dl2) - do i=1, bds%nurey - dr = bds%top%cmm(:,bds%ureyat(1,i)) - & - bds%top%cmm(:,bds%ureyat(2,i)) - l = sqrt(dot_product(dr, dr)) - dl = l - bds%l0urey(i) - dl2 = dl * dl - - V = V + bds%kurey(i)*dl2 * (1.0_rp + bds%urey_cubic*dl + & - bds%urey_quartic*dl2) - end do - end if - end subroutine urey_potential - - subroutine urey_geomgrad(bds, grad) - use mod_constants, only : eps_rp - use mod_jacobian_mat, only: Rij_jacobian - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - !! Bonded potential data structure - real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) - !! Gradients of bond stretching terms of potential energy - - integer :: i, ia, ib - logical(lp) :: use_cubic, use_quartic - logical :: sk_a, sk_b - real(rp) :: l, dl, J_a(3), J_b(3), g - - if(.not. bds%use_urey) return - - use_cubic = (abs(bds%urey_cubic) > eps_rp) - use_quartic = (abs(bds%urey_quartic) > eps_rp) - - if(.not. use_cubic .and. .not. use_quartic) then - ! This is just a regular harmonic potential - !$omp parallel do default(shared) & - !$omp private(i,ia,ib,sk_a,sk_b,l,dl,g,J_a,J_b) - do i=1, bds%nurey - ia = bds%ureyat(1,i) - ib = bds%ureyat(2,i) - - if(bds%top%use_frozen) then - sk_a = bds%top%frozen(ia) - sk_b = bds%top%frozen(ib) - if(sk_a .and. sk_b) cycle - else - sk_a = .false. - sk_b = .false. - end if - - call Rij_jacobian(bds%top%cmm(:,ia), & - bds%top%cmm(:,ib), & - l, J_a, J_b) - dl = l - bds%l0urey(i) - g = 2 * bds%kurey(i) * dl - - if(.not. sk_a) then - !$omp atomic update - grad(1,ia) = grad(1,ia) + J_a(1) * g - !$omp atomic update - grad(2,ia) = grad(2,ia) + J_a(2) * g - !$omp atomic update - grad(3,ia) = grad(3,ia) + J_a(3) * g - end if - - if(.not. sk_b) then - !$omp atomic update - grad(1,ib) = grad(1,ib) + J_b(1) * g - !$omp atomic update - grad(2,ib) = grad(2,ib) + J_b(2) * g - !$omp atomic update - grad(3,ib) = grad(3,ib) + J_b(3) * g - end if - end do - else - !$omp parallel do default(shared) & - !$omp private(i,ia,ib,sk_a,sk_b,l,dl,g,J_a,J_b) - do i=1, bds%nurey - ia = bds%ureyat(1,i) - ib = bds%ureyat(2,i) - - if(bds%top%use_frozen) then - sk_a = bds%top%frozen(ia) - sk_b = bds%top%frozen(ib) - if(sk_a .and. sk_b) cycle - else - sk_a = .false. - sk_b = .false. - end if - - call Rij_jacobian(bds%top%cmm(:,ia), & - bds%top%cmm(:,ib), & - l, J_a, J_b) - dl = l - bds%l0urey(i) - g = 2 * bds%kurey(i) * dl * (1.0 & - + 3.0/2.0 * bds%urey_cubic*dl & - + 2.0 * bds%urey_quartic*dl**2) - - if(.not. sk_a) then - !$omp atomic update - grad(1,ia) = grad(1,ia) + J_a(1) * g - !$omp atomic update - grad(2,ia) = grad(2,ia) + J_a(2) * g - !$omp atomic update - grad(3,ia) = grad(3,ia) + J_a(3) * g - end if - - if(.not. sk_b) then - !$omp atomic update - grad(1,ib) = grad(1,ib) + J_b(1) * g - !$omp atomic update - grad(2,ib) = grad(2,ib) + J_b(2) * g - !$omp atomic update - grad(3,ib) = grad(3,ib) + J_b(3) * g - end if - end do - end if - end subroutine urey_geomgrad - - subroutine opb_init(bds, n, opbtype) - !! Initialize arrays for out-of-plane bending potential calculation. - !! @todo Currently only Allinger functional form is supported - use mod_io, only: ommp_message - use mod_constants, only: OMMP_VERBOSE_LOW - use mod_memory, only: mallocate - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - integer(ip) :: n - !! Number of out of plane Bending functions in the potential - !! energy of the system - character(len=*) :: opbtype - - select case(opbtype) - case('allinger') - continue - case('w-d-c') - call fatal_error('Out-of-plane bend W-D-C is not implemented') - case default - call ommp_message("Found OPB type: '"//opbtype//"'", OMMP_VERBOSE_LOW) - call fatal_error('Out-of-plane type specified is not understood') - end select - - if( n < 1 ) return - bds%use_opb = .true. - - call mallocate('opb_init [opbat]', 4, n, bds%opbat) - call mallocate('opb_init [kopb]', n, bds%kopb) - bds%nopb = n - - end subroutine opb_init - - subroutine opb_potential(bds, V) - !! Computes the out-of-plane bending potential. - !! With Allinger formula: similarly to in plane angles, here we are - !! considering a trigonal center, where D is the central atom and - !! A, B, C are connected to D. Allinger formula consider the angle - !! between vector \(\vec{AD}\) and the normal vector of plane ABC, - !! using \(\frac{\pi}{2}\) as implicit equilibrium value. The formula - !! for this potential term is: - !! \[U_{out-of-plane} = \sum_i k_i \chi_i^2 \large(1 + - !! \sum_{j=1}^4 k^{(j+2)} \chi_i^j \large) \] - - use mod_constants, only : pi - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: V - !! out-of-plane potential, result will be added to V - real(rp), dimension(3) :: a, b, c, d, plv1, plv2, pln, vad - real(rp) :: lpln, lvad, thet, thet2, thet3, thet4 - integer(ip) :: i - - if(.not. bds%use_opb) return - - !$omp parallel do default(shared) reduction(+:V) & - !$omp private(i,a,b,c,d,plv1,plv2,pln,lpln,vad,lvad,thet,thet2,thet3,thet4) - do i=1, bds%nopb - ! A* -- D -- C - ! | - ! B - a = bds%top%cmm(:,bds%opbat(2,i)) - d = bds%top%cmm(:,bds%opbat(1,i)) - c = bds%top%cmm(:,bds%opbat(3,i)) - b = bds%top%cmm(:,bds%opbat(4,i)) - - ! Compute the normal vector of the plane - plv1 = a - b - plv2 = a - c - pln(1) = plv1(2)*plv2(3) - plv1(3)*plv2(2) - pln(2) = plv1(3)*plv2(1) - plv1(1)*plv2(3) - pln(3) = plv1(1)*plv2(2) - plv1(2)*plv2(1) - lpln = norm2(pln) - - ! Vector from A to D - vad = a - d - lvad = norm2(vad) - - thet = abs(pi/2.0 - acos(dot_product(vad, pln)/(lvad*lpln))) - thet2 = thet*thet - thet3 = thet2*thet - thet4 = thet3*thet - V = V + bds%kopb(i) * thet2 * (1 + bds%opb_cubic*thet & - + bds%opb_quartic*thet2 + bds%opb_pentic*thet3 & - + bds%opb_sextic*thet4) - end do - end subroutine opb_potential - - subroutine opb_geomgrad(bds, grad) - use mod_jacobian_mat, only: opb_angle_jacobian - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) - !! Gradients of bond stretching terms of potential energy - real(rp) :: thet, g, J_a(3), J_b(3), J_c(3), J_d(3) - integer(ip) :: i, ia, ib, ic, id - logical :: sk_a, sk_b, sk_c, sk_d - - if(.not. bds%use_opb) return - - !$omp parallel do default(shared) schedule(dynamic)& - !$omp private(i,ia,ib,ic,id,sk_a,sk_b,sk_c,sk_d,thet,J_a,J_b,J_c,J_d,g) - do i=1, bds%nopb - ia = bds%opbat(2,i) - ib = bds%opbat(4,i) - ic = bds%opbat(3,i) - id = bds%opbat(1,i) - - if(bds%top%use_frozen) then - sk_a = bds%top%frozen(ia) - sk_b = bds%top%frozen(ib) - sk_c = bds%top%frozen(ic) - sk_d = bds%top%frozen(id) - if(sk_a .and. sk_b .and. sk_c .and. sk_d) cycle - else - sk_a = .false. - sk_b = .false. - sk_c = .false. - sk_d = .false. - end if - - call opb_angle_jacobian(bds%top%cmm(:,ia), & - bds%top%cmm(:,ib), & - bds%top%cmm(:,ic), & - bds%top%cmm(:,id), & - thet, J_a, J_b, J_c, J_d) - - g = bds%kopb(i) * thet * (2.0 + 3.0*bds%opb_cubic*thet & - + 4.0*bds%opb_quartic*thet**2 + 5.0*bds%opb_pentic*thet**3 & - + 6.0*bds%opb_sextic*thet**4) - - if(.not. sk_a) then - !$omp atomic update - grad(1,ia) = grad(1,ia) + J_a(1) * g - !$omp atomic update - grad(2,ia) = grad(2,ia) + J_a(2) * g - !$omp atomic update - grad(3,ia) = grad(3,ia) + J_a(3) * g - end if - - if(.not. sk_b) then - !$omp atomic update - grad(1,ib) = grad(1,ib) + J_b(1) * g - !$omp atomic update - grad(2,ib) = grad(2,ib) + J_b(2) * g - !$omp atomic update - grad(3,ib) = grad(3,ib) + J_b(3) * g - end if - - if(.not. sk_c) then - !$omp atomic update - grad(1,ic) = grad(1,ic) + J_c(1) * g - !$omp atomic update - grad(2,ic) = grad(2,ic) + J_c(2) * g - !$omp atomic update - grad(3,ic) = grad(3,ic) + J_c(3) * g - end if - - if(.not. sk_d) then - !$omp atomic update - grad(1,id) = grad(1,id) + J_d(1) * g - !$omp atomic update - grad(2,id) = grad(2,id) + J_d(2) * g - !$omp atomic update - grad(3,id) = grad(3,id) + J_d(3) * g - end if - end do - end subroutine opb_geomgrad - - - subroutine pitors_init(bds, n) - !! Initialize arrays needed to compute pi-torsion potential - - use mod_memory, only: mallocate - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - integer(ip) :: n - !! Number of out of plane pi-torsion functions in the potential - !! enerpgy of the system - - if( n < 1 ) return - - bds%use_pitors = .true. - - call mallocate('pitors_init [pitorsat]', 6, n, bds%pitorsat) - call mallocate('pitors_init [kpitors]', n, bds%kpitors) - bds%npitors = n - - end subroutine pitors_init - - subroutine pitors_potential(bds, V) - !! Compute pi-torsion terms of the potential. - !! This potential is defined on a \(\pi\)-system, and uses the - !! coordinates of six atoms A...F the central "double" bond is A-B, then - !! C and D are connected to A while E and F are connected to B. So two - !! plane ACD and BEF are defined. The potential is computed using the - !! dihedral angle of the normal vector of those two planes, connected - !! by segment A-B (\(\theta\)). - !! The formula used is: - !! \[U_{\pi-torsion} = \sum_i k_i \large(1 + cos(2\theta-\pi) \large)\] - - use mod_constants, only : pi - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: V - !! pi-torsion potential, result will be added to V - real(rp), dimension(3) :: a, b, c, d, e, f, u, t, cd, plv1, plv2, pln1, pln2 - real(rp) :: thet, costhet - integer(ip) :: i - - if(.not. bds%use_pitors) return - - !$omp parallel do default(shared) reduction(+:V) & - !$omp private(i,a,b,c,d,e,f,plv1,plv2,pln1,pln2,t,u,cd,thet,costhet) - do i=1, bds%npitors - ! - ! 2(c) 5(e) a => 1 - ! \ / b => 4 - ! 1(a) -- 4(b) - ! / \ - ! 3(d) 6(f) - - ! Atoms that defines the two planes - a = bds%top%cmm(:,bds%pitorsat(1,i)) - c = bds%top%cmm(:,bds%pitorsat(2,i)) - d = bds%top%cmm(:,bds%pitorsat(3,i)) - - b = bds%top%cmm(:,bds%pitorsat(4,i)) - e = bds%top%cmm(:,bds%pitorsat(5,i)) - f = bds%top%cmm(:,bds%pitorsat(6,i)) - - - ! Compute the normal vector of the first plane - plv1 = d - b - plv2 = c - b - pln1(1) = plv1(2)*plv2(3) - plv1(3)*plv2(2) - pln1(2) = plv1(3)*plv2(1) - plv1(1)*plv2(3) - pln1(3) = plv1(1)*plv2(2) - plv1(2)*plv2(1) - - ! Compute the normal vector of the second plane - plv1 = f - a - plv2 = e - a - pln2(1) = plv1(2)*plv2(3) - plv1(3)*plv2(2) - pln2(2) = plv1(3)*plv2(1) - plv1(1)*plv2(3) - pln2(3) = plv1(1)*plv2(2) - plv1(2)*plv2(1) - - cd = b - a - - t(1) = pln1(2)*cd(3) - pln1(3)*cd(2) - t(2) = pln1(3)*cd(1) - pln1(1)*cd(3) - t(3) = pln1(1)*cd(2) - pln1(2)*cd(1) - t = t / norm2(t) - - u(1) = cd(2)*pln2(3) - cd(3)*pln2(2) - u(2) = cd(3)*pln2(1) - cd(1)*pln2(3) - u(3) = cd(1)*pln2(2) - cd(2)*pln2(1) - u = u / norm2(u) - - costhet = dot_product(u,t) - - thet = acos(costhet) - - V = V + bds%kpitors(i) * (1 + cos(2.0*thet-pi)) - end do - - end subroutine pitors_potential - - subroutine pitors_geomgrad(bds, grad) - use mod_jacobian_mat, only: pitors_angle_jacobian - use mod_constants, only : pi - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) - !! improper torsion potential, result will be added to V - real(rp) :: thet, g, J_a(3), J_b(3), J_c(3), J_d(3), J_e(3), J_f(3) - integer(ip) :: i, ia, ib, ic, id, ie, if_ - logical :: sk_a, sk_b, sk_c, sk_d, sk_e, sk_f - - if(.not. bds%use_pitors) return - - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,ia,ib,ic,id,ie,if_,sk_a,sk_b,sk_c,sk_d,sk_e,sk_f) & - !$omp private(J_a,J_b,J_c,J_d,J_e,J_f,g,thet) - do i=1, bds%npitors - ia = bds%pitorsat(1,i) - ic = bds%pitorsat(2,i) - id = bds%pitorsat(3,i) - ib = bds%pitorsat(4,i) - ie = bds%pitorsat(5,i) - if_ = bds%pitorsat(6,i) - - if(bds%top%use_frozen) then - sk_a = bds%top%frozen(ia) - sk_b = bds%top%frozen(ib) - sk_c = bds%top%frozen(ic) - sk_d = bds%top%frozen(id) - sk_e = bds%top%frozen(ie) - sk_f = bds%top%frozen(if_) - if(sk_a .and. sk_b .and. sk_c .and. sk_d .and. sk_e .and. sk_f) cycle - else - sk_a = .false. - sk_b = .false. - sk_c = .false. - sk_d = .false. - sk_e = .false. - sk_f = .false. - end if - - call pitors_angle_jacobian(bds%top%cmm(:,ia), & - bds%top%cmm(:,ib), & - bds%top%cmm(:,ic), & - bds%top%cmm(:,id), & - bds%top%cmm(:,ie), & - bds%top%cmm(:,if_), & - thet, J_a, J_b, J_c, J_d, J_e, J_f) - - g = -2.0 * bds%kpitors(i) * sin(2.0*thet-pi) - - if(.not. sk_a) then - !$omp atomic update - grad(1,ia) = grad(1,ia) + g * J_a(1) - !$omp atomic update - grad(2,ia) = grad(2,ia) + g * J_a(2) - !$omp atomic update - grad(3,ia) = grad(3,ia) + g * J_a(3) - end if - - if(.not. sk_b) then - !$omp atomic update - grad(1,ib) = grad(1,ib) + g * J_b(1) - !$omp atomic update - grad(2,ib) = grad(2,ib) + g * J_b(2) - !$omp atomic update - grad(3,ib) = grad(3,ib) + g * J_b(3) - end if - - if(.not. sk_c) then - !$omp atomic update - grad(1,ic) = grad(1,ic) + g * J_c(1) - !$omp atomic update - grad(2,ic) = grad(2,ic) + g * J_c(2) - !$omp atomic update - grad(3,ic) = grad(3,ic) + g * J_c(3) - end if - - if(.not. sk_d) then - !$omp atomic update - grad(1,id) = grad(1,id) + g * J_d(1) - !$omp atomic update - grad(2,id) = grad(2,id) + g * J_d(2) - !$omp atomic update - grad(3,id) = grad(3,id) + g * J_d(3) - end if - - if(.not. sk_e) then - !$omp atomic update - grad(1,ie) = grad(1,ie) + g * J_e(1) - !$omp atomic update - grad(2,ie) = grad(2,ie) + g * J_e(2) - !$omp atomic update - grad(3,ie) = grad(3,ie) + g * J_e(3) - end if - - if(.not. sk_f) then - !$omp atomic update - grad(1,if_) = grad(1,if_) + g * J_f(1) - !$omp atomic update - grad(2,if_) = grad(2,if_) + g * J_f(2) - !$omp atomic update - grad(3,if_) = grad(3,if_) + g * J_f(3) - end if - end do - end subroutine pitors_geomgrad - - - subroutine torsion_init(bds, n) - !! Initialize torsion potential arrays - - use mod_memory, only: mallocate - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - integer(ip) :: n - !! Number of torsion functions in the potential - !! energy of the system - - if( n < 1 ) return - bds%use_torsion = .true. - - call mallocate('torsion_init [torsionat]', 4, n, bds%torsionat) - call mallocate('torsion_init [torsamp]', 6, n, bds%torsamp) - call mallocate('torsion_init [torsphase]', 6, n, bds%torsphase) - call mallocate('torsion_init [torsn]', 6, n, bds%torsn) - - bds%ntorsion = n - - end subroutine torsion_init - - subroutine torsion_potential(bds, V) - !! Compute torsion potential - use mod_constants, only: pi, eps_rp - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: V - !! torsion potential, result will be added to V - real(rp) :: thet, costhet - integer(ip) :: i, j - - if(.not. bds%use_torsion) return - - !$omp parallel do default(shared) & - !$omp private(i,costhet,thet,j) reduction(+:V) - do i=1, bds%ntorsion - ! Atoms that defines the dihedral angle - costhet = cos_torsion(bds%top, bds%torsionat(:,i)) - - if(costhet + 1.0 <= eps_rp) then - thet = pi - else if(abs(costhet - 1.0) <= eps_rp) then - thet = 0.0 - else - thet = acos(costhet) - end if - - do j=1, 6 - if(bds%torsn(j,i) < 1) exit - V = V + bds%torsamp(j,i) * (1+cos(real(bds%torsn(j,i))*thet & - - bds%torsphase(j,i))) - end do - end do - - end subroutine torsion_potential - - subroutine torsion_geomgrad(bds, grad) - !! Compute torsion potential - use mod_jacobian_mat, only: torsion_angle_jacobian - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) - !! Gradients of bond stretching terms of potential energy - real(rp) :: thet, g, J_a(3), J_b(3), J_c(3), J_d(3) - integer(ip) :: i, j, ia, ib, ic, id - logical :: sk_a, sk_b, sk_c, sk_d - - if(.not. bds%use_torsion) return - - !$omp parallel do default(shared) & - !$omp private(i,ia,ib,ic,id,sk_a,sk_b,sk_c,sk_d,j,thet,J_a,J_b,J_c,J_d,g) - do i=1, bds%ntorsion - ia = bds%torsionat(1,i) - ib = bds%torsionat(2,i) - ic = bds%torsionat(3,i) - id = bds%torsionat(4,i) - - if(bds%top%use_frozen) then - sk_a = bds%top%frozen(ia) - sk_b = bds%top%frozen(ib) - sk_c = bds%top%frozen(ic) - sk_d = bds%top%frozen(id) - if(sk_a .and. sk_b .and. sk_c .and. sk_d) cycle - else - sk_a = .false. - sk_b = .false. - sk_c = .false. - sk_d = .false. - end if - - call torsion_angle_jacobian(bds%top%cmm(:,ia), & - bds%top%cmm(:,ib), & - bds%top%cmm(:,ic), & - bds%top%cmm(:,id), & - thet, J_a, J_b, J_c, J_d) - - do j=1, 6 - if(bds%torsn(j,i) < 1) exit - g = -real(bds%torsn(j,i)) * sin(real(bds%torsn(j,i))* thet & - - bds%torsphase(j,i)) & - * bds%torsamp(j,i) - if(.not. sk_a) then - !$omp atomic update - grad(1, ia) = grad(1, ia) + J_a(1) * g - !$omp atomic update - grad(2, ia) = grad(2, ia) + J_a(2) * g - !$omp atomic update - grad(3, ia) = grad(3, ia) + J_a(3) * g - end if - if(.not. sk_b) then - !$omp atomic update - grad(1, ib) = grad(1, ib) + J_b(1) * g - !$omp atomic update - grad(2, ib) = grad(2, ib) + J_b(2) * g - !$omp atomic update - grad(3, ib) = grad(3, ib) + J_b(3) * g - end if - if(.not. sk_c) then - !$omp atomic update - grad(1, ic) = grad(1, ic) + J_c(1) * g - !$omp atomic update - grad(2, ic) = grad(2, ic) + J_c(2) * g - !$omp atomic update - grad(3, ic) = grad(3, ic) + J_c(3) * g - end if - if(.not. sk_d) then - !$omp atomic update - grad(1, id) = grad(1, id) + J_d(1) * g - !$omp atomic update - grad(2, id) = grad(2, id) + J_d(2) * g - !$omp atomic update - grad(3, id) = grad(3, id) + J_d(3) * g - end if - end do - end do - - end subroutine torsion_geomgrad - - subroutine imptorsion_potential(bds, V) - !! Compute torsion potential - use mod_constants, only: pi, eps_rp - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: V - !! improper torsion potential, result will be added to V - real(rp) :: thet, costhet - integer(ip) :: i, j - - if(.not. bds%use_imptorsion) return - - do i=1, bds%nimptorsion - ! Atoms that defines the dihedral angle - costhet = cos_torsion(bds%top, bds%imptorsionat(:,i)) - - if(costhet + 1.0 <= eps_rp) then - thet = pi - else - thet = acos(costhet) - end if - - do j=1, 3 - if(bds%imptorsn(j,i) < 1) exit - V = V + bds%imptorsamp(j,i) * (1+cos(real(bds%imptorsn(j,i))*thet & - - bds%imptorsphase(j,i))) - end do - end do - - end subroutine imptorsion_potential - - subroutine imptorsion_geomgrad(bds, grad) - !! Compute torsion potential - use mod_jacobian_mat, only: torsion_angle_jacobian - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: grad(3, bds%top%mm_atoms) - !! improper torsion potential, result will be added to V - real(rp) :: thet, g, J_a(3), J_b(3), J_c(3), J_d(3) - integer(ip) :: i, j, ia, ib, ic, id - logical :: sk_a, sk_b, sk_c, sk_d - - if (.not. bds%use_imptorsion) return - - !$omp parallel do default(shared) & - !$omp private(i, ia, ib, ic, id, sk_a, sk_b, sk_c, sk_d, j, thet, J_a, J_b, J_c, J_d, g) - do i = 1, bds%nimptorsion - ! Atoms that define the dihedral angle - ia = bds%imptorsionat(1, i) - ib = bds%imptorsionat(2, i) - ic = bds%imptorsionat(3, i) - id = bds%imptorsionat(4, i) - - if (bds%top%use_frozen) then - sk_a = bds%top%frozen(ia) - sk_b = bds%top%frozen(ib) - sk_c = bds%top%frozen(ic) - sk_d = bds%top%frozen(id) - if (sk_a .and. sk_b .and. sk_c .and. sk_d) cycle - else - sk_a = .false. - sk_b = .false. - sk_c = .false. - sk_d = .false. - end if - - call torsion_angle_jacobian(bds%top%cmm(:, ia), & - bds%top%cmm(:, ib), & - bds%top%cmm(:, ic), & - bds%top%cmm(:, id), & - thet, J_a, J_b, J_c, J_d) - - do j = 1, 3 - if (bds%imptorsn(j, i) < 1) exit - g = -real(bds%imptorsn(j, i)) * sin(real(bds%imptorsn(j, i)) * thet & - - bds%imptorsphase(j, i)) & - * bds%imptorsamp(j, i) - if (.not. sk_a) then - !$omp atomic update - grad(1, ia) = grad(1, ia) + J_a(1) * g - !$omp atomic update - grad(2, ia) = grad(2, ia) + J_a(2) * g - !$omp atomic update - grad(3, ia) = grad(3, ia) + J_a(3) * g - end if - if (.not. sk_b) then - !$omp atomic update - grad(1, ib) = grad(1, ib) + J_b(1) * g - !$omp atomic update - grad(2, ib) = grad(2, ib) + J_b(2) * g - !$omp atomic update - grad(3, ib) = grad(3, ib) + J_b(3) * g - end if - if (.not. sk_c) then - !$omp atomic update - grad(1, ic) = grad(1, ic) + J_c(1) * g - !$omp atomic update - grad(2, ic) = grad(2, ic) + J_c(2) * g - !$omp atomic update - grad(3, ic) = grad(3, ic) + J_c(3) * g - end if - if (.not. sk_d) then - !$omp atomic update - grad(1, id) = grad(1, id) + J_d(1) * g - !$omp atomic update - grad(2, id) = grad(2, id) + J_d(2) * g - !$omp atomic update - grad(3, id) = grad(3, id) + J_d(3) * g - end if - end do - end do - end subroutine imptorsion_geomgrad - - subroutine imptorsion_init(bds, n) - !! Initialize improper torsion potential arrays - - use mod_memory, only: mallocate - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - integer(ip) :: n - !! Number of improper torsion functions in the potential - !! energy of the system - - if( n < 1 ) return - bds%use_imptorsion = .true. - - call mallocate('imptorsion_init [imptorsionat]', 4, n, bds%imptorsionat) - call mallocate('imptorsion_init [imptorsamp]', 3, n, bds%imptorsamp) - call mallocate('imptorsion_init [imptorsphase]', 3, n, bds%imptorsphase) - call mallocate('imptorsion_init [imptorsn]', 3, n, bds%imptorsn) - - bds%nimptorsion = n - - end subroutine imptorsion_init - - subroutine angtor_init(bds, n) - !! Initialize angle-torsion coupling potential arrays - - use mod_memory, only: mallocate - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - integer(ip) :: n - !! Number of angle torsion coupling functions in the potential - !! energy of the system - - if( n < 1 ) return - bds%use_angtor = .true. - - call mallocate('angtor_init [angtorat]', 4, n, bds%angtorat) - call mallocate('angtor_init [angtork]', 6, n, bds%angtork) - call mallocate('angtor_init [angtor_t]', n, bds%angtor_t) - call mallocate('angtor_init [angtor_a]', 2, n, bds%angtor_a) - - bds%nangtor = n - - end subroutine angtor_init - - subroutine strtor_init(bds, n) - - use mod_memory, only: mallocate - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - integer(ip) :: n - - if( n < 1 ) return - bds%use_strtor = .true. - - call mallocate('strtor_init [strtorat]', 4, n, bds%strtorat) - call mallocate('strtor_init [strtork]', 9, n, bds%strtork) - call mallocate('strtor_init [strtor_t]', n, bds%strtor_t) - call mallocate('strtor_init [strtor_a]', 3, n, bds%strtor_b) - - bds%nstrtor = n - - end subroutine strtor_init - - subroutine angtor_potential(bds, V) - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: V - real(rp) :: thet, costhet, dihef(3), delta_a(2), vat, l1, l2, & - dr1(3), dr2(3), angle1, angle2 - integer(ip) :: i, j, k, ia1, ia2 - - if(.not. bds%use_angtor) return - - !$omp parallel do default(shared) reduction(+:V) & - !$omp private(i,costhet,thet,j,dihef,ia1,ia2,dr1,dr2,l1,l2,angle1,angle2,delta_a,vat,k) - do i=1, bds%nangtor - ! Atoms that defines the dihedral angle - costhet = cos_torsion(bds%top, bds%angtorat(:,i)) - thet = acos(costhet) - do j=1, 3 - dihef(j) = 1.0 + cos(j*thet+bds%torsphase(j,bds%angtor_t(i))) - end do - - ia1 = bds%angtor_a(1,i) - ia2 = bds%angtor_a(2,i) - - dr1 = bds%top%cmm(:, bds%angleat(1,ia1)) - & - bds%top%cmm(:, bds%angleat(2,ia1)) - dr2 = bds%top%cmm(:, bds%angleat(3,ia1)) - & - bds%top%cmm(:, bds%angleat(2,ia1)) - l1 = norm2(dr1) - l2 = norm2(dr2) - angle1 = acos(dot_product(dr1, dr2)/(l1*l2)) - - dr1 = bds%top%cmm(:, bds%angleat(1,ia2)) - & - bds%top%cmm(:, bds%angleat(2,ia2)) - dr2 = bds%top%cmm(:, bds%angleat(3,ia2)) - & - bds%top%cmm(:, bds%angleat(2,ia2)) - l1 = norm2(dr1) - l2 = norm2(dr2) - angle2 = acos(dot_product(dr1, dr2)/(l1*l2)) - - delta_a(1) = angle1 - bds%eqangle(bds%angtor_a(1,i)) - delta_a(2) = angle2 - bds%eqangle(bds%angtor_a(2,i)) - - do j=1,2 - vat = 0.0 - do k=1, 3 - vat = vat + bds%angtork((j-1)*3+k,i) * dihef(k) - end do - V = V + vat * delta_a(j) - end do - end do - - end subroutine angtor_potential - - subroutine angtor_geomgrad(bds, grad) - use mod_jacobian_mat, only: simple_angle_jacobian, torsion_angle_jacobian - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) - !! improper torsion potential, result will be added to V - real(rp) :: thet, gt(3), dihef(3), da1, da2, angle1, angle2, f1, f2, f3, & - Jt_a(3), Jt_b(3), Jt_c(3), Jt_d(3), & - Ja1_a(3), Ja1_b(3), Ja1_c(3), & - Ja2_a(3), Ja2_b(3), Ja2_c(3) - - integer(ip) :: i, j, k, ia1, ia2, & - it_a, it_b, it_c, it_d, & - ia1_a, ia1_b, ia1_c, & - ia2_a, ia2_b, ia2_c - logical :: sk_ta, sk_tb, sk_tc, sk_td, & - sk_1a, sk_1b, sk_1c, & - sk_2a, sk_2b, sk_2c - - if(.not. bds%use_angtor) return - - !$omp parallel do default(shared) & - !$omp private(thet, gt, dihef, da1, da2, angle1, angle2, f1, f2, f3, Jt_a, Jt_b) & - !$omp private(Jt_c, Jt_d, Ja1_a, Ja1_b, Ja1_c) & - !$omp private(Ja2_a, Ja2_b, Ja2_c, i, j, k, ia1, ia2) & - !$omp private(it_a, it_b, it_c, it_d, ia1_a, ia1_b, ia1_c, ia2_a, ia2_b, ia2_c) & - !$omp private(sk_ta, sk_tb, sk_tc, sk_td, sk_1a, sk_1b, sk_1c, sk_2a, sk_2b, sk_2c) - do i=1, bds%nangtor - ! Atoms that define the dihedral angle - it_a = bds%angtorat(1,i) - it_b = bds%angtorat(2,i) - it_c = bds%angtorat(3,i) - it_d = bds%angtorat(4,i) - - ia1 = bds%angtor_a(1,i) - ia1_a = bds%angleat(1,ia1) - ia1_b = bds%angleat(2,ia1) - ia1_c = bds%angleat(3,ia1) - - ia2 = bds%angtor_a(2,i) - ia2_a = bds%angleat(1,ia2) - ia2_b = bds%angleat(2,ia2) - ia2_c = bds%angleat(3,ia2) - - if(bds%top%use_frozen) then - sk_ta = bds%top%frozen(it_a) - sk_tb = bds%top%frozen(it_b) - sk_tc = bds%top%frozen(it_c) - sk_td = bds%top%frozen(it_d) - - sk_1a = bds%top%frozen(ia1_a) - sk_1b = bds%top%frozen(ia1_b) - sk_1c = bds%top%frozen(ia1_c) - - sk_2a = bds%top%frozen(ia2_a) - sk_2b = bds%top%frozen(ia2_b) - sk_2c = bds%top%frozen(ia2_c) - - if(sk_ta .and. sk_tb .and. sk_tc .and. sk_td .and. & - sk_1a .and. sk_1b .and. sk_1c .and. & - sk_2a .and. sk_2b .and. sk_2c) cycle - else - sk_ta = .false. - sk_tb = .false. - sk_tc = .false. - sk_td = .false. - sk_1a = .false. - sk_1b = .false. - sk_1c = .false. - sk_2a = .false. - sk_2b = .false. - sk_2c = .false. - end if - - call torsion_angle_jacobian(bds%top%cmm(:,it_a), & - bds%top%cmm(:,it_b), & - bds%top%cmm(:,it_c), & - bds%top%cmm(:,it_d), & - thet, Jt_a, Jt_b, Jt_c, Jt_d) - do j=1, 3 - gt(j) = -real(j) * sin(j*thet+bds%torsphase(j,bds%angtor_t(i))) - dihef(j) = 1.0 + cos(j*thet+bds%torsphase(j,bds%angtor_t(i))) - end do - - call simple_angle_jacobian(bds%top%cmm(:,ia1_a), & - bds%top%cmm(:,ia1_b), & - bds%top%cmm(:,ia1_c), & - angle1, Ja1_a, Ja1_b, Ja1_c) - - call simple_angle_jacobian(bds%top%cmm(:,ia2_a), & - bds%top%cmm(:,ia2_b), & - bds%top%cmm(:,ia2_c), & - angle2, Ja2_a, Ja2_b, Ja2_c) - - da1 = angle1 - bds%eqangle(ia1) - da2 = angle2 - bds%eqangle(ia2) - - do k = 1, 3 - if(.not.(sk_ta .and. sk_tb .and. sk_tc .and. sk_td)) & - f1 = (bds%angtork(k, i) * da1 + bds%angtork(3+k,i) * da2) * gt(k) - if(.not.(sk_1a .and. sk_1b .and. sk_1c)) & - f2 = bds%angtork(k, i) * dihef(k) - if(.not.(sk_2a .and. sk_2b .and. sk_2c)) & - f3 = bds%angtork(3+k, i) * dihef(k) - - if (.not. sk_ta) then - !$omp atomic update - grad(1, it_a) = grad(1, it_a) + f1 * Jt_a(1) - !$omp atomic update - grad(2, it_a) = grad(2, it_a) + f1 * Jt_a(2) - !$omp atomic update - grad(3, it_a) = grad(3, it_a) + f1 * Jt_a(3) - end if - - if (.not. sk_tb) then - !$omp atomic update - grad(1, it_b) = grad(1, it_b) + f1 * Jt_b(1) - !$omp atomic update - grad(2, it_b) = grad(2, it_b) + f1 * Jt_b(2) - !$omp atomic update - grad(3, it_b) = grad(3, it_b) + f1 * Jt_b(3) - end if - if (.not. sk_tc) then - !$omp atomic update - grad(1, it_c) = grad(1, it_c) + f1 * Jt_c(1) - !$omp atomic update - grad(2, it_c) = grad(2, it_c) + f1 * Jt_c(2) - !$omp atomic update - grad(3, it_c) = grad(3, it_c) + f1 * Jt_c(3) - end if - if (.not. sk_td) then - !$omp atomic update - grad(1, it_d) = grad(1, it_d) + f1 * Jt_d(1) - !$omp atomic update - grad(2, it_d) = grad(2, it_d) + f1 * Jt_d(2) - !$omp atomic update - grad(3, it_d) = grad(3, it_d) + f1 * Jt_d(3) - end if - - if (.not. sk_1a) then - !$omp atomic update - grad(1, ia1_a) = grad(1, ia1_a) + f2 * Ja1_a(1) - !$omp atomic update - grad(2, ia1_a) = grad(2, ia1_a) + f2 * Ja1_a(2) - !$omp atomic update - grad(3, ia1_a) = grad(3, ia1_a) + f2 * Ja1_a(3) - end if - if (.not. sk_1b) then - !$omp atomic update - grad(1, ia1_b) = grad(1, ia1_b) + f2 * Ja1_b(1) - !$omp atomic update - grad(2, ia1_b) = grad(2, ia1_b) + f2 * Ja1_b(2) - !$omp atomic update - grad(3, ia1_b) = grad(3, ia1_b) + f2 * Ja1_b(3) - end if - if (.not. sk_1c) then - !$omp atomic update - grad(1, ia1_c) = grad(1, ia1_c) + f2 * Ja1_c(1) - !$omp atomic update - grad(2, ia1_c) = grad(2, ia1_c) + f2 * Ja1_c(2) - !$omp atomic update - grad(3, ia1_c) = grad(3, ia1_c) + f2 * Ja1_c(3) - end if - - if (.not. sk_2a) then - !$omp atomic update - grad(1, ia2_a) = grad(1, ia2_a) + f3 * Ja2_a(1) - !$omp atomic update - grad(2, ia2_a) = grad(2, ia2_a) + f3 * Ja2_a(2) - !$omp atomic update - grad(3, ia2_a) = grad(3, ia2_a) + f3 * Ja2_a(3) - end if - if (.not. sk_2b) then - !$omp atomic update - grad(1, ia2_b) = grad(1, ia2_b) + f3 * Ja2_b(1) - !$omp atomic update - grad(2, ia2_b) = grad(2, ia2_b) + f3 * Ja2_b(2) - !$omp atomic update - grad(3, ia2_b) = grad(3, ia2_b) + f3 * Ja2_b(3) - end if - if (.not. sk_2c) then - !$omp atomic update - grad(1, ia2_c) = grad(1, ia2_c) + f3 * Ja2_c(1) - !$omp atomic update - grad(2, ia2_c) = grad(2, ia2_c) + f3 * Ja2_c(2) - !$omp atomic update - grad(3, ia2_c) = grad(3, ia2_c) + f3 * Ja2_c(3) - end if - end do - end do - end subroutine angtor_geomgrad - - subroutine strtor_potential(bds, V) - use mod_constants - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: V - real(rp) :: thet, costhet, dihef(3), dr(3), r(3), vst - integer(ip) :: i, j, k, ib1, ib2, ib3 - - if(.not. bds%use_strtor) return - - !$omp parallel do default(shared) reduction(+:V) & - !$omp private(i,costhet,thet,j,dihef,ib1,ib2,ib3,r,dr,vst,k) - do i=1, bds%nstrtor - ! Atoms that defines the dihedral angle - costhet = cos_torsion(bds%top, bds%strtorat(:,i)) - thet = acos(costhet) - do j=1, 3 - dihef(j) = 1.0 + cos(j*thet+bds%torsphase(j,bds%strtor_t(i))) - end do - - ib1 = bds%strtor_b(1,i) - ib2 = bds%strtor_b(2,i) - ib3 = bds%strtor_b(3,i) - r(1) = norm2(bds%top%cmm(:, bds%bondat(1,ib1)) - & - bds%top%cmm(:, bds%bondat(2,ib1))) - r(2) = norm2(bds%top%cmm(:, bds%bondat(1,ib2)) - & - bds%top%cmm(:, bds%bondat(2,ib2))) - r(3) = norm2(bds%top%cmm(:, bds%bondat(1,ib3)) - & - bds%top%cmm(:, bds%bondat(2,ib3))) - dr(1) = r(1) - bds%l0bond(ib1) - dr(2) = r(2) - bds%l0bond(ib2) - dr(3) = r(3) - bds%l0bond(ib3) - - do j=1,3 - vst = 0.0 - do k=1, 3 - vst = vst + bds%strtork((j-1)*3+k,i) * dihef(k) - end do - V = V + vst * dr(j) - end do - end do - - end subroutine strtor_potential - - subroutine strtor_geomgrad(bds, grad) - use mod_jacobian_mat, only: Rij_jacobian, torsion_angle_jacobian - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: grad(3, bds%top%mm_atoms) - !! improper torsion potential, result will be added to V - - real(rp) :: thet, gt(3), dihef(3), dr1, dr2, dr3, r1, r2, r3, & - Jt_a(3), Jt_b(3), Jt_c(3), Jt_d(3), & - Jb1_a(3), Jb1_b(3), & - Jb2_a(3), Jb2_b(3), & - Jb3_a(3), Jb3_b(3) - - integer(ip) :: i, j, k, ib1, ib2, ib3, & - it_a, it_b, it_c, it_d, & - ib1_a, ib1_b, & - ib2_a, ib2_b, & - ib3_a, ib3_b - logical :: sk_ta, sk_tb, sk_tc, sk_td, & - sk_1a, sk_1b, & - sk_2a, sk_2b, & - sk_3a, sk_3b - - if (.not. bds%use_strtor) return - - !$omp parallel do default(shared) & - !$omp private(thet, gt, dihef, dr1, dr2, dr3, r1, r2, r3) & - !$omp private(Jt_a, Jt_b, Jt_c, Jt_d, Jb1_a, Jb1_b, Jb2_a, Jb2_b) & - !$omp private(Jb3_a, Jb3_b, i, j, k, ib1, ib2, ib3, it_a, it_b, it_c, it_d) & - !$omp private(ib1_a, ib1_b, ib2_a, ib2_b, ib3_a, ib3_b, sk_ta, sk_tb, sk_tc, sk_td) & - !$omp private(sk_1a, sk_1b, sk_2a, sk_2b, sk_3a, sk_3b) - do i = 1, bds%nstrtor - ! Atoms that define the dihedral angle - it_a = bds%strtorat(1, i) - it_b = bds%strtorat(2, i) - it_c = bds%strtorat(3, i) - it_d = bds%strtorat(4, i) - - ib1 = bds%strtor_b(1, i) - ib1_a = bds%bondat(1, ib1) - ib1_b = bds%bondat(2, ib1) - - ib2 = bds%strtor_b(2, i) - ib2_a = bds%bondat(1, ib2) - ib2_b = bds%bondat(2, ib2) - - ib3 = bds%strtor_b(3, i) - ib3_a = bds%bondat(1, ib3) - ib3_b = bds%bondat(2, ib3) - - if (bds%top%use_frozen) then - sk_ta = bds%top%frozen(it_a) - sk_tb = bds%top%frozen(it_b) - sk_tc = bds%top%frozen(it_c) - sk_td = bds%top%frozen(it_d) - - sk_1a = bds%top%frozen(ib1_a) - sk_1b = bds%top%frozen(ib1_b) - - sk_2a = bds%top%frozen(ib2_a) - sk_2b = bds%top%frozen(ib2_b) - - sk_3a = bds%top%frozen(ib3_a) - sk_3b = bds%top%frozen(ib3_b) - - if (sk_ta .and. sk_tb .and. sk_tc .and. sk_td .and. & - sk_1a .and. sk_1b .and. & - sk_2a .and. sk_2b .and. & - sk_3a .and. sk_3b) cycle - else - sk_ta = .false. - sk_tb = .false. - sk_tc = .false. - sk_td = .false. - sk_1a = .false. - sk_1b = .false. - sk_2a = .false. - sk_2b = .false. - sk_3a = .false. - sk_3b = .false. - end if - - call torsion_angle_jacobian(bds%top%cmm(:, it_a), & - bds%top%cmm(:, it_b), & - bds%top%cmm(:, it_c), & - bds%top%cmm(:, it_d), & - thet, Jt_a, Jt_b, Jt_c, Jt_d) - do j = 1, 3 - gt(j) = -real(j) * sin(j * thet + bds%torsphase(j, bds%angtor_t(i))) - dihef(j) = 1.0 + cos(j * thet + bds%torsphase(j, bds%angtor_t(i))) - end do - - call Rij_jacobian(bds%top%cmm(:, ib1_a), & - bds%top%cmm(:, ib1_b), & - r1, Jb1_a, Jb1_b) - dr1 = r1 - bds%l0bond(ib1) - - call Rij_jacobian(bds%top%cmm(:, ib2_a), & - bds%top%cmm(:, ib2_b), & - r2, Jb2_a, Jb2_b) - dr2 = r2 - bds%l0bond(ib2) - - call Rij_jacobian(bds%top%cmm(:, ib3_a), & - bds%top%cmm(:, ib3_b), & - r3, Jb3_a, Jb3_b) - dr3 = r3 - bds%l0bond(ib3) - - do k = 1, 3 - if (.not. sk_ta) then - !$omp atomic update - grad(1, it_a) = grad(1, it_a) + bds%strtork(k, i) * dr1 * gt(k) * Jt_a(1) - !$omp atomic update - grad(2, it_a) = grad(2, it_a) + bds%strtork(k, i) * dr1 * gt(k) * Jt_a(2) - !$omp atomic update - grad(3, it_a) = grad(3, it_a) + bds%strtork(k, i) * dr1 * gt(k) * Jt_a(3) - end if - if (.not. sk_tb) then - !$omp atomic update - grad(1, it_b) = grad(1, it_b) + bds%strtork(k, i) * dr1 * gt(k) * Jt_b(1) - !$omp atomic update - grad(2, it_b) = grad(2, it_b) + bds%strtork(k, i) * dr1 * gt(k) * Jt_b(2) - !$omp atomic update - grad(3, it_b) = grad(3, it_b) + bds%strtork(k, i) * dr1 * gt(k) * Jt_b(3) - end if - if (.not. sk_tc) then - !$omp atomic update - grad(1, it_c) = grad(1, it_c) + bds%strtork(k, i) * dr1 * gt(k) * Jt_c(1) - !$omp atomic update - grad(2, it_c) = grad(2, it_c) + bds%strtork(k, i) * dr1 * gt(k) * Jt_c(2) - !$omp atomic update - grad(3, it_c) = grad(3, it_c) + bds%strtork(k, i) * dr1 * gt(k) * Jt_c(3) - end if - if (.not. sk_td) then - !$omp atomic update - grad(1, it_d) = grad(1, it_d) + bds%strtork(k, i) * dr1 * gt(k) * Jt_d(1) - !$omp atomic update - grad(2, it_d) = grad(2, it_d) + bds%strtork(k, i) * dr1 * gt(k) * Jt_d(2) - !$omp atomic update - grad(3, it_d) = grad(3, it_d) + bds%strtork(k, i) * dr1 * gt(k) * Jt_d(3) - end if - if (.not. sk_1a) then - !$omp atomic update - grad(1, ib1_a) = grad(1, ib1_a) + bds%strtork(k, i) * dihef(k) * Jb1_a(1) - !$omp atomic update - grad(2, ib1_a) = grad(2, ib1_a) + bds%strtork(k, i) * dihef(k) * Jb1_a(2) - !$omp atomic update - grad(3, ib1_a) = grad(3, ib1_a) + bds%strtork(k, i) * dihef(k) * Jb1_a(3) - end if - if (.not. sk_1b) then - !$omp atomic update - grad(1, ib1_b) = grad(1, ib1_b) + bds%strtork(k, i) * dihef(k) * Jb1_b(1) - !$omp atomic update - grad(2, ib1_b) = grad(2, ib1_b) + bds%strtork(k, i) * dihef(k) * Jb1_b(2) - !$omp atomic update - grad(3, ib1_b) = grad(3, ib1_b) + bds%strtork(k, i) * dihef(k) * Jb1_b(3) - end if - if (.not. sk_ta) then - !$omp atomic update - grad(1, it_a) = grad(1, it_a) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_a(1) - !$omp atomic update - grad(2, it_a) = grad(2, it_a) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_a(2) - !$omp atomic update - grad(3, it_a) = grad(3, it_a) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_a(3) - end if - if (.not. sk_tb) then - !$omp atomic update - grad(1, it_b) = grad(1, it_b) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_b(1) - !$omp atomic update - grad(2, it_b) = grad(2, it_b) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_b(2) - !$omp atomic update - grad(3, it_b) = grad(3, it_b) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_b(3) - end if - if (.not. sk_tc) then - !$omp atomic update - grad(1, it_c) = grad(1, it_c) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_c(1) - !$omp atomic update - grad(2, it_c) = grad(2, it_c) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_c(2) - !$omp atomic update - grad(3, it_c) = grad(3, it_c) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_c(3) - end if - if (.not. sk_td) then - !$omp atomic update - grad(1, it_d) = grad(1, it_d) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_d(1) - !$omp atomic update - grad(2, it_d) = grad(2, it_d) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_d(2) - !$omp atomic update - grad(3, it_d) = grad(3, it_d) + bds%strtork(3 + k, i) * dr2 * gt(k) * Jt_d(3) - end if - if (.not. sk_2a) then - !$omp atomic update - grad(1, ib2_a) = grad(1, ib2_a) + bds%strtork(3 + k, i) * dihef(k) * Jb2_a(1) - !$omp atomic update - grad(2, ib2_a) = grad(2, ib2_a) + bds%strtork(3 + k, i) * dihef(k) * Jb2_a(2) - !$omp atomic update - grad(3, ib2_a) = grad(3, ib2_a) + bds%strtork(3 + k, i) * dihef(k) * Jb2_a(3) - end if - if (.not. sk_2b) then - !$omp atomic update - grad(1, ib2_b) = grad(1, ib2_b) + bds%strtork(3 + k, i) * dihef(k) * Jb2_b(1) - !$omp atomic update - grad(2, ib2_b) = grad(2, ib2_b) + bds%strtork(3 + k, i) * dihef(k) * Jb2_b(2) - !$omp atomic update - grad(3, ib2_b) = grad(3, ib2_b) + bds%strtork(3 + k, i) * dihef(k) * Jb2_b(3) - end if - if (.not. sk_ta) then - !$omp atomic update - grad(1, it_a) = grad(1, it_a) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_a(1) - !$omp atomic update - grad(2, it_a) = grad(2, it_a) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_a(2) - !$omp atomic update - grad(3, it_a) = grad(3, it_a) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_a(3) - end if - if (.not. sk_tb) then - !$omp atomic update - grad(1, it_b) = grad(1, it_b) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_b(1) - !$omp atomic update - grad(2, it_b) = grad(2, it_b) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_b(2) - !$omp atomic update - grad(3, it_b) = grad(3, it_b) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_b(3) - end if - if (.not. sk_tc) then - !$omp atomic update - grad(1, it_c) = grad(1, it_c) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_c(1) - !$omp atomic update - grad(2, it_c) = grad(2, it_c) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_c(2) - !$omp atomic update - grad(3, it_c) = grad(3, it_c) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_c(3) - end if - if (.not. sk_td) then - !$omp atomic update - grad(1, it_d) = grad(1, it_d) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_d(1) - !$omp atomic update - grad(2, it_d) = grad(2, it_d) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_d(2) - !$omp atomic update - grad(3, it_d) = grad(3, it_d) + bds%strtork(6 + k, i) * dr3 * gt(k) * Jt_d(3) - end if - if (.not. sk_3a) then - !$omp atomic update - grad(1, ib3_a) = grad(1, ib3_a) + bds%strtork(6 + k, i) * dihef(k) * Jb3_a(1) - !$omp atomic update - grad(2, ib3_a) = grad(2, ib3_a) + bds%strtork(6 + k, i) * dihef(k) * Jb3_a(2) - !$omp atomic update - grad(3, ib3_a) = grad(3, ib3_a) + bds%strtork(6 + k, i) * dihef(k) * Jb3_a(3) - end if - if (.not. sk_3b) then - !$omp atomic update - grad(1, ib3_b) = grad(1, ib3_b) + bds%strtork(6 + k, i) * dihef(k) * Jb3_b(1) - !$omp atomic update - grad(2, ib3_b) = grad(2, ib3_b) + bds%strtork(6 + k, i) * dihef(k) * Jb3_b(2) - !$omp atomic update - grad(3, ib3_b) = grad(3, ib3_b) + bds%strtork(6 + k, i) * dihef(k) * Jb3_b(3) - end if - end do - end do - end subroutine strtor_geomgrad - - - subroutine tortor_init(bds, n) - !! Initialize torsion-torsion correction potential arrays - - use mod_memory, only: mallocate - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - integer(ip) :: n - !! Number of torsion-torsion 'map' functions in the potential - !! energy of the system - - if( n < 1 ) return - bds%use_tortor = .true. - - call mallocate('torsion_init [tortorprm]', n, bds%tortorprm ) - call mallocate('torsion_init [tortorat]', 5, n, bds%tortorat) - - bds%ntortor = n - - end subroutine tortor_init - - subroutine tortor_newmap(bds, d1, d2, ang1, ang2, v) - !! Store in module memory the data describing a new torsion-torsion - !! map - use mod_memory, only: mallocate, mfree - use mod_utils, only: cyclic_spline - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - integer(ip), intent(in) :: d1, d2 - !! Dimensions of the new map to be saved - real(rp), intent(in) :: ang1(:) - !! Value of torsion1 for the new map - real(rp), intent(in) :: ang2(:) - !! Value of torsion2 for the new map - real(rp), intent(in) :: v(:) - !! Value of potential for the new map - - integer :: i, j, ii - real(rp), allocatable, dimension(:) :: a, b, c, d, dx, dy, dxy, tmpx, tmpy - - real(rp), allocatable :: rtmp(:) - integer(ip), allocatable :: itmp(:,:) - integer(ip) :: n_data, n_map - - if(allocated(bds%ttmap_ang1)) then - ! Reallocate the arrays to make space for the new data - n_data = size(bds%ttmap_ang1) - call mallocate('torstors_newmap [rtmp]', n_data, rtmp) - - rtmp = bds%ttmap_ang1 - call mfree('torstors_newmap [ttmap_ang1]', bds%ttmap_ang1) - call mallocate('torstors_newmap [ttmap_ang1]', & - n_data+d1*d2, bds%ttmap_ang1) - bds%ttmap_ang1(:n_data) = rtmp - - rtmp = bds%ttmap_ang2 - call mfree('torstors_newmap [ttmap_ang2]', bds%ttmap_ang2) - call mallocate('torstors_newmap [ttmap_ang2]', & - n_data+d1*d2, bds%ttmap_ang2) - bds%ttmap_ang2(:n_data) = rtmp - - - call mfree('torstors_newmap [rtmp]', rtmp) - n_data = size(bds%ttmap_v) - call mallocate('torstors_newmap [rtmp]', n_data, rtmp) - - rtmp = bds%ttmap_v - call mfree('torstors_newmap [ttmap_v]', bds%ttmap_v) - call mallocate('torstors_newmap [ttmap_v]', & - n_data+d1*d2, bds%ttmap_v) - bds%ttmap_v(:n_data) = rtmp - - rtmp = bds%ttmap_vx - call mfree('torstors_newmap [ttmap_vx]', bds%ttmap_vx) - call mallocate('torstors_newmap [ttmap_vx]', & - n_data+d1*d2, bds%ttmap_vx) - bds%ttmap_vx(:n_data) = rtmp - - rtmp = bds%ttmap_vy - call mfree('torstors_newmap [ttmap_vy]', bds%ttmap_vy) - call mallocate('torstors_newmap [ttmap_vy]', & - n_data+d1*d2, bds%ttmap_vy) - bds%ttmap_vy(:n_data) = rtmp - - rtmp = bds%ttmap_vxy - call mfree('torstors_newmap [ttmap_vxy]', bds%ttmap_vxy) - call mallocate('torstors_newmap [ttmap_vxy]', & - n_data+d1*d2, bds%ttmap_vxy) - bds%ttmap_vxy(:n_data) = rtmp - call mfree('torstors_newmap [rtmp]', rtmp) - - n_map = size(bds%ttmap_shape, 2) - call mallocate('torstors_newmap [itmp]', 2, n_map, itmp) - itmp = bds%ttmap_shape - call mfree('torstors_newmap [ttmap_shape]', bds%ttmap_shape) - call mallocate('torstors_newmap [ttmap_shape]', & - 2, n_map+1, bds%ttmap_shape) - bds%ttmap_shape(:,:n_map) = itmp - - call mfree('torstors_newmap [itmp]', itmp) - else - ! First allocation, n_data and n_map are just set for consistency - n_data = 0 - n_map = 0 - call mallocate('torstors_newmap [ttmap_ang1]', d1*d2, bds%ttmap_ang1) - call mallocate('torstors_newmap [ttmap_ang2]', d1*d2, bds%ttmap_ang2) - call mallocate('torstors_newmap [ttmap_v]', d1*d2, bds%ttmap_v) - call mallocate('torstors_newmap [ttmap_vx]', d1*d2, bds%ttmap_vx) - call mallocate('torstors_newmap [ttmap_vy]', d1*d2, bds%ttmap_vy) - call mallocate('torstors_newmap [ttmap_vxy]', d1*d2, bds%ttmap_vxy) - call mallocate('torstors_newmap [ttmap_shape]', 2, 1, bds%ttmap_shape) - end if - - call mallocate('tortor_newmap [a]', max(d1,d2), a) - call mallocate('tortor_newmap [b]', max(d1,d2), b) - call mallocate('tortor_newmap [c]', max(d1,d2), c) - call mallocate('tortor_newmap [d]', max(d1,d2), d) - call mallocate('tortor_newmap [dx]', d1*d2, dx) - call mallocate('tortor_newmap [dy]', d1*d2, dy) - call mallocate('tortor_newmap [dxy]', d1*d2, dxy) - - ! This part of the code computes df/dx, df/dy and d^2f/dxdy on the grid. - ! Since we are basically interpolating on a sphere, we extract the - ! coordinate on a meridian, we interpolate it with a cubic spline, and - ! finally we compute the derivative of this curve at the grid intersection - ! The same is done in the second direction. - ! To compute the mixed derivative we apply the same procedure but using - ! the derivative data (basically we apply the procedure used to compute - ! df/dx but using df/dy data instead of actual f values. - do i=1, d2 - call cyclic_spline(d1, ang1((i-1)*d1+1:i*d1), v((i-1)*d1+1:i*d1), & - a(1:d1), b(1:d1), c(1:d1), d(1:d1)) - dx((i-1)*d1+1:i*d1) = b(1:d1) - end do - - ! df/dy since in this direction data are not contiguous, wa allocate - ! temporary arrays - call mallocate('tortor_newmap [tmpx]', d2, tmpx) - call mallocate('tortor_newmap [tmpy]', d2, tmpy) - do i=1, d1 - ii = 1 - do j=i, (d2-1)*d1+i, d2 - tmpx(ii) = ang2(j) - tmpy(ii) = v(j) - ii = ii + 1 - end do - call cyclic_spline(d2, tmpx, tmpy, & - a(1:d2), b(1:d2), c(1:d2), d(1:d2)) - - ii = 1 - do j=i, (d2-1)*d1+i, d2 - dy(j) = b(ii) - ii = ii + 1 - end do - end do - - ! d^2f/dxdy in this case we use df/dx procedure to exploit data contiguity. - do i=1, d2 - call cyclic_spline(d1, ang1((i-1)*d1+1:i*d1), dy((i-1)*d1+1:i*d1), & - a(1:d1), b(1:d1), c(1:d1), d(1:d1)) - dxy((i-1)*d1+1:i*d1) = b(1:d1) - end do - call mfree('tortor_newmap [tmpx]', tmpx) - call mfree('tortor_newmap [tmpy]', tmpy) - - bds%ttmap_ang1(n_data+1:) = ang1 - bds%ttmap_ang2(n_data+1:) = ang2 - bds%ttmap_shape(1,n_map+1) = d1 - bds%ttmap_shape(2,n_map+1) = d2 - bds%ttmap_v(n_data+1:) = v - bds%ttmap_vx(n_data+1:) = dx - bds%ttmap_vy(n_data+1:) = dy - bds%ttmap_vxy(n_data+1:) = dxy - - call mfree('tortor_newmap [a]', a) - call mfree('tortor_newmap [b]', b) - call mfree('tortor_newmap [c]', c) - call mfree('tortor_newmap [d]', d) - call mfree('tortor_newmap [dx]', dx) - call mfree('tortor_newmap [dy]', dy) - call mfree('tortor_newmap [dxy]', dxy) - - end subroutine tortor_newmap - - subroutine tortor_potential(bds, V) - !! Compute torsion potential - - use mod_utils, only: compute_bicubic_interp - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: V - !! torsion potential, result will be added to V - real(rp) :: thetx, thety, vtt, dvttdx, dvttdy - - integer(ip) :: i, j, iprm, ibeg, iend - - if(.not. bds%use_tortor) return - - !$omp parallel do default(shared) reduction(+:V) & - !$omp private(i,iprm,ibeg,j,iend,thetx,thety,vtt,dvttdx,dvttdy) - do i=1, bds%ntortor - ! Atoms that defines the two angles - iprm = bds%tortorprm(i) - ibeg = 1 - do j=1, iprm-1 - ibeg = ibeg + bds%ttmap_shape(1,j)*bds%ttmap_shape(2,j) - end do - iend = ibeg + bds%ttmap_shape(1,iprm)*bds%ttmap_shape(2,iprm) - 1 - - thetx = ang_torsion(bds%top, bds%tortorat(1:4,i)) - thety = ang_torsion(bds%top, bds%tortorat(2:5,i)) - - call compute_bicubic_interp(thetx, thety, vtt, & - dvttdx, dvttdy, & - bds%ttmap_shape(1,iprm), & - bds%ttmap_shape(2,iprm), & - bds%ttmap_ang1(ibeg:iend), & - bds%ttmap_ang2(ibeg:iend), & - bds%ttmap_v(ibeg:iend), & - bds%ttmap_vx(ibeg:iend), & - bds%ttmap_vy(ibeg:iend), & - bds%ttmap_vxy(ibeg:iend)) - - V = V + vtt - end do - - end subroutine tortor_potential - - subroutine tortor_geomgrad(bds, grad) - !! Compute torsion potential - - use mod_utils, only: compute_bicubic_interp - use mod_jacobian_mat, only: torsion_angle_jacobian - - implicit none - - type(ommp_bonded_type), intent(in) :: bds - ! Bonded potential data structure - real(rp), intent(inout) :: grad(3,bds%top%mm_atoms) - !! improper torsion potential, result will be added to V - real(rp) :: thetx, thety, vtt, dvttdx, dvttdy - real(rp), dimension(3) :: J1_a, J1_b, J2_b, J1_c, & - J2_c, J1_d, J2_d, J2_e - - integer(ip) :: i, j, iprm, ibeg, iend, ia, ib, ic, id, ie - logical :: sk_a, sk_b, sk_c, sk_d, sk_e - - if(.not. bds%use_tortor) return - - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,iprm,ibeg,j,iend,ia,ib,ic,id,ie,sk_a,sk_b,sk_c,sk_d,sk_e) & - !$omp private(thetx,thety,J1_a,J1_b,J1_c,J1_d,J2_b,J2_c,J2_d,J2_e,vtt,dvttdx,dvttdy) - do i=1, bds%ntortor - ! Atoms that defines the two angles - iprm = bds%tortorprm(i) - ibeg = 1 - do j=1, iprm-1 - ibeg = ibeg + bds%ttmap_shape(1,j)*bds%ttmap_shape(2,j) - end do - iend = ibeg + bds%ttmap_shape(1,iprm)*bds%ttmap_shape(2,iprm) - 1 - - ia = bds%tortorat(1,i) - ib = bds%tortorat(2,i) - ic = bds%tortorat(3,i) - id = bds%tortorat(4,i) - ie = bds%tortorat(5,i) - - if(bds%top%use_frozen) then - sk_a = bds%top%frozen(ia) - sk_b = bds%top%frozen(ib) - sk_c = bds%top%frozen(ic) - sk_d = bds%top%frozen(id) - sk_e = bds%top%frozen(ie) - if(sk_a .and. sk_b .and. sk_c .and. sk_d .and. sk_e) cycle - else - sk_a = .false. - sk_b = .false. - sk_c = .false. - sk_d = .false. - sk_e = .false. - end if - - call torsion_angle_jacobian(bds%top%cmm(:,ia), & - bds%top%cmm(:,ib), & - bds%top%cmm(:,ic), & - bds%top%cmm(:,id), & - thetx, & - J1_a, J1_b, J1_c, J1_d) - thetx = ang_torsion(bds%top, bds%tortorat(1:4,i)) - - call torsion_angle_jacobian(bds%top%cmm(:,ib), & - bds%top%cmm(:,ic), & - bds%top%cmm(:,id), & - bds%top%cmm(:,ie), & - thety, & - J2_b, J2_c, J2_d, J2_e) - thety = ang_torsion(bds%top, bds%tortorat(2:5,i)) - - call compute_bicubic_interp(thetx, thety, vtt, & - dvttdx, dvttdy, & - bds%ttmap_shape(1,iprm), & - bds%ttmap_shape(2,iprm), & - bds%ttmap_ang1(ibeg:iend), & - bds%ttmap_ang2(ibeg:iend), & - bds%ttmap_v(ibeg:iend), & - bds%ttmap_vx(ibeg:iend), & - bds%ttmap_vy(ibeg:iend), & - bds%ttmap_vxy(ibeg:iend)) - - - if(.not. sk_a) then - !$omp atomic update - grad(1,ia) = grad(1,ia) + J1_a(1) * dvttdx - !$omp atomic update - grad(2,ia) = grad(2,ia) + J1_a(2) * dvttdx - !$omp atomic update - grad(3,ia) = grad(3,ia) + J1_a(3) * dvttdx - end if - if(.not. sk_b) then - !$omp atomic update - grad(1,ib) = grad(1,ib) + J1_b(1) * dvttdx + J2_b(1) * dvttdy - !$omp atomic update - grad(2,ib) = grad(2,ib) + J1_b(2) * dvttdx + J2_b(2) * dvttdy - !$omp atomic update - grad(3,ib) = grad(3,ib) + J1_b(3) * dvttdx + J2_b(3) * dvttdy - end if - if(.not. sk_c) then - !$omp atomic update - grad(1,ic) = grad(1,ic) + J1_c(1) * dvttdx + J2_c(1) * dvttdy - !$omp atomic update - grad(2,ic) = grad(2,ic) + J1_c(2) * dvttdx + J2_c(2) * dvttdy - !$omp atomic update - grad(3,ic) = grad(3,ic) + J1_c(3) * dvttdx + J2_c(3) * dvttdy - end if - if(.not. sk_d) then - !$omp atomic update - grad(1,id) = grad(1,id) + J1_d(1) * dvttdx + J2_d(1) * dvttdy - !$omp atomic update - grad(2,id) = grad(2,id) + J1_d(2) * dvttdx + J2_d(2) * dvttdy - !$omp atomic update - grad(3,id) = grad(3,id) + J1_d(3) * dvttdx + J2_d(3) * dvttdy - end if - if(.not. sk_e) then - !$omp atomic update - grad(1,ie) = grad(1,ie) + J2_e(1) * dvttdy - !$omp atomic update - grad(2,ie) = grad(2,ie) + J2_e(2) * dvttdy - !$omp atomic update - grad(3,ie) = grad(3,ie) + J2_e(3) * dvttdy - end if - end do - - end subroutine tortor_geomgrad - - pure function cos_torsion(top, idx) - !! Compute the cosine of torsional angle between four atoms specified - !! with indices idx - - implicit none - - type(ommp_topology_type), intent(in) :: top - integer(ip), intent(in) :: idx(4) - real(rp) :: cos_torsion - - real(rp), dimension(3) :: a, b, c, d, ab, cd, cb, t, u - - a = top%cmm(:,idx(1)) - b = top%cmm(:,idx(2)) - c = top%cmm(:,idx(3)) - d = top%cmm(:,idx(4)) - - ab = b - a - cd = d - c - cb = b - c - - t(1) = ab(2)*cb(3) - ab(3)*cb(2) - t(2) = ab(3)*cb(1) - ab(1)*cb(3) - t(3) = ab(1)*cb(2) - ab(2)*cb(1) - t = t / norm2(t) - - u(1) = cb(2)*cd(3) - cb(3)*cd(2) - u(2) = cb(3)*cd(1) - cb(1)*cd(3) - u(3) = cb(1)*cd(2) - cb(2)*cd(1) - u = u / norm2(u) - - cos_torsion = dot_product(u,t) - return - - end function - - pure function ang_torsion(top, idx) - !! Compute the torsional angle between four atoms specified - !! with indices idx; results are in range [-pi;pi] - - implicit none - - type(ommp_topology_type), intent(in) :: top - integer(ip), intent(in) :: idx(4) - real(rp) :: cos_torsion, ang_torsion - - real(rp), dimension(3) :: a, b, c, d, ab, cd, cb, t, u - - a = top%cmm(:,idx(1)) - b = top%cmm(:,idx(2)) - c = top%cmm(:,idx(3)) - d = top%cmm(:,idx(4)) - - ab = b - a - cd = d - c - cb = b - c - - t(1) = ab(2)*cb(3) - ab(3)*cb(2) - t(2) = ab(3)*cb(1) - ab(1)*cb(3) - t(3) = ab(1)*cb(2) - ab(2)*cb(1) - t = t / norm2(t) - - u(1) = cb(2)*cd(3) - cb(3)*cd(2) - u(2) = cb(3)*cd(1) - cb(1)*cd(3) - u(3) = cb(1)*cd(2) - cb(2)*cd(1) - u = u / norm2(u) - - cos_torsion = dot_product(u,t) - ang_torsion = acos(cos_torsion) - !if(dot_product(ab, u) > 0) ang_torsion = - ang_torsion - ang_torsion = ang_torsion * sign(1.0_rp, -dot_product(ab,u)) - - end function - - subroutine bonded_terminate(bds) - !! Just terminate every "submodule" in bonded, - !! deallocating arrays and disabling the potential terms - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - - call bond_terminate(bds) - call angle_terminate(bds) - call strbnd_terminate(bds) - call urey_terminate(bds) - call opb_terminate(bds) - call pitors_terminate(bds) - call torsion_terminate(bds) - call imptorsion_terminate(bds) - call tortor_terminate(bds) - call angtor_terminate(bds) - call strtor_terminate(bds) - - end subroutine bonded_terminate - - subroutine bond_terminate(bds) - use mod_memory, only: mfree - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - if( .not. bds%use_bond ) return - - bds%use_bond = .false. - call mfree('bond_terminate [bondat]', bds%bondat) - call mfree('bond_terminate [kbond]', bds%kbond) - call mfree('bond_terminate [l0bond]', bds%l0bond) - - end subroutine bond_terminate - - subroutine angle_terminate(bds) - use mod_memory, only: mfree - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - if( .not. bds%use_angle ) return - - bds%use_angle = .false. - call mfree('angle_terminate [angleat]', bds%angleat) - call mfree('angle_terminate [anglety]', bds%anglety) - call mfree('angle_terminate [angauxat]', bds%angauxat) - call mfree('angle_terminate [kangle]', bds%kangle) - call mfree('angle_terminate [eqangle]', bds%eqangle) - - end subroutine angle_terminate - - subroutine strbnd_terminate(bds) - use mod_memory, only: mfree - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - if( .not. bds%use_strbnd ) return - - bds%use_strbnd = .false. - call mfree('strbnd_terminate [strbndat]', bds%strbndat) - call mfree('strbnd_terminate [strbndl10]', bds%strbndl10) - call mfree('strbnd_terminate [strbndl20]', bds%strbndl20) - call mfree('strbnd_terminate [strbndthet0]', bds%strbndthet0) - call mfree('strbnd_terminate [strbndk1]', bds%strbndk1) - call mfree('strbnd_terminate [strbndk2]', bds%strbndk2) - - end subroutine strbnd_terminate - - subroutine urey_terminate(bds) - use mod_memory, only: mfree - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - if( .not. bds%use_urey ) return - - bds%use_urey = .false. - call mfree('urey_terminate [ureya]', bds%ureyat) - call mfree('urey_terminate [kurey]', bds%kurey) - call mfree('urey_terminate [l0urey]', bds%l0urey) - - end subroutine urey_terminate - - subroutine opb_terminate(bds) - use mod_memory, only: mfree - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - if( .not. bds%use_opb ) return - - bds%use_opb = .false. - call mfree('opb_terminate [opbat]', bds%opbat) - call mfree('opb_terminate [kopb]', bds%kopb) - - end subroutine opb_terminate - - subroutine pitors_terminate(bds) - use mod_memory, only: mfree - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - if( .not. bds%use_pitors ) return - - bds%use_pitors = .false. - call mfree('pitors_terminate [pitorsat]', bds%pitorsat) - call mfree('p_terminate [kpitors]', bds%kpitors) - - end subroutine pitors_terminate - - subroutine torsion_terminate(bds) - use mod_memory, only: mfree - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - if( .not. bds%use_torsion ) return - - bds%use_torsion = .false. - call mfree('torsion_terminate [torsionat]', bds%torsionat) - call mfree('torsion_terminate [torsamp]', bds%torsamp) - call mfree('torsion_terminate [torsphase]', bds%torsphase) - call mfree('torsion_terminate [torsn]', bds%torsn) - - end subroutine torsion_terminate - - subroutine imptorsion_terminate(bds) - use mod_memory, only: mfree - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - if( .not. bds%use_imptorsion ) return - - bds%use_imptorsion = .false. - call mfree('imptorsion_terminate [imptorsionat]', bds%imptorsionat) - call mfree('imptorsion_terminate [imptorsamp]', bds%imptorsamp) - call mfree('imptorsion_terminate [imptorsphase]', bds%imptorsphase) - call mfree('imptorsion_terminate [imptorsn]', bds%imptorsn) - - end subroutine imptorsion_terminate - - subroutine tortor_terminate(bds) - use mod_memory, only: mfree - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - if( .not. bds%use_tortor ) return - - bds%use_tortor = .false. - call mfree('tortor_terminate [tortorprm]', bds%tortorprm ) - call mfree('tortor_terminate [tortorat]', bds%tortorat) - call mfree('tortor_terminate [ttmap_shape]', bds%ttmap_shape) - call mfree('tortor_terminate [ttmap_ang1]', bds%ttmap_ang1) - call mfree('tortor_terminate [ttmap_ang2]', bds%ttmap_ang2) - call mfree('tortor_terminate [ttmap_v]', bds%ttmap_v) - call mfree('tortor_terminate [ttmap_vx]', bds%ttmap_vx) - call mfree('tortor_terminate [ttmap_vy]', bds%ttmap_vy) - call mfree('tortor_terminate [ttmap_vxy]', bds%ttmap_vxy) - - end subroutine tortor_terminate - - subroutine angtor_terminate(bds) - use mod_memory, only: mfree - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - if( .not. bds%use_angtor ) return - - bds%use_angtor = .false. - call mfree('angtor_terminate [angtorat]', bds%angtorat) - call mfree('angtor_terminate [angtork]', bds%angtork) - call mfree('angtor_terminate [angtor_t]', bds%angtor_t) - call mfree('angtor_terminate [angtor_a]', bds%angtor_a) - - end subroutine angtor_terminate - - subroutine strtor_terminate(bds) - use mod_memory, only: mfree - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - ! Bonded potential data structure - if( .not. bds%use_strtor ) return - - bds%use_strtor = .false. - call mfree('strtor_terminate [strtorat]', bds%strtorat) - call mfree('strtor_terminate [strtork]', bds%strtork) - call mfree('strtor_terminate [strtor_t]', bds%strtor_t) - call mfree('strtor_terminate [strtor_b]', bds%strtor_b) - - end subroutine strtor_terminate - -end module mod_bonded diff --git a/src/mod_c_interface.F90 b/src/mod_c_interface.F90 new file mode 100644 index 0000000..b88c837 --- /dev/null +++ b/src/mod_c_interface.F90 @@ -0,0 +1,1764 @@ +! Wrapper function for open-mmpol library +module mod_ommp_C_interface + !! The interface of the library, basically all the operation performed + !! by an external code should be done through the routines of this + !! module. + !! The interface is conceived to work naturally with C and Fortran; the C + !! interface is also used to build the interface for Python. + !! In a fortran code, this module can be imported and it should expose + !! directly all the vector and scalar quantities needed. + !! In a C code, routines are provided to get the pointer or the values of + !! vector and scalar quantites respectively. + + use iso_c_binding + use ommp_interface + use mod_constants, only: OMMP_STR_CHAR_MAX + + implicit none + + private :: c2f_string, OMMP_STR_CHAR_MAX + +contains + !! Internal utilities for Fortran -> C interface + pure subroutine c2f_string(c_str, f_str) + !! Convert a string coming from C into a Fortran string + implicit none + + character(kind=c_char), intent(in) :: c_str(:) + !! Input string to be converted + character(len=*), intent(out) :: f_str + + integer :: i + + i = 1 + do while(c_str(i) /= c_null_char) + f_str(i:i) = c_str(i) + i = i + 1 + end do + + do i = i, len(f_str) + f_str(i:i) = ' ' + end do + + f_str = trim(f_str) + end subroutine c2f_string + + ! Functions directly mapped on OMMP internal functions (which are + ! exposed on fortran side by + ! use mod_xxx, only a => b + subroutine C_ommp_set_verbose(verb) bind(c, name='ommp_set_verbose') + !! Set the verbosity level of the library to verb + implicit none + + integer(ommp_integer), intent(in), value :: verb + + !! Requested verbosityi of library + call ommp_set_verbose(verb) + end subroutine C_ommp_set_verbose + + subroutine C_ommp_set_default_solver(s_prt, solver) bind(c, name='ommp_set_default_solver') + implicit none + + integer(ommp_integer), intent(in), value :: solver + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + + call c_f_pointer(s_prt, s) + + call ommp_set_default_solver(s, solver) + end subroutine C_ommp_set_default_solver + + subroutine C_ommp_set_default_matv(s_prt, matv) bind(c, name='ommp_set_default_matv') + implicit none + + integer(ommp_integer), intent(in), value :: matv + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + + call c_f_pointer(s_prt, s) + + call ommp_set_default_matv(s, matv) + end subroutine C_ommp_set_default_matv + + subroutine C_ommp_fatal(c_msg) & + bind(c, name='ommp_fatal') + implicit none + + character(kind=c_char), intent(in) :: c_msg(OMMP_STR_CHAR_MAX) + character(len=OMMP_STR_CHAR_MAX) :: msg + + call c2f_string(c_msg, msg) + call ommp_fatal(msg) + + end subroutine C_ommp_fatal + + subroutine C_ommp_message(c_msg, level, c_pre) & + bind(c, name='ommp_message') + implicit none + + character(kind=c_char), intent(in) :: c_msg(OMMP_STR_CHAR_MAX) + integer(kind=ommp_integer), value :: level + character(kind=c_char), intent(in) :: c_pre(OMMP_STR_CHAR_MAX) + character(len=OMMP_STR_CHAR_MAX) :: msg + character(len=OMMP_STR_CHAR_MAX) :: pre + + call c2f_string(c_msg, msg) + call c2f_string(c_pre, pre) + call ommp_message(msg, level, pre) + + end subroutine C_ommp_message + + subroutine C_ommp_time_pull(c_msg) & + bind(c, name='ommp_time_pull') + implicit none + + character(kind=c_char), intent(in) :: c_msg(OMMP_STR_CHAR_MAX) + character(len=OMMP_STR_CHAR_MAX) :: msg + + call c2f_string(c_msg, msg) + call ommp_time_pull(trim(msg)) + + end subroutine C_ommp_time_pull + + subroutine C_ommp_time_push() & + bind(c, name='ommp_time_push') + implicit none + + call ommp_time_push + + end subroutine C_ommp_time_push + + subroutine C_ommp_set_outputfile(fname) & + bind(c, name='ommp_set_outputfile') + implicit none + + character(kind=c_char), intent(in) :: fname(OMMP_STR_CHAR_MAX) + character(len=OMMP_STR_CHAR_MAX) :: ffname + + call c2f_string(fname, ffname) + call ommp_set_outputfile(ffname) + + end subroutine C_ommp_set_outputfile + + subroutine C_ommp_close_outputfile() & + bind(c, name='ommp_close_outputfile') + implicit none + + call ommp_close_outputfile() + + end subroutine C_ommp_close_outputfile + + subroutine C_ommp_print_summary(s_prt) bind(c, name='ommp_print_summary') + !! Print a summary of the system input on standard output. + implicit none + + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + + call c_f_pointer(s_prt, s) + call ommp_print_summary(s) + + end subroutine C_ommp_print_summary + + subroutine C_ommp_print_summary_to_file(s_prt, filename) & + bind(c, name='ommp_print_summary_to_file') + !! Print a summary of the system input on file. + implicit none + + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + character(kind=c_char), intent(in) :: filename(OMMP_STR_CHAR_MAX) + !! File where the summary will be printed + character(len=OMMP_STR_CHAR_MAX) :: output_file + + call c_f_pointer(s_prt, s) + call c2f_string(filename, output_file) + call ommp_print_summary_to_file(s, output_file) + + end subroutine C_ommp_print_summary_to_file + + subroutine C_ommp_save_mmp(s_prt, filename, version) & + bind(c, name='ommp_save_mmp') + implicit none + type(c_ptr), value :: s_prt + character(kind=c_char), intent(in) :: filename(OMMP_STR_CHAR_MAX) + integer(ommp_integer), value :: version + + character(len=OMMP_STR_CHAR_MAX) :: output_file + type(ommp_system), pointer :: s + + call c_f_pointer(s_prt, s) + + call c2f_string(filename, output_file) + call ommp_save_mmp(s, output_file, version) + end subroutine + + subroutine C_ommp_update_coordinates(s_prt, new_c_p) & + bind(C, name='ommp_update_coordinates') + use mod_mmpol, only: update_coordinates + + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: new_c_p + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: new_c(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(new_c_p, new_c, [3, s%top%mm_atoms]) + + call update_coordinates(s, new_c) + end subroutine + + ! Functions mapped on actual Fortran interface functions + ! OMMP System Object housekeeping + function C_ommp_init_mmp(filename) & + result(c_prt) bind(c, name='ommp_init_mmp') + !! Initalize OMMP System Object from .mmp file + implicit none + + type(ommp_system), pointer, save :: s + character(kind=c_char), intent(in) :: filename(OMMP_STR_CHAR_MAX) + character(len=OMMP_STR_CHAR_MAX) :: input_file + type(c_ptr) :: c_prt + + !allocate(s) + + call c2f_string(filename, input_file) + call ommp_init_mmp(s, input_file) + c_prt = c_loc(s) + end function + + function C_ommp_init_xyz(xyzfile, prmfile) & + result(c_prt) bind(c, name='ommp_init_xyz') + !! Initialize the library using a Tinker xyz and a Tinker prm + implicit none + + type(ommp_system), pointer, save :: s + character(kind=c_char), intent(in) :: xyzfile(OMMP_STR_CHAR_MAX), & + prmfile(OMMP_STR_CHAR_MAX) + character(len=OMMP_STR_CHAR_MAX) :: xyz_file, prm_file + type(c_ptr) :: c_prt + + !allocate(s) + + call c2f_string(prmfile, prm_file) + call c2f_string(xyzfile, xyz_file) + call ommp_init_xyz(s, xyz_file, prm_file) + c_prt = c_loc(s) + end function + + subroutine C_ommp_set_frozen_atoms(s_prt, n, frozen) & + bind(c, name='ommp_set_frozen_atoms') + implicit none + type(c_ptr), value :: s_prt, frozen + integer(ommp_integer), value :: n + type(ommp_system), pointer :: s + integer(ommp_integer), pointer :: f(:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(frozen, f, [n]) + call ommp_set_frozen_atoms(s, n, f) + end subroutine + + subroutine C_ommp_turn_pol_off(s_prt, n, nopol) & + bind(c, name='ommp_turn_pol_off') + implicit none + type(c_ptr), value :: s_prt, nopol + integer(ommp_integer), value :: n + type(ommp_system), pointer :: s + integer(ommp_integer), pointer :: f(:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(nopol, f, [n]) + call ommp_turn_pol_off(s, n, f) + end subroutine + + subroutine C_ommp_terminate(s_prt) bind(c, name='ommp_terminate') + !! Terminate a OMMP System Object + implicit none + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + + call c_f_pointer(s_prt, s) + call ommp_terminate(s) + end subroutine + + ! Interface for normal operation of OMMP System Object + subroutine C_ommp_set_external_field(s_prt, ext_field_prt, solver, matv) & + bind(c, name='ommp_set_external_field') + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: ext_field_prt + integer(ommp_integer), intent(in), value :: solver + integer(ommp_integer), intent(in), value :: matv + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: ext_field(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(ext_field_prt, ext_field, [3, s%eel%pol_atoms]) + + call ommp_set_external_field(s, ext_field, solver, matv, .true.) + end subroutine C_ommp_set_external_field + + subroutine C_ommp_set_external_field_nomm(s_prt, ext_field_prt, solver, matv) & + bind(c, name='ommp_set_external_field_nomm') + !!use mod_mmpol, only: pol_atoms + + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: ext_field_prt + integer(ommp_integer), intent(in), value :: solver + integer(ommp_integer), intent(in), value :: matv + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: ext_field(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(ext_field_prt, ext_field, [3, s%eel%pol_atoms]) + + call ommp_set_external_field(s, ext_field, solver, matv, .false.) + end subroutine C_ommp_set_external_field_nomm + + subroutine C_ommp_potential_mmpol2ext(s_prt, n, cext, v) & + bind(c, name='ommp_potential_mmpol2ext') + ! Compute the electric potential of static sites at + ! arbitrary coordinates + implicit none + + integer(ommp_integer), intent(in), value :: n + type(c_ptr), value :: s_prt, cext, v + type(ommp_system), pointer :: s + real(ommp_real), pointer :: fcext(:,:), fv(:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(cext, fcext, [3,n]) + call c_f_pointer(v, fv, [n]) + call ommp_potential_mmpol2ext(s, n, fcext, fv) + end subroutine + + subroutine C_ommp_potential_pol2ext(s_prt, n, cext, v) & + bind(c, name='ommp_potential_pol2ext') + ! Compute the electric potential of static sites at + ! arbitrary coordinates + implicit none + + integer(ommp_integer), intent(in), value :: n + type(c_ptr), value :: s_prt, cext, v + type(ommp_system), pointer :: s + real(ommp_real), pointer :: fcext(:,:), fv(:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(cext, fcext, [3,n]) + call c_f_pointer(v, fv, [n]) + call ommp_potential_pol2ext(s, n, fcext, fv) + end subroutine + + subroutine C_ommp_potential_mm2ext(s_prt, n, cext, v) & + bind(c, name='ommp_potential_mm2ext') + ! Compute the electric potential of static sites at + ! arbitrary coordinates + implicit none + + integer(ommp_integer), intent(in), value :: n + type(c_ptr), value :: s_prt, cext, v + type(ommp_system), pointer :: s + real(ommp_real), pointer :: fcext(:,:), fv(:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(cext, fcext, [3,n]) + call c_f_pointer(v, fv, [n]) + call ommp_potential_mm2ext(s, n, fcext, fv) + end subroutine + + function C_ommp_get_polelec_energy(s_prt) & + result(epol) bind(c, name='ommp_get_polelec_energy') + implicit none + + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + real(ommp_real) :: epol + + call c_f_pointer(s_prt, s) + epol = ommp_get_polelec_energy(s) + end function + + function C_ommp_get_fixedelec_energy(s_prt) & + result(emm) bind(c, name='ommp_get_fixedelec_energy') + ! Get the interaction energy of fixed multipoles + implicit none + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + real(ommp_real) :: emm + + call c_f_pointer(s_prt, s) + + emm = ommp_get_fixedelec_energy(s) + end function + + function C_ommp_get_full_ele_energy(s_prt) & + result(ene) bind(c, name='ommp_get_full_ele_energy') + implicit none + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: sys_obj + real(ommp_real) :: ene + + call c_f_pointer(s_prt, sys_obj) + + ene = ommp_get_full_ele_energy(sys_obj) + end function + + function C_ommp_get_vdw_energy(s_prt) & + result(evdw) bind(c, name='ommp_get_vdw_energy') + implicit none + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + real(ommp_real) :: evdw + + call c_f_pointer(s_prt, s) + + evdw = ommp_get_vdw_energy(s) + + end function + + function C_ommp_get_bond_energy(s_prt) & + result(ebnd) bind(c, name='ommp_get_bond_energy') + implicit none + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + real(ommp_real) :: ebnd + + call c_f_pointer(s_prt, s) + + ebnd = ommp_get_bond_energy(s) + end function + + function C_ommp_get_angle_energy(s_prt) & + result(eang) bind(c, name='ommp_get_angle_energy') + implicit none + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + real(ommp_real) :: eang + + call c_f_pointer(s_prt, s) + + eang = ommp_get_angle_energy(s) + end function + + function C_ommp_get_strbnd_energy(s_prt) & + result(eba) bind(c, name='ommp_get_strbnd_energy') + implicit none + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + real(ommp_real) :: eba + + call c_f_pointer(s_prt, s) + + eba = ommp_get_strbnd_energy(s) + end function + + function C_ommp_get_urey_energy(s_prt) & + result(eub) bind(c, name='ommp_get_urey_energy') + implicit none + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + real(ommp_real) :: eub + + call c_f_pointer(s_prt, s) + + eub = ommp_get_urey_energy(s) + end function + + function C_ommp_get_opb_energy(s_prt) & + result(eopb) bind(c, name='ommp_get_opb_energy') + + use mod_bonded, only: opb_potential + + implicit none + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + real(ommp_real) :: eopb + + call c_f_pointer(s_prt, s) + + eopb = ommp_get_opb_energy(s) + end function + + function C_ommp_get_imptorsion_energy(s_prt) & + result(et) bind(c, name='ommp_get_imptorsion_energy') + implicit none + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + real(ommp_real) :: et + + call c_f_pointer(s_prt, s) + + et = ommp_get_imptorsion_energy(s) + end function + + function C_ommp_get_torsion_energy(s_prt) & + result(et) bind(c, name='ommp_get_torsion_energy') + implicit none + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + real(ommp_real) :: et + + call c_f_pointer(s_prt, s) + + et = ommp_get_torsion_energy(s) + end function + + function C_ommp_get_pitors_energy(s_prt) & + result(epitors) bind(c, name='ommp_get_pitors_energy') + implicit none + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + real(ommp_real) :: epitors + + call c_f_pointer(s_prt, s) + + epitors = ommp_get_pitors_energy(s) + end function + + function C_ommp_get_strtor_energy(s_prt) & + result(ebt) bind(c, name='ommp_get_strtor_energy') + implicit none + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + real(ommp_real) :: ebt + + call c_f_pointer(s_prt, s) + + ebt = ommp_get_strtor_energy(s) + end function + + function C_ommp_get_angtor_energy(s_prt) & + result(eat) bind(c, name='ommp_get_angtor_energy') + implicit none + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + real(ommp_real) :: eat + + call c_f_pointer(s_prt, s) + + eat = ommp_get_angtor_energy(s) + end function + + function C_ommp_get_tortor_energy(s_prt) & + result(ett) bind(c, name='ommp_get_tortor_energy') + implicit none + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + real(ommp_real) :: ett + + call c_f_pointer(s_prt, s) + + ett = ommp_get_tortor_energy(s) + end function + + function C_ommp_get_full_bnd_energy(s_prt) & + result(ene) bind(c, name='ommp_get_full_bnd_energy') + + implicit none + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: sys_obj + real(ommp_real) :: ene + + call c_f_pointer(s_prt, sys_obj) + + ene = ommp_get_full_bnd_energy(sys_obj) + end function + + function C_ommp_get_full_energy(s_prt) & + result(ene) bind(c, name='ommp_get_full_energy') + + implicit none + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: sys_obj + real(ommp_real) :: ene + + call c_f_pointer(s_prt, sys_obj) + + ene = ommp_get_full_energy(sys_obj) + end function + + ! Functions for advanced operation and gradients + subroutine C_ommp_vdw_geomgrad(s_prt, grd_prt) & + bind(C, name='ommp_vdw_geomgrad') + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: grd_prt + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: grd(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) + + call ommp_vdw_geomgrad(s, grd) + end subroutine + + subroutine C_ommp_rotation_geomgrad(s_prt, pE, pE_grd, grd_prt) & + bind(C, name="ommp_rotation_geomgrad") + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: pE + type(c_ptr), value :: pE_grd + type(c_ptr), value :: grd_prt + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: grd(:,:), E(:,:), Egrd(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) + call c_f_pointer(pE, E, [3, s%top%mm_atoms]) + call c_f_pointer(pE_grd, Egrd, [6, s%top%mm_atoms]) + + call ommp_rotation_geomgrad(s, E, Egrd, grd) + end subroutine + + subroutine C_ommp_bond_geomgrad(s_prt, grd_prt) & + bind(C, name='ommp_bond_geomgrad') + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: grd_prt + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: grd(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) + + call ommp_bond_geomgrad(s, grd) + end subroutine + + subroutine C_ommp_angle_geomgrad(s_prt, grd_prt) & + bind(C, name='ommp_angle_geomgrad') + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: grd_prt + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: grd(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) + + call ommp_angle_geomgrad(s, grd) + end subroutine + + subroutine C_ommp_strbnd_geomgrad(s_prt, grd_prt) & + bind(C, name='ommp_strbnd_geomgrad') + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: grd_prt + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: grd(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) + + call ommp_strbnd_geomgrad(s, grd) + end subroutine + + subroutine C_ommp_urey_geomgrad(s_prt, grd_prt) & + bind(C, name='ommp_urey_geomgrad') + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: grd_prt + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: grd(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) + + call ommp_urey_geomgrad(s, grd) + end subroutine + + subroutine C_ommp_torsion_geomgrad(s_prt, grd_prt) & + bind(C, name='ommp_torsion_geomgrad') + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: grd_prt + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: grd(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) + + call ommp_torsion_geomgrad(s, grd) + end subroutine + + subroutine C_ommp_imptorsion_geomgrad(s_prt, grd_prt) & + bind(C, name='ommp_imptorsion_geomgrad') + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: grd_prt + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: grd(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) + + call ommp_imptorsion_geomgrad(s, grd) + end subroutine + + subroutine C_ommp_angtor_geomgrad(s_prt, grd_prt) & + bind(C, name='ommp_angtor_geomgrad') + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: grd_prt + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: grd(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) + + call ommp_angtor_geomgrad(s, grd) + end subroutine + + subroutine C_ommp_opb_geomgrad(s_prt, grd_prt) & + bind(C, name='ommp_opb_geomgrad') + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: grd_prt + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: grd(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) + + call ommp_opb_geomgrad(s, grd) + end subroutine + + subroutine C_ommp_strtor_geomgrad(s_prt, grd_prt) & + bind(C, name='ommp_strtor_geomgrad') + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: grd_prt + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: grd(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) + + call ommp_strtor_geomgrad(s, grd) + end subroutine + + subroutine C_ommp_tortor_geomgrad(s_prt, grd_prt) & + bind(C, name='ommp_tortor_geomgrad') + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: grd_prt + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: grd(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) + + call ommp_tortor_geomgrad(s, grd) + end subroutine + + subroutine C_ommp_pitors_geomgrad(s_prt, grd_prt) & + bind(C, name='ommp_pitors_geomgrad') + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: grd_prt + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: grd(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) + + call ommp_pitors_geomgrad(s, grd) + end subroutine + + subroutine C_ommp_full_bnd_geomgrad(s_prt, grd_prt) & + bind(C, name='ommp_full_bnd_geomgrad') + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: grd_prt + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: grd(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) + + call ommp_full_bnd_geomgrad(s, grd) + end subroutine + + subroutine C_ommp_fixedelec_geomgrad(s_prt, grd_prt) & + bind(C, name='ommp_fixedelec_geomgrad') + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: grd_prt + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: grd(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) + call ommp_fixedelec_geomgrad(s, grd) + end subroutine + + subroutine C_ommp_polelec_geomgrad(s_prt, grd_prt) & + bind(C, name='ommp_polelec_geomgrad') + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: grd_prt + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: grd(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) + call ommp_polelec_geomgrad(s, grd) + end subroutine + + subroutine C_ommp_full_geomgrad(s_prt, grd_prt) & + bind(C, name='ommp_full_geomgrad') + use ommp_interface, only: ommp_full_geomgrad + + implicit none + + type(c_ptr), value :: s_prt + type(c_ptr), value :: grd_prt + + type(ommp_system), pointer :: s + real(ommp_real), pointer :: grd(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) + + call ommp_full_geomgrad(s, grd) + end subroutine + + function C_ommp_init_hdf5(filename, namespace) & + result(c_prt) bind(c, name='ommp_init_hdf5') + !! This function is an interface for saving an HDF5 file + !! with all the data contained in mmpol module using + !! [[mod_io:mmpol_save_as_hdf5]] + use mod_iohdf5, only: mmpol_init_from_hdf5 + + implicit none + + type(ommp_system), pointer :: s + character(kind=c_char), intent(in) :: filename(OMMP_STR_CHAR_MAX), & + namespace(OMMP_STR_CHAR_MAX) + character(len=OMMP_STR_CHAR_MAX) :: hdf5in, nms + integer(ommp_integer) :: ok + type(c_ptr) :: c_prt + + allocate(s) + + call c2f_string(filename, hdf5in) + call c2f_string(namespace, nms) + call mmpol_init_from_hdf5(hdf5in, trim(nms), s, ok) + + c_prt = c_loc(s) + + end function C_ommp_init_hdf5 + + subroutine C_ommp_save_as_hdf5(s_prt, filename, namespace) & + bind(c, name='ommp_save_as_hdf5') + + use mod_iohdf5, only: save_system_as_hdf5 + + implicit none + + character(kind=c_char), intent(in) :: filename(OMMP_STR_CHAR_MAX), & + namespace(OMMP_STR_CHAR_MAX) + character(len=OMMP_STR_CHAR_MAX) :: hdf5out, nms + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + integer(kind=4) :: err + + call c_f_pointer(s_prt, s) + + call c2f_string(filename, hdf5out) + call c2f_string(namespace, nms) + call save_system_as_hdf5(hdf5out, s, err, trim(nms), logical(.false., kind=ommp_logical)) + + end subroutine C_ommp_save_as_hdf5 + + subroutine C_ommp_checkpoint(s_prt, filename, namespace) & + bind(c, name='ommp_checkpoint') + + use mod_iohdf5, only: save_system_as_hdf5 + + implicit none + + character(kind=c_char), intent(in) :: filename(OMMP_STR_CHAR_MAX), & + namespace(OMMP_STR_CHAR_MAX) + character(len=OMMP_STR_CHAR_MAX) :: hdf5out, nms + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + integer(kind=4) :: err + + call c_f_pointer(s_prt, s) + + call c2f_string(filename, hdf5out) + call c2f_string(namespace, nms) + call save_system_as_hdf5(hdf5out, s, err, trim(nms), logical(.true., kind=ommp_logical)) + + end subroutine C_ommp_checkpoint + + ! Functions to provide direct access to Fortran objects/memory from + ! C and derived codes. + function C_ommp_get_cmm(s_prt) bind(c, name='ommp_get_cmm') + !! Return the c-pointer to the array containing the coordinates of + !! MM atoms. + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + type(c_ptr) :: C_ommp_get_cmm + + call c_f_pointer(s_prt, s) + C_ommp_get_cmm = c_loc(s%top%cmm) + end function C_ommp_get_cmm + + function C_ommp_get_zmm(s_prt) bind(c, name='ommp_get_zmm') + !! Return the c-pointer to the array containing the coordinates of + !! MM atoms. + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + type(c_ptr) :: C_ommp_get_zmm + + call c_f_pointer(s_prt, s) + C_ommp_get_zmm = c_loc(s%top%atz) + end function C_ommp_get_zmm + + function C_ommp_get_attypemm(s_prt) bind(c, name='ommp_get_attypemm') + !! Return the c-pointer to the array containing the coordinates of + !! MM atoms. + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + type(c_ptr) :: C_ommp_get_attypemm + + call c_f_pointer(s_prt, s) + if(s%top%attype_initialized) then + C_ommp_get_attypemm = c_loc(s%top%attype) + else + C_ommp_get_attypemm = c_null_ptr + end if + end function C_ommp_get_attypemm + + + function C_ommp_get_cpol(s_prt) bind(c, name='ommp_get_cpol') + !! Return the c-pointer to the array containing the coordinates of + !! polarizable atoms. + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + type(c_ptr) :: C_ommp_get_cpol + + call c_f_pointer(s_prt, s) + C_ommp_get_cpol = c_loc(s%eel%cpol) + end function C_ommp_get_cpol + + function C_ommp_get_q(s_prt) bind(c, name='ommp_get_q') + !! Return the c-pointer to the array containing the static source of + !! the electrostatic field. + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + type(c_ptr) :: C_ommp_get_q + + call c_f_pointer(s_prt, s) + C_ommp_get_q = c_loc(s%eel%q) + end function C_ommp_get_q + + function C_ommp_get_ipd(s_prt) bind(c, name='ommp_get_ipd') + !! Return the c-pointer to the array containing the induced dipoles + !! on polarizable sites. + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + type(c_ptr) :: C_ommp_get_ipd + + call c_f_pointer(s_prt, s) + C_ommp_get_ipd = c_loc(s%eel%ipd) + end function C_ommp_get_ipd + + function C_ommp_get_polar_mm(s_prt) bind(c, name='ommp_get_polar_mm') + !! Return the c-pointer to the array containing the map from + !! polarizable to MM atoms. + use mod_memory, only: mallocate + implicit none + + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + type(c_ptr) :: C_ommp_get_polar_mm + + call c_f_pointer(s_prt, s) + if(.not. allocated(s%eel%C_polar_mm)) then + call mallocate('C_ommp_get_polar_mm [C_polar_mm]', & + size(s%eel%polar_mm), s%eel%C_polar_mm) + s%eel%C_polar_mm = s%eel%polar_mm - 1 + end if + + C_ommp_get_polar_mm = c_loc(s%eel%C_polar_mm) + end function C_ommp_get_polar_mm + + function C_ommp_use_frozen(s_prt) bind(c, name='ommp_use_frozen') + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + logical(c_bool) :: C_ommp_use_frozen + + call c_f_pointer(s_prt, s) + C_ommp_use_frozen = s%top%use_frozen + end function C_ommp_use_frozen + + function C_ommp_get_frozen(s_prt) bind(c, name='ommp_get_frozen') + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + type(c_ptr) :: C_ommp_get_frozen + + call c_f_pointer(s_prt, s) + C_ommp_get_frozen = c_loc(s%top%frozen) + end function C_ommp_get_frozen + + function C_ommp_get_mm_atoms(s_prt) bind(c, name='ommp_get_mm_atoms') + !! Return the number of MM atoms in the system. + implicit none + + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + integer(ommp_integer) :: C_ommp_get_mm_atoms + + call c_f_pointer(s_prt, s) + C_ommp_get_mm_atoms = s%top%mm_atoms + end function C_ommp_get_mm_atoms + + function C_ommp_get_pol_atoms(s_prt) bind(c, name='ommp_get_pol_atoms') + !! Return the number of polarizable atoms in the system. + implicit none + + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + integer(ommp_integer) :: C_ommp_get_pol_atoms + + call c_f_pointer(s_prt, s) + + C_ommp_get_pol_atoms = s%eel%pol_atoms + end function C_ommp_get_pol_atoms + + function C_ommp_get_n_ipd(s_prt) bind(c, name='ommp_get_n_ipd') + !! Return the number of dipole's set for the current Force-Field. + implicit none + + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + integer(ommp_integer) :: C_ommp_get_n_ipd + + call c_f_pointer(s_prt, s) + C_ommp_get_n_ipd = s%eel%n_ipd + end function C_ommp_get_n_ipd + + function C_ommp_get_ld_cart(s_prt) bind(c, name='ommp_get_ld_cart') + implicit none + + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + integer(ommp_integer) :: C_ommp_get_ld_cart + + call c_f_pointer(s_prt, s) + C_ommp_get_ld_cart = s%eel%ld_cart + end function C_ommp_get_ld_cart + + function C_ommp_ff_is_amoeba(s_prt) bind(c, name='ommp_ff_is_amoeba') + !! Return true if the current forcefield is AMOEBA, and false in + !! all other cases. + implicit none + + type(c_ptr), value :: s_prt + type(ommp_system), pointer :: s + logical(c_bool) :: C_ommp_ff_is_amoeba + + call c_f_pointer(s_prt, s) + C_ommp_ff_is_amoeba = s%amoeba + end function C_ommp_ff_is_amoeba + + function C_ommp_use_linkatoms(s_ptr) & + result(u) bind(C, name='ommp_use_linkatoms') + implicit none + + type(c_ptr), value :: s_ptr + !! C pointer to system object + type(ommp_system), pointer :: s + logical(c_bool) :: u + + call c_f_pointer(s_ptr, s) + u = s%use_linkatoms + end function + + !?? + subroutine C_ommp_field_mmpol2ext(s_prt, n, cext, E) & + bind(c, name='ommp_field_mmpol2ext') + ! Compute the electric potential of static sites at + ! arbitrary coordinates + implicit none + + integer(ommp_integer), intent(in), value :: n + type(c_ptr), value :: s_prt, cext, E + type(ommp_system), pointer :: s + real(ommp_real), pointer :: fcext(:,:), fE(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(cext, fcext, [3,n]) + call c_f_pointer(E, fE, [3,n]) + call ommp_field_mmpol2ext(s, n, fcext, fE) + end subroutine + + subroutine C_ommp_field_mm2ext(s_prt, n, cext, E) & + bind(c, name='ommp_field_mm2ext') + ! Compute the electric potential of static sites at + ! arbitrary coordinates + use mod_electrostatics, only: field_M2E + + implicit none + + integer(ommp_integer), intent(in), value :: n + type(c_ptr), value :: s_prt, cext, E + type(ommp_system), pointer :: s + real(ommp_real), pointer :: fcext(:,:), fE(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(cext, fcext, [3,n]) + call c_f_pointer(E, fE, [3,n]) + call field_M2E(s%eel, fcext, fE) + end subroutine + + subroutine C_ommp_field_pol2ext(s_prt, n, cext, E) & + bind(c, name='ommp_field_pol2ext') + ! Compute the electric potential of static sites at + ! arbitrary coordinates + use mod_electrostatics, only: field_D2E + + implicit none + + integer(ommp_integer), intent(in), value :: n + type(c_ptr), value :: s_prt, cext, E + type(ommp_system), pointer :: s + real(ommp_real), pointer :: fcext(:,:), fE(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(cext, fcext, [3,n]) + call c_f_pointer(E, fE, [3,n]) + call field_D2E(s%eel, fcext, fE) + end subroutine + + ! Interface for QM Helper module + function C_ommp_init_qm_helper(n, cqm, qqm, zqm) & + result(c_prt) bind(c, name='ommp_init_qm_helper') + implicit none + + type(ommp_qm_helper), pointer :: s + integer(ommp_integer), value, intent(in) :: n + type(c_ptr), value, intent(in) :: cqm, qqm, zqm + + real(ommp_real), pointer :: fcqm(:,:), fqqm(:) + integer(ommp_integer), pointer :: fzqm(:) + type(c_ptr) :: c_prt + + call c_f_pointer(cqm, fcqm, [3,n]) + call c_f_pointer(qqm, fqqm, [n]) + call c_f_pointer(zqm, fzqm, [n]) + call ommp_init_qm_helper(s, n, fcqm, fqqm, fzqm) + c_prt = c_loc(s) + end function + + subroutine C_ommp_qm_helper_set_frozen_atoms(s_prt, n, frozen) & + bind(c, name='ommp_qm_helper_set_frozen_atoms') + implicit none + type(c_ptr), value :: s_prt, frozen + integer(ommp_integer), value :: n + type(ommp_qm_helper), pointer :: s + integer(ommp_integer), pointer :: f(:) + call c_f_pointer(s_prt, s) + call c_f_pointer(frozen, f, [n]) + + call ommp_qm_helper_set_frozen_atoms(s, n, f) + end subroutine + + subroutine C_ommp_terminate_qm_helper(s_ptr) & + bind(c, name='ommp_terminate_qm_helper') + + use mod_qm_helper, only: qm_helper_terminate, ommp_qm_helper + + implicit none + + type(c_ptr), value :: s_ptr + type(ommp_qm_helper), pointer :: s + + if(c_associated(s_ptr)) then + call c_f_pointer(s_ptr, s) + call qm_helper_terminate(s) + deallocate(s) + end if + end subroutine + + subroutine C_ommp_qm_helper_update_coord(s_ptr, cqm) & + bind(c, name='ommp_qm_helper_update_coord') + implicit none + + type(c_ptr), value :: s_ptr + type(c_ptr), value, intent(in) :: cqm + + real(ommp_real), pointer :: fcqm(:,:) + type(ommp_qm_helper), pointer :: s + + call c_f_pointer(s_ptr, s) + call c_f_pointer(cqm, fcqm, [3,s%qm_top%mm_atoms]) + call ommp_qm_helper_update_coord(s, fcqm) + end subroutine + + subroutine C_ommp_qm_helper_set_attype(pqm, pattype) & + bind(c, name='ommp_qm_helper_set_attype') + implicit none + + type(c_ptr), value, intent(in) :: pqm, pattype + + type(ommp_qm_helper), pointer :: qm + integer(ommp_integer), pointer :: attype(:) + + call c_f_pointer(pqm, qm) + call c_f_pointer(pattype, attype, [qm%qm_top%mm_atoms]) + + call ommp_qm_helper_set_attype(qm, attype) + end subroutine + + subroutine C_ommp_qm_helper_init_vdw_prm(pqm, cprmfile) & + bind(c, name='ommp_qm_helper_init_vdw_prm') + implicit none + + type(c_ptr), value, intent(in) :: pqm + character(kind=c_char), intent(in) :: cprmfile(OMMP_STR_CHAR_MAX) + + type(ommp_qm_helper), pointer :: qm + character(len=OMMP_STR_CHAR_MAX) :: prmfile + + call c_f_pointer(pqm, qm) + call c2f_string(cprmfile, prmfile) + + call ommp_qm_helper_init_vdw_prm(qm, prmfile) + end subroutine + + subroutine C_ommp_qm_helper_init_vdw(pqm, peps, prad, pfac, & + cvdw_type, cradius_rule, & + cradius_size, cradius_type, & + ceps_rule) & + bind(c, name='ommp_qm_helper_init_vdw') + implicit none + + type(c_ptr), value, intent(in) :: pqm, peps, prad, pfac + character(kind=c_char), intent(in) :: cvdw_type(OMMP_STR_CHAR_MAX), & + cradius_rule(OMMP_STR_CHAR_MAX), & + cradius_size(OMMP_STR_CHAR_MAX), & + cradius_type(OMMP_STR_CHAR_MAX), & + ceps_rule(OMMP_STR_CHAR_MAX) + + type(ommp_qm_helper), pointer :: qm + character(len=OMMP_STR_CHAR_MAX) :: vdw_type, radius_rule, & + radius_size, radius_type, & + eps_rule + real(ommp_real), pointer :: eps(:), rad(:), fac(:) + + call c_f_pointer(pqm, qm) + call c_f_pointer(peps, eps, [qm%qm_top%mm_atoms]) + call c_f_pointer(prad, rad, [qm%qm_top%mm_atoms]) + call c_f_pointer(pfac, fac, [qm%qm_top%mm_atoms]) + call c2f_string(cvdw_type, vdw_type) + call c2f_string(cradius_rule, radius_rule) + call c2f_string(cradius_size, radius_size) + call c2f_string(cradius_type, radius_type) + call c2f_string(ceps_rule, eps_rule) + + call ommp_qm_helper_init_vdw(qm, eps, rad, fac, vdw_type, radius_rule, & + radius_size, radius_type, eps_rule) + end subroutine + + function C_ommp_qm_helper_vdw_energy(qm_prt, s_prt) & + result(evdw) bind(c, name='ommp_qm_helper_vdw_energy') + implicit none + + type(c_ptr), value :: qm_prt, s_prt + type(ommp_system), pointer :: s + type(ommp_qm_helper), pointer :: qm + real(ommp_real) :: evdw + + call c_f_pointer(s_prt, s) + call c_f_pointer(qm_prt, qm) + + evdw = ommp_qm_helper_vdw_energy(qm, s) + end function + + subroutine C_ommp_qm_helper_vdw_geomgrad(qm_prt, s_prt, qmg_prt, mmg_prt) & + bind(c, name='ommp_qm_helper_vdw_geomgrad') + implicit none + + type(c_ptr), value :: qm_prt, s_prt, qmg_prt, mmg_prt + type(ommp_system), pointer :: s + type(ommp_qm_helper), pointer :: qm + real(ommp_real), pointer :: qmg(:,:), mmg(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(qm_prt, qm) + call c_f_pointer(qmg_prt, qmg, [3,qm%qm_top%mm_atoms]) + call c_f_pointer(mmg_prt, mmg, [3,s%top%mm_atoms]) + + call ommp_qm_helper_vdw_geomgrad(qm, s, qmg, mmg) + end subroutine + + subroutine C_ommp_qm_helper_link_atom_geomgrad(qm_prt, s_prt, qmg_prt, mmg_prt, old_qmg_ptr) & + bind(c, name='ommp_qm_helper_link_atom_geomgrad') + implicit none + + type(c_ptr), value :: qm_prt, s_prt, qmg_prt, mmg_prt, old_qmg_ptr + type(ommp_system), pointer :: s + type(ommp_qm_helper), pointer :: qm + real(ommp_real), pointer :: qmg(:,:), mmg(:,:), old_qmg(:,:) + + call c_f_pointer(s_prt, s) + call c_f_pointer(qm_prt, qm) + call c_f_pointer(qmg_prt, qmg, [3,qm%qm_top%mm_atoms]) + call c_f_pointer(old_qmg_ptr, old_qmg, [3,qm%qm_top%mm_atoms]) + call c_f_pointer(mmg_prt, mmg, [3,s%top%mm_atoms]) + + call ommp_qm_helper_link_atom_geomgrad(qm, s, qmg, mmg, old_qmg) + end subroutine + + subroutine C_ommp_prepare_qm_ele_ene(s_ptr, qm_ptr) & + bind(c, name='ommp_prepare_qm_ele_ene') + implicit none + + type(c_ptr), value :: s_ptr + !! C pointer to system object + type(c_ptr), value :: qm_ptr + !! C pointer to qm_helper object + + type(ommp_qm_helper), pointer :: qm_help + type(ommp_system), pointer :: s + + call c_f_pointer(qm_ptr, qm_help) + call c_f_pointer(s_ptr, s) + + call ommp_prepare_qm_ele_ene(s, qm_help) + end subroutine + + subroutine C_ommp_prepare_qm_ele_grd(s_ptr, qm_ptr) & + bind(c, name='ommp_prepare_qm_ele_grd') + implicit none + + type(c_ptr), value :: s_ptr + !! C pointer to system object + type(c_ptr), value :: qm_ptr + !! C pointer to qm_helper object + + type(ommp_qm_helper), pointer :: qm_help + type(ommp_system), pointer :: s + + call c_f_pointer(qm_ptr, qm_help) + call c_f_pointer(s_ptr, s) + + call ommp_prepare_qm_ele_grd(s, qm_help) + end subroutine + + function C_ommp_qm_helper_get_npol(qm_ptr) & + result(npol) bind(C, name='ommp_qm_helper_get_npol') + use mod_qm_helper, only: ommp_qm_helper + implicit none + + type(c_ptr), value :: qm_ptr + !! C pointer to qm_helper object + + type(ommp_qm_helper), pointer :: qm_help + integer(ommp_integer) :: npol + + call c_f_pointer(qm_ptr, qm_help) + if(qm_help%E_n2p_done) then + npol = size(qm_help%E_n2p, 2, ommp_integer) + else + npol = 0 + end if + end function + + function C_ommp_qm_helper_get_nmm(qm_ptr) & + result(nmm) bind(C, name='ommp_qm_helper_get_nmm') + use mod_qm_helper, only: ommp_qm_helper + implicit none + + type(c_ptr), value :: qm_ptr + !! C pointer to qm_helper object + + type(ommp_qm_helper), pointer :: qm_help + integer(ommp_integer) :: nmm + + call c_f_pointer(qm_ptr, qm_help) + if(qm_help%E_n2m_done) then + nmm = size(qm_help%E_n2m, 2, ommp_integer) + else + nmm = 0 + end if + end function + + function C_ommp_qm_helper_get_cqm(qm_ptr) & + result(ptr) bind(C, name='ommp_qm_helper_get_cqm') + use mod_qm_helper, only: ommp_qm_helper + implicit none + + type(c_ptr), value :: qm_ptr + !! C pointer to qm_helper object + + type(ommp_qm_helper), pointer :: qm_help + type(c_ptr) :: ptr + + call c_f_pointer(qm_ptr, qm_help) + ptr = c_loc(qm_help%qm_top%cmm) + end function + + function C_ommp_qm_helper_get_E_n2p(qm_ptr) & + result(ptr) bind(C, name='ommp_qm_helper_get_E_n2p') + use mod_qm_helper, only: ommp_qm_helper + implicit none + + type(c_ptr), value :: qm_ptr + !! C pointer to qm_helper object + + type(ommp_qm_helper), pointer :: qm_help + type(c_ptr) :: ptr + + call c_f_pointer(qm_ptr, qm_help) + if(qm_help%E_n2p_done) then + ptr = c_loc(qm_help%E_n2p) + else + ptr = c_null_ptr + end if + end function + + function C_ommp_qm_helper_get_G_n2p(qm_ptr) & + result(ptr) bind(C, name='ommp_qm_helper_get_G_n2p') + use mod_qm_helper, only: ommp_qm_helper + implicit none + + type(c_ptr), value :: qm_ptr + !! C pointer to qm_helper object + + type(ommp_qm_helper), pointer :: qm_help + type(c_ptr) :: ptr + + call c_f_pointer(qm_ptr, qm_help) + if(qm_help%G_n2p_done) then + ptr = c_loc(qm_help%G_n2p) + else + ptr = c_null_ptr + end if + end function + + function C_ommp_qm_helper_get_E_n2m(qm_ptr) & + result(ptr) bind(C, name='ommp_qm_helper_get_E_n2m') + use mod_qm_helper, only: ommp_qm_helper + implicit none + + type(c_ptr), value :: qm_ptr + !! C pointer to qm_helper object + + type(ommp_qm_helper), pointer :: qm_help + type(c_ptr) :: ptr + + call c_f_pointer(qm_ptr, qm_help) + if(qm_help%E_n2m_done) then + ptr = c_loc(qm_help%E_n2m) + else + ptr = c_null_ptr + end if + end function + + function C_ommp_qm_helper_get_G_n2m(qm_ptr) & + result(ptr) bind(C, name='ommp_qm_helper_get_G_n2m') + use mod_qm_helper, only: ommp_qm_helper + implicit none + + type(c_ptr), value :: qm_ptr + !! C pointer to qm_helper object + + type(ommp_qm_helper), pointer :: qm_help + type(c_ptr) :: ptr + + call c_f_pointer(qm_ptr, qm_help) + if(qm_help%G_n2m_done) then + ptr = c_loc(qm_help%G_n2m) + else + ptr = c_null_ptr + end if + end function + + function C_ommp_qm_helper_get_H_n2m(qm_ptr) & + result(ptr) bind(C, name='ommp_qm_helper_get_H_n2m') + use mod_qm_helper, only: ommp_qm_helper + implicit none + + type(c_ptr), value :: qm_ptr + !! C pointer to qm_helper object + + type(ommp_qm_helper), pointer :: qm_help + type(c_ptr) :: ptr + + call c_f_pointer(qm_ptr, qm_help) + if(qm_help%H_n2m_done) then + ptr = c_loc(qm_help%H_n2m) + else + ptr = c_null_ptr + end if + end function + + function C_ommp_qm_helper_get_E_m2n(qm_ptr) & + result(ptr) bind(C, name='ommp_qm_helper_get_E_m2n') + use mod_qm_helper, only: ommp_qm_helper + implicit none + + type(c_ptr), value :: qm_ptr + !! C pointer to qm_helper object + + type(ommp_qm_helper), pointer :: qm_help + type(c_ptr) :: ptr + + call c_f_pointer(qm_ptr, qm_help) + if(qm_help%E_m2n_done) then + ptr = c_loc(qm_help%E_m2n) + else + ptr = c_null_ptr + end if + end function + + function C_ommp_qm_helper_get_E_p2n(qm_ptr) & + result(ptr) bind(C, name='ommp_qm_helper_get_E_p2n') + use mod_qm_helper, only: ommp_qm_helper + implicit none + + type(c_ptr), value :: qm_ptr + !! C pointer to qm_helper object + + type(ommp_qm_helper), pointer :: qm_help + type(c_ptr) :: ptr + + call c_f_pointer(qm_ptr, qm_help) + if(qm_help%E_p2n_done) then + ptr = c_loc(qm_help%E_p2n) + else + ptr = c_null_ptr + end if + end function + + function C_ommp_qm_helper_get_V_m2n(qm_ptr) & + result(ptr) bind(C, name='ommp_qm_helper_get_V_m2n') + use mod_qm_helper, only: ommp_qm_helper + implicit none + + type(c_ptr), value :: qm_ptr + !! C pointer to qm_helper object + + type(ommp_qm_helper), pointer :: qm_help + type(c_ptr) :: ptr + + call c_f_pointer(qm_ptr, qm_help) + if(qm_help%V_m2n_done) then + ptr = c_loc(qm_help%V_m2n) + else + ptr = c_null_ptr + end if + end function + + function C_ommp_qm_helper_get_V_p2n(qm_ptr) & + result(ptr) bind(C, name='ommp_qm_helper_get_V_p2n') + use mod_qm_helper, only: ommp_qm_helper + implicit none + + type(c_ptr), value :: qm_ptr + !! C pointer to qm_helper object + + type(ommp_qm_helper), pointer :: qm_help + type(c_ptr) :: ptr + + call c_f_pointer(qm_ptr, qm_help) + if(qm_help%V_p2n_done) then + ptr = c_loc(qm_help%V_p2n) + else + ptr = c_null_ptr + end if + end function + + function C_ommp_qm_helper_get_qm_atoms(qm_ptr) & + result(n) bind(C, name='ommp_qm_helper_get_qm_atoms') + use mod_qm_helper, only: ommp_qm_helper + implicit none + + type(c_ptr), value :: qm_ptr + !! C pointer to qm_helper object + + type(ommp_qm_helper), pointer :: qm_help + integer(ommp_integer) :: n + + call c_f_pointer(qm_ptr, qm_help) + n = qm_help%qm_top%mm_atoms + end function + + function C_ommp_qm_helper_use_nonbonded(qm_ptr) & + result(u) bind(C, name='ommp_qm_helper_use_nonbonded') + use mod_qm_helper, only: ommp_qm_helper + implicit none + + type(c_ptr), value :: qm_ptr + !! C pointer to qm_helper object + type(ommp_qm_helper), pointer :: qm_help + logical(c_bool) :: u + + call c_f_pointer(qm_ptr, qm_help) + u = qm_help%use_nonbonded + end function + + function C_ommp_qm_helper_use_frozen(s_prt) bind(c, name='ommp_qm_helper_use_frozen') + use mod_qm_helper, only: ommp_qm_helper + implicit none + + type(c_ptr), value :: s_prt + type(ommp_qm_helper), pointer :: s + logical(c_bool) :: C_ommp_qm_helper_use_frozen + + call c_f_pointer(s_prt, s) + C_ommp_qm_helper_use_frozen = s%qm_top%use_frozen + end function C_ommp_qm_helper_use_frozen + + function C_ommp_qm_helper_get_frozen(s_prt) bind(c, name='ommp_qm_helper_get_frozen') + use mod_qm_helper, only: ommp_qm_helper + implicit none + + type(c_ptr), value :: s_prt + type(ommp_qm_helper), pointer :: s + type(c_ptr) :: C_ommp_qm_helper_get_frozen + + call c_f_pointer(s_prt, s) + C_ommp_qm_helper_get_frozen = c_loc(s%qm_top%frozen) + end function C_ommp_qm_helper_get_frozen + + function C_ommp_create_link_atom(qm_prt, s_prt, imm, iqm, ila, prmfile, & + ladist, neel_remove) & + result(la_idx) & + bind(c, name='ommp_create_link_atom') + implicit none + + type(c_ptr), value :: s_prt, qm_prt + integer(ommp_integer), value :: iqm, imm, ila, neel_remove + real(ommp_real), value :: ladist + character(kind=c_char), intent(in) :: prmfile(OMMP_STR_CHAR_MAX) + + + type(ommp_system), pointer :: s + type(ommp_qm_helper), pointer :: qm + + integer(ommp_integer) :: la_idx + character(len=OMMP_STR_CHAR_MAX) :: prm_file + + call c2f_string(prmfile, prm_file) + call c_f_pointer(s_prt, s) + call c_f_pointer(qm_prt, qm) + + la_idx = ommp_create_link_atom(qm, s, imm, iqm, ila, prm_file, & + ladist, neel_remove) + end function + + subroutine C_ommp_get_link_atom_coordinates(s_p, la_idx, crd_p) & + bind(c, name="ommp_get_link_atom_coordinates") + implicit none + + type(c_ptr), value :: s_p, crd_p + integer(ommp_integer), value :: la_idx + + type(ommp_system), pointer :: s + real(ommp_real), dimension(:), pointer :: crd + + call c_f_pointer(s_p, s) + call c_f_pointer(crd_p, crd, [3]) + + call ommp_get_link_atom_coordinates(s, la_idx, crd) + + end subroutine + + subroutine C_ommp_update_link_atoms_position(qm_prt, s_prt) & + bind(c, name='ommp_update_link_atoms_position') + implicit none + + type(c_ptr), value :: s_prt, qm_prt + + type(ommp_system), pointer :: s + type(ommp_qm_helper), pointer :: qm + + call c_f_pointer(s_prt, s) + call c_f_pointer(qm_prt, qm) + + call ommp_update_link_atoms_position(qm, s) + end subroutine + + function C_ommp_system_from_qm_helper(cqmh, cprm_file) & + result(csys) bind(c, name='ommp_system_from_qm_helper') + implicit none + + type(c_ptr), value, intent(in) :: cqmh + + type(ommp_system), pointer, save :: s + type(ommp_qm_helper), pointer :: qm + type(c_ptr) :: csys + + character(kind=c_char), intent(in) :: cprm_file(OMMP_STR_CHAR_MAX) + character(len=OMMP_STR_CHAR_MAX) :: prm_file + + call c2f_string(cprm_file, prm_file) + call c_f_pointer(cqmh, qm) + + !allocate(s) + + call ommp_system_from_qm_helper(qm, prm_file, s) + csys = c_loc(s) + end function + + subroutine C_ommp_set_vdw_cutoff(sp, cutoff) & + bind(c, name='ommp_set_vdw_cutoff') + + implicit none + + type(c_ptr), value, intent(in) :: sp + real(ommp_real), intent(in), value :: cutoff + + type(ommp_system), pointer :: s + + call c_f_pointer(sp, s) + call ommp_set_vdw_cutoff(s, cutoff) + end subroutine + +end module mod_ommp_C_interface diff --git a/src/mod_c_interface.f90 b/src/mod_c_interface.f90 deleted file mode 100644 index 134ac20..0000000 --- a/src/mod_c_interface.f90 +++ /dev/null @@ -1,1765 +0,0 @@ -! Wrapper function for open-mmpol library -module mod_ommp_C_interface - !! The interface of the library, basically all the operation performed - !! by an external code should be done through the routines of this - !! module. - !! The interface is conceived to work naturally with C and Fortran; the C - !! interface is also used to build the interface for Python. - !! In a fortran code, this module can be imported and it should expose - !! directly all the vector and scalar quantities needed. - !! In a C code, routines are provided to get the pointer or the values of - !! vector and scalar quantites respectively. - - use iso_c_binding - use ommp_interface - use mod_constants, only: OMMP_STR_CHAR_MAX - - implicit none - - private :: c2f_string, OMMP_STR_CHAR_MAX - - contains - !! Internal utilities for Fortran -> C interface - pure subroutine c2f_string(c_str, f_str) - !! Convert a string coming from C into a Fortran string - implicit none - - character(kind=c_char), intent(in) :: c_str(:) - !! Input string to be converted - character(len=*), intent(out) :: f_str - - integer :: i - - i = 1 - do while(c_str(i) /= c_null_char) - f_str(i:i) = c_str(i) - i = i + 1 - end do - - do i = i, len(f_str) - f_str(i:i) = ' ' - end do - - f_str = trim(f_str) - end subroutine c2f_string - - ! Functions directly mapped on OMMP internal functions (which are - ! exposed on fortran side by - ! use mod_xxx, only a => b - subroutine C_ommp_set_verbose(verb) bind(c, name='ommp_set_verbose') - !! Set the verbosity level of the library to verb - implicit none - - integer(ommp_integer), intent(in), value :: verb - - !! Requested verbosityi of library - call ommp_set_verbose(verb) - end subroutine C_ommp_set_verbose - - subroutine C_ommp_set_default_solver(s_prt, solver) bind(c, name='ommp_set_default_solver') - implicit none - - integer(ommp_integer), intent(in), value :: solver - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - - call c_f_pointer(s_prt, s) - - call ommp_set_default_solver(s, solver) - end subroutine C_ommp_set_default_solver - - subroutine C_ommp_set_default_matv(s_prt, matv) bind(c, name='ommp_set_default_matv') - implicit none - - integer(ommp_integer), intent(in), value :: matv - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - - call c_f_pointer(s_prt, s) - - call ommp_set_default_matv(s, matv) - end subroutine C_ommp_set_default_matv - - subroutine C_ommp_fatal(c_msg) & - bind(c, name='ommp_fatal') - implicit none - - character(kind=c_char), intent(in) :: c_msg(OMMP_STR_CHAR_MAX) - character(len=OMMP_STR_CHAR_MAX) :: msg - - call c2f_string(c_msg, msg) - call ommp_fatal(msg) - - end subroutine C_ommp_fatal - - subroutine C_ommp_message(c_msg, level, c_pre) & - bind(c, name='ommp_message') - implicit none - - character(kind=c_char), intent(in) :: c_msg(OMMP_STR_CHAR_MAX) - integer(kind=ommp_integer), value :: level - character(kind=c_char), intent(in) :: c_pre(OMMP_STR_CHAR_MAX) - character(len=OMMP_STR_CHAR_MAX) :: msg - character(len=OMMP_STR_CHAR_MAX) :: pre - - call c2f_string(c_msg, msg) - call c2f_string(c_pre, pre) - call ommp_message(msg, level, pre) - - end subroutine C_ommp_message - - subroutine C_ommp_time_pull(c_msg) & - bind(c, name='ommp_time_pull') - implicit none - - character(kind=c_char), intent(in) :: c_msg(OMMP_STR_CHAR_MAX) - character(len=OMMP_STR_CHAR_MAX) :: msg - - call c2f_string(c_msg, msg) - call ommp_time_pull(trim(msg)) - - end subroutine C_ommp_time_pull - - subroutine C_ommp_time_push() & - bind(c, name='ommp_time_push') - implicit none - - call ommp_time_push - - end subroutine C_ommp_time_push - - subroutine C_ommp_set_outputfile(fname) & - bind(c, name='ommp_set_outputfile') - implicit none - - character(kind=c_char), intent(in) :: fname(OMMP_STR_CHAR_MAX) - character(len=OMMP_STR_CHAR_MAX) :: ffname - - call c2f_string(fname, ffname) - call ommp_set_outputfile(ffname) - - end subroutine C_ommp_set_outputfile - - subroutine C_ommp_close_outputfile() & - bind(c, name='ommp_close_outputfile') - implicit none - - call ommp_close_outputfile() - - end subroutine C_ommp_close_outputfile - - subroutine C_ommp_print_summary(s_prt) bind(c, name='ommp_print_summary') - !! Print a summary of the system input on standard output. - implicit none - - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - - call c_f_pointer(s_prt, s) - call ommp_print_summary(s) - - end subroutine C_ommp_print_summary - - subroutine C_ommp_print_summary_to_file(s_prt, filename) & - bind(c, name='ommp_print_summary_to_file') - !! Print a summary of the system input on file. - implicit none - - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - character(kind=c_char), intent(in) :: filename(OMMP_STR_CHAR_MAX) - !! File where the summary will be printed - character(len=OMMP_STR_CHAR_MAX) :: output_file - - call c_f_pointer(s_prt, s) - call c2f_string(filename, output_file) - call ommp_print_summary_to_file(s, output_file) - - end subroutine C_ommp_print_summary_to_file - - subroutine C_ommp_save_mmp(s_prt, filename, version) & - bind(c, name='ommp_save_mmp') - implicit none - type(c_ptr), value :: s_prt - character(kind=c_char), intent(in) :: filename(OMMP_STR_CHAR_MAX) - integer(ommp_integer), value :: version - - character(len=OMMP_STR_CHAR_MAX) :: output_file - type(ommp_system), pointer :: s - - call c_f_pointer(s_prt, s) - - call c2f_string(filename, output_file) - call ommp_save_mmp(s, output_file, version) - end subroutine - - subroutine C_ommp_update_coordinates(s_prt, new_c_p) & - bind(C, name='ommp_update_coordinates') - use mod_mmpol, only: update_coordinates - - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: new_c_p - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: new_c(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(new_c_p, new_c, [3, s%top%mm_atoms]) - - call update_coordinates(s, new_c) - end subroutine - - ! Functions mapped on actual Fortran interface functions - ! OMMP System Object housekeeping - function C_ommp_init_mmp(filename) & - result(c_prt) bind(c, name='ommp_init_mmp') - !! Initalize OMMP System Object from .mmp file - implicit none - - type(ommp_system), pointer, save :: s - character(kind=c_char), intent(in) :: filename(OMMP_STR_CHAR_MAX) - character(len=OMMP_STR_CHAR_MAX) :: input_file - type(c_ptr) :: c_prt - - !allocate(s) - - call c2f_string(filename, input_file) - call ommp_init_mmp(s, input_file) - c_prt = c_loc(s) - end function - - function C_ommp_init_xyz(xyzfile, prmfile) & - result(c_prt) bind(c, name='ommp_init_xyz') - !! Initialize the library using a Tinker xyz and a Tinker prm - implicit none - - type(ommp_system), pointer, save :: s - character(kind=c_char), intent(in) :: xyzfile(OMMP_STR_CHAR_MAX), & - prmfile(OMMP_STR_CHAR_MAX) - character(len=OMMP_STR_CHAR_MAX) :: xyz_file, prm_file - type(c_ptr) :: c_prt - - !allocate(s) - - call c2f_string(prmfile, prm_file) - call c2f_string(xyzfile, xyz_file) - call ommp_init_xyz(s, xyz_file, prm_file) - c_prt = c_loc(s) - end function - - subroutine C_ommp_set_frozen_atoms(s_prt, n, frozen) & - bind(c, name='ommp_set_frozen_atoms') - implicit none - type(c_ptr), value :: s_prt, frozen - integer(ommp_integer), value :: n - type(ommp_system), pointer :: s - integer(ommp_integer), pointer :: f(:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(frozen, f, [n]) - call ommp_set_frozen_atoms(s, n, f) - end subroutine - - subroutine C_ommp_turn_pol_off(s_prt, n, nopol) & - bind(c, name='ommp_turn_pol_off') - implicit none - type(c_ptr), value :: s_prt, nopol - integer(ommp_integer), value :: n - type(ommp_system), pointer :: s - integer(ommp_integer), pointer :: f(:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(nopol, f, [n]) - call ommp_turn_pol_off(s, n, f) - end subroutine - - subroutine C_ommp_terminate(s_prt) bind(c, name='ommp_terminate') - !! Terminate a OMMP System Object - implicit none - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - - call c_f_pointer(s_prt, s) - call ommp_terminate(s) - end subroutine - - ! Interface for normal operation of OMMP System Object - subroutine C_ommp_set_external_field(s_prt, ext_field_prt, solver, matv) & - bind(c, name='ommp_set_external_field') - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: ext_field_prt - integer(ommp_integer), intent(in), value :: solver - integer(ommp_integer), intent(in), value :: matv - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: ext_field(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(ext_field_prt, ext_field, [3, s%eel%pol_atoms]) - - call ommp_set_external_field(s, ext_field, solver, matv, .true.) - end subroutine C_ommp_set_external_field - - subroutine C_ommp_set_external_field_nomm(s_prt, ext_field_prt, solver, matv) & - bind(c, name='ommp_set_external_field_nomm') - !!use mod_mmpol, only: pol_atoms - - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: ext_field_prt - integer(ommp_integer), intent(in), value :: solver - integer(ommp_integer), intent(in), value :: matv - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: ext_field(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(ext_field_prt, ext_field, [3, s%eel%pol_atoms]) - - call ommp_set_external_field(s, ext_field, solver, matv, .false.) - end subroutine C_ommp_set_external_field_nomm - - subroutine C_ommp_potential_mmpol2ext(s_prt, n, cext, v) & - bind(c, name='ommp_potential_mmpol2ext') - ! Compute the electric potential of static sites at - ! arbitrary coordinates - implicit none - - integer(ommp_integer), intent(in), value :: n - type(c_ptr), value :: s_prt, cext, v - type(ommp_system), pointer :: s - real(ommp_real), pointer :: fcext(:,:), fv(:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(cext, fcext, [3,n]) - call c_f_pointer(v, fv, [n]) - call ommp_potential_mmpol2ext(s, n, fcext, fv) - end subroutine - - subroutine C_ommp_potential_pol2ext(s_prt, n, cext, v) & - bind(c, name='ommp_potential_pol2ext') - ! Compute the electric potential of static sites at - ! arbitrary coordinates - implicit none - - integer(ommp_integer), intent(in), value :: n - type(c_ptr), value :: s_prt, cext, v - type(ommp_system), pointer :: s - real(ommp_real), pointer :: fcext(:,:), fv(:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(cext, fcext, [3,n]) - call c_f_pointer(v, fv, [n]) - call ommp_potential_pol2ext(s, n, fcext, fv) - end subroutine - - subroutine C_ommp_potential_mm2ext(s_prt, n, cext, v) & - bind(c, name='ommp_potential_mm2ext') - ! Compute the electric potential of static sites at - ! arbitrary coordinates - implicit none - - integer(ommp_integer), intent(in), value :: n - type(c_ptr), value :: s_prt, cext, v - type(ommp_system), pointer :: s - real(ommp_real), pointer :: fcext(:,:), fv(:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(cext, fcext, [3,n]) - call c_f_pointer(v, fv, [n]) - call ommp_potential_mm2ext(s, n, fcext, fv) - end subroutine - - function C_ommp_get_polelec_energy(s_prt) & - result(epol) bind(c, name='ommp_get_polelec_energy') - implicit none - - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - real(ommp_real) :: epol - - call c_f_pointer(s_prt, s) - epol = ommp_get_polelec_energy(s) - end function - - function C_ommp_get_fixedelec_energy(s_prt) & - result(emm) bind(c, name='ommp_get_fixedelec_energy') - ! Get the interaction energy of fixed multipoles - implicit none - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - real(ommp_real) :: emm - - call c_f_pointer(s_prt, s) - - emm = ommp_get_fixedelec_energy(s) - end function - - function C_ommp_get_full_ele_energy(s_prt) & - result(ene) bind(c, name='ommp_get_full_ele_energy') - implicit none - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: sys_obj - real(ommp_real) :: ene - - call c_f_pointer(s_prt, sys_obj) - - ene = ommp_get_full_ele_energy(sys_obj) - end function - - function C_ommp_get_vdw_energy(s_prt) & - result(evdw) bind(c, name='ommp_get_vdw_energy') - implicit none - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - real(ommp_real) :: evdw - - call c_f_pointer(s_prt, s) - - evdw = ommp_get_vdw_energy(s) - - end function - - function C_ommp_get_bond_energy(s_prt) & - result(ebnd) bind(c, name='ommp_get_bond_energy') - implicit none - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - real(ommp_real) :: ebnd - - call c_f_pointer(s_prt, s) - - ebnd = ommp_get_bond_energy(s) - end function - - function C_ommp_get_angle_energy(s_prt) & - result(eang) bind(c, name='ommp_get_angle_energy') - implicit none - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - real(ommp_real) :: eang - - call c_f_pointer(s_prt, s) - - eang = ommp_get_angle_energy(s) - end function - - function C_ommp_get_strbnd_energy(s_prt) & - result(eba) bind(c, name='ommp_get_strbnd_energy') - implicit none - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - real(ommp_real) :: eba - - call c_f_pointer(s_prt, s) - - eba = ommp_get_strbnd_energy(s) - end function - - function C_ommp_get_urey_energy(s_prt) & - result(eub) bind(c, name='ommp_get_urey_energy') - implicit none - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - real(ommp_real) :: eub - - call c_f_pointer(s_prt, s) - - eub = ommp_get_urey_energy(s) - end function - - function C_ommp_get_opb_energy(s_prt) & - result(eopb) bind(c, name='ommp_get_opb_energy') - - use mod_bonded, only: opb_potential - - implicit none - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - real(ommp_real) :: eopb - - call c_f_pointer(s_prt, s) - - eopb = ommp_get_opb_energy(s) - end function - - function C_ommp_get_imptorsion_energy(s_prt) & - result(et) bind(c, name='ommp_get_imptorsion_energy') - implicit none - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - real(ommp_real) :: et - - call c_f_pointer(s_prt, s) - - et = ommp_get_imptorsion_energy(s) - end function - - function C_ommp_get_torsion_energy(s_prt) & - result(et) bind(c, name='ommp_get_torsion_energy') - implicit none - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - real(ommp_real) :: et - - call c_f_pointer(s_prt, s) - - et = ommp_get_torsion_energy(s) - end function - - function C_ommp_get_pitors_energy(s_prt) & - result(epitors) bind(c, name='ommp_get_pitors_energy') - implicit none - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - real(ommp_real) :: epitors - - call c_f_pointer(s_prt, s) - - epitors = ommp_get_pitors_energy(s) - end function - - function C_ommp_get_strtor_energy(s_prt) & - result(ebt) bind(c, name='ommp_get_strtor_energy') - implicit none - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - real(ommp_real) :: ebt - - call c_f_pointer(s_prt, s) - - ebt = ommp_get_strtor_energy(s) - end function - - function C_ommp_get_angtor_energy(s_prt) & - result(eat) bind(c, name='ommp_get_angtor_energy') - implicit none - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - real(ommp_real) :: eat - - call c_f_pointer(s_prt, s) - - eat = ommp_get_angtor_energy(s) - end function - - function C_ommp_get_tortor_energy(s_prt) & - result(ett) bind(c, name='ommp_get_tortor_energy') - implicit none - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - real(ommp_real) :: ett - - call c_f_pointer(s_prt, s) - - ett = ommp_get_tortor_energy(s) - end function - - function C_ommp_get_full_bnd_energy(s_prt) & - result(ene) bind(c, name='ommp_get_full_bnd_energy') - - implicit none - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: sys_obj - real(ommp_real) :: ene - - call c_f_pointer(s_prt, sys_obj) - - ene = ommp_get_full_bnd_energy(sys_obj) - end function - - function C_ommp_get_full_energy(s_prt) & - result(ene) bind(c, name='ommp_get_full_energy') - - implicit none - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: sys_obj - real(ommp_real) :: ene - - call c_f_pointer(s_prt, sys_obj) - - ene = ommp_get_full_energy(sys_obj) - end function - - ! Functions for advanced operation and gradients - subroutine C_ommp_vdw_geomgrad(s_prt, grd_prt) & - bind(C, name='ommp_vdw_geomgrad') - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: grd_prt - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: grd(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) - - call ommp_vdw_geomgrad(s, grd) - end subroutine - - subroutine C_ommp_rotation_geomgrad(s_prt, pE, pE_grd, grd_prt) & - bind(C, name="ommp_rotation_geomgrad") - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: pE - type(c_ptr), value :: pE_grd - type(c_ptr), value :: grd_prt - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: grd(:,:), E(:,:), Egrd(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) - call c_f_pointer(pE, E, [3, s%top%mm_atoms]) - call c_f_pointer(pE_grd, Egrd, [6, s%top%mm_atoms]) - - call ommp_rotation_geomgrad(s, E, Egrd, grd) - end subroutine - - subroutine C_ommp_bond_geomgrad(s_prt, grd_prt) & - bind(C, name='ommp_bond_geomgrad') - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: grd_prt - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: grd(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) - - call ommp_bond_geomgrad(s, grd) - end subroutine - - subroutine C_ommp_angle_geomgrad(s_prt, grd_prt) & - bind(C, name='ommp_angle_geomgrad') - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: grd_prt - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: grd(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) - - call ommp_angle_geomgrad(s, grd) - end subroutine - - subroutine C_ommp_strbnd_geomgrad(s_prt, grd_prt) & - bind(C, name='ommp_strbnd_geomgrad') - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: grd_prt - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: grd(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) - - call ommp_strbnd_geomgrad(s, grd) - end subroutine - - subroutine C_ommp_urey_geomgrad(s_prt, grd_prt) & - bind(C, name='ommp_urey_geomgrad') - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: grd_prt - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: grd(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) - - call ommp_urey_geomgrad(s, grd) - end subroutine - - subroutine C_ommp_torsion_geomgrad(s_prt, grd_prt) & - bind(C, name='ommp_torsion_geomgrad') - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: grd_prt - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: grd(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) - - call ommp_torsion_geomgrad(s, grd) - end subroutine - - subroutine C_ommp_imptorsion_geomgrad(s_prt, grd_prt) & - bind(C, name='ommp_imptorsion_geomgrad') - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: grd_prt - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: grd(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) - - call ommp_imptorsion_geomgrad(s, grd) - end subroutine - - subroutine C_ommp_angtor_geomgrad(s_prt, grd_prt) & - bind(C, name='ommp_angtor_geomgrad') - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: grd_prt - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: grd(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) - - call ommp_angtor_geomgrad(s, grd) - end subroutine - - subroutine C_ommp_opb_geomgrad(s_prt, grd_prt) & - bind(C, name='ommp_opb_geomgrad') - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: grd_prt - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: grd(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) - - call ommp_opb_geomgrad(s, grd) - end subroutine - - subroutine C_ommp_strtor_geomgrad(s_prt, grd_prt) & - bind(C, name='ommp_strtor_geomgrad') - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: grd_prt - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: grd(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) - - call ommp_strtor_geomgrad(s, grd) - end subroutine - - subroutine C_ommp_tortor_geomgrad(s_prt, grd_prt) & - bind(C, name='ommp_tortor_geomgrad') - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: grd_prt - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: grd(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) - - call ommp_tortor_geomgrad(s, grd) - end subroutine - - subroutine C_ommp_pitors_geomgrad(s_prt, grd_prt) & - bind(C, name='ommp_pitors_geomgrad') - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: grd_prt - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: grd(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) - - call ommp_pitors_geomgrad(s, grd) - end subroutine - - subroutine C_ommp_full_bnd_geomgrad(s_prt, grd_prt) & - bind(C, name='ommp_full_bnd_geomgrad') - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: grd_prt - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: grd(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) - - call ommp_full_bnd_geomgrad(s, grd) - end subroutine - - subroutine C_ommp_fixedelec_geomgrad(s_prt, grd_prt) & - bind(C, name='ommp_fixedelec_geomgrad') - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: grd_prt - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: grd(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) - call ommp_fixedelec_geomgrad(s, grd) - end subroutine - - subroutine C_ommp_polelec_geomgrad(s_prt, grd_prt) & - bind(C, name='ommp_polelec_geomgrad') - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: grd_prt - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: grd(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) - call ommp_polelec_geomgrad(s, grd) - end subroutine - - subroutine C_ommp_full_geomgrad(s_prt, grd_prt) & - bind(C, name='ommp_full_geomgrad') - use ommp_interface, only: ommp_full_geomgrad - - implicit none - - type(c_ptr), value :: s_prt - type(c_ptr), value :: grd_prt - - type(ommp_system), pointer :: s - real(ommp_real), pointer :: grd(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(grd_prt, grd, [3, s%top%mm_atoms]) - - call ommp_full_geomgrad(s, grd) - end subroutine - -#ifdef USE_HDF5 - function C_ommp_init_hdf5(filename, namespace) & - result(c_prt) bind(c, name='ommp_init_hdf5') - !! This function is an interface for saving an HDF5 file - !! with all the data contained in mmpol module using - !! [[mod_io:mmpol_save_as_hdf5]] - use mod_iohdf5, only: mmpol_init_from_hdf5 - - implicit none - - type(ommp_system), pointer :: s - character(kind=c_char), intent(in) :: filename(OMMP_STR_CHAR_MAX), & - namespace(OMMP_STR_CHAR_MAX) - character(len=OMMP_STR_CHAR_MAX) :: hdf5in, nms - integer(ommp_integer) :: ok - type(c_ptr) :: c_prt - - allocate(s) - - call c2f_string(filename, hdf5in) - call c2f_string(namespace, nms) - call mmpol_init_from_hdf5(hdf5in, trim(nms), s, ok) - - c_prt = c_loc(s) - - end function C_ommp_init_hdf5 - - subroutine C_ommp_save_as_hdf5(s_prt, filename, namespace) & - bind(c, name='ommp_save_as_hdf5') - - use mod_iohdf5, only: save_system_as_hdf5 - - implicit none - - character(kind=c_char), intent(in) :: filename(OMMP_STR_CHAR_MAX), & - namespace(OMMP_STR_CHAR_MAX) - character(len=OMMP_STR_CHAR_MAX) :: hdf5out, nms - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - integer(kind=4) :: err - - call c_f_pointer(s_prt, s) - - call c2f_string(filename, hdf5out) - call c2f_string(namespace, nms) - call save_system_as_hdf5(hdf5out, s, err, trim(nms), logical(.false., kind=ommp_logical)) - - end subroutine C_ommp_save_as_hdf5 - - subroutine C_ommp_checkpoint(s_prt, filename, namespace) & - bind(c, name='ommp_checkpoint') - - use mod_iohdf5, only: save_system_as_hdf5 - - implicit none - - character(kind=c_char), intent(in) :: filename(OMMP_STR_CHAR_MAX), & - namespace(OMMP_STR_CHAR_MAX) - character(len=OMMP_STR_CHAR_MAX) :: hdf5out, nms - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - integer(kind=4) :: err - - call c_f_pointer(s_prt, s) - - call c2f_string(filename, hdf5out) - call c2f_string(namespace, nms) - call save_system_as_hdf5(hdf5out, s, err, trim(nms), logical(.true., kind=ommp_logical)) - - end subroutine C_ommp_checkpoint -#endif - ! Functions to provide direct access to Fortran objects/memory from - ! C and derived codes. - function C_ommp_get_cmm(s_prt) bind(c, name='ommp_get_cmm') - !! Return the c-pointer to the array containing the coordinates of - !! MM atoms. - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - type(c_ptr) :: C_ommp_get_cmm - - call c_f_pointer(s_prt, s) - C_ommp_get_cmm = c_loc(s%top%cmm) - end function C_ommp_get_cmm - - function C_ommp_get_zmm(s_prt) bind(c, name='ommp_get_zmm') - !! Return the c-pointer to the array containing the coordinates of - !! MM atoms. - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - type(c_ptr) :: C_ommp_get_zmm - - call c_f_pointer(s_prt, s) - C_ommp_get_zmm = c_loc(s%top%atz) - end function C_ommp_get_zmm - - function C_ommp_get_attypemm(s_prt) bind(c, name='ommp_get_attypemm') - !! Return the c-pointer to the array containing the coordinates of - !! MM atoms. - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - type(c_ptr) :: C_ommp_get_attypemm - - call c_f_pointer(s_prt, s) - if(s%top%attype_initialized) then - C_ommp_get_attypemm = c_loc(s%top%attype) - else - C_ommp_get_attypemm = c_null_ptr - end if - end function C_ommp_get_attypemm - - - function C_ommp_get_cpol(s_prt) bind(c, name='ommp_get_cpol') - !! Return the c-pointer to the array containing the coordinates of - !! polarizable atoms. - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - type(c_ptr) :: C_ommp_get_cpol - - call c_f_pointer(s_prt, s) - C_ommp_get_cpol = c_loc(s%eel%cpol) - end function C_ommp_get_cpol - - function C_ommp_get_q(s_prt) bind(c, name='ommp_get_q') - !! Return the c-pointer to the array containing the static source of - !! the electrostatic field. - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - type(c_ptr) :: C_ommp_get_q - - call c_f_pointer(s_prt, s) - C_ommp_get_q = c_loc(s%eel%q) - end function C_ommp_get_q - - function C_ommp_get_ipd(s_prt) bind(c, name='ommp_get_ipd') - !! Return the c-pointer to the array containing the induced dipoles - !! on polarizable sites. - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - type(c_ptr) :: C_ommp_get_ipd - - call c_f_pointer(s_prt, s) - C_ommp_get_ipd = c_loc(s%eel%ipd) - end function C_ommp_get_ipd - - function C_ommp_get_polar_mm(s_prt) bind(c, name='ommp_get_polar_mm') - !! Return the c-pointer to the array containing the map from - !! polarizable to MM atoms. - use mod_memory, only: mallocate - implicit none - - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - type(c_ptr) :: C_ommp_get_polar_mm - - call c_f_pointer(s_prt, s) - if(.not. allocated(s%eel%C_polar_mm)) then - call mallocate('C_ommp_get_polar_mm [C_polar_mm]', & - size(s%eel%polar_mm), s%eel%C_polar_mm) - s%eel%C_polar_mm = s%eel%polar_mm - 1 - end if - - C_ommp_get_polar_mm = c_loc(s%eel%C_polar_mm) - end function C_ommp_get_polar_mm - - function C_ommp_use_frozen(s_prt) bind(c, name='ommp_use_frozen') - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - logical(c_bool) :: C_ommp_use_frozen - - call c_f_pointer(s_prt, s) - C_ommp_use_frozen = s%top%use_frozen - end function C_ommp_use_frozen - - function C_ommp_get_frozen(s_prt) bind(c, name='ommp_get_frozen') - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - type(c_ptr) :: C_ommp_get_frozen - - call c_f_pointer(s_prt, s) - C_ommp_get_frozen = c_loc(s%top%frozen) - end function C_ommp_get_frozen - - function C_ommp_get_mm_atoms(s_prt) bind(c, name='ommp_get_mm_atoms') - !! Return the number of MM atoms in the system. - implicit none - - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - integer(ommp_integer) :: C_ommp_get_mm_atoms - - call c_f_pointer(s_prt, s) - C_ommp_get_mm_atoms = s%top%mm_atoms - end function C_ommp_get_mm_atoms - - function C_ommp_get_pol_atoms(s_prt) bind(c, name='ommp_get_pol_atoms') - !! Return the number of polarizable atoms in the system. - implicit none - - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - integer(ommp_integer) :: C_ommp_get_pol_atoms - - call c_f_pointer(s_prt, s) - - C_ommp_get_pol_atoms = s%eel%pol_atoms - end function C_ommp_get_pol_atoms - - function C_ommp_get_n_ipd(s_prt) bind(c, name='ommp_get_n_ipd') - !! Return the number of dipole's set for the current Force-Field. - implicit none - - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - integer(ommp_integer) :: C_ommp_get_n_ipd - - call c_f_pointer(s_prt, s) - C_ommp_get_n_ipd = s%eel%n_ipd - end function C_ommp_get_n_ipd - - function C_ommp_get_ld_cart(s_prt) bind(c, name='ommp_get_ld_cart') - implicit none - - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - integer(ommp_integer) :: C_ommp_get_ld_cart - - call c_f_pointer(s_prt, s) - C_ommp_get_ld_cart = s%eel%ld_cart - end function C_ommp_get_ld_cart - - function C_ommp_ff_is_amoeba(s_prt) bind(c, name='ommp_ff_is_amoeba') - !! Return true if the current forcefield is AMOEBA, and false in - !! all other cases. - implicit none - - type(c_ptr), value :: s_prt - type(ommp_system), pointer :: s - logical(c_bool) :: C_ommp_ff_is_amoeba - - call c_f_pointer(s_prt, s) - C_ommp_ff_is_amoeba = s%amoeba - end function C_ommp_ff_is_amoeba - - function C_ommp_use_linkatoms(s_ptr) & - result(u) bind(C, name='ommp_use_linkatoms') - implicit none - - type(c_ptr), value :: s_ptr - !! C pointer to system object - type(ommp_system), pointer :: s - logical(c_bool) :: u - - call c_f_pointer(s_ptr, s) - u = s%use_linkatoms - end function - - !?? - subroutine C_ommp_field_mmpol2ext(s_prt, n, cext, E) & - bind(c, name='ommp_field_mmpol2ext') - ! Compute the electric potential of static sites at - ! arbitrary coordinates - implicit none - - integer(ommp_integer), intent(in), value :: n - type(c_ptr), value :: s_prt, cext, E - type(ommp_system), pointer :: s - real(ommp_real), pointer :: fcext(:,:), fE(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(cext, fcext, [3,n]) - call c_f_pointer(E, fE, [3,n]) - call ommp_field_mmpol2ext(s, n, fcext, fE) - end subroutine - - subroutine C_ommp_field_mm2ext(s_prt, n, cext, E) & - bind(c, name='ommp_field_mm2ext') - ! Compute the electric potential of static sites at - ! arbitrary coordinates - use mod_electrostatics, only: field_M2E - - implicit none - - integer(ommp_integer), intent(in), value :: n - type(c_ptr), value :: s_prt, cext, E - type(ommp_system), pointer :: s - real(ommp_real), pointer :: fcext(:,:), fE(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(cext, fcext, [3,n]) - call c_f_pointer(E, fE, [3,n]) - call field_M2E(s%eel, fcext, fE) - end subroutine - - subroutine C_ommp_field_pol2ext(s_prt, n, cext, E) & - bind(c, name='ommp_field_pol2ext') - ! Compute the electric potential of static sites at - ! arbitrary coordinates - use mod_electrostatics, only: field_D2E - - implicit none - - integer(ommp_integer), intent(in), value :: n - type(c_ptr), value :: s_prt, cext, E - type(ommp_system), pointer :: s - real(ommp_real), pointer :: fcext(:,:), fE(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(cext, fcext, [3,n]) - call c_f_pointer(E, fE, [3,n]) - call field_D2E(s%eel, fcext, fE) - end subroutine - - ! Interface for QM Helper module - function C_ommp_init_qm_helper(n, cqm, qqm, zqm) & - result(c_prt) bind(c, name='ommp_init_qm_helper') - implicit none - - type(ommp_qm_helper), pointer :: s - integer(ommp_integer), value, intent(in) :: n - type(c_ptr), value, intent(in) :: cqm, qqm, zqm - - real(ommp_real), pointer :: fcqm(:,:), fqqm(:) - integer(ommp_integer), pointer :: fzqm(:) - type(c_ptr) :: c_prt - - call c_f_pointer(cqm, fcqm, [3,n]) - call c_f_pointer(qqm, fqqm, [n]) - call c_f_pointer(zqm, fzqm, [n]) - call ommp_init_qm_helper(s, n, fcqm, fqqm, fzqm) - c_prt = c_loc(s) - end function - - subroutine C_ommp_qm_helper_set_frozen_atoms(s_prt, n, frozen) & - bind(c, name='ommp_qm_helper_set_frozen_atoms') - implicit none - type(c_ptr), value :: s_prt, frozen - integer(ommp_integer), value :: n - type(ommp_qm_helper), pointer :: s - integer(ommp_integer), pointer :: f(:) - call c_f_pointer(s_prt, s) - call c_f_pointer(frozen, f, [n]) - - call ommp_qm_helper_set_frozen_atoms(s, n, f) - end subroutine - - subroutine C_ommp_terminate_qm_helper(s_ptr) & - bind(c, name='ommp_terminate_qm_helper') - - use mod_qm_helper, only: qm_helper_terminate, ommp_qm_helper - - implicit none - - type(c_ptr), value :: s_ptr - type(ommp_qm_helper), pointer :: s - - if(c_associated(s_ptr)) then - call c_f_pointer(s_ptr, s) - call qm_helper_terminate(s) - deallocate(s) - end if - end subroutine - - subroutine C_ommp_qm_helper_update_coord(s_ptr, cqm) & - bind(c, name='ommp_qm_helper_update_coord') - implicit none - - type(c_ptr), value :: s_ptr - type(c_ptr), value, intent(in) :: cqm - - real(ommp_real), pointer :: fcqm(:,:) - type(ommp_qm_helper), pointer :: s - - call c_f_pointer(s_ptr, s) - call c_f_pointer(cqm, fcqm, [3,s%qm_top%mm_atoms]) - call ommp_qm_helper_update_coord(s, fcqm) - end subroutine - - subroutine C_ommp_qm_helper_set_attype(pqm, pattype) & - bind(c, name='ommp_qm_helper_set_attype') - implicit none - - type(c_ptr), value, intent(in) :: pqm, pattype - - type(ommp_qm_helper), pointer :: qm - integer(ommp_integer), pointer :: attype(:) - - call c_f_pointer(pqm, qm) - call c_f_pointer(pattype, attype, [qm%qm_top%mm_atoms]) - - call ommp_qm_helper_set_attype(qm, attype) - end subroutine - - subroutine C_ommp_qm_helper_init_vdw_prm(pqm, cprmfile) & - bind(c, name='ommp_qm_helper_init_vdw_prm') - implicit none - - type(c_ptr), value, intent(in) :: pqm - character(kind=c_char), intent(in) :: cprmfile(OMMP_STR_CHAR_MAX) - - type(ommp_qm_helper), pointer :: qm - character(len=OMMP_STR_CHAR_MAX) :: prmfile - - call c_f_pointer(pqm, qm) - call c2f_string(cprmfile, prmfile) - - call ommp_qm_helper_init_vdw_prm(qm, prmfile) - end subroutine - - subroutine C_ommp_qm_helper_init_vdw(pqm, peps, prad, pfac, & - cvdw_type, cradius_rule, & - cradius_size, cradius_type, & - ceps_rule) & - bind(c, name='ommp_qm_helper_init_vdw') - implicit none - - type(c_ptr), value, intent(in) :: pqm, peps, prad, pfac - character(kind=c_char), intent(in) :: cvdw_type(OMMP_STR_CHAR_MAX), & - cradius_rule(OMMP_STR_CHAR_MAX), & - cradius_size(OMMP_STR_CHAR_MAX), & - cradius_type(OMMP_STR_CHAR_MAX), & - ceps_rule(OMMP_STR_CHAR_MAX) - - type(ommp_qm_helper), pointer :: qm - character(len=OMMP_STR_CHAR_MAX) :: vdw_type, radius_rule, & - radius_size, radius_type, & - eps_rule - real(ommp_real), pointer :: eps(:), rad(:), fac(:) - - call c_f_pointer(pqm, qm) - call c_f_pointer(peps, eps, [qm%qm_top%mm_atoms]) - call c_f_pointer(prad, rad, [qm%qm_top%mm_atoms]) - call c_f_pointer(pfac, fac, [qm%qm_top%mm_atoms]) - call c2f_string(cvdw_type, vdw_type) - call c2f_string(cradius_rule, radius_rule) - call c2f_string(cradius_size, radius_size) - call c2f_string(cradius_type, radius_type) - call c2f_string(ceps_rule, eps_rule) - - call ommp_qm_helper_init_vdw(qm, eps, rad, fac, vdw_type, radius_rule, & - radius_size, radius_type, eps_rule) - end subroutine - - function C_ommp_qm_helper_vdw_energy(qm_prt, s_prt) & - result(evdw) bind(c, name='ommp_qm_helper_vdw_energy') - implicit none - - type(c_ptr), value :: qm_prt, s_prt - type(ommp_system), pointer :: s - type(ommp_qm_helper), pointer :: qm - real(ommp_real) :: evdw - - call c_f_pointer(s_prt, s) - call c_f_pointer(qm_prt, qm) - - evdw = ommp_qm_helper_vdw_energy(qm, s) - end function - - subroutine C_ommp_qm_helper_vdw_geomgrad(qm_prt, s_prt, qmg_prt, mmg_prt) & - bind(c, name='ommp_qm_helper_vdw_geomgrad') - implicit none - - type(c_ptr), value :: qm_prt, s_prt, qmg_prt, mmg_prt - type(ommp_system), pointer :: s - type(ommp_qm_helper), pointer :: qm - real(ommp_real), pointer :: qmg(:,:), mmg(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(qm_prt, qm) - call c_f_pointer(qmg_prt, qmg, [3,qm%qm_top%mm_atoms]) - call c_f_pointer(mmg_prt, mmg, [3,s%top%mm_atoms]) - - call ommp_qm_helper_vdw_geomgrad(qm, s, qmg, mmg) - end subroutine - - subroutine C_ommp_qm_helper_link_atom_geomgrad(qm_prt, s_prt, qmg_prt, mmg_prt, old_qmg_ptr) & - bind(c, name='ommp_qm_helper_link_atom_geomgrad') - implicit none - - type(c_ptr), value :: qm_prt, s_prt, qmg_prt, mmg_prt, old_qmg_ptr - type(ommp_system), pointer :: s - type(ommp_qm_helper), pointer :: qm - real(ommp_real), pointer :: qmg(:,:), mmg(:,:), old_qmg(:,:) - - call c_f_pointer(s_prt, s) - call c_f_pointer(qm_prt, qm) - call c_f_pointer(qmg_prt, qmg, [3,qm%qm_top%mm_atoms]) - call c_f_pointer(old_qmg_ptr, old_qmg, [3,qm%qm_top%mm_atoms]) - call c_f_pointer(mmg_prt, mmg, [3,s%top%mm_atoms]) - - call ommp_qm_helper_link_atom_geomgrad(qm, s, qmg, mmg, old_qmg) - end subroutine - - subroutine C_ommp_prepare_qm_ele_ene(s_ptr, qm_ptr) & - bind(c, name='ommp_prepare_qm_ele_ene') - implicit none - - type(c_ptr), value :: s_ptr - !! C pointer to system object - type(c_ptr), value :: qm_ptr - !! C pointer to qm_helper object - - type(ommp_qm_helper), pointer :: qm_help - type(ommp_system), pointer :: s - - call c_f_pointer(qm_ptr, qm_help) - call c_f_pointer(s_ptr, s) - - call ommp_prepare_qm_ele_ene(s, qm_help) - end subroutine - - subroutine C_ommp_prepare_qm_ele_grd(s_ptr, qm_ptr) & - bind(c, name='ommp_prepare_qm_ele_grd') - implicit none - - type(c_ptr), value :: s_ptr - !! C pointer to system object - type(c_ptr), value :: qm_ptr - !! C pointer to qm_helper object - - type(ommp_qm_helper), pointer :: qm_help - type(ommp_system), pointer :: s - - call c_f_pointer(qm_ptr, qm_help) - call c_f_pointer(s_ptr, s) - - call ommp_prepare_qm_ele_grd(s, qm_help) - end subroutine - - function C_ommp_qm_helper_get_npol(qm_ptr) & - result(npol) bind(C, name='ommp_qm_helper_get_npol') - use mod_qm_helper, only: ommp_qm_helper - implicit none - - type(c_ptr), value :: qm_ptr - !! C pointer to qm_helper object - - type(ommp_qm_helper), pointer :: qm_help - integer(ommp_integer) :: npol - - call c_f_pointer(qm_ptr, qm_help) - if(qm_help%E_n2p_done) then - npol = size(qm_help%E_n2p, 2, ommp_integer) - else - npol = 0 - end if - end function - - function C_ommp_qm_helper_get_nmm(qm_ptr) & - result(nmm) bind(C, name='ommp_qm_helper_get_nmm') - use mod_qm_helper, only: ommp_qm_helper - implicit none - - type(c_ptr), value :: qm_ptr - !! C pointer to qm_helper object - - type(ommp_qm_helper), pointer :: qm_help - integer(ommp_integer) :: nmm - - call c_f_pointer(qm_ptr, qm_help) - if(qm_help%E_n2m_done) then - nmm = size(qm_help%E_n2m, 2, ommp_integer) - else - nmm = 0 - end if - end function - - function C_ommp_qm_helper_get_cqm(qm_ptr) & - result(ptr) bind(C, name='ommp_qm_helper_get_cqm') - use mod_qm_helper, only: ommp_qm_helper - implicit none - - type(c_ptr), value :: qm_ptr - !! C pointer to qm_helper object - - type(ommp_qm_helper), pointer :: qm_help - type(c_ptr) :: ptr - - call c_f_pointer(qm_ptr, qm_help) - ptr = c_loc(qm_help%qm_top%cmm) - end function - - function C_ommp_qm_helper_get_E_n2p(qm_ptr) & - result(ptr) bind(C, name='ommp_qm_helper_get_E_n2p') - use mod_qm_helper, only: ommp_qm_helper - implicit none - - type(c_ptr), value :: qm_ptr - !! C pointer to qm_helper object - - type(ommp_qm_helper), pointer :: qm_help - type(c_ptr) :: ptr - - call c_f_pointer(qm_ptr, qm_help) - if(qm_help%E_n2p_done) then - ptr = c_loc(qm_help%E_n2p) - else - ptr = c_null_ptr - end if - end function - - function C_ommp_qm_helper_get_G_n2p(qm_ptr) & - result(ptr) bind(C, name='ommp_qm_helper_get_G_n2p') - use mod_qm_helper, only: ommp_qm_helper - implicit none - - type(c_ptr), value :: qm_ptr - !! C pointer to qm_helper object - - type(ommp_qm_helper), pointer :: qm_help - type(c_ptr) :: ptr - - call c_f_pointer(qm_ptr, qm_help) - if(qm_help%G_n2p_done) then - ptr = c_loc(qm_help%G_n2p) - else - ptr = c_null_ptr - end if - end function - - function C_ommp_qm_helper_get_E_n2m(qm_ptr) & - result(ptr) bind(C, name='ommp_qm_helper_get_E_n2m') - use mod_qm_helper, only: ommp_qm_helper - implicit none - - type(c_ptr), value :: qm_ptr - !! C pointer to qm_helper object - - type(ommp_qm_helper), pointer :: qm_help - type(c_ptr) :: ptr - - call c_f_pointer(qm_ptr, qm_help) - if(qm_help%E_n2m_done) then - ptr = c_loc(qm_help%E_n2m) - else - ptr = c_null_ptr - end if - end function - - function C_ommp_qm_helper_get_G_n2m(qm_ptr) & - result(ptr) bind(C, name='ommp_qm_helper_get_G_n2m') - use mod_qm_helper, only: ommp_qm_helper - implicit none - - type(c_ptr), value :: qm_ptr - !! C pointer to qm_helper object - - type(ommp_qm_helper), pointer :: qm_help - type(c_ptr) :: ptr - - call c_f_pointer(qm_ptr, qm_help) - if(qm_help%G_n2m_done) then - ptr = c_loc(qm_help%G_n2m) - else - ptr = c_null_ptr - end if - end function - - function C_ommp_qm_helper_get_H_n2m(qm_ptr) & - result(ptr) bind(C, name='ommp_qm_helper_get_H_n2m') - use mod_qm_helper, only: ommp_qm_helper - implicit none - - type(c_ptr), value :: qm_ptr - !! C pointer to qm_helper object - - type(ommp_qm_helper), pointer :: qm_help - type(c_ptr) :: ptr - - call c_f_pointer(qm_ptr, qm_help) - if(qm_help%H_n2m_done) then - ptr = c_loc(qm_help%H_n2m) - else - ptr = c_null_ptr - end if - end function - - function C_ommp_qm_helper_get_E_m2n(qm_ptr) & - result(ptr) bind(C, name='ommp_qm_helper_get_E_m2n') - use mod_qm_helper, only: ommp_qm_helper - implicit none - - type(c_ptr), value :: qm_ptr - !! C pointer to qm_helper object - - type(ommp_qm_helper), pointer :: qm_help - type(c_ptr) :: ptr - - call c_f_pointer(qm_ptr, qm_help) - if(qm_help%E_m2n_done) then - ptr = c_loc(qm_help%E_m2n) - else - ptr = c_null_ptr - end if - end function - - function C_ommp_qm_helper_get_E_p2n(qm_ptr) & - result(ptr) bind(C, name='ommp_qm_helper_get_E_p2n') - use mod_qm_helper, only: ommp_qm_helper - implicit none - - type(c_ptr), value :: qm_ptr - !! C pointer to qm_helper object - - type(ommp_qm_helper), pointer :: qm_help - type(c_ptr) :: ptr - - call c_f_pointer(qm_ptr, qm_help) - if(qm_help%E_p2n_done) then - ptr = c_loc(qm_help%E_p2n) - else - ptr = c_null_ptr - end if - end function - - function C_ommp_qm_helper_get_V_m2n(qm_ptr) & - result(ptr) bind(C, name='ommp_qm_helper_get_V_m2n') - use mod_qm_helper, only: ommp_qm_helper - implicit none - - type(c_ptr), value :: qm_ptr - !! C pointer to qm_helper object - - type(ommp_qm_helper), pointer :: qm_help - type(c_ptr) :: ptr - - call c_f_pointer(qm_ptr, qm_help) - if(qm_help%V_m2n_done) then - ptr = c_loc(qm_help%V_m2n) - else - ptr = c_null_ptr - end if - end function - - function C_ommp_qm_helper_get_V_p2n(qm_ptr) & - result(ptr) bind(C, name='ommp_qm_helper_get_V_p2n') - use mod_qm_helper, only: ommp_qm_helper - implicit none - - type(c_ptr), value :: qm_ptr - !! C pointer to qm_helper object - - type(ommp_qm_helper), pointer :: qm_help - type(c_ptr) :: ptr - - call c_f_pointer(qm_ptr, qm_help) - if(qm_help%V_p2n_done) then - ptr = c_loc(qm_help%V_p2n) - else - ptr = c_null_ptr - end if - end function - - function C_ommp_qm_helper_get_qm_atoms(qm_ptr) & - result(n) bind(C, name='ommp_qm_helper_get_qm_atoms') - use mod_qm_helper, only: ommp_qm_helper - implicit none - - type(c_ptr), value :: qm_ptr - !! C pointer to qm_helper object - - type(ommp_qm_helper), pointer :: qm_help - integer(ommp_integer) :: n - - call c_f_pointer(qm_ptr, qm_help) - n = qm_help%qm_top%mm_atoms - end function - - function C_ommp_qm_helper_use_nonbonded(qm_ptr) & - result(u) bind(C, name='ommp_qm_helper_use_nonbonded') - use mod_qm_helper, only: ommp_qm_helper - implicit none - - type(c_ptr), value :: qm_ptr - !! C pointer to qm_helper object - type(ommp_qm_helper), pointer :: qm_help - logical(c_bool) :: u - - call c_f_pointer(qm_ptr, qm_help) - u = qm_help%use_nonbonded - end function - - function C_ommp_qm_helper_use_frozen(s_prt) bind(c, name='ommp_qm_helper_use_frozen') - use mod_qm_helper, only: ommp_qm_helper - implicit none - - type(c_ptr), value :: s_prt - type(ommp_qm_helper), pointer :: s - logical(c_bool) :: C_ommp_qm_helper_use_frozen - - call c_f_pointer(s_prt, s) - C_ommp_qm_helper_use_frozen = s%qm_top%use_frozen - end function C_ommp_qm_helper_use_frozen - - function C_ommp_qm_helper_get_frozen(s_prt) bind(c, name='ommp_qm_helper_get_frozen') - use mod_qm_helper, only: ommp_qm_helper - implicit none - - type(c_ptr), value :: s_prt - type(ommp_qm_helper), pointer :: s - type(c_ptr) :: C_ommp_qm_helper_get_frozen - - call c_f_pointer(s_prt, s) - C_ommp_qm_helper_get_frozen = c_loc(s%qm_top%frozen) - end function C_ommp_qm_helper_get_frozen - - function C_ommp_create_link_atom(qm_prt, s_prt, imm, iqm, ila, prmfile, & - ladist, neel_remove) & - result(la_idx) & - bind(c, name='ommp_create_link_atom') - implicit none - - type(c_ptr), value :: s_prt, qm_prt - integer(ommp_integer), value :: iqm, imm, ila, neel_remove - real(ommp_real), value :: ladist - character(kind=c_char), intent(in) :: prmfile(OMMP_STR_CHAR_MAX) - - - type(ommp_system), pointer :: s - type(ommp_qm_helper), pointer :: qm - - integer(ommp_integer) :: la_idx - character(len=OMMP_STR_CHAR_MAX) :: prm_file - - call c2f_string(prmfile, prm_file) - call c_f_pointer(s_prt, s) - call c_f_pointer(qm_prt, qm) - - la_idx = ommp_create_link_atom(qm, s, imm, iqm, ila, prm_file, & - ladist, neel_remove) - end function - - subroutine C_ommp_get_link_atom_coordinates(s_p, la_idx, crd_p) & - bind(c, name="ommp_get_link_atom_coordinates") - implicit none - - type(c_ptr), value :: s_p, crd_p - integer(ommp_integer), value :: la_idx - - type(ommp_system), pointer :: s - real(ommp_real), dimension(:), pointer :: crd - - call c_f_pointer(s_p, s) - call c_f_pointer(crd_p, crd, [3]) - - call ommp_get_link_atom_coordinates(s, la_idx, crd) - - end subroutine - - subroutine C_ommp_update_link_atoms_position(qm_prt, s_prt) & - bind(c, name='ommp_update_link_atoms_position') - implicit none - - type(c_ptr), value :: s_prt, qm_prt - - type(ommp_system), pointer :: s - type(ommp_qm_helper), pointer :: qm - - call c_f_pointer(s_prt, s) - call c_f_pointer(qm_prt, qm) - - call ommp_update_link_atoms_position(qm, s) - end subroutine - - function C_ommp_system_from_qm_helper(cqmh, cprm_file) & - result(csys) bind(c, name='ommp_system_from_qm_helper') - implicit none - - type(c_ptr), value, intent(in) :: cqmh - - type(ommp_system), pointer, save :: s - type(ommp_qm_helper), pointer :: qm - type(c_ptr) :: csys - - character(kind=c_char), intent(in) :: cprm_file(OMMP_STR_CHAR_MAX) - character(len=OMMP_STR_CHAR_MAX) :: prm_file - - call c2f_string(cprm_file, prm_file) - call c_f_pointer(cqmh, qm) - - !allocate(s) - - call ommp_system_from_qm_helper(qm, prm_file, s) - csys = c_loc(s) - end function - - subroutine C_ommp_set_vdw_cutoff(sp, cutoff) & - bind(c, name='ommp_set_vdw_cutoff') - - implicit none - - type(c_ptr), value, intent(in) :: sp - real(ommp_real), intent(in), value :: cutoff - - type(ommp_system), pointer :: s - - call c_f_pointer(sp, s) - call ommp_set_vdw_cutoff(s, cutoff) - end subroutine - -end module mod_ommp_C_interface diff --git a/src/mod_constants.F90 b/src/mod_constants.F90 new file mode 100644 index 0000000..205aebb --- /dev/null +++ b/src/mod_constants.F90 @@ -0,0 +1,131 @@ +#include + +module mod_constants + !! Contains several constants that are usefoul around the code. There are + !! physical constants (there should be no duplicate around!), default + !! force-field parameters that are used when no other input is specified, + !! and internal constants that are used as easy-to-remember names of code + !! constants. + use iso_c_binding + + implicit none + +#ifdef USE_I8 + integer(kind=c_int64_t), parameter :: ip = c_int64_t +#else + integer(kind=c_int32_t), parameter :: ip = c_int32_t +#endif + !! Required precision for integer type + integer(ip), parameter :: rp = c_double !! Required precision for real type + integer(ip), parameter :: lp = c_bool + + ! Physical constants + real(rp), parameter :: angstrom2au = OMMP_FORT_ANG2AU + !! Conversion factor from \(\AA\) to A.U. + real(rp), parameter :: kcalmol2au = OMMP_FORT_KCALMOL2AU + !! Conversion factor from kcal mol\(^{-1}\) to A.U. + real(rp), parameter :: au2kcalmol = OMMP_FORT_AU2KCALMOL + !! Conversion factor from A.U. to kcal mol\(^{-1}\) + real(rp), parameter :: pi = 4.0 * atan(1.0) + !! Value of \(\pi\) + real(rp), parameter :: deg2rad = pi / 180.0 + !! Conversion from arc degree to radians + real(rp), parameter :: rad2deg = 180.0 / pi + !! Conversion from radians to arc degree + + ! Force Field parameters + real(rp), parameter :: mscale_wang_al(4) = [0.0_rp, 0.0_rp, 1.0_rp, 1.0_rp] + real(rp), parameter :: pscale_wang_al(4) = [0.0_rp, 0.0_rp, 1.0_rp, 1.0_rp] + real(rp), parameter :: dscale_wang_al(4) = [0.0_rp, 0.0_rp, 1.0_rp, 1.0_rp] + real(rp), parameter :: uscale_wang_al(4) = [0.0_rp, 0.0_rp, 1.0_rp, 1.0_rp] + + real(rp), parameter :: mscale_wang_dl(4) = [1.0_rp, 1.0_rp, 1.0_rp, 1.0_rp] + real(rp), parameter :: pscale_wang_dl(4) = [1.0_rp, 1.0_rp, 1.0_rp, 1.0_rp] + real(rp), parameter :: dscale_wang_dl(4) = [1.0_rp, 1.0_rp, 1.0_rp, 1.0_rp] + real(rp), parameter :: uscale_wang_dl(4) = [1.0_rp, 1.0_rp, 1.0_rp, 1.0_rp] + + real(rp), parameter :: mscale_amoeba(4) = [0.0_rp, 0.0_rp, 0.4_rp, 0.8_rp] + real(rp), parameter :: pscale_amoeba(4) = [0.0_rp, 0.0_rp, 1.0_rp, 1.0_rp] + real(rp), parameter :: dscale_amoeba(4) = [0.0_rp, 1.0_rp, 1.0_rp, 1.0_rp] + real(rp), parameter :: uscale_amoeba(4) = [1.0_rp, 1.0_rp, 1.0_rp, 1.0_rp] + real(rp), parameter :: pscale_intra_amoeba(4) = & + [0.0_rp, 0.0_rp, 0.5_rp, 1.0_rp] + + + real(rp), parameter :: thole_scale_wang_al = 2.5874_rp + !! Default Thole scaling factor used in Wang-AL force field + real(rp), parameter :: thole_scale_wang_dl = 2.0580_rp + !! Default Thole scaling factor used in Wang-DL force field + + ! Code constants + real(rp), parameter :: eps_rp = epsilon(0.0_rp) * 100 + !! Threshold used to compare REALS for queality + integer(ip), parameter :: ommp_str_char_max = OMMP_STR_CHAR_MAX + + ! Flag handler + integer(ip), parameter :: ommp_ff_amoeba = OMMP_FF_AMOEBA + !! Amoeba force field id + integer(ip), parameter :: ommp_ff_wang_al = OMMP_FF_WANG_AL + !! Wang AL force field id + integer(ip), parameter :: ommp_ff_wang_dl = OMMP_FF_WANG_DL + !! Wang DL force field id + integer(ip), parameter :: ommp_ff_amber = OMMP_FF_AMBER + !! Amber-like force field + integer(ip), parameter :: ommp_ff_unknown = OMMP_FF_UNKNOWN + !! Unknown force field + + integer(ip), parameter :: ommp_solver_cg = OMMP_SOLVER_CG + !! Conjugate gradients solver id + integer(ip), parameter :: ommp_solver_diis = OMMP_SOLVER_DIIS + !! DIIS solver id + integer(ip), parameter :: ommp_solver_inversion = OMMP_SOLVER_INVERSION + !! Matrix inversion solver id + integer(ip), parameter :: ommp_solver_default = OMMP_SOLVER_DEFAULT + !! Default value for solver + integer(ip), parameter :: ommp_solver_none = OMMP_SOLVER_NONE + !! Placeholder equivalent to not passing the argument, mainly for C interfaces + + integer(ip), parameter :: ommp_matv_incore = OMMP_MATV_INCORE + !! Build matrix in memory to perform vector matrix multiplication + !! in iterative solvers (uses dgemv with [[\mathcal O(2)]] memory usage + integer(ip), parameter :: ommp_matv_direct = OMMP_MATV_DIRECT + !! Vector matrix multiplication in iterative solvers are done in a direct + !! fashion + integer(ip), parameter :: ommp_matv_default = OMMP_MATV_DEFAULT + !! Default value for matrix vector multiplication + integer(ip), parameter :: ommp_matv_none = OMMP_MATV_NONE + !! Placeholder equivalent to not passing the argument, mainly for C interfaces + + integer(ip), parameter :: ommp_verbose_debug = OMMP_VERBOSE_DEBUG + !! Maximum verbosity level allowed + integer(ip), parameter :: ommp_verbose_high = OMMP_VERBOSE_HIGH + !! High level of verbosity + integer(ip), parameter :: ommp_verbose_low = OMMP_VERBOSE_LOW + !! Normal verbosity level + integer(ip), parameter :: ommp_verbose_none = OMMP_VERBOSE_NONE + !! All output should be suppressed at this level + integer(ip), parameter :: ommp_verbose_default = OMMP_VERBOSE_DEFAULT + !! All output should be suppressed at this level + + integer(ip), parameter :: AMOEBA_ROT_NONE = 0_ip + integer(ip), parameter :: AMOEBA_ROT_Z_THEN_X = 1_ip + integer(ip), parameter :: AMOEBA_ROT_BISECTOR = 2_ip + integer(ip), parameter :: AMOEBA_ROT_Z_ONLY = 3_ip + integer(ip), parameter :: AMOEBA_ROT_Z_BISECT = 4_ip + integer(ip), parameter :: AMOEBA_ROT_3_FOLD = 5_ip + + integer(ip), parameter :: OMMP_VDWTYPE_LJ = 0 + integer(ip), parameter :: OMMP_VDWTYPE_BUF714 = 2 + integer(ip), parameter :: OMMP_RADRULE_ARITHMETIC = 1 + integer(ip), parameter :: OMMP_RADRULE_CUBIC = 2 + integer(ip), parameter :: OMMP_RADTYPE_RMIN = 1 + integer(ip), parameter :: OMMP_EPSRULE_GEOMETRIC = 0 + integer(ip), parameter :: OMMP_EPSRULE_HHG = 1 + + integer(ip), parameter :: ommp_default_nl_sub = OMMP_DEFAULT_NL_SUB + real(rp), parameter :: ommp_default_nl_cutoff = OMMP_DEFAULT_NL_CUTOFF + + integer(ip), parameter :: default_link_atom_n_eel_remove = OMMP_DEFAULT_LA_N_EEL_REMOVE + real(rp), parameter :: default_link_atom_dist = OMMP_DEFAULT_LA_DIST + +end module mod_constants diff --git a/src/mod_constants.f90 b/src/mod_constants.f90 deleted file mode 100644 index 3ce2841..0000000 --- a/src/mod_constants.f90 +++ /dev/null @@ -1,131 +0,0 @@ -#include - -module mod_constants - !! Contains several constants that are usefoul around the code. There are - !! physical constants (there should be no duplicate around!), default - !! force-field parameters that are used when no other input is specified, - !! and internal constants that are used as easy-to-remember names of code - !! constants. - use iso_c_binding - - implicit none - -#ifdef USE_I8 - integer(kind=c_int64_t), parameter :: ip = c_int64_t -#else - integer(kind=c_int32_t), parameter :: ip = c_int32_t -#endif - !! Required precision for integer type - integer(ip), parameter :: rp = c_double !! Required precision for real type - integer(ip), parameter :: lp = c_bool - - ! Physical constants - real(rp), parameter :: angstrom2au = OMMP_FORT_ANG2AU - !! Conversion factor from \(\AA\) to A.U. - real(rp), parameter :: kcalmol2au = OMMP_FORT_KCALMOL2AU - !! Conversion factor from kcal mol\(^{-1}\) to A.U. - real(rp), parameter :: au2kcalmol = OMMP_FORT_AU2KCALMOL - !! Conversion factor from A.U. to kcal mol\(^{-1}\) - real(rp), parameter :: pi = 4.0 * atan(1.0) - !! Value of \(\pi\) - real(rp), parameter :: deg2rad = pi / 180.0 - !! Conversion from arc degree to radians - real(rp), parameter :: rad2deg = 180.0 / pi - !! Conversion from radians to arc degree - - ! Force Field parameters - real(rp), parameter :: mscale_wang_al(4) = [0.0_rp, 0.0_rp, 1.0_rp, 1.0_rp] - real(rp), parameter :: pscale_wang_al(4) = [0.0_rp, 0.0_rp, 1.0_rp, 1.0_rp] - real(rp), parameter :: dscale_wang_al(4) = [0.0_rp, 0.0_rp, 1.0_rp, 1.0_rp] - real(rp), parameter :: uscale_wang_al(4) = [0.0_rp, 0.0_rp, 1.0_rp, 1.0_rp] - - real(rp), parameter :: mscale_wang_dl(4) = [1.0_rp, 1.0_rp, 1.0_rp, 1.0_rp] - real(rp), parameter :: pscale_wang_dl(4) = [1.0_rp, 1.0_rp, 1.0_rp, 1.0_rp] - real(rp), parameter :: dscale_wang_dl(4) = [1.0_rp, 1.0_rp, 1.0_rp, 1.0_rp] - real(rp), parameter :: uscale_wang_dl(4) = [1.0_rp, 1.0_rp, 1.0_rp, 1.0_rp] - - real(rp), parameter :: mscale_amoeba(4) = [0.0_rp, 0.0_rp, 0.4_rp, 0.8_rp] - real(rp), parameter :: pscale_amoeba(4) = [0.0_rp, 0.0_rp, 1.0_rp, 1.0_rp] - real(rp), parameter :: dscale_amoeba(4) = [0.0_rp, 1.0_rp, 1.0_rp, 1.0_rp] - real(rp), parameter :: uscale_amoeba(4) = [1.0_rp, 1.0_rp, 1.0_rp, 1.0_rp] - real(rp), parameter :: pscale_intra_amoeba(4) = & - [0.0_rp, 0.0_rp, 0.5_rp, 1.0_rp] - - - real(rp), parameter :: thole_scale_wang_al = 2.5874_rp - !! Default Thole scaling factor used in Wang-AL force field - real(rp), parameter :: thole_scale_wang_dl = 2.0580_rp - !! Default Thole scaling factor used in Wang-DL force field - - ! Code constants - real(rp), parameter :: eps_rp = epsilon(0.0_rp) * 100 - !! Threshold used to compare REALS for queality - integer(ip), parameter :: ommp_str_char_max = OMMP_STR_CHAR_MAX - - ! Flag handler - integer(ip), parameter :: ommp_ff_amoeba = OMMP_FF_AMOEBA - !! Amoeba force field id - integer(ip), parameter :: ommp_ff_wang_al = OMMP_FF_WANG_AL - !! Wang AL force field id - integer(ip), parameter :: ommp_ff_wang_dl = OMMP_FF_WANG_DL - !! Wang DL force field id - integer(ip), parameter :: ommp_ff_amber = OMMP_FF_AMBER - !! Amber-like force field - integer(ip), parameter :: ommp_ff_unknown = OMMP_FF_UNKNOWN - !! Unknown force field - - integer(ip), parameter :: ommp_solver_cg = OMMP_SOLVER_CG - !! Conjugate gradients solver id - integer(ip), parameter :: ommp_solver_diis = OMMP_SOLVER_DIIS - !! DIIS solver id - integer(ip), parameter :: ommp_solver_inversion = OMMP_SOLVER_INVERSION - !! Matrix inversion solver id - integer(ip), parameter :: ommp_solver_default = OMMP_SOLVER_DEFAULT - !! Default value for solver - integer(ip), parameter :: ommp_solver_none = OMMP_SOLVER_NONE - !! Placeholder equivalent to not passing the argument, mainly for C interfaces - - integer(ip), parameter :: ommp_matv_incore = OMMP_MATV_INCORE - !! Build matrix in memory to perform vector matrix multiplication - !! in iterative solvers (uses dgemv with [[\mathcal O(2)]] memory usage - integer(ip), parameter :: ommp_matv_direct = OMMP_MATV_DIRECT - !! Vector matrix multiplication in iterative solvers are done in a direct - !! fashion - integer(ip), parameter :: ommp_matv_default = OMMP_MATV_DEFAULT - !! Default value for matrix vector multiplication - integer(ip), parameter :: ommp_matv_none = OMMP_MATV_NONE - !! Placeholder equivalent to not passing the argument, mainly for C interfaces - - integer(ip), parameter :: ommp_verbose_debug = OMMP_VERBOSE_DEBUG - !! Maximum verbosity level allowed - integer(ip), parameter :: ommp_verbose_high = OMMP_VERBOSE_HIGH - !! High level of verbosity - integer(ip), parameter :: ommp_verbose_low = OMMP_VERBOSE_LOW - !! Normal verbosity level - integer(ip), parameter :: ommp_verbose_none = OMMP_VERBOSE_NONE - !! All output should be suppressed at this level - integer(ip), parameter :: ommp_verbose_default = OMMP_VERBOSE_DEFAULT - !! All output should be suppressed at this level - - integer(ip), parameter :: AMOEBA_ROT_NONE = 0_ip - integer(ip), parameter :: AMOEBA_ROT_Z_THEN_X = 1_ip - integer(ip), parameter :: AMOEBA_ROT_BISECTOR = 2_ip - integer(ip), parameter :: AMOEBA_ROT_Z_ONLY = 3_ip - integer(ip), parameter :: AMOEBA_ROT_Z_BISECT = 4_ip - integer(ip), parameter :: AMOEBA_ROT_3_FOLD = 5_ip - - integer(ip), parameter :: OMMP_VDWTYPE_LJ = 0 - integer(ip), parameter :: OMMP_VDWTYPE_BUF714 = 2 - integer(ip), parameter :: OMMP_RADRULE_ARITHMETIC = 1 - integer(ip), parameter :: OMMP_RADRULE_CUBIC = 2 - integer(ip), parameter :: OMMP_RADTYPE_RMIN = 1 - integer(ip), parameter :: OMMP_EPSRULE_GEOMETRIC = 0 - integer(ip), parameter :: OMMP_EPSRULE_HHG = 1 - - integer(ip), parameter :: ommp_default_nl_sub = OMMP_DEFAULT_NL_SUB - real(rp), parameter :: ommp_default_nl_cutoff = OMMP_DEFAULT_NL_CUTOFF - - integer(ip), parameter :: default_link_atom_n_eel_remove = OMMP_DEFAULT_LA_N_EEL_REMOVE - real(rp), parameter :: default_link_atom_dist = OMMP_DEFAULT_LA_DIST - -end module mod_constants diff --git a/src/mod_electrostatics.F90 b/src/mod_electrostatics.F90 new file mode 100644 index 0000000..c272c38 --- /dev/null +++ b/src/mod_electrostatics.F90 @@ -0,0 +1,2472 @@ +#include "f_cart_components.h" +module mod_electrostatics + use mod_io, only: fatal_error, ommp_message + use mod_constants, only: OMMP_VERBOSE_DEBUG + use mod_profiling, only: time_push, time_pull + use mod_memory, only: ip, rp, lp + use mod_adjacency_mat, only: yale_sparse + use mod_topology, only: ommp_topology_type + + !! TODO Check the signs in electrostatic elemental functions + !! TODO [OPT] Use Laplace equation to simplify the calculations: + !! TODO 1. Egrd(_zz_) = -(Egrd(_xx_) + Egrd(_yy_)) + !! TODO 2. EHes(_zzz_) = -(EHes(_xxz_) + EHes(_yyz_)) + !! TODO 3. EHes(_zzx_) = -(EHes(_xxx_) + EHes(_yyx_)) + !! TODO 4. EHes(_zzy_) = -(EHes(_xxy_) + EHes(_yyy_)) + !! TODO [OPT] Fundamental electrostatic functions should be pure/elemental + !! TODO [BUG] Handling of flags gg + implicit none + private + + type ommp_electrostatics_type + integer(ip) :: def_solver + !! Solver to be used by default for this eel object. + integer(ip) :: def_matv + !! Matrix-vector method to be used by default for this eel object. + + type(ommp_topology_type), pointer :: top + !! Data structure containing all the topological informations + integer(ip) :: pol_atoms + !! number of polarizable atoms + logical(lp) :: amoeba + !! True if AMOEBA FF is used + integer(ip) :: ld_cart, ld_cder + !! size of the cartesian multipolar distribution (i.e., (l+1)*(l+2)*(l+3)/6) + !! this is 1 for AMBER (charges only), 10 for AMOEBA (up to quadrupoles). + !! this is also the size of the array that contains the electrostatic properties + !! of the sources at the sources. ld_cder is the leading size of the derivative of + !! such a distribution, which is 3 for AMBER and 19 for AMOEBA. + integer(ip) :: n_ipd + !! number of induced point dipoles distributions + !! this is 1 for AMBER and 2 for AMOEBA + + real(rp) :: mscale(4) + !! factors for charge-charge (or multipole-multipole) interactions + + real(rp) :: pscale(4) + !! factors for chrage-ipd (or multipole-ipd) interactions. + !! in AMOEBA, this is used to define the polarization field, i.e., the right-hand + !! side to the polarization equations, and depends on the connectivity. + + real(rp) :: pscale_intra(4) + !! Only used for AMOEBA, same as pscale but for atoms that belong to the + !! same polarization group + + real(rp) :: dscale(4) + !! factors for multipoles-ipd interactions used to compute the direct field, + !! which is used to define the polarization energy. these factors depend on + !! the polarization group "connectivity" (AMOEBA only) + + real(rp) :: uscale(4) + !! factor for ipd-ipd interactions. these depend on the connectivity (AMBER) + !! or on the polarization group " connectivity (AMOEBA) + + ! allocatable arrays which describe the polarizable system + + real(rp), allocatable :: thole(:) + !! array to store the thole factors for computing damping functions + + real(rp) :: thole_scale + !! Scale factor for thole damping (only used by non-AMOEBA FF); all + !! the element of thole(:) are multiplied by thole_scale ** 0.5 + + real(rp), allocatable :: cpol(:,:) + !! Coordinates of polarizable atoms (3:pol_atoms) + + real(rp), allocatable :: q(:,:) + !! Mutlipolar distribution (ld_cart:mm_atoms) + !! For AMOEBA this is the rotated distribution. + !! The order for the stored multipoles is + !! q, px, py, pz, Qxx, Qxy, Qyy, Qxz, Qyx, Qzz. + + real(rp), allocatable :: q0(:,:) + !! Unrotated utlipolar distribution (ld_cart:mm_atoms) + !! (AMOEBA only) + + real(rp), allocatable :: pol(:) + !! Polarizabilities for each polarizable atom + + integer(ip), allocatable :: mm_polar(:) + !! for each mm atom: 0 if is not polarizable, index in + !! polarizable atom list otherwise + + integer(ip), allocatable :: polar_mm(:) + !! positions of a polarizable atom in the mm atoms list + + integer(ip), allocatable :: C_polar_mm(:) + !! [[polar_mm]] with 0-based C-indexing, only allocated at need. + + integer(ip), allocatable :: mmat_polgrp(:) + !! Polarizability group index for each MM site + + type(yale_sparse) :: polgrp_mmat + !! For each polarization group index, list all the MM atoms included. + !! It basically is a sparse boolean matrix of dimension + !! N_polgroups x N_mmatoms + + type(yale_sparse), allocatable :: pg_conn(:) + !! Adjacency and connectivity matytrices between polarizability groups. + !! Two groups are said to be adjacent if they are connected by a chemical + !! bond. The 1st element is the identity matrix for code simplicity. + + ! parameters for the definition of the rotation matrices for the multipoles: + integer(ip), allocatable :: mol_frame(:) + !! definition of the molecular frame + !! convention: 0 ... do not rotate + !! 1 ... z-then-x + !! 2 ... bisector + !! 3 ... z-only + !! 4 ... z-bisector + !! 5 ... 3-fold + + integer(ip), allocatable :: ix(:), iy(:), iz(:) + !! neighboring atoms used to define the axes of the molecular frame + + !- Intermediate data allocate here -! + logical(lp) :: M2M_done = .false. + !! flag to set when M2M electrostatic quantities are computed. + logical(lp) :: M2Mgg_done = .false. + !! flag to set when M2M electrostatic quantities for geometrical + !! gradients are computed. + real(rp), allocatable :: V_M2M(:) + !! potential of MM permanent multipoles at MM sites; + real(rp), allocatable :: E_M2M(:,:) + !! electric_field of MM permanent multipoles at MM sites; + real(rp), allocatable :: Egrd_M2M(:,:) + !! electric_field gradient of MM permanent multipoles at MM sites; + real(rp), allocatable :: EHes_M2M(:,:) + !! electric field Hessian of MM permanent multipoles at MM sites; + + logical(lp) :: M2D_done = .false. + !! Flag to set when M2D electrostatics have been computed. + logical(lp) :: M2Dgg_done = .false. + !! Flag to set when M2D electrostatics for geometrical gradients + !! have been computed. + real(rp), allocatable :: V_M2D(:,:) + ! electrostatic potential of MM permanent multipoles at POL sites; unused. + real(rp), allocatable :: E_M2D(:,:,:) ! TODO the third dimension is used? + !! electric field of MM permanent multipoles at POL sites; + real(rp), allocatable :: Egrd_M2D(:,:,:) + !! electric field of MM permanent multipoles at POL sites; + real(rp), allocatable :: EHes_M2D(:,:,:) + ! electric field Hessian of MM permanent multipoles at POL sites; unused. + + logical(lp) :: D2Mgg_done = .false. + real(rp), allocatable :: V_D2M(:) + real(rp), allocatable :: E_D2M(:,:) + real(rp), allocatable :: Egrd_D2M(:,:) + real(rp), allocatable :: EHes_D2M(:,:) + + logical(lp) :: D2Dgg_done = .false. + real(rp), allocatable :: V_D2D(:,:) + real(rp), allocatable :: E_D2D(:,:,:) + real(rp), allocatable :: Egrd_D2D(:,:,:) + real(rp), allocatable :: EHes_D2D(:,:,:) + + logical(lp) :: ipd_done = .false. + !! Flag to set when IPD have been computed. + logical(lp) :: ipd_use_guess = .false. + !! Flag to set when current value of IPD can be + !! used as guess for next solution of LS. + real(rp), allocatable :: ipd(:,:,:) + !! induced point dipoles (3:pol_atoms:ipd) + + real(rp), allocatable :: TMat(:,:) + !! Interaction tensor, only allocated for the methods that explicitly + !! requires it. + + logical(lp) :: screening_list_done = .false. + !! Flag to check if screening list have already been prepared + type(yale_sparse), allocatable :: list_S_S, list_P_P, list_S_P_P, list_S_P_D + !! Sparse matrix containg the scale factors for the scaled elements + !! of electrostatic interactions (all the element that are not + !! present in the sparse matrix have a scaling factor 1.0). + logical(lp), dimension(:), allocatable :: todo_S_S, todo_P_P, todo_S_P_P, todo_S_P_D + !! Logical array of the same dimension of column-index vector; true if + !! the scaling factor is zero, false otherwise + real(rp), dimension(:), allocatable :: scalef_S_S, scalef_P_P, & + scalef_S_P_P, scalef_S_P_D + !! Array of the same dimension of column-index vector; contains the + !! value of the scaling factors different from 1.0 + end type ommp_electrostatics_type + + public :: ommp_electrostatics_type + public :: electrostatics_init, electrostatics_terminate + public :: set_def_solver, set_def_matv + public :: thole_init, remove_null_pol, set_screening_parameters + public :: screening_rules, make_screening_lists + public :: damped_coulomb_kernel, field_extD2D + public :: energy_MM_MM, energy_MM_pol + public :: prepare_fixedelec, prepare_polelec + public :: q_elec_prop, coulomb_kernel + public :: potential_M2E, potential_D2E + public :: field_M2E, field_D2E + +contains + + subroutine electrostatics_init(eel_obj, amoeba, pol_atoms, top_obj) + use mod_memory, only: mallocate + use mod_constants, only: OMMP_MATV_DEFAULT, OMMP_SOLVER_DEFAULT + + implicit none + + logical(lp), intent(in) :: amoeba + integer(ip), intent(in) :: pol_atoms + type(ommp_topology_type), intent(in), target :: top_obj + type(ommp_electrostatics_type), intent(inout) :: eel_obj + + integer(ip) :: mm_atoms + + mm_atoms = top_obj%mm_atoms + eel_obj%amoeba = amoeba + eel_obj%pol_atoms = pol_atoms + eel_obj%top => top_obj + eel_obj%def_solver = OMMP_SOLVER_DEFAULT + eel_obj%def_matv = OMMP_MATV_DEFAULT + + if(amoeba) then + eel_obj%ld_cart = 10_ip + eel_obj%ld_cder = 19_ip + eel_obj%n_ipd = 2_ip + else + eel_obj%ld_cart = 1_ip + eel_obj%ld_cder = 3_ip + eel_obj%n_ipd = 1_ip + endif + + call mallocate('electrostatics_init [q]', eel_obj%ld_cart, & + mm_atoms, eel_obj%q) + call mallocate('electrostatics_init [pol]', eel_obj%pol_atoms, & + eel_obj%pol) + call mallocate('electrostatics_init [cpol]', 3_ip, eel_obj%pol_atoms, & + eel_obj%cpol) + call mallocate('electrostatics_init [polar_mm]', eel_obj%pol_atoms, & + eel_obj%polar_mm) + call mallocate('electrostatics_init [mm_polar]', mm_atoms, & + eel_obj%mm_polar) + call mallocate('electrostatics_init [thole]', mm_atoms, & + eel_obj%thole) + + call mallocate('electrostatics_init [idp]', 3_ip, eel_obj%pol_atoms, & + eel_obj%n_ipd, eel_obj%ipd) + eel_obj%ipd_done = .false. + eel_obj%ipd = 0.0_rp + + if (eel_obj%amoeba) then + ! Extra quantities that should be allocated only + ! for AMOEBA + call mallocate('electrostatics_init [q0]', eel_obj%ld_cart, & + mm_atoms, eel_obj%q0) + + call mallocate('electrostatics_init [mmat_polgrp]', & + mm_atoms, eel_obj%mmat_polgrp) + + call mallocate('electrostatics_init [mol_frame]', & + mm_atoms, eel_obj%mol_frame) + call mallocate('electrostatics_init [ix]', mm_atoms, eel_obj%ix) + call mallocate('electrostatics_init [iy]', mm_atoms, eel_obj%iy) + call mallocate('electrostatics_init [iz]', mm_atoms, eel_obj%iz) + end if + + end subroutine electrostatics_init + + subroutine electrostatics_terminate(eel_obj) + use mod_memory, only: mfree + use mod_adjacency_mat, only: matfree + + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel_obj + integer(ip) :: i + + call mfree('electrostatics_terminate [q]', eel_obj%q) + call mfree('electrostatics_terminate [pol]', eel_obj%pol) + call mfree('electrostatics_terminate [cpol]', eel_obj%cpol) + call mfree('electrostatics_terminate [polar_mm]', eel_obj%polar_mm) + call mfree('electrostatics_terminate [mm_polar]', eel_obj%mm_polar) + call mfree('electrostatics_terminate [thole]', eel_obj%thole) + call mfree('electrostatics_terminate [idp]', eel_obj%ipd) + + if (eel_obj%amoeba) then + call mfree('electrostatics_terminate [q0]', eel_obj%q0) + call mfree('electrostatics_terminate [mmat_polgrp]', & + eel_obj%mmat_polgrp) + if(allocated(eel_obj%pg_conn)) then + do i=1, size(eel_obj%pg_conn) + call matfree(eel_obj%pg_conn(i)) + end do + deallocate(eel_obj%pg_conn) + end if + + call matfree(eel_obj%polgrp_mmat) + call mfree('electrostatics_terminate [mol_frame]', & + eel_obj%mol_frame) + call mfree('electrostatics_terminate [ix]', eel_obj%ix) + call mfree('electrostatics_terminate [iy]', eel_obj%iy) + call mfree('electrostatics_terminate [iz]', eel_obj%iz) + end if + + call mfree('electrostatics_terminate [E_M2D]', eel_obj%E_M2D) + call mfree('electrostatics_terminate [V_M2M]', eel_obj%V_M2M) + call mfree('electrostatics_terminate [E_M2M]', eel_obj%E_M2M) + call mfree('electrostatics_terminate [Egrd_M2M]', eel_obj%Egrd_M2M) + + if(allocated(eel_obj%todo_S_S)) deallocate(eel_obj%todo_S_S) + if(allocated(eel_obj%todo_P_P)) deallocate(eel_obj%todo_P_P) + call mfree('electrostatics_terminate [scalef_S_S]', eel_obj%scalef_S_S) + call mfree('electrostatics_terminate [scalef_P_P]', eel_obj%scalef_P_P) + if(allocated(eel_obj%list_S_S)) then + call matfree(eel_obj%list_S_S) + deallocate(eel_obj%list_S_S) + end if + if(allocated(eel_obj%list_P_P)) then + call matfree(eel_obj%list_P_P) + deallocate(eel_obj%list_P_P) + end if + + end subroutine electrostatics_terminate + + subroutine set_def_solver(eel_obj, solver) + use mod_constants, only: OMMP_SOLVER_CG, OMMP_SOLVER_INVERSION, OMMP_SOLVER_DIIS + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel_obj + integer(ip), intent(in) :: solver + + if(solver /= OMMP_SOLVER_CG .and. & + solver /= OMMP_SOLVER_INVERSION .and. & + solver /= OMMP_SOLVER_DIIS) & + call fatal_error("Unrecognized setting for default solver method") + eel_obj%def_solver = solver + end subroutine + + subroutine set_def_matv(eel_obj, matv) + use mod_constants, only: OMMP_MATV_INCORE, OMMP_MATV_DIRECT + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel_obj + integer(ip), intent(in) :: matv + + if(matv /= OMMP_MATV_INCORE .and. & + matv /= OMMP_MATV_DIRECT) & + call fatal_error("Unrecognized setting for default matrix-vector method") + eel_obj%def_matv = matv + end subroutine + + subroutine set_screening_parameters(eel_obj, m, p, d, u, i) + !! Subroutine to initialize the screening parameters + + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel_obj + real(rp), intent(in) :: m(4), p(4), d(4), u(4) + real(rp), optional, intent(in) :: i(4) + + eel_obj%mscale = m + eel_obj%pscale = p + eel_obj%dscale = d + eel_obj%uscale = u + + if(present(i)) then + if(eel_obj%amoeba) then + eel_obj%pscale_intra = i + else + call fatal_error("Scale factors for atoms of the same group & + &cannot be set outside AMOEBA FF") + end if + else + if(eel_obj%amoeba) & + call fatal_error("Scale factors for atoms of the same group & + &should be defined in AMOEBA FF") + end if + + end subroutine set_screening_parameters + + subroutine remove_null_pol(eel) + !! Check which polarizabilities are close enough to 0 to be + !! just excluded from the calculation, and remove them. + + use mod_constants, only: OMMP_STR_CHAR_MAX, OMMP_VERBOSE_LOW, eps_rp + use mod_memory, only: mallocate, mfree + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel + integer(ip), allocatable :: idx(:), polar_mm(:) + integer(ip) :: i, nidx + real(rp), allocatable :: tmp(:) + character(len=OMMP_STR_CHAR_MAX) :: msg + + if(eel%pol_atoms > 0 .and. allocated(eel%pol)) then + call mallocate('remove_null_pol [idx]', eel%pol_atoms, idx) + nidx = 0 + do i=1, eel%pol_atoms + if(abs(eel%pol(i)) > eps_rp) then + nidx = nidx + 1 + idx(nidx) = i + end if + end do + + if(nidx < eel%pol_atoms) then + write(msg, '(A,I0,A,I0)') "Removing ", eel%pol_atoms - nidx, & + " polarizabilities out of ", eel%pol_atoms + call ommp_message(msg, OMMP_VERBOSE_LOW) + call mallocate('remove_null_pol [tmp]', eel%pol_atoms, tmp) + ! Polarizabilities + tmp = eel%pol + call mfree('remove_null_pol [eel%pol]', eel%pol) + call mallocate('remove_null_pol [eel%pol]', nidx, eel%pol) + do i=1, nidx + eel%pol(i) = tmp(idx(i)) + end do + call mfree('remove_null_pol [tmp]', tmp) + + call mallocate('remove_null_pol [polar_mm]', eel%pol_atoms, polar_mm) + polar_mm = eel%polar_mm + call mfree('remove_null_pol [eel%polar_mm]', eel%polar_mm) + call mallocate('remove_null_pol [eel%polar_mm]', nidx, eel%polar_mm) + call mfree('remove_null_pol [eel%cpol]', eel%cpol) + call mallocate('remove_null_pol [eel%cpol]', 3, nidx, eel%cpol) + eel%mm_polar = 0 + do i=1, nidx + eel%polar_mm(i) = polar_mm(idx(i)) + eel%mm_polar(eel%polar_mm(i)) = i + eel%cpol(:,i) = eel%top%cmm(:,eel%polar_mm(i)) + end do + + call mfree('remove_null_pol [polar_mm]', polar_mm) + + eel%pol_atoms = nidx + call mfree('remove_null_pol [eel%ipd]', eel%ipd) + call mallocate('electrostatics_init [idp]', 3_ip, eel%pol_atoms, & + eel%n_ipd, eel%ipd) + eel%ipd_done = .false. + eel%ipd_use_guess = .false. + eel%ipd = 0.0_rp + + call ommp_message("Removing null polarizable sites done", OMMP_VERBOSE_LOW) + end if + + call mfree('remove_null_pol [idx]', idx) + end if + + end subroutine + + subroutine make_screening_lists(eel) + use mod_memory, only: mallocate, mfree + use mod_adjacency_mat, only: compress_list, compress_data + use mod_constants, only: eps_rp + + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel + + integer(ip) :: i, ineigh, ij, j, ns, ns_guess, n, npol, & + ipp, jp, ns_guess_grp, pg_i, igrp, grp, ib, ie + logical :: to_do, to_scale + real(rp) :: scalf + integer(ip), allocatable :: itmp(:,:), ntmp(:) + real(rp), allocatable :: rtmp(:,:) + + if(eel%screening_list_done) return + + n = eel%top%mm_atoms + npol = eel%pol_atoms + + ! First estimate the maximum number of elements to scale + ns_guess = 0 + !$omp parallel do default(shared) private(ns, ineigh, i) + do i=1, n + ns = 0 + do ineigh=1, 4 + ns = ns + eel%top%conn(ineigh)%ri(i+1) - eel%top%conn(ineigh)%ri(i) + end do + !$omp atomic + ns_guess = max(ns, ns_guess) + end do + + if(eel%amoeba) then + ! If amoeba is used, some scaling (D-field) are performed using + ! polarization group, so a second guess should be done and the + ! maximum is used in memory allocation. + ns_guess_grp = 0 + + !$omp parallel do default(shared) & + !$omp private(i, pg_i, ineigh, igrp, grp, ns) + do i=1, n + pg_i = eel%mmat_polgrp(i) + ns = 0 + do ineigh=1, 4 + do igrp=eel%pg_conn(ineigh)%ri(pg_i), & + eel%pg_conn(ineigh)%ri(pg_i+1)-1 + + grp = eel%pg_conn(ineigh)%ci(igrp) + ns = ns + eel%polgrp_mmat%ri(grp+1)-eel%polgrp_mmat%ri(grp) + end do + end do + !$omp atomic + ns_guess_grp = max(ns, ns_guess_grp) + end do + + ns_guess = max(ns_guess_grp, ns_guess) + end if + + allocate(eel%list_S_S) + allocate(eel%list_P_P) + allocate(eel%list_S_P_P) + if(eel%amoeba) allocate(eel%list_S_P_D) + + !allocate(ltmp(ns_guess)) + call mallocate('make_screening_list [rtmp]', ns_guess, n, rtmp) + call mallocate('make_screening_list [itmp]', ns_guess, n, itmp) + call mallocate('make_screening_list [ntmp]', n, ntmp) + + + ! Build S S list + !$omp parallel do schedule(dynamic) default(shared) & + !$omp private(i,ineigh,ij,j, scalf) + do i=1, n + ntmp(i) = 0 + do ineigh=1, 4 + do ij=eel%top%conn(ineigh)%ri(i), eel%top%conn(ineigh)%ri(i+1)-1 + j = eel%top%conn(ineigh)%ci(ij) + scalf = screening_rules(eel, i, 'S', j, 'S', '-') + if(abs(scalf-1.0) > eps_rp) then + ntmp(i) = ntmp(i) + 1 + itmp(ntmp(i),i) = j + rtmp(ntmp(i),i) = scalf + end if + end do + end do + end do + + ! Compress the list + call compress_list(n, itmp, ntmp, eel%list_S_S) + call compress_data(eel%list_S_S, rtmp, eel%scalef_S_S) + call mallocate('make_screening_list [todo_S_S]', & + size(eel%scalef_S_S), eel%todo_S_S) + !$omp parallel do + do i=1, size(eel%scalef_S_S) + eel%todo_S_S(i) = (abs(eel%scalef_S_S(i)) > eps_rp) + end do + + ! Build P P list + ntmp = 0 + !$omp parallel do schedule(dynamic) default(shared) & + !$omp private(ipp,i,ineigh,ij,j,jp,scalf) + do ipp=1, npol + i = eel%polar_mm(ipp) + do ineigh=1, 4 + do ij=eel%top%conn(ineigh)%ri(i), eel%top%conn(ineigh)%ri(i+1)-1 + j = eel%top%conn(ineigh)%ci(ij) + jp = eel%mm_polar(j) + if(jp > 0) then + scalf = screening_rules(eel, ipp, 'P', jp, 'P', '-') + if(abs(scalf-1.0) > eps_rp) then + ntmp(ipp) = ntmp(ipp) + 1 + itmp(ntmp(ipp),ipp) = jp + rtmp(ntmp(ipp),ipp) = scalf + end if + end if + end do + end do + end do + + ! Compress the list + call compress_list(npol, itmp, ntmp(1:npol), eel%list_P_P) + call compress_data(eel%list_P_P, rtmp, eel%scalef_P_P) + call mallocate('make_screening_list [todo_P_P]', & + size(eel%scalef_P_P), eel%todo_P_P) + !$omp parallel do + do i=1, size(eel%scalef_P_P) + eel%todo_P_P(i) = (abs(eel%scalef_P_P(i)) > eps_rp) + end do + + ! Build S P lists + !$omp parallel do schedule(dynamic) default(shared) & + !$omp private(i,ineigh,ij,j,jp,scalf) + do i=1, n + ntmp(i) = 0 + do ineigh=1, 4 + do ij=eel%top%conn(ineigh)%ri(i), eel%top%conn(ineigh)%ri(i+1)-1 + j = eel%top%conn(ineigh)%ci(ij) + jp = eel%mm_polar(j) + if(jp > 0) then + ! Needed for either amoeba or amber + scalf = screening_rules(eel, i, 'S', jp, 'P', 'P') + if(abs(scalf-1.0) > eps_rp) then + ntmp(i) = ntmp(i) + 1 + itmp(ntmp(i),i) = jp + rtmp(ntmp(i),i) = scalf + end if + end if + end do + end do + end do + + ! Compress the list + call compress_list(n, itmp, ntmp, eel%list_S_P_P) + call compress_data(eel%list_S_P_P, rtmp, eel%scalef_S_P_P) + call mallocate('make_screening_list [todo_S_P_P]', & + size(eel%scalef_S_P_P), eel%todo_S_P_P) + !$omp parallel do + do i=1, size(eel%scalef_S_P_P) + eel%todo_S_P_P(i) = (abs(eel%scalef_S_P_P(i)) > eps_rp) + end do + + if(eel%amoeba) then + !$omp parallel do schedule(dynamic) default(shared) & + !$omp private(i,ineigh,ij,j,jp,scalf,pg_i,igrp,grp) + do i=1, n + ntmp(i) = 0 + pg_i = eel%mmat_polgrp(i) + + do ineigh=1, 4 + do igrp=eel%pg_conn(ineigh)%ri(pg_i), & + eel%pg_conn(ineigh)%ri(pg_i+1)-1 + + grp = eel%pg_conn(ineigh)%ci(igrp) + + do j=eel%polgrp_mmat%ri(grp), & + eel%polgrp_mmat%ri(grp+1)-1 + jp = eel%mm_polar(j) + if(jp > 0) then + scalf = screening_rules(eel, i, 'S', jp, 'P', 'D') + if(abs(scalf-1.0) > eps_rp) then + ntmp(i) = ntmp(i) + 1 + itmp(ntmp(i),i) = jp + rtmp(ntmp(i),i) = scalf + end if + end if + end do + end do + end do + end do + + ! Compress the list + call compress_list(n, itmp, ntmp, eel%list_S_P_D) + call compress_data(eel%list_S_P_D, rtmp, eel%scalef_S_P_D) + call mallocate('make_screening_list [todo_S_P_D]', & + size(eel%scalef_S_P_D), eel%todo_S_P_D) + !$omp parallel do + do i=1, size(eel%scalef_S_P_D) + eel%todo_S_P_D(i) = (abs(eel%scalef_S_P_D(i)) > eps_rp) + end do + end if + + eel%screening_list_done = .true. + + call mfree('make_screening_list [rtmp]', rtmp) + call mfree('make_screening_list [itmp]', itmp) + call mfree('make_screening_list [ntmp]', ntmp) + end subroutine + + subroutine thole_init(eel) + ! This routine compute the thole factors and stores + ! them in a vector. TODO add reference + ! TODO in AMOEBA should be read from FF + + use mod_constants, only: OMMP_VERBOSE_LOW, eps_rp + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel + + integer(ip) :: i, j + + eel%thole = 0.0_rp + + do i = 1, eel%pol_atoms + j = eel%polar_mm(i) + eel%thole(j) = eel%pol(i) ** (1.0_rp/6.0_rp) + end do + + if(.not. eel%amoeba) then + if(eel%thole_scale > eps_rp) then + eel%thole = eel%thole * sqrt(eel%thole_scale) + else + call fatal_error("Scale factor for Thole damping should be & + &greater than 0.0 when non-AMOEBA FF are used") + end if + else + if(eel%thole_scale > eps_rp) then + call ommp_message("Scale factor set for thole damping is & + &ignored because AMOEBA FF is used", OMMP_VERBOSE_LOW) + end if + end if + end subroutine thole_init + + subroutine energy_MM_MM(eel, ene) + !! This function computes the interaction energy of + !! static electric multipoles + use mod_memory, only: mallocate, mfree + + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel + !! Electrostatics data structure + real(rp), intent(inout) :: ene + !! Energy (results will be added) + real(rp) :: eMM + + integer(ip) :: i + + call prepare_fixedelec(eel) + eMM = 0.0 + + if(eel%amoeba) then + eMM = eMM + dot_product(eel%q(1,:), eel%V_M2M) + do i=1, 3 + eMM = eMM - dot_product(eel%q(i+1,:), eel%E_M2M(i,:)) + end do + + do i=1,6 + if(i == _xx_ .or. i == _yy_ .or. i == _zz_) then + ! diagonal elements + eMM = eMM + dot_product(eel%q(i+4,:), eel%Egrd_M2M(i,:)) + else + ! off-diagonal elements (are stored once, but + ! should be counted twice + eMM = eMM + 2.0 * dot_product(eel%q(i+4,:), eel%Egrd_M2M(i,:)) + end if + end do + else + eMM = eMM + dot_product(eel%q(1,:), eel%V_M2M) + end if + + ! Since potential is computed using all the sites each + ! interaction is counted twice + ene = ene + 0.5_rp * eMM + + end subroutine energy_MM_MM + + subroutine energy_MM_pol(eel, ene) + !! This function computes the interaction energy of + !! static electric multipoles + use mod_memory, only: mallocate, mfree + + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel + !! Electrostatics data structure + real(rp), intent(inout) :: ene + !! Energy (results will be added) + real(rp) :: eMM + + integer(ip) :: i + + call prepare_polelec(eel) + if(.not. eel%ipd_done) call fatal_error("IPD should be computed before& + & computing MM-Pol energy.") + eMM = 0.0 + + if(eel%amoeba) then + do i=1, 3 + eMM = eMM - dot_product(eel%ipd(i,:,_amoeba_D_), & + eel%E_M2D(i,:,_amoeba_P_)) + end do + else + do i=1, 3 + eMM = eMM - dot_product(eel%ipd(i,:,1), eel%E_M2D(i,:,1)) + end do + end if + + ene = ene + 0.5_rp * eMM + + end subroutine energy_MM_pol + + subroutine coulomb_kernel(dr, maxder, res) + !! This function compute the coulomb kernel for the distance vector dr and + !! its derivative up to the value required by maxder. + use mod_memory, only: ip, rp + use mod_io, only: fatal_error + use mod_constants, only: eps_rp + + implicit none + + real(rp), intent(in) :: dr(3) + !! Distance vector from atom i to atom j + integer(ip), intent(in) :: maxder + !! Maximum derivative to be computed + real(rp), intent(out), dimension(maxder+1) :: res + !! Results vector + + integer(ip) :: ii + real(rp) :: norm2_r, inv_norm_sq + + if(maxder < 0) then + ! Strange request, maybe a warning should be printed + return + end if + + norm2_r = sqrt(dr(1)*dr(1) + dr(2)*dr(2) + dr(3)*dr(3)) + if(norm2_r < eps_rp) then + call fatal_error("Requesting Coulomb kernel for two atoms & + &placed in the same point, this could be & + &an internal bug or a problem in your input & + &file, please check.") + end if + res(1) = 1.0_rp / norm2_r + inv_norm_sq = res(1) * res(1) + + do ii = 1, maxder + res(ii+1) = res(ii) * inv_norm_sq + end do + + end subroutine coulomb_kernel + + subroutine damped_coulomb_kernel(eel, i, j, maxder, res, dr) + !! This subroutine computes the damped coulomb kernel between two atoms. + !! Note that this only makes sense between two MM atoms, as it is only used + !! to compute the field that induces the point dipoles! + + use mod_memory, only: ip, rp + use mod_constants, only: eps_rp + + implicit none + + type(ommp_electrostatics_type), intent(in) :: eel + !! Electrostatics data structure + integer(ip), intent(in) :: i, j + !! Index of atoms (in MM atom list) for which the kernel should be + !! computed + integer(ip), intent(in) :: maxder + !! Maximum derivative to be computed + real(rp), intent(out), dimension(maxder+1) :: res + !! Results vector + real(rp), intent(out), dimension(3) :: dr + !! Distance vector between i and j + + real(rp) :: s, u, u3, u4, fexp, eexp + + s = eel%thole(i) * eel%thole(j) + + ! Compute undamped kernels + dr = eel%top%cmm(:,j) - eel%top%cmm(:,i) + call coulomb_kernel(dr, maxder, res) + + if(abs(s) < eps_rp) then + ! either thole(i) or thole(j) are zero, so the damped kernel + ! is just the same as the regular one. Job is done. + return + end if + + u = 1.0_rp / (res(1) * s) + u3 = u**3 + + if(eel%amoeba .and. u3 * 0.39_rp < 50.0_rp) then + ! 1.0 / (res(1) * s)**3 * 0.39_rp < 50_rp TODO Remove 0.39, this is a + ! FF constants, ask someone why this condition is here. + ! Here basically we multiply the standard interactions kernel for + ! dumping coefficients. The equations implemented here correspond to + ! eq. (5) of 10.1021/jp027815 + fexp = -0.39_rp * u3 + eexp = exp(fexp) + if(maxder >= 1) res(2) = res(2) * (1.0_rp - eexp) + if(maxder >= 2) res(3) = res(3) * (1.0_rp - (1.0_rp - fexp) * eexp) + if(maxder >= 3) res(4) = res(4) * & + (1.0_rp - (1.0_rp - fexp + 0.6_rp * fexp * fexp) * eexp) + if(maxder >= 4) res(5) = res(5) * & + (1.0_rp - (1.0_rp - fexp + 18.0_rp/35.0_rp * fexp * fexp - & + 9.0_rp/35.0_rp * fexp * fexp * fexp) * eexp) + if(maxder >= 5) then + call fatal_error("Damped Coulomb kernel (AMOEBA) only supports up to the 5th derivative") + end if + else if(.not. eel%amoeba .and. res(1) > 1_rp/s) then + ! TODO Again it is not clear to me why condition res(1) > 1_rp/s is here. + u4 = u3*u + if(maxder >= 1) res(2) = res(2) * (4.0_rp * u3 - 3.0_rp * u4) + if(maxder >= 2) res(3) = res(3) * u4 + if(maxder >= 3) res(4) = res(4) * 0.2_rp * u4 + if(maxder >= 4) then + call fatal_error("Damped Coulomb kernel (WANG) only supports up to the 4th derivative") + end if + end if + end subroutine damped_coulomb_kernel + + subroutine q_elec_prop(q, dr, kernel, & + do_V, V, do_E, E, do_grdE, grdE, do_HE, HE) + !! TODO + !! Computes the electric potential of a charge \(q\) at position + !! \(\mathbf{dr}\) from the charge itself. Pre-computed kernel should + !! be provided as input. + !! The result is added to \(V\). + !! $$ V_q = q \frac{f(r)}{||\mathbf{dr}||} $$ + + implicit none + + real(rp), intent(in) :: q + !! Charge + real(rp), intent(in) :: dr(3) + !! Distance vector + real(rp), intent(in) :: kernel(:) + !! Array of coulomb kernel (either damped or undamped) + logical, intent(in) :: do_V, do_E, do_grdE, do_HE + !! Flags to enable/disable calculation of different electrostatic + !! properties + real(rp), intent(inout) :: V, E(3), grdE(6), HE(10) + !! Electric potential + + if(do_V) then + V = V + kernel(1) * q + end if + + if(do_E) then + E = E + q * kernel(2) * dr + end if + + if(do_grdE) then + ! xx + grdE(1) = grdE(1) + q * 3.0_rp * kernel(3) * dr(1) * dr(1) - q * kernel(2) + ! xy + grdE(2) = grdE(2) + q * 3.0_rp * kernel(3) * dr(1) * dr(2) + ! yy + grdE(3) = grdE(3) + q * 3.0_rp * kernel(3) * dr(2) * dr(2) - q * kernel(2) + ! xz + grdE(4) = grdE(4) + q * 3.0_rp * kernel(3) * dr(1) * dr(3) + ! yz + grdE(5) = grdE(5) + q * 3.0_rp * kernel(3) * dr(2) * dr(3) + ! zz + grdE(6) = grdE(6) + q * 3.0_rp * kernel(3) * dr(3) * dr(3) - q * kernel(2) + end if + + if(do_HE) then + ! xxx + HE(1) = HE(1) + (15.0_rp * kernel(4) * dr(1) * dr(1) * dr(1) - & + 9.0_rp * kernel(3) * dr(1)) * q + ! xxy + HE(2) = HE(2) + (15.0_rp * kernel(4) * dr(1) * dr(1) * dr(2) - & + 3.0_rp * kernel(3) * dr(2)) * q + ! xxz + HE(3) = HE(3) + (15.0_rp * kernel(4) * dr(1) * dr(1) * dr(3) - & + 3.0_rp * kernel(3) * dr(3)) * q + ! xyy + HE(4) = HE(4) + (15.0_rp * kernel(4) * dr(2) * dr(2) * dr(1) - & + 3.0_rp * kernel(3) * dr(1)) * q + ! xyz + HE(5) = HE(5) + 15.0_rp * kernel(4) * dr(1) * dr(2) * dr(3) * q + + ! xzz + HE(6) = HE(6) + (15.0_rp * kernel(4) * dr(3) * dr(3) * dr(1) - & + 3.0_rp * kernel(3) * dr(1)) * q + ! yyy + HE(7) = HE(7) + (15.0_rp * kernel(4) * dr(2) * dr(2) * dr(2) - & + 9.0_rp * kernel(3) * dr(2)) * q + ! yyz + HE(8) = HE(8) + (15.0_rp * kernel(4) * dr(2) * dr(2) * dr(3) - & + 3.0_rp * kernel(3) * dr(3)) * q + ! yzz + HE(9) = HE(9) + (15.0_rp * kernel(4) * dr(3) * dr(3) * dr(2) - & + 3.0_rp * kernel(3) * dr(2)) * q + ! zzz + HE(10) = HE(10) + (15.0_rp * kernel(4) * dr(3) * dr(3) * dr(3) - & + 9.0_rp * kernel(3) * dr(3)) * q + end if + + end subroutine q_elec_prop + + subroutine mu_elec_prop(mu, dr, kernel, & + do_V, V, do_E, E, do_grdE, grdE, do_HE, HE) + + implicit none + + real(rp), intent(in) :: mu(3) + !! point dipole + real(rp), intent(in) :: dr(3) + !! Distance vector + real(rp), intent(in) :: kernel(:) + !! Array of coulomb kernel (either damped or undamped) + logical, intent(in) :: do_V, do_E, do_grdE, do_HE + !! Flags to enable/disable calculation of different electrostatic + !! properties + real(rp), intent(inout) :: V, E(3), grdE(6), HE(10) + !! Electric potential + + real(rp) :: mu_dot_dr + + mu_dot_dr = dot_product(mu, dr) + + if(do_V) then + V = V + mu_dot_dr * kernel(2) + end if + + if(do_E) then + E = E + 3.0_rp * mu_dot_dr * dr * kernel(3) - mu * kernel(2) + end if + + if(do_grdE) then + ! xx + grdE(1) = grdE(1) + mu_dot_dr * kernel(4) * 15.0 * dr(1) * dr(1) - & + (mu_dot_dr + 2.0 * mu(1) * dr(1)) * 3.0 * kernel(3) + ! xy + grdE(2) = grdE(2) + mu_dot_dr * kernel(4) * 15.0 * dr(1) * dr(2) - & + (mu(1)*dr(2) + mu(2)*dr(1)) * 3.0 * kernel(3) + ! yy + grdE(3) = grdE(3) + mu_dot_dr * kernel(4) * 15.0 * dr(2) * dr(2) - & + (mu_dot_dr + 2.0 * mu(2) * dr(2)) * 3.0 * kernel(3) + ! xz + grdE(4) = grdE(4) + mu_dot_dr * kernel(4) * 15.0 * dr(1) * dr(3) - & + (mu(1)*dr(3) + mu(3)*dr(1)) * 3.0 * kernel(3) + ! yz + grdE(5) = grdE(5) + mu_dot_dr * kernel(4) * 15.0 * dr(2) * dr(3) - & + (mu(2)*dr(3) + mu(3)*dr(2)) * 3.0 * kernel(3) + ! zz + grdE(6) = grdE(6) + mu_dot_dr * kernel(4) * 15.0 * dr(3) * dr(3) - & + (mu_dot_dr + 2.0 * mu(3) * dr(3)) * 3.0 * kernel(3) + end if + + if(do_HE) then + ! xxx + HE(1) = HE(1) + 105.0_rp * mu_dot_dr * kernel(5) * dr(1)*dr(1)*dr(1) & + - 45.0_rp * kernel(4) * dr(1) * (mu(1)*dr(1) + mu_dot_dr) & + + 9.0_rp * kernel(3) * mu(1) + ! xxy + HE(2) = HE(2) + 105.0_rp * kernel(5) * mu_dot_dr * dr(1)*dr(1)*dr(2) & + - 15.0_rp * kernel(4) * (mu(2)*dr(1)*dr(1) + & + 2.0_rp *mu(1)*dr(1)*dr(2) + & + mu_dot_dr*dr(2)) & + + 3.0_rp * kernel(3) * mu(2) + + ! xxz + HE(3) = HE(3) + 105.0_rp * kernel(5) * mu_dot_dr * dr(1)*dr(1)*dr(3) & + - 15.0_rp * kernel(4) * (mu(3)*dr(1)*dr(1) + & + 2.0_rp *mu(1)*dr(1)*dr(3) + & + mu_dot_dr*dr(3)) & + + 3.0_rp * kernel(3) * mu(3) + ! xyy + HE(4) = HE(4) + 105.0_rp * kernel(5) * mu_dot_dr * dr(2)*dr(2)*dr(1) & + - 15.0_rp * kernel(4) * (mu(1)*dr(2)*dr(2) + & + 2.0_rp *mu(2)*dr(2)*dr(1) + & + mu_dot_dr*dr(1)) & + + 3.0_rp * kernel(3) * mu(1) + ! xyz + HE(5) = HE(5) + 105.0_rp * mu_dot_dr * kernel(5) * dr(1)*dr(2)*dr(3) & + - 15.0_rp * kernel(4) * (mu(1)*dr(2)*dr(3) + & + dr(1)*mu(2)*dr(3) + & + dr(1)*dr(2)*mu(3)) + ! xzz + HE(6) = HE(6) + 105.0_rp * kernel(5) * mu_dot_dr * dr(3)*dr(3)*dr(1) & + - 15.0_rp * kernel(4) * (mu(1)*dr(3)*dr(3) + & + 2.0_rp *mu(3)*dr(3)*dr(1) + & + mu_dot_dr*dr(1)) & + + 3.0_rp * kernel(3) * mu(1) + ! yyy + HE(7) = HE(7) + 105.0_rp * mu_dot_dr * kernel(5) * dr(2)*dr(2)*dr(2) & + - 45.0_rp * kernel(4) * dr(2) * (mu(2)*dr(2) + mu_dot_dr) & + + 9.0_rp * kernel(3) * mu(2) + ! yyz + HE(8) = HE(8) + 105.0_rp * kernel(5) * mu_dot_dr * dr(2)*dr(2)*dr(3) & + - 15.0_rp * kernel(4) * (mu(3)*dr(2)*dr(2) + & + 2.0_rp *mu(2)*dr(2)*dr(3) + & + mu_dot_dr*dr(3)) & + + 3.0_rp * kernel(3) * mu(3) + ! yzz + HE(9) = HE(9) + 105.0_rp * kernel(5) * mu_dot_dr * dr(3)*dr(3)*dr(2) & + - 15.0_rp * kernel(4) * (mu(2)*dr(3)*dr(3) + & + 2.0_rp *mu(3)*dr(3)*dr(2) + & + mu_dot_dr*dr(2)) & + + 3.0_rp * kernel(3) * mu(2) + ! zzz + HE(10) = HE(10) + 105.0_rp * mu_dot_dr * kernel(5) * dr(3)*dr(3)*dr(3) & + - 45.0_rp * kernel(4) * dr(3) * (mu(3)*dr(3) + mu_dot_dr) & + + 9.0_rp * kernel(3) * mu(3) + end if + end subroutine mu_elec_prop + + subroutine quad_elec_prop(quad, dr, kernel, & + do_V, V, do_E, E, do_grdE, grdE, do_HE, HE) + + implicit none + + real(rp), intent(in) :: quad(6) + !! point quadrupole stored as (xx, xy, yy, xz, yz, zz) + real(rp), intent(in) :: dr(3) + !! Distance vector + real(rp), intent(in) :: kernel(:) + !! Array of coulomb kernel (either damped or undamped) + logical, intent(in) :: do_V, do_E, do_grdE, do_HE + !! Flags to enable/disable calculation of different electrostatic + !! properties + real(rp), intent(inout) :: V, E(3), grdE(6), HE(10) + !! Electric potential + + real(rp) :: quadxr(3), quadxr_dot_r + + quadxr(1) = quad(1)*dr(1) + quad(2)*dr(2) + quad(4)*dr(3) + quadxr(2) = quad(2)*dr(1) + quad(3)*dr(2) + quad(5)*dr(3) + quadxr(3) = quad(4)*dr(1) + quad(5)*dr(2) + quad(6)*dr(3) + + quadxr_dot_r = dot_product(quadxr, dr) + + if(do_V) then + V = V + 3.0_rp * quadxr_dot_r * kernel(3) + end if + + if(do_E) then + E = E + 15.0_rp * quadxr_dot_r * dr * kernel(4) & + - 6.0_rp * quadxr * kernel(3) + end if + + if(do_grdE) then + ! xx + grdE(1) = grdE(1) + 105.0 * kernel(5) * quadxr_dot_r * dr(1)*dr(1) + & + 6.0 * kernel(3) * quad(1) - & + 15.0*kernel(4)*(quadxr_dot_r+4.0*quadxr(1)*dr(1)) + ! xy + grdE(2) = grdE(2) + 105.0 * kernel(5) * quadxr_dot_r * dr(1)*dr(2) + & + 6.0 * kernel(3) * quad(2) - & + 30.0*kernel(4)*(quadxr(1)*dr(2)+quadxr(2)*dr(1)) + ! yy + grdE(3) = grdE(3) + 105.0 * kernel(5) * quadxr_dot_r * dr(2)*dr(2) + & + 6.0 * kernel(3) * quad(3) - & + 15.0*kernel(4)*(quadxr_dot_r+4.0*quadxr(2)*dr(2)) + ! xz + grdE(4) = grdE(4) + 105.0 * kernel(5) * quadxr_dot_r * dr(1)*dr(3) + & + 6.0 * kernel(3) * quad(4) - & + 30.0*kernel(4)*(quadxr(1)*dr(3)+quadxr(3)*dr(1)) + ! yz + grdE(5) = grdE(5) + 105.0 * kernel(5) * quadxr_dot_r * dr(2)*dr(3) + & + 6.0 * kernel(3) * quad(5) - & + 30.0*kernel(4)*(quadxr(2)*dr(3)+quadxr(3)*dr(2)) + ! zz + grdE(6) = grdE(6) + 105.0 * kernel(5) * quadxr_dot_r * dr(3)*dr(3) + & + 6.0 * kernel(3) * quad(6) - & + 15.0*kernel(4)*(quadxr_dot_r+4.0*quadxr(3)*dr(3)) + end if + + if(do_HE) then + ! 3 + HE(_xxx_) = HE(_xxx_) + 945*kernel(6)*dr(_x_)**3 * quadxr_dot_r & + - 315*kernel(5)*dr(_x_)*(2*quadxr(_x_)*dr(_x_) + quadxr_dot_r) & + + 90*kernel(4)*(quad(_xx_)*dr(_x_) + quadxr(_x_)) + + HE(_yyy_) = HE(_yyy_) + 945*kernel(6)*dr(_y_)**3 * quadxr_dot_r & + - 315*kernel(5)*dr(_y_)*(2*quadxr(_y_)*dr(_y_) + quadxr_dot_r) & + + 90*kernel(4)*(quad(_yy_)*dr(_y_) + quadxr(_y_)) + + HE(_zzz_) = HE(_zzz_) + 945*kernel(6)*dr(_z_)**3 * quadxr_dot_r & + - 315*kernel(5)*dr(_z_)*(2*quadxr(_z_)*dr(_z_) + quadxr_dot_r) & + + 90*kernel(4)*(quad(_zz_)*dr(_z_) + quadxr(_z_)) + + ! 2 + 1 + HE(_xxy_) = HE(_xxy_) + 945*kernel(6)*dr(_x_)**2*dr(_y_)*quadxr_dot_r & + - 105*kernel(5)*(4*quadxr(_x_)*dr(_x_)*dr(_y_) + & + 2*quadxr(_y_)*dr(_x_)*dr(_x_) + & + dr(_y_)*quadxr_dot_r) & + + 30*kernel(4)*(quad(_xx_)*dr(_y_) + 2*quad(_xy_)*dr(_x_) + quadxr(_y_)) + + HE(_xxz_) = HE(_xxz_) + 945*kernel(6)*dr(_x_)**2*dr(_z_)*quadxr_dot_r & + - 105*kernel(5)*(4*quadxr(_x_)*dr(_x_)*dr(_z_) + & + 2*quadxr(_z_)*dr(_x_)*dr(_x_) + & + dr(_z_)*quadxr_dot_r) & + + 30*kernel(4)*(quad(_xx_)*dr(_z_) + 2*quad(_xz_)*dr(_x_) + quadxr(_z_)) + + HE(_yyx_) = HE(_yyx_) + 945*kernel(6)*dr(_y_)**2*dr(_x_)*quadxr_dot_r & + - 105*kernel(5)*(4*quadxr(_y_)*dr(_y_)*dr(_x_) + & + 2*quadxr(_x_)*dr(_y_)*dr(_y_) + & + dr(_x_)*quadxr_dot_r) & + + 30*kernel(4)*(quad(_yy_)*dr(_x_) + 2*quad(_xy_)*dr(_y_) + quadxr(_x_)) + + HE(_yyz_) = HE(_yyz_) + 945*kernel(6)*dr(_y_)**2*dr(_z_)*quadxr_dot_r & + - 105*kernel(5)*(4*quadxr(_y_)*dr(_y_)*dr(_z_) + & + 2*quadxr(_z_)*dr(_y_)*dr(_y_) + & + dr(_z_)*quadxr_dot_r) & + + 30*kernel(4)*(quad(_yy_)*dr(_z_) + 2*quad(_zy_)*dr(_y_) + quadxr(_z_)) + + HE(_zzx_) = HE(_zzx_) + 945*kernel(6)*dr(_z_)**2*dr(_x_)*quadxr_dot_r & + - 105*kernel(5)*(4*quadxr(_z_)*dr(_z_)*dr(_x_) + & + 2*quadxr(_x_)*dr(_z_)*dr(_z_) + & + dr(_x_)*quadxr_dot_r) & + + 30*kernel(4)*(quad(_zz_)*dr(_x_) + 2*quad(_zx_)*dr(_z_) + quadxr(_x_)) + + HE(_zzy_) = HE(_zzy_) + 945*kernel(6)*dr(_z_)**2*dr(_y_)*quadxr_dot_r & + - 105*kernel(5)*(4*quadxr(_z_)*dr(_z_)*dr(_y_) + & + 2*quadxr(_y_)*dr(_z_)*dr(_z_) + & + dr(_y_)*quadxr_dot_r) & + + 30*kernel(4)*(quad(_zz_)*dr(_y_) + 2*quad(_zy_)*dr(_z_) + quadxr(_y_)) + + ! 1 + 1 + 1 + HE(_xyz_) = HE(_xyz_) + 945*kernel(6)*dr(_x_)*dr(_y_)*dr(_z_)*quadxr_dot_r & + - 210*kernel(5)*(quadxr(_x_)*dr(_y_)*dr(_z_) + & + quadxr(_y_)*dr(_x_)*dr(_z_) + & + quadxr(_z_)*dr(_x_)*dr(_y_)) & + + 30*kernel(4)*(quad(_xy_)*dr(_z_) + quad(_xz_)*dr(_y_) + quad(_yz_)*dr(_x_)) + end if + end subroutine quad_elec_prop + + subroutine prepare_fixedelec(eel, arg_dogg) + !! This function allocate and populate array of electrostatic + !! properties of static multipoles at static multipoles sites. + !! It should be called blindly before any calculation that requires + !! V_M2M etc. + + use mod_memory, only: mallocate + + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel + logical, optional, intent(in) :: arg_dogg + + integer(ip) :: mm_atoms + logical :: do_gg + + mm_atoms = eel%top%mm_atoms + + !! TODO Improve logic + do_gg = .false. + if(present(arg_dogg)) then + if(arg_dogg) do_gg = .true. + end if + + if(.not. do_gg .and. eel%M2M_done) return + if(do_gg .and. eel%M2M_done .and. eel%M2Mgg_done) return + + if(eel%amoeba) then + if(.not. allocated(eel%V_M2M)) then + call mallocate('prepare_fixedelec [V_M2M]', mm_atoms, eel%V_M2M) + end if + + if(.not. allocated(eel%E_M2M)) then + call mallocate('prepare_fixedelec [E_M2M]', 3, mm_atoms, eel%E_M2M) + end if + + if(.not. allocated(eel%Egrd_M2M)) then + call mallocate('prepare_fixedelec [Egrd_M2M]', 6, mm_atoms, eel%Egrd_M2M) + end if + + if(do_gg .and. .not. allocated(eel%EHes_M2M)) then + call mallocate('prepare_fixedelec [EHes_M2M]', 10, mm_atoms, eel%EHes_M2M) + end if + + eel%V_M2M = 0.0_rp + eel%E_M2M = 0.0_rp + eel%Egrd_M2M = 0.0_rp + if(do_gg) eel%EHes_M2M = 0.0_rp + + if(do_gg) then + call elec_prop_M2M(eel, .true., .true., .true., .true.) + else + call elec_prop_M2M(eel, .true., .true., .true., .false.) + end if + else + if(.not. allocated(eel%V_M2M)) then + call mallocate('prepare_fixedelec [V_M2M]', mm_atoms, eel%V_M2M) + end if + + if(do_gg .and. .not. allocated(eel%E_M2M)) then + call mallocate('prepare_fixedelec [E_M2M]', 3, mm_atoms, eel%E_M2M) + end if + + eel%V_M2M = 0.0_rp + if(do_gg) eel%E_M2M = 0.0_rp + + if(do_gg) then + call elec_prop_M2M(eel, .true., .true., .false., .false.) + else + call elec_prop_M2M(eel, .true., .false., .false., .false.) + end if + end if + + eel%M2M_done = .true. + if(do_gg) eel%M2Mgg_done = .true. + + end subroutine prepare_fixedelec + + subroutine prepare_polelec(eel, arg_dogg) + use mod_memory, only: mallocate + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel + logical, optional, intent(in) :: arg_dogg + + logical :: do_gg + + do_gg = .false. + if(present(arg_dogg)) then + if(arg_dogg) do_gg = .true. + end if + + if(.not. do_gg .and. eel%M2D_done) return + if(do_gg .and. eel%M2D_done .and. eel%M2Dgg_done) return + + if(.not. allocated(eel%E_M2D)) then + call mallocate('prepare_polelec [E_M2D]', 3, eel%pol_atoms, & + eel%n_ipd, eel%E_M2D) + end if + + if(do_gg) then + if(.not. eel%ipd_done) call fatal_error("IPD should be computed & + &before computing analytical geometrical gradients of & + &polarization energy.") + + if(.not. allocated(eel%Egrd_M2D)) then + call mallocate('prepare_polelec [Egrd_M2D]', 6, eel%pol_atoms, & + eel%n_ipd, eel%Egrd_M2D) + end if + + if(.not. allocated(eel%Egrd_D2D)) then + call mallocate('prepare_polelec [Egrd_D2D]', 6, eel%pol_atoms, & + eel%n_ipd, eel%Egrd_D2D) + end if + + if(.not. allocated(eel%E_D2M)) then + call mallocate('prepare_polelec [E_D2M]', 3, eel%top%mm_atoms, & + eel%E_D2M) + end if + if(.not. allocated(eel%Egrd_D2M) .and. eel%amoeba) then + call mallocate('prepare_polelec [Egrd_D2M]', 6, eel%top%mm_atoms, & + eel%Egrd_D2M) + end if + if(.not. allocated(eel%EHes_D2M) .and. eel%amoeba) then + call mallocate('prepare_polelec [E_D2M]', 10, eel%top%mm_atoms, & + eel%EHes_D2M) + end if + + end if + + if(.not. do_gg) then + eel%E_M2D = 0.0_rp + call elec_prop_M2D(eel, .false., .true., .false., .false.) + else + eel%E_M2D = 0.0_rp + eel%Egrd_M2D = 0.0_rp + call elec_prop_M2D(eel, .false., .true., .true., .false.) + + eel%E_D2M = 0.0_rp + eel%Egrd_D2D = 0.0_rp + + if(eel%amoeba) then + eel%Egrd_D2M = 0.0_rp + eel%EHes_D2M = 0.0_rp + call elec_prop_D2M(eel, 'P', .false., .true., .true., .true.) + call elec_prop_D2M(eel, 'D', .false., .true., .true., .true.) + + eel%E_D2M = eel%E_D2M * 0.5 + eel%Egrd_D2M = eel%Egrd_D2M * 0.5 + eel%EHes_D2M = eel%EHes_D2M * 0.5 + + call elec_prop_D2D(eel, 'P', .false., .false., .true., .false.) + call elec_prop_D2D(eel, 'D', .false., .false., .true., .false.) + else + call elec_prop_D2M(eel, '-', .false., .true., .false., .false.) + call elec_prop_D2D(eel, '-', .false., .false., .true., .false.) + end if + end if + + if(do_gg) eel%M2Dgg_done = .true. + eel%M2D_done = .true. + end subroutine prepare_polelec + + subroutine elec_prop_M2M(eel, do_V, do_E, do_Egrd, do_EHes) + !! Computes the electric potential, field and field gradients of + !! static multipoles at all sites (polarizable sites are a + !! subset of static ones) + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel + !! Electrostatics data structure + logical, intent(in) :: do_V, do_E, do_Egrd, do_EHes + !! Flags to enable/disable the calculation of different components + + + real(rp) :: kernel(6), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10), scalf + integer(ip) :: i, j, idx, ikernel + logical :: to_do, to_scale + type(ommp_topology_type), pointer :: top + + top => eel%top + + if(do_EHes) then + ikernel = 3 + elseif(do_Egrd) then + ikernel = 2 + elseif(do_E) then + ikernel = 1 + elseif(do_V) then + ikernel = 0 + else + return + end if + if(eel%amoeba) ikernel = ikernel + 2 + + if(eel%amoeba) then + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,idx,to_do,to_scale,scalf,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) + do j=1, top%mm_atoms + ! loop on sources + do i=1, top%mm_atoms + if(j == i) cycle + !loop on target + + to_do = .true. + to_scale = .false. + scalf = 1.0 + + ! Check if the element should be scaled + do idx=eel%list_S_S%ri(i), eel%list_S_S%ri(i+1)-1 + if(eel%list_S_S%ci(idx) == j) then + to_scale = .true. + exit + end if + end do + + !If it should set the correct variables + if(to_scale) then + to_do = eel%todo_S_S(idx) + scalf = eel%scalef_S_S(idx) + end if + + if(to_do) then + dr = top%cmm(:,j) - top%cmm(:, i) + call coulomb_kernel(dr, ikernel, kernel) + + if(do_V) tmpV = 0.0_rp + if(do_E) tmpE = 0.0_rp + if(do_Egrd) tmpEgr = 0.0_rp + if(do_EHes) tmpHE = 0.0_rp + + call q_elec_prop(eel%q(1,i), dr, kernel, & + do_V, tmpV, & + do_E, tmpE, & + do_Egrd, tmpEgr, & + do_EHes, tmpHE) + + call mu_elec_prop(eel%q(2:4,i), dr, kernel, & + do_V, tmpV, & + do_E, tmpE, & + do_Egrd, tmpEgr, & + do_EHes, tmpHE) + + call quad_elec_prop(eel%q(5:10,i), dr, kernel, & + do_V, tmpV, & + do_E, tmpE, & + do_Egrd, tmpEgr, & + do_EHes, tmpHE) + + if(to_scale) then + if(do_V) eel%V_M2M(j) = eel%V_M2M(j) + tmpV * scalf + if(do_E) eel%E_M2M(:,j) = eel%E_M2M(:,j) + tmpE * scalf + if(do_Egrd) eel%Egrd_M2M(:,j) = eel%Egrd_M2M(:,j) + tmpEgr * scalf + if(do_EHes) eel%EHes_M2M(:,j) = eel%EHes_M2M(:,j) + tmpHE * scalf + else + if(do_V) eel%V_M2M(j) = eel%V_M2M(j) + tmpV + if(do_E) eel%E_M2M(:,j) = eel%E_M2M(:,j) + tmpE + if(do_Egrd) eel%Egrd_M2M(:,j) = eel%Egrd_M2M(:,j) + tmpEgr + if(do_EHes) eel%EHes_M2M(:,j) = eel%EHes_M2M(:,j) + tmpHE + end if + end if + end do + end do + else + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,idx,to_do,to_scale,scalf,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) + do j=1, top%mm_atoms + ! loop on sources + do i=1, top%mm_atoms + if(j == i) cycle + !loop on target + to_do = .true. + to_scale = .false. + scalf = 1.0 + + ! Check if the element should be scaled + do idx=eel%list_S_S%ri(i), eel%list_S_S%ri(i+1)-1 + if(eel%list_S_S%ci(idx) == j) then + to_scale = .true. + exit + end if + end do + + !If it should set the correct variables + if(to_scale) then + to_do = eel%todo_S_S(idx) + scalf = eel%scalef_S_S(idx) + end if + + if(to_do) then + dr = top%cmm(:,j) - top%cmm(:, i) + call coulomb_kernel(dr, ikernel, kernel) + + if(do_V) tmpV = 0.0_rp + if(do_E) tmpE = 0.0_rp + if(do_Egrd) tmpEgr = 0.0_rp + if(do_EHes) tmpHE = 0.0_rp + + call q_elec_prop(eel%q(1,i), dr, kernel, & + do_V, tmpV, & + do_E, tmpE, & + do_Egrd, tmpEgr, & + do_EHes, tmpHE) + + if(to_scale) then + if(do_V) eel%V_M2M(j) = eel%V_M2M(j) + tmpV * scalf + if(do_E) eel%E_M2M(:,j) = eel%E_M2M(:,j) + tmpE * scalf + if(do_Egrd) eel%Egrd_M2M(:,j) = eel%Egrd_M2M(:,j) + tmpEgr * scalf + if(do_EHes) eel%EHes_M2M(:,j) = eel%EHes_M2M(:,j) + tmpHE * scalf + else + if(do_V) eel%V_M2M(j) = eel%V_M2M(j) + tmpV + if(do_E) eel%E_M2M(:,j) = eel%E_M2M(:,j) + tmpE + if(do_Egrd) eel%Egrd_M2M(:,j) = eel%Egrd_M2M(:,j) + tmpEgr + if(do_EHes) eel%EHes_M2M(:,j) = eel%EHes_M2M(:,j) + tmpHE + end if + end if + end do + end do + end if + end subroutine elec_prop_M2M + + subroutine field_extD2D(eel, ext_ipd, E) + !! Computes the electric field of a trial set of induced point dipoles + !! at polarizable sites. This is intended to be used as matrix-vector + !! routine in the solution of the linear system. + + implicit none + + type(ommp_electrostatics_type), intent(in) :: eel + !! Data structure for electrostatic part of the system + real(rp), intent(in) :: ext_ipd(3, eel%pol_atoms) + !! External induced point dipoles at polarizable sites + real(rp), intent(inout) :: E(3, eel%pol_atoms) + !! Electric field (results will be added) + + integer(ip) :: i, j, idx + logical :: to_scale, to_do + real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10), scalf + + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,to_do,to_scale,scalf,idx,tmpV,tmpE,tmpEgr,tmpHE,kernel,dr) + do j=1, eel%pol_atoms + do i=1, eel%pol_atoms + if(j == i) cycle + !loop on target + to_do = .true. + to_scale = .false. + scalf = 1.0 + + ! Check if the element should be scaled + do idx=eel%list_P_P%ri(i), eel%list_P_P%ri(i+1)-1 + if(eel%list_P_P%ci(idx) == j) then + to_scale = .true. + exit + end if + end do + + !If it should set the correct variables + if(to_scale) then + to_do = eel%todo_P_P(idx) + scalf = eel%scalef_P_P(idx) + end if + + if(to_do) then + call damped_coulomb_kernel(eel, eel%polar_mm(i), & + eel%polar_mm(j),& + 2, kernel(1:3), dr) + + tmpE = 0.0_rp + + call mu_elec_prop(ext_ipd(:,i), dr, kernel, .false., tmpV, & + .true., tmpE, .false., tmpEgr, & + .false., tmpHE) + if(to_scale) then + E(:, j) = E(:, j) + tmpE * scalf + else + E(:, j) = E(:, j) + tmpE + end if + end if + end do + end do + end subroutine field_extD2D + + subroutine elec_prop_D2D(eel, in_kind, do_V, do_E, do_Egrd, do_EHes) + !! Computes the electric field of a trial set of induced point dipoles + !! at polarizable sites. This is intended to be used as matrix-vector + !! routine in the solution of the linear system. + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel + !! Data structure for electrostatic part of the system + logical, intent(in) :: do_V, do_E, do_Egrd, do_EHes + !! Flag to control which properties have to be computed. + character, intent(in) :: in_kind + + integer(ip) :: i, j, idx, ikernel, knd + logical :: to_scale, to_do + real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10), scalf + + knd = 1 ! Default + if(in_kind == 'P') then + knd = _amoeba_P_ + elseif(in_kind == 'D') then + knd = _amoeba_D_ + elseif(eel%amoeba) then + call fatal_error("Unrecognized interaction '"//in_kind//"' in elec& + &_prop_D2D.") + else + knd = 1 + end if + + if(do_EHes) then + ikernel = 5 + elseif(do_Egrd) then + ikernel = 4 + elseif(do_E) then + ikernel = 3 + elseif(do_V) then + ikernel = 2 + else + return + end if + + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,idx,dr,kernel,to_do,to_scale,scalf,tmpV,tmpE,tmpEgr,tmpHE) + do j=1, eel%pol_atoms + do i=1, eel%pol_atoms + if(j == i) cycle + !loop on target + to_do = .true. + to_scale = .false. + scalf = 1.0 + + ! Check if the element should be scaled + do idx=eel%list_P_P%ri(i), eel%list_P_P%ri(i+1)-1 + if(eel%list_P_P%ci(idx) == j) then + to_scale = .true. + exit + end if + end do + + !If it should set the correct variables + if(to_scale) then + to_do = eel%todo_P_P(idx) + scalf = eel%scalef_P_P(idx) + end if + + if(to_do) then + call damped_coulomb_kernel(eel, eel%polar_mm(i), & + eel%polar_mm(j),& + ikernel, kernel, dr) + + if(do_V) tmpV = 0.0_rp + if(do_E) tmpE = 0.0_rp + if(do_Egrd) tmpEgr = 0.0_rp + if(do_EHes) tmpHE = 0.0_rp + + call mu_elec_prop(eel%ipd(:,i,knd), dr, kernel, & + do_V, tmpV, & + do_E, tmpE, & + do_Egrd, tmpEgr, & + do_EHes, tmpHE) + if(to_scale) then + if(do_V) eel%V_D2D(j,knd) = eel%V_D2D(j,knd) + tmpV * scalf + if(do_E) eel%E_D2D(:, j,knd) = eel%E_D2D(:, j,knd) + tmpE * scalf + if(do_Egrd) eel%Egrd_D2D(:, j,knd) = eel%Egrd_D2D(:, j,knd) + tmpEgr * scalf + if(do_EHes) eel%EHes_D2D(:, j,knd) = eel%EHes_D2D(:, j,knd) + tmpHE * scalf + else + if(do_V) eel%V_D2D(j,knd) = eel%V_D2D(j,knd) + tmpV + if(do_E) eel%E_D2D(:, j,knd) = eel%E_D2D(:, j,knd) + tmpE + if(do_Egrd) eel%Egrd_D2D(:, j,knd) = eel%Egrd_D2D(:, j,knd) + tmpEgr + if(do_EHes) eel%EHes_D2D(:, j,knd) = eel%EHes_D2D(:, j,knd) + tmpHE + end if + end if + end do + end do + end subroutine elec_prop_D2D + + subroutine elec_prop_M2D(eel, do_V, do_E, do_Egrd, do_EHes) + !! Computes the electric field of static multipoles at induced dipoles + !! sites. This is only intended to be used to build the RHS of the + !! linear system. This field is modified by the indroduction of the + !! damped kernels and by the connectivity-based screening rules. + + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel + !! Electrostatics data structure + logical, intent(in) :: do_V, do_E, do_Egrd, do_EHes + !! Flag to control which properties have to be computed. + + integer(ip) :: i, j, idx, ikernel + logical :: to_do_p, to_scale_p, to_do_d, to_scale_d, to_do, to_scale, & + amoeba + real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10), & + scalf_p, scalf_d, scalf + type(ommp_topology_type), pointer :: top + + ! Shortcuts + top => eel%top + amoeba = eel%amoeba + + if(do_EHes) then + ikernel = 3 + elseif(do_Egrd) then + ikernel = 2 + elseif(do_E) then + ikernel = 1 + elseif(do_V) then + ikernel = 0 + else + return + end if + if(eel%amoeba) ikernel = ikernel + 2 + + if(amoeba) then + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,idx,dr,kernel,to_do_p,to_do_d,to_scale_p,to_scale_d,scalf_p,scalf_d,tmpV,tmpE,tmpEgr,tmpHE) + do j=1, eel%pol_atoms + ! loop on sources + do i=1, top%mm_atoms + if(eel%polar_mm(j) == i) cycle + !loop on target + to_do_p = .true. + to_scale_p = .false. + scalf_p = 1.0 + + ! Check if the element should be scaled + do idx=eel%list_S_P_P%ri(i), eel%list_S_P_P%ri(i+1)-1 + if(eel%list_S_P_P%ci(idx) == j) then + to_scale_p = .true. + exit + end if + end do + + !If it should set the correct variables + if(to_scale_p) then + to_do_p = eel%todo_S_P_P(idx) + scalf_p = eel%scalef_S_P_P(idx) + end if + + to_do_d = .true. + to_scale_d = .false. + scalf_d = 1.0 + + ! Check if the element should be scaled + do idx=eel%list_S_P_D%ri(i), eel%list_S_P_D%ri(i+1)-1 + if(eel%list_S_P_D%ci(idx) == j) then + to_scale_d = .true. + exit + end if + end do + + !If it should set the correct variables + if(to_scale_d) then + to_do_d = eel%todo_S_P_D(idx) + scalf_d = eel%scalef_S_P_D(idx) + end if + + if(to_do_p .or. to_do_d) then + call damped_coulomb_kernel(eel, i, eel%polar_mm(j), & + ikernel, kernel, dr) + + if(do_V) tmpV = 0.0_rp + if(do_E) tmpE = 0.0_rp + if(do_Egrd) tmpEgr = 0.0_rp + if(do_EHes) tmpHE = 0.0_rp + + call q_elec_prop(eel%q(1,i), dr, kernel, & + do_V, tmpV, & + do_E, tmpE, & + do_Egrd, tmpEgr, & + do_EHes, tmpHE) + call mu_elec_prop(eel%q(2:4,i), dr, kernel, & + do_V, tmpV, & + do_E, tmpE, & + do_Egrd, tmpEgr, & + do_EHes, tmpHE) + call quad_elec_prop(eel%q(5:10,i), dr, kernel, & + do_V, tmpV, & + do_E, tmpE, & + do_Egrd, tmpEgr, & + do_EHes, tmpHE) + + if(to_do_p) then + if(to_scale_p) then + if(do_V) eel%V_M2D(j, _amoeba_P_) = eel%V_M2D(j, _amoeba_P_) + tmpV * scalf_p + if(do_E) eel%E_M2D(:, j, _amoeba_P_) = eel%E_M2D(:, j, _amoeba_P_) + tmpE * scalf_p + if(do_Egrd) eel%Egrd_M2D(:, j, _amoeba_P_) = eel%Egrd_M2D(:, j, _amoeba_P_) + tmpEgr * scalf_p + if(do_EHes) eel%EHes_M2D(:, j, _amoeba_P_) = eel%EHes_M2D(:, j, _amoeba_P_) + tmpHE * scalf_p + else + if(do_V) eel%V_M2D(j, _amoeba_P_) = eel%V_M2D(j, _amoeba_P_) + tmpV + if(do_E) eel%E_M2D(:, j, _amoeba_P_) = eel%E_M2D(:, j, _amoeba_P_) + tmpE + if(do_Egrd) eel%Egrd_M2D(:, j, _amoeba_P_) = eel%Egrd_M2D(:, j, _amoeba_P_) + tmpEgr + if(do_EHes) eel%EHes_M2D(:, j, _amoeba_P_) = eel%EHes_M2D(:, j, _amoeba_P_) + tmpHE + end if + end if + + if(to_do_d) then + if(to_scale_d) then + if(do_V) eel%V_M2D(j, _amoeba_D_) = eel%V_M2D(j, _amoeba_D_) + tmpV * scalf_d + if(do_E) eel%E_M2D(:, j, _amoeba_D_) = eel%E_M2D(:, j, _amoeba_D_) + tmpE * scalf_d + if(do_Egrd) eel%Egrd_M2D(:, j, _amoeba_D_) = eel%Egrd_M2D(:, j, _amoeba_D_) + tmpEgr * scalf_d + if(do_EHes) eel%EHes_M2D(:, j, _amoeba_D_) = eel%EHes_M2D(:, j, _amoeba_D_) + tmpHE * scalf_d + else + if(do_V) eel%V_M2D(j, _amoeba_D_) = eel%V_M2D(j, _amoeba_D_) + tmpV + if(do_E) eel%E_M2D(:, j, _amoeba_D_) = eel%E_M2D(:, j, _amoeba_D_) + tmpE + if(do_Egrd) eel%Egrd_M2D(:, j, _amoeba_D_) = eel%Egrd_M2D(:, j, _amoeba_D_) + tmpEgr + if(do_EHes) eel%EHes_M2D(:, j, _amoeba_D_) = eel%EHes_M2D(:, j, _amoeba_D_) + tmpHE + end if + end if + end if + end do + end do + else + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,idx,dr,kernel,to_do,to_scale,scalf,tmpV,tmpE,tmpEgr,tmpHE) + do j=1, eel%pol_atoms + ! loop on sources + do i=1, top%mm_atoms + if(eel%polar_mm(j) == i) cycle + !loop on target + to_do = .true. + to_scale = .false. + scalf = 1.0 + + ! Check if the element should be scaled + do idx=eel%list_S_P_P%ri(i), eel%list_S_P_P%ri(i+1)-1 + if(eel%list_S_P_P%ci(idx) == j) then + to_scale = .true. + exit + end if + end do + + !If it should set the correct variables + if(to_scale) then + to_do = eel%todo_S_P_P(idx) + scalf = eel%scalef_S_P_P(idx) + end if + + if(to_do) then + call damped_coulomb_kernel(eel, i, eel%polar_mm(j), & + ikernel, kernel, dr) + + if(do_V) tmpV = 0.0_rp + if(do_E) tmpE = 0.0_rp + if(do_Egrd) tmpEgr = 0.0_rp + if(do_EHes) tmpHE = 0.0_rp + + call q_elec_prop(eel%q(1,i), dr, kernel, & + do_V, tmpV, & + do_E, tmpE, & + do_Egrd, tmpEgr, & + do_EHes, tmpHE) + if(to_scale) then + if(do_V) eel%V_M2D(j, 1) = eel%V_M2D(j, 1) + tmpV * scalf + if(do_E) eel%E_M2D(:, j, 1) = eel%E_M2D(:, j, 1) + tmpE * scalf + if(do_Egrd) eel%Egrd_M2D(:, j, 1) = eel%Egrd_M2D(:, j, 1) + tmpEgr * scalf + if(do_EHes) eel%EHes_M2D(:, j, 1) = eel%EHes_M2D(:, j, 1) + tmpHE * scalf + else + if(do_V) eel%V_M2D(j, 1) = eel%V_M2D(j, 1) + tmpV + if(do_E) eel%E_M2D(:, j, 1) = eel%E_M2D(:, j, 1) + tmpE + if(do_Egrd) eel%Egrd_M2D(:, j, 1) = eel%Egrd_M2D(:, j, 1) + tmpEgr + if(do_EHes) eel%EHes_M2D(:, j, 1) = eel%EHes_M2D(:, j, 1) + tmpHE + end if + end if + end do + end do + end if + + end subroutine + + subroutine elec_prop_D2M(eel, in_kind, do_V, do_E, do_Egrd, do_EHes) + + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel + !! Electrostatics data structure + character, intent(in) :: in_kind + + logical, intent(in) :: do_V, do_E, do_Egrd, do_EHes + !! Flag to control which properties have to be computed. + + integer(ip) :: i, j, idx, ikernel, knd + logical :: to_do, to_scale, amoeba + real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10), & + scalf + type(ommp_topology_type), pointer :: top + character :: screening_type + + ! Shortcuts + top => eel%top + amoeba = eel%amoeba + + knd = 1 ! Default + if(eel%amoeba .and. in_kind /= 'P' .and. in_kind /= 'D') then + call fatal_error("Unrecognized field '"//in_kind//"' for AMOEBA & + &force-field.") + elseif(eel%amoeba .and. in_kind == 'P') then + knd = _amoeba_P_ + screening_type = 'D' + elseif(eel%amoeba .and. in_kind == 'D') then + knd = _amoeba_D_ + screening_type = 'P' + elseif(.not. eel%amoeba) then + screening_type = '-' + else + call fatal_error("Unexpected error in elec_prop_D2M.") + end if + + if(do_EHes) then + ikernel = 4 + elseif(do_Egrd) then + ikernel = 3 + elseif(do_E) then + ikernel = 2 + elseif(do_V) then + ikernel = 1 + else + return + end if + + if(amoeba) then + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,idx,dr,kernel,to_do,to_scale,scalf,tmpV,tmpE,tmpEgr,tmpHE) + do j=1, top%mm_atoms + ! loop on sources + do i=1, eel%pol_atoms + if(eel%polar_mm(i) == j) cycle + !loop on target + if(screening_type == 'P') then + to_do = .true. + to_scale = .false. + scalf = 1.0 + + ! Check if the element should be scaled + do idx=eel%list_S_P_P%ri(j), eel%list_S_P_P%ri(j+1)-1 + if(eel%list_S_P_P%ci(idx) == i) then + to_scale = .true. + exit + end if + end do + + !If it should set the correct variables + if(to_scale) then + to_do = eel%todo_S_P_P(idx) + scalf = eel%scalef_S_P_P(idx) + end if + else + to_do = .true. + to_scale = .false. + scalf = 1.0 + + ! Check if the element should be scaled + do idx=eel%list_S_P_D%ri(j), eel%list_S_P_D%ri(j+1)-1 + if(eel%list_S_P_D%ci(idx) == i) then + to_scale = .true. + exit + end if + end do + + !If it should set the correct variables + if(to_scale) then + to_do = eel%todo_S_P_D(idx) + scalf = eel%scalef_S_P_D(idx) + end if + end if + + + if(to_do) then + call damped_coulomb_kernel(eel, eel%polar_mm(i), j, & + ikernel, kernel, dr) + + if(do_V) tmpV = 0.0_rp + if(do_E) tmpE = 0.0_rp + if(do_Egrd) tmpEgr = 0.0_rp + if(do_EHes) tmpHE = 0.0_rp + + call mu_elec_prop(eel%ipd(:,i, knd), dr, kernel, & + do_V, tmpV, & + do_E, tmpE, & + do_Egrd, tmpEgr, & + do_EHes, tmpHE) + if(to_scale) then + if(do_V) eel%V_D2M(j) = eel%V_D2M(j) + tmpV * scalf + if(do_E) eel%E_D2M(:, j) = eel%E_D2M(:, j) + tmpE * scalf + if(do_Egrd) eel%Egrd_D2M(:, j) = eel%Egrd_D2M(:, j) + tmpEgr * scalf + if(do_EHes) eel%EHes_D2M(:, j) = eel%EHes_D2M(:, j) + tmpHE * scalf + else + if(do_V) eel%V_D2M(j) = eel%V_D2M(j) + tmpV + if(do_E) eel%E_D2M(:, j) = eel%E_D2M(:, j) + tmpE + if(do_Egrd) eel%Egrd_D2M(:, j) = eel%Egrd_D2M(:, j) + tmpEgr + if(do_EHes) eel%EHes_D2M(:, j) = eel%EHes_D2M(:, j) + tmpHE + end if + end if + end do + end do + else + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,idx,dr,kernel,to_do,to_scale,scalf,tmpV,tmpE,tmpEgr,tmpHE) + do j=1, top%mm_atoms + ! loop on sources + do i=1, eel%pol_atoms + if(eel%polar_mm(i) == j) cycle + !loop on target + to_do = .true. + to_scale = .false. + scalf = 1.0 + + ! Check if the element should be scaled + do idx=eel%list_S_P_P%ri(j), eel%list_S_P_P%ri(j+1)-1 + if(eel%list_S_P_P%ci(idx) == i) then + to_scale = .true. + exit + end if + end do + + !If it should set the correct variables + if(to_scale) then + to_do = eel%todo_S_P_P(idx) + scalf = eel%scalef_S_P_P(idx) + end if + + if(to_do) then + call damped_coulomb_kernel(eel, eel%polar_mm(i), j, & + ikernel, kernel, dr) + + if(do_V) tmpV = 0.0_rp + if(do_E) tmpE = 0.0_rp + if(do_Egrd) tmpEgr = 0.0_rp + if(do_EHes) tmpHE = 0.0_rp + + call mu_elec_prop(eel%ipd(:,i, knd), dr, kernel, & + do_V, tmpV, & + do_E, tmpE, & + do_Egrd, tmpEgr, & + do_EHes, tmpHE) + if(to_scale) then + if(do_V) eel%V_D2M(j) = eel%V_D2M(j) + tmpV * scalf + if(do_E) eel%E_D2M(:, j) = eel%E_D2M(:, j) + tmpE * scalf + if(do_Egrd) eel%Egrd_D2M(:, j) = eel%Egrd_D2M(:, j) + tmpEgr * scalf + if(do_EHes) eel%EHes_D2M(:, j) = eel%EHes_D2M(:, j) + tmpHE * scalf + else + if(do_V) eel%V_D2M(j) = eel%V_D2M(j) + tmpV + if(do_E) eel%E_D2M(:, j) = eel%E_D2M(:, j) + tmpE + if(do_Egrd) eel%Egrd_D2M(:, j) = eel%Egrd_D2M(:, j) + tmpEgr + if(do_EHes) eel%EHes_D2M(:, j) = eel%EHes_D2M(:, j) + tmpHE + end if + end if + end do + end do + end if + + end subroutine + + subroutine potential_D2E(eel, cpt, V, amoeba_P_insted_of_D_) + !! This subroutine computes the potential generated by the induced + !! point dipoles to a set of arbitrary coordinates, without applying + !! any screening rules. Note: for AMOEBA D dipoles should be used. + + implicit none + + type(ommp_electrostatics_type), intent(in) :: eel + !! Electrostatics data structure + real(rp), intent(inout) :: V(:) + !! Electric field (results will be added) + real(rp), intent(in) :: cpt(:,:) + !! Coordinates at which the electric field is requested + logical, optional, intent(in) :: amoeba_P_insted_of_D_ + !! For AMOEBA FF, if true the potential of P dipoles + !! is computed, otherwise potential of D dipoles is computed + + integer(ip) :: i, j, n_cpt + logical :: amoeba_P_insted_of_D + real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10) + + if(eel%pol_atoms < 1) return + + if(present(amoeba_P_insted_of_D_)) then + amoeba_P_insted_of_D = amoeba_P_insted_of_D_ + else + amoeba_P_insted_of_D = .false. + end if + + if(.not. eel%ipd_done) call fatal_error("IPD should be computed before& + & D2E potential.") + n_cpt = size(cpt, 2) + + if(eel%amoeba) then + if(.not. amoeba_P_insted_of_D) then + !$omp parallel do default(shared) schedule(dynamic) collapse(2) & + !$omp private(i,j,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) reduction(+:V) + do i=1, eel%pol_atoms + do j=1, n_cpt + dr = cpt(:,j) - eel%cpol(:,i) + call coulomb_kernel(dr, 2, kernel(1:2)) + tmpV = 0.0_rp + + call mu_elec_prop(eel%ipd(:,i,_amoeba_D_), & + dr, kernel, .true., tmpV, & + .false., tmpE, .false., tmpEgr, & + .false., tmpHE) + + V(j) = V(j) + tmpV + end do + end do + else + !$omp parallel do default(shared) schedule(dynamic) collapse(2) & + !$omp private(i,j,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) reduction(+:V) + do i=1, eel%pol_atoms + do j=1, n_cpt + dr = cpt(:,j) - eel%cpol(:,i) + call coulomb_kernel(dr, 2, kernel(1:2)) + tmpV = 0.0_rp + + call mu_elec_prop(eel%ipd(:,i,_amoeba_P_), & + dr, kernel, .true., tmpV, & + .false., tmpE, .false., tmpEgr, & + .false., tmpHE) + + V(j) = V(j) + tmpV + end do + end do + end if + else + !$omp parallel do default(shared) schedule(dynamic) collapse(2) & + !$omp private(i,j,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) reduction(+:V) + do i=1, eel%pol_atoms + ! loop on sources + do j=1, n_cpt + dr = cpt(:,j) - eel%cpol(:,i) + call coulomb_kernel(dr, 2, kernel(1:2)) + tmpV = 0.0_rp + + call mu_elec_prop(eel%ipd(:,i,1), & + dr, kernel, .true., tmpV, & + .false., tmpE, .false., tmpEgr, & + .false., tmpHE) + + V(j) = V(j) + tmpV + end do + end do + end if + end subroutine potential_D2E + + subroutine potential_M2E(eel, cpt, V) + !! This subroutine computes the potential generated by the static + !! multipoles to a set of arbitrary coordinates, without applying + !! any screening rules. + + implicit none + + type(ommp_electrostatics_type), intent(in) :: eel + !! Electrostatics data structure + real(rp), intent(inout) :: V(:) + !! Electric field (results will be added) + real(rp), intent(in) :: cpt(:,:) + !! Coordinates at which the electric field is requested + + integer(ip) :: i, j, n_cpt + real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10) + + n_cpt = size(cpt, 2) + + if(eel%amoeba) then + !$omp parallel do default(shared) schedule(dynamic) collapse(2) & + !$omp private(i,j,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) reduction(+:V) + do i=1, eel%top%mm_atoms + do j=1, n_cpt + dr = cpt(:,j) - eel%top%cmm(:,i) + call coulomb_kernel(dr, 2, kernel(1:3)) + tmpV = 0.0_rp + + call q_elec_prop(eel%q(1,i), dr, kernel, .true., tmpV, & + .false., tmpE, .false., tmpEgr, & + .false., tmpHE) + call mu_elec_prop(eel%q(2:4,i), dr, kernel, .true., tmpV, & + .false., tmpE, .false., tmpEgr, & + .false., tmpHE) + call quad_elec_prop(eel%q(5:10,i), dr, kernel, .true., tmpV, & + .false., tmpE, .false., tmpEgr, & + .false., tmpHE) + + V(j) = V(j) + tmpV + end do + end do + else + !$omp parallel do default(shared) schedule(dynamic) collapse(2) & + !$omp private(i,j,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) reduction(+:V) + do i=1, eel%top%mm_atoms + ! loop on sources + do j=1, n_cpt + dr = cpt(:,j) - eel%top%cmm(:,i) + call coulomb_kernel(dr, 1, kernel(1:2)) + tmpV = 0.0_rp + + call q_elec_prop(eel%q(1,i), dr, kernel, .true., tmpV, & + .false., tmpE, .false., tmpEgr, & + .false., tmpHE) + + V(j) = V(j) + tmpV + end do + end do + end if + end subroutine potential_M2E + + subroutine field_D2E(eel, cpt, E) + !! This subroutine computes the potential generated by the static + !! multipoles to a set of arbitrary coordinates, without applying + !! any screening rules. + + implicit none + + type(ommp_electrostatics_type), intent(in) :: eel + !! Electrostatics data structure + real(rp), intent(inout) :: E(:,:) + !! Electric field (results will be added) + real(rp), intent(in) :: cpt(:,:) + !! Coordinates at which the electric field is requested + + integer(ip) :: i, j, n_cpt + real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10) + + if(eel%pol_atoms < 1) return + + if(.not. eel%ipd_done) call fatal_error("IPD should be computed before& + & computing D2E field.") + n_cpt = size(cpt, 2) + + if(eel%amoeba) then + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) reduction(+:E) + do i=1, eel%pol_atoms + do j=1, n_cpt + dr = cpt(:,j) - eel%cpol(:,i) + call coulomb_kernel(dr, 3, kernel) + tmpE = 0.0_rp + !TODO + call mu_elec_prop(0.5*(eel%ipd(:,i, _amoeba_P_) + eel%ipd(:,i, _amoeba_D_)), dr, kernel, .false., tmpV, & + .true., tmpE, .false., tmpEgr, & + .false., tmpHE) + + E(:,j) = E(:,j) + tmpE + end do + end do + else + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) reduction(+:E) + do i=1, eel%pol_atoms + ! loop on sources + do j=1, n_cpt + dr = cpt(:,j) - eel%cpol(:,i) + call coulomb_kernel(dr, 3, kernel) + tmpE = 0.0_rp + + call mu_elec_prop(eel%ipd(:,i,1), dr, kernel, .false., tmpV, & + .true., tmpE, .false., tmpEgr, & + .false., tmpHE) + + E(:,j) = E(:,j) + tmpE + end do + end do + end if + end subroutine field_D2E + + subroutine field_M2E(eel, cpt, E) + !! This subroutine computes the potential generated by the static + !! multipoles to a set of arbitrary coordinates, without applying + !! any screening rules. + + implicit none + + type(ommp_electrostatics_type), intent(in) :: eel + !! Electrostatics data structure + real(rp), intent(inout) :: E(:,:) + !! Electric field (results will be added) + real(rp), intent(in) :: cpt(:,:) + !! Coordinates at which the electric field is requested + + integer(ip) :: i, j, n_cpt + real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10) + + n_cpt = size(cpt, 2) + + if(eel%amoeba) then + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,dr,kernel,tmpE,tmpV,tmpEgr,tmpHE) reduction(+:E) + do i=1, eel%top%mm_atoms + do j=1, n_cpt + dr = cpt(:,j) - eel%top%cmm(:,i) + call coulomb_kernel(dr, 4, kernel) + tmpE = 0.0_rp + + call q_elec_prop(eel%q(1,i), dr, kernel, .false., tmpV, & + .true., tmpE, .false., tmpEgr, & + .false., tmpHE) + call mu_elec_prop(eel%q(2:4,i), dr, kernel, .false., tmpV, & + .true., tmpE, .false., tmpEgr, & + .false., tmpHE) + call quad_elec_prop(eel%q(5:10,i), dr, kernel, .false., tmpV, & + .true., tmpE, .false., tmpEgr, & + .false., tmpHE) + + E(:,j) = E(:,j) + tmpE + end do + end do + else + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,dr,kernel,tmpE,tmpV,tmpEgr,tmpHE) reduction(+:E) + do i=1, eel%top%mm_atoms + ! loop on sources + do j=1, n_cpt + dr = cpt(:,j) - eel%top%cmm(:,i) + call coulomb_kernel(dr, 2, kernel) + tmpE = 0.0_rp + + call q_elec_prop(eel%q(1,i), dr, kernel, .false., tmpV, & + .true., tmpE, .false., tmpEgr, & + .false., tmpHE) + + E(:,j) = E(:,j) + tmpE + end do + end do + end if + end subroutine field_M2E + + function screening_rules(eel, i, kind_i, j, kind_j, in_field) result(scalf) + !! Utility function used to decide if an interaction between sites i and j + !! should be computed and eventually scaled by a factor. + !! This function is intended to be used in \(\mathcalO(n^2)\) code, for + !! linear scaling code lists should be built. + !! This is written to minimize code repetitions, all the screening rules + !! are handled in two possible cases: + !! 1. rules based on adjacency matrix + !! 2. rules based on AMOEBA polarization groups + + use mod_constants, only: eps_rp + + type(ommp_electrostatics_type), intent(in) :: eel + !! Electrostatics object + integer(ip), intent(in) :: i + !! Index of source site (MM index is used for static sites, while + !! Pol index is used for polarizable sites) + integer(ip), intent(in) :: j + !! Index of target site (MM index is used for static sites, while + !! Pol index is used for polarizable sites) + character, intent(in) :: in_field + !! Which screening rules have to be applied? 'D' = screening rules + !! for direct field; 'P' = screening rules for polarization field + character, intent(in) :: kind_i, kind_j + !! Type of sites i and j in the interaction for which the screening + !! rules are required; possible choices are 'P' (polarizable site) or + !! 'S' (static site). Any other option will cause a fatal error. + real(rp) :: scalf + !! Scale factor for the interaction + + integer(ip) :: ineigh, grp, igrp, pg_i + integer(ip) :: j_mm, i_mm + character :: field, interaction + logical :: amoeba + type(ommp_topology_type), pointer :: top + real(rp) :: myscale(4), myscale_intra(4) + + ! Some shortcut + top => eel%top + amoeba = eel%amoeba + + ! Decide which kind of rule should be used + if(kind_i == 'P') then + i_mm = eel%polar_mm(i) + else if(kind_i == 'S') then + i_mm = i + else + call fatal_error('Unexpected value of kind_i in screening_rules') + i_mm = 0 + end if + + if(kind_j == 'P') then + j_mm = eel%polar_mm(j) + else if(kind_j == 'S') then + j_mm = j + else + call fatal_error('Unexpected value of kind_j in screening_rules') + j_mm = 0 + end if + + myscale = 0.0_rp + if(kind_j == 'P' .and. kind_i == 'P') then + ! Use IPD-IPD screening rules + myscale = eel%uscale + interaction = 'P' !Pol-pol interaction is named P + else if(kind_j == 'S' .and. kind_i == 'S') then + ! Use static multipoles-static multipoles screening rules + myscale = eel%mscale + field = '-' + interaction = 'S' !Static-static interaction is named S + else + ! Use static multipoles-IPD screening rules + if(in_field == 'P' .and. amoeba) then + myscale = eel%pscale + myscale_intra = eel%pscale_intra + field = 'P' + else if(in_field == 'D' .and. amoeba) then + myscale = eel%dscale + field = 'D' + else if(.not. amoeba) then + myscale = eel%pscale + field = 'P' + else + call fatal_error('Unexpected value of field in screening rules') + end if + interaction = 'M' !Mixed interaction is named M + end if + + ! Default return value + scalf = 1.0_rp + + if((.not. amoeba) .or. & + (amoeba .and. interaction == 'M' .and. field == 'P') .or. & + (amoeba .and. interaction == 'S')) then + ! Screening rules based on connectivity matrix: + ! 1. all the ones of non-amoeba FF, + ! 2. the static to IPD polarization field + ! 3. the static-static interaction of AMOEBA + do ineigh=1,4 + ! Look if j is at distance ineigh from i + if(any(top%conn(ineigh)%ci(top%conn(ineigh)%ri(i_mm): & + top%conn(ineigh)%ri(i_mm+1)-1) == j_mm)) then + + if(interaction == 'M' .and. amoeba) then + ! Amoeba uses two different screening rules for atoms + ! of the same group and for atoms of different group + if(eel%mmat_polgrp(i_mm) == eel%mmat_polgrp(j_mm)) then + scalf = myscale_intra(ineigh) + else + scalf = myscale(ineigh) + end if + else + ! In any other case just use the scale factor for this + ! distance + scalf = myscale(ineigh) + end if + + ! Exit the loop + exit + + end if + end do + else if((amoeba .and. interaction == 'M' .and. field == 'D') .or. & + (amoeba .and. interaction == 'P')) then + ! Screening rules based on polarization groups: + ! 1. the static to IPD direct field + ! 2. the IPD to IPD interaction of AMOEBA + pg_i = eel%mmat_polgrp(i_mm) + + outer: do ineigh=1,4 + do igrp=eel%pg_conn(ineigh)%ri(pg_i), & + eel%pg_conn(ineigh)%ri(pg_i+1)-1 + ! Indexes of groups at distance ineigh from group pg_i + grp = eel%pg_conn(ineigh)%ci(igrp) + + if(any(eel%polgrp_mmat%ci(eel%polgrp_mmat%ri(grp): & + eel%polgrp_mmat%ri(grp+1)-1) == j_mm)) then + ! If atom j is in a group at distance ineigh from the + ! one of atom i, the field is scaled according to dscale + scalf = myscale(ineigh) + exit outer + end if + end do + end do outer + else + ! Unexpected error + call fatal_error("Unexpected combination of parameter for screening_rules") + end if + + end function screening_rules + +end module mod_electrostatics diff --git a/src/mod_electrostatics.f90 b/src/mod_electrostatics.f90 deleted file mode 100644 index 9eb083d..0000000 --- a/src/mod_electrostatics.f90 +++ /dev/null @@ -1,2472 +0,0 @@ -#include "f_cart_components.h" -module mod_electrostatics - use mod_io, only: fatal_error, ommp_message - use mod_constants, only: OMMP_VERBOSE_DEBUG - use mod_profiling, only: time_push, time_pull - use mod_memory, only: ip, rp, lp - use mod_adjacency_mat, only: yale_sparse - use mod_topology, only: ommp_topology_type - - !! TODO Check the signs in electrostatic elemental functions - !! TODO [OPT] Use Laplace equation to simplify the calculations: - !! TODO 1. Egrd(_zz_) = -(Egrd(_xx_) + Egrd(_yy_)) - !! TODO 2. EHes(_zzz_) = -(EHes(_xxz_) + EHes(_yyz_)) - !! TODO 3. EHes(_zzx_) = -(EHes(_xxx_) + EHes(_yyx_)) - !! TODO 4. EHes(_zzy_) = -(EHes(_xxy_) + EHes(_yyy_)) - !! TODO [OPT] Fundamental electrostatic functions should be pure/elemental - !! TODO [BUG] Handling of flags gg - implicit none - private - - type ommp_electrostatics_type - integer(ip) :: def_solver - !! Solver to be used by default for this eel object. - integer(ip) :: def_matv - !! Matrix-vector method to be used by default for this eel object. - - type(ommp_topology_type), pointer :: top - !! Data structure containing all the topological informations - integer(ip) :: pol_atoms - !! number of polarizable atoms - logical(lp) :: amoeba - !! True if AMOEBA FF is used - integer(ip) :: ld_cart, ld_cder - !! size of the cartesian multipolar distribution (i.e., (l+1)*(l+2)*(l+3)/6) - !! this is 1 for AMBER (charges only), 10 for AMOEBA (up to quadrupoles). - !! this is also the size of the array that contains the electrostatic properties - !! of the sources at the sources. ld_cder is the leading size of the derivative of - !! such a distribution, which is 3 for AMBER and 19 for AMOEBA. - integer(ip) :: n_ipd - !! number of induced point dipoles distributions - !! this is 1 for AMBER and 2 for AMOEBA - - real(rp) :: mscale(4) - !! factors for charge-charge (or multipole-multipole) interactions - - real(rp) :: pscale(4) - !! factors for chrage-ipd (or multipole-ipd) interactions. - !! in AMOEBA, this is used to define the polarization field, i.e., the right-hand - !! side to the polarization equations, and depends on the connectivity. - - real(rp) :: pscale_intra(4) - !! Only used for AMOEBA, same as pscale but for atoms that belong to the - !! same polarization group - - real(rp) :: dscale(4) - !! factors for multipoles-ipd interactions used to compute the direct field, - !! which is used to define the polarization energy. these factors depend on - !! the polarization group "connectivity" (AMOEBA only) - - real(rp) :: uscale(4) - !! factor for ipd-ipd interactions. these depend on the connectivity (AMBER) - !! or on the polarization group " connectivity (AMOEBA) - - ! allocatable arrays which describe the polarizable system - - real(rp), allocatable :: thole(:) - !! array to store the thole factors for computing damping functions - - real(rp) :: thole_scale - !! Scale factor for thole damping (only used by non-AMOEBA FF); all - !! the element of thole(:) are multiplied by thole_scale ** 0.5 - - real(rp), allocatable :: cpol(:,:) - !! Coordinates of polarizable atoms (3:pol_atoms) - - real(rp), allocatable :: q(:,:) - !! Mutlipolar distribution (ld_cart:mm_atoms) - !! For AMOEBA this is the rotated distribution. - !! The order for the stored multipoles is - !! q, px, py, pz, Qxx, Qxy, Qyy, Qxz, Qyx, Qzz. - - real(rp), allocatable :: q0(:,:) - !! Unrotated utlipolar distribution (ld_cart:mm_atoms) - !! (AMOEBA only) - - real(rp), allocatable :: pol(:) - !! Polarizabilities for each polarizable atom - - integer(ip), allocatable :: mm_polar(:) - !! for each mm atom: 0 if is not polarizable, index in - !! polarizable atom list otherwise - - integer(ip), allocatable :: polar_mm(:) - !! positions of a polarizable atom in the mm atoms list - - integer(ip), allocatable :: C_polar_mm(:) - !! [[polar_mm]] with 0-based C-indexing, only allocated at need. - - integer(ip), allocatable :: mmat_polgrp(:) - !! Polarizability group index for each MM site - - type(yale_sparse) :: polgrp_mmat - !! For each polarization group index, list all the MM atoms included. - !! It basically is a sparse boolean matrix of dimension - !! N_polgroups x N_mmatoms - - type(yale_sparse), allocatable :: pg_conn(:) - !! Adjacency and connectivity matytrices between polarizability groups. - !! Two groups are said to be adjacent if they are connected by a chemical - !! bond. The 1st element is the identity matrix for code simplicity. - - ! parameters for the definition of the rotation matrices for the multipoles: - integer(ip), allocatable :: mol_frame(:) - !! definition of the molecular frame - !! convention: 0 ... do not rotate - !! 1 ... z-then-x - !! 2 ... bisector - !! 3 ... z-only - !! 4 ... z-bisector - !! 5 ... 3-fold - - integer(ip), allocatable :: ix(:), iy(:), iz(:) - !! neighboring atoms used to define the axes of the molecular frame - - !- Intermediate data allocate here -! - logical(lp) :: M2M_done = .false. - !! flag to set when M2M electrostatic quantities are computed. - logical(lp) :: M2Mgg_done = .false. - !! flag to set when M2M electrostatic quantities for geometrical - !! gradients are computed. - real(rp), allocatable :: V_M2M(:) - !! potential of MM permanent multipoles at MM sites; - real(rp), allocatable :: E_M2M(:,:) - !! electric_field of MM permanent multipoles at MM sites; - real(rp), allocatable :: Egrd_M2M(:,:) - !! electric_field gradient of MM permanent multipoles at MM sites; - real(rp), allocatable :: EHes_M2M(:,:) - !! electric field Hessian of MM permanent multipoles at MM sites; - - logical(lp) :: M2D_done = .false. - !! Flag to set when M2D electrostatics have been computed. - logical(lp) :: M2Dgg_done = .false. - !! Flag to set when M2D electrostatics for geometrical gradients - !! have been computed. - real(rp), allocatable :: V_M2D(:,:) - ! electrostatic potential of MM permanent multipoles at POL sites; unused. - real(rp), allocatable :: E_M2D(:,:,:) ! TODO the third dimension is used? - !! electric field of MM permanent multipoles at POL sites; - real(rp), allocatable :: Egrd_M2D(:,:,:) - !! electric field of MM permanent multipoles at POL sites; - real(rp), allocatable :: EHes_M2D(:,:,:) - ! electric field Hessian of MM permanent multipoles at POL sites; unused. - - logical(lp) :: D2Mgg_done = .false. - real(rp), allocatable :: V_D2M(:) - real(rp), allocatable :: E_D2M(:,:) - real(rp), allocatable :: Egrd_D2M(:,:) - real(rp), allocatable :: EHes_D2M(:,:) - - logical(lp) :: D2Dgg_done = .false. - real(rp), allocatable :: V_D2D(:,:) - real(rp), allocatable :: E_D2D(:,:,:) - real(rp), allocatable :: Egrd_D2D(:,:,:) - real(rp), allocatable :: EHes_D2D(:,:,:) - - logical(lp) :: ipd_done = .false. - !! Flag to set when IPD have been computed. - logical(lp) :: ipd_use_guess = .false. - !! Flag to set when current value of IPD can be - !! used as guess for next solution of LS. - real(rp), allocatable :: ipd(:,:,:) - !! induced point dipoles (3:pol_atoms:ipd) - - real(rp), allocatable :: TMat(:,:) - !! Interaction tensor, only allocated for the methods that explicitly - !! requires it. - - logical(lp) :: screening_list_done = .false. - !! Flag to check if screening list have already been prepared - type(yale_sparse), allocatable :: list_S_S, list_P_P, list_S_P_P, list_S_P_D - !! Sparse matrix containg the scale factors for the scaled elements - !! of electrostatic interactions (all the element that are not - !! present in the sparse matrix have a scaling factor 1.0). - logical(lp), dimension(:), allocatable :: todo_S_S, todo_P_P, todo_S_P_P, todo_S_P_D - !! Logical array of the same dimension of column-index vector; true if - !! the scaling factor is zero, false otherwise - real(rp), dimension(:), allocatable :: scalef_S_S, scalef_P_P, & - scalef_S_P_P, scalef_S_P_D - !! Array of the same dimension of column-index vector; contains the - !! value of the scaling factors different from 1.0 - end type ommp_electrostatics_type - - public :: ommp_electrostatics_type - public :: electrostatics_init, electrostatics_terminate - public :: set_def_solver, set_def_matv - public :: thole_init, remove_null_pol, set_screening_parameters - public :: screening_rules, make_screening_lists - public :: damped_coulomb_kernel, field_extD2D - public :: energy_MM_MM, energy_MM_pol - public :: prepare_fixedelec, prepare_polelec - public :: q_elec_prop, coulomb_kernel - public :: potential_M2E, potential_D2E - public :: field_M2E, field_D2E - - contains - - subroutine electrostatics_init(eel_obj, amoeba, pol_atoms, top_obj) - use mod_memory, only: mallocate - use mod_constants, only: OMMP_MATV_DEFAULT, OMMP_SOLVER_DEFAULT - - implicit none - - logical(lp), intent(in) :: amoeba - integer(ip), intent(in) :: pol_atoms - type(ommp_topology_type), intent(in), target :: top_obj - type(ommp_electrostatics_type), intent(inout) :: eel_obj - - integer(ip) :: mm_atoms - - mm_atoms = top_obj%mm_atoms - eel_obj%amoeba = amoeba - eel_obj%pol_atoms = pol_atoms - eel_obj%top => top_obj - eel_obj%def_solver = OMMP_SOLVER_DEFAULT - eel_obj%def_matv = OMMP_MATV_DEFAULT - - if(amoeba) then - eel_obj%ld_cart = 10_ip - eel_obj%ld_cder = 19_ip - eel_obj%n_ipd = 2_ip - else - eel_obj%ld_cart = 1_ip - eel_obj%ld_cder = 3_ip - eel_obj%n_ipd = 1_ip - endif - - call mallocate('electrostatics_init [q]', eel_obj%ld_cart, & - mm_atoms, eel_obj%q) - call mallocate('electrostatics_init [pol]', eel_obj%pol_atoms, & - eel_obj%pol) - call mallocate('electrostatics_init [cpol]', 3_ip, eel_obj%pol_atoms, & - eel_obj%cpol) - call mallocate('electrostatics_init [polar_mm]', eel_obj%pol_atoms, & - eel_obj%polar_mm) - call mallocate('electrostatics_init [mm_polar]', mm_atoms, & - eel_obj%mm_polar) - call mallocate('electrostatics_init [thole]', mm_atoms, & - eel_obj%thole) - - call mallocate('electrostatics_init [idp]', 3_ip, eel_obj%pol_atoms, & - eel_obj%n_ipd, eel_obj%ipd) - eel_obj%ipd_done = .false. - eel_obj%ipd = 0.0_rp - - if (eel_obj%amoeba) then - ! Extra quantities that should be allocated only - ! for AMOEBA - call mallocate('electrostatics_init [q0]', eel_obj%ld_cart, & - mm_atoms, eel_obj%q0) - - call mallocate('electrostatics_init [mmat_polgrp]', & - mm_atoms, eel_obj%mmat_polgrp) - - call mallocate('electrostatics_init [mol_frame]', & - mm_atoms, eel_obj%mol_frame) - call mallocate('electrostatics_init [ix]', mm_atoms, eel_obj%ix) - call mallocate('electrostatics_init [iy]', mm_atoms, eel_obj%iy) - call mallocate('electrostatics_init [iz]', mm_atoms, eel_obj%iz) - end if - - end subroutine electrostatics_init - - subroutine electrostatics_terminate(eel_obj) - use mod_memory, only: mfree - use mod_adjacency_mat, only: matfree - - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel_obj - integer(ip) :: i - - call mfree('electrostatics_terminate [q]', eel_obj%q) - call mfree('electrostatics_terminate [pol]', eel_obj%pol) - call mfree('electrostatics_terminate [cpol]', eel_obj%cpol) - call mfree('electrostatics_terminate [polar_mm]', eel_obj%polar_mm) - call mfree('electrostatics_terminate [mm_polar]', eel_obj%mm_polar) - call mfree('electrostatics_terminate [thole]', eel_obj%thole) - call mfree('electrostatics_terminate [idp]', eel_obj%ipd) - - if (eel_obj%amoeba) then - call mfree('electrostatics_terminate [q0]', eel_obj%q0) - call mfree('electrostatics_terminate [mmat_polgrp]', & - eel_obj%mmat_polgrp) - if(allocated(eel_obj%pg_conn)) then - do i=1, size(eel_obj%pg_conn) - call matfree(eel_obj%pg_conn(i)) - end do - deallocate(eel_obj%pg_conn) - end if - - call matfree(eel_obj%polgrp_mmat) - call mfree('electrostatics_terminate [mol_frame]', & - eel_obj%mol_frame) - call mfree('electrostatics_terminate [ix]', eel_obj%ix) - call mfree('electrostatics_terminate [iy]', eel_obj%iy) - call mfree('electrostatics_terminate [iz]', eel_obj%iz) - end if - - call mfree('electrostatics_terminate [E_M2D]', eel_obj%E_M2D) - call mfree('electrostatics_terminate [V_M2M]', eel_obj%V_M2M) - call mfree('electrostatics_terminate [E_M2M]', eel_obj%E_M2M) - call mfree('electrostatics_terminate [Egrd_M2M]', eel_obj%Egrd_M2M) - - if(allocated(eel_obj%todo_S_S)) deallocate(eel_obj%todo_S_S) - if(allocated(eel_obj%todo_P_P)) deallocate(eel_obj%todo_P_P) - call mfree('electrostatics_terminate [scalef_S_S]', eel_obj%scalef_S_S) - call mfree('electrostatics_terminate [scalef_P_P]', eel_obj%scalef_P_P) - if(allocated(eel_obj%list_S_S)) then - call matfree(eel_obj%list_S_S) - deallocate(eel_obj%list_S_S) - end if - if(allocated(eel_obj%list_P_P)) then - call matfree(eel_obj%list_P_P) - deallocate(eel_obj%list_P_P) - end if - - end subroutine electrostatics_terminate - - subroutine set_def_solver(eel_obj, solver) - use mod_constants, only: OMMP_SOLVER_CG, OMMP_SOLVER_INVERSION, OMMP_SOLVER_DIIS - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel_obj - integer(ip), intent(in) :: solver - - if(solver /= OMMP_SOLVER_CG .and. & - solver /= OMMP_SOLVER_INVERSION .and. & - solver /= OMMP_SOLVER_DIIS) & - call fatal_error("Unrecognized setting for default solver method") - eel_obj%def_solver = solver - end subroutine - - subroutine set_def_matv(eel_obj, matv) - use mod_constants, only: OMMP_MATV_INCORE, OMMP_MATV_DIRECT - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel_obj - integer(ip), intent(in) :: matv - - if(matv /= OMMP_MATV_INCORE .and. & - matv /= OMMP_MATV_DIRECT) & - call fatal_error("Unrecognized setting for default matrix-vector method") - eel_obj%def_matv = matv - end subroutine - - subroutine set_screening_parameters(eel_obj, m, p, d, u, i) - !! Subroutine to initialize the screening parameters - - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel_obj - real(rp), intent(in) :: m(4), p(4), d(4), u(4) - real(rp), optional, intent(in) :: i(4) - - eel_obj%mscale = m - eel_obj%pscale = p - eel_obj%dscale = d - eel_obj%uscale = u - - if(present(i)) then - if(eel_obj%amoeba) then - eel_obj%pscale_intra = i - else - call fatal_error("Scale factors for atoms of the same group & - &cannot be set outside AMOEBA FF") - end if - else - if(eel_obj%amoeba) & - call fatal_error("Scale factors for atoms of the same group & - &should be defined in AMOEBA FF") - end if - - end subroutine set_screening_parameters - - subroutine remove_null_pol(eel) - !! Check which polarizabilities are close enough to 0 to be - !! just excluded from the calculation, and remove them. - - use mod_constants, only: OMMP_STR_CHAR_MAX, OMMP_VERBOSE_LOW, eps_rp - use mod_memory, only: mallocate, mfree - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel - integer(ip), allocatable :: idx(:), polar_mm(:) - integer(ip) :: i, nidx - real(rp), allocatable :: tmp(:) - character(len=OMMP_STR_CHAR_MAX) :: msg - - if(eel%pol_atoms > 0 .and. allocated(eel%pol)) then - call mallocate('remove_null_pol [idx]', eel%pol_atoms, idx) - nidx = 0 - do i=1, eel%pol_atoms - if(abs(eel%pol(i)) > eps_rp) then - nidx = nidx + 1 - idx(nidx) = i - end if - end do - - if(nidx < eel%pol_atoms) then - write(msg, '(A,I0,A,I0)') "Removing ", eel%pol_atoms - nidx, & - " polarizabilities out of ", eel%pol_atoms - call ommp_message(msg, OMMP_VERBOSE_LOW) - call mallocate('remove_null_pol [tmp]', eel%pol_atoms, tmp) - ! Polarizabilities - tmp = eel%pol - call mfree('remove_null_pol [eel%pol]', eel%pol) - call mallocate('remove_null_pol [eel%pol]', nidx, eel%pol) - do i=1, nidx - eel%pol(i) = tmp(idx(i)) - end do - call mfree('remove_null_pol [tmp]', tmp) - - call mallocate('remove_null_pol [polar_mm]', eel%pol_atoms, polar_mm) - polar_mm = eel%polar_mm - call mfree('remove_null_pol [eel%polar_mm]', eel%polar_mm) - call mallocate('remove_null_pol [eel%polar_mm]', nidx, eel%polar_mm) - call mfree('remove_null_pol [eel%cpol]', eel%cpol) - call mallocate('remove_null_pol [eel%cpol]', 3, nidx, eel%cpol) - eel%mm_polar = 0 - do i=1, nidx - eel%polar_mm(i) = polar_mm(idx(i)) - eel%mm_polar(eel%polar_mm(i)) = i - eel%cpol(:,i) = eel%top%cmm(:,eel%polar_mm(i)) - end do - - call mfree('remove_null_pol [polar_mm]', polar_mm) - - eel%pol_atoms = nidx - call mfree('remove_null_pol [eel%ipd]', eel%ipd) - call mallocate('electrostatics_init [idp]', 3_ip, eel%pol_atoms, & - eel%n_ipd, eel%ipd) - eel%ipd_done = .false. - eel%ipd_use_guess = .false. - eel%ipd = 0.0_rp - - call ommp_message("Removing null polarizable sites done", OMMP_VERBOSE_LOW) - end if - - call mfree('remove_null_pol [idx]', idx) - end if - - end subroutine - - subroutine make_screening_lists(eel) - use mod_memory, only: mallocate, mfree - use mod_adjacency_mat, only: compress_list, compress_data - use mod_constants, only: eps_rp - - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel - - integer(ip) :: i, ineigh, ij, j, ns, ns_guess, n, npol, & - ipp, jp, ns_guess_grp, pg_i, igrp, grp, ib, ie - logical :: to_do, to_scale - real(rp) :: scalf - integer(ip), allocatable :: itmp(:,:), ntmp(:) - real(rp), allocatable :: rtmp(:,:) - - if(eel%screening_list_done) return - - n = eel%top%mm_atoms - npol = eel%pol_atoms - - ! First estimate the maximum number of elements to scale - ns_guess = 0 - !$omp parallel do default(shared) private(ns, ineigh, i) - do i=1, n - ns = 0 - do ineigh=1, 4 - ns = ns + eel%top%conn(ineigh)%ri(i+1) - eel%top%conn(ineigh)%ri(i) - end do - !$omp atomic - ns_guess = max(ns, ns_guess) - end do - - if(eel%amoeba) then - ! If amoeba is used, some scaling (D-field) are performed using - ! polarization group, so a second guess should be done and the - ! maximum is used in memory allocation. - ns_guess_grp = 0 - - !$omp parallel do default(shared) & - !$omp private(i, pg_i, ineigh, igrp, grp, ns) - do i=1, n - pg_i = eel%mmat_polgrp(i) - ns = 0 - do ineigh=1, 4 - do igrp=eel%pg_conn(ineigh)%ri(pg_i), & - eel%pg_conn(ineigh)%ri(pg_i+1)-1 - - grp = eel%pg_conn(ineigh)%ci(igrp) - ns = ns + eel%polgrp_mmat%ri(grp+1)-eel%polgrp_mmat%ri(grp) - end do - end do - !$omp atomic - ns_guess_grp = max(ns, ns_guess_grp) - end do - - ns_guess = max(ns_guess_grp, ns_guess) - end if - - allocate(eel%list_S_S) - allocate(eel%list_P_P) - allocate(eel%list_S_P_P) - if(eel%amoeba) allocate(eel%list_S_P_D) - - !allocate(ltmp(ns_guess)) - call mallocate('make_screening_list [rtmp]', ns_guess, n, rtmp) - call mallocate('make_screening_list [itmp]', ns_guess, n, itmp) - call mallocate('make_screening_list [ntmp]', n, ntmp) - - - ! Build S S list - !$omp parallel do schedule(dynamic) default(shared) & - !$omp private(i,ineigh,ij,j, scalf) - do i=1, n - ntmp(i) = 0 - do ineigh=1, 4 - do ij=eel%top%conn(ineigh)%ri(i), eel%top%conn(ineigh)%ri(i+1)-1 - j = eel%top%conn(ineigh)%ci(ij) - scalf = screening_rules(eel, i, 'S', j, 'S', '-') - if(abs(scalf-1.0) > eps_rp) then - ntmp(i) = ntmp(i) + 1 - itmp(ntmp(i),i) = j - rtmp(ntmp(i),i) = scalf - end if - end do - end do - end do - - ! Compress the list - call compress_list(n, itmp, ntmp, eel%list_S_S) - call compress_data(eel%list_S_S, rtmp, eel%scalef_S_S) - call mallocate('make_screening_list [todo_S_S]', & - size(eel%scalef_S_S), eel%todo_S_S) - !$omp parallel do - do i=1, size(eel%scalef_S_S) - eel%todo_S_S(i) = (abs(eel%scalef_S_S(i)) > eps_rp) - end do - - ! Build P P list - ntmp = 0 - !$omp parallel do schedule(dynamic) default(shared) & - !$omp private(ipp,i,ineigh,ij,j,jp,scalf) - do ipp=1, npol - i = eel%polar_mm(ipp) - do ineigh=1, 4 - do ij=eel%top%conn(ineigh)%ri(i), eel%top%conn(ineigh)%ri(i+1)-1 - j = eel%top%conn(ineigh)%ci(ij) - jp = eel%mm_polar(j) - if(jp > 0) then - scalf = screening_rules(eel, ipp, 'P', jp, 'P', '-') - if(abs(scalf-1.0) > eps_rp) then - ntmp(ipp) = ntmp(ipp) + 1 - itmp(ntmp(ipp),ipp) = jp - rtmp(ntmp(ipp),ipp) = scalf - end if - end if - end do - end do - end do - - ! Compress the list - call compress_list(npol, itmp, ntmp(1:npol), eel%list_P_P) - call compress_data(eel%list_P_P, rtmp, eel%scalef_P_P) - call mallocate('make_screening_list [todo_P_P]', & - size(eel%scalef_P_P), eel%todo_P_P) - !$omp parallel do - do i=1, size(eel%scalef_P_P) - eel%todo_P_P(i) = (abs(eel%scalef_P_P(i)) > eps_rp) - end do - - ! Build S P lists - !$omp parallel do schedule(dynamic) default(shared) & - !$omp private(i,ineigh,ij,j,jp,scalf) - do i=1, n - ntmp(i) = 0 - do ineigh=1, 4 - do ij=eel%top%conn(ineigh)%ri(i), eel%top%conn(ineigh)%ri(i+1)-1 - j = eel%top%conn(ineigh)%ci(ij) - jp = eel%mm_polar(j) - if(jp > 0) then - ! Needed for either amoeba or amber - scalf = screening_rules(eel, i, 'S', jp, 'P', 'P') - if(abs(scalf-1.0) > eps_rp) then - ntmp(i) = ntmp(i) + 1 - itmp(ntmp(i),i) = jp - rtmp(ntmp(i),i) = scalf - end if - end if - end do - end do - end do - - ! Compress the list - call compress_list(n, itmp, ntmp, eel%list_S_P_P) - call compress_data(eel%list_S_P_P, rtmp, eel%scalef_S_P_P) - call mallocate('make_screening_list [todo_S_P_P]', & - size(eel%scalef_S_P_P), eel%todo_S_P_P) - !$omp parallel do - do i=1, size(eel%scalef_S_P_P) - eel%todo_S_P_P(i) = (abs(eel%scalef_S_P_P(i)) > eps_rp) - end do - - if(eel%amoeba) then - !$omp parallel do schedule(dynamic) default(shared) & - !$omp private(i,ineigh,ij,j,jp,scalf,pg_i,igrp,grp) - do i=1, n - ntmp(i) = 0 - pg_i = eel%mmat_polgrp(i) - - do ineigh=1, 4 - do igrp=eel%pg_conn(ineigh)%ri(pg_i), & - eel%pg_conn(ineigh)%ri(pg_i+1)-1 - - grp = eel%pg_conn(ineigh)%ci(igrp) - - do j=eel%polgrp_mmat%ri(grp), & - eel%polgrp_mmat%ri(grp+1)-1 - jp = eel%mm_polar(j) - if(jp > 0) then - scalf = screening_rules(eel, i, 'S', jp, 'P', 'D') - if(abs(scalf-1.0) > eps_rp) then - ntmp(i) = ntmp(i) + 1 - itmp(ntmp(i),i) = jp - rtmp(ntmp(i),i) = scalf - end if - end if - end do - end do - end do - end do - - ! Compress the list - call compress_list(n, itmp, ntmp, eel%list_S_P_D) - call compress_data(eel%list_S_P_D, rtmp, eel%scalef_S_P_D) - call mallocate('make_screening_list [todo_S_P_D]', & - size(eel%scalef_S_P_D), eel%todo_S_P_D) - !$omp parallel do - do i=1, size(eel%scalef_S_P_D) - eel%todo_S_P_D(i) = (abs(eel%scalef_S_P_D(i)) > eps_rp) - end do - end if - - eel%screening_list_done = .true. - - call mfree('make_screening_list [rtmp]', rtmp) - call mfree('make_screening_list [itmp]', itmp) - call mfree('make_screening_list [ntmp]', ntmp) - end subroutine - - subroutine thole_init(eel) - ! This routine compute the thole factors and stores - ! them in a vector. TODO add reference - ! TODO in AMOEBA should be read from FF - - use mod_constants, only: OMMP_VERBOSE_LOW, eps_rp - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel - - integer(ip) :: i, j - - eel%thole = 0.0_rp - - do i = 1, eel%pol_atoms - j = eel%polar_mm(i) - eel%thole(j) = eel%pol(i) ** (1.0_rp/6.0_rp) - end do - - if(.not. eel%amoeba) then - if(eel%thole_scale > eps_rp) then - eel%thole = eel%thole * sqrt(eel%thole_scale) - else - call fatal_error("Scale factor for Thole damping should be & - &greater than 0.0 when non-AMOEBA FF are used") - end if - else - if(eel%thole_scale > eps_rp) then - call ommp_message("Scale factor set for thole damping is & - &ignored because AMOEBA FF is used", OMMP_VERBOSE_LOW) - end if - end if - end subroutine thole_init - - subroutine energy_MM_MM(eel, ene) - !! This function computes the interaction energy of - !! static electric multipoles - use mod_memory, only: mallocate, mfree - - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel - !! Electrostatics data structure - real(rp), intent(inout) :: ene - !! Energy (results will be added) - real(rp) :: eMM - - integer(ip) :: i - - call prepare_fixedelec(eel) - eMM = 0.0 - - if(eel%amoeba) then - eMM = eMM + dot_product(eel%q(1,:), eel%V_M2M) - do i=1, 3 - eMM = eMM - dot_product(eel%q(i+1,:), eel%E_M2M(i,:)) - end do - - do i=1,6 - if(i == _xx_ .or. i == _yy_ .or. i == _zz_) then - ! diagonal elements - eMM = eMM + dot_product(eel%q(i+4,:), eel%Egrd_M2M(i,:)) - else - ! off-diagonal elements (are stored once, but - ! should be counted twice - eMM = eMM + 2.0 * dot_product(eel%q(i+4,:), eel%Egrd_M2M(i,:)) - end if - end do - else - eMM = eMM + dot_product(eel%q(1,:), eel%V_M2M) - end if - - ! Since potential is computed using all the sites each - ! interaction is counted twice - ene = ene + 0.5_rp * eMM - - end subroutine energy_MM_MM - - subroutine energy_MM_pol(eel, ene) - !! This function computes the interaction energy of - !! static electric multipoles - use mod_memory, only: mallocate, mfree - - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel - !! Electrostatics data structure - real(rp), intent(inout) :: ene - !! Energy (results will be added) - real(rp) :: eMM - - integer(ip) :: i - - call prepare_polelec(eel) - if(.not. eel%ipd_done) call fatal_error("IPD should be computed before& - & computing MM-Pol energy.") - eMM = 0.0 - - if(eel%amoeba) then - do i=1, 3 - eMM = eMM - dot_product(eel%ipd(i,:,_amoeba_D_), & - eel%E_M2D(i,:,_amoeba_P_)) - end do - else - do i=1, 3 - eMM = eMM - dot_product(eel%ipd(i,:,1), eel%E_M2D(i,:,1)) - end do - end if - - ene = ene + 0.5_rp * eMM - - end subroutine energy_MM_pol - - subroutine coulomb_kernel(dr, maxder, res) - !! This function compute the coulomb kernel for the distance vector dr and - !! its derivative up to the value required by maxder. - use mod_memory, only: ip, rp - use mod_io, only: fatal_error - use mod_constants, only: eps_rp - - implicit none - - real(rp), intent(in) :: dr(3) - !! Distance vector from atom i to atom j - integer(ip), intent(in) :: maxder - !! Maximum derivative to be computed - real(rp), intent(out), dimension(maxder+1) :: res - !! Results vector - - integer(ip) :: ii - real(rp) :: norm2_r, inv_norm_sq - - if(maxder < 0) then - ! Strange request, maybe a warning should be printed - return - end if - - norm2_r = sqrt(dr(1)*dr(1) + dr(2)*dr(2) + dr(3)*dr(3)) - if(norm2_r < eps_rp) then - call fatal_error("Requesting Coulomb kernel for two atoms & - &placed in the same point, this could be & - &an internal bug or a problem in your input & - &file, please check.") - end if - res(1) = 1.0_rp / norm2_r - inv_norm_sq = res(1) * res(1) - - do ii = 1, maxder - res(ii+1) = res(ii) * inv_norm_sq - end do - - end subroutine coulomb_kernel - - subroutine damped_coulomb_kernel(eel, i, j, maxder, res, dr) - !! This subroutine computes the damped coulomb kernel between two atoms. - !! Note that this only makes sense between two MM atoms, as it is only used - !! to compute the field that induces the point dipoles! - - use mod_memory, only: ip, rp - use mod_constants, only: eps_rp - - implicit none - - type(ommp_electrostatics_type), intent(in) :: eel - !! Electrostatics data structure - integer(ip), intent(in) :: i, j - !! Index of atoms (in MM atom list) for which the kernel should be - !! computed - integer(ip), intent(in) :: maxder - !! Maximum derivative to be computed - real(rp), intent(out), dimension(maxder+1) :: res - !! Results vector - real(rp), intent(out), dimension(3) :: dr - !! Distance vector between i and j - - real(rp) :: s, u, u3, u4, fexp, eexp - - s = eel%thole(i) * eel%thole(j) - - ! Compute undamped kernels - dr = eel%top%cmm(:,j) - eel%top%cmm(:,i) - call coulomb_kernel(dr, maxder, res) - - if(abs(s) < eps_rp) then - ! either thole(i) or thole(j) are zero, so the damped kernel - ! is just the same as the regular one. Job is done. - return - end if - - u = 1.0_rp / (res(1) * s) - u3 = u**3 - - if(eel%amoeba .and. u3 * 0.39_rp < 50.0_rp) then - ! 1.0 / (res(1) * s)**3 * 0.39_rp < 50_rp TODO Remove 0.39, this is a - ! FF constants, ask someone why this condition is here. - ! Here basically we multiply the standard interactions kernel for - ! dumping coefficients. The equations implemented here correspond to - ! eq. (5) of 10.1021/jp027815 - fexp = -0.39_rp * u3 - eexp = exp(fexp) - if(maxder >= 1) res(2) = res(2) * (1.0_rp - eexp) - if(maxder >= 2) res(3) = res(3) * (1.0_rp - (1.0_rp - fexp) * eexp) - if(maxder >= 3) res(4) = res(4) * & - (1.0_rp - (1.0_rp - fexp + 0.6_rp * fexp * fexp) * eexp) - if(maxder >= 4) res(5) = res(5) * & - (1.0_rp - (1.0_rp - fexp + 18.0_rp/35.0_rp * fexp * fexp - & - 9.0_rp/35.0_rp * fexp * fexp * fexp) * eexp) - if(maxder >= 5) then - call fatal_error("Damped Coulomb kernel (AMOEBA) only supports up to the 5th derivative") - end if - else if(.not. eel%amoeba .and. res(1) > 1_rp/s) then - ! TODO Again it is not clear to me why condition res(1) > 1_rp/s is here. - u4 = u3*u - if(maxder >= 1) res(2) = res(2) * (4.0_rp * u3 - 3.0_rp * u4) - if(maxder >= 2) res(3) = res(3) * u4 - if(maxder >= 3) res(4) = res(4) * 0.2_rp * u4 - if(maxder >= 4) then - call fatal_error("Damped Coulomb kernel (WANG) only supports up to the 4th derivative") - end if - end if - end subroutine damped_coulomb_kernel - - subroutine q_elec_prop(q, dr, kernel, & - do_V, V, do_E, E, do_grdE, grdE, do_HE, HE) - !! TODO - !! Computes the electric potential of a charge \(q\) at position - !! \(\mathbf{dr}\) from the charge itself. Pre-computed kernel should - !! be provided as input. - !! The result is added to \(V\). - !! $$ V_q = q \frac{f(r)}{||\mathbf{dr}||} $$ - - implicit none - - real(rp), intent(in) :: q - !! Charge - real(rp), intent(in) :: dr(3) - !! Distance vector - real(rp), intent(in) :: kernel(:) - !! Array of coulomb kernel (either damped or undamped) - logical, intent(in) :: do_V, do_E, do_grdE, do_HE - !! Flags to enable/disable calculation of different electrostatic - !! properties - real(rp), intent(inout) :: V, E(3), grdE(6), HE(10) - !! Electric potential - - if(do_V) then - V = V + kernel(1) * q - end if - - if(do_E) then - E = E + q * kernel(2) * dr - end if - - if(do_grdE) then - ! xx - grdE(1) = grdE(1) + q * 3.0_rp * kernel(3) * dr(1) * dr(1) - q * kernel(2) - ! xy - grdE(2) = grdE(2) + q * 3.0_rp * kernel(3) * dr(1) * dr(2) - ! yy - grdE(3) = grdE(3) + q * 3.0_rp * kernel(3) * dr(2) * dr(2) - q * kernel(2) - ! xz - grdE(4) = grdE(4) + q * 3.0_rp * kernel(3) * dr(1) * dr(3) - ! yz - grdE(5) = grdE(5) + q * 3.0_rp * kernel(3) * dr(2) * dr(3) - ! zz - grdE(6) = grdE(6) + q * 3.0_rp * kernel(3) * dr(3) * dr(3) - q * kernel(2) - end if - - if(do_HE) then - ! xxx - HE(1) = HE(1) + (15.0_rp * kernel(4) * dr(1) * dr(1) * dr(1) - & - 9.0_rp * kernel(3) * dr(1)) * q - ! xxy - HE(2) = HE(2) + (15.0_rp * kernel(4) * dr(1) * dr(1) * dr(2) - & - 3.0_rp * kernel(3) * dr(2)) * q - ! xxz - HE(3) = HE(3) + (15.0_rp * kernel(4) * dr(1) * dr(1) * dr(3) - & - 3.0_rp * kernel(3) * dr(3)) * q - ! xyy - HE(4) = HE(4) + (15.0_rp * kernel(4) * dr(2) * dr(2) * dr(1) - & - 3.0_rp * kernel(3) * dr(1)) * q - ! xyz - HE(5) = HE(5) + 15.0_rp * kernel(4) * dr(1) * dr(2) * dr(3) * q - - ! xzz - HE(6) = HE(6) + (15.0_rp * kernel(4) * dr(3) * dr(3) * dr(1) - & - 3.0_rp * kernel(3) * dr(1)) * q - ! yyy - HE(7) = HE(7) + (15.0_rp * kernel(4) * dr(2) * dr(2) * dr(2) - & - 9.0_rp * kernel(3) * dr(2)) * q - ! yyz - HE(8) = HE(8) + (15.0_rp * kernel(4) * dr(2) * dr(2) * dr(3) - & - 3.0_rp * kernel(3) * dr(3)) * q - ! yzz - HE(9) = HE(9) + (15.0_rp * kernel(4) * dr(3) * dr(3) * dr(2) - & - 3.0_rp * kernel(3) * dr(2)) * q - ! zzz - HE(10) = HE(10) + (15.0_rp * kernel(4) * dr(3) * dr(3) * dr(3) - & - 9.0_rp * kernel(3) * dr(3)) * q - end if - - end subroutine q_elec_prop - - subroutine mu_elec_prop(mu, dr, kernel, & - do_V, V, do_E, E, do_grdE, grdE, do_HE, HE) - - implicit none - - real(rp), intent(in) :: mu(3) - !! point dipole - real(rp), intent(in) :: dr(3) - !! Distance vector - real(rp), intent(in) :: kernel(:) - !! Array of coulomb kernel (either damped or undamped) - logical, intent(in) :: do_V, do_E, do_grdE, do_HE - !! Flags to enable/disable calculation of different electrostatic - !! properties - real(rp), intent(inout) :: V, E(3), grdE(6), HE(10) - !! Electric potential - - real(rp) :: mu_dot_dr - - mu_dot_dr = dot_product(mu, dr) - - if(do_V) then - V = V + mu_dot_dr * kernel(2) - end if - - if(do_E) then - E = E + 3.0_rp * mu_dot_dr * dr * kernel(3) - mu * kernel(2) - end if - - if(do_grdE) then - ! xx - grdE(1) = grdE(1) + mu_dot_dr * kernel(4) * 15.0 * dr(1) * dr(1) - & - (mu_dot_dr + 2.0 * mu(1) * dr(1)) * 3.0 * kernel(3) - ! xy - grdE(2) = grdE(2) + mu_dot_dr * kernel(4) * 15.0 * dr(1) * dr(2) - & - (mu(1)*dr(2) + mu(2)*dr(1)) * 3.0 * kernel(3) - ! yy - grdE(3) = grdE(3) + mu_dot_dr * kernel(4) * 15.0 * dr(2) * dr(2) - & - (mu_dot_dr + 2.0 * mu(2) * dr(2)) * 3.0 * kernel(3) - ! xz - grdE(4) = grdE(4) + mu_dot_dr * kernel(4) * 15.0 * dr(1) * dr(3) - & - (mu(1)*dr(3) + mu(3)*dr(1)) * 3.0 * kernel(3) - ! yz - grdE(5) = grdE(5) + mu_dot_dr * kernel(4) * 15.0 * dr(2) * dr(3) - & - (mu(2)*dr(3) + mu(3)*dr(2)) * 3.0 * kernel(3) - ! zz - grdE(6) = grdE(6) + mu_dot_dr * kernel(4) * 15.0 * dr(3) * dr(3) - & - (mu_dot_dr + 2.0 * mu(3) * dr(3)) * 3.0 * kernel(3) - end if - - if(do_HE) then - ! xxx - HE(1) = HE(1) + 105.0_rp * mu_dot_dr * kernel(5) * dr(1)*dr(1)*dr(1) & - - 45.0_rp * kernel(4) * dr(1) * (mu(1)*dr(1) + mu_dot_dr) & - + 9.0_rp * kernel(3) * mu(1) - ! xxy - HE(2) = HE(2) + 105.0_rp * kernel(5) * mu_dot_dr * dr(1)*dr(1)*dr(2) & - - 15.0_rp * kernel(4) * (mu(2)*dr(1)*dr(1) + & - 2.0_rp *mu(1)*dr(1)*dr(2) + & - mu_dot_dr*dr(2)) & - + 3.0_rp * kernel(3) * mu(2) - - ! xxz - HE(3) = HE(3) + 105.0_rp * kernel(5) * mu_dot_dr * dr(1)*dr(1)*dr(3) & - - 15.0_rp * kernel(4) * (mu(3)*dr(1)*dr(1) + & - 2.0_rp *mu(1)*dr(1)*dr(3) + & - mu_dot_dr*dr(3)) & - + 3.0_rp * kernel(3) * mu(3) - ! xyy - HE(4) = HE(4) + 105.0_rp * kernel(5) * mu_dot_dr * dr(2)*dr(2)*dr(1) & - - 15.0_rp * kernel(4) * (mu(1)*dr(2)*dr(2) + & - 2.0_rp *mu(2)*dr(2)*dr(1) + & - mu_dot_dr*dr(1)) & - + 3.0_rp * kernel(3) * mu(1) - ! xyz - HE(5) = HE(5) + 105.0_rp * mu_dot_dr * kernel(5) * dr(1)*dr(2)*dr(3) & - - 15.0_rp * kernel(4) * (mu(1)*dr(2)*dr(3) + & - dr(1)*mu(2)*dr(3) + & - dr(1)*dr(2)*mu(3)) - ! xzz - HE(6) = HE(6) + 105.0_rp * kernel(5) * mu_dot_dr * dr(3)*dr(3)*dr(1) & - - 15.0_rp * kernel(4) * (mu(1)*dr(3)*dr(3) + & - 2.0_rp *mu(3)*dr(3)*dr(1) + & - mu_dot_dr*dr(1)) & - + 3.0_rp * kernel(3) * mu(1) - ! yyy - HE(7) = HE(7) + 105.0_rp * mu_dot_dr * kernel(5) * dr(2)*dr(2)*dr(2) & - - 45.0_rp * kernel(4) * dr(2) * (mu(2)*dr(2) + mu_dot_dr) & - + 9.0_rp * kernel(3) * mu(2) - ! yyz - HE(8) = HE(8) + 105.0_rp * kernel(5) * mu_dot_dr * dr(2)*dr(2)*dr(3) & - - 15.0_rp * kernel(4) * (mu(3)*dr(2)*dr(2) + & - 2.0_rp *mu(2)*dr(2)*dr(3) + & - mu_dot_dr*dr(3)) & - + 3.0_rp * kernel(3) * mu(3) - ! yzz - HE(9) = HE(9) + 105.0_rp * kernel(5) * mu_dot_dr * dr(3)*dr(3)*dr(2) & - - 15.0_rp * kernel(4) * (mu(2)*dr(3)*dr(3) + & - 2.0_rp *mu(3)*dr(3)*dr(2) + & - mu_dot_dr*dr(2)) & - + 3.0_rp * kernel(3) * mu(2) - ! zzz - HE(10) = HE(10) + 105.0_rp * mu_dot_dr * kernel(5) * dr(3)*dr(3)*dr(3) & - - 45.0_rp * kernel(4) * dr(3) * (mu(3)*dr(3) + mu_dot_dr) & - + 9.0_rp * kernel(3) * mu(3) - end if - end subroutine mu_elec_prop - - subroutine quad_elec_prop(quad, dr, kernel, & - do_V, V, do_E, E, do_grdE, grdE, do_HE, HE) - - implicit none - - real(rp), intent(in) :: quad(6) - !! point quadrupole stored as (xx, xy, yy, xz, yz, zz) - real(rp), intent(in) :: dr(3) - !! Distance vector - real(rp), intent(in) :: kernel(:) - !! Array of coulomb kernel (either damped or undamped) - logical, intent(in) :: do_V, do_E, do_grdE, do_HE - !! Flags to enable/disable calculation of different electrostatic - !! properties - real(rp), intent(inout) :: V, E(3), grdE(6), HE(10) - !! Electric potential - - real(rp) :: quadxr(3), quadxr_dot_r - - quadxr(1) = quad(1)*dr(1) + quad(2)*dr(2) + quad(4)*dr(3) - quadxr(2) = quad(2)*dr(1) + quad(3)*dr(2) + quad(5)*dr(3) - quadxr(3) = quad(4)*dr(1) + quad(5)*dr(2) + quad(6)*dr(3) - - quadxr_dot_r = dot_product(quadxr, dr) - - if(do_V) then - V = V + 3.0_rp * quadxr_dot_r * kernel(3) - end if - - if(do_E) then - E = E + 15.0_rp * quadxr_dot_r * dr * kernel(4) & - - 6.0_rp * quadxr * kernel(3) - end if - - if(do_grdE) then - ! xx - grdE(1) = grdE(1) + 105.0 * kernel(5) * quadxr_dot_r * dr(1)*dr(1) + & - 6.0 * kernel(3) * quad(1) - & - 15.0*kernel(4)*(quadxr_dot_r+4.0*quadxr(1)*dr(1)) - ! xy - grdE(2) = grdE(2) + 105.0 * kernel(5) * quadxr_dot_r * dr(1)*dr(2) + & - 6.0 * kernel(3) * quad(2) - & - 30.0*kernel(4)*(quadxr(1)*dr(2)+quadxr(2)*dr(1)) - ! yy - grdE(3) = grdE(3) + 105.0 * kernel(5) * quadxr_dot_r * dr(2)*dr(2) + & - 6.0 * kernel(3) * quad(3) - & - 15.0*kernel(4)*(quadxr_dot_r+4.0*quadxr(2)*dr(2)) - ! xz - grdE(4) = grdE(4) + 105.0 * kernel(5) * quadxr_dot_r * dr(1)*dr(3) + & - 6.0 * kernel(3) * quad(4) - & - 30.0*kernel(4)*(quadxr(1)*dr(3)+quadxr(3)*dr(1)) - ! yz - grdE(5) = grdE(5) + 105.0 * kernel(5) * quadxr_dot_r * dr(2)*dr(3) + & - 6.0 * kernel(3) * quad(5) - & - 30.0*kernel(4)*(quadxr(2)*dr(3)+quadxr(3)*dr(2)) - ! zz - grdE(6) = grdE(6) + 105.0 * kernel(5) * quadxr_dot_r * dr(3)*dr(3) + & - 6.0 * kernel(3) * quad(6) - & - 15.0*kernel(4)*(quadxr_dot_r+4.0*quadxr(3)*dr(3)) - end if - - if(do_HE) then - ! 3 - HE(_xxx_) = HE(_xxx_) + 945*kernel(6)*dr(_x_)**3 * quadxr_dot_r & - - 315*kernel(5)*dr(_x_)*(2*quadxr(_x_)*dr(_x_) + quadxr_dot_r) & - + 90*kernel(4)*(quad(_xx_)*dr(_x_) + quadxr(_x_)) - - HE(_yyy_) = HE(_yyy_) + 945*kernel(6)*dr(_y_)**3 * quadxr_dot_r & - - 315*kernel(5)*dr(_y_)*(2*quadxr(_y_)*dr(_y_) + quadxr_dot_r) & - + 90*kernel(4)*(quad(_yy_)*dr(_y_) + quadxr(_y_)) - - HE(_zzz_) = HE(_zzz_) + 945*kernel(6)*dr(_z_)**3 * quadxr_dot_r & - - 315*kernel(5)*dr(_z_)*(2*quadxr(_z_)*dr(_z_) + quadxr_dot_r) & - + 90*kernel(4)*(quad(_zz_)*dr(_z_) + quadxr(_z_)) - - ! 2 + 1 - HE(_xxy_) = HE(_xxy_) + 945*kernel(6)*dr(_x_)**2*dr(_y_)*quadxr_dot_r & - - 105*kernel(5)*(4*quadxr(_x_)*dr(_x_)*dr(_y_) + & - 2*quadxr(_y_)*dr(_x_)*dr(_x_) + & - dr(_y_)*quadxr_dot_r) & - + 30*kernel(4)*(quad(_xx_)*dr(_y_) + 2*quad(_xy_)*dr(_x_) + quadxr(_y_)) - - HE(_xxz_) = HE(_xxz_) + 945*kernel(6)*dr(_x_)**2*dr(_z_)*quadxr_dot_r & - - 105*kernel(5)*(4*quadxr(_x_)*dr(_x_)*dr(_z_) + & - 2*quadxr(_z_)*dr(_x_)*dr(_x_) + & - dr(_z_)*quadxr_dot_r) & - + 30*kernel(4)*(quad(_xx_)*dr(_z_) + 2*quad(_xz_)*dr(_x_) + quadxr(_z_)) - - HE(_yyx_) = HE(_yyx_) + 945*kernel(6)*dr(_y_)**2*dr(_x_)*quadxr_dot_r & - - 105*kernel(5)*(4*quadxr(_y_)*dr(_y_)*dr(_x_) + & - 2*quadxr(_x_)*dr(_y_)*dr(_y_) + & - dr(_x_)*quadxr_dot_r) & - + 30*kernel(4)*(quad(_yy_)*dr(_x_) + 2*quad(_xy_)*dr(_y_) + quadxr(_x_)) - - HE(_yyz_) = HE(_yyz_) + 945*kernel(6)*dr(_y_)**2*dr(_z_)*quadxr_dot_r & - - 105*kernel(5)*(4*quadxr(_y_)*dr(_y_)*dr(_z_) + & - 2*quadxr(_z_)*dr(_y_)*dr(_y_) + & - dr(_z_)*quadxr_dot_r) & - + 30*kernel(4)*(quad(_yy_)*dr(_z_) + 2*quad(_zy_)*dr(_y_) + quadxr(_z_)) - - HE(_zzx_) = HE(_zzx_) + 945*kernel(6)*dr(_z_)**2*dr(_x_)*quadxr_dot_r & - - 105*kernel(5)*(4*quadxr(_z_)*dr(_z_)*dr(_x_) + & - 2*quadxr(_x_)*dr(_z_)*dr(_z_) + & - dr(_x_)*quadxr_dot_r) & - + 30*kernel(4)*(quad(_zz_)*dr(_x_) + 2*quad(_zx_)*dr(_z_) + quadxr(_x_)) - - HE(_zzy_) = HE(_zzy_) + 945*kernel(6)*dr(_z_)**2*dr(_y_)*quadxr_dot_r & - - 105*kernel(5)*(4*quadxr(_z_)*dr(_z_)*dr(_y_) + & - 2*quadxr(_y_)*dr(_z_)*dr(_z_) + & - dr(_y_)*quadxr_dot_r) & - + 30*kernel(4)*(quad(_zz_)*dr(_y_) + 2*quad(_zy_)*dr(_z_) + quadxr(_y_)) - - ! 1 + 1 + 1 - HE(_xyz_) = HE(_xyz_) + 945*kernel(6)*dr(_x_)*dr(_y_)*dr(_z_)*quadxr_dot_r & - - 210*kernel(5)*(quadxr(_x_)*dr(_y_)*dr(_z_) + & - quadxr(_y_)*dr(_x_)*dr(_z_) + & - quadxr(_z_)*dr(_x_)*dr(_y_)) & - + 30*kernel(4)*(quad(_xy_)*dr(_z_) + quad(_xz_)*dr(_y_) + quad(_yz_)*dr(_x_)) - end if - end subroutine quad_elec_prop - - subroutine prepare_fixedelec(eel, arg_dogg) - !! This function allocate and populate array of electrostatic - !! properties of static multipoles at static multipoles sites. - !! It should be called blindly before any calculation that requires - !! V_M2M etc. - - use mod_memory, only: mallocate - - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel - logical, optional, intent(in) :: arg_dogg - - integer(ip) :: mm_atoms - logical :: do_gg - - mm_atoms = eel%top%mm_atoms - - !! TODO Improve logic - do_gg = .false. - if(present(arg_dogg)) then - if(arg_dogg) do_gg = .true. - end if - - if(.not. do_gg .and. eel%M2M_done) return - if(do_gg .and. eel%M2M_done .and. eel%M2Mgg_done) return - - if(eel%amoeba) then - if(.not. allocated(eel%V_M2M)) then - call mallocate('prepare_fixedelec [V_M2M]', mm_atoms, eel%V_M2M) - end if - - if(.not. allocated(eel%E_M2M)) then - call mallocate('prepare_fixedelec [E_M2M]', 3, mm_atoms, eel%E_M2M) - end if - - if(.not. allocated(eel%Egrd_M2M)) then - call mallocate('prepare_fixedelec [Egrd_M2M]', 6, mm_atoms, eel%Egrd_M2M) - end if - - if(do_gg .and. .not. allocated(eel%EHes_M2M)) then - call mallocate('prepare_fixedelec [EHes_M2M]', 10, mm_atoms, eel%EHes_M2M) - end if - - eel%V_M2M = 0.0_rp - eel%E_M2M = 0.0_rp - eel%Egrd_M2M = 0.0_rp - if(do_gg) eel%EHes_M2M = 0.0_rp - - if(do_gg) then - call elec_prop_M2M(eel, .true., .true., .true., .true.) - else - call elec_prop_M2M(eel, .true., .true., .true., .false.) - end if - else - if(.not. allocated(eel%V_M2M)) then - call mallocate('prepare_fixedelec [V_M2M]', mm_atoms, eel%V_M2M) - end if - - if(do_gg .and. .not. allocated(eel%E_M2M)) then - call mallocate('prepare_fixedelec [E_M2M]', 3, mm_atoms, eel%E_M2M) - end if - - eel%V_M2M = 0.0_rp - if(do_gg) eel%E_M2M = 0.0_rp - - if(do_gg) then - call elec_prop_M2M(eel, .true., .true., .false., .false.) - else - call elec_prop_M2M(eel, .true., .false., .false., .false.) - end if - end if - - eel%M2M_done = .true. - if(do_gg) eel%M2Mgg_done = .true. - - end subroutine prepare_fixedelec - - subroutine prepare_polelec(eel, arg_dogg) - use mod_memory, only: mallocate - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel - logical, optional, intent(in) :: arg_dogg - - logical :: do_gg - - do_gg = .false. - if(present(arg_dogg)) then - if(arg_dogg) do_gg = .true. - end if - - if(.not. do_gg .and. eel%M2D_done) return - if(do_gg .and. eel%M2D_done .and. eel%M2Dgg_done) return - - if(.not. allocated(eel%E_M2D)) then - call mallocate('prepare_polelec [E_M2D]', 3, eel%pol_atoms, & - eel%n_ipd, eel%E_M2D) - end if - - if(do_gg) then - if(.not. eel%ipd_done) call fatal_error("IPD should be computed & - &before computing analytical geometrical gradients of & - &polarization energy.") - - if(.not. allocated(eel%Egrd_M2D)) then - call mallocate('prepare_polelec [Egrd_M2D]', 6, eel%pol_atoms, & - eel%n_ipd, eel%Egrd_M2D) - end if - - if(.not. allocated(eel%Egrd_D2D)) then - call mallocate('prepare_polelec [Egrd_D2D]', 6, eel%pol_atoms, & - eel%n_ipd, eel%Egrd_D2D) - end if - - if(.not. allocated(eel%E_D2M)) then - call mallocate('prepare_polelec [E_D2M]', 3, eel%top%mm_atoms, & - eel%E_D2M) - end if - if(.not. allocated(eel%Egrd_D2M) .and. eel%amoeba) then - call mallocate('prepare_polelec [Egrd_D2M]', 6, eel%top%mm_atoms, & - eel%Egrd_D2M) - end if - if(.not. allocated(eel%EHes_D2M) .and. eel%amoeba) then - call mallocate('prepare_polelec [E_D2M]', 10, eel%top%mm_atoms, & - eel%EHes_D2M) - end if - - end if - - if(.not. do_gg) then - eel%E_M2D = 0.0_rp - call elec_prop_M2D(eel, .false., .true., .false., .false.) - else - eel%E_M2D = 0.0_rp - eel%Egrd_M2D = 0.0_rp - call elec_prop_M2D(eel, .false., .true., .true., .false.) - - eel%E_D2M = 0.0_rp - eel%Egrd_D2D = 0.0_rp - - if(eel%amoeba) then - eel%Egrd_D2M = 0.0_rp - eel%EHes_D2M = 0.0_rp - call elec_prop_D2M(eel, 'P', .false., .true., .true., .true.) - call elec_prop_D2M(eel, 'D', .false., .true., .true., .true.) - - eel%E_D2M = eel%E_D2M * 0.5 - eel%Egrd_D2M = eel%Egrd_D2M * 0.5 - eel%EHes_D2M = eel%EHes_D2M * 0.5 - - call elec_prop_D2D(eel, 'P', .false., .false., .true., .false.) - call elec_prop_D2D(eel, 'D', .false., .false., .true., .false.) - else - call elec_prop_D2M(eel, '-', .false., .true., .false., .false.) - call elec_prop_D2D(eel, '-', .false., .false., .true., .false.) - end if - end if - - if(do_gg) eel%M2Dgg_done = .true. - eel%M2D_done = .true. - end subroutine prepare_polelec - - subroutine elec_prop_M2M(eel, do_V, do_E, do_Egrd, do_EHes) - !! Computes the electric potential, field and field gradients of - !! static multipoles at all sites (polarizable sites are a - !! subset of static ones) - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel - !! Electrostatics data structure - logical, intent(in) :: do_V, do_E, do_Egrd, do_EHes - !! Flags to enable/disable the calculation of different components - - - real(rp) :: kernel(6), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10), scalf - integer(ip) :: i, j, idx, ikernel - logical :: to_do, to_scale - type(ommp_topology_type), pointer :: top - - top => eel%top - - if(do_EHes) then - ikernel = 3 - elseif(do_Egrd) then - ikernel = 2 - elseif(do_E) then - ikernel = 1 - elseif(do_V) then - ikernel = 0 - else - return - end if - if(eel%amoeba) ikernel = ikernel + 2 - - if(eel%amoeba) then - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,idx,to_do,to_scale,scalf,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) - do j=1, top%mm_atoms - ! loop on sources - do i=1, top%mm_atoms - if(j == i) cycle - !loop on target - - to_do = .true. - to_scale = .false. - scalf = 1.0 - - ! Check if the element should be scaled - do idx=eel%list_S_S%ri(i), eel%list_S_S%ri(i+1)-1 - if(eel%list_S_S%ci(idx) == j) then - to_scale = .true. - exit - end if - end do - - !If it should set the correct variables - if(to_scale) then - to_do = eel%todo_S_S(idx) - scalf = eel%scalef_S_S(idx) - end if - - if(to_do) then - dr = top%cmm(:,j) - top%cmm(:, i) - call coulomb_kernel(dr, ikernel, kernel) - - if(do_V) tmpV = 0.0_rp - if(do_E) tmpE = 0.0_rp - if(do_Egrd) tmpEgr = 0.0_rp - if(do_EHes) tmpHE = 0.0_rp - - call q_elec_prop(eel%q(1,i), dr, kernel, & - do_V, tmpV, & - do_E, tmpE, & - do_Egrd, tmpEgr, & - do_EHes, tmpHE) - - call mu_elec_prop(eel%q(2:4,i), dr, kernel, & - do_V, tmpV, & - do_E, tmpE, & - do_Egrd, tmpEgr, & - do_EHes, tmpHE) - - call quad_elec_prop(eel%q(5:10,i), dr, kernel, & - do_V, tmpV, & - do_E, tmpE, & - do_Egrd, tmpEgr, & - do_EHes, tmpHE) - - if(to_scale) then - if(do_V) eel%V_M2M(j) = eel%V_M2M(j) + tmpV * scalf - if(do_E) eel%E_M2M(:,j) = eel%E_M2M(:,j) + tmpE * scalf - if(do_Egrd) eel%Egrd_M2M(:,j) = eel%Egrd_M2M(:,j) + tmpEgr * scalf - if(do_EHes) eel%EHes_M2M(:,j) = eel%EHes_M2M(:,j) + tmpHE * scalf - else - if(do_V) eel%V_M2M(j) = eel%V_M2M(j) + tmpV - if(do_E) eel%E_M2M(:,j) = eel%E_M2M(:,j) + tmpE - if(do_Egrd) eel%Egrd_M2M(:,j) = eel%Egrd_M2M(:,j) + tmpEgr - if(do_EHes) eel%EHes_M2M(:,j) = eel%EHes_M2M(:,j) + tmpHE - end if - end if - end do - end do - else - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,idx,to_do,to_scale,scalf,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) - do j=1, top%mm_atoms - ! loop on sources - do i=1, top%mm_atoms - if(j == i) cycle - !loop on target - to_do = .true. - to_scale = .false. - scalf = 1.0 - - ! Check if the element should be scaled - do idx=eel%list_S_S%ri(i), eel%list_S_S%ri(i+1)-1 - if(eel%list_S_S%ci(idx) == j) then - to_scale = .true. - exit - end if - end do - - !If it should set the correct variables - if(to_scale) then - to_do = eel%todo_S_S(idx) - scalf = eel%scalef_S_S(idx) - end if - - if(to_do) then - dr = top%cmm(:,j) - top%cmm(:, i) - call coulomb_kernel(dr, ikernel, kernel) - - if(do_V) tmpV = 0.0_rp - if(do_E) tmpE = 0.0_rp - if(do_Egrd) tmpEgr = 0.0_rp - if(do_EHes) tmpHE = 0.0_rp - - call q_elec_prop(eel%q(1,i), dr, kernel, & - do_V, tmpV, & - do_E, tmpE, & - do_Egrd, tmpEgr, & - do_EHes, tmpHE) - - if(to_scale) then - if(do_V) eel%V_M2M(j) = eel%V_M2M(j) + tmpV * scalf - if(do_E) eel%E_M2M(:,j) = eel%E_M2M(:,j) + tmpE * scalf - if(do_Egrd) eel%Egrd_M2M(:,j) = eel%Egrd_M2M(:,j) + tmpEgr * scalf - if(do_EHes) eel%EHes_M2M(:,j) = eel%EHes_M2M(:,j) + tmpHE * scalf - else - if(do_V) eel%V_M2M(j) = eel%V_M2M(j) + tmpV - if(do_E) eel%E_M2M(:,j) = eel%E_M2M(:,j) + tmpE - if(do_Egrd) eel%Egrd_M2M(:,j) = eel%Egrd_M2M(:,j) + tmpEgr - if(do_EHes) eel%EHes_M2M(:,j) = eel%EHes_M2M(:,j) + tmpHE - end if - end if - end do - end do - end if - end subroutine elec_prop_M2M - - subroutine field_extD2D(eel, ext_ipd, E) - !! Computes the electric field of a trial set of induced point dipoles - !! at polarizable sites. This is intended to be used as matrix-vector - !! routine in the solution of the linear system. - - implicit none - - type(ommp_electrostatics_type), intent(in) :: eel - !! Data structure for electrostatic part of the system - real(rp), intent(in) :: ext_ipd(3, eel%pol_atoms) - !! External induced point dipoles at polarizable sites - real(rp), intent(inout) :: E(3, eel%pol_atoms) - !! Electric field (results will be added) - - integer(ip) :: i, j, idx - logical :: to_scale, to_do - real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10), scalf - - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,to_do,to_scale,scalf,idx,tmpV,tmpE,tmpEgr,tmpHE,kernel,dr) - do j=1, eel%pol_atoms - do i=1, eel%pol_atoms - if(j == i) cycle - !loop on target - to_do = .true. - to_scale = .false. - scalf = 1.0 - - ! Check if the element should be scaled - do idx=eel%list_P_P%ri(i), eel%list_P_P%ri(i+1)-1 - if(eel%list_P_P%ci(idx) == j) then - to_scale = .true. - exit - end if - end do - - !If it should set the correct variables - if(to_scale) then - to_do = eel%todo_P_P(idx) - scalf = eel%scalef_P_P(idx) - end if - - if(to_do) then - call damped_coulomb_kernel(eel, eel%polar_mm(i), & - eel%polar_mm(j),& - 2, kernel(1:3), dr) - - tmpE = 0.0_rp - - call mu_elec_prop(ext_ipd(:,i), dr, kernel, .false., tmpV, & - .true., tmpE, .false., tmpEgr, & - .false., tmpHE) - if(to_scale) then - E(:, j) = E(:, j) + tmpE * scalf - else - E(:, j) = E(:, j) + tmpE - end if - end if - end do - end do - end subroutine field_extD2D - - subroutine elec_prop_D2D(eel, in_kind, do_V, do_E, do_Egrd, do_EHes) - !! Computes the electric field of a trial set of induced point dipoles - !! at polarizable sites. This is intended to be used as matrix-vector - !! routine in the solution of the linear system. - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel - !! Data structure for electrostatic part of the system - logical, intent(in) :: do_V, do_E, do_Egrd, do_EHes - !! Flag to control which properties have to be computed. - character, intent(in) :: in_kind - - integer(ip) :: i, j, idx, ikernel, knd - logical :: to_scale, to_do - real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10), scalf - - knd = 1 ! Default - if(in_kind == 'P') then - knd = _amoeba_P_ - elseif(in_kind == 'D') then - knd = _amoeba_D_ - elseif(eel%amoeba) then - call fatal_error("Unrecognized interaction '"//in_kind//"' in elec& - &_prop_D2D.") - else - knd = 1 - end if - - if(do_EHes) then - ikernel = 5 - elseif(do_Egrd) then - ikernel = 4 - elseif(do_E) then - ikernel = 3 - elseif(do_V) then - ikernel = 2 - else - return - end if - - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,idx,dr,kernel,to_do,to_scale,scalf,tmpV,tmpE,tmpEgr,tmpHE) - do j=1, eel%pol_atoms - do i=1, eel%pol_atoms - if(j == i) cycle - !loop on target - to_do = .true. - to_scale = .false. - scalf = 1.0 - - ! Check if the element should be scaled - do idx=eel%list_P_P%ri(i), eel%list_P_P%ri(i+1)-1 - if(eel%list_P_P%ci(idx) == j) then - to_scale = .true. - exit - end if - end do - - !If it should set the correct variables - if(to_scale) then - to_do = eel%todo_P_P(idx) - scalf = eel%scalef_P_P(idx) - end if - - if(to_do) then - call damped_coulomb_kernel(eel, eel%polar_mm(i), & - eel%polar_mm(j),& - ikernel, kernel, dr) - - if(do_V) tmpV = 0.0_rp - if(do_E) tmpE = 0.0_rp - if(do_Egrd) tmpEgr = 0.0_rp - if(do_EHes) tmpHE = 0.0_rp - - call mu_elec_prop(eel%ipd(:,i,knd), dr, kernel, & - do_V, tmpV, & - do_E, tmpE, & - do_Egrd, tmpEgr, & - do_EHes, tmpHE) - if(to_scale) then - if(do_V) eel%V_D2D(j,knd) = eel%V_D2D(j,knd) + tmpV * scalf - if(do_E) eel%E_D2D(:, j,knd) = eel%E_D2D(:, j,knd) + tmpE * scalf - if(do_Egrd) eel%Egrd_D2D(:, j,knd) = eel%Egrd_D2D(:, j,knd) + tmpEgr * scalf - if(do_EHes) eel%EHes_D2D(:, j,knd) = eel%EHes_D2D(:, j,knd) + tmpHE * scalf - else - if(do_V) eel%V_D2D(j,knd) = eel%V_D2D(j,knd) + tmpV - if(do_E) eel%E_D2D(:, j,knd) = eel%E_D2D(:, j,knd) + tmpE - if(do_Egrd) eel%Egrd_D2D(:, j,knd) = eel%Egrd_D2D(:, j,knd) + tmpEgr - if(do_EHes) eel%EHes_D2D(:, j,knd) = eel%EHes_D2D(:, j,knd) + tmpHE - end if - end if - end do - end do - end subroutine elec_prop_D2D - - subroutine elec_prop_M2D(eel, do_V, do_E, do_Egrd, do_EHes) - !! Computes the electric field of static multipoles at induced dipoles - !! sites. This is only intended to be used to build the RHS of the - !! linear system. This field is modified by the indroduction of the - !! damped kernels and by the connectivity-based screening rules. - - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel - !! Electrostatics data structure - logical, intent(in) :: do_V, do_E, do_Egrd, do_EHes - !! Flag to control which properties have to be computed. - - integer(ip) :: i, j, idx, ikernel - logical :: to_do_p, to_scale_p, to_do_d, to_scale_d, to_do, to_scale, & - amoeba - real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10), & - scalf_p, scalf_d, scalf - type(ommp_topology_type), pointer :: top - - ! Shortcuts - top => eel%top - amoeba = eel%amoeba - - if(do_EHes) then - ikernel = 3 - elseif(do_Egrd) then - ikernel = 2 - elseif(do_E) then - ikernel = 1 - elseif(do_V) then - ikernel = 0 - else - return - end if - if(eel%amoeba) ikernel = ikernel + 2 - - if(amoeba) then - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,idx,dr,kernel,to_do_p,to_do_d,to_scale_p,to_scale_d,scalf_p,scalf_d,tmpV,tmpE,tmpEgr,tmpHE) - do j=1, eel%pol_atoms - ! loop on sources - do i=1, top%mm_atoms - if(eel%polar_mm(j) == i) cycle - !loop on target - to_do_p = .true. - to_scale_p = .false. - scalf_p = 1.0 - - ! Check if the element should be scaled - do idx=eel%list_S_P_P%ri(i), eel%list_S_P_P%ri(i+1)-1 - if(eel%list_S_P_P%ci(idx) == j) then - to_scale_p = .true. - exit - end if - end do - - !If it should set the correct variables - if(to_scale_p) then - to_do_p = eel%todo_S_P_P(idx) - scalf_p = eel%scalef_S_P_P(idx) - end if - - to_do_d = .true. - to_scale_d = .false. - scalf_d = 1.0 - - ! Check if the element should be scaled - do idx=eel%list_S_P_D%ri(i), eel%list_S_P_D%ri(i+1)-1 - if(eel%list_S_P_D%ci(idx) == j) then - to_scale_d = .true. - exit - end if - end do - - !If it should set the correct variables - if(to_scale_d) then - to_do_d = eel%todo_S_P_D(idx) - scalf_d = eel%scalef_S_P_D(idx) - end if - - if(to_do_p .or. to_do_d) then - call damped_coulomb_kernel(eel, i, eel%polar_mm(j), & - ikernel, kernel, dr) - - if(do_V) tmpV = 0.0_rp - if(do_E) tmpE = 0.0_rp - if(do_Egrd) tmpEgr = 0.0_rp - if(do_EHes) tmpHE = 0.0_rp - - call q_elec_prop(eel%q(1,i), dr, kernel, & - do_V, tmpV, & - do_E, tmpE, & - do_Egrd, tmpEgr, & - do_EHes, tmpHE) - call mu_elec_prop(eel%q(2:4,i), dr, kernel, & - do_V, tmpV, & - do_E, tmpE, & - do_Egrd, tmpEgr, & - do_EHes, tmpHE) - call quad_elec_prop(eel%q(5:10,i), dr, kernel, & - do_V, tmpV, & - do_E, tmpE, & - do_Egrd, tmpEgr, & - do_EHes, tmpHE) - - if(to_do_p) then - if(to_scale_p) then - if(do_V) eel%V_M2D(j, _amoeba_P_) = eel%V_M2D(j, _amoeba_P_) + tmpV * scalf_p - if(do_E) eel%E_M2D(:, j, _amoeba_P_) = eel%E_M2D(:, j, _amoeba_P_) + tmpE * scalf_p - if(do_Egrd) eel%Egrd_M2D(:, j, _amoeba_P_) = eel%Egrd_M2D(:, j, _amoeba_P_) + tmpEgr * scalf_p - if(do_EHes) eel%EHes_M2D(:, j, _amoeba_P_) = eel%EHes_M2D(:, j, _amoeba_P_) + tmpHE * scalf_p - else - if(do_V) eel%V_M2D(j, _amoeba_P_) = eel%V_M2D(j, _amoeba_P_) + tmpV - if(do_E) eel%E_M2D(:, j, _amoeba_P_) = eel%E_M2D(:, j, _amoeba_P_) + tmpE - if(do_Egrd) eel%Egrd_M2D(:, j, _amoeba_P_) = eel%Egrd_M2D(:, j, _amoeba_P_) + tmpEgr - if(do_EHes) eel%EHes_M2D(:, j, _amoeba_P_) = eel%EHes_M2D(:, j, _amoeba_P_) + tmpHE - end if - end if - - if(to_do_d) then - if(to_scale_d) then - if(do_V) eel%V_M2D(j, _amoeba_D_) = eel%V_M2D(j, _amoeba_D_) + tmpV * scalf_d - if(do_E) eel%E_M2D(:, j, _amoeba_D_) = eel%E_M2D(:, j, _amoeba_D_) + tmpE * scalf_d - if(do_Egrd) eel%Egrd_M2D(:, j, _amoeba_D_) = eel%Egrd_M2D(:, j, _amoeba_D_) + tmpEgr * scalf_d - if(do_EHes) eel%EHes_M2D(:, j, _amoeba_D_) = eel%EHes_M2D(:, j, _amoeba_D_) + tmpHE * scalf_d - else - if(do_V) eel%V_M2D(j, _amoeba_D_) = eel%V_M2D(j, _amoeba_D_) + tmpV - if(do_E) eel%E_M2D(:, j, _amoeba_D_) = eel%E_M2D(:, j, _amoeba_D_) + tmpE - if(do_Egrd) eel%Egrd_M2D(:, j, _amoeba_D_) = eel%Egrd_M2D(:, j, _amoeba_D_) + tmpEgr - if(do_EHes) eel%EHes_M2D(:, j, _amoeba_D_) = eel%EHes_M2D(:, j, _amoeba_D_) + tmpHE - end if - end if - end if - end do - end do - else - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,idx,dr,kernel,to_do,to_scale,scalf,tmpV,tmpE,tmpEgr,tmpHE) - do j=1, eel%pol_atoms - ! loop on sources - do i=1, top%mm_atoms - if(eel%polar_mm(j) == i) cycle - !loop on target - to_do = .true. - to_scale = .false. - scalf = 1.0 - - ! Check if the element should be scaled - do idx=eel%list_S_P_P%ri(i), eel%list_S_P_P%ri(i+1)-1 - if(eel%list_S_P_P%ci(idx) == j) then - to_scale = .true. - exit - end if - end do - - !If it should set the correct variables - if(to_scale) then - to_do = eel%todo_S_P_P(idx) - scalf = eel%scalef_S_P_P(idx) - end if - - if(to_do) then - call damped_coulomb_kernel(eel, i, eel%polar_mm(j), & - ikernel, kernel, dr) - - if(do_V) tmpV = 0.0_rp - if(do_E) tmpE = 0.0_rp - if(do_Egrd) tmpEgr = 0.0_rp - if(do_EHes) tmpHE = 0.0_rp - - call q_elec_prop(eel%q(1,i), dr, kernel, & - do_V, tmpV, & - do_E, tmpE, & - do_Egrd, tmpEgr, & - do_EHes, tmpHE) - if(to_scale) then - if(do_V) eel%V_M2D(j, 1) = eel%V_M2D(j, 1) + tmpV * scalf - if(do_E) eel%E_M2D(:, j, 1) = eel%E_M2D(:, j, 1) + tmpE * scalf - if(do_Egrd) eel%Egrd_M2D(:, j, 1) = eel%Egrd_M2D(:, j, 1) + tmpEgr * scalf - if(do_EHes) eel%EHes_M2D(:, j, 1) = eel%EHes_M2D(:, j, 1) + tmpHE * scalf - else - if(do_V) eel%V_M2D(j, 1) = eel%V_M2D(j, 1) + tmpV - if(do_E) eel%E_M2D(:, j, 1) = eel%E_M2D(:, j, 1) + tmpE - if(do_Egrd) eel%Egrd_M2D(:, j, 1) = eel%Egrd_M2D(:, j, 1) + tmpEgr - if(do_EHes) eel%EHes_M2D(:, j, 1) = eel%EHes_M2D(:, j, 1) + tmpHE - end if - end if - end do - end do - end if - - end subroutine - - subroutine elec_prop_D2M(eel, in_kind, do_V, do_E, do_Egrd, do_EHes) - - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel - !! Electrostatics data structure - character, intent(in) :: in_kind - - logical, intent(in) :: do_V, do_E, do_Egrd, do_EHes - !! Flag to control which properties have to be computed. - - integer(ip) :: i, j, idx, ikernel, knd - logical :: to_do, to_scale, amoeba - real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10), & - scalf - type(ommp_topology_type), pointer :: top - character :: screening_type - - ! Shortcuts - top => eel%top - amoeba = eel%amoeba - - knd = 1 ! Default - if(eel%amoeba .and. in_kind /= 'P' .and. in_kind /= 'D') then - call fatal_error("Unrecognized field '"//in_kind//"' for AMOEBA & - &force-field.") - elseif(eel%amoeba .and. in_kind == 'P') then - knd = _amoeba_P_ - screening_type = 'D' - elseif(eel%amoeba .and. in_kind == 'D') then - knd = _amoeba_D_ - screening_type = 'P' - elseif(.not. eel%amoeba) then - screening_type = '-' - else - call fatal_error("Unexpected error in elec_prop_D2M.") - end if - - if(do_EHes) then - ikernel = 4 - elseif(do_Egrd) then - ikernel = 3 - elseif(do_E) then - ikernel = 2 - elseif(do_V) then - ikernel = 1 - else - return - end if - - if(amoeba) then - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,idx,dr,kernel,to_do,to_scale,scalf,tmpV,tmpE,tmpEgr,tmpHE) - do j=1, top%mm_atoms - ! loop on sources - do i=1, eel%pol_atoms - if(eel%polar_mm(i) == j) cycle - !loop on target - if(screening_type == 'P') then - to_do = .true. - to_scale = .false. - scalf = 1.0 - - ! Check if the element should be scaled - do idx=eel%list_S_P_P%ri(j), eel%list_S_P_P%ri(j+1)-1 - if(eel%list_S_P_P%ci(idx) == i) then - to_scale = .true. - exit - end if - end do - - !If it should set the correct variables - if(to_scale) then - to_do = eel%todo_S_P_P(idx) - scalf = eel%scalef_S_P_P(idx) - end if - else - to_do = .true. - to_scale = .false. - scalf = 1.0 - - ! Check if the element should be scaled - do idx=eel%list_S_P_D%ri(j), eel%list_S_P_D%ri(j+1)-1 - if(eel%list_S_P_D%ci(idx) == i) then - to_scale = .true. - exit - end if - end do - - !If it should set the correct variables - if(to_scale) then - to_do = eel%todo_S_P_D(idx) - scalf = eel%scalef_S_P_D(idx) - end if - end if - - - if(to_do) then - call damped_coulomb_kernel(eel, eel%polar_mm(i), j, & - ikernel, kernel, dr) - - if(do_V) tmpV = 0.0_rp - if(do_E) tmpE = 0.0_rp - if(do_Egrd) tmpEgr = 0.0_rp - if(do_EHes) tmpHE = 0.0_rp - - call mu_elec_prop(eel%ipd(:,i, knd), dr, kernel, & - do_V, tmpV, & - do_E, tmpE, & - do_Egrd, tmpEgr, & - do_EHes, tmpHE) - if(to_scale) then - if(do_V) eel%V_D2M(j) = eel%V_D2M(j) + tmpV * scalf - if(do_E) eel%E_D2M(:, j) = eel%E_D2M(:, j) + tmpE * scalf - if(do_Egrd) eel%Egrd_D2M(:, j) = eel%Egrd_D2M(:, j) + tmpEgr * scalf - if(do_EHes) eel%EHes_D2M(:, j) = eel%EHes_D2M(:, j) + tmpHE * scalf - else - if(do_V) eel%V_D2M(j) = eel%V_D2M(j) + tmpV - if(do_E) eel%E_D2M(:, j) = eel%E_D2M(:, j) + tmpE - if(do_Egrd) eel%Egrd_D2M(:, j) = eel%Egrd_D2M(:, j) + tmpEgr - if(do_EHes) eel%EHes_D2M(:, j) = eel%EHes_D2M(:, j) + tmpHE - end if - end if - end do - end do - else - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,idx,dr,kernel,to_do,to_scale,scalf,tmpV,tmpE,tmpEgr,tmpHE) - do j=1, top%mm_atoms - ! loop on sources - do i=1, eel%pol_atoms - if(eel%polar_mm(i) == j) cycle - !loop on target - to_do = .true. - to_scale = .false. - scalf = 1.0 - - ! Check if the element should be scaled - do idx=eel%list_S_P_P%ri(j), eel%list_S_P_P%ri(j+1)-1 - if(eel%list_S_P_P%ci(idx) == i) then - to_scale = .true. - exit - end if - end do - - !If it should set the correct variables - if(to_scale) then - to_do = eel%todo_S_P_P(idx) - scalf = eel%scalef_S_P_P(idx) - end if - - if(to_do) then - call damped_coulomb_kernel(eel, eel%polar_mm(i), j, & - ikernel, kernel, dr) - - if(do_V) tmpV = 0.0_rp - if(do_E) tmpE = 0.0_rp - if(do_Egrd) tmpEgr = 0.0_rp - if(do_EHes) tmpHE = 0.0_rp - - call mu_elec_prop(eel%ipd(:,i, knd), dr, kernel, & - do_V, tmpV, & - do_E, tmpE, & - do_Egrd, tmpEgr, & - do_EHes, tmpHE) - if(to_scale) then - if(do_V) eel%V_D2M(j) = eel%V_D2M(j) + tmpV * scalf - if(do_E) eel%E_D2M(:, j) = eel%E_D2M(:, j) + tmpE * scalf - if(do_Egrd) eel%Egrd_D2M(:, j) = eel%Egrd_D2M(:, j) + tmpEgr * scalf - if(do_EHes) eel%EHes_D2M(:, j) = eel%EHes_D2M(:, j) + tmpHE * scalf - else - if(do_V) eel%V_D2M(j) = eel%V_D2M(j) + tmpV - if(do_E) eel%E_D2M(:, j) = eel%E_D2M(:, j) + tmpE - if(do_Egrd) eel%Egrd_D2M(:, j) = eel%Egrd_D2M(:, j) + tmpEgr - if(do_EHes) eel%EHes_D2M(:, j) = eel%EHes_D2M(:, j) + tmpHE - end if - end if - end do - end do - end if - - end subroutine - - subroutine potential_D2E(eel, cpt, V, amoeba_P_insted_of_D_) - !! This subroutine computes the potential generated by the induced - !! point dipoles to a set of arbitrary coordinates, without applying - !! any screening rules. Note: for AMOEBA D dipoles should be used. - - implicit none - - type(ommp_electrostatics_type), intent(in) :: eel - !! Electrostatics data structure - real(rp), intent(inout) :: V(:) - !! Electric field (results will be added) - real(rp), intent(in) :: cpt(:,:) - !! Coordinates at which the electric field is requested - logical, optional, intent(in) :: amoeba_P_insted_of_D_ - !! For AMOEBA FF, if true the potential of P dipoles - !! is computed, otherwise potential of D dipoles is computed - - integer(ip) :: i, j, n_cpt - logical :: amoeba_P_insted_of_D - real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10) - - if(eel%pol_atoms < 1) return - - if(present(amoeba_P_insted_of_D_)) then - amoeba_P_insted_of_D = amoeba_P_insted_of_D_ - else - amoeba_P_insted_of_D = .false. - end if - - if(.not. eel%ipd_done) call fatal_error("IPD should be computed before& - & D2E potential.") - n_cpt = size(cpt, 2) - - if(eel%amoeba) then - if(.not. amoeba_P_insted_of_D) then - !$omp parallel do default(shared) schedule(dynamic) collapse(2) & - !$omp private(i,j,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) reduction(+:V) - do i=1, eel%pol_atoms - do j=1, n_cpt - dr = cpt(:,j) - eel%cpol(:,i) - call coulomb_kernel(dr, 2, kernel(1:2)) - tmpV = 0.0_rp - - call mu_elec_prop(eel%ipd(:,i,_amoeba_D_), & - dr, kernel, .true., tmpV, & - .false., tmpE, .false., tmpEgr, & - .false., tmpHE) - - V(j) = V(j) + tmpV - end do - end do - else - !$omp parallel do default(shared) schedule(dynamic) collapse(2) & - !$omp private(i,j,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) reduction(+:V) - do i=1, eel%pol_atoms - do j=1, n_cpt - dr = cpt(:,j) - eel%cpol(:,i) - call coulomb_kernel(dr, 2, kernel(1:2)) - tmpV = 0.0_rp - - call mu_elec_prop(eel%ipd(:,i,_amoeba_P_), & - dr, kernel, .true., tmpV, & - .false., tmpE, .false., tmpEgr, & - .false., tmpHE) - - V(j) = V(j) + tmpV - end do - end do - end if - else - !$omp parallel do default(shared) schedule(dynamic) collapse(2) & - !$omp private(i,j,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) reduction(+:V) - do i=1, eel%pol_atoms - ! loop on sources - do j=1, n_cpt - dr = cpt(:,j) - eel%cpol(:,i) - call coulomb_kernel(dr, 2, kernel(1:2)) - tmpV = 0.0_rp - - call mu_elec_prop(eel%ipd(:,i,1), & - dr, kernel, .true., tmpV, & - .false., tmpE, .false., tmpEgr, & - .false., tmpHE) - - V(j) = V(j) + tmpV - end do - end do - end if - end subroutine potential_D2E - - subroutine potential_M2E(eel, cpt, V) - !! This subroutine computes the potential generated by the static - !! multipoles to a set of arbitrary coordinates, without applying - !! any screening rules. - - implicit none - - type(ommp_electrostatics_type), intent(in) :: eel - !! Electrostatics data structure - real(rp), intent(inout) :: V(:) - !! Electric field (results will be added) - real(rp), intent(in) :: cpt(:,:) - !! Coordinates at which the electric field is requested - - integer(ip) :: i, j, n_cpt - real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10) - - n_cpt = size(cpt, 2) - - if(eel%amoeba) then - !$omp parallel do default(shared) schedule(dynamic) collapse(2) & - !$omp private(i,j,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) reduction(+:V) - do i=1, eel%top%mm_atoms - do j=1, n_cpt - dr = cpt(:,j) - eel%top%cmm(:,i) - call coulomb_kernel(dr, 2, kernel(1:3)) - tmpV = 0.0_rp - - call q_elec_prop(eel%q(1,i), dr, kernel, .true., tmpV, & - .false., tmpE, .false., tmpEgr, & - .false., tmpHE) - call mu_elec_prop(eel%q(2:4,i), dr, kernel, .true., tmpV, & - .false., tmpE, .false., tmpEgr, & - .false., tmpHE) - call quad_elec_prop(eel%q(5:10,i), dr, kernel, .true., tmpV, & - .false., tmpE, .false., tmpEgr, & - .false., tmpHE) - - V(j) = V(j) + tmpV - end do - end do - else - !$omp parallel do default(shared) schedule(dynamic) collapse(2) & - !$omp private(i,j,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) reduction(+:V) - do i=1, eel%top%mm_atoms - ! loop on sources - do j=1, n_cpt - dr = cpt(:,j) - eel%top%cmm(:,i) - call coulomb_kernel(dr, 1, kernel(1:2)) - tmpV = 0.0_rp - - call q_elec_prop(eel%q(1,i), dr, kernel, .true., tmpV, & - .false., tmpE, .false., tmpEgr, & - .false., tmpHE) - - V(j) = V(j) + tmpV - end do - end do - end if - end subroutine potential_M2E - - subroutine field_D2E(eel, cpt, E) - !! This subroutine computes the potential generated by the static - !! multipoles to a set of arbitrary coordinates, without applying - !! any screening rules. - - implicit none - - type(ommp_electrostatics_type), intent(in) :: eel - !! Electrostatics data structure - real(rp), intent(inout) :: E(:,:) - !! Electric field (results will be added) - real(rp), intent(in) :: cpt(:,:) - !! Coordinates at which the electric field is requested - - integer(ip) :: i, j, n_cpt - real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10) - - if(eel%pol_atoms < 1) return - - if(.not. eel%ipd_done) call fatal_error("IPD should be computed before& - & computing D2E field.") - n_cpt = size(cpt, 2) - - if(eel%amoeba) then - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) reduction(+:E) - do i=1, eel%pol_atoms - do j=1, n_cpt - dr = cpt(:,j) - eel%cpol(:,i) - call coulomb_kernel(dr, 3, kernel) - tmpE = 0.0_rp - !TODO - call mu_elec_prop(0.5*(eel%ipd(:,i, _amoeba_P_) + eel%ipd(:,i, _amoeba_D_)), dr, kernel, .false., tmpV, & - .true., tmpE, .false., tmpEgr, & - .false., tmpHE) - - E(:,j) = E(:,j) + tmpE - end do - end do - else - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,dr,kernel,tmpV,tmpE,tmpEgr,tmpHE) reduction(+:E) - do i=1, eel%pol_atoms - ! loop on sources - do j=1, n_cpt - dr = cpt(:,j) - eel%cpol(:,i) - call coulomb_kernel(dr, 3, kernel) - tmpE = 0.0_rp - - call mu_elec_prop(eel%ipd(:,i,1), dr, kernel, .false., tmpV, & - .true., tmpE, .false., tmpEgr, & - .false., tmpHE) - - E(:,j) = E(:,j) + tmpE - end do - end do - end if - end subroutine field_D2E - - subroutine field_M2E(eel, cpt, E) - !! This subroutine computes the potential generated by the static - !! multipoles to a set of arbitrary coordinates, without applying - !! any screening rules. - - implicit none - - type(ommp_electrostatics_type), intent(in) :: eel - !! Electrostatics data structure - real(rp), intent(inout) :: E(:,:) - !! Electric field (results will be added) - real(rp), intent(in) :: cpt(:,:) - !! Coordinates at which the electric field is requested - - integer(ip) :: i, j, n_cpt - real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), tmpHE(10) - - n_cpt = size(cpt, 2) - - if(eel%amoeba) then - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,dr,kernel,tmpE,tmpV,tmpEgr,tmpHE) reduction(+:E) - do i=1, eel%top%mm_atoms - do j=1, n_cpt - dr = cpt(:,j) - eel%top%cmm(:,i) - call coulomb_kernel(dr, 4, kernel) - tmpE = 0.0_rp - - call q_elec_prop(eel%q(1,i), dr, kernel, .false., tmpV, & - .true., tmpE, .false., tmpEgr, & - .false., tmpHE) - call mu_elec_prop(eel%q(2:4,i), dr, kernel, .false., tmpV, & - .true., tmpE, .false., tmpEgr, & - .false., tmpHE) - call quad_elec_prop(eel%q(5:10,i), dr, kernel, .false., tmpV, & - .true., tmpE, .false., tmpEgr, & - .false., tmpHE) - - E(:,j) = E(:,j) + tmpE - end do - end do - else - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,dr,kernel,tmpE,tmpV,tmpEgr,tmpHE) reduction(+:E) - do i=1, eel%top%mm_atoms - ! loop on sources - do j=1, n_cpt - dr = cpt(:,j) - eel%top%cmm(:,i) - call coulomb_kernel(dr, 2, kernel) - tmpE = 0.0_rp - - call q_elec_prop(eel%q(1,i), dr, kernel, .false., tmpV, & - .true., tmpE, .false., tmpEgr, & - .false., tmpHE) - - E(:,j) = E(:,j) + tmpE - end do - end do - end if - end subroutine field_M2E - - function screening_rules(eel, i, kind_i, j, kind_j, in_field) result(scalf) - !! Utility function used to decide if an interaction between sites i and j - !! should be computed and eventually scaled by a factor. - !! This function is intended to be used in \(\mathcalO(n^2)\) code, for - !! linear scaling code lists should be built. - !! This is written to minimize code repetitions, all the screening rules - !! are handled in two possible cases: - !! 1. rules based on adjacency matrix - !! 2. rules based on AMOEBA polarization groups - - use mod_constants, only: eps_rp - - type(ommp_electrostatics_type), intent(in) :: eel - !! Electrostatics object - integer(ip), intent(in) :: i - !! Index of source site (MM index is used for static sites, while - !! Pol index is used for polarizable sites) - integer(ip), intent(in) :: j - !! Index of target site (MM index is used for static sites, while - !! Pol index is used for polarizable sites) - character, intent(in) :: in_field - !! Which screening rules have to be applied? 'D' = screening rules - !! for direct field; 'P' = screening rules for polarization field - character, intent(in) :: kind_i, kind_j - !! Type of sites i and j in the interaction for which the screening - !! rules are required; possible choices are 'P' (polarizable site) or - !! 'S' (static site). Any other option will cause a fatal error. - real(rp) :: scalf - !! Scale factor for the interaction - - integer(ip) :: ineigh, grp, igrp, pg_i - integer(ip) :: j_mm, i_mm - character :: field, interaction - logical :: amoeba - type(ommp_topology_type), pointer :: top - real(rp) :: myscale(4), myscale_intra(4) - - ! Some shortcut - top => eel%top - amoeba = eel%amoeba - - ! Decide which kind of rule should be used - if(kind_i == 'P') then - i_mm = eel%polar_mm(i) - else if(kind_i == 'S') then - i_mm = i - else - call fatal_error('Unexpected value of kind_i in screening_rules') - i_mm = 0 - end if - - if(kind_j == 'P') then - j_mm = eel%polar_mm(j) - else if(kind_j == 'S') then - j_mm = j - else - call fatal_error('Unexpected value of kind_j in screening_rules') - j_mm = 0 - end if - - myscale = 0.0_rp - if(kind_j == 'P' .and. kind_i == 'P') then - ! Use IPD-IPD screening rules - myscale = eel%uscale - interaction = 'P' !Pol-pol interaction is named P - else if(kind_j == 'S' .and. kind_i == 'S') then - ! Use static multipoles-static multipoles screening rules - myscale = eel%mscale - field = '-' - interaction = 'S' !Static-static interaction is named S - else - ! Use static multipoles-IPD screening rules - if(in_field == 'P' .and. amoeba) then - myscale = eel%pscale - myscale_intra = eel%pscale_intra - field = 'P' - else if(in_field == 'D' .and. amoeba) then - myscale = eel%dscale - field = 'D' - else if(.not. amoeba) then - myscale = eel%pscale - field = 'P' - else - call fatal_error('Unexpected value of field in screening rules') - end if - interaction = 'M' !Mixed interaction is named M - end if - - ! Default return value - scalf = 1.0_rp - - if((.not. amoeba) .or. & - (amoeba .and. interaction == 'M' .and. field == 'P') .or. & - (amoeba .and. interaction == 'S')) then - ! Screening rules based on connectivity matrix: - ! 1. all the ones of non-amoeba FF, - ! 2. the static to IPD polarization field - ! 3. the static-static interaction of AMOEBA - do ineigh=1,4 - ! Look if j is at distance ineigh from i - if(any(top%conn(ineigh)%ci(top%conn(ineigh)%ri(i_mm): & - top%conn(ineigh)%ri(i_mm+1)-1) == j_mm)) then - - if(interaction == 'M' .and. amoeba) then - ! Amoeba uses two different screening rules for atoms - ! of the same group and for atoms of different group - if(eel%mmat_polgrp(i_mm) == eel%mmat_polgrp(j_mm)) then - scalf = myscale_intra(ineigh) - else - scalf = myscale(ineigh) - end if - else - ! In any other case just use the scale factor for this - ! distance - scalf = myscale(ineigh) - end if - - ! Exit the loop - exit - - end if - end do - else if((amoeba .and. interaction == 'M' .and. field == 'D') .or. & - (amoeba .and. interaction == 'P')) then - ! Screening rules based on polarization groups: - ! 1. the static to IPD direct field - ! 2. the IPD to IPD interaction of AMOEBA - pg_i = eel%mmat_polgrp(i_mm) - - outer: do ineigh=1,4 - do igrp=eel%pg_conn(ineigh)%ri(pg_i), & - eel%pg_conn(ineigh)%ri(pg_i+1)-1 - ! Indexes of groups at distance ineigh from group pg_i - grp = eel%pg_conn(ineigh)%ci(igrp) - - if(any(eel%polgrp_mmat%ci(eel%polgrp_mmat%ri(grp): & - eel%polgrp_mmat%ri(grp+1)-1) == j_mm)) then - ! If atom j is in a group at distance ineigh from the - ! one of atom i, the field is scaled according to dscale - scalf = myscale(ineigh) - exit outer - end if - end do - end do outer - else - ! Unexpected error - call fatal_error("Unexpected combination of parameter for screening_rules") - end if - - end function screening_rules - -end module mod_electrostatics diff --git a/src/mod_geomgrad.F90 b/src/mod_geomgrad.F90 new file mode 100644 index 0000000..40ff265 --- /dev/null +++ b/src/mod_geomgrad.F90 @@ -0,0 +1,271 @@ +#include "f_cart_components.h" + +module mod_geomgrad + use mod_io, only: fatal_error, ommp_message + use mod_memory, only: ip, rp + use mod_mmpol, only: ommp_system + use mod_topology, only: ommp_topology_type + + implicit none + private + + public :: fixedelec_geomgrad, polelec_geomgrad + +contains + + subroutine fixedelec_geomgrad(s, grad) + use mod_electrostatics, only: prepare_fixedelec, & + ommp_electrostatics_type + + implicit none + + type(ommp_system), intent(inout), target :: s + !! System data structure + real(rp), dimension(3,s%top%mm_atoms), intent(inout) :: grad + !! Geometrical gradients in output, results will be added + + integer(ip) :: i + type(ommp_electrostatics_type), pointer :: eel + eel => s%eel + + call prepare_fixedelec(eel, .true.) + + if(eel%amoeba) then + !$omp parallel do + do i=1, s%top%mm_atoms + ! If the atom is frozen, there are no contribution to compute + if(s%top%use_frozen) then + if(s%top%frozen(i)) cycle + end if + + ! Charges -qE + grad(:,i) = grad(:,i) - eel%q(1,i) * eel%E_M2M(:,i) + + ! Dipoles mu \nablaE + grad(_x_,i) = grad(_x_,i) & + + eel%q(1+_x_,i) * eel%Egrd_M2M(_xx_,i) & + + eel%q(1+_y_,i) * eel%Egrd_M2M(_xy_,i) & + + eel%q(1+_z_,i) * eel%Egrd_M2M(_xz_,i) + grad(_y_,i) = grad(_y_,i) & + + eel%q(1+_x_,i) * eel%Egrd_M2M(_yx_,i) & + + eel%q(1+_y_,i) * eel%Egrd_M2M(_yy_,i) & + + eel%q(1+_z_,i) * eel%Egrd_M2M(_yz_,i) + grad(_z_,i) = grad(_z_,i) & + + eel%q(1+_x_,i) * eel%Egrd_M2M(_zx_,i) & + + eel%q(1+_y_,i) * eel%Egrd_M2M(_zy_,i) & + + eel%q(1+_z_,i) * eel%Egrd_M2M(_zz_,i) + + ! Quadrupoles Q \nabla^2E + grad(_x_,i) = grad(_x_,i) & + - eel%q(4+_xx_,i) * eel%EHes_M2M(_xxx_,i) & + - eel%q(4+_yy_,i) * eel%EHes_M2M(_yyx_,i) & + - eel%q(4+_zz_,i) * eel%EHes_M2M(_zzx_,i) & + - 2*(eel%q(4+_xy_,i) * eel%EHes_M2M(_xyx_,i) & + + eel%q(4+_xz_,i) * eel%EHes_M2M(_xzx_,i) & + + eel%q(4+_yz_,i) * eel%EHes_M2M(_yzx_,i)) + grad(_y_,i) = grad(_y_,i) & + - eel%q(4+_xx_,i) * eel%EHes_M2M(_xxy_,i) & + - eel%q(4+_yy_,i) * eel%EHes_M2M(_yyy_,i) & + - eel%q(4+_zz_,i) * eel%EHes_M2M(_zzy_,i) & + - 2*(eel%q(4+_xy_,i) * eel%EHes_M2M(_xyy_,i) & + + eel%q(4+_xz_,i) * eel%EHes_M2M(_xzy_,i) & + + eel%q(4+_yz_,i) * eel%EHes_M2M(_yzy_,i)) + grad(_z_,i) = grad(_z_,i) & + - eel%q(4+_xx_,i) * eel%EHes_M2M(_xxz_,i) & + - eel%q(4+_yy_,i) * eel%EHes_M2M(_yyz_,i) & + - eel%q(4+_zz_,i) * eel%EHes_M2M(_zzz_,i) & + - 2*(eel%q(4+_xy_,i) * eel%EHes_M2M(_xyz_,i) & + + eel%q(4+_xz_,i) * eel%EHes_M2M(_xzz_,i) & + + eel%q(4+_yz_,i) * eel%EHes_M2M(_yzz_,i)) + + end do + ! Torque forces from multipoles rotation + call rotation_geomgrad(eel, eel%E_M2M, eel%Egrd_M2M, grad) + else + !$omp parallel do + do i=1, s%top%mm_atoms + ! Skip frozen atoms contributions + if(s%top%use_frozen) then + if(s%top%frozen(i)) cycle + end if + + ! Here the minus sign is due to the definition of Electric + ! field that is E = -\nabla V. + ! The factor 1/2 that is present in the definition of the + ! energy disappear because in the derivative there is a + ! factor 2 that takes in account that when an atom is + ! "displaced", this affect both the point at which the + ! potential of all the other charges is computed and + ! the potential computed at the -fixed- position of all + ! the other charges (due to the displaced source). + grad(:,i) = grad(:,i) - eel%q(1,i) * eel%E_M2M(:,i) + end do + end if + end subroutine + + subroutine polelec_geomgrad(s, grad) + !use mod_electrostatics, only: prepare_M2D, ommp_electrostatics_type + use mod_polarization, only: polarization + use mod_electrostatics + + implicit none + + type(ommp_system), intent(inout), target :: s + !! System data structure + real(rp), dimension(3,s%top%mm_atoms), intent(inout) :: grad + !! Geometrical gradients in output, results will be added + + integer(ip) :: i + type(ommp_electrostatics_type), pointer :: eel + eel => s%eel + + if(.not. eel%ipd_done) then + call prepare_polelec(eel, .false.) + call polarization(s, eel%e_M2D) + end if + call prepare_polelec(eel, .true.) + + if(eel%amoeba) then + !$omp parallel do + do i=1, eel%top%mm_atoms + ! Skip frozen atoms contributions + if(s%top%use_frozen) then + if(s%top%frozen(i)) cycle + end if + + ! Charges q E + grad(:,i) = grad(:,i) - eel%q(1,i) * eel%E_D2M(:,i) + + ! Dipoles mu \nablaE + grad(_x_,i) = grad(_x_,i) & + + eel%q(1+_x_,i) * eel%Egrd_D2M(_xx_,i) & + + eel%q(1+_y_,i) * eel%Egrd_D2M(_xy_,i) & + + eel%q(1+_z_,i) * eel%Egrd_D2M(_xz_,i) + grad(_y_,i) = grad(_y_,i) & + + eel%q(1+_x_,i) * eel%Egrd_D2M(_yx_,i) & + + eel%q(1+_y_,i) * eel%Egrd_D2M(_yy_,i) & + + eel%q(1+_z_,i) * eel%Egrd_D2M(_yz_,i) + grad(_z_,i) = grad(_z_,i) & + + eel%q(1+_x_,i) * eel%Egrd_D2M(_zx_,i) & + + eel%q(1+_y_,i) * eel%Egrd_D2M(_zy_,i) & + + eel%q(1+_z_,i) * eel%Egrd_D2M(_zz_,i) + + ! Quadrupoles Q \nabla^2E + grad(_x_,i) = grad(_x_,i) & + - eel%q(4+_xx_,i) * eel%EHes_D2M(_xxx_,i) & + - eel%q(4+_yy_,i) * eel%EHes_D2M(_yyx_,i) & + - eel%q(4+_zz_,i) * eel%EHes_D2M(_zzx_,i) & + - 2*(eel%q(4+_xy_,i) * eel%EHes_D2M(_xyx_,i) & + + eel%q(4+_xz_,i) * eel%EHes_D2M(_xzx_,i) & + + eel%q(4+_yz_,i) * eel%EHes_D2M(_yzx_,i)) + grad(_y_,i) = grad(_y_,i) & + - eel%q(4+_xx_,i) * eel%EHes_D2M(_xxy_,i) & + - eel%q(4+_yy_,i) * eel%EHes_D2M(_yyy_,i) & + - eel%q(4+_zz_,i) * eel%EHes_D2M(_zzy_,i) & + - 2*(eel%q(4+_xy_,i) * eel%EHes_D2M(_xyy_,i) & + + eel%q(4+_xz_,i) * eel%EHes_D2M(_xzy_,i) & + + eel%q(4+_yz_,i) * eel%EHes_D2M(_yzy_,i)) + grad(_z_,i) = grad(_z_,i) & + - eel%q(4+_xx_,i) * eel%EHes_D2M(_xxz_,i) & + - eel%q(4+_yy_,i) * eel%EHes_D2M(_yyz_,i) & + - eel%q(4+_zz_,i) * eel%EHes_D2M(_zzz_,i) & + - 2*(eel%q(4+_xy_,i) * eel%EHes_D2M(_xyz_,i) & + + eel%q(4+_xz_,i) * eel%EHes_D2M(_xzz_,i) & + + eel%q(4+_yz_,i) * eel%EHes_D2M(_yzz_,i)) + end do + + !$omp parallel do + do i=1, eel%pol_atoms + ! Skip frozen atoms contributions + if(s%top%use_frozen) then + if(s%top%frozen(eel%polar_mm(i))) cycle + end if + + ! \mu_D Egrd_P + grad(_x_,eel%polar_mm(i)) = grad(_x_,eel%polar_mm(i)) & + + 0.5*eel%ipd(_x_,i,_amoeba_D_) * (eel%Egrd_M2D(_xx_,i,_amoeba_P_) & + + eel%Egrd_D2D(_xx_,i,_amoeba_P_)) & + + 0.5*eel%ipd(_y_,i,_amoeba_D_) * (eel%Egrd_M2D(_xy_,i,_amoeba_P_) & + + eel%Egrd_D2D(_xy_,i,_amoeba_P_)) & + + 0.5*eel%ipd(_z_,i,_amoeba_D_) * (eel%Egrd_M2D(_xz_,i,_amoeba_P_) & + + eel%Egrd_D2D(_xz_,i,_amoeba_P_)) + grad(_y_,eel%polar_mm(i)) = grad(_y_,eel%polar_mm(i)) & + + 0.5*eel%ipd(_x_,i,_amoeba_D_) * (eel%Egrd_M2D(_yx_,i,_amoeba_P_) & + + eel%Egrd_D2D(_yx_,i,_amoeba_P_)) & + + 0.5*eel%ipd(_y_,i,_amoeba_D_) * (eel%Egrd_M2D(_yy_,i,_amoeba_P_) & + + eel%Egrd_D2D(_yy_,i,_amoeba_P_)) & + + 0.5*eel%ipd(_z_,i,_amoeba_D_) * (eel%Egrd_M2D(_yz_,i,_amoeba_P_) & + + eel%Egrd_D2D(_yz_,i,_amoeba_P_)) + grad(_z_,eel%polar_mm(i)) = grad(_z_,eel%polar_mm(i)) & + + 0.5*eel%ipd(_x_,i,_amoeba_D_) * (eel%Egrd_M2D(_zx_,i,_amoeba_P_) & + + eel%Egrd_D2D(_zx_,i,_amoeba_P_)) & + + 0.5*eel%ipd(_y_,i,_amoeba_D_) * (eel%Egrd_M2D(_zy_,i,_amoeba_P_) & + + eel%Egrd_D2D(_zy_,i,_amoeba_P_)) & + + 0.5*eel%ipd(_z_,i,_amoeba_D_) * (eel%Egrd_M2D(_zz_,i,_amoeba_P_) & + + eel%Egrd_D2D(_zz_,i,_amoeba_P_)) + ! \mu_P Egrd_D + grad(_x_,eel%polar_mm(i)) = grad(_x_,eel%polar_mm(i)) & + + 0.5*eel%ipd(_x_,i,_amoeba_P_) * (eel%Egrd_M2D(_xx_,i,_amoeba_D_) & + + eel%Egrd_D2D(_xx_,i,_amoeba_D_)) & + + 0.5*eel%ipd(_y_,i,_amoeba_P_) * (eel%Egrd_M2D(_xy_,i,_amoeba_D_) & + + eel%Egrd_D2D(_xy_,i,_amoeba_D_)) & + + 0.5*eel%ipd(_z_,i,_amoeba_P_) * (eel%Egrd_M2D(_xz_,i,_amoeba_D_) & + + eel%Egrd_D2D(_xz_,i,_amoeba_D_)) + grad(_y_,eel%polar_mm(i)) = grad(_y_,eel%polar_mm(i)) & + + 0.5*eel%ipd(_x_,i,_amoeba_P_) * (eel%Egrd_M2D(_yx_,i,_amoeba_D_) & + + eel%Egrd_D2D(_yx_,i,_amoeba_D_)) & + + 0.5*eel%ipd(_y_,i,_amoeba_P_) * (eel%Egrd_M2D(_yy_,i,_amoeba_D_) & + + eel%Egrd_D2D(_yy_,i,_amoeba_D_)) & + + 0.5*eel%ipd(_z_,i,_amoeba_P_) * (eel%Egrd_M2D(_yz_,i,_amoeba_D_) & + + eel%Egrd_D2D(_yz_,i,_amoeba_D_)) + grad(_z_,eel%polar_mm(i)) = grad(_z_,eel%polar_mm(i)) & + + 0.5*eel%ipd(_x_,i,_amoeba_P_) * (eel%Egrd_M2D(_zx_,i,_amoeba_D_) & + + eel%Egrd_D2D(_zx_,i,_amoeba_D_)) & + + 0.5*eel%ipd(_y_,i,_amoeba_P_) * (eel%Egrd_M2D(_zy_,i,_amoeba_D_) & + + eel%Egrd_D2D(_zy_,i,_amoeba_D_)) & + + 0.5*eel%ipd(_z_,i,_amoeba_P_) * (eel%Egrd_M2D(_zz_,i,_amoeba_D_) & + + eel%Egrd_D2D(_zz_,i,_amoeba_D_)) + end do + else + do i=1, eel%top%mm_atoms + ! Skip frozen atoms contributions + if(s%top%use_frozen) then + if(s%top%frozen(i)) cycle + end if + + grad(:,i) = grad(:,i) - eel%q(1,i) * eel%E_D2M(:,i) + end do + + do i=1, eel%pol_atoms + ! Skip frozen atoms contributions + if(s%top%use_frozen) then + if(s%top%frozen(eel%polar_mm(i))) cycle + end if + + grad(_x_,eel%polar_mm(i)) = grad(_x_,eel%polar_mm(i)) & + + eel%ipd(_x_,i,1) * (eel%Egrd_M2D(_xx_,i,1) & + + eel%Egrd_D2D(_xx_,i,1)) & + + eel%ipd(_y_,i,1) * (eel%Egrd_M2D(_xy_,i,1) & + + eel%Egrd_D2D(_xy_,i,1)) & + + eel%ipd(_z_,i,1) * (eel%Egrd_M2D(_xz_,i,1) & + + eel%Egrd_D2D(_xz_,i,1)) + grad(_y_,eel%polar_mm(i)) = grad(_y_,eel%polar_mm(i)) & + + eel%ipd(_x_,i,1) * (eel%Egrd_M2D(_yx_,i,1) & + + eel%Egrd_D2D(_yx_,i,1)) & + + eel%ipd(_y_,i,1) * (eel%Egrd_M2D(_yy_,i,1) & + + eel%Egrd_D2D(_yy_,i,1)) & + + eel%ipd(_z_,i,1) * (eel%Egrd_M2D(_yz_,i,1) & + + eel%Egrd_D2D(_yz_,i,1)) + grad(_z_,eel%polar_mm(i)) = grad(_z_,eel%polar_mm(i)) & + + eel%ipd(_x_,i,1) * (eel%Egrd_M2D(_zx_,i,1) & + + eel%Egrd_D2D(_zx_,i,1)) & + + eel%ipd(_y_,i,1) * (eel%Egrd_M2D(_zy_,i,1) & + + eel%Egrd_D2D(_zy_,i,1)) & + + eel%ipd(_z_,i,1) * (eel%Egrd_M2D(_zz_,i,1) & + + eel%Egrd_D2D(_zz_,i,1)) + end do + end if + + if(eel%amoeba) call rotation_geomgrad(eel, eel%E_D2M, eel%Egrd_D2M, grad) + end subroutine +end module diff --git a/src/mod_geomgrad.f90 b/src/mod_geomgrad.f90 deleted file mode 100644 index f2c68a8..0000000 --- a/src/mod_geomgrad.f90 +++ /dev/null @@ -1,271 +0,0 @@ -#include "f_cart_components.h" - -module mod_geomgrad - use mod_io, only: fatal_error, ommp_message - use mod_memory, only: ip, rp - use mod_mmpol, only: ommp_system - use mod_topology, only: ommp_topology_type - - implicit none - private - - public :: fixedelec_geomgrad, polelec_geomgrad - - contains - - subroutine fixedelec_geomgrad(s, grad) - use mod_electrostatics, only: prepare_fixedelec, & - ommp_electrostatics_type - - implicit none - - type(ommp_system), intent(inout), target :: s - !! System data structure - real(rp), dimension(3,s%top%mm_atoms), intent(inout) :: grad - !! Geometrical gradients in output, results will be added - - integer(ip) :: i - type(ommp_electrostatics_type), pointer :: eel - eel => s%eel - - call prepare_fixedelec(eel, .true.) - - if(eel%amoeba) then - !$omp parallel do - do i=1, s%top%mm_atoms - ! If the atom is frozen, there are no contribution to compute - if(s%top%use_frozen) then - if(s%top%frozen(i)) cycle - end if - - ! Charges -qE - grad(:,i) = grad(:,i) - eel%q(1,i) * eel%E_M2M(:,i) - - ! Dipoles mu \nablaE - grad(_x_,i) = grad(_x_,i) & - + eel%q(1+_x_,i) * eel%Egrd_M2M(_xx_,i) & - + eel%q(1+_y_,i) * eel%Egrd_M2M(_xy_,i) & - + eel%q(1+_z_,i) * eel%Egrd_M2M(_xz_,i) - grad(_y_,i) = grad(_y_,i) & - + eel%q(1+_x_,i) * eel%Egrd_M2M(_yx_,i) & - + eel%q(1+_y_,i) * eel%Egrd_M2M(_yy_,i) & - + eel%q(1+_z_,i) * eel%Egrd_M2M(_yz_,i) - grad(_z_,i) = grad(_z_,i) & - + eel%q(1+_x_,i) * eel%Egrd_M2M(_zx_,i) & - + eel%q(1+_y_,i) * eel%Egrd_M2M(_zy_,i) & - + eel%q(1+_z_,i) * eel%Egrd_M2M(_zz_,i) - - ! Quadrupoles Q \nabla^2E - grad(_x_,i) = grad(_x_,i) & - - eel%q(4+_xx_,i) * eel%EHes_M2M(_xxx_,i) & - - eel%q(4+_yy_,i) * eel%EHes_M2M(_yyx_,i) & - - eel%q(4+_zz_,i) * eel%EHes_M2M(_zzx_,i) & - - 2*(eel%q(4+_xy_,i) * eel%EHes_M2M(_xyx_,i) & - + eel%q(4+_xz_,i) * eel%EHes_M2M(_xzx_,i) & - + eel%q(4+_yz_,i) * eel%EHes_M2M(_yzx_,i)) - grad(_y_,i) = grad(_y_,i) & - - eel%q(4+_xx_,i) * eel%EHes_M2M(_xxy_,i) & - - eel%q(4+_yy_,i) * eel%EHes_M2M(_yyy_,i) & - - eel%q(4+_zz_,i) * eel%EHes_M2M(_zzy_,i) & - - 2*(eel%q(4+_xy_,i) * eel%EHes_M2M(_xyy_,i) & - + eel%q(4+_xz_,i) * eel%EHes_M2M(_xzy_,i) & - + eel%q(4+_yz_,i) * eel%EHes_M2M(_yzy_,i)) - grad(_z_,i) = grad(_z_,i) & - - eel%q(4+_xx_,i) * eel%EHes_M2M(_xxz_,i) & - - eel%q(4+_yy_,i) * eel%EHes_M2M(_yyz_,i) & - - eel%q(4+_zz_,i) * eel%EHes_M2M(_zzz_,i) & - - 2*(eel%q(4+_xy_,i) * eel%EHes_M2M(_xyz_,i) & - + eel%q(4+_xz_,i) * eel%EHes_M2M(_xzz_,i) & - + eel%q(4+_yz_,i) * eel%EHes_M2M(_yzz_,i)) - - end do - ! Torque forces from multipoles rotation - call rotation_geomgrad(eel, eel%E_M2M, eel%Egrd_M2M, grad) - else - !$omp parallel do - do i=1, s%top%mm_atoms - ! Skip frozen atoms contributions - if(s%top%use_frozen) then - if(s%top%frozen(i)) cycle - end if - - ! Here the minus sign is due to the definition of Electric - ! field that is E = -\nabla V. - ! The factor 1/2 that is present in the definition of the - ! energy disappear because in the derivative there is a - ! factor 2 that takes in account that when an atom is - ! "displaced", this affect both the point at which the - ! potential of all the other charges is computed and - ! the potential computed at the -fixed- position of all - ! the other charges (due to the displaced source). - grad(:,i) = grad(:,i) - eel%q(1,i) * eel%E_M2M(:,i) - end do - end if - end subroutine - - subroutine polelec_geomgrad(s, grad) - !use mod_electrostatics, only: prepare_M2D, ommp_electrostatics_type - use mod_polarization, only: polarization - use mod_electrostatics - - implicit none - - type(ommp_system), intent(inout), target :: s - !! System data structure - real(rp), dimension(3,s%top%mm_atoms), intent(inout) :: grad - !! Geometrical gradients in output, results will be added - - integer(ip) :: i - type(ommp_electrostatics_type), pointer :: eel - eel => s%eel - - if(.not. eel%ipd_done) then - call prepare_polelec(eel, .false.) - call polarization(s, eel%e_M2D) - end if - call prepare_polelec(eel, .true.) - - if(eel%amoeba) then - !$omp parallel do - do i=1, eel%top%mm_atoms - ! Skip frozen atoms contributions - if(s%top%use_frozen) then - if(s%top%frozen(i)) cycle - end if - - ! Charges q E - grad(:,i) = grad(:,i) - eel%q(1,i) * eel%E_D2M(:,i) - - ! Dipoles mu \nablaE - grad(_x_,i) = grad(_x_,i) & - + eel%q(1+_x_,i) * eel%Egrd_D2M(_xx_,i) & - + eel%q(1+_y_,i) * eel%Egrd_D2M(_xy_,i) & - + eel%q(1+_z_,i) * eel%Egrd_D2M(_xz_,i) - grad(_y_,i) = grad(_y_,i) & - + eel%q(1+_x_,i) * eel%Egrd_D2M(_yx_,i) & - + eel%q(1+_y_,i) * eel%Egrd_D2M(_yy_,i) & - + eel%q(1+_z_,i) * eel%Egrd_D2M(_yz_,i) - grad(_z_,i) = grad(_z_,i) & - + eel%q(1+_x_,i) * eel%Egrd_D2M(_zx_,i) & - + eel%q(1+_y_,i) * eel%Egrd_D2M(_zy_,i) & - + eel%q(1+_z_,i) * eel%Egrd_D2M(_zz_,i) - - ! Quadrupoles Q \nabla^2E - grad(_x_,i) = grad(_x_,i) & - - eel%q(4+_xx_,i) * eel%EHes_D2M(_xxx_,i) & - - eel%q(4+_yy_,i) * eel%EHes_D2M(_yyx_,i) & - - eel%q(4+_zz_,i) * eel%EHes_D2M(_zzx_,i) & - - 2*(eel%q(4+_xy_,i) * eel%EHes_D2M(_xyx_,i) & - + eel%q(4+_xz_,i) * eel%EHes_D2M(_xzx_,i) & - + eel%q(4+_yz_,i) * eel%EHes_D2M(_yzx_,i)) - grad(_y_,i) = grad(_y_,i) & - - eel%q(4+_xx_,i) * eel%EHes_D2M(_xxy_,i) & - - eel%q(4+_yy_,i) * eel%EHes_D2M(_yyy_,i) & - - eel%q(4+_zz_,i) * eel%EHes_D2M(_zzy_,i) & - - 2*(eel%q(4+_xy_,i) * eel%EHes_D2M(_xyy_,i) & - + eel%q(4+_xz_,i) * eel%EHes_D2M(_xzy_,i) & - + eel%q(4+_yz_,i) * eel%EHes_D2M(_yzy_,i)) - grad(_z_,i) = grad(_z_,i) & - - eel%q(4+_xx_,i) * eel%EHes_D2M(_xxz_,i) & - - eel%q(4+_yy_,i) * eel%EHes_D2M(_yyz_,i) & - - eel%q(4+_zz_,i) * eel%EHes_D2M(_zzz_,i) & - - 2*(eel%q(4+_xy_,i) * eel%EHes_D2M(_xyz_,i) & - + eel%q(4+_xz_,i) * eel%EHes_D2M(_xzz_,i) & - + eel%q(4+_yz_,i) * eel%EHes_D2M(_yzz_,i)) - end do - - !$omp parallel do - do i=1, eel%pol_atoms - ! Skip frozen atoms contributions - if(s%top%use_frozen) then - if(s%top%frozen(eel%polar_mm(i))) cycle - end if - - ! \mu_D Egrd_P - grad(_x_,eel%polar_mm(i)) = grad(_x_,eel%polar_mm(i)) & - + 0.5*eel%ipd(_x_,i,_amoeba_D_) * (eel%Egrd_M2D(_xx_,i,_amoeba_P_) & - + eel%Egrd_D2D(_xx_,i,_amoeba_P_)) & - + 0.5*eel%ipd(_y_,i,_amoeba_D_) * (eel%Egrd_M2D(_xy_,i,_amoeba_P_) & - + eel%Egrd_D2D(_xy_,i,_amoeba_P_)) & - + 0.5*eel%ipd(_z_,i,_amoeba_D_) * (eel%Egrd_M2D(_xz_,i,_amoeba_P_) & - + eel%Egrd_D2D(_xz_,i,_amoeba_P_)) - grad(_y_,eel%polar_mm(i)) = grad(_y_,eel%polar_mm(i)) & - + 0.5*eel%ipd(_x_,i,_amoeba_D_) * (eel%Egrd_M2D(_yx_,i,_amoeba_P_) & - + eel%Egrd_D2D(_yx_,i,_amoeba_P_)) & - + 0.5*eel%ipd(_y_,i,_amoeba_D_) * (eel%Egrd_M2D(_yy_,i,_amoeba_P_) & - + eel%Egrd_D2D(_yy_,i,_amoeba_P_)) & - + 0.5*eel%ipd(_z_,i,_amoeba_D_) * (eel%Egrd_M2D(_yz_,i,_amoeba_P_) & - + eel%Egrd_D2D(_yz_,i,_amoeba_P_)) - grad(_z_,eel%polar_mm(i)) = grad(_z_,eel%polar_mm(i)) & - + 0.5*eel%ipd(_x_,i,_amoeba_D_) * (eel%Egrd_M2D(_zx_,i,_amoeba_P_) & - + eel%Egrd_D2D(_zx_,i,_amoeba_P_)) & - + 0.5*eel%ipd(_y_,i,_amoeba_D_) * (eel%Egrd_M2D(_zy_,i,_amoeba_P_) & - + eel%Egrd_D2D(_zy_,i,_amoeba_P_)) & - + 0.5*eel%ipd(_z_,i,_amoeba_D_) * (eel%Egrd_M2D(_zz_,i,_amoeba_P_) & - + eel%Egrd_D2D(_zz_,i,_amoeba_P_)) - ! \mu_P Egrd_D - grad(_x_,eel%polar_mm(i)) = grad(_x_,eel%polar_mm(i)) & - + 0.5*eel%ipd(_x_,i,_amoeba_P_) * (eel%Egrd_M2D(_xx_,i,_amoeba_D_) & - + eel%Egrd_D2D(_xx_,i,_amoeba_D_)) & - + 0.5*eel%ipd(_y_,i,_amoeba_P_) * (eel%Egrd_M2D(_xy_,i,_amoeba_D_) & - + eel%Egrd_D2D(_xy_,i,_amoeba_D_)) & - + 0.5*eel%ipd(_z_,i,_amoeba_P_) * (eel%Egrd_M2D(_xz_,i,_amoeba_D_) & - + eel%Egrd_D2D(_xz_,i,_amoeba_D_)) - grad(_y_,eel%polar_mm(i)) = grad(_y_,eel%polar_mm(i)) & - + 0.5*eel%ipd(_x_,i,_amoeba_P_) * (eel%Egrd_M2D(_yx_,i,_amoeba_D_) & - + eel%Egrd_D2D(_yx_,i,_amoeba_D_)) & - + 0.5*eel%ipd(_y_,i,_amoeba_P_) * (eel%Egrd_M2D(_yy_,i,_amoeba_D_) & - + eel%Egrd_D2D(_yy_,i,_amoeba_D_)) & - + 0.5*eel%ipd(_z_,i,_amoeba_P_) * (eel%Egrd_M2D(_yz_,i,_amoeba_D_) & - + eel%Egrd_D2D(_yz_,i,_amoeba_D_)) - grad(_z_,eel%polar_mm(i)) = grad(_z_,eel%polar_mm(i)) & - + 0.5*eel%ipd(_x_,i,_amoeba_P_) * (eel%Egrd_M2D(_zx_,i,_amoeba_D_) & - + eel%Egrd_D2D(_zx_,i,_amoeba_D_)) & - + 0.5*eel%ipd(_y_,i,_amoeba_P_) * (eel%Egrd_M2D(_zy_,i,_amoeba_D_) & - + eel%Egrd_D2D(_zy_,i,_amoeba_D_)) & - + 0.5*eel%ipd(_z_,i,_amoeba_P_) * (eel%Egrd_M2D(_zz_,i,_amoeba_D_) & - + eel%Egrd_D2D(_zz_,i,_amoeba_D_)) - end do - else - do i=1, eel%top%mm_atoms - ! Skip frozen atoms contributions - if(s%top%use_frozen) then - if(s%top%frozen(i)) cycle - end if - - grad(:,i) = grad(:,i) - eel%q(1,i) * eel%E_D2M(:,i) - end do - - do i=1, eel%pol_atoms - ! Skip frozen atoms contributions - if(s%top%use_frozen) then - if(s%top%frozen(eel%polar_mm(i))) cycle - end if - - grad(_x_,eel%polar_mm(i)) = grad(_x_,eel%polar_mm(i)) & - + eel%ipd(_x_,i,1) * (eel%Egrd_M2D(_xx_,i,1) & - + eel%Egrd_D2D(_xx_,i,1)) & - + eel%ipd(_y_,i,1) * (eel%Egrd_M2D(_xy_,i,1) & - + eel%Egrd_D2D(_xy_,i,1)) & - + eel%ipd(_z_,i,1) * (eel%Egrd_M2D(_xz_,i,1) & - + eel%Egrd_D2D(_xz_,i,1)) - grad(_y_,eel%polar_mm(i)) = grad(_y_,eel%polar_mm(i)) & - + eel%ipd(_x_,i,1) * (eel%Egrd_M2D(_yx_,i,1) & - + eel%Egrd_D2D(_yx_,i,1)) & - + eel%ipd(_y_,i,1) * (eel%Egrd_M2D(_yy_,i,1) & - + eel%Egrd_D2D(_yy_,i,1)) & - + eel%ipd(_z_,i,1) * (eel%Egrd_M2D(_yz_,i,1) & - + eel%Egrd_D2D(_yz_,i,1)) - grad(_z_,eel%polar_mm(i)) = grad(_z_,eel%polar_mm(i)) & - + eel%ipd(_x_,i,1) * (eel%Egrd_M2D(_zx_,i,1) & - + eel%Egrd_D2D(_zx_,i,1)) & - + eel%ipd(_y_,i,1) * (eel%Egrd_M2D(_zy_,i,1) & - + eel%Egrd_D2D(_zy_,i,1)) & - + eel%ipd(_z_,i,1) * (eel%Egrd_M2D(_zz_,i,1) & - + eel%Egrd_D2D(_zz_,i,1)) - end do - end if - - if(eel%amoeba) call rotation_geomgrad(eel, eel%E_D2M, eel%Egrd_D2M, grad) - end subroutine -end module diff --git a/src/mod_inputloader.F90 b/src/mod_inputloader.F90 new file mode 100644 index 0000000..d330ee8 --- /dev/null +++ b/src/mod_inputloader.F90 @@ -0,0 +1,494 @@ +module mod_inputloader + use mod_io, only: ommp_message, fatal_error + use mod_profiling, only: time_push, time_pull + use mod_constants, only: OMMP_STR_CHAR_MAX + + use mod_mmpol, only: ommp_system + + implicit none + private + + public :: mmpol_init_from_mmp, mmpol_init_from_xyz + +contains + + subroutine mmpol_init_from_mmp(input_file, sys_obj) + !! This function read a .mmp file (revision 2 and 3) are supported + !! and initialize all the quantities need to describe the environment + !! within this library. + + use mod_mmpol, only: mmpol_prepare, mmpol_init + use mod_electrostatics, only: set_screening_parameters + + use mod_memory, only: ip, rp, mfree, mallocate, memory_init + use mod_io, only: iof_mmpinp + use mod_adjacency_mat, only: adj_mat_from_conn + use mod_utils, only: skip_lines + use mod_constants, only: angstrom2au, OMMP_VERBOSE_DEBUG + use mod_constants, only: mscale_wang_al, & + pscale_wang_al, & + dscale_wang_al, & + uscale_wang_al, & + mscale_wang_dl, & + pscale_wang_dl, & + dscale_wang_dl, & + uscale_wang_dl, & + mscale_amoeba, & + pscale_amoeba, & + dscale_amoeba, & + uscale_amoeba, & + pscale_intra_amoeba, & + thole_scale_wang_dl, & + thole_scale_wang_al + + implicit none + + type(ommp_system), intent(inout) :: sys_obj + !! System data structure to be initialized + + character(len=*), intent(in) :: input_file + !! name of the input file + + ! read the input for the mmpol calculation and process it. + integer(ip) :: input_revision + integer(ip) :: my_mm_atoms, my_pol_atoms, my_ff_type, my_ff_rules + integer(ip) :: my_ld_cart + + integer(ip) :: i, ist + + real(rp), allocatable :: my_pol(:), my_cmm(:,:), my_q(:,:) + integer(ip), allocatable :: pol_atoms_list(:), my_ip11(:,:) + + integer(ip), parameter :: maxn12 = 8 + !! maximum number of neighbour atoms + integer(ip), parameter :: maxpgp = 120 + !! maximum number of members for the same polarization group + real(rp), parameter :: thres = 1e-8 + !! Threshold used to decide if a polarizability is zero + ! TODO why we do not use eps_rp directly? + + integer(ip), allocatable :: i12(:,:) + character(len=OMMP_STR_CHAR_MAX) :: msg + logical :: fex + + call time_push() + write(msg, "(A)") "Reading MMP file: "//input_file(1:len(trim(input_file))) + call ommp_message(msg, OMMP_VERBOSE_DEBUG) + + inquire(file=input_file(1:len(trim(input_file))), exist=fex) + if(.not. fex) then + call fatal_error("Input file '"//& + &input_file(1:len(trim(input_file)))//"' does not exist.") + end if + + open(unit=iof_mmpinp, & + file=input_file(1:len(trim(input_file))), & + form='formatted', & + access='sequential', & + iostat=ist, & + action='read') + + if(ist /= 0) then + call fatal_error('Error while opening MMP input file') + end if + + call ommp_message("Reading input parameters", OMMP_VERBOSE_DEBUG) + + ! Read input revision, supported revisions are 2 and 3. + read(iof_mmpinp,*) input_revision + + if (input_revision /= 3 .and. input_revision /= 2) & + call fatal_error('MMP file is only supported with version 2 or 3.') + + !TODO + call memory_init(.false., 0.0_rp) + + call skip_lines(iof_mmpinp, 2) + read(iof_mmpinp,*) my_ff_type + read(iof_mmpinp,*) my_ff_rules + + if(input_revision == 3) then + call skip_lines(iof_mmpinp, 17) + else if(input_revision == 2) then + call skip_lines(iof_mmpinp, 15) + end if + + read(iof_mmpinp,*) my_mm_atoms + + if(my_ff_type == 1) then + my_ld_cart = 10 + else + my_ld_cart = 1 + end if + + call ommp_message("Allocating memory", OMMP_VERBOSE_DEBUG) + + call mallocate('mmpol_init_from_mmp [my_cmm]', 3_ip, my_mm_atoms, my_cmm) + call mallocate('mmpol_init_from_mmp [my_q]', my_ld_cart, my_mm_atoms, my_q) + call mallocate('mmpol_init_from_mmp [my_pol]', my_mm_atoms, my_pol) + call mallocate('mmpol_init_from_mmp [my_pol_atoms]', my_mm_atoms, pol_atoms_list) + call mallocate('mmpol_init_from_mmp [my_ip11]', maxpgp, my_mm_atoms, my_ip11) + + call skip_lines(iof_mmpinp, my_mm_atoms+1) ! Skip a zero and the section of atomic numbers + + call ommp_message("Reading coordinates", OMMP_VERBOSE_DEBUG) + ! coordinates: + do i = 1, my_mm_atoms + read(iof_mmpinp,*) my_cmm(1:3,i) + end do + + call skip_lines(iof_mmpinp, my_mm_atoms) ! Skip section of residues number + + call ommp_message("Reading fixed multipoles", OMMP_VERBOSE_DEBUG) + ! charges/multipoles: + do i = 1, my_mm_atoms + read(iof_mmpinp,*) my_q(1:my_ld_cart,i) + end do + + call ommp_message("Reading polarizabilities", OMMP_VERBOSE_DEBUG) + ! polarizabilities: + my_pol = 0.0_rp + do i = 1, my_mm_atoms + read(iof_mmpinp,*) my_pol(i) + end do + + call ommp_message("Processing polarizabilities", OMMP_VERBOSE_DEBUG) + ! count how many atoms are polarizable: + ! TODO this is more efficiently done with pack and count + my_pol_atoms = 0 + pol_atoms_list(:) = 0 + do i = 1, my_mm_atoms + if (my_pol(i) > thres) then + my_pol_atoms = my_pol_atoms + 1 + pol_atoms_list(my_pol_atoms) = i + end if + end do + + ! remove null polarizabilities from the list + do i = 1, my_pol_atoms + my_pol(i) = my_pol(pol_atoms_list(i)) + end do + my_pol(my_pol_atoms+1:my_mm_atoms) = 0.0_rp + + call ommp_message("Initializing open mmpol module", OMMP_VERBOSE_DEBUG) + ! mmpol module initialization + call mmpol_init(sys_obj, my_ff_type, my_mm_atoms, my_pol_atoms) + if(sys_obj%amoeba) then + call set_screening_parameters(sys_obj%eel, & + mscale_amoeba, & + pscale_amoeba, & + dscale_amoeba, & + uscale_amoeba, & + pscale_intra_amoeba) + sys_obj%eel%thole_scale = 0.0_rp + else + if(my_ff_rules == 1) then + call set_screening_parameters(sys_obj%eel, & + mscale_wang_dl, & + pscale_wang_dl, & + dscale_wang_dl, & + uscale_wang_dl) + sys_obj%eel%thole_scale = thole_scale_wang_dl + else if(my_ff_rules == 0) then + call set_screening_parameters(sys_obj%eel, & + mscale_wang_al, & + pscale_wang_al, & + dscale_wang_al, & + uscale_wang_al) + sys_obj%eel%thole_scale = thole_scale_wang_al + end if + end if + + call ommp_message("Converting input units to A.U.", OMMP_VERBOSE_DEBUG) + ! Copy data in the correct units (this means AU) + sys_obj%top%cmm = my_cmm * angstrom2au + sys_obj%eel%q = my_q + if(sys_obj%amoeba) then + my_pol = my_pol*angstrom2au**3 + end if + sys_obj%eel%pol = my_pol(1:my_pol_atoms) + sys_obj%eel%polar_mm = pol_atoms_list(1:my_pol_atoms) + + call mfree('mmpol_init_from_mmp [my_cmm]', my_cmm) + call mfree('mmpol_init_from_mmp [my_q]', my_q) + call mfree('mmpol_init_from_mmp [pol]', my_pol) + + call ommp_message("Processing connectivity informations", OMMP_VERBOSE_DEBUG) + + ! 1-2 connectivity: + call mallocate('mmpol_init_from_mmp [i12]', maxn12, my_mm_atoms, i12) + do i = 1, my_mm_atoms + read(iof_mmpinp,*) i12(1:maxn12,i) + end do + + ! Writes the adjacency matrix in Yale sparse format in conn(1) + call adj_mat_from_conn(i12, sys_obj%top%conn(1)) + call mfree('mmpol_init_from_mmp [i12]', i12) + + if(sys_obj%amoeba) then + ! group 11 connectivity: + ! (to be replaced with polarization group) + do i = 1, my_mm_atoms + read(iof_mmpinp,*) my_ip11(1:maxpgp,i) + end do + + call polgroup11_to_mm2pg(my_ip11, sys_obj%eel%mmat_polgrp) + call mfree('mmpol_init_from_mmp [my_ip11]', my_ip11) + + ! information to rotate the multipoles to the lab frame. + ! mol_frame, iz, ix, iy: + do i = 1, my_mm_atoms + read(iof_mmpinp,*) sys_obj%eel%mol_frame(i), & + sys_obj%eel%iz(i), sys_obj%eel%ix(i), & + sys_obj%eel%iy(i) + end do + end if + ! now, process the input, create all the required arrays + ! and the correspondence lists: + + call ommp_message("Populating utility arrays", OMMP_VERBOSE_DEBUG) + call mmpol_prepare(sys_obj) + close(iof_mmpinp) + call ommp_message("Initialization from MMP file done.", OMMP_VERBOSE_DEBUG) + call time_pull('MMPol initialization from .mmp file') + end subroutine mmpol_init_from_mmp + + subroutine polgroup11_to_mm2pg(polgroup_neigh, mm2pol) + !! Take as input a matrix in which the n-th row stores the atoms + !! that are in the same polarization group as the n-th atom (rows are + !! padded with zeros) and assign to each atom a group index, according to + !! the input information. This is a way of compressing and making more + !! clear the handling of polarization groups. + + use mod_memory, only : ip + + implicit none + + integer(ip), intent(in) :: polgroup_neigh(:,:) + integer(ip), intent(out) :: mm2pol(:) + + integer(ip) :: i, j, maxn, ipg, mm_atoms + + mm2pol = 0 + ipg = 1 + maxn = size(polgroup_neigh, 1) + mm_atoms = size(polgroup_neigh, 2) + + do i=1, mm_atoms + if(mm2pol(i) == 0) then + ! This is a new group + do j=1, maxn + if(polgroup_neigh(j,i) == 0) exit + if(mm2pol(polgroup_neigh(j,i)) /= 0) then + call fatal_error("Unexpected error in polgroup11_to_mm2pg") + end if + mm2pol(polgroup_neigh(j,i)) = ipg + end do + + ipg = ipg + 1 + end if + end do + + if( any(mm2pol == 0) ) then + call fatal_error("Unexpected error in polgroup11_to_mm2pg") + end if + + end subroutine polgroup11_to_mm2pg + + subroutine mmpol_init_from_xyz(sys_obj, xyz_file, prm_file) + !! This function read a Tinker xyz and prm files + !! and initialize all the quantities need to describe the environment + !! within this library. + use mod_mmpol, only: mmpol_prepare, mmpol_init, mmpol_init_nonbonded, & + mmpol_init_bonded + use mod_topology, only: ommp_topology_type, check_conn_matrix + use mod_electrostatics, only: ommp_electrostatics_type + + use mod_memory, only: ip, mfree, mallocate, memory_init + use mod_constants, only: angstrom2au, OMMP_VERBOSE_DEBUG + use mod_adjacency_mat, only: adj_mat_from_conn, yale_sparse, & + build_conn_upto_n + use mod_prm, only: check_keyword, assign_pol, assign_mpoles, & + assign_vdw, assign_bond, assign_angle, assign_urey, & + assign_strbnd, assign_opb, assign_pitors, & + assign_torsion, assign_tortors, assign_angtor, & + assign_strtor, assign_imptorsion, get_prm_ff_type + use mod_utils, only: starts_with_alpha, isreal, isint, & + str_to_lower, str_uncomment, & + tokenize_pure, atoi, atof + use mod_io, only: large_file_read + + implicit none + + type(ommp_system), intent(inout), target :: sys_obj + !! The system object to be initialized + character(len=*), intent(in) :: xyz_file + !! name of the input XYZ file + character(len=*), intent(in) :: prm_file + !! name of the input PRM file + + integer(ip), parameter :: iof_xyzinp = 200, & + maxn12 = 8 + integer(ip) :: my_mm_atoms, ist, i, j, atom_id, lc, tokx(2) + integer(ip), allocatable :: i12(:,:), attype(:) + character(len=OMMP_STR_CHAR_MAX) :: msg + character(len=OMMP_STR_CHAR_MAX), allocatable :: lines(:), prm_buf(:) + logical :: fex + type(yale_sparse) :: adj + type(ommp_topology_type), pointer :: top + type(ommp_electrostatics_type), pointer :: eel + + call time_push() + call time_push() + ! Check that files are present + inquire(file=prm_file(1:len(trim(prm_file))), exist=fex) + if(.not. fex) then + call fatal_error("Input file '"//& + &prm_file(1:len(trim(prm_file)))//"' does not exist.") + end if + + inquire(file=xyz_file(1:len(trim(xyz_file))), exist=fex) + if(.not. fex) then + call fatal_error("Input file '"//& + &xyz_file(1:len(trim(xyz_file)))//"' does not exist.") + end if + + write(msg, "(A)") "Reading XYZ file: "//xyz_file(1:len(trim(xyz_file))) + call ommp_message(msg, OMMP_VERBOSE_DEBUG) + + ! read tinker xyz file + call time_push() + call large_file_read(xyz_file, lines) + call time_pull('XYZ File reading') + call large_file_read(prm_file, prm_buf) + ! Remove comments from prm file + !$omp parallel do + do i=1, size(prm_buf) + prm_buf(i) = str_to_lower(prm_buf(i)) + prm_buf(i) = str_uncomment(prm_buf(i), '!') + end do + + ! First line contains as first word the number of atoms and + ! then a comment that could be ignored. + read(lines(1), *) my_mm_atoms + + ! Initialize the mmpol module + ! TODO I'm assuming that it is AMOEBA and fully polarizable + + call mmpol_init(sys_obj, get_prm_ff_type(prm_buf), & + my_mm_atoms, my_mm_atoms) + ! Those are just shortcut + top => sys_obj%top + eel => sys_obj%eel + + ! Temporary quantities that are only used during the initialization + call mallocate('mmpol_init_from_xyz [attype]', my_mm_atoms, attype) + call mallocate('mmpol_init_from_xyz [i12]', maxn12, my_mm_atoms, i12) + + call time_push() + !$omp parallel do default(shared) private(i, lc, tokx) & + !$omp private(atom_id, j) + do i=1, my_mm_atoms + lc = i+1 + + ! Initializations + attype(i) = 0_ip + i12(:,i) = 0_ip + eel%polar_mm(i) = i + eel%pol(i) = 0.0 + + ! First token contains an atom ID. Only sequential numbering is + ! currently supported. + !dir$ forceinline + tokx = tokenize_pure(lines(lc)) + !dir$ forceinline + tokx = tokenize_pure(lines(lc), tokx(2)) + + atom_id = atoi(lines(lc)(tokx(1):tokx(2))) + if(atom_id /= i) then + call fatal_error('Non-sequential atom ids in xyz cannot be handled') + end if + + ! This token should contain an atom name, so it should start + ! with a letter. If this is not true, an unexpected error should + ! be raised. + !dir$ forceinline + tokx = tokenize_pure(lines(lc), tokx(2)+1) + if(isreal(lines(lc)(tokx(1):tokx(2)))) then + call fatal_error('Atom symbol missing (or completely numerical) or PBC string present in XYZ') + end if + + ! The remaining part contains cartesian coordinates, atom type + ! and connectivity for the current atom. + do j=1, 3 + ! Read coordinates and convert to angstrom + !dir$ forceinline + tokx = tokenize_pure(lines(lc), tokx(2)+1) + top%cmm(j,i) = atof(lines(lc)(tokx(1):tokx(2))) * angstrom2au + end do + + !dir$ forceinline + tokx = tokenize_pure(lines(lc), tokx(2)+1) + attype(i) = atoi(lines(lc)(tokx(1):tokx(2))) + + do j=1, maxn12 + !dir$ forceinline + tokx = tokenize_pure(lines(lc), tokx(2)+1) + if(tokx(2) < 0) exit + i12(j,i) = atoi(lines(lc)(tokx(1):tokx(2))) + end do + end do + deallocate(lines) + call time_pull('Interpreting XYZ') + + ! Writes the adjacency matrix in Yale sparse format in adj and then + ! build the connectivity up to 4th order. This is needed here to be + ! able to assign the parameters + + call adj_mat_from_conn(i12, adj) + call build_conn_upto_n(adj, 4, top%conn, .false.) + + call mfree('mmpol_init_from_xyz [i12]', i12) + + if( .not. check_keyword(prm_buf)) then + call fatal_error("PRM file cannot be completely understood") + end if + call time_pull("XYZ reading and topology generation") + + top%attype = attype + top%attype_initialized = .true. + call mfree('mmpol_init_from_xyz [attype]', attype) + + call time_push() + call ommp_message("Assigning electrostatic parameters", OMMP_VERBOSE_DEBUG) + call assign_pol(eel, prm_buf) + call assign_mpoles(eel, prm_buf) + + call ommp_message("Assigning non-bonded parameters", OMMP_VERBOSE_DEBUG) + call mmpol_init_nonbonded(sys_obj) + call assign_vdw(sys_obj%vdw, top, prm_buf) + + call ommp_message("Assigning bonded parameters", OMMP_VERBOSE_DEBUG) + call mmpol_init_bonded(sys_obj) + call check_conn_matrix(sys_obj%top, 4) + call assign_bond(sys_obj%bds, prm_buf) + call assign_angle(sys_obj%bds, prm_buf) + call assign_urey(sys_obj%bds, prm_buf) + call assign_strbnd(sys_obj%bds, prm_buf) + call assign_opb(sys_obj%bds, prm_buf) + call assign_pitors(sys_obj%bds, prm_buf) + call assign_torsion(sys_obj%bds, prm_buf) + call assign_imptorsion(sys_obj%bds, prm_buf) + call assign_tortors(sys_obj%bds, prm_buf) + call assign_angtor(sys_obj%bds, prm_buf) + call assign_strtor(sys_obj%bds, prm_buf) + call time_pull('Total prm assignament') + + deallocate(prm_buf) + + call mmpol_prepare(sys_obj) + call time_pull('MMPol initialization from .xyz file') + + end subroutine mmpol_init_from_xyz + +end module mod_inputloader diff --git a/src/mod_inputloader.f90 b/src/mod_inputloader.f90 deleted file mode 100644 index fa37be6..0000000 --- a/src/mod_inputloader.f90 +++ /dev/null @@ -1,494 +0,0 @@ -module mod_inputloader - use mod_io, only: ommp_message, fatal_error - use mod_profiling, only: time_push, time_pull - use mod_constants, only: OMMP_STR_CHAR_MAX - - use mod_mmpol, only: ommp_system - - implicit none - private - - public :: mmpol_init_from_mmp, mmpol_init_from_xyz - - contains - - subroutine mmpol_init_from_mmp(input_file, sys_obj) - !! This function read a .mmp file (revision 2 and 3) are supported - !! and initialize all the quantities need to describe the environment - !! within this library. - - use mod_mmpol, only: mmpol_prepare, mmpol_init - use mod_electrostatics, only: set_screening_parameters - - use mod_memory, only: ip, rp, mfree, mallocate, memory_init - use mod_io, only: iof_mmpinp - use mod_adjacency_mat, only: adj_mat_from_conn - use mod_utils, only: skip_lines - use mod_constants, only: angstrom2au, OMMP_VERBOSE_DEBUG - use mod_constants, only: mscale_wang_al, & - pscale_wang_al, & - dscale_wang_al, & - uscale_wang_al, & - mscale_wang_dl, & - pscale_wang_dl, & - dscale_wang_dl, & - uscale_wang_dl, & - mscale_amoeba, & - pscale_amoeba, & - dscale_amoeba, & - uscale_amoeba, & - pscale_intra_amoeba, & - thole_scale_wang_dl, & - thole_scale_wang_al - - implicit none - - type(ommp_system), intent(inout) :: sys_obj - !! System data structure to be initialized - - character(len=*), intent(in) :: input_file - !! name of the input file - - ! read the input for the mmpol calculation and process it. - integer(ip) :: input_revision - integer(ip) :: my_mm_atoms, my_pol_atoms, my_ff_type, my_ff_rules - integer(ip) :: my_ld_cart - - integer(ip) :: i, ist - - real(rp), allocatable :: my_pol(:), my_cmm(:,:), my_q(:,:) - integer(ip), allocatable :: pol_atoms_list(:), my_ip11(:,:) - - integer(ip), parameter :: maxn12 = 8 - !! maximum number of neighbour atoms - integer(ip), parameter :: maxpgp = 120 - !! maximum number of members for the same polarization group - real(rp), parameter :: thres = 1e-8 - !! Threshold used to decide if a polarizability is zero - ! TODO why we do not use eps_rp directly? - - integer(ip), allocatable :: i12(:,:) - character(len=OMMP_STR_CHAR_MAX) :: msg - logical :: fex - - call time_push() - write(msg, "(A)") "Reading MMP file: "//input_file(1:len(trim(input_file))) - call ommp_message(msg, OMMP_VERBOSE_DEBUG) - - inquire(file=input_file(1:len(trim(input_file))), exist=fex) - if(.not. fex) then - call fatal_error("Input file '"//& - &input_file(1:len(trim(input_file)))//"' does not exist.") - end if - - open(unit=iof_mmpinp, & - file=input_file(1:len(trim(input_file))), & - form='formatted', & - access='sequential', & - iostat=ist, & - action='read') - - if(ist /= 0) then - call fatal_error('Error while opening MMP input file') - end if - - call ommp_message("Reading input parameters", OMMP_VERBOSE_DEBUG) - - ! Read input revision, supported revisions are 2 and 3. - read(iof_mmpinp,*) input_revision - - if (input_revision /= 3 .and. input_revision /= 2) & - call fatal_error('MMP file is only supported with version 2 or 3.') - - !TODO - call memory_init(.false., 0.0_rp) - - call skip_lines(iof_mmpinp, 2) - read(iof_mmpinp,*) my_ff_type - read(iof_mmpinp,*) my_ff_rules - - if(input_revision == 3) then - call skip_lines(iof_mmpinp, 17) - else if(input_revision == 2) then - call skip_lines(iof_mmpinp, 15) - end if - - read(iof_mmpinp,*) my_mm_atoms - - if(my_ff_type == 1) then - my_ld_cart = 10 - else - my_ld_cart = 1 - end if - - call ommp_message("Allocating memory", OMMP_VERBOSE_DEBUG) - - call mallocate('mmpol_init_from_mmp [my_cmm]', 3_ip, my_mm_atoms, my_cmm) - call mallocate('mmpol_init_from_mmp [my_q]', my_ld_cart, my_mm_atoms, my_q) - call mallocate('mmpol_init_from_mmp [my_pol]', my_mm_atoms, my_pol) - call mallocate('mmpol_init_from_mmp [my_pol_atoms]', my_mm_atoms, pol_atoms_list) - call mallocate('mmpol_init_from_mmp [my_ip11]', maxpgp, my_mm_atoms, my_ip11) - - call skip_lines(iof_mmpinp, my_mm_atoms+1) ! Skip a zero and the section of atomic numbers - - call ommp_message("Reading coordinates", OMMP_VERBOSE_DEBUG) - ! coordinates: - do i = 1, my_mm_atoms - read(iof_mmpinp,*) my_cmm(1:3,i) - end do - - call skip_lines(iof_mmpinp, my_mm_atoms) ! Skip section of residues number - - call ommp_message("Reading fixed multipoles", OMMP_VERBOSE_DEBUG) - ! charges/multipoles: - do i = 1, my_mm_atoms - read(iof_mmpinp,*) my_q(1:my_ld_cart,i) - end do - - call ommp_message("Reading polarizabilities", OMMP_VERBOSE_DEBUG) - ! polarizabilities: - my_pol = 0.0_rp - do i = 1, my_mm_atoms - read(iof_mmpinp,*) my_pol(i) - end do - - call ommp_message("Processing polarizabilities", OMMP_VERBOSE_DEBUG) - ! count how many atoms are polarizable: - ! TODO this is more efficiently done with pack and count - my_pol_atoms = 0 - pol_atoms_list(:) = 0 - do i = 1, my_mm_atoms - if (my_pol(i) > thres) then - my_pol_atoms = my_pol_atoms + 1 - pol_atoms_list(my_pol_atoms) = i - end if - end do - - ! remove null polarizabilities from the list - do i = 1, my_pol_atoms - my_pol(i) = my_pol(pol_atoms_list(i)) - end do - my_pol(my_pol_atoms+1:my_mm_atoms) = 0.0_rp - - call ommp_message("Initializing open mmpol module", OMMP_VERBOSE_DEBUG) - ! mmpol module initialization - call mmpol_init(sys_obj, my_ff_type, my_mm_atoms, my_pol_atoms) - if(sys_obj%amoeba) then - call set_screening_parameters(sys_obj%eel, & - mscale_amoeba, & - pscale_amoeba, & - dscale_amoeba, & - uscale_amoeba, & - pscale_intra_amoeba) - sys_obj%eel%thole_scale = 0.0_rp - else - if(my_ff_rules == 1) then - call set_screening_parameters(sys_obj%eel, & - mscale_wang_dl, & - pscale_wang_dl, & - dscale_wang_dl, & - uscale_wang_dl) - sys_obj%eel%thole_scale = thole_scale_wang_dl - else if(my_ff_rules == 0) then - call set_screening_parameters(sys_obj%eel, & - mscale_wang_al, & - pscale_wang_al, & - dscale_wang_al, & - uscale_wang_al) - sys_obj%eel%thole_scale = thole_scale_wang_al - end if - end if - - call ommp_message("Converting input units to A.U.", OMMP_VERBOSE_DEBUG) - ! Copy data in the correct units (this means AU) - sys_obj%top%cmm = my_cmm * angstrom2au - sys_obj%eel%q = my_q - if(sys_obj%amoeba) then - my_pol = my_pol*angstrom2au**3 - end if - sys_obj%eel%pol = my_pol(1:my_pol_atoms) - sys_obj%eel%polar_mm = pol_atoms_list(1:my_pol_atoms) - - call mfree('mmpol_init_from_mmp [my_cmm]', my_cmm) - call mfree('mmpol_init_from_mmp [my_q]', my_q) - call mfree('mmpol_init_from_mmp [pol]', my_pol) - - call ommp_message("Processing connectivity informations", OMMP_VERBOSE_DEBUG) - - ! 1-2 connectivity: - call mallocate('mmpol_init_from_mmp [i12]', maxn12, my_mm_atoms, i12) - do i = 1, my_mm_atoms - read(iof_mmpinp,*) i12(1:maxn12,i) - end do - - ! Writes the adjacency matrix in Yale sparse format in conn(1) - call adj_mat_from_conn(i12, sys_obj%top%conn(1)) - call mfree('mmpol_init_from_mmp [i12]', i12) - - if(sys_obj%amoeba) then - ! group 11 connectivity: - ! (to be replaced with polarization group) - do i = 1, my_mm_atoms - read(iof_mmpinp,*) my_ip11(1:maxpgp,i) - end do - - call polgroup11_to_mm2pg(my_ip11, sys_obj%eel%mmat_polgrp) - call mfree('mmpol_init_from_mmp [my_ip11]', my_ip11) - - ! information to rotate the multipoles to the lab frame. - ! mol_frame, iz, ix, iy: - do i = 1, my_mm_atoms - read(iof_mmpinp,*) sys_obj%eel%mol_frame(i), & - sys_obj%eel%iz(i), sys_obj%eel%ix(i), & - sys_obj%eel%iy(i) - end do - end if - ! now, process the input, create all the required arrays - ! and the correspondence lists: - - call ommp_message("Populating utility arrays", OMMP_VERBOSE_DEBUG) - call mmpol_prepare(sys_obj) - close(iof_mmpinp) - call ommp_message("Initialization from MMP file done.", OMMP_VERBOSE_DEBUG) - call time_pull('MMPol initialization from .mmp file') - end subroutine mmpol_init_from_mmp - - subroutine polgroup11_to_mm2pg(polgroup_neigh, mm2pol) - !! Take as input a matrix in which the n-th row stores the atoms - !! that are in the same polarization group as the n-th atom (rows are - !! padded with zeros) and assign to each atom a group index, according to - !! the input information. This is a way of compressing and making more - !! clear the handling of polarization groups. - - use mod_memory, only : ip - - implicit none - - integer(ip), intent(in) :: polgroup_neigh(:,:) - integer(ip), intent(out) :: mm2pol(:) - - integer(ip) :: i, j, maxn, ipg, mm_atoms - - mm2pol = 0 - ipg = 1 - maxn = size(polgroup_neigh, 1) - mm_atoms = size(polgroup_neigh, 2) - - do i=1, mm_atoms - if(mm2pol(i) == 0) then - ! This is a new group - do j=1, maxn - if(polgroup_neigh(j,i) == 0) exit - if(mm2pol(polgroup_neigh(j,i)) /= 0) then - call fatal_error("Unexpected error in polgroup11_to_mm2pg") - end if - mm2pol(polgroup_neigh(j,i)) = ipg - end do - - ipg = ipg + 1 - end if - end do - - if( any(mm2pol == 0) ) then - call fatal_error("Unexpected error in polgroup11_to_mm2pg") - end if - - end subroutine polgroup11_to_mm2pg - - subroutine mmpol_init_from_xyz(sys_obj, xyz_file, prm_file) - !! This function read a Tinker xyz and prm files - !! and initialize all the quantities need to describe the environment - !! within this library. - use mod_mmpol, only: mmpol_prepare, mmpol_init, mmpol_init_nonbonded, & - mmpol_init_bonded - use mod_topology, only: ommp_topology_type, check_conn_matrix - use mod_electrostatics, only: ommp_electrostatics_type - - use mod_memory, only: ip, mfree, mallocate, memory_init - use mod_constants, only: angstrom2au, OMMP_VERBOSE_DEBUG - use mod_adjacency_mat, only: adj_mat_from_conn, yale_sparse, & - build_conn_upto_n - use mod_prm, only: check_keyword, assign_pol, assign_mpoles, & - assign_vdw, assign_bond, assign_angle, assign_urey, & - assign_strbnd, assign_opb, assign_pitors, & - assign_torsion, assign_tortors, assign_angtor, & - assign_strtor, assign_imptorsion, get_prm_ff_type - use mod_utils, only: starts_with_alpha, isreal, isint, & - str_to_lower, str_uncomment, & - tokenize_pure, atoi, atof - use mod_io, only: large_file_read - - implicit none - - type(ommp_system), intent(inout), target :: sys_obj - !! The system object to be initialized - character(len=*), intent(in) :: xyz_file - !! name of the input XYZ file - character(len=*), intent(in) :: prm_file - !! name of the input PRM file - - integer(ip), parameter :: iof_xyzinp = 200, & - maxn12 = 8 - integer(ip) :: my_mm_atoms, ist, i, j, atom_id, lc, tokx(2) - integer(ip), allocatable :: i12(:,:), attype(:) - character(len=OMMP_STR_CHAR_MAX) :: msg - character(len=OMMP_STR_CHAR_MAX), allocatable :: lines(:), prm_buf(:) - logical :: fex - type(yale_sparse) :: adj - type(ommp_topology_type), pointer :: top - type(ommp_electrostatics_type), pointer :: eel - - call time_push() - call time_push() - ! Check that files are present - inquire(file=prm_file(1:len(trim(prm_file))), exist=fex) - if(.not. fex) then - call fatal_error("Input file '"//& - &prm_file(1:len(trim(prm_file)))//"' does not exist.") - end if - - inquire(file=xyz_file(1:len(trim(xyz_file))), exist=fex) - if(.not. fex) then - call fatal_error("Input file '"//& - &xyz_file(1:len(trim(xyz_file)))//"' does not exist.") - end if - - write(msg, "(A)") "Reading XYZ file: "//xyz_file(1:len(trim(xyz_file))) - call ommp_message(msg, OMMP_VERBOSE_DEBUG) - - ! read tinker xyz file - call time_push() - call large_file_read(xyz_file, lines) - call time_pull('XYZ File reading') - call large_file_read(prm_file, prm_buf) - ! Remove comments from prm file - !$omp parallel do - do i=1, size(prm_buf) - prm_buf(i) = str_to_lower(prm_buf(i)) - prm_buf(i) = str_uncomment(prm_buf(i), '!') - end do - - ! First line contains as first word the number of atoms and - ! then a comment that could be ignored. - read(lines(1), *) my_mm_atoms - - ! Initialize the mmpol module - ! TODO I'm assuming that it is AMOEBA and fully polarizable - - call mmpol_init(sys_obj, get_prm_ff_type(prm_buf), & - my_mm_atoms, my_mm_atoms) - ! Those are just shortcut - top => sys_obj%top - eel => sys_obj%eel - - ! Temporary quantities that are only used during the initialization - call mallocate('mmpol_init_from_xyz [attype]', my_mm_atoms, attype) - call mallocate('mmpol_init_from_xyz [i12]', maxn12, my_mm_atoms, i12) - - call time_push() - !$omp parallel do default(shared) private(i, lc, tokx) & - !$omp private(atom_id, j) - do i=1, my_mm_atoms - lc = i+1 - - ! Initializations - attype(i) = 0_ip - i12(:,i) = 0_ip - eel%polar_mm(i) = i - eel%pol(i) = 0.0 - - ! First token contains an atom ID. Only sequential numbering is - ! currently supported. - !dir$ forceinline - tokx = tokenize_pure(lines(lc)) - !dir$ forceinline - tokx = tokenize_pure(lines(lc), tokx(2)) - - atom_id = atoi(lines(lc)(tokx(1):tokx(2))) - if(atom_id /= i) then - call fatal_error('Non-sequential atom ids in xyz cannot be handled') - end if - - ! This token should contain an atom name, so it should start - ! with a letter. If this is not true, an unexpected error should - ! be raised. - !dir$ forceinline - tokx = tokenize_pure(lines(lc), tokx(2)+1) - if(isreal(lines(lc)(tokx(1):tokx(2)))) then - call fatal_error('Atom symbol missing (or completely numerical) or PBC string present in XYZ') - end if - - ! The remaining part contains cartesian coordinates, atom type - ! and connectivity for the current atom. - do j=1, 3 - ! Read coordinates and convert to angstrom - !dir$ forceinline - tokx = tokenize_pure(lines(lc), tokx(2)+1) - top%cmm(j,i) = atof(lines(lc)(tokx(1):tokx(2))) * angstrom2au - end do - - !dir$ forceinline - tokx = tokenize_pure(lines(lc), tokx(2)+1) - attype(i) = atoi(lines(lc)(tokx(1):tokx(2))) - - do j=1, maxn12 - !dir$ forceinline - tokx = tokenize_pure(lines(lc), tokx(2)+1) - if(tokx(2) < 0) exit - i12(j,i) = atoi(lines(lc)(tokx(1):tokx(2))) - end do - end do - deallocate(lines) - call time_pull('Interpreting XYZ') - - ! Writes the adjacency matrix in Yale sparse format in adj and then - ! build the connectivity up to 4th order. This is needed here to be - ! able to assign the parameters - - call adj_mat_from_conn(i12, adj) - call build_conn_upto_n(adj, 4, top%conn, .false.) - - call mfree('mmpol_init_from_xyz [i12]', i12) - - if( .not. check_keyword(prm_buf)) then - call fatal_error("PRM file cannot be completely understood") - end if - call time_pull("XYZ reading and topology generation") - - top%attype = attype - top%attype_initialized = .true. - call mfree('mmpol_init_from_xyz [attype]', attype) - - call time_push() - call ommp_message("Assigning electrostatic parameters", OMMP_VERBOSE_DEBUG) - call assign_pol(eel, prm_buf) - call assign_mpoles(eel, prm_buf) - - call ommp_message("Assigning non-bonded parameters", OMMP_VERBOSE_DEBUG) - call mmpol_init_nonbonded(sys_obj) - call assign_vdw(sys_obj%vdw, top, prm_buf) - - call ommp_message("Assigning bonded parameters", OMMP_VERBOSE_DEBUG) - call mmpol_init_bonded(sys_obj) - call check_conn_matrix(sys_obj%top, 4) - call assign_bond(sys_obj%bds, prm_buf) - call assign_angle(sys_obj%bds, prm_buf) - call assign_urey(sys_obj%bds, prm_buf) - call assign_strbnd(sys_obj%bds, prm_buf) - call assign_opb(sys_obj%bds, prm_buf) - call assign_pitors(sys_obj%bds, prm_buf) - call assign_torsion(sys_obj%bds, prm_buf) - call assign_imptorsion(sys_obj%bds, prm_buf) - call assign_tortors(sys_obj%bds, prm_buf) - call assign_angtor(sys_obj%bds, prm_buf) - call assign_strtor(sys_obj%bds, prm_buf) - call time_pull('Total prm assignament') - - deallocate(prm_buf) - - call mmpol_prepare(sys_obj) - call time_pull('MMPol initialization from .xyz file') - - end subroutine mmpol_init_from_xyz - -end module mod_inputloader diff --git a/src/mod_interface.F90 b/src/mod_interface.F90 new file mode 100644 index 0000000..e6136bb --- /dev/null +++ b/src/mod_interface.F90 @@ -0,0 +1,1505 @@ +#include "f_cart_components.h" +#include "version.h" +! Wrapper function for open-mmpol library +module ommp_interface + !! The interface of the library, basically all the operation performed + !! by an external code should be done through the routines of this + !! module. + !! The interface is conceived to work naturally with C and Fortran; the C + !! interface is also used to build the interface for Python. + !! In a fortran code, this module can be imported and it should expose + !! directly all the vector and scalar quantities needed. + !! In a C code, routines are provided to get the pointer or the values of + !! vector and scalar quantites respectively. + + ! Renamed import of several global variables that should be available + ! in the interface + use mod_constants, only: OMMP_FF_AMOEBA, OMMP_FF_WANG_AL, OMMP_FF_WANG_DL, & + OMMP_SOLVER_CG, OMMP_SOLVER_DIIS, & + OMMP_SOLVER_INVERSION, OMMP_SOLVER_DEFAULT, & + OMMP_SOLVER_NONE, & + OMMP_MATV_INCORE, OMMP_MATV_DIRECT, & + OMMP_MATV_DEFAULT, OMMP_MATV_NONE, & + OMMP_VERBOSE_DEBUG, OMMP_VERBOSE_HIGH, & + OMMP_VERBOSE_LOW, OMMP_VERBOSE_NONE, & + OMMP_AU2KCALMOL => au2kcalmol, & + OMMP_ANG2AU => angstrom2au, & + OMMP_STR_CHAR_MAX + + ! Internal types + use mod_memory, only: ommp_integer => ip, & + ommp_real => rp, & + ommp_logical => lp + use mod_mmpol, only: ommp_system + use mod_electrostatics, only: ommp_electrostatics_type, set_def_solver, set_def_matv + use mod_topology, only: ommp_topology_type, set_frozen + use mod_qm_helper, only: ommp_qm_helper + + use mod_mmpol, only: ommp_save_mmp => mmpol_save_as_mmp, & + ommp_print_summary => mmpol_ommp_print_summary, & + ommp_update_coordinates => update_coordinates, & + ommp_print_summary_to_file => mmpol_ommp_print_summary + + use mod_io, only: ommp_set_verbose => set_verbosity, & + ommp_message, & + ommp_set_outputfile => set_iof_mmpol, & + ommp_close_outputfile => close_output, & + ommp_fatal => fatal_error, & + ommp_version + + use mod_qm_helper, only: ommp_qm_helper_set_attype => qm_helper_set_attype, & + ommp_qm_helper_init_vdw_prm => qm_helper_init_vdw_prm, & + ommp_qm_helper_init_vdw => qm_helper_init_vdw, & + ommp_prepare_qm_ele_ene => electrostatic_for_ene, & + ommp_prepare_qm_ele_grd => electrostatic_for_grad + + use mod_profiling, only: ommp_time_push => time_push, & + ommp_time_pull => time_pull + + use mod_iohdf5, only: mmpol_init_from_hdf5, save_system_as_hdf5 + + use mod_inputloader, only : mmpol_init_from_mmp, mmpol_init_from_xyz + + implicit none + + character(*), parameter :: ommp_version_string = _OMMP_VERSION + +contains + + subroutine ommp_set_default_solver(s, solver) + implicit none + + integer(ommp_integer), intent(in), value :: solver + type(ommp_system), pointer :: s + + + call set_def_solver(s%eel, solver) + end subroutine ommp_set_default_solver + + subroutine ommp_set_default_matv(s, matv) + implicit none + + integer(ommp_integer), intent(in), value :: matv + type(ommp_system), pointer :: s + + + call set_def_matv(s%eel, matv) + end subroutine ommp_set_default_matv + + subroutine ommp_init_mmp(s, filename) + implicit none + + type(ommp_system), pointer, intent(inout) :: s + character(len=*) :: filename + + call ommp_version(OMMP_VERBOSE_LOW) + allocate(s) + call mmpol_init_from_mmp(trim(filename), s) + end subroutine + + subroutine ommp_init_xyz(s, xyzfile, prmfile) + implicit none + + type(ommp_system), pointer, intent(inout) :: s + character(len=*) :: xyzfile, prmfile + + call ommp_version(OMMP_VERBOSE_LOW) + allocate(s) + call mmpol_init_from_xyz(s, trim(xyzfile), trim(prmfile)) + end subroutine + + subroutine ommp_set_frozen_atoms(s, n, frozen) + implicit none + + type(ommp_system), pointer, intent(inout) :: s + !! OpenMMPol system + integer(ommp_integer), intent(in) :: n, frozen(n) + !! Atoms to freeze + + if(minval(frozen) < 1) then + call ommp_fatal("Atom indexes are 1-based, so no index should be less than 1") + end if + if(maxval(frozen) > s%top%mm_atoms) then + call ommp_fatal("Atom indexes should be inside the topology range") + end if + call set_frozen(s%top, frozen) + end subroutine + + subroutine ommp_turn_pol_off(s, n, nopol) + use mod_electrostatics, only: remove_null_pol + use mod_io, only: ommp_message + use mod_constants, only: OMMP_STR_CHAR_MAX, & + OMMP_VERBOSE_LOW + + implicit none + + type(ommp_system), pointer, intent(inout) :: s + !! OpenMMPol system + integer(ommp_integer), intent(in) :: n, nopol(n) + !! Atoms to freeze in MM indexing + + integer(ommp_integer) :: i, j + character(len=OMMP_STR_CHAR_MAX) :: msg + + if(minval(nopol) < 1) then + call ommp_fatal("Atom indexes are 1-based, so no index should be less than 1") + end if + if(maxval(nopol) > s%top%mm_atoms) then + call ommp_fatal("Atom indexes should be inside the topology range") + end if + + do i=1, n + j = s%eel%mm_polar(i) + if(j > 0) then + s%eel%pol(j) = 0.0 + else + write(msg, "('Atom ', I0, ' is not polarizable. Ignoring.')") i + call ommp_message(msg, OMMP_VERBOSE_LOW) + end if + end do + + call remove_null_pol(s%eel) + + end subroutine + + subroutine ommp_terminate(s) + use mod_mmpol, only: mmpol_terminate + + implicit none + + type(ommp_system), pointer, intent(inout) :: s + + call mmpol_terminate(s) + + deallocate(s) + + end subroutine + + subroutine ommp_set_external_field(sys_obj, ext_field, solver, matv, & + add_mm_field) + !! This function get an external field and solve the polarization + !! system in the presence of the provided external field. + use mod_polarization, only: polarization + use mod_electrostatics, only: prepare_polelec + use mod_memory, only: mallocate, mfree + + implicit none + + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real), intent(in) :: ext_field(3,sys_obj%eel%pol_atoms) + integer(ommp_integer), intent(in), value :: solver + integer(ommp_integer), intent(in), value :: matv + logical, intent(in), value, optional :: add_mm_field + + type(ommp_electrostatics_type), pointer :: eel + real(ommp_real), allocatable :: ef(:,:,:) + integer :: i + logical :: do_mm_f + + eel => sys_obj%eel + + if(present(add_mm_field)) then + do_mm_f = add_mm_field + else + do_mm_f = .true. + end if + + eel%ipd_done = .false. + + if(do_mm_f) then + call mallocate('ommp_get_polelec_energy [ef]', & + 3, eel%pol_atoms, eel%n_ipd, ef) + call prepare_polelec(eel) + do i=1, eel%n_ipd + ef(:,:,i) = eel%e_m2d(:,:,i) + ext_field + end do + call polarization(sys_obj, ef, solver) + call mfree('ommp_get_polelec_energy [ef]', ef) + else + call mallocate('ommp_get_polelec_energy [ef]', & + 3, eel%pol_atoms, eel%n_ipd, ef) + + ef(:,:,1) = ext_field + call polarization(sys_obj, ef, solver, matv, [.true., .false.] ) + + call mfree('ommp_get_polelec_energy [ef]', ef) + end if + end subroutine ommp_set_external_field + + subroutine ommp_set_external_field_nomm(sys_obj, ext_field, solver, matv) + !! This is just the same as [[ommp_set_external_field]] but + !! implicitly assuming [[ommp_set_external_field:add_mm_field]] as + !! false, mainly here for interface consistency with C + + implicit none + + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real), intent(in) :: ext_field(3,sys_obj%eel%pol_atoms) + integer(ommp_integer), intent(in), value :: solver + integer(ommp_integer), intent(in), value :: matv + + call ommp_set_external_field(sys_obj, ext_field, solver, matv, .false.) + end subroutine + + subroutine ommp_potential_mmpol2ext(s, n, cext, v) + ! Compute the electric potential of static sites at + ! arbitrary coordinates + use mod_electrostatics, only: potential_D2E, & + potential_M2E + + implicit none + + type(ommp_system), intent(inout), target :: s + integer(ommp_integer), intent(in) :: n + real(ommp_real), intent(in) :: cext(3,n) + real(ommp_real), intent(inout) :: v(n) + + call potential_M2E(s%eel, cext, v) + call potential_D2E(s%eel, cext, v) + end subroutine + + subroutine ommp_potential_pol2ext(s, n, cext, v) + ! Compute the electric potential of static sites at + ! arbitrary coordinates + use mod_electrostatics, only: potential_D2E + + implicit none + + type(ommp_system), intent(inout), target :: s + integer(ommp_integer), intent(in) :: n + real(ommp_real), intent(in) :: cext(3,n) + real(ommp_real), intent(inout) :: v(n) + + call potential_D2E(s%eel, cext, v) + end subroutine + + subroutine ommp_potential_mm2ext(s, n, cext, v) + ! Compute the electric potential of static sites at + ! arbitrary coordinates + use mod_electrostatics, only: potential_M2E + + implicit none + + type(ommp_system), intent(inout), target :: s + integer(ommp_integer), intent(in) :: n + real(ommp_real), intent(in) :: cext(3,n) + real(ommp_real), intent(inout) :: v(n) + + call potential_M2E(s%eel, cext, v) + end subroutine + + subroutine ommp_field_mmpol2ext(s, n, cext, E) + ! Compute the electric potential of static sites at + ! arbitrary coordinates + use mod_electrostatics, only: field_D2E, field_M2E + + implicit none + + integer(ommp_integer), intent(in), value :: n + type(ommp_system), intent(in), target :: s + real(ommp_real), intent(in) :: cext(3,n) + real(ommp_real), intent(out) :: E(3,n) + + call field_M2E(s%eel, cext, E) + call field_D2E(s%eel, cext, E) + end subroutine + + subroutine ommp_field_mm2ext(s, n, cext, E) + ! Compute the electric potential of static sites at + ! arbitrary coordinates + use mod_electrostatics, only: field_M2E + + implicit none + + integer(ommp_integer), intent(in), value :: n + type(ommp_system), intent(in), target :: s + real(ommp_real), intent(in) :: cext(3,n) + real(ommp_real), intent(out) :: E(3,n) + + call field_M2E(s%eel, cext, E) + end subroutine + + subroutine ommp_field_pol2ext(s, n, cext, E) + ! Compute the electric potential of static sites at + ! arbitrary coordinates + use mod_electrostatics, only: field_D2E + + implicit none + + integer(ommp_integer), intent(in), value :: n + type(ommp_system), intent(in), target :: s + real(ommp_real), intent(in) :: cext(3,n) + real(ommp_real), intent(out) :: E(3,n) + + call field_D2E(s%eel, cext, E) + end subroutine + + function ommp_get_polelec_energy(sys_obj) result(ene) + !! Solve the polarization equation for a certain external field + !! and compute the interaction energy of the induced dipoles with + !! themselves and fixed multipoles. + + use mod_electrostatics, only: energy_MM_pol, prepare_polelec + use mod_polarization, only: polarization + + implicit none + + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real) :: ene + + call ommp_time_push() + if(sys_obj%eel%pol_atoms == 0) then + ene = 0.0 + else + if(.not. sys_obj%eel%ipd_done) then + !! Solve the polarization system without external field + call prepare_polelec(sys_obj%eel) + call polarization(sys_obj, sys_obj%eel%e_m2d) + end if + + ene = 0.0 + call energy_MM_pol(sys_obj%eel, ene) + end if + call ommp_time_pull('Polarizable Electrostatic energy') + end function + + function ommp_get_fixedelec_energy(sys_obj) result(ene) + + use mod_electrostatics, only: energy_MM_MM + + implicit none + + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real) :: ene + + call ommp_time_push() + ene = 0.0 + call energy_MM_MM(sys_obj%eel, ene) + call ommp_time_pull('Fixed Electrostatic energy') + + end function + + function ommp_get_full_ele_energy(sys_obj) result(ene) + + implicit none + + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real) :: ene + + ene = ommp_get_fixedelec_energy(sys_obj) + ene = ene + ommp_get_polelec_energy(sys_obj) + + end function + + function ommp_get_vdw_energy(sys_obj) result(evdw) + + use mod_nonbonded, only: vdw_potential + + implicit none + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real) :: evdw + + call ommp_time_push() + evdw = 0.0 + if(sys_obj%use_nonbonded) call vdw_potential(sys_obj%vdw, evdw) + call ommp_time_pull('Non-bonded energy') + + end function + + function ommp_get_bond_energy(sys_obj) result(eb) + + use mod_bonded, only: bond_potential + use mod_link_atom, only: link_atom_update_merged_topology + + implicit none + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real) :: eb + + call ommp_time_push() + eb = 0.0 + if(sys_obj%use_bonded) then + call bond_potential(sys_obj%bds, eb) + if(sys_obj%use_linkatoms) then + call link_atom_update_merged_topology(sys_obj%la) + call bond_potential(sys_obj%la%bds, eb) + endif + end if + call ommp_time_pull('Bonded energy') + + end function + + function ommp_get_angle_energy(sys_obj) result(ea) + + use mod_bonded, only: angle_potential + use mod_link_atom, only: link_atom_update_merged_topology + + implicit none + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real) :: ea + + call ommp_time_push() + ea = 0.0 + if(sys_obj%use_bonded) then + call angle_potential(sys_obj%bds, ea) + if(sys_obj%use_linkatoms) then + call link_atom_update_merged_topology(sys_obj%la) + call angle_potential(sys_obj%la%bds, ea) + end if + end if + call ommp_time_pull('Angle energy') + + end function + + function ommp_get_strbnd_energy(sys_obj) result(eba) + + use mod_bonded, only: strbnd_potential + + implicit none + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real) :: eba + + call ommp_time_push + eba = 0.0 + if(sys_obj%use_bonded) call strbnd_potential(sys_obj%bds, eba) + call ommp_time_pull('Stretching-bending energy') + + end function + + function ommp_get_urey_energy(sys_obj) result(eub) + + use mod_bonded, only: urey_potential + + implicit none + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real) :: eub + + call ommp_time_push + eub = 0.0 + if(sys_obj%use_bonded) call urey_potential(sys_obj%bds, eub) + call ommp_time_pull('Urey-Bradley energy') + + end function + + function ommp_get_opb_energy(sys_obj) result(eopb) + + use mod_bonded, only: opb_potential + + implicit none + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real) :: eopb + + call ommp_time_push + eopb = 0.0 + if(sys_obj%use_bonded) call opb_potential(sys_obj%bds, eopb) + call ommp_time_pull('Out of plane energy') + + end function + + function ommp_get_imptorsion_energy(sys_obj) result(et) + + use mod_bonded, only: imptorsion_potential + + implicit none + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real) :: et + + call ommp_time_push + et = 0.0 + if(sys_obj%use_bonded) call imptorsion_potential(sys_obj%bds, et) + call ommp_time_pull('Improper torsion energy') + + end function + + function ommp_get_torsion_energy(sys_obj) result(et) + + use mod_bonded, only: torsion_potential + use mod_link_atom, only: link_atom_update_merged_topology + + implicit none + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real) :: et + + call ommp_time_push + et = 0.0 + if(sys_obj%use_bonded) then + call torsion_potential(sys_obj%bds, et) + if(sys_obj%use_linkatoms) then + call link_atom_update_merged_topology(sys_obj%la) + call torsion_potential(sys_obj%la%bds, et) + end if + end if + call ommp_time_pull('Torsion energy') + + end function + + function ommp_get_pitors_energy(sys_obj) result(ept) + + use mod_bonded, only: pitors_potential + + implicit none + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real) :: ept + + call ommp_time_push + ept = 0.0 + if(sys_obj%use_bonded) call pitors_potential(sys_obj%bds, ept) + call ommp_time_pull('Pi-system torsion energy') + + end function + + function ommp_get_strtor_energy(sys_obj) result(est) + + use mod_bonded, only: strtor_potential + + implicit none + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real) :: est + + call ommp_time_push + est = 0.0 + if(sys_obj%use_bonded) call strtor_potential(sys_obj%bds, est) + call ommp_time_pull('Stretching-torsion energy') + + end function + + function ommp_get_angtor_energy(sys_obj) result(eat) + + use mod_bonded, only: angtor_potential + + implicit none + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real) :: eat + + call ommp_time_push + eat = 0.0 + if(sys_obj%use_bonded) call angtor_potential(sys_obj%bds, eat) + call ommp_time_pull('Bending-torsion energy') + + end function + + function ommp_get_tortor_energy(sys_obj) result(ett) + + use mod_bonded, only: tortor_potential + + implicit none + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real) :: ett + + call ommp_time_push + ett = 0.0 + if(sys_obj%use_bonded) call tortor_potential(sys_obj%bds, ett) + call ommp_time_pull('Torsion-torsion energy') + + end function + + function ommp_get_full_bnd_energy(sys_obj) result(ene) + + use mod_link_atom, only: link_atom_update_merged_topology + use mod_bonded, only: bond_potential, angtor_potential, & + strbnd_potential, urey_potential, & + opb_potential, pitors_potential, & + torsion_potential, tortor_potential, & + strtor_potential, angle_potential, & + imptorsion_potential + + implicit none + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real) :: ene + + call ommp_time_push + ene = 0.0 + + if(sys_obj%use_bonded) then + call bond_potential(sys_obj%bds, ene) + call angle_potential(sys_obj%bds, ene) + call strbnd_potential(sys_obj%bds, ene) + call urey_potential(sys_obj%bds, ene) + call opb_potential(sys_obj%bds, ene) + call imptorsion_potential(sys_obj%bds, ene) + call torsion_potential(sys_obj%bds, ene) + call pitors_potential(sys_obj%bds, ene) + call strtor_potential(sys_obj%bds, ene) + call angtor_potential(sys_obj%bds, ene) + call tortor_potential(sys_obj%bds, ene) + + if(sys_obj%use_linkatoms) then + call link_atom_update_merged_topology(sys_obj%la) + call bond_potential(sys_obj%la%bds, ene) + call angle_potential(sys_obj%la%bds, ene) + call torsion_potential(sys_obj%la%bds, ene) + end if + + end if + call ommp_time_pull('Total bond energy') + end function + + function ommp_get_full_energy(sys_obj) result(ene) + + implicit none + type(ommp_system), intent(inout), target :: sys_obj + real(ommp_real) :: ene + + call ommp_time_push + ene = 0.0 + ene = ene + ommp_get_vdw_energy(sys_obj) + ene = ene + ommp_get_full_ele_energy(sys_obj) + ene = ene + ommp_get_full_bnd_energy(sys_obj) + call ommp_time_pull('Total energy') + end function + + ! Functions for advanced operation and gradients + subroutine ommp_fixedelec_geomgrad(s, grd) + use mod_geomgrad, only: fixedelec_geomgrad + + implicit none + + type(ommp_system), intent(inout), target :: s + real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) + + call ommp_time_push + grd = 0.0 + call fixedelec_geomgrad(s, grd) + call ommp_time_pull('Fixed Elctrostatic grad') + end subroutine + + subroutine ommp_polelec_geomgrad(s, grd) + use mod_geomgrad, only: polelec_geomgrad + + implicit none + + type(ommp_system), intent(inout), target :: s + real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) + + call ommp_time_push + grd = 0.0 + if(s%eel%pol_atoms > 0) call polelec_geomgrad(s, grd) + call ommp_time_pull('Polarizable Elctrostatic grad') + end subroutine + + subroutine ommp_vdw_geomgrad(s, grd) + use mod_nonbonded, only: vdw_geomgrad + + implicit none + + type(ommp_system), intent(inout), target :: s + real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) + + call ommp_time_push + grd = 0.0 + if(s%use_nonbonded) call vdw_geomgrad(s%vdw, grd) + call ommp_time_pull('Non-bonded grad') + end subroutine + + subroutine ommp_rotation_geomgrad(s, E, Egrd, grd ) + implicit none + + type(ommp_system), intent(inout), target :: s + real(ommp_real), intent(in) :: E(:,:), Egrd(:,:) + real(ommp_real), intent(out) :: grd(:,:) + + call ommp_time_push + grd = 0.0 + call rotation_geomgrad(s%eel, E, Egrd, grd) + call ommp_time_pull('Multipole rotation grad') + end subroutine + + subroutine ommp_bond_geomgrad(s, grd) + use mod_bonded, only: bond_geomgrad + use mod_link_atom, only: link_atom_update_merged_topology, & + link_atom_bond_geomgrad + + implicit none + + type(ommp_system), intent(inout), target :: s + real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) + + real(ommp_real) :: fake_qmg(3,1) + + call ommp_time_push + grd = 0.0 + if(s%use_bonded) then + call bond_geomgrad(s%bds, grd) + if(s%use_linkatoms) then + call link_atom_update_merged_topology(s%la) + call link_atom_bond_geomgrad(s%la, & + fake_qmg, grd, & + .false., .true.) + end if + end if + call ommp_time_pull("Bonded grad") + end subroutine + + subroutine ommp_angle_geomgrad(s, grd) + use mod_bonded, only: angle_geomgrad + use mod_link_atom, only: link_atom_update_merged_topology, & + link_atom_angle_geomgrad + + implicit none + + type(ommp_system), intent(inout), target :: s + real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) + + real(ommp_real) :: fake_qmg(3,1) + + call ommp_time_push + grd = 0.0 + if(s%use_bonded) then + call angle_geomgrad(s%bds, grd) + if(s%use_linkatoms) then + call link_atom_update_merged_topology(s%la) + call link_atom_angle_geomgrad(s%la, & + fake_qmg, grd, & + .false., .true.) + end if + end if + call ommp_time_pull("Angle grad") + end subroutine + + subroutine ommp_strbnd_geomgrad(s, grd) + use mod_bonded, only: strbnd_geomgrad + + implicit none + + type(ommp_system), intent(inout), target :: s + real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) + + call ommp_time_push + grd = 0.0 + if(s%use_bonded) call strbnd_geomgrad(s%bds, grd) + call ommp_time_pull("Stretching-bending grad") + end subroutine + + subroutine ommp_urey_geomgrad(s, grd) + use mod_bonded, only: urey_geomgrad + + implicit none + + type(ommp_system), intent(inout), target :: s + real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) + + call ommp_time_push + grd = 0.0 + if(s%use_bonded) call urey_geomgrad(s%bds, grd) + call ommp_time_pull("Urey-Bradley grad") + end subroutine + + subroutine ommp_torsion_geomgrad(s, grd) + use mod_bonded, only: torsion_geomgrad + use mod_link_atom, only: link_atom_update_merged_topology, & + link_atom_torsion_geomgrad + + implicit none + + type(ommp_system), intent(inout), target :: s + real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) + + real(ommp_real) :: fake_qmg(3,1) + + call ommp_time_push + grd = 0.0 + if(s%use_bonded) then + call torsion_geomgrad(s%bds, grd) + if(s%use_linkatoms) then + call link_atom_update_merged_topology(s%la) + call link_atom_torsion_geomgrad(s%la, & + fake_qmg, grd, & + .false., .true.) + end if + end if + call ommp_time_pull("Torsion grad") + end subroutine + + subroutine ommp_imptorsion_geomgrad(s, grd) + use mod_bonded, only: imptorsion_geomgrad + + implicit none + + type(ommp_system), intent(inout), target :: s + real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) + + call ommp_time_push + grd = 0.0 + if(s%use_bonded) call imptorsion_geomgrad(s%bds, grd) + call ommp_time_pull("Improper torsion grad") + end subroutine + + subroutine ommp_angtor_geomgrad(s, grd) + use mod_bonded, only: angtor_geomgrad + + implicit none + + type(ommp_system), intent(inout), target :: s + real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) + + call ommp_time_push + grd = 0.0 + if(s%use_bonded) call angtor_geomgrad(s%bds, grd) + call ommp_time_pull("Angle-torsion grad") + end subroutine + + subroutine ommp_opb_geomgrad(s, grd) + use mod_bonded, only: opb_geomgrad + + implicit none + + type(ommp_system), intent(inout), target :: s + real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) + + call ommp_time_push + grd = 0.0 + if(s%use_bonded) call opb_geomgrad(s%bds, grd) + call ommp_time_pull("Out of plane grad") + end subroutine + + subroutine ommp_strtor_geomgrad(s, grd) + use mod_bonded, only: strtor_geomgrad + + implicit none + + type(ommp_system), intent(inout), target :: s + real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) + + call ommp_time_push + grd = 0.0 + if(s%use_bonded) call strtor_geomgrad(s%bds, grd) + call ommp_time_pull("Stretching-torsion grad") + end subroutine + + subroutine ommp_tortor_geomgrad(s, grd) + use mod_bonded, only: tortor_geomgrad + + implicit none + + type(ommp_system), intent(inout), target :: s + real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) + + call ommp_time_push + grd = 0.0 + if(s%use_bonded) call tortor_geomgrad(s%bds, grd) + call ommp_time_pull('Torsion-torsion grad') + end subroutine + + subroutine ommp_pitors_geomgrad(s, grd) + use mod_bonded, only: pitors_geomgrad + + implicit none + + type(ommp_system), intent(inout), target :: s + real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) + + call ommp_time_push + grd = 0.0 + if(s%use_bonded) call pitors_geomgrad(s%bds, grd) + call ommp_time_pull('Pi-system torsion grad') + end subroutine + + subroutine ommp_full_bnd_geomgrad(s, grd) + use mod_bonded, only: bond_geomgrad, & + angle_geomgrad, & + strbnd_geomgrad, & + urey_geomgrad, & + opb_geomgrad, & + imptorsion_geomgrad, & + torsion_geomgrad, & + pitors_geomgrad, & + strtor_geomgrad, & + angtor_geomgrad, & + tortor_geomgrad + use mod_link_atom, only: link_atom_update_merged_topology, & + link_atom_bond_geomgrad, & + link_atom_angle_geomgrad, & + link_atom_torsion_geomgrad + + implicit none + + type(ommp_system), intent(inout), target :: s + real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) + + real(ommp_real) :: fake_qmg(3,1) + + call ommp_time_push + grd = 0.0 + if(s%use_bonded) then + call bond_geomgrad(s%bds, grd) + call angle_geomgrad(s%bds, grd) + call strbnd_geomgrad(s%bds, grd) + call urey_geomgrad(s%bds, grd) + call opb_geomgrad(s%bds, grd) + call imptorsion_geomgrad(s%bds, grd) + call torsion_geomgrad(s%bds, grd) + call pitors_geomgrad(s%bds, grd) + call strtor_geomgrad(s%bds, grd) + call angtor_geomgrad(s%bds, grd) + call tortor_geomgrad(s%bds, grd) + if(s%use_linkatoms) then + call link_atom_update_merged_topology(s%la) + call link_atom_bond_geomgrad(s%la, & + fake_qmg, grd, & + .false., .true.) + call link_atom_angle_geomgrad(s%la, & + fake_qmg, grd, & + .false., .true.) + call link_atom_torsion_geomgrad(s%la, & + fake_qmg, grd, & + .false., .true.) + end if + end if + call ommp_time_pull("Total bonded grad") + end subroutine + + subroutine ommp_full_geomgrad(s, grd) + use mod_memory, only: mallocate + use mod_nonbonded, only: vdw_geomgrad + use mod_geomgrad, only: polelec_geomgrad, fixedelec_geomgrad + + implicit none + type(ommp_system), intent(inout), target :: s + real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) + + call ommp_time_push + grd = 0.0 + call ommp_full_bnd_geomgrad(s, grd) + call fixedelec_geomgrad(s, grd) + if(s%eel%pol_atoms > 0) call polelec_geomgrad(s, grd) + if(s%use_nonbonded) call vdw_geomgrad(s%vdw, grd) + call ommp_time_pull("Total grad") + + end subroutine + + subroutine ommp_init_hdf5(s, filename, namespace) + + implicit none + + type(ommp_system), pointer :: s + character(len=*) :: filename, namespace + integer(ommp_integer) :: ok + + call ommp_version(OMMP_VERBOSE_LOW) + allocate(s) + call mmpol_init_from_hdf5(filename, namespace, s, ok) + + end subroutine ommp_init_hdf5 + + subroutine ommp_save_as_hdf5(s, filename, namespace) + !! This function is an interface for saving an HDF5 file + !! with all the data contained in mmpol module using + !! [[mod_io:mmpol_save_as_hdf5]] + + implicit none + + character(len=*) :: filename, namespace + type(ommp_system), pointer :: s + integer(kind=4) :: err + + call save_system_as_hdf5(filename, & + s, & + err, & + namespace, & + logical(.false., kind=ommp_logical)) + + end subroutine ommp_save_as_hdf5 + + subroutine ommp_checkpoint(s, filename, namespace) + + implicit none + + character(len=*) :: filename, namespace + type(ommp_system), pointer :: s + integer(kind=4) :: err + + call save_system_as_hdf5(filename, & + s, & + err, & + namespace, & + logical(.true., kind=ommp_logical)) + + end subroutine ommp_checkpoint +! #endif + + ! QM Helper Object housekeeping + subroutine ommp_init_qm_helper(s, n, cqm, qqm, zqm) + + use mod_qm_helper, only: qm_helper_init + + implicit none + + type(ommp_qm_helper), pointer, intent(inout) :: s + integer(ommp_integer) :: n + real(ommp_real), intent(in) :: cqm(:,:), qqm(:) + integer(ommp_integer), intent(in) :: zqm(:) + + allocate(s) + call qm_helper_init(s, n, cqm, qqm, zqm) + end subroutine + + subroutine ommp_qm_helper_set_frozen_atoms(s, n, frozen) + use mod_topology, only: set_frozen + + implicit none + + type(ommp_qm_helper), pointer, intent(inout) :: s + !! OpenMMPol system + integer(ommp_integer), intent(in) :: n, frozen(n) + !! Atoms to freeze + + if(minval(frozen) < 1) then + call ommp_fatal("Atom indexes are 1-based, so no index should be less than 1") + end if + if(maxval(frozen) > s%qm_top%mm_atoms) then + call ommp_fatal("Atom indexes should be inside the topology range") + end if + call set_frozen(s%qm_top, frozen) + end subroutine + + subroutine ommp_terminate_qm_helper(s) + + use mod_qm_helper, only: qm_helper_terminate + + implicit none + + type(ommp_qm_helper), pointer, intent(inout) :: s + + call qm_helper_terminate(s) + deallocate(s) + end subroutine + + subroutine ommp_qm_helper_update_coord(s, cqm) + + use mod_qm_helper, only: qm_helper_update_coord + + implicit none + + type(ommp_qm_helper), intent(inout) :: s + real(ommp_real), intent(in) :: cqm(:,:) + + call qm_helper_update_coord(s, cqm) + end subroutine + + function ommp_qm_helper_vdw_energy(qm, s) result(evdw) + use mod_qm_helper, only: qm_helper_vdw_energy + + implicit none + + type(ommp_system), intent(inout) :: s + type(ommp_qm_helper), intent(in) :: qm + real(ommp_real) :: evdw + + evdw = 0.0 + call qm_helper_vdw_energy(qm, s, evdw) + end function + + subroutine ommp_qm_helper_vdw_geomgrad(qm, s, qmg, mmg) + + use mod_qm_helper, only: qm_helper_vdw_geomgrad + + implicit none + + type(ommp_system), intent(inout) :: s + type(ommp_qm_helper), intent(in) :: qm + real(ommp_real), intent(out) :: qmg(:,:), mmg(:,:) + + mmg = 0.0 + qmg = 0.0 + call qm_helper_vdw_geomgrad(qm, s, qmg, mmg) + end subroutine + + subroutine ommp_qm_helper_link_atom_geomgrad(qm, s, qmg, mmg, old_qmg) + + use mod_qm_helper, only: qm_helper_link_atom_geomgrad + + implicit none + + type(ommp_system), intent(inout) :: s + type(ommp_qm_helper), intent(in) :: qm + real(ommp_real), intent(out) :: qmg(:,:), mmg(:,:) + real(ommp_real), intent(in) :: old_qmg(:,:) + + mmg = 0.0 + qmg = 0.0 + call qm_helper_link_atom_geomgrad(qm, s, qmg, mmg, old_qmg) + end subroutine + + function ommp_create_link_atom(qm, s, imm, iqm, ila, prmfile, & + la_dist_in, n_eel_remove_in) result(la_idx) +#define _MM_ 1 +#define _QM_ 2 +#define _LA_ 3 + use mod_link_atom, only: link_atom_position, init_link_atom, & + default_link_atom_dist, default_link_atom_n_eel_remove, & + init_eel_for_link_atom, & + init_vdw_for_link_atom, & + init_bonded_for_link_atom, & + add_link_atom + use mod_topology, only: create_new_bond + use mod_qm_helper, only: qm_helper_update_coord, qm_helper_init_vdw_prm + use mod_mmpol, only: mmpol_init_link_atom + use mod_nonbonded, only: vdw_remove_potential + use mod_memory, only: lp + + implicit none + + type(ommp_system), intent(inout) :: s + type(ommp_qm_helper), intent(inout) :: qm + integer(ommp_integer), intent(in) :: iqm, imm, ila + character(len=*), intent(in) :: prmfile + integer(ommp_integer), optional, intent(in) :: n_eel_remove_in + real(ommp_real), optional, intent(in) :: la_dist_in + + integer(ommp_integer) :: la_idx, n_eel_remove, i + real(ommp_real) :: la_dist + real(ommp_real), allocatable :: cnew(:,:) + real(ommp_real), dimension(3) :: cla + character(len=OMMP_STR_CHAR_MAX) :: message + + ! Handle optional arguments + n_eel_remove = default_link_atom_n_eel_remove + la_dist = default_link_atom_dist + if(present(n_eel_remove_in)) n_eel_remove = n_eel_remove_in + if(present(la_dist_in)) la_dist = la_dist_in + + ! Sanity checks + if(.not. qm%qm_top%attype_initialized) then + call ommp_fatal("For a correct handling of link atoms you should & + &initialize atom types for QM atoms before.") + end if + + ! If it is still not initialized, initialize link atom structure + if(.not. s%use_linkatoms) then + call ommp_message("Initializing link atom module", OMMP_VERBOSE_DEBUG, 'linkatom') + call mmpol_init_link_atom(s) + call init_link_atom(s%la, qm%qm_top, s%top) + ! TODO otherwise check if the qm system is the same... + end if + + ! If VdW for QM part are not initialized, it's the right moment to do so + if(.not. qm%use_nonbonded) then + call ommp_message("Initializing VdW in QM Helper", OMMP_VERBOSE_DEBUG, 'linkatom') + call qm_helper_init_vdw_prm(qm, prmfile) + end if + + ! Sanity check + if(iqm == ila) then + call ommp_fatal("QM atom and link atom should have different indices") + end if + + if(iqm > s%la%qmtop%mm_atoms .or. iqm < 1) then + call ommp_fatal("QM atom index is not in the topology.") + end if + + if(ila > s%la%qmtop%mm_atoms .or. ila < 1) then + call ommp_fatal("LA atom index is not in the topology.") + end if + + if(imm > s%la%mmtop%mm_atoms .or. imm < 1) then + call ommp_fatal("MM atom index is not in the topology.") + end if + ! TODO check that link atom is a monovalent hydrogen + + ! Create the link atom inside OMMP main object + write(message, "('Creating link [',I0,'] (MM) - [',I0,'] (LA) - [',& + &I0,'] (QM) with a fixed distance LA-QM of ', F5.3, ' A.U.')") & + imm, ila, iqm, la_dist + call ommp_message(message, OMMP_VERBOSE_DEBUG, 'linkatom') + + call add_link_atom(s%la, imm, iqm, ila, la_dist) + + ! Compute new QM coordinates (for link atom only actually) and update + allocate(cnew(3,qm%qm_top%mm_atoms)) + cnew = qm%qm_top%cmm + call link_atom_position(s%la, s%la%nla, cla) + write(message, '(A, I0, A, 3F8.4, A, 3F8.4, A)') & + "Link atom [", ila, "] will be moved from [", & + cnew(:,ila), "] to [", cla, "]." + call ommp_message(message, OMMP_VERBOSE_LOW, 'linkatom') + cnew(:,ila) = cla + call qm_helper_update_coord(qm, cnew, logical(.true., lp), s%la%links(_LA_,1:s%la%nla)) + do i=1, s%la%nla + call create_new_bond(qm%qm_top, s%la%links(_QM_,i), s%la%links(_LA_,i)) + end do + deallocate(cnew) + + call ommp_message("Preparing electrostatics for link atom", & + OMMP_VERBOSE_LOW, 'linkatom') + call init_eel_for_link_atom(s%la, imm, ila, s%eel, prmfile) + + ! Remove non-bonded interactions from link atom inside QMHelper object + write(message, '(A, I0, A)') "Removing VdW interactions from link atom (QM) [", ila, "]" + call ommp_message(message, OMMP_VERBOSE_DEBUG, 'linkatom') + call vdw_remove_potential(qm%qm_vdw, ila) + + ! Screen vdw interactions between QM and MM atoms + if(qm%use_nonbonded .and. s%use_nonbonded) then + call init_vdw_for_link_atom(s%la, & + iqm, imm, & + s%vdw%vdw_screening) + end if + + if(s%use_bonded) then + call init_bonded_for_link_atom(s%la, prmfile) + end if + + ! Return link atom index + la_idx = s%la%nla +#undef _MM_ +#undef _QM_ +#undef _LA_ + end function + + subroutine ommp_get_link_atom_coordinates(s, la_idx, crd) + use mod_link_atom, only : link_atom_position + + implicit none + + type(ommp_system), intent(in) :: s + integer(ommp_integer), intent(in) :: la_idx + real(ommp_real), dimension(3), intent(out) :: crd + + if(s%use_linkatoms) then + call link_atom_position(s%la, la_idx, crd) + end if + end subroutine + + subroutine ommp_update_link_atoms_position(qm, s) + use mod_link_atom, only : link_atom_position, link_atom_update_merged_topology + use mod_qm_helper, only: qm_helper_update_coord + use mod_io, only: ommp_message + + implicit none + + type(ommp_system), intent(inout) :: s + type(ommp_qm_helper), intent(inout) :: qm + + integer(ommp_integer) :: i, ila + real(ommp_real), dimension(3) :: crd + real(ommp_real), allocatable :: cnew(:,:) + character(len=OMMP_STR_CHAR_MAX) :: message + + if(s%use_linkatoms) then + call link_atom_update_merged_topology(s%la) + allocate(cnew(3,qm%qm_top%mm_atoms)) + cnew = qm%qm_top%cmm + + do i=1, s%la%nla + ila = s%la%links(3,i) + call link_atom_position(s%la, i, crd) + write(message, '(A, I0, A, 3F8.4, A, 3F8.4, A)') & + "Link atom [", ila, "] will be moved from [", & + cnew(:,ila), "] to [", crd, "]." + call ommp_message(message, OMMP_VERBOSE_LOW, 'linkatom') + cnew(:,ila) = crd + end do + + call qm_helper_update_coord(qm, cnew) + deallocate(cnew) + end if + end subroutine + + subroutine ommp_smartinput(json_filename, system, qmhelp) + use iso_c_binding, only: c_char, c_ptr, c_loc, & + c_null_char, c_f_pointer + !! External interface for smartinput function + character(len=*), intent(in) :: json_filename + type(ommp_system), intent(inout), pointer :: system + type(ommp_qm_helper), intent(inout), pointer :: qmhelp + + interface + subroutine c_smartinput(json_fname, s, q) bind(c) + use iso_c_binding, only: c_ptr + implicit none + + type(c_ptr), value :: json_fname + type(c_ptr) :: s, q ! Pointer to pointer + end subroutine + end interface + + character(kind=c_char), pointer :: c_json_filename(:) + type(c_ptr) :: c_system, c_qmhelp, c_json_fname_p + integer :: i + + c_system = c_loc(system) + c_qmhelp = c_loc(qmhelp) + + allocate(c_json_filename(len(json_filename) + 1)) + + do i=1, len(json_filename) + c_json_filename(i) = json_filename(i:i) + end do + c_json_filename(i) = c_null_char + + c_json_fname_p = c_loc(c_json_filename) + + call c_smartinput(c_json_fname_p, c_system, c_qmhelp) + ! Put everything back in Fortran pointers + call c_f_pointer(c_system, system) + call c_f_pointer(c_qmhelp, qmhelp) + + deallocate(c_json_filename) + end subroutine + + subroutine ommp_smartinput_cpstr(json_filename, path, outs) + use iso_c_binding, only: c_char, c_ptr, c_loc, & + c_null_char, c_f_pointer, c_new_line + !! External interface for smartinput function + character(len=*), intent(in) :: json_filename + character(len=*), intent(in) :: path + character(len=*), intent(inout) :: outs + + interface + subroutine c_smartinput_cpstr(json_fname, path, outs) bind(c) + use iso_c_binding, only: c_ptr + implicit none + + type(c_ptr), value :: json_fname, path + type(c_ptr) :: outs ! Pointer to pointer + end subroutine + end interface + + character(kind=c_char), pointer :: c_json_filename(:), c_path(:) + type(c_ptr) :: c_outs, c_json_fname_p, c_path_p + integer :: i + character(kind=c_char), pointer :: tmp(:) + + allocate(c_json_filename(len(json_filename) + 1)) + allocate(c_path(len(path) + 1)) + + do i=1, len(json_filename) + c_json_filename(i) = json_filename(i:i) + end do + c_json_filename(i) = c_null_char + + do i=1, len(path) + c_path(i) = path(i:i) + end do + c_path(i) = c_null_char + + c_json_fname_p = c_loc(c_json_filename) + c_path_p = c_loc(c_path) + + call c_smartinput_cpstr(c_json_fname_p, c_path_p, c_outs) + ! Put everything back in Fortran pointers + call c_f_pointer(c_outs, tmp, shape=[OMMP_STR_CHAR_MAX]) + + do i=1, OMMP_STR_CHAR_MAX + if(tmp(i) == c_null_char .or. tmp(i) == c_new_line) exit + outs(i:i) = tmp(i) + end do + deallocate(tmp) + + deallocate(c_json_filename, c_path) + end subroutine + + subroutine ommp_system_from_qm_helper(qmh, prm_file, sys) + !! Takes in input a QM Helper object, with initialized + !! atom types, and using a parameter file, it generates a + !! OMMP System object that corresponds to the QM system. + !! It is used for internal testing pourpose but other + !! creative things are always possible. + + use mod_mmpol, only: mmpol_prepare, mmpol_init, mmpol_init_nonbonded, & + mmpol_init_bonded + use mod_topology, only: check_conn_matrix + use mod_adjacency_mat, only: build_conn_upto_n + use mod_prm, only: check_keyword, assign_pol, assign_mpoles, & + assign_vdw, assign_bond, assign_angle, assign_urey, & + assign_strbnd, assign_opb, assign_pitors, & + assign_torsion, assign_tortors, assign_angtor, & + assign_strtor, assign_imptorsion, get_prm_ff_type + use mod_constants, only: OMMP_STR_CHAR_MAX + use mod_io, only: fatal_error, large_file_read + use mod_utils, only: str_to_lower, str_uncomment + + implicit none + + type(ommp_system), intent(inout), pointer :: sys + type(ommp_qm_helper), intent(in) :: qmh + character(len=*), intent(in) :: prm_file + + integer(ommp_integer) :: i, ist + character(len=OMMP_STR_CHAR_MAX), allocatable :: prm_buf(:) + + if(.not. (qmh%qm_top%attype_initialized .and. & + qmh%qm_top%atz_initialized)) & + call ommp_fatal("In order to convert QM Helper to & + &OMMP System atom types and atomic & + &number should be set.") + + allocate(sys) + ! Load prm file in RAM + call large_file_read(prm_file, prm_buf) + ! Remove comments from prm file + !$omp parallel do + do i=1, size(prm_buf) + prm_buf(i) = str_to_lower(prm_buf(i)) + prm_buf(i) = str_uncomment(prm_buf(i), '!') + end do + + call mmpol_init(sys, get_prm_ff_type(prm_buf), & + qmh%qm_top%mm_atoms, qmh%qm_top%mm_atoms) + + do i=1, sys%top%mm_atoms + sys%eel%polar_mm(i) = i + end do + + ! Copy the topology from QM system! + sys%top%cmm = qmh%qm_top%cmm + + sys%top%use_frozen = qmh%qm_top%use_frozen + sys%top%frozen = qmh%qm_top%frozen + + sys%top%atz_initialized = qmh%qm_top%atz_initialized + sys%top%atz = qmh%qm_top%atz + + sys%top%attype_initialized = qmh%qm_top%attype_initialized + sys%top%attype = qmh%qm_top%attype + ! Create connectivities from adjacency matrix + call build_conn_upto_n(qmh%qm_top%conn(1), 4, sys%top%conn, .false.) + ! Now assign parameters + + if( .not. check_keyword(prm_buf)) then + call ommp_fatal("PRM file cannot be completely understood") + end if + + call ommp_message("QMH->SYS Assigning electrostatic parameters", OMMP_VERBOSE_DEBUG) + call assign_pol(sys%eel, prm_buf) + call assign_mpoles(sys%eel, prm_buf) + + call ommp_message("QMH->SYS Assigning non-bonded parameters", OMMP_VERBOSE_DEBUG) + call mmpol_init_nonbonded(sys) + call assign_vdw(sys%vdw, sys%top, prm_buf) + + call ommp_message("QMH->SYS Assigning bonded parameters", OMMP_VERBOSE_DEBUG) + call mmpol_init_bonded(sys) + call check_conn_matrix(sys%top, 4) + call assign_bond(sys%bds, prm_buf) + call assign_angle(sys%bds, prm_buf) + call assign_urey(sys%bds, prm_buf) + call assign_strbnd(sys%bds, prm_buf) + call assign_opb(sys%bds, prm_buf) + call assign_pitors(sys%bds, prm_buf) + call assign_torsion(sys%bds, prm_buf) + call assign_imptorsion(sys%bds, prm_buf) + call assign_tortors(sys%bds, prm_buf) + call assign_angtor(sys%bds, prm_buf) + call assign_strtor(sys%bds, prm_buf) + + deallocate(prm_buf) + + call mmpol_prepare(sys) + call ommp_message('QMH->SYS Completed', OMMP_VERBOSE_DEBUG) + end subroutine ommp_system_from_qm_helper + + subroutine ommp_set_vdw_cutoff(s, cutoff) + use mod_nonbonded, only: vdw_set_cutoff + use mod_constants, only: OMMP_DEFAULT_NL_SUB + + implicit none + + type(ommp_system), intent(inout) :: s + real(ommp_real), intent(in) :: cutoff + + if(s%use_nonbonded) then + call vdw_set_cutoff(s%vdw, cutoff, OMMP_DEFAULT_NL_SUB) + end if + end subroutine + +end module ommp_interface diff --git a/src/mod_interface.f90 b/src/mod_interface.f90 deleted file mode 100644 index 8377fd4..0000000 --- a/src/mod_interface.f90 +++ /dev/null @@ -1,1512 +0,0 @@ -#include "f_cart_components.h" -#include "version.h" -! Wrapper function for open-mmpol library -module ommp_interface - !! The interface of the library, basically all the operation performed - !! by an external code should be done through the routines of this - !! module. - !! The interface is conceived to work naturally with C and Fortran; the C - !! interface is also used to build the interface for Python. - !! In a fortran code, this module can be imported and it should expose - !! directly all the vector and scalar quantities needed. - !! In a C code, routines are provided to get the pointer or the values of - !! vector and scalar quantites respectively. - - ! Renamed import of several global variables that should be available - ! in the interface - use mod_constants, only: OMMP_FF_AMOEBA, OMMP_FF_WANG_AL, OMMP_FF_WANG_DL, & - OMMP_SOLVER_CG, OMMP_SOLVER_DIIS, & - OMMP_SOLVER_INVERSION, OMMP_SOLVER_DEFAULT, & - OMMP_SOLVER_NONE, & - OMMP_MATV_INCORE, OMMP_MATV_DIRECT, & - OMMP_MATV_DEFAULT, OMMP_MATV_NONE, & - OMMP_VERBOSE_DEBUG, OMMP_VERBOSE_HIGH, & - OMMP_VERBOSE_LOW, OMMP_VERBOSE_NONE, & - OMMP_AU2KCALMOL => au2kcalmol, & - OMMP_ANG2AU => angstrom2au, & - OMMP_STR_CHAR_MAX - - ! Internal types - use mod_memory, only: ommp_integer => ip, & - ommp_real => rp, & - ommp_logical => lp - use mod_mmpol, only: ommp_system - use mod_electrostatics, only: ommp_electrostatics_type - use mod_topology, only: ommp_topology_type - use mod_qm_helper, only: ommp_qm_helper - - use mod_mmpol, only: ommp_save_mmp => mmpol_save_as_mmp, & - ommp_print_summary => mmpol_ommp_print_summary, & - ommp_update_coordinates => update_coordinates, & - ommp_print_summary_to_file => mmpol_ommp_print_summary - - use mod_io, only: ommp_set_verbose => set_verbosity, & - ommp_message, & - ommp_set_outputfile => set_iof_mmpol, & - ommp_close_outputfile => close_output, & - ommp_fatal => fatal_error, & - ommp_version - - use mod_qm_helper, only: ommp_qm_helper_set_attype => qm_helper_set_attype, & - ommp_qm_helper_init_vdw_prm => qm_helper_init_vdw_prm, & - ommp_qm_helper_init_vdw => qm_helper_init_vdw, & - ommp_prepare_qm_ele_ene => electrostatic_for_ene, & - ommp_prepare_qm_ele_grd => electrostatic_for_grad - use mod_profiling, only: ommp_time_push => time_push, & - ommp_time_pull => time_pull - implicit none - - character(*), parameter :: ommp_version_string = _OMMP_VERSION - - contains - - subroutine ommp_set_default_solver(s, solver) - use mod_electrostatics, only: set_def_solver - implicit none - - integer(ommp_integer), intent(in), value :: solver - type(ommp_system), pointer :: s - - - call set_def_solver(s%eel, solver) - end subroutine ommp_set_default_solver - - subroutine ommp_set_default_matv(s, matv) - use mod_electrostatics, only: set_def_matv - implicit none - - integer(ommp_integer), intent(in), value :: matv - type(ommp_system), pointer :: s - - - call set_def_matv(s%eel, matv) - end subroutine ommp_set_default_matv - - subroutine ommp_init_mmp(s, filename) - use mod_inputloader, only : mmpol_init_from_mmp - - implicit none - - type(ommp_system), pointer, intent(inout) :: s - character(len=*) :: filename - - call ommp_version(OMMP_VERBOSE_LOW) - allocate(s) - call mmpol_init_from_mmp(trim(filename), s) - end subroutine - - subroutine ommp_init_xyz(s, xyzfile, prmfile) - use mod_inputloader, only : mmpol_init_from_xyz - - implicit none - - type(ommp_system), pointer, intent(inout) :: s - character(len=*) :: xyzfile, prmfile - - call ommp_version(OMMP_VERBOSE_LOW) - allocate(s) - call mmpol_init_from_xyz(s, trim(xyzfile), trim(prmfile)) - end subroutine - - subroutine ommp_set_frozen_atoms(s, n, frozen) - use mod_topology, only: set_frozen - - implicit none - - type(ommp_system), pointer, intent(inout) :: s - !! OpenMMPol system - integer(ommp_integer), intent(in) :: n, frozen(n) - !! Atoms to freeze - - if(minval(frozen) < 1) then - call ommp_fatal("Atom indexes are 1-based, so no index should be less than 1") - end if - if(maxval(frozen) > s%top%mm_atoms) then - call ommp_fatal("Atom indexes should be inside the topology range") - end if - call set_frozen(s%top, frozen) - end subroutine - - subroutine ommp_turn_pol_off(s, n, nopol) - use mod_electrostatics, only: remove_null_pol - use mod_io, only: ommp_message - use mod_constants, only: OMMP_STR_CHAR_MAX, & - OMMP_VERBOSE_LOW - - implicit none - - type(ommp_system), pointer, intent(inout) :: s - !! OpenMMPol system - integer(ommp_integer), intent(in) :: n, nopol(n) - !! Atoms to freeze in MM indexing - - integer(ommp_integer) :: i, j - character(len=OMMP_STR_CHAR_MAX) :: msg - - if(minval(nopol) < 1) then - call ommp_fatal("Atom indexes are 1-based, so no index should be less than 1") - end if - if(maxval(nopol) > s%top%mm_atoms) then - call ommp_fatal("Atom indexes should be inside the topology range") - end if - - do i=1, n - j = s%eel%mm_polar(i) - if(j > 0) then - s%eel%pol(j) = 0.0 - else - write(msg, "('Atom ', I0, ' is not polarizable. Ignoring.')") i - call ommp_message(msg, OMMP_VERBOSE_LOW) - end if - end do - - call remove_null_pol(s%eel) - - end subroutine - - subroutine ommp_terminate(s) - use mod_mmpol, only: mmpol_terminate - - implicit none - - type(ommp_system), pointer, intent(inout) :: s - - call mmpol_terminate(s) - - deallocate(s) - - end subroutine - - subroutine ommp_set_external_field(sys_obj, ext_field, solver, matv, & - add_mm_field) - !! This function get an external field and solve the polarization - !! system in the presence of the provided external field. - use mod_polarization, only: polarization - use mod_electrostatics, only: prepare_polelec - use mod_memory, only: mallocate, mfree - - implicit none - - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real), intent(in) :: ext_field(3,sys_obj%eel%pol_atoms) - integer(ommp_integer), intent(in), value :: solver - integer(ommp_integer), intent(in), value :: matv - logical, intent(in), value, optional :: add_mm_field - - type(ommp_electrostatics_type), pointer :: eel - real(ommp_real), allocatable :: ef(:,:,:) - integer :: i - logical :: do_mm_f - - eel => sys_obj%eel - - if(present(add_mm_field)) then - do_mm_f = add_mm_field - else - do_mm_f = .true. - end if - - eel%ipd_done = .false. - - if(do_mm_f) then - call mallocate('ommp_get_polelec_energy [ef]', & - 3, eel%pol_atoms, eel%n_ipd, ef) - call prepare_polelec(eel) - do i=1, eel%n_ipd - ef(:,:,i) = eel%e_m2d(:,:,i) + ext_field - end do - call polarization(sys_obj, ef, solver) - call mfree('ommp_get_polelec_energy [ef]', ef) - else - call mallocate('ommp_get_polelec_energy [ef]', & - 3, eel%pol_atoms, eel%n_ipd, ef) - - ef(:,:,1) = ext_field - call polarization(sys_obj, ef, solver, matv, [.true., .false.] ) - - call mfree('ommp_get_polelec_energy [ef]', ef) - end if - end subroutine ommp_set_external_field - - subroutine ommp_set_external_field_nomm(sys_obj, ext_field, solver, matv) - !! This is just the same as [[ommp_set_external_field]] but - !! implicitly assuming [[ommp_set_external_field:add_mm_field]] as - !! false, mainly here for interface consistency with C - - implicit none - - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real), intent(in) :: ext_field(3,sys_obj%eel%pol_atoms) - integer(ommp_integer), intent(in), value :: solver - integer(ommp_integer), intent(in), value :: matv - - call ommp_set_external_field(sys_obj, ext_field, solver, matv, .false.) - end subroutine - - subroutine ommp_potential_mmpol2ext(s, n, cext, v) - ! Compute the electric potential of static sites at - ! arbitrary coordinates - use mod_electrostatics, only: potential_D2E, & - potential_M2E - - implicit none - - type(ommp_system), intent(inout), target :: s - integer(ommp_integer), intent(in) :: n - real(ommp_real), intent(in) :: cext(3,n) - real(ommp_real), intent(inout) :: v(n) - - call potential_M2E(s%eel, cext, v) - call potential_D2E(s%eel, cext, v) - end subroutine - - subroutine ommp_potential_pol2ext(s, n, cext, v) - ! Compute the electric potential of static sites at - ! arbitrary coordinates - use mod_electrostatics, only: potential_D2E - - implicit none - - type(ommp_system), intent(inout), target :: s - integer(ommp_integer), intent(in) :: n - real(ommp_real), intent(in) :: cext(3,n) - real(ommp_real), intent(inout) :: v(n) - - call potential_D2E(s%eel, cext, v) - end subroutine - - subroutine ommp_potential_mm2ext(s, n, cext, v) - ! Compute the electric potential of static sites at - ! arbitrary coordinates - use mod_electrostatics, only: potential_M2E - - implicit none - - type(ommp_system), intent(inout), target :: s - integer(ommp_integer), intent(in) :: n - real(ommp_real), intent(in) :: cext(3,n) - real(ommp_real), intent(inout) :: v(n) - - call potential_M2E(s%eel, cext, v) - end subroutine - - subroutine ommp_field_mmpol2ext(s, n, cext, E) - ! Compute the electric potential of static sites at - ! arbitrary coordinates - use mod_electrostatics, only: field_D2E, field_M2E - - implicit none - - integer(ommp_integer), intent(in), value :: n - type(ommp_system), intent(in), target :: s - real(ommp_real), intent(in) :: cext(3,n) - real(ommp_real), intent(out) :: E(3,n) - - call field_M2E(s%eel, cext, E) - call field_D2E(s%eel, cext, E) - end subroutine - - subroutine ommp_field_mm2ext(s, n, cext, E) - ! Compute the electric potential of static sites at - ! arbitrary coordinates - use mod_electrostatics, only: field_M2E - - implicit none - - integer(ommp_integer), intent(in), value :: n - type(ommp_system), intent(in), target :: s - real(ommp_real), intent(in) :: cext(3,n) - real(ommp_real), intent(out) :: E(3,n) - - call field_M2E(s%eel, cext, E) - end subroutine - - subroutine ommp_field_pol2ext(s, n, cext, E) - ! Compute the electric potential of static sites at - ! arbitrary coordinates - use mod_electrostatics, only: field_D2E - - implicit none - - integer(ommp_integer), intent(in), value :: n - type(ommp_system), intent(in), target :: s - real(ommp_real), intent(in) :: cext(3,n) - real(ommp_real), intent(out) :: E(3,n) - - call field_D2E(s%eel, cext, E) - end subroutine - - function ommp_get_polelec_energy(sys_obj) result(ene) - !! Solve the polarization equation for a certain external field - !! and compute the interaction energy of the induced dipoles with - !! themselves and fixed multipoles. - - use mod_electrostatics, only: energy_MM_pol, prepare_polelec - use mod_polarization, only: polarization - - implicit none - - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real) :: ene - - call ommp_time_push() - if(sys_obj%eel%pol_atoms == 0) then - ene = 0.0 - else - if(.not. sys_obj%eel%ipd_done) then - !! Solve the polarization system without external field - call prepare_polelec(sys_obj%eel) - call polarization(sys_obj, sys_obj%eel%e_m2d) - end if - - ene = 0.0 - call energy_MM_pol(sys_obj%eel, ene) - end if - call ommp_time_pull('Polarizable Electrostatic energy') - end function - - function ommp_get_fixedelec_energy(sys_obj) result(ene) - - use mod_electrostatics, only: energy_MM_MM - - implicit none - - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real) :: ene - - call ommp_time_push() - ene = 0.0 - call energy_MM_MM(sys_obj%eel, ene) - call ommp_time_pull('Fixed Electrostatic energy') - - end function - - function ommp_get_full_ele_energy(sys_obj) result(ene) - - implicit none - - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real) :: ene - - ene = ommp_get_fixedelec_energy(sys_obj) - ene = ene + ommp_get_polelec_energy(sys_obj) - - end function - - function ommp_get_vdw_energy(sys_obj) result(evdw) - - use mod_nonbonded, only: vdw_potential - - implicit none - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real) :: evdw - - call ommp_time_push() - evdw = 0.0 - if(sys_obj%use_nonbonded) call vdw_potential(sys_obj%vdw, evdw) - call ommp_time_pull('Non-bonded energy') - - end function - - function ommp_get_bond_energy(sys_obj) result(eb) - - use mod_bonded, only: bond_potential - use mod_link_atom, only: link_atom_update_merged_topology - - implicit none - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real) :: eb - - call ommp_time_push() - eb = 0.0 - if(sys_obj%use_bonded) then - call bond_potential(sys_obj%bds, eb) - if(sys_obj%use_linkatoms) then - call link_atom_update_merged_topology(sys_obj%la) - call bond_potential(sys_obj%la%bds, eb) - endif - end if - call ommp_time_pull('Bonded energy') - - end function - - function ommp_get_angle_energy(sys_obj) result(ea) - - use mod_bonded, only: angle_potential - use mod_link_atom, only: link_atom_update_merged_topology - - implicit none - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real) :: ea - - call ommp_time_push() - ea = 0.0 - if(sys_obj%use_bonded) then - call angle_potential(sys_obj%bds, ea) - if(sys_obj%use_linkatoms) then - call link_atom_update_merged_topology(sys_obj%la) - call angle_potential(sys_obj%la%bds, ea) - end if - end if - call ommp_time_pull('Angle energy') - - end function - - function ommp_get_strbnd_energy(sys_obj) result(eba) - - use mod_bonded, only: strbnd_potential - - implicit none - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real) :: eba - - call ommp_time_push - eba = 0.0 - if(sys_obj%use_bonded) call strbnd_potential(sys_obj%bds, eba) - call ommp_time_pull('Stretching-bending energy') - - end function - - function ommp_get_urey_energy(sys_obj) result(eub) - - use mod_bonded, only: urey_potential - - implicit none - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real) :: eub - - call ommp_time_push - eub = 0.0 - if(sys_obj%use_bonded) call urey_potential(sys_obj%bds, eub) - call ommp_time_pull('Urey-Bradley energy') - - end function - - function ommp_get_opb_energy(sys_obj) result(eopb) - - use mod_bonded, only: opb_potential - - implicit none - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real) :: eopb - - call ommp_time_push - eopb = 0.0 - if(sys_obj%use_bonded) call opb_potential(sys_obj%bds, eopb) - call ommp_time_pull('Out of plane energy') - - end function - - function ommp_get_imptorsion_energy(sys_obj) result(et) - - use mod_bonded, only: imptorsion_potential - - implicit none - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real) :: et - - call ommp_time_push - et = 0.0 - if(sys_obj%use_bonded) call imptorsion_potential(sys_obj%bds, et) - call ommp_time_pull('Improper torsion energy') - - end function - - function ommp_get_torsion_energy(sys_obj) result(et) - - use mod_bonded, only: torsion_potential - use mod_link_atom, only: link_atom_update_merged_topology - - implicit none - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real) :: et - - call ommp_time_push - et = 0.0 - if(sys_obj%use_bonded) then - call torsion_potential(sys_obj%bds, et) - if(sys_obj%use_linkatoms) then - call link_atom_update_merged_topology(sys_obj%la) - call torsion_potential(sys_obj%la%bds, et) - end if - end if - call ommp_time_pull('Torsion energy') - - end function - - function ommp_get_pitors_energy(sys_obj) result(ept) - - use mod_bonded, only: pitors_potential - - implicit none - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real) :: ept - - call ommp_time_push - ept = 0.0 - if(sys_obj%use_bonded) call pitors_potential(sys_obj%bds, ept) - call ommp_time_pull('Pi-system torsion energy') - - end function - - function ommp_get_strtor_energy(sys_obj) result(est) - - use mod_bonded, only: strtor_potential - - implicit none - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real) :: est - - call ommp_time_push - est = 0.0 - if(sys_obj%use_bonded) call strtor_potential(sys_obj%bds, est) - call ommp_time_pull('Stretching-torsion energy') - - end function - - function ommp_get_angtor_energy(sys_obj) result(eat) - - use mod_bonded, only: angtor_potential - - implicit none - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real) :: eat - - call ommp_time_push - eat = 0.0 - if(sys_obj%use_bonded) call angtor_potential(sys_obj%bds, eat) - call ommp_time_pull('Bending-torsion energy') - - end function - - function ommp_get_tortor_energy(sys_obj) result(ett) - - use mod_bonded, only: tortor_potential - - implicit none - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real) :: ett - - call ommp_time_push - ett = 0.0 - if(sys_obj%use_bonded) call tortor_potential(sys_obj%bds, ett) - call ommp_time_pull('Torsion-torsion energy') - - end function - - function ommp_get_full_bnd_energy(sys_obj) result(ene) - - use mod_link_atom, only: link_atom_update_merged_topology - use mod_bonded, only: bond_potential, angtor_potential, & - strbnd_potential, urey_potential, & - opb_potential, pitors_potential, & - torsion_potential, tortor_potential, & - strtor_potential, angle_potential, & - imptorsion_potential - - implicit none - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real) :: ene - - call ommp_time_push - ene = 0.0 - - if(sys_obj%use_bonded) then - call bond_potential(sys_obj%bds, ene) - call angle_potential(sys_obj%bds, ene) - call strbnd_potential(sys_obj%bds, ene) - call urey_potential(sys_obj%bds, ene) - call opb_potential(sys_obj%bds, ene) - call imptorsion_potential(sys_obj%bds, ene) - call torsion_potential(sys_obj%bds, ene) - call pitors_potential(sys_obj%bds, ene) - call strtor_potential(sys_obj%bds, ene) - call angtor_potential(sys_obj%bds, ene) - call tortor_potential(sys_obj%bds, ene) - - if(sys_obj%use_linkatoms) then - call link_atom_update_merged_topology(sys_obj%la) - call bond_potential(sys_obj%la%bds, ene) - call angle_potential(sys_obj%la%bds, ene) - call torsion_potential(sys_obj%la%bds, ene) - end if - - end if - call ommp_time_pull('Total bond energy') - end function - - function ommp_get_full_energy(sys_obj) result(ene) - - implicit none - type(ommp_system), intent(inout), target :: sys_obj - real(ommp_real) :: ene - - call ommp_time_push - ene = 0.0 - ene = ene + ommp_get_vdw_energy(sys_obj) - ene = ene + ommp_get_full_ele_energy(sys_obj) - ene = ene + ommp_get_full_bnd_energy(sys_obj) - call ommp_time_pull('Total energy') - end function - - ! Functions for advanced operation and gradients - subroutine ommp_fixedelec_geomgrad(s, grd) - use mod_geomgrad, only: fixedelec_geomgrad - - implicit none - - type(ommp_system), intent(inout), target :: s - real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) - - call ommp_time_push - grd = 0.0 - call fixedelec_geomgrad(s, grd) - call ommp_time_pull('Fixed Elctrostatic grad') - end subroutine - - subroutine ommp_polelec_geomgrad(s, grd) - use mod_geomgrad, only: polelec_geomgrad - - implicit none - - type(ommp_system), intent(inout), target :: s - real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) - - call ommp_time_push - grd = 0.0 - if(s%eel%pol_atoms > 0) call polelec_geomgrad(s, grd) - call ommp_time_pull('Polarizable Elctrostatic grad') - end subroutine - - subroutine ommp_vdw_geomgrad(s, grd) - use mod_nonbonded, only: vdw_geomgrad - - implicit none - - type(ommp_system), intent(inout), target :: s - real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) - - call ommp_time_push - grd = 0.0 - if(s%use_nonbonded) call vdw_geomgrad(s%vdw, grd) - call ommp_time_pull('Non-bonded grad') - end subroutine - - subroutine ommp_rotation_geomgrad(s, E, Egrd, grd ) - implicit none - - type(ommp_system), intent(inout), target :: s - real(ommp_real), intent(in) :: E(:,:), Egrd(:,:) - real(ommp_real), intent(out) :: grd(:,:) - - call ommp_time_push - grd = 0.0 - call rotation_geomgrad(s%eel, E, Egrd, grd) - call ommp_time_pull('Multipole rotation grad') - end subroutine - - subroutine ommp_bond_geomgrad(s, grd) - use mod_bonded, only: bond_geomgrad - use mod_link_atom, only: link_atom_update_merged_topology, & - link_atom_bond_geomgrad - - implicit none - - type(ommp_system), intent(inout), target :: s - real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) - - real(ommp_real) :: fake_qmg(3,1) - - call ommp_time_push - grd = 0.0 - if(s%use_bonded) then - call bond_geomgrad(s%bds, grd) - if(s%use_linkatoms) then - call link_atom_update_merged_topology(s%la) - call link_atom_bond_geomgrad(s%la, & - fake_qmg, grd, & - .false., .true.) - end if - end if - call ommp_time_pull("Bonded grad") - end subroutine - - subroutine ommp_angle_geomgrad(s, grd) - use mod_bonded, only: angle_geomgrad - use mod_link_atom, only: link_atom_update_merged_topology, & - link_atom_angle_geomgrad - - implicit none - - type(ommp_system), intent(inout), target :: s - real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) - - real(ommp_real) :: fake_qmg(3,1) - - call ommp_time_push - grd = 0.0 - if(s%use_bonded) then - call angle_geomgrad(s%bds, grd) - if(s%use_linkatoms) then - call link_atom_update_merged_topology(s%la) - call link_atom_angle_geomgrad(s%la, & - fake_qmg, grd, & - .false., .true.) - end if - end if - call ommp_time_pull("Angle grad") - end subroutine - - subroutine ommp_strbnd_geomgrad(s, grd) - use mod_bonded, only: strbnd_geomgrad - - implicit none - - type(ommp_system), intent(inout), target :: s - real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) - - call ommp_time_push - grd = 0.0 - if(s%use_bonded) call strbnd_geomgrad(s%bds, grd) - call ommp_time_pull("Stretching-bending grad") - end subroutine - - subroutine ommp_urey_geomgrad(s, grd) - use mod_bonded, only: urey_geomgrad - - implicit none - - type(ommp_system), intent(inout), target :: s - real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) - - call ommp_time_push - grd = 0.0 - if(s%use_bonded) call urey_geomgrad(s%bds, grd) - call ommp_time_pull("Urey-Bradley grad") - end subroutine - - subroutine ommp_torsion_geomgrad(s, grd) - use mod_bonded, only: torsion_geomgrad - use mod_link_atom, only: link_atom_update_merged_topology, & - link_atom_torsion_geomgrad - - implicit none - - type(ommp_system), intent(inout), target :: s - real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) - - real(ommp_real) :: fake_qmg(3,1) - - call ommp_time_push - grd = 0.0 - if(s%use_bonded) then - call torsion_geomgrad(s%bds, grd) - if(s%use_linkatoms) then - call link_atom_update_merged_topology(s%la) - call link_atom_torsion_geomgrad(s%la, & - fake_qmg, grd, & - .false., .true.) - end if - end if - call ommp_time_pull("Torsion grad") - end subroutine - - subroutine ommp_imptorsion_geomgrad(s, grd) - use mod_bonded, only: imptorsion_geomgrad - - implicit none - - type(ommp_system), intent(inout), target :: s - real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) - - call ommp_time_push - grd = 0.0 - if(s%use_bonded) call imptorsion_geomgrad(s%bds, grd) - call ommp_time_pull("Improper torsion grad") - end subroutine - - subroutine ommp_angtor_geomgrad(s, grd) - use mod_bonded, only: angtor_geomgrad - - implicit none - - type(ommp_system), intent(inout), target :: s - real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) - - call ommp_time_push - grd = 0.0 - if(s%use_bonded) call angtor_geomgrad(s%bds, grd) - call ommp_time_pull("Angle-torsion grad") - end subroutine - - subroutine ommp_opb_geomgrad(s, grd) - use mod_bonded, only: opb_geomgrad - - implicit none - - type(ommp_system), intent(inout), target :: s - real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) - - call ommp_time_push - grd = 0.0 - if(s%use_bonded) call opb_geomgrad(s%bds, grd) - call ommp_time_pull("Out of plane grad") - end subroutine - - subroutine ommp_strtor_geomgrad(s, grd) - use mod_bonded, only: strtor_geomgrad - - implicit none - - type(ommp_system), intent(inout), target :: s - real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) - - call ommp_time_push - grd = 0.0 - if(s%use_bonded) call strtor_geomgrad(s%bds, grd) - call ommp_time_pull("Stretching-torsion grad") - end subroutine - - subroutine ommp_tortor_geomgrad(s, grd) - use mod_bonded, only: tortor_geomgrad - - implicit none - - type(ommp_system), intent(inout), target :: s - real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) - - call ommp_time_push - grd = 0.0 - if(s%use_bonded) call tortor_geomgrad(s%bds, grd) - call ommp_time_pull('Torsion-torsion grad') - end subroutine - - subroutine ommp_pitors_geomgrad(s, grd) - use mod_bonded, only: pitors_geomgrad - - implicit none - - type(ommp_system), intent(inout), target :: s - real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) - - call ommp_time_push - grd = 0.0 - if(s%use_bonded) call pitors_geomgrad(s%bds, grd) - call ommp_time_pull('Pi-system torsion grad') - end subroutine - - subroutine ommp_full_bnd_geomgrad(s, grd) - use mod_bonded, only: bond_geomgrad, & - angle_geomgrad, & - strbnd_geomgrad, & - urey_geomgrad, & - opb_geomgrad, & - imptorsion_geomgrad, & - torsion_geomgrad, & - pitors_geomgrad, & - strtor_geomgrad, & - angtor_geomgrad, & - tortor_geomgrad - use mod_link_atom, only: link_atom_update_merged_topology, & - link_atom_bond_geomgrad, & - link_atom_angle_geomgrad, & - link_atom_torsion_geomgrad - - implicit none - - type(ommp_system), intent(inout), target :: s - real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) - - real(ommp_real) :: fake_qmg(3,1) - - call ommp_time_push - grd = 0.0 - if(s%use_bonded) then - call bond_geomgrad(s%bds, grd) - call angle_geomgrad(s%bds, grd) - call strbnd_geomgrad(s%bds, grd) - call urey_geomgrad(s%bds, grd) - call opb_geomgrad(s%bds, grd) - call imptorsion_geomgrad(s%bds, grd) - call torsion_geomgrad(s%bds, grd) - call pitors_geomgrad(s%bds, grd) - call strtor_geomgrad(s%bds, grd) - call angtor_geomgrad(s%bds, grd) - call tortor_geomgrad(s%bds, grd) - if(s%use_linkatoms) then - call link_atom_update_merged_topology(s%la) - call link_atom_bond_geomgrad(s%la, & - fake_qmg, grd, & - .false., .true.) - call link_atom_angle_geomgrad(s%la, & - fake_qmg, grd, & - .false., .true.) - call link_atom_torsion_geomgrad(s%la, & - fake_qmg, grd, & - .false., .true.) - end if - end if - call ommp_time_pull("Total bonded grad") - end subroutine - - subroutine ommp_full_geomgrad(s, grd) - use mod_memory, only: mallocate - use mod_nonbonded, only: vdw_geomgrad - use mod_geomgrad, only: polelec_geomgrad, fixedelec_geomgrad - - implicit none - type(ommp_system), intent(inout), target :: s - real(ommp_real), intent(out) :: grd(3,s%top%mm_atoms) - - call ommp_time_push - grd = 0.0 - call ommp_full_bnd_geomgrad(s, grd) - call fixedelec_geomgrad(s, grd) - if(s%eel%pol_atoms > 0) call polelec_geomgrad(s, grd) - if(s%use_nonbonded) call vdw_geomgrad(s%vdw, grd) - call ommp_time_pull("Total grad") - - end subroutine - -#ifdef USE_HDF5 - subroutine ommp_init_hdf5(s, filename, namespace) - use mod_iohdf5, only: mmpol_init_from_hdf5 - - implicit none - - type(ommp_system), pointer :: s - character(len=*) :: filename, namespace - integer(ommp_integer) :: ok - - call ommp_version(OMMP_VERBOSE_LOW) - allocate(s) - call mmpol_init_from_hdf5(filename, namespace, s, ok) - - end subroutine ommp_init_hdf5 - - subroutine ommp_save_as_hdf5(s, filename, namespace) - !! This function is an interface for saving an HDF5 file - !! with all the data contained in mmpol module using - !! [[mod_io:mmpol_save_as_hdf5]] - use mod_iohdf5, only: save_system_as_hdf5 - - implicit none - - character(len=*) :: filename, namespace - type(ommp_system), pointer :: s - integer(kind=4) :: err - - call save_system_as_hdf5(filename, & - s, & - err, & - namespace, & - logical(.false., kind=ommp_logical)) - - end subroutine ommp_save_as_hdf5 - - subroutine ommp_checkpoint(s, filename, namespace) - - use mod_iohdf5, only: save_system_as_hdf5 - - implicit none - - character(len=*) :: filename, namespace - type(ommp_system), pointer :: s - integer(kind=4) :: err - - call save_system_as_hdf5(filename, & - s, & - err, & - namespace, & - logical(.true., kind=ommp_logical)) - - end subroutine ommp_checkpoint -#endif - - ! QM Helper Object housekeeping - subroutine ommp_init_qm_helper(s, n, cqm, qqm, zqm) - - use mod_qm_helper, only: qm_helper_init - - implicit none - - type(ommp_qm_helper), pointer, intent(inout) :: s - integer(ommp_integer) :: n - real(ommp_real), intent(in) :: cqm(:,:), qqm(:) - integer(ommp_integer), intent(in) :: zqm(:) - - allocate(s) - call qm_helper_init(s, n, cqm, qqm, zqm) - end subroutine - - subroutine ommp_qm_helper_set_frozen_atoms(s, n, frozen) - use mod_topology, only: set_frozen - - implicit none - - type(ommp_qm_helper), pointer, intent(inout) :: s - !! OpenMMPol system - integer(ommp_integer), intent(in) :: n, frozen(n) - !! Atoms to freeze - - if(minval(frozen) < 1) then - call ommp_fatal("Atom indexes are 1-based, so no index should be less than 1") - end if - if(maxval(frozen) > s%qm_top%mm_atoms) then - call ommp_fatal("Atom indexes should be inside the topology range") - end if - call set_frozen(s%qm_top, frozen) - end subroutine - - subroutine ommp_terminate_qm_helper(s) - - use mod_qm_helper, only: qm_helper_terminate - - implicit none - - type(ommp_qm_helper), pointer, intent(inout) :: s - - call qm_helper_terminate(s) - deallocate(s) - end subroutine - - subroutine ommp_qm_helper_update_coord(s, cqm) - - use mod_qm_helper, only: qm_helper_update_coord - - implicit none - - type(ommp_qm_helper), intent(inout) :: s - real(ommp_real), intent(in) :: cqm(:,:) - - call qm_helper_update_coord(s, cqm) - end subroutine - - function ommp_qm_helper_vdw_energy(qm, s) result(evdw) - use mod_qm_helper, only: qm_helper_vdw_energy - - implicit none - - type(ommp_system), intent(inout) :: s - type(ommp_qm_helper), intent(in) :: qm - real(ommp_real) :: evdw - - evdw = 0.0 - call qm_helper_vdw_energy(qm, s, evdw) - end function - - subroutine ommp_qm_helper_vdw_geomgrad(qm, s, qmg, mmg) - - use mod_qm_helper, only: qm_helper_vdw_geomgrad - - implicit none - - type(ommp_system), intent(inout) :: s - type(ommp_qm_helper), intent(in) :: qm - real(ommp_real), intent(out) :: qmg(:,:), mmg(:,:) - - mmg = 0.0 - qmg = 0.0 - call qm_helper_vdw_geomgrad(qm, s, qmg, mmg) - end subroutine - - subroutine ommp_qm_helper_link_atom_geomgrad(qm, s, qmg, mmg, old_qmg) - - use mod_qm_helper, only: qm_helper_link_atom_geomgrad - - implicit none - - type(ommp_system), intent(inout) :: s - type(ommp_qm_helper), intent(in) :: qm - real(ommp_real), intent(out) :: qmg(:,:), mmg(:,:) - real(ommp_real), intent(in) :: old_qmg(:,:) - - mmg = 0.0 - qmg = 0.0 - call qm_helper_link_atom_geomgrad(qm, s, qmg, mmg, old_qmg) - end subroutine - - function ommp_create_link_atom(qm, s, imm, iqm, ila, prmfile, & - la_dist_in, n_eel_remove_in) result(la_idx) -#define _MM_ 1 -#define _QM_ 2 -#define _LA_ 3 - use mod_link_atom, only: link_atom_position, init_link_atom, & - default_link_atom_dist, default_link_atom_n_eel_remove, & - init_eel_for_link_atom, & - init_vdw_for_link_atom, & - init_bonded_for_link_atom, & - add_link_atom - use mod_topology, only: create_new_bond - use mod_qm_helper, only: qm_helper_update_coord, qm_helper_init_vdw_prm - use mod_mmpol, only: mmpol_init_link_atom - use mod_nonbonded, only: vdw_remove_potential - use mod_memory, only: lp - - implicit none - - type(ommp_system), intent(inout) :: s - type(ommp_qm_helper), intent(inout) :: qm - integer(ommp_integer), intent(in) :: iqm, imm, ila - character(len=*), intent(in) :: prmfile - integer(ommp_integer), optional, intent(in) :: n_eel_remove_in - real(ommp_real), optional, intent(in) :: la_dist_in - - integer(ommp_integer) :: la_idx, n_eel_remove, i - real(ommp_real) :: la_dist - real(ommp_real), allocatable :: cnew(:,:) - real(ommp_real), dimension(3) :: cla - character(len=OMMP_STR_CHAR_MAX) :: message - - ! Handle optional arguments - n_eel_remove = default_link_atom_n_eel_remove - la_dist = default_link_atom_dist - if(present(n_eel_remove_in)) n_eel_remove = n_eel_remove_in - if(present(la_dist_in)) la_dist = la_dist_in - - ! Sanity checks - if(.not. qm%qm_top%attype_initialized) then - call ommp_fatal("For a correct handling of link atoms you should & - &initialize atom types for QM atoms before.") - end if - - ! If it is still not initialized, initialize link atom structure - if(.not. s%use_linkatoms) then - call ommp_message("Initializing link atom module", OMMP_VERBOSE_DEBUG, 'linkatom') - call mmpol_init_link_atom(s) - call init_link_atom(s%la, qm%qm_top, s%top) - ! TODO otherwise check if the qm system is the same... - end if - - ! If VdW for QM part are not initialized, it's the right moment to do so - if(.not. qm%use_nonbonded) then - call ommp_message("Initializing VdW in QM Helper", OMMP_VERBOSE_DEBUG, 'linkatom') - call qm_helper_init_vdw_prm(qm, prmfile) - end if - - ! Sanity check - if(iqm == ila) then - call ommp_fatal("QM atom and link atom should have different indices") - end if - - if(iqm > s%la%qmtop%mm_atoms .or. iqm < 1) then - call ommp_fatal("QM atom index is not in the topology.") - end if - - if(ila > s%la%qmtop%mm_atoms .or. ila < 1) then - call ommp_fatal("LA atom index is not in the topology.") - end if - - if(imm > s%la%mmtop%mm_atoms .or. imm < 1) then - call ommp_fatal("MM atom index is not in the topology.") - end if - ! TODO check that link atom is a monovalent hydrogen - - ! Create the link atom inside OMMP main object - write(message, "('Creating link [',I0,'] (MM) - [',I0,'] (LA) - [',& - &I0,'] (QM) with a fixed distance LA-QM of ', F5.3, ' A.U.')") & - imm, ila, iqm, la_dist - call ommp_message(message, OMMP_VERBOSE_DEBUG, 'linkatom') - - call add_link_atom(s%la, imm, iqm, ila, la_dist) - - ! Compute new QM coordinates (for link atom only actually) and update - allocate(cnew(3,qm%qm_top%mm_atoms)) - cnew = qm%qm_top%cmm - call link_atom_position(s%la, s%la%nla, cla) - write(message, '(A, I0, A, 3F8.4, A, 3F8.4, A)') & - "Link atom [", ila, "] will be moved from [", & - cnew(:,ila), "] to [", cla, "]." - call ommp_message(message, OMMP_VERBOSE_LOW, 'linkatom') - cnew(:,ila) = cla - call qm_helper_update_coord(qm, cnew, logical(.true., lp), s%la%links(_LA_,1:s%la%nla)) - do i=1, s%la%nla - call create_new_bond(qm%qm_top, s%la%links(_QM_,i), s%la%links(_LA_,i)) - end do - deallocate(cnew) - - call ommp_message("Preparing electrostatics for link atom", & - OMMP_VERBOSE_LOW, 'linkatom') - call init_eel_for_link_atom(s%la, imm, ila, s%eel, prmfile) - - ! Remove non-bonded interactions from link atom inside QMHelper object - write(message, '(A, I0, A)') "Removing VdW interactions from link atom (QM) [", ila, "]" - call ommp_message(message, OMMP_VERBOSE_DEBUG, 'linkatom') - call vdw_remove_potential(qm%qm_vdw, ila) - - ! Screen vdw interactions between QM and MM atoms - if(qm%use_nonbonded .and. s%use_nonbonded) then - call init_vdw_for_link_atom(s%la, & - iqm, imm, & - s%vdw%vdw_screening) - end if - - if(s%use_bonded) then - call init_bonded_for_link_atom(s%la, prmfile) - end if - - ! Return link atom index - la_idx = s%la%nla -#undef _MM_ -#undef _QM_ -#undef _LA_ - end function - - subroutine ommp_get_link_atom_coordinates(s, la_idx, crd) - use mod_link_atom, only : link_atom_position - - implicit none - - type(ommp_system), intent(in) :: s - integer(ommp_integer), intent(in) :: la_idx - real(ommp_real), dimension(3), intent(out) :: crd - - if(s%use_linkatoms) then - call link_atom_position(s%la, la_idx, crd) - end if - end subroutine - - subroutine ommp_update_link_atoms_position(qm, s) - use mod_link_atom, only : link_atom_position, link_atom_update_merged_topology - use mod_qm_helper, only: qm_helper_update_coord - use mod_io, only: ommp_message - - implicit none - - type(ommp_system), intent(inout) :: s - type(ommp_qm_helper), intent(inout) :: qm - - integer(ommp_integer) :: i, ila - real(ommp_real), dimension(3) :: crd - real(ommp_real), allocatable :: cnew(:,:) - character(len=OMMP_STR_CHAR_MAX) :: message - - if(s%use_linkatoms) then - call link_atom_update_merged_topology(s%la) - allocate(cnew(3,qm%qm_top%mm_atoms)) - cnew = qm%qm_top%cmm - - do i=1, s%la%nla - ila = s%la%links(3,i) - call link_atom_position(s%la, i, crd) - write(message, '(A, I0, A, 3F8.4, A, 3F8.4, A)') & - "Link atom [", ila, "] will be moved from [", & - cnew(:,ila), "] to [", crd, "]." - call ommp_message(message, OMMP_VERBOSE_LOW, 'linkatom') - cnew(:,ila) = crd - end do - - call qm_helper_update_coord(qm, cnew) - deallocate(cnew) - end if - end subroutine - - subroutine ommp_smartinput(json_filename, system, qmhelp) - use iso_c_binding, only: c_char, c_ptr, c_loc, & - c_null_char, c_f_pointer - !! External interface for smartinput function - character(len=*), intent(in) :: json_filename - type(ommp_system), intent(inout), pointer :: system - type(ommp_qm_helper), intent(inout), pointer :: qmhelp - - interface - subroutine c_smartinput(json_fname, s, q) bind(c) - use iso_c_binding, only: c_ptr - implicit none - - type(c_ptr), value :: json_fname - type(c_ptr) :: s, q ! Pointer to pointer - end subroutine - end interface - - character(kind=c_char), pointer :: c_json_filename(:) - type(c_ptr) :: c_system, c_qmhelp, c_json_fname_p - integer :: i - - c_system = c_loc(system) - c_qmhelp = c_loc(qmhelp) - - allocate(c_json_filename(len(json_filename) + 1)) - - do i=1, len(json_filename) - c_json_filename(i) = json_filename(i:i) - end do - c_json_filename(i) = c_null_char - - c_json_fname_p = c_loc(c_json_filename) - - call c_smartinput(c_json_fname_p, c_system, c_qmhelp) - ! Put everything back in Fortran pointers - call c_f_pointer(c_system, system) - call c_f_pointer(c_qmhelp, qmhelp) - - deallocate(c_json_filename) - end subroutine - - subroutine ommp_smartinput_cpstr(json_filename, path, outs) - use iso_c_binding, only: c_char, c_ptr, c_loc, & - c_null_char, c_f_pointer, c_new_line - !! External interface for smartinput function - character(len=*), intent(in) :: json_filename - character(len=*), intent(in) :: path - character(len=*), intent(inout) :: outs - - interface - subroutine c_smartinput_cpstr(json_fname, path, outs) bind(c) - use iso_c_binding, only: c_ptr - implicit none - - type(c_ptr), value :: json_fname, path - type(c_ptr) :: outs ! Pointer to pointer - end subroutine - end interface - - character(kind=c_char), pointer :: c_json_filename(:), c_path(:) - type(c_ptr) :: c_outs, c_json_fname_p, c_path_p - integer :: i - character(kind=c_char), pointer :: tmp(:) - - allocate(c_json_filename(len(json_filename) + 1)) - allocate(c_path(len(path) + 1)) - - do i=1, len(json_filename) - c_json_filename(i) = json_filename(i:i) - end do - c_json_filename(i) = c_null_char - - do i=1, len(path) - c_path(i) = path(i:i) - end do - c_path(i) = c_null_char - - c_json_fname_p = c_loc(c_json_filename) - c_path_p = c_loc(c_path) - - call c_smartinput_cpstr(c_json_fname_p, c_path_p, c_outs) - ! Put everything back in Fortran pointers - call c_f_pointer(c_outs, tmp, shape=[OMMP_STR_CHAR_MAX]) - - do i=1, OMMP_STR_CHAR_MAX - if(tmp(i) == c_null_char .or. tmp(i) == c_new_line) exit - outs(i:i) = tmp(i) - end do - deallocate(tmp) - - deallocate(c_json_filename, c_path) - end subroutine - - subroutine ommp_system_from_qm_helper(qmh, prm_file, sys) - !! Takes in input a QM Helper object, with initialized - !! atom types, and using a parameter file, it generates a - !! OMMP System object that corresponds to the QM system. - !! It is used for internal testing pourpose but other - !! creative things are always possible. - - use mod_mmpol, only: mmpol_prepare, mmpol_init, mmpol_init_nonbonded, & - mmpol_init_bonded - use mod_topology, only: check_conn_matrix - use mod_adjacency_mat, only: build_conn_upto_n - use mod_prm, only: check_keyword, assign_pol, assign_mpoles, & - assign_vdw, assign_bond, assign_angle, assign_urey, & - assign_strbnd, assign_opb, assign_pitors, & - assign_torsion, assign_tortors, assign_angtor, & - assign_strtor, assign_imptorsion, get_prm_ff_type - use mod_constants, only: OMMP_STR_CHAR_MAX - use mod_io, only: fatal_error, large_file_read - use mod_utils, only: str_to_lower, str_uncomment - - implicit none - - type(ommp_system), intent(inout), pointer :: sys - type(ommp_qm_helper), intent(in) :: qmh - character(len=*), intent(in) :: prm_file - - integer(ommp_integer) :: i, ist - character(len=OMMP_STR_CHAR_MAX), allocatable :: prm_buf(:) - - if(.not. (qmh%qm_top%attype_initialized .and. & - qmh%qm_top%atz_initialized)) & - call ommp_fatal("In order to convert QM Helper to & - &OMMP System atom types and atomic & - &number should be set.") - - allocate(sys) - ! Load prm file in RAM - call large_file_read(prm_file, prm_buf) - ! Remove comments from prm file - !$omp parallel do - do i=1, size(prm_buf) - prm_buf(i) = str_to_lower(prm_buf(i)) - prm_buf(i) = str_uncomment(prm_buf(i), '!') - end do - - call mmpol_init(sys, get_prm_ff_type(prm_buf), & - qmh%qm_top%mm_atoms, qmh%qm_top%mm_atoms) - - do i=1, sys%top%mm_atoms - sys%eel%polar_mm(i) = i - end do - - ! Copy the topology from QM system! - sys%top%cmm = qmh%qm_top%cmm - - sys%top%use_frozen = qmh%qm_top%use_frozen - sys%top%frozen = qmh%qm_top%frozen - - sys%top%atz_initialized = qmh%qm_top%atz_initialized - sys%top%atz = qmh%qm_top%atz - - sys%top%attype_initialized = qmh%qm_top%attype_initialized - sys%top%attype = qmh%qm_top%attype - ! Create connectivities from adjacency matrix - call build_conn_upto_n(qmh%qm_top%conn(1), 4, sys%top%conn, .false.) - ! Now assign parameters - - if( .not. check_keyword(prm_buf)) then - call ommp_fatal("PRM file cannot be completely understood") - end if - - call ommp_message("QMH->SYS Assigning electrostatic parameters", OMMP_VERBOSE_DEBUG) - call assign_pol(sys%eel, prm_buf) - call assign_mpoles(sys%eel, prm_buf) - - call ommp_message("QMH->SYS Assigning non-bonded parameters", OMMP_VERBOSE_DEBUG) - call mmpol_init_nonbonded(sys) - call assign_vdw(sys%vdw, sys%top, prm_buf) - - call ommp_message("QMH->SYS Assigning bonded parameters", OMMP_VERBOSE_DEBUG) - call mmpol_init_bonded(sys) - call check_conn_matrix(sys%top, 4) - call assign_bond(sys%bds, prm_buf) - call assign_angle(sys%bds, prm_buf) - call assign_urey(sys%bds, prm_buf) - call assign_strbnd(sys%bds, prm_buf) - call assign_opb(sys%bds, prm_buf) - call assign_pitors(sys%bds, prm_buf) - call assign_torsion(sys%bds, prm_buf) - call assign_imptorsion(sys%bds, prm_buf) - call assign_tortors(sys%bds, prm_buf) - call assign_angtor(sys%bds, prm_buf) - call assign_strtor(sys%bds, prm_buf) - - deallocate(prm_buf) - - call mmpol_prepare(sys) - call ommp_message('QMH->SYS Completed', OMMP_VERBOSE_DEBUG) - end subroutine ommp_system_from_qm_helper - - subroutine ommp_set_vdw_cutoff(s, cutoff) - use mod_nonbonded, only: vdw_set_cutoff - use mod_constants, only: OMMP_DEFAULT_NL_SUB - - implicit none - - type(ommp_system), intent(inout) :: s - real(ommp_real), intent(in) :: cutoff - - if(s%use_nonbonded) then - call vdw_set_cutoff(s%vdw, cutoff, OMMP_DEFAULT_NL_SUB) - end if - end subroutine - -end module ommp_interface diff --git a/src/mod_io.F90 b/src/mod_io.F90 new file mode 100644 index 0000000..9b3833d --- /dev/null +++ b/src/mod_io.F90 @@ -0,0 +1,419 @@ +#include "version.h" + +module mod_io + !! Unified Input/Output handling across the code. + + use mod_constants, only: OMMP_VERBOSE_DEBUG, & + OMMP_VERBOSE_HIGH, & + OMMP_VERBOSE_LOW, & + OMMP_VERBOSE_NONE, & + OMMP_VERBOSE_DEFAULT, & + ip, rp + + implicit none + private + + integer :: iof_mmpol = 6 + integer, parameter :: iof_mmpinp = 100 + + integer(ip), protected :: verbose = OMMP_VERBOSE_DEFAULT + !! verbosity flag, allowed range 0 (no printing at all) -- + !! 3 (debug printing) + + public :: iof_mmpol, iof_mmpinp + public :: set_iof_mmpol, close_output + public :: set_verbosity, ommp_message, fatal_error, ommp_version + public :: print_matrix, print_int_vec + public :: large_file_read + + interface print_matrix + !! Interface for matrix printing function + module procedure d1_print_matrix + module procedure d2_print_matrix + end interface print_matrix + +contains + + subroutine set_iof_mmpol(filename) + !! This subroutine changes the output file for mmpol to a file defined by filename. + use mod_constants, only: OMMP_STR_CHAR_MAX + + implicit none + + character(len=*), intent(in) :: filename + !! File name for the new output stream + character(len=OMMP_STR_CHAR_MAX) :: msg, oldfname + integer(ip) :: ist + + + if(iof_mmpol /= 6) then + !! A file has already been set, close it before proceed. + inquire(unit=iof_mmpol, name=oldfname) + write(msg, '("Switching output from ", a, " to ", a,".")') trim(oldfname), trim(filename) + call ommp_message(msg, OMMP_VERBOSE_LOW) + close(iof_mmpol) + else + write(msg, '("Switching output from stdout to ", a,".")') trim(filename) + call ommp_message(msg, OMMP_VERBOSE_LOW) + end if + + open(unit=110, & + file=filename, & + form='formatted', & + iostat=ist, & + action='write') + + if(ist /= 0) then + call fatal_error('Error while opening output input file') + end if + + iof_mmpol = 110 + end subroutine + + subroutine close_output() + !! This subroutine changes the output file for mmpol to a file defined by filename. + use mod_constants, only: OMMP_STR_CHAR_MAX + + implicit none + + character(len=OMMP_STR_CHAR_MAX) :: msg, oldfname + + + if(iof_mmpol /= 6) then + !! A file has already been set, close it before proceed. + inquire(unit=iof_mmpol, name=oldfname) + write(msg, '("Closing output file ", a,".")') trim(oldfname) + call ommp_message(msg, OMMP_VERBOSE_LOW) + close(iof_mmpol) + end if + + end subroutine + + subroutine set_verbosity(v) + !! Set the verbosity level for the output, this is a library-level + !! function, that changes the behaviour of several I/O functions. It + !! also enforces min/max verbosity levels (currently no output is 0, + !! while debug output is 3). + + integer(ip), intent(in) :: v + !! Requested level of verbosity + + if( v < 0 ) then + verbose = 0_ip + else if( v > 3 ) then + verbose = 3_ip + else + verbose = v + end if + end subroutine set_verbosity + + subroutine ommp_message(s, level, logpre, u) + !! Output a message according to the verbosity level. + !! @note All the output messages should pass for this function, if it + !! is necessary, first use write to format the message on a string and + !! then pass the string to [[ommp_message]] + + implicit none + + character(len=*), intent(in) :: s + !! Message to be printed + character(len=*), intent(in), optional :: logpre + !! String that explains the type of message, if missing a default type + !! is assigned based on requested verbosity level + integer(ip), intent(in) :: level + !! Requested verbosity level + integer(ip), intent(in), optional :: u + !! Output unit for the message, if missing, [[iof_mmpol]] is used. + + integer(ip) :: outunit + character(len=12) :: pre + + if(level > verbose) return + + if(present(u)) then + outunit = u + else + outunit = iof_mmpol + end if + + if(present(logpre)) then + write(pre, '(A12)') "["//trim(logpre)//"]" + else + select case(level) + case(OMMP_VERBOSE_LOW) + write(pre, '(A12)') '[warning]' + case(OMMP_VERBOSE_HIGH) + write(pre, '(A12)') '[info]' + case(OMMP_VERBOSE_DEBUG) + write(pre, '(A12)') '[debug]' + end select + end if + + write(outunit, '(A6, A12, " ", A)') '[OMMP]', pre, trim(s) + end subroutine ommp_message + + subroutine fatal_error(message) + !! Prints a message and exit from the program. This + !! function should be used in all the conditions + !! where the program cannot proceed. + + implicit none + + character (len=*), intent(in) :: message + !! Message to print before the program termination + call ommp_message(message, OMMP_VERBOSE_LOW, 'stop') + call ommp_message("Unrecoverable error in openMMPol & + &library. Exiting.", OMMP_VERBOSE_LOW, & + 'stop') + !! Close output file + call close_output() + + !TODO call mmpol_terminate() + + !stop 1 + call exit(1) + end subroutine fatal_error + + subroutine ommp_version(v) + integer(ip), intent(in) :: v + + call ommp_message("OpenMMPol version: "//_OMMP_VERSION, & + v, "version") + + end subroutine + + subroutine d1_print_matrix(trans, label, matrix, ofunit) + !! Output a 1D-matrix of real in a well formatted way + implicit none + + logical, intent(in) :: trans + !! It the matrix is transposed or not + character(len=*), intent(in) :: label + !! Label to be printed before the matrix + real(rp), dimension(:), intent(in) :: matrix + !! Matrix to be printed + integer(ip), intent(in), optional :: ofunit + !! Unit where the matrix should be printed, if not present [[iof_mmpol]] + !! is used. + + call d2_print_matrix(trans, label, & + reshape(matrix, [size(matrix), 1]), ofunit) + + end subroutine d1_print_matrix + + subroutine d2_print_matrix(trans, label, matrix, ofunit) + !! Output a 2D-matrix of real in a well formatted way + implicit none + + logical, intent(in) :: trans + !! It the matrix is transposed or not + character(len=*), intent(in) :: label + !! Label to be printed before the matrix + real(rp), dimension(:, :), intent(in) :: matrix + !! Matrix to be printed + integer(ip), intent(in), optional :: ofunit + !! Unit where the matrix should be printed, if not present [[iof_mmpol]] + !! is used. + + integer(ip) :: i, j, nbatch, nres, out_unit, nrow, ncol + integer(ip), parameter :: colperrow = 5 + integer(ip), dimension(colperrow) :: icol + character (len=24) :: iform, rform + + if(present(ofunit)) then + out_unit = ofunit + else + out_unit = iof_mmpol + end if + + nrow = size(matrix, 1) + ncol = size(matrix, 2) + + icol = [(i, i=1, colperrow)] + +1000 format(t3,a) +1010 format(t3,5i16) +1020 format(t3,5f16.8) + + write(out_unit,1000) label + + if(trans) then + nbatch = nrow/colperrow + nres = mod(nrow, colperrow) + + write(iform,'("(t3,",i1,"i16)")') nres + write(rform,'("(t3,",i1,"f16.8)")') nres + + do i = 1, nbatch + write(out_unit, 1010) icol(1:colperrow) + + do j = 1, ncol + write(out_unit, 1020) matrix(icol(1):icol(colperrow), j) + end do + + write(out_unit,'("")') + + icol = icol + colperrow + end do + + if (nres > 0) then + write(out_unit,iform) icol(1:nres) + + do j = 1, ncol + write(out_unit,rform) matrix(icol(1):icol(nres),j) + end do + end if + else + nbatch = ncol/colperrow + nres = mod(ncol,colperrow) + write(iform,'("(t3,",i1,"i16)")') nres + write(rform,'("(t3,",i1,"f16.8)")') nres + + do i = 1, nbatch + write(out_unit,1010) icol(1:colperrow) + + do j = 1, nrow + write(out_unit,1020) matrix(j,icol(1):icol(colperrow)) + end do + + write(out_unit,*) + icol = icol + colperrow + end do + + if(nres.ne.0) then + write(out_unit,iform) icol(1:nres) + + do j = 1, nrow + write(out_unit,rform) matrix(j,icol(1):icol(nres)) + end do + end if + end if + end subroutine d2_print_matrix + + subroutine print_int_vec(label, vec, ofunit, ibeg, iend) + !! Print an array of integers in a well formatted way. + + implicit none + + character(len=*), intent(in) :: label + !! Label to print before the array + integer(ip), dimension(:), intent(in) :: vec + !! Integer vector to be printed + integer(ip), intent(in), optional :: ofunit + !! If present specify the unit where the array should be printed, + !! otherwise [[iof_mmpol]] is used. + integer(ip), intent(in), optional :: ibeg + !! Index of the first element to be printed, if 0 or absent the first + !! element is used + integer(ip), intent(in), optional :: iend + !! Index of the last element to be printed, if 0 or absent the last + + integer(ip) :: ib, ie, out_unit + + if(present(ibeg)) then + ib = ibeg + else + ib = 0 + end if + if(present(ibeg)) then + ie = iend + else + ie = 0 + end if + if(ib == 0) ib = 1 + if(ie == 0) ie = size(vec) + + if(present(ofunit)) then + out_unit = ofunit + else + out_unit = iof_mmpol + end if + + write(out_unit, '(t3, a)') label + + if(ib > ie) then + write(out_unit,'(t5)') + return + end if + + write(out_unit,'(t5, 10i8)') vec(ib:ie) + + end subroutine print_int_vec + + subroutine large_file_read(fname, outstr) + !! This function attempt some magic to speed up the read of a + !! large text file in order to transfer it to memory. + use mod_constants, only: OMMP_STR_CHAR_MAX + implicit none + + character(len=*), intent(in) :: fname + !! File to be read + character(len=OMMP_STR_CHAR_MAX), allocatable, intent(out) :: outstr(:) + !! Data structure to be filled with the data from file + + character(len=:), allocatable :: buf + character :: nlc + + integer(ip) :: inu, i, nline + integer(ip), allocatable :: lineidx(:) + integer(8) :: fs + integer(ip) :: err_r, ierr + + err_r = 0 + + inquire(file = fname, size = fs, iostat = ierr) + if(fs < 0 .or. ierr > 0) then + call fatal_error("Error while checking size of file '"//fname//"'. Cannot continue.") + end if + + if(allocated(outstr)) then + deallocate(outstr) + end if + + allocate(character(len=fs) :: buf) + + open(newunit=inu, & + file=fname, & + form='unformatted', & + action='read', & + access='stream', & + status='old') + + read(inu,pos=1,iostat=err_r) buf + close(inu) + + if(err_r /= 0) call fatal_error("Error while reading file '"//fname//"'. Cannot continue.") + nlc = new_line(buf(1:1)) + + !nline = 1 + !do i=1, fs + ! if(buf(i:i) == nlc) then + ! nline = nline + 1 + ! end if + !end do + + ! I think it's just faster to allocate the maximum number of lines + ! that could possibly be there... + allocate(lineidx(fs)) + + nline = 2 + lineidx(1) = 0 + do i=1, fs + if(buf(i:i) == nlc) then + lineidx(nline) = i + nline = nline + 1 + end if + end do + lineidx(nline) = fs + + allocate(outstr(nline-1)) + + do i=1, nline-1 + outstr(i) = buf(lineidx(i)+1:lineidx(i+1)-1) + end do + + deallocate(lineidx) + deallocate(buf) + end subroutine + +end module mod_io diff --git a/src/mod_io.f90 b/src/mod_io.f90 deleted file mode 100644 index 6a48289..0000000 --- a/src/mod_io.f90 +++ /dev/null @@ -1,418 +0,0 @@ -#include "version.h" - -module mod_io - !! Unified Input/Output handling across the code. - - use mod_constants, only: OMMP_VERBOSE_DEBUG, & - OMMP_VERBOSE_HIGH, & - OMMP_VERBOSE_LOW, & - OMMP_VERBOSE_NONE, & - OMMP_VERBOSE_DEFAULT, & - ip, rp - - implicit none - private - - integer :: iof_mmpol = 6 - integer, parameter :: iof_mmpinp = 100 - - integer(ip), protected :: verbose = OMMP_VERBOSE_DEFAULT - !! verbosity flag, allowed range 0 (no printing at all) -- - !! 3 (debug printing) - - public :: iof_mmpol, iof_mmpinp - public :: set_iof_mmpol, close_output - public :: set_verbosity, ommp_message, fatal_error, ommp_version - public :: print_matrix, print_int_vec - public :: large_file_read - - interface print_matrix - !! Interface for matrix printing function - module procedure d1_print_matrix - module procedure d2_print_matrix - end interface print_matrix - - contains - - subroutine set_iof_mmpol(filename) - !! This subroutine changes the output file for mmpol to a file defined by filename. - use mod_constants, only: OMMP_STR_CHAR_MAX - - implicit none - - character(len=*), intent(in) :: filename - !! File name for the new output stream - character(len=OMMP_STR_CHAR_MAX) :: msg, oldfname - integer(ip) :: ist - - - if(iof_mmpol /= 6) then - !! A file has already been set, close it before proceed. - inquire(unit=iof_mmpol, name=oldfname) - write(msg, '("Switching output from ", a, " to ", a,".")') trim(oldfname), trim(filename) - call ommp_message(msg, OMMP_VERBOSE_LOW) - close(iof_mmpol) - else - write(msg, '("Switching output from stdout to ", a,".")') trim(filename) - call ommp_message(msg, OMMP_VERBOSE_LOW) - end if - - open(unit=110, & - file=filename, & - form='formatted', & - iostat=ist, & - action='write') - - if(ist /= 0) then - call fatal_error('Error while opening output input file') - end if - - iof_mmpol = 110 - end subroutine - - subroutine close_output() - !! This subroutine changes the output file for mmpol to a file defined by filename. - use mod_constants, only: OMMP_STR_CHAR_MAX - - implicit none - - character(len=OMMP_STR_CHAR_MAX) :: msg, oldfname - - - if(iof_mmpol /= 6) then - !! A file has already been set, close it before proceed. - inquire(unit=iof_mmpol, name=oldfname) - write(msg, '("Closing output file ", a,".")') trim(oldfname) - call ommp_message(msg, OMMP_VERBOSE_LOW) - close(iof_mmpol) - end if - - end subroutine - - subroutine set_verbosity(v) - !! Set the verbosity level for the output, this is a library-level - !! function, that changes the behaviour of several I/O functions. It - !! also enforces min/max verbosity levels (currently no output is 0, - !! while debug output is 3). - - integer(ip), intent(in) :: v - !! Requested level of verbosity - - if( v < 0 ) then - verbose = 0_ip - else if( v > 3 ) then - verbose = 3_ip - else - verbose = v - end if - end subroutine set_verbosity - - subroutine ommp_message(s, level, logpre, u) - !! Output a message according to the verbosity level. - !! @note All the output messages should pass for this function, if it - !! is necessary, first use write to format the message on a string and - !! then pass the string to [[ommp_message]] - - implicit none - - character(len=*), intent(in) :: s - !! Message to be printed - character(len=*), intent(in), optional :: logpre - !! String that explains the type of message, if missing a default type - !! is assigned based on requested verbosity level - integer(ip), intent(in) :: level - !! Requested verbosity level - integer(ip), intent(in), optional :: u - !! Output unit for the message, if missing, [[iof_mmpol]] is used. - - integer(ip) :: outunit - character(len=12) :: pre - - if(level > verbose) return - - if(present(u)) then - outunit = u - else - outunit = iof_mmpol - end if - - if(present(logpre)) then - write(pre, '(A12)') "["//trim(logpre)//"]" - else - select case(level) - case(OMMP_VERBOSE_LOW) - write(pre, '(A12)') '[warning]' - case(OMMP_VERBOSE_HIGH) - write(pre, '(A12)') '[info]' - case(OMMP_VERBOSE_DEBUG) - write(pre, '(A12)') '[debug]' - end select - end if - - write(outunit, '(A6, A12, " ", A)') '[OMMP]', pre, trim(s) - end subroutine ommp_message - - subroutine fatal_error(message) - !! Prints a message and exit from the program. This - !! function should be used in all the conditions - !! where the program cannot proceed. - - implicit none - - character (len=*), intent(in) :: message - !! Message to print before the program termination - call ommp_message(message, OMMP_VERBOSE_LOW, 'stop') - call ommp_message("Unrecoverable error in openMMPol & - &library. Exiting.", OMMP_VERBOSE_LOW, & - 'stop') - !! Close output file - call close_output() - - !TODO call mmpol_terminate() - - !stop 1 - call exit(1) - end subroutine fatal_error - - subroutine ommp_version(v) - integer(ip), intent(in) :: v - - call ommp_message("OpenMMPol version: "//_OMMP_VERSION, & - v, "version") - end subroutine - - subroutine d1_print_matrix(trans, label, matrix, ofunit) - !! Output a 1D-matrix of real in a well formatted way - implicit none - - logical, intent(in) :: trans - !! It the matrix is transposed or not - character(len=*), intent(in) :: label - !! Label to be printed before the matrix - real(rp), dimension(:), intent(in) :: matrix - !! Matrix to be printed - integer(ip), intent(in), optional :: ofunit - !! Unit where the matrix should be printed, if not present [[iof_mmpol]] - !! is used. - - call d2_print_matrix(trans, label, & - reshape(matrix, [size(matrix), 1]), ofunit) - - end subroutine d1_print_matrix - - subroutine d2_print_matrix(trans, label, matrix, ofunit) - !! Output a 2D-matrix of real in a well formatted way - implicit none - - logical, intent(in) :: trans - !! It the matrix is transposed or not - character(len=*), intent(in) :: label - !! Label to be printed before the matrix - real(rp), dimension(:, :), intent(in) :: matrix - !! Matrix to be printed - integer(ip), intent(in), optional :: ofunit - !! Unit where the matrix should be printed, if not present [[iof_mmpol]] - !! is used. - - integer(ip) :: i, j, nbatch, nres, out_unit, nrow, ncol - integer(ip), parameter :: colperrow = 5 - integer(ip), dimension(colperrow) :: icol - character (len=24) :: iform, rform - - if(present(ofunit)) then - out_unit = ofunit - else - out_unit = iof_mmpol - end if - - nrow = size(matrix, 1) - ncol = size(matrix, 2) - - icol = [(i, i=1, colperrow)] - - 1000 format(t3,a) - 1010 format(t3,5i16) - 1020 format(t3,5f16.8) - - write(out_unit,1000) label - - if(trans) then - nbatch = nrow/colperrow - nres = mod(nrow, colperrow) - - write(iform,'("(t3,",i1,"i16)")') nres - write(rform,'("(t3,",i1,"f16.8)")') nres - - do i = 1, nbatch - write(out_unit, 1010) icol(1:colperrow) - - do j = 1, ncol - write(out_unit, 1020) matrix(icol(1):icol(colperrow), j) - end do - - write(out_unit,'("")') - - icol = icol + colperrow - end do - - if (nres > 0) then - write(out_unit,iform) icol(1:nres) - - do j = 1, ncol - write(out_unit,rform) matrix(icol(1):icol(nres),j) - end do - end if - else - nbatch = ncol/colperrow - nres = mod(ncol,colperrow) - write(iform,'("(t3,",i1,"i16)")') nres - write(rform,'("(t3,",i1,"f16.8)")') nres - - do i = 1, nbatch - write(out_unit,1010) icol(1:colperrow) - - do j = 1, nrow - write(out_unit,1020) matrix(j,icol(1):icol(colperrow)) - end do - - write(out_unit,*) - icol = icol + colperrow - end do - - if(nres.ne.0) then - write(out_unit,iform) icol(1:nres) - - do j = 1, nrow - write(out_unit,rform) matrix(j,icol(1):icol(nres)) - end do - end if - end if - end subroutine d2_print_matrix - - subroutine print_int_vec(label, vec, ofunit, ibeg, iend) - !! Print an array of integers in a well formatted way. - - implicit none - - character(len=*), intent(in) :: label - !! Label to print before the array - integer(ip), dimension(:), intent(in) :: vec - !! Integer vector to be printed - integer(ip), intent(in), optional :: ofunit - !! If present specify the unit where the array should be printed, - !! otherwise [[iof_mmpol]] is used. - integer(ip), intent(in), optional :: ibeg - !! Index of the first element to be printed, if 0 or absent the first - !! element is used - integer(ip), intent(in), optional :: iend - !! Index of the last element to be printed, if 0 or absent the last - - integer(ip) :: ib, ie, out_unit - - if(present(ibeg)) then - ib = ibeg - else - ib = 0 - end if - if(present(ibeg)) then - ie = iend - else - ie = 0 - end if - if(ib == 0) ib = 1 - if(ie == 0) ie = size(vec) - - if(present(ofunit)) then - out_unit = ofunit - else - out_unit = iof_mmpol - end if - - write(out_unit, '(t3, a)') label - - if(ib > ie) then - write(out_unit,'(t5)') - return - end if - - write(out_unit,'(t5, 10i8)') vec(ib:ie) - - end subroutine print_int_vec - - subroutine large_file_read(fname, outstr) - !! This function attempt some magic to speed up the read of a - !! large text file in order to transfer it to memory. - use mod_constants, only: OMMP_STR_CHAR_MAX - implicit none - - character(len=*), intent(in) :: fname - !! File to be read - character(len=OMMP_STR_CHAR_MAX), allocatable, intent(out) :: outstr(:) - !! Data structure to be filled with the data from file - - character(len=:), allocatable :: buf - character :: nlc - - integer(ip) :: inu, i, nline - integer(ip), allocatable :: lineidx(:) - integer(8) :: fs - integer(ip) :: err_r, ierr - - err_r = 0 - - inquire(file = fname, size = fs, iostat = ierr) - if(fs < 0 .or. ierr > 0) then - call fatal_error("Error while checking size of file '"//fname//"'. Cannot continue.") - end if - - if(allocated(outstr)) then - deallocate(outstr) - end if - - allocate(character(len=fs) :: buf) - - open(newunit=inu, & - file=fname, & - form='unformatted', & - action='read', & - access='stream', & - status='old') - - read(inu,pos=1,iostat=err_r) buf - close(inu) - - if(err_r /= 0) call fatal_error("Error while reading file '"//fname//"'. Cannot continue.") - nlc = new_line(buf(1:1)) - - !nline = 1 - !do i=1, fs - ! if(buf(i:i) == nlc) then - ! nline = nline + 1 - ! end if - !end do - - ! I think it's just faster to allocate the maximum number of lines - ! that could possibly be there... - allocate(lineidx(fs)) - - nline = 2 - lineidx(1) = 0 - do i=1, fs - if(buf(i:i) == nlc) then - lineidx(nline) = i - nline = nline + 1 - end if - end do - lineidx(nline) = fs - - allocate(outstr(nline-1)) - - do i=1, nline-1 - outstr(i) = buf(lineidx(i)+1:lineidx(i+1)-1) - end do - - deallocate(lineidx) - deallocate(buf) - end subroutine - -end module mod_io diff --git a/src/mod_iohdf5.F90 b/src/mod_iohdf5.F90 new file mode 100644 index 0000000..5601178 --- /dev/null +++ b/src/mod_iohdf5.F90 @@ -0,0 +1,1893 @@ +#define H5T_RP H5T_NATIVE_DOUBLE +#define H5T_LP H5T_NATIVE_B8 +#ifdef USE_I8 +#define H5T_IP H5T_STD_I64LE +#else +#define H5T_IP H5T_STD_I32LE +#endif + +module mod_iohdf5 +#ifdef USE_HDF5 + use hdf5 +#endif + use mod_memory, only: ip, rp, lp + use mod_mmpol, only: ommp_system + use mod_topology, only: ommp_topology_type + use mod_electrostatics, only: ommp_electrostatics_type + use mod_nonbonded, only: ommp_nonbonded_type, vdw_init + use mod_bonded, only: ommp_bonded_type + use mod_constants, only: OMMP_VERBOSE_LOW, OMMP_VERBOSE_HIGH + use mod_io, only: ommp_message, fatal_error + + implicit none + private + public :: save_system_as_hdf5, mmpol_init_from_hdf5 + +#ifndef USE_HDF5 + ! If HDF5 is not used, use + ! those placeholders + integer, parameter :: hid_t = 8 + ! integer :: hsize_t = 8 +#endif + + interface hdf5_add_scalar + ! Write a scalar as an attribute of the group + module procedure r_hdf5_add_scalar + module procedure i_hdf5_add_scalar + module procedure l_hdf5_add_scalar + end interface hdf5_add_scalar + + interface hdf5_read_scalar + module procedure r_hdf5_read_scalar + module procedure i_hdf5_read_scalar + module procedure l_hdf5_read_scalar + end interface hdf5_read_scalar + + interface hdf5_add_array + ! Write a scalar as an attribute of the group + module procedure r1_hdf5_add_array + module procedure r2_hdf5_add_array + module procedure r3_hdf5_add_array + + module procedure i1_hdf5_add_array + module procedure i2_hdf5_add_array + module procedure i3_hdf5_add_array + + module procedure l1_hdf5_add_array + module procedure l2_hdf5_add_array + end interface hdf5_add_array + + interface hdf5_read_array + module procedure r1_hdf5_read_array + module procedure r2_hdf5_read_array + module procedure r3_hdf5_read_array + + module procedure i1_hdf5_read_array + module procedure i2_hdf5_read_array + module procedure i3_hdf5_read_array + + module procedure l1_hdf5_read_array + module procedure l2_hdf5_read_array + end interface hdf5_read_array + + +contains + + ! Subroutines dedicated to HDF5 I/O + + subroutine r_hdf5_add_scalar(hid, label, scalar) +#ifdef USE_HDF5 + use hdf5 +#endif + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: label + real(rp), intent(in) :: scalar +#ifdef USE_HDF5 + integer(hsize_t), dimension(1), parameter :: dims = [1] + integer(hid_t) :: cur_dst, cur_dsp + integer(kind=4) :: eflag + + + call H5Screate_f(H5S_SCALAR_F, cur_dsp, eflag) + + call H5Acreate_f(hid, & + label, & + H5T_RP, & + cur_dsp, cur_dst, eflag) + call H5Awrite_f(cur_dst, H5T_RP, scalar, dims, eflag) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine i_hdf5_add_scalar(hid, label, scalar) +#ifdef USE_HDF5 + use hdf5 +#endif + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: label + integer(ip), intent(in) :: scalar +#ifdef USE_HDF5 + integer(hsize_t), dimension(1), parameter :: dims = [1] + integer(hid_t) :: cur_dst, cur_dsp + integer(kind=4) :: eflag + + call H5Screate_f(H5S_SCALAR_F, cur_dsp, eflag) + call H5Acreate_f(hid, & + label, & + H5T_IP, & + cur_dsp, cur_dst, eflag) + call H5Awrite_f(cur_dst, H5T_IP, scalar, dims, eflag) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + + end subroutine + + subroutine l_hdf5_add_scalar(hid, label, scalar) +#ifdef USE_HDF5 + use hdf5 +#endif + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: label + logical(lp), intent(in) :: scalar +#ifdef USE_HDF5 + integer(hsize_t), dimension(1), parameter :: dims = [1] + integer(hid_t) :: cur_dst, cur_dsp + integer(kind=4) :: eflag + + call H5Screate_f(H5S_SCALAR_F, cur_dsp, eflag) + call H5Acreate_f(hid, & + label, & + H5T_LP, & + cur_dsp, cur_dst, eflag) + if(scalar) then + call H5Awrite_f(cur_dst, H5T_LP, 1, dims, eflag) + else + call H5Awrite_f(cur_dst, H5T_LP, 0, dims, eflag) + end if +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + + end subroutine + + subroutine r1_hdf5_add_array(hid, label, v) +#ifdef USE_HDF5 + use hdf5 +#endif + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: label + real(rp), intent(in), dimension(:) :: v +#ifdef USE_HDF5 + integer(hsize_t), dimension(1) :: dims + integer(hid_t) :: cur_dst, cur_dsp + integer(kind=4) :: eflag + + dims = shape(v) + call h5screate_simple_f(1, dims, cur_dsp, eflag) + call h5dcreate_f(hid, & + label, & + H5T_RP, & + cur_dsp, cur_dst, eflag) + call h5dwrite_f(cur_dst, H5T_RP, v, dims, eflag) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine r2_hdf5_add_array(hid, label, v) +#ifdef USE_HDF5 + use hdf5 +#endif + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: label + real(rp), intent(in), dimension(:,:) :: v +#ifdef USE_HDF5 + integer(hsize_t), dimension(2) :: dims + integer(hid_t) :: cur_dst, cur_dsp + integer(kind=4) :: eflag + + dims = shape(v) + call h5screate_simple_f(2, dims, cur_dsp, eflag) + call h5dcreate_f(hid, & + label, & + H5T_RP, & + cur_dsp, cur_dst, eflag) + call h5dwrite_f(cur_dst, H5T_RP, v, dims, eflag) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine r3_hdf5_add_array(hid, label, v) +#ifdef USE_HDF5 + use hdf5 +#endif + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: label + real(rp), intent(in), dimension(:,:,:) :: v +#ifdef USE_HDF5 + integer(hsize_t), dimension(3) :: dims + integer(hid_t) :: cur_dst, cur_dsp + integer(kind=4) :: eflag + + dims = shape(v) + call h5screate_simple_f(3, dims, cur_dsp, eflag) + call h5dcreate_f(hid, & + label, & + H5T_RP, & + cur_dsp, cur_dst, eflag) + call h5dwrite_f(cur_dst, H5T_RP, v, dims, eflag) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine i1_hdf5_add_array(hid, label, v) +#ifdef USE_HDF5 + use hdf5 +#endif + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: label + integer(ip), intent(in), dimension(:) :: v +#ifdef USE_HDF5 + integer(hsize_t), dimension(1) :: dims + integer(hid_t) :: cur_dst, cur_dsp + integer(kind=4) :: eflag + + dims = shape(v) + call h5screate_simple_f(1, dims, cur_dsp, eflag) + call h5dcreate_f(hid, & + label, & + H5T_IP, & + cur_dsp, cur_dst, eflag) + call h5dwrite_f(cur_dst, H5T_IP, v, dims, eflag) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine i2_hdf5_add_array(hid, label, v) +#ifdef USE_HDF5 + use hdf5 +#endif + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: label + integer(ip), intent(in), dimension(:,:) :: v +#ifdef USE_HDF5 + integer(hsize_t), dimension(2) :: dims + integer(hid_t) :: cur_dst, cur_dsp + integer(kind=4) :: eflag + + dims = shape(v) + call h5screate_simple_f(2, dims, cur_dsp, eflag) + call h5dcreate_f(hid, & + label, & + H5T_IP, & + cur_dsp, cur_dst, eflag) + call h5dwrite_f(cur_dst, H5T_IP, v, dims, eflag) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine i3_hdf5_add_array(hid, label, v) +#ifdef USE_HDF5 + use hdf5 +#endif + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: label + integer(ip), intent(in), dimension(:,:,:) :: v +#ifdef USE_HDF5 + integer(hsize_t), dimension(3) :: dims + integer(hid_t) :: cur_dst, cur_dsp + integer(kind=4) :: eflag + + dims = shape(v) + call h5screate_simple_f(3, dims, cur_dsp, eflag) + call h5dcreate_f(hid, & + label, & + H5T_IP, & + cur_dsp, cur_dst, eflag) + call h5dwrite_f(cur_dst, H5T_IP, v, dims, eflag) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine l1_hdf5_add_array(hid, label, v) +#ifdef USE_HDF5 + use hdf5 +#endif + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: label + logical(lp), intent(in), dimension(:) :: v +#ifdef USE_HDF5 + integer(hsize_t), dimension(1) :: dims + integer(hid_t) :: cur_dst, cur_dsp + integer(kind=4) :: eflag + + integer(kind=c_int8_t), dimension(:), allocatable :: tmp + integer(hsize_t) :: i + + dims = shape(v) + + allocate(tmp(dims(1))) + do i=1, dims(1) + if(v(i)) then + tmp(i) = 1 + else + tmp(i) = 0 + end if + end do + + call h5screate_simple_f(1, dims, cur_dsp, eflag) + call h5dcreate_f(hid, & + label, & + H5T_LP, & + cur_dsp, cur_dst, eflag) + call h5dwrite_f(cur_dst, H5T_LP, tmp, dims, eflag) + + deallocate(tmp) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine l2_hdf5_add_array(hid, label, v) +#ifdef USE_HDF5 + use hdf5 +#endif + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: label + logical(lp), intent(in), dimension(:,:) :: v +#ifdef USE_HDF5 + integer(hsize_t), dimension(2) :: dims + integer(hid_t) :: cur_dst, cur_dsp + integer(kind=4) :: eflag + + integer(kind=c_int8_t), dimension(:,:), allocatable :: tmp + integer(hsize_t) :: i, j + + dims = shape(v) + + allocate(tmp(dims(1), dims(2))) + do i=1, dims(1) + do j=1, dims(2) + if(v(i,j)) then + tmp(i,j) = 1 + else + tmp(i,j) = 0 + end if + end do + end do + call h5screate_simple_f(2, dims, cur_dsp, eflag) + call h5dcreate_f(hid, & + label, & + H5T_LP, & + cur_dsp, cur_dst, eflag) + call h5dwrite_f(cur_dst, H5T_LP, tmp, dims, eflag) + deallocate(tmp) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + function hdf5_array_len(hid, dataset_name) +#ifdef USE_HDF5 + use hdf5 +#endif + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: dataset_name + integer(ip) :: hdf5_array_len +#ifdef USE_HDF5 + integer(hsize_t), dimension(4) :: dims, maxdims + integer(ip) :: rank + integer(hid_t) :: dataset, dataspace + integer(kind=4) :: eflag + + call h5dopen_f(hid, dataset_name, dataset, eflag) + call h5dget_space_f(dataset, dataspace, eflag) + call h5sget_simple_extent_ndims_f(dataspace, rank, eflag) + call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) + hdf5_array_len = int(dims(rank), kind=ip) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end function + + subroutine r1_hdf5_read_array(hid, dataset_name, v) +#ifdef USE_HDF5 + use hdf5 +#endif + use mod_mmpol, only: fatal_error + use mod_memory, only: mallocate + + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: dataset_name + real(rp), allocatable, dimension(:) :: v +#ifdef USE_HDF5 + integer(hsize_t), dimension(1) :: dims, maxdims + integer(hid_t) :: dataset, dataspace + integer(kind=4) :: eflag + + call h5dopen_f(hid, dataset_name, dataset, eflag) + call h5dget_space_f(dataset, dataspace, eflag) + call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) + if(.not. allocated(v)) then + call mallocate('r1_hdf5_read_array [v]', int(dims(1), ip), v) + else + if(size(v, 1) /= int(dims(1), ip)) then + call fatal_error("Reading HDF5 array on a buffer of wrong size ["//dataset_name//"]") + end if + end if + call h5dread_f(dataset, H5T_RP, v, dims, eflag) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine r2_hdf5_read_array(hid, dataset_name, v) +#ifdef USE_HDF5 + use hdf5 +#endif + use mod_mmpol, only: fatal_error + use mod_memory, only: mallocate + + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: dataset_name + real(rp), allocatable, dimension(:,:) :: v +#ifdef USE_HDF5 + integer(hsize_t), dimension(2) :: dims, maxdims + integer(hid_t) :: dataset, dataspace + integer(kind=4) :: eflag + + call h5dopen_f(hid, dataset_name, dataset, eflag) + call h5dget_space_f(dataset, dataspace, eflag) + call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) + if(.not. allocated(v)) then + call mallocate('r2_hdf5_read_array [v]', int(dims(1), ip), & + int(dims(2), ip), v) + else + if(size(v, 1) /= int(dims(1), ip) .or. & + size(v, 2) /= int(dims(2), ip)) then + call fatal_error("Reading HDF5 array on a buffer of wrong size ["//dataset_name//"]") + end if + end if + call h5dread_f(dataset, H5T_RP, v, dims, eflag) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine r3_hdf5_read_array(hid, dataset_name, v) +#ifdef USE_HDF5 + use hdf5 +#endif + use mod_mmpol, only: fatal_error + use mod_memory, only: mallocate + + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: dataset_name + real(rp), allocatable, dimension(:,:,:) :: v +#ifdef USE_HDF5 + integer(hsize_t), dimension(3) :: dims, maxdims + integer(hid_t) :: dataset, dataspace + integer(kind=4) :: eflag + + call h5dopen_f(hid, dataset_name, dataset, eflag) + call h5dget_space_f(dataset, dataspace, eflag) + call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) + if(.not. allocated(v)) then + call mallocate('r3_hdf5_read_array [v]', int(dims(1), ip), & + int(dims(2), ip), int(dims(3), ip), v) + else + if(size(v, 1) /= int(dims(1), ip) .or. & + size(v, 2) /= int(dims(2), ip) .or. & + size(v, 3) /= int(dims(3), ip)) then + call fatal_error("Reading HDF5 array on a buffer of wrong size ["//dataset_name//"]") + end if + end if + call h5dread_f(dataset, H5T_RP, v, dims, eflag) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine i1_hdf5_read_array(hid, dataset_name, v) +#ifdef USE_HDF5 + use hdf5 +#endif + use mod_mmpol, only: fatal_error + use mod_memory, only: mallocate + + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: dataset_name + integer(ip), allocatable, dimension(:) :: v +#ifdef USE_HDF5 + integer(hsize_t), dimension(1) :: dims, maxdims + integer(hid_t) :: dataset, dataspace + integer(kind=4) :: eflag + + call h5dopen_f(hid, dataset_name, dataset, eflag) + call h5dget_space_f(dataset, dataspace, eflag) + call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) + if(.not. allocated(v)) then + call mallocate('i1_hdf5_read_array [v]', int(dims(1), ip), v) + else + if(size(v, 1) /= int(dims(1), ip)) then + call fatal_error("Reading HDF5 array on a buffer of wrong size ["//dataset_name//"]") + end if + end if + call h5dread_f(dataset, H5T_IP, v, dims, eflag) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine i2_hdf5_read_array(hid, dataset_name, v) +#ifdef USE_HDF5 + use hdf5 +#endif + use mod_mmpol, only: fatal_error + use mod_memory, only: mallocate + + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: dataset_name + integer(ip), allocatable, dimension(:,:) :: v +#ifdef USE_HDF5 + integer(hsize_t), dimension(2) :: dims, maxdims + integer(hid_t) :: dataset, dataspace + integer(kind=4) :: eflag + + call h5dopen_f(hid, dataset_name, dataset, eflag) + call h5dget_space_f(dataset, dataspace, eflag) + call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) + if(.not. allocated(v)) then + call mallocate('i2_hdf5_read_array [v]', int(dims(1), ip), & + int(dims(2), ip), v) + else + if(size(v, 1) /= int(dims(1), ip) .or. & + size(v, 2) /= int(dims(2), ip)) then + call fatal_error("Reading HDF5 array on a buffer of wrong size ["//dataset_name//"]") + end if + end if + call h5dread_f(dataset, H5T_IP, v, dims, eflag) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine i3_hdf5_read_array(hid, dataset_name, v) +#ifdef USE_HDF5 + use hdf5 +#endif + use mod_mmpol, only: fatal_error + use mod_memory, only: mallocate + + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: dataset_name + integer(ip), allocatable, dimension(:,:,:) :: v +#ifdef USE_HDF5 + integer(hsize_t), dimension(3) :: dims, maxdims + integer(hid_t) :: dataset, dataspace + integer(kind=4) :: eflag + + call h5dopen_f(hid, dataset_name, dataset, eflag) + call h5dget_space_f(dataset, dataspace, eflag) + call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) + if(.not. allocated(v)) then + call mallocate('i3_hdf5_read_array [v]', int(dims(1), ip), & + int(dims(2), ip), int(dims(3), ip), v) + else + if(size(v, 1) /= int(dims(1), ip) .or. & + size(v, 2) /= int(dims(2), ip) .or. & + size(v, 3) /= int(dims(3), ip)) then + call fatal_error("Reading HDF5 array on a buffer of wrong size ["//dataset_name//"]") + end if + end if + call h5dread_f(dataset, H5T_IP, v, dims, eflag) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine l1_hdf5_read_array(hid, dataset_name, v) +#ifdef USE_HDF5 + use hdf5 +#endif + use mod_mmpol, only: fatal_error + use mod_memory, only: mallocate + + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: dataset_name + logical(lp), allocatable, dimension(:) :: v +#ifdef USE_HDF5 + integer(hsize_t), dimension(1) :: dims, maxdims + integer(hid_t) :: dataset, dataspace + integer(kind=4) :: eflag + integer(kind=c_int8_t), dimension(:), allocatable :: tmp + integer(hsize_t) :: i + + call h5dopen_f(hid, dataset_name, dataset, eflag) + call h5dget_space_f(dataset, dataspace, eflag) + call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) + if(.not. allocated(v)) then + call mallocate('l1_hdf5_read_array [v]', int(dims(1), ip), v) + else + if(size(v, 1) /= int(dims(1), ip)) then + call fatal_error("Reading HDF5 array on a buffer of wrong size ["//dataset_name//"]") + end if + end if + + allocate(tmp(dims(1))) + call h5dread_f(dataset, H5T_LP, tmp, dims, eflag) + + do i=1, dims(1) + if(tmp(i) == 1) then + v(i) = .true. + else + v(i) = .false. + end if + end do + + deallocate(tmp) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine l2_hdf5_read_array(hid, dataset_name, v) +#ifdef USE_HDF5 + use hdf5 +#endif + use mod_mmpol, only: fatal_error + use mod_memory, only: mallocate + + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: dataset_name + logical(lp), allocatable, dimension(:,:) :: v +#ifdef USE_HDF5 + integer(hsize_t), dimension(2) :: dims, maxdims + integer(hid_t) :: dataset, dataspace + integer(kind=4) :: eflag + + integer(kind=c_int8_t), dimension(:,:), allocatable :: tmp + integer(hsize_t) :: i, j + + call h5dopen_f(hid, dataset_name, dataset, eflag) + call h5dget_space_f(dataset, dataspace, eflag) + call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) + if(.not. allocated(v)) then + call mallocate('i2_hdf5_read_array [v]', int(dims(1), ip), & + int(dims(2), ip), v) + else + if(size(v, 1) /= int(dims(1), ip) .or. & + size(v, 2) /= int(dims(2), ip)) then + call fatal_error("Reading HDF5 array on a buffer of wrong size ["//dataset_name//"]") + end if + end if + + allocate(tmp(dims(1), dims(2))) + call h5dread_f(dataset, H5T_LP, tmp, dims, eflag) + + do i=1, dims(1) + do j=1, dims(2) + if(tmp(i,j) == 1) then + v(i,j) = .true. + else + v(i,j) = .false. + end if + end do + end do + + deallocate(tmp) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine r_hdf5_read_scalar(hid, location, attname, s) +#ifdef USE_HDF5 + use hdf5 +#endif + + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: location, attname + real(rp) :: s +#ifdef USE_HDF5 + integer(hsize_t), dimension(1), parameter :: dims = [1] + integer(kind=4) :: eflag + integer(hid_t) :: att_id, dataset + + call h5gopen_f(hid, location, dataset, eflag) + call H5Aopen_name_f(dataset, attname, att_id, eflag) + call H5Aread_f(att_id, H5T_RP, s, dims, eflag) + call h5gclose_f(dataset, eflag) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine i_hdf5_read_scalar(hid, location, attname, s) +#ifdef USE_HDF5 + use hdf5 +#endif + + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: location, attname + integer(ip) :: s +#ifdef USE_HDF5 + integer(hsize_t), dimension(1), parameter :: dims = [1] + integer(kind=4) :: eflag + integer(hid_t) :: att_id, dataset + + call h5gopen_f(hid, location, dataset, eflag) + call H5Aopen_name_f(dataset, attname, att_id, eflag) + call H5Aread_f(att_id, H5T_IP, s, dims, eflag) + call h5gclose_f(dataset, eflag) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine l_hdf5_read_scalar(hid, location, attname, s) +#ifdef USE_HDF5 + use hdf5 +#endif + + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: location, attname + logical(lp) :: s +#ifdef USE_HDF5 + integer(c_int8_t) :: is + integer(hsize_t), dimension(1), parameter :: dims = [1] + integer(kind=4) :: eflag + integer(hid_t) :: att_id, dataset + + call h5gopen_f(hid, location, dataset, eflag) + call H5Aopen_name_f(dataset, attname, att_id, eflag) + call H5Aread_f(att_id, H5T_LP, is, dims, eflag) + call h5gclose_f(dataset, eflag) + if(is == 0) then + s = .false. + else + s = .true. + end if +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + function hdf5_name_exists(hid, location) result(exists) + implicit none + + integer(hid_t), intent(in) :: hid + character(len=*), intent(in) :: location + logical :: exists + + integer(kind=4) :: eflag +#ifdef USE_HDF5 + call h5lexists_f(hid, location, exists, eflag) +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end function + + subroutine save_system_as_hdf5(filename, s, out_fail, & + namespace, & + mutable_only) + + implicit none + + character(len=*), intent(in) :: filename, namespace + type(ommp_system), intent(in) :: s + integer(ip), intent(out) :: out_fail + logical(lp), intent(in) :: mutable_only +#ifdef USE_HDF5 + integer(hid_t) :: hg + integer(kind=4) :: eflag + integer(hid_t) :: iof_hdf5 = 301 + logical :: append + + ! Initialize interface + call h5open_f(eflag) + if(eflag /= 0) then + call ommp_message("Unable to initialize HDF5 module. Failure in & + &h5open_f subroutine.", OMMP_VERBOSE_LOW) + out_fail = -1_ip + return + end if + + inquire(file=filename, exist=append) + if(append) then + call ommp_message("HDF5 file exists, appending.", OMMP_VERBOSE_HIGH) + call h5fopen_f(filename, H5F_ACC_RDWR_F, iof_hdf5, eflag) + if( eflag /= 0) then + call ommp_message("Unable to open HDF5 file. Failure in & + &h5opene_f subroutine.", OMMP_VERBOSE_LOW) + out_fail = -1_ip + return + end if + else + call h5fcreate_f(filename, H5F_ACC_EXCL_F, iof_hdf5, eflag) + if( eflag /= 0) then + call ommp_message("Unable to create HDF5 file. Failure in & + &h5fcreate_f subroutine.", OMMP_VERBOSE_LOW) + out_fail = -1_ip + return + end if + end if + + ! TODO Handle more complex cases like a/b/c in namespace + call h5gcreate_f(iof_hdf5, namespace, hg, eflag) + if( eflag /= 0) then + call ommp_message("fatal_error while creating group.& + &Failure in h5gcreate_f subroutine.", OMMP_VERBOSE_LOW) + out_fail = -1_ip + return + end if + call hdf5_add_scalar(hg, 'mutable_only', mutable_only) + call h5gclose_f(hg, eflag) + + call save_topology_as_hdf5(iof_hdf5, s%top, eflag, & + namespace//'/topology', mutable_only) + call save_electrostatics_as_hdf5(iof_hdf5, s%eel, eflag, & + namespace//'/electrostatics', & + mutable_only) + + if(s%use_nonbonded) & + call save_nonbonded_as_hdf5(iof_hdf5, s%vdw, eflag, & + namespace//'/nonbonded', & + mutable_only) + if(s%use_bonded) & + call save_bonded_as_hdf5(iof_hdf5, s%bds, eflag, & + namespace//'/bonded', & + mutable_only) + + call h5fclose_f(iof_hdf5, eflag) + if( eflag /= 0) then + call ommp_message("fatal_error while closing HDF5 file. Failure in & + &h5fclose_f subroutine.", OMMP_VERBOSE_LOW) + out_fail = -1_ip + return + end if + + out_fail = 0_ip +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine save_topology_as_hdf5(iof_hdf5, top, out_fail, & + namespace, & + mutable_only) + + implicit none + + integer(hid_t) :: iof_hdf5 + character(len=*), intent(in) :: namespace + type(ommp_topology_type), intent(in) :: top + integer(ip), intent(out) :: out_fail + logical(lp), intent(in) :: mutable_only +#ifdef USE_HDF5 + integer(hid_t) :: hg, hg_cur + integer(kind=4) :: eflag + + call h5gcreate_f(iof_hdf5, namespace, hg, eflag) + if( eflag /= 0) then + call ommp_message("fatal_error while creating group 'system model.'& + &Failure in h5gcreate_f subroutine.", OMMP_VERBOSE_LOW) + out_fail = -1_ip + return + end if + + if(.not. mutable_only) then + call hdf5_add_scalar(hg, "N-atoms", top%mm_atoms) + call h5gcreate_f(hg, "connectivity", hg_cur, eflag) + call hdf5_add_array(hg_cur, "ADJ1-RowIdx", top%conn(1)%ri) + call hdf5_add_array(hg_cur, "ADJ1-ColIdx", top%conn(1)%ci) + call h5gclose_f(hg_cur, eflag) + + if(top%atz_initialized) call hdf5_add_array(hg, "Atoms-Z", top%atz) + if(top%attype_initialized) & + call hdf5_add_array(hg, "Atoms-Type", top%attype) + if(top%atclass_initialized) & + call hdf5_add_array(hg, "Atoms-Class", top%atclass) + end if + + call hdf5_add_array(hg, "Atoms-Coordinates", top%cmm) + call h5gclose_f(hg, eflag) + + out_fail = 0_ip +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine save_electrostatics_as_hdf5(iof_hdf5, eel, out_fail, & + namespace, & + mutable_only) + + use mod_memory, only: mallocate, mfree + implicit none + + integer(hid_t) :: iof_hdf5 + character(len=*), intent(in) :: namespace + type(ommp_electrostatics_type), intent(in) :: eel + integer(ip), intent(out) :: out_fail + logical(lp), intent(in) :: mutable_only +#ifdef USE_HDF5 + integer(hid_t) :: hg, listg + integer(kind=4) :: eflag + real(rp), allocatable :: tmp_q0(:, :) + + call h5gcreate_f(iof_hdf5, namespace, hg, eflag) + if( eflag /= 0) then + call ommp_message("fatal_error while creating group. & + &Failure in h5gcreate_f subroutine.", OMMP_VERBOSE_LOW) + out_fail = -1_ip + return + end if + + if(.not. mutable_only) then + call hdf5_add_scalar(hg, "N-pol-atoms", eel%pol_atoms) + call hdf5_add_scalar(hg, "amoeba", eel%amoeba) + call hdf5_add_scalar(hg, "thole_scale", eel%thole_scale) + + if(eel%amoeba) then + ! Write the unrotated multipoles, that are coordinates independent + ! Since quadrupoles have been multiplied by 1/3 + ! (see [[mod_mmpol::mmpol_prepare]]) we should now save them + ! correctly so we multiply quadrupoles terms by 3 + call mallocate('save_as_hdf5 [tmp_q0]', & + size(eel%q0, 1), size(eel%q0, 2), tmp_q0) + tmp_q0 = eel%q0 + tmp_q0(5:10,:) = tmp_q0(5:10,:) * 3.0 + call hdf5_add_array(hg, "fixed_multipoles_unrotated", tmp_q0) + call mfree('save_as_hdf5 [tmp_q0]', tmp_q0) + + ! Write all the information needed to perform the rotation of the + ! multipoles + call hdf5_add_array(hg, "fixed_mmpoles_rot_Z", eel%iz) + call hdf5_add_array(hg, "fixed_mmpoles_rot_X", eel%ix) + call hdf5_add_array(hg, "fixed_mmpoles_rot_Y", eel%iy) + call hdf5_add_array(hg, "fixed_mmpoles_rot_CONV", eel%mol_frame) + + call hdf5_add_array(hg, "polarization_group_id", eel%mmat_polgrp) + else + call hdf5_add_array(hg, "fixed_multipoles", eel%q) + end if + + call hdf5_add_array(hg, "fixed_fixed_scale_f", eel%mscale) + call hdf5_add_array(hg, "fixed_ipd_scale_f", eel%pscale) + call hdf5_add_array(hg, "ipd_ipd_scale_f", eel%uscale) + if(eel%amoeba) then + call hdf5_add_array(hg, "fixed_direct_ipd_scale_f", eel%dscale) + call hdf5_add_array(hg, "fixed_intragroup_ipd_scale_f", eel%pscale_intra) + end if + + call hdf5_add_array(hg, "polarizable_atoms_idx", eel%polar_mm) + call hdf5_add_array(hg, "polarizabilities", eel%pol) + + if(eel%screening_list_done) then + call h5gcreate_f(iof_hdf5, namespace//"/screening_lists", listg, eflag) + if( eflag /= 0) then + call ommp_message("fatal_error while creating group. & + &Failure in h5gcreate_f subroutine.", OMMP_VERBOSE_LOW) + out_fail = -1_ip + return + end if + + call hdf5_add_scalar(listg, "SS_n", eel%list_S_S%n) + call hdf5_add_array(listg, "SS_ri", eel%list_S_S%ri) + call hdf5_add_array(listg, "SS_ci", eel%list_S_S%ci) + call hdf5_add_array(listg, "SS_scalef", eel%scalef_S_S) + call hdf5_add_array(listg, "SS_todo", eel%todo_S_S) + + call hdf5_add_scalar(listg, "PP_n", eel%list_P_P%n) + call hdf5_add_array(listg, "PP_ri", eel%list_P_P%ri) + call hdf5_add_array(listg, "PP_ci", eel%list_P_P%ci) + call hdf5_add_array(listg, "PP_scalef", eel%scalef_P_P) + call hdf5_add_array(listg, "PP_todo", eel%todo_P_P) + + call hdf5_add_scalar(listg, "SPP_n", eel%list_S_P_P%n) + call hdf5_add_array(listg, "SPP_ri", eel%list_S_P_P%ri) + call hdf5_add_array(listg, "SPP_ci", eel%list_S_P_P%ci) + call hdf5_add_array(listg, "SPP_scalef", eel%scalef_S_P_P) + call hdf5_add_array(listg, "SPP_todo", eel%todo_S_P_P) + + if(eel%amoeba) then + call hdf5_add_scalar(listg, "SPD_n", eel%list_S_P_D%n) + call hdf5_add_array(listg, "SPD_ri", eel%list_S_P_D%ri) + call hdf5_add_array(listg, "SPD_ci", eel%list_S_P_D%ci) + call hdf5_add_array(listg, "SPD_scalef", eel%scalef_S_P_D) + call hdf5_add_array(listg, "SPD_todo", eel%todo_S_P_D) + end if + call h5gclose_f(listg, eflag) + end if + end if + + if(eel%amoeba) then + call hdf5_add_array(hg, "fixed_multipoles_rotated", eel%q) + end if + + if(eel%M2M_done) then + call hdf5_add_array(hg, "potential_M2M", eel%V_M2M) + call hdf5_add_array(hg, "field_M2M", eel%E_M2M) + call hdf5_add_array(hg, "field_grd_M2M", eel%Egrd_M2M) + end if + + if(eel%M2D_done) then + call hdf5_add_array(hg, "field_M2M", eel%E_M2D) + end if + + if(eel%ipd_done) then + call hdf5_add_array(hg, "induced_point_dipoles", eel%ipd) + end if + + call h5gclose_f(hg, eflag) + + out_fail = 0_ip +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine save_nonbonded_as_hdf5(iof_hdf5, vdw, out_fail, & + namespace, & + mutable_only) + + implicit none + + integer(hid_t) :: iof_hdf5 + character(len=*), intent(in) :: namespace + type(ommp_nonbonded_type), intent(in) :: vdw + integer(ip), intent(out) :: out_fail + logical(lp), intent(in) :: mutable_only +#ifdef USE_HDF5 + integer(hid_t) :: hg + integer(kind=4) :: eflag + + call h5gcreate_f(iof_hdf5, namespace, hg, eflag) + if( eflag /= 0) then + call ommp_message("fatal_error while creating group. & + &Failure in h5gcreate_f subroutine.", OMMP_VERBOSE_LOW) + out_fail = -1_ip + return + end if + + if(.not. mutable_only) then + call hdf5_add_scalar(hg, "use_nl", vdw%use_nl) + call hdf5_add_scalar(hg, "radrule", vdw%radrule) + call hdf5_add_scalar(hg, "radtype", vdw%radtype) + call hdf5_add_scalar(hg, "vdwtype", vdw%vdwtype) + call hdf5_add_scalar(hg, "epsrule", vdw%epsrule) + call hdf5_add_scalar(hg, "radf", vdw%radf) + + call hdf5_add_array(hg, "screening", vdw%vdw_screening) + call hdf5_add_array(hg, "radius", vdw%vdw_r) + call hdf5_add_array(hg, "energy", vdw%vdw_e) + call hdf5_add_array(hg, "scale_factor", vdw%vdw_f) + call hdf5_add_scalar(hg, "npair", vdw%npair) + call hdf5_add_array(hg, "vdw_pair_mask_a", vdw%vdw_pair_mask_a) + call hdf5_add_array(hg, "vdw_pair_mask_b", vdw%vdw_pair_mask_b) + call hdf5_add_array(hg, "pair_radius", vdw%vdw_pair_r) + call hdf5_add_array(hg, "pair_energy", vdw%vdw_pair_e) + end if + + call h5gclose_f(hg, eflag) + + out_fail = 0_ip +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine save_bonded_as_hdf5(iof_hdf5, bds, out_fail, & + namespace, & + mutable_only) + + implicit none + + integer(hid_t) :: iof_hdf5 + character(len=*), intent(in) :: namespace + type(ommp_bonded_type), intent(in) :: bds + integer(ip), intent(out) :: out_fail + logical(lp), intent(in) :: mutable_only +#ifdef USE_HDF5 + integer(hid_t) :: hg, hg_cur_bp + integer(kind=4) :: eflag + + call h5gcreate_f(iof_hdf5, namespace, hg, eflag) + if( eflag /= 0) then + call ommp_message("fatal_error while creating group. & + &Failure in h5gcreate_f subroutine.", OMMP_VERBOSE_LOW) + out_fail = -1_ip + return + end if + + if(.not. mutable_only) then + call h5gcreate_f(hg, "stretching", hg_cur_bp, eflag) + call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_bond) + if(bds%use_bond) then + call hdf5_add_scalar(hg_cur_bp, "cubic", bds%bond_cubic) + call hdf5_add_scalar(hg_cur_bp, "quartic", bds%bond_quartic) + call hdf5_add_array(hg_cur_bp, "k", bds%kbond) + call hdf5_add_array(hg_cur_bp, "l0", bds%l0bond) + call hdf5_add_array(hg_cur_bp, "atoms", bds%bondat) + end if + call h5gclose_f(hg_cur_bp, eflag) + + ! Angle bending + call h5gcreate_f(hg, "bending", hg_cur_bp, eflag) + call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_angle) + if(bds%use_angle) then + call hdf5_add_scalar(hg_cur_bp, "cubic", bds%angle_cubic) + call hdf5_add_scalar(hg_cur_bp, "quartic", bds%angle_quartic) + call hdf5_add_scalar(hg_cur_bp, "pentic", bds%angle_pentic) + call hdf5_add_scalar(hg_cur_bp, "sextic", bds%angle_sextic) + call hdf5_add_array(hg_cur_bp, "k", bds%kangle) + call hdf5_add_array(hg_cur_bp, "ang0", bds%eqangle) + call hdf5_add_array(hg_cur_bp, "atoms", bds%angleat) + call hdf5_add_array(hg_cur_bp, "auxatom", bds%angauxat) + call hdf5_add_array(hg_cur_bp, "type", bds%anglety) + end if + call h5gclose_f(hg_cur_bp, eflag) + + ! Dihedral torsion + call h5gcreate_f(hg, "torsion", hg_cur_bp, eflag) + call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_torsion) + if(bds%use_torsion) then + call hdf5_add_array(hg_cur_bp, "amplitudes", bds%torsamp) + call hdf5_add_array(hg_cur_bp, "phase", bds%torsphase) + call hdf5_add_array(hg_cur_bp, "atoms", bds%torsionat) + call hdf5_add_array(hg_cur_bp, "period", bds%torsn) + end if + call h5gclose_f(hg_cur_bp, eflag) + + ! Improper Dihedral torsion + call h5gcreate_f(hg, "improper_torsion", hg_cur_bp, eflag) + call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_imptorsion) + if(bds%use_imptorsion) then + call hdf5_add_array(hg_cur_bp, "amplitudes", bds%imptorsamp) + call hdf5_add_array(hg_cur_bp, "phase", bds%imptorsphase) + call hdf5_add_array(hg_cur_bp, "atoms", bds%imptorsionat) + call hdf5_add_array(hg_cur_bp, "period", bds%imptorsn) + end if + call h5gclose_f(hg_cur_bp, eflag) + + ! Stretching-bending coupling + call h5gcreate_f(hg, "stretching-bending", hg_cur_bp, eflag) + call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_strbnd) + if(bds%use_strbnd) then + call hdf5_add_array(hg_cur_bp, "k1", bds%strbndk1) + call hdf5_add_array(hg_cur_bp, "k2", bds%strbndk2) + call hdf5_add_array(hg_cur_bp, "l1_0", bds%strbndl10) + call hdf5_add_array(hg_cur_bp, "l2_0", bds%strbndl20) + call hdf5_add_array(hg_cur_bp, "ang0", bds%strbndthet0) + call hdf5_add_array(hg_cur_bp, "atoms", bds%strbndat) + end if + call h5gclose_f(hg_cur_bp, eflag) + + ! Stretching-torsion coupling + call h5gcreate_f(hg, "stretching-torsion", hg_cur_bp, eflag) + call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_strtor) + if(bds%use_strtor) then + call hdf5_add_array(hg_cur_bp, "k", bds%strtork) + call hdf5_add_array(hg_cur_bp, "bonds_idx", bds%strtor_b) + call hdf5_add_array(hg_cur_bp, "torsion_idx", bds%strtor_t) + call hdf5_add_array(hg_cur_bp, "atoms", bds%strtorat) + end if + call h5gclose_f(hg_cur_bp, eflag) + + ! Bending-torsion coupling + call h5gcreate_f(hg, "bending-torsion", hg_cur_bp, eflag) + call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_angtor) + if(bds%use_angtor) then + call hdf5_add_array(hg_cur_bp, "k", bds%angtork) + call hdf5_add_array(hg_cur_bp, "angles_idx", bds%angtor_a) + call hdf5_add_array(hg_cur_bp, "torsion_idx", bds%angtor_t) + call hdf5_add_array(hg_cur_bp, "atoms", bds%angtorat) + end if + call h5gclose_f(hg_cur_bp, eflag) + + ! Torsion-torsion coupling + call h5gcreate_f(hg, "torsion-torsion", hg_cur_bp, eflag) + call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_tortor) + if(bds%use_tortor) then + call hdf5_add_array(hg_cur_bp, "atoms", bds%tortorat) + call hdf5_add_array(hg_cur_bp, "map_id", bds%tortorprm) + call hdf5_add_array(hg_cur_bp, "maps_ang1", bds%ttmap_ang1) + call hdf5_add_array(hg_cur_bp, "maps_ang2", bds%ttmap_ang2) + call hdf5_add_array(hg_cur_bp, "maps_pot", bds%ttmap_v) + call hdf5_add_array(hg_cur_bp, "maps_shapes", bds%ttmap_shape) + end if + call h5gclose_f(hg_cur_bp, eflag) + + ! Pi-torsion + call h5gcreate_f(hg, "pi-torsion", hg_cur_bp, eflag) + call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_pitors) + if(bds%use_pitors) then + call hdf5_add_array(hg_cur_bp, "atoms", bds%pitorsat) + call hdf5_add_array(hg_cur_bp, "k", bds%kpitors) + end if + call h5gclose_f(hg_cur_bp, eflag) + + ! Out-of-plane bending + call h5gcreate_f(hg, "out-of-plane-bending", hg_cur_bp, eflag) + call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_opb) + if(bds%use_opb) then + call hdf5_add_scalar(hg_cur_bp, "cubic", bds%opb_cubic) + call hdf5_add_scalar(hg_cur_bp, "quartic", bds%opb_quartic) + call hdf5_add_scalar(hg_cur_bp, "pentic", bds%opb_pentic) + call hdf5_add_scalar(hg_cur_bp, "sextic", bds%opb_sextic) + call hdf5_add_array(hg_cur_bp, "k", bds%kopb) + call hdf5_add_array(hg_cur_bp, "atoms", bds%opbat) + endif + call h5gclose_f(hg_cur_bp, eflag) + + ! Urey-Bradley stretching + call h5gcreate_f(hg, "urey-bradley", hg_cur_bp, eflag) + call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_urey) + if(bds%use_urey) then + call hdf5_add_scalar(hg_cur_bp, "cubic", bds%urey_cubic) + call hdf5_add_scalar(hg_cur_bp, "quartic", bds%urey_quartic) + call hdf5_add_array(hg_cur_bp, "k", bds%kurey) + call hdf5_add_array(hg_cur_bp, "l0", bds%l0urey) + call hdf5_add_array(hg_cur_bp, "atoms", bds%ureyat) + end if + call h5gclose_f(hg_cur_bp, eflag) + end if + + call h5gclose_f(hg, eflag) + + out_fail = 0_ip +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine + + subroutine mmpol_init_from_hdf5(filename, namespace, s, out_fail) +#ifdef USE_HDF5 + use hdf5 +#endif + use mod_adjacency_mat, only: build_conn_upto_n, yale_sparse + use mod_io, only: ommp_message + use mod_memory, only: mfree, mallocate + use mod_mmpol, only: mmpol_init, & + mmpol_prepare, mmpol_init_nonbonded, mmpol_init_bonded + use mod_electrostatics, only: set_screening_parameters + use mod_constants, only: OMMP_VERBOSE_LOW + use mod_bonded, only: bond_init, angle_init, urey_init, strbnd_init, & + opb_init, pitors_init, torsion_init, tortor_init, & + strtor_init, angtor_init, tortor_newmap, imptorsion_init + use mod_nonbonded, only: vdw_set_pair + + implicit none + + character(len=*), intent(in) :: namespace + type(ommp_system), intent(inout), target :: s + character(len=*), intent(in) :: filename + integer(ip), intent(out) :: out_fail +#ifdef USE_HDF5 + integer(hid_t) :: iof_hdf5 = 301 + integer(kind=4) :: eflag + real(rp), dimension(:), allocatable :: l_mscale, l_pscale, l_dscale, & + l_uscale, l_ipscale, l_vdwscale + type(yale_sparse) :: conn_1 + integer(ip) :: mm_atoms, pol_atoms + logical(lp) :: amoeba, mutable_only + + ! For handling torsion maps + integer(ip) :: i, j, ibeg, iend + integer(ip), allocatable, dimension(:,:) :: tmp_shape + real(rp), allocatable, dimension(:) :: tmp_ang1, tmp_ang2, tmp_v + + ! Initialize interface + call h5open_f(eflag) + if(eflag /= 0) then + call ommp_message("Unable to initialize HDF5 module. Failure in & + &h5open_f subroutine.", OMMP_VERBOSE_LOW) + out_fail = -1_ip + return + end if + + call h5fopen_f(filename, H5F_ACC_RDONLY_F, iof_hdf5, eflag) + if( eflag /= 0) then + call ommp_message("Unable to open HDF5 file. Failure in & + &h5fopen_f subroutine.", OMMP_VERBOSE_LOW) + out_fail = -1_ip + return + end if + + call hdf5_read_scalar(iof_hdf5, & + namespace, 'mutable_only', & + mutable_only) + if(mutable_only) then + call ommp_message("Unable to intialize from the selected file/& + &namespace as it is marked mutable only", & + OMMP_VERBOSE_LOW) + out_fail = -1_ip + return + end if + + call hdf5_read_scalar(iof_hdf5, & + namespace//'/topology', 'N-atoms', & + mm_atoms) + call hdf5_read_scalar(iof_hdf5, & + namespace//'/electrostatics', 'N-pol-atoms', & + pol_atoms) + call hdf5_read_scalar(iof_hdf5, & + namespace//'/electrostatics', 'amoeba', & + amoeba) + + if(amoeba) then + call mmpol_init(s, 1_ip, mm_atoms, pol_atoms) + else + call mmpol_init(s, 0_ip, mm_atoms, pol_atoms) + end if + + ! Connectivity + call hdf5_read_array(iof_hdf5, & + namespace//'/topology/connectivity/ADJ1-RowIdx', & + conn_1%ri) + call hdf5_read_array(iof_hdf5, & + namespace//'/topology/connectivity/ADJ1-ColIdx', & + conn_1%ci) + conn_1%n = size(conn_1%ri) - 1 + call build_conn_upto_n(conn_1, 4, s%top%conn, .false.) + + if(hdf5_name_exists(iof_hdf5, namespace//'/topology/Atoms-Type')) then + s%top%attype_initialized = .true. + call hdf5_read_array(iof_hdf5, & + namespace//'/topology/Atoms-Type', & + s%top%attype) + end if + + if(hdf5_name_exists(iof_hdf5, namespace//'/topology/Atoms-Class')) then + s%top%atclass_initialized = .true. + call hdf5_read_array(iof_hdf5, & + namespace//'/topology/Atoms-Class', & + s%top%atclass) + end if + + ! AMOEBA + if(amoeba) then + call hdf5_read_array(iof_hdf5, & + namespace//'/electrostatics/polarization_group_id', & + s%eel%mmat_polgrp) + end if + + ! Bonded Parameters + if(hdf5_name_exists(iof_hdf5, namespace//'/bonded')) then + call mmpol_init_bonded(s) + ! Bond stretching + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/stretching', & + 'enabled', & + s%bds%use_bond) + if(s%bds%use_bond) then + call bond_init(s%bds, hdf5_array_len(iof_hdf5, & + namespace//'/bonded/stretching/atoms')) + + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/stretching', & + 'quartic', & + s%bds%bond_quartic) + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/stretching', & + 'cubic', & + s%bds%bond_cubic) + call hdf5_read_array(iof_hdf5, & + namespace//'/bonded/stretching/k', & + s%bds%kbond) + call hdf5_read_array(iof_hdf5, & + namespace//'/bonded/stretching/l0', & + s%bds%l0bond) + call hdf5_read_array(iof_hdf5, & + namespace//'/bonded/stretching/atoms', & + s%bds%bondat) + end if + + ! Angle bending + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/bending', & + 'enabled', & + s%bds%use_angle) + if(s%bds%use_angle) then + call angle_init(s%bds, hdf5_array_len(iof_hdf5, & + namespace//'/bonded/bending/atoms')) + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/bending', & + "cubic", s%bds%angle_cubic) + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/bending', & + "quartic", s%bds%angle_quartic) + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/bending', & + "pentic", s%bds%angle_pentic) + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/bending', & + "sextic", s%bds%angle_sextic) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/bending/k", & + s%bds%kangle) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/bending/ang0", & + s%bds%eqangle) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/bending/atoms", & + s%bds%angleat) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/bending/auxatom", & + s%bds%angauxat) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/bending/type", & + s%bds%anglety) + end if + + ! Dihedral torsion + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/torsion', & + 'enabled', & + s%bds%use_torsion) + if(s%bds%use_torsion) then + call torsion_init(s%bds, hdf5_array_len(iof_hdf5, & + namespace//'/bonded/torsion/atoms')) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/torsion/amplitudes", & + s%bds%torsamp) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/torsion/phase", & + s%bds%torsphase) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/torsion/atoms", & + s%bds%torsionat) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/torsion/period", & + s%bds%torsn) + end if + + ! Improper Dihedral torsion + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/improper_torsion', & + 'enabled', & + s%bds%use_imptorsion) + if(s%bds%use_imptorsion) then + call imptorsion_init(s%bds, hdf5_array_len(iof_hdf5, & + namespace//'/bonded/improper_torsion/atoms')) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/improper_torsion/amplitudes", & + s%bds%imptorsamp) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/improper_torsion/phase", & + s%bds%imptorsphase) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/improper_torsion/atoms", & + s%bds%imptorsionat) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/improper_torsion/period", & + s%bds%imptorsn) + end if + + ! Stretching-bending coupling + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/stretching-bending', & + 'enabled', & + s%bds%use_strbnd) + if(s%bds%use_strbnd) then + call strbnd_init(s%bds, hdf5_array_len(iof_hdf5, & + namespace//'/bonded/stretching-bending/atoms')) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/stretching-bending/k1", & + s%bds%strbndk1) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/stretching-bending/k2", & + s%bds%strbndk2) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/stretching-bending/l1_0", & + s%bds%strbndl10) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/stretching-bending/l2_0", & + s%bds%strbndl20) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/stretching-bending/ang0", & + s%bds%strbndthet0) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/stretching-bending/atoms", & + s%bds%strbndat) + end if + + ! Stretching-torsion coupling + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/stretching-torsion', & + 'enabled', & + s%bds%use_strtor) + if(s%bds%use_strtor) then + call strtor_init(s%bds, hdf5_array_len(iof_hdf5, & + namespace//'/bonded/stretching-torsion/atoms')) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/stretching-torsion/k", & + s%bds%strtork) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/stretching-torsion/bonds_idx", & + s%bds%strtor_b) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/stretching-torsion/torsion_idx", & + s%bds%strtor_t) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/stretching-torsion/atoms", & + s%bds%strtorat) + end if + + ! Bending-torsion coupling + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/bending-torsion', & + 'enabled', & + s%bds%use_angtor) + if(s%bds%use_angtor) then + call angtor_init(s%bds, hdf5_array_len(iof_hdf5, & + namespace//'/bonded/bending-torsion/atoms')) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/bending-torsion/k", & + s%bds%angtork) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/bending-torsion/angles_idx", & + s%bds%angtor_a) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/bending-torsion/torsion_idx", & + s%bds%angtor_t) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/bending-torsion/atoms", & + s%bds%angtorat) + end if + + ! Torsion-torsion coupling + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/torsion-torsion', & + 'enabled', & + s%bds%use_tortor) + if(s%bds%use_tortor) then + call tortor_init(s%bds, hdf5_array_len(iof_hdf5, & + namespace//'/bonded/torsion-torsion/atoms')) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/torsion-torsion/atoms", & + s%bds%tortorat) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/torsion-torsion/map_id", & + s%bds%tortorprm) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/torsion-torsion/maps_ang1", & + tmp_ang1) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/torsion-torsion/maps_ang2", & + tmp_ang2) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/torsion-torsion/maps_pot", & + tmp_v) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/torsion-torsion/maps_shapes", & + tmp_shape) + + iend = 0 + do i=1, size(tmp_shape, 2) + ibeg = iend + 1 + iend = ibeg + tmp_shape(1,i) * tmp_shape(2,i) - 1 + + call tortor_newmap(s%bds, tmp_shape(1,i), & + tmp_shape(2,i), & + tmp_ang1(ibeg:iend), & + tmp_ang2(ibeg:iend), & + tmp_v(ibeg:iend)) + end do + + call mfree('mmpol_init_from_hdf5 [tmp_ang1]', tmp_ang1) + call mfree('mmpol_init_from_hdf5 [tmp_ang2]', tmp_ang2) + call mfree('mmpol_init_from_hdf5 [tmp_v]', tmp_v) + call mfree('mmpol_init_from_hdf5 [tmp_shape]', tmp_shape) + end if + + ! Pi-torsion + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/pi-torsion', & + 'enabled', & + s%bds%use_pitors) + if(s%bds%use_pitors) then + call pitors_init(s%bds, hdf5_array_len(iof_hdf5, & + namespace//'/bonded/pi-torsion/atoms')) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/pi-torsion/atoms", & + s%bds%pitorsat) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/pi-torsion/k", & + s%bds%kpitors) + end if + + ! Out-of-plane bending + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/out-of-plane-bending', & + 'enabled', & + s%bds%use_opb) + if(s%bds%use_opb) then + call opb_init(s%bds, hdf5_array_len(iof_hdf5, & + namespace//'/bonded/out-of-plane-bending/atoms'), 'allinger') + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/out-of-plane-bending', & + "cubic", s%bds%opb_cubic) + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/out-of-plane-bending', & + "quartic", s%bds%opb_quartic) + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/out-of-plane-bending', & + "pentic", s%bds%opb_pentic) + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/out-of-plane-bending', & + "sextic", s%bds%opb_sextic) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/out-of-plane-bending/k", & + s%bds%kopb) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/out-of-plane-bending/atoms", & + s%bds%opbat) + endif + + ! Urey-Bradley stretching + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/urey-bradley', & + 'enabled', & + s%bds%use_urey) + if(s%bds%use_urey) then + call urey_init(s%bds, hdf5_array_len(iof_hdf5, & + namespace//'/bonded/urey-bradley/atoms')) + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/urey-bradley', & + "cubic", s%bds%urey_cubic) + call hdf5_read_scalar(iof_hdf5, & + namespace//'/bonded/urey-bradley', & + "quartic", s%bds%urey_quartic) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/urey-bradley/k", & + s%bds%kurey) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/urey-bradley/l0", & + s%bds%l0urey) + call hdf5_read_array(iof_hdf5, & + namespace//"/bonded/urey-bradley/atoms", & + s%bds%ureyat) + end if + end if + + if(hdf5_name_exists(iof_hdf5, namespace//"/nonbonded")) then + call mmpol_init_nonbonded(s) + !call vdw_init(s%vdw, s%top, "buffered-14-7", "cubic-mean", "diameter", "r-min", & + ! "hhg") + call hdf5_read_scalar(iof_hdf5, namespace//"/nonbonded", "use_nl", s%vdw%use_nl) + call hdf5_read_scalar(iof_hdf5, namespace//"/nonbonded", "radrule", s%vdw%radrule) + call hdf5_read_scalar(iof_hdf5, namespace//"/nonbonded", "radtype", s%vdw%radtype) + call hdf5_read_scalar(iof_hdf5, namespace//"/nonbonded", "vdwtype", s%vdw%vdwtype) + call hdf5_read_scalar(iof_hdf5, namespace//"/nonbonded", "epsrule", s%vdw%epsrule) + call hdf5_read_scalar(iof_hdf5, namespace//"/nonbonded", "radf", s%vdw%radf) + s%vdw%top => s%top + call hdf5_read_array(iof_hdf5, & + namespace//"/nonbonded/screening", & + l_vdwscale) + + s%vdw%vdw_screening = l_vdwscale + call mfree('mmpol_init_from_hdf5 [l_vdwscale]', l_vdwscale) + + call hdf5_read_array(iof_hdf5, & + namespace//"/nonbonded/radius", & + s%vdw%vdw_r) + call hdf5_read_array(iof_hdf5, & + namespace//"/nonbonded/energy", & + s%vdw%vdw_e) + call hdf5_read_array(iof_hdf5, & + namespace//"/nonbonded/scale_factor", & + s%vdw%vdw_f) + call hdf5_read_scalar(iof_hdf5, & + namespace//"/nonbonded", "npair", & + s%vdw%npair) + call hdf5_read_array(iof_hdf5, & + namespace//"/nonbonded/vdw_pair_mask_a", & + s%vdw%vdw_pair_mask_a) + call hdf5_read_array(iof_hdf5, & + namespace//"/nonbonded/vdw_pair_mask_b", & + s%vdw%vdw_pair_mask_b) + call hdf5_read_array(iof_hdf5, & + namespace//"/nonbonded/pair_radius", & + s%vdw%vdw_pair_r) + call hdf5_read_array(iof_hdf5, & + namespace//"/nonbonded/pair_energy", & + s%vdw%vdw_pair_e) + end if + + if(amoeba) then + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/fixed_multipoles_unrotated", s%eel%q) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/fixed_mmpoles_rot_Z", & + s%eel%iz) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/fixed_mmpoles_rot_X", & + s%eel%ix) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/fixed_mmpoles_rot_Y", & + s%eel%iy) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/fixed_mmpoles_rot_CONV", & + s%eel%mol_frame) + else + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/fixed_multipoles", s%eel%q) + end if + call hdf5_read_scalar(iof_hdf5, namespace//"/electrostatics", "thole_scale", s%eel%thole_scale) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/fixed_fixed_scale_f", l_mscale) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/fixed_ipd_scale_f", l_pscale) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/ipd_ipd_scale_f", l_uscale) + if(amoeba) then + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/fixed_direct_ipd_scale_f", & + l_dscale) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/fixed_intragroup_ipd_scale_f", & + l_ipscale) + call set_screening_parameters(s%eel, l_mscale, l_pscale, l_dscale, l_uscale, & + l_ipscale) + else + call mallocate('l_dscale', 4_ip, l_dscale) + l_dscale = l_pscale + call set_screening_parameters(s%eel, l_mscale, l_pscale, l_dscale, l_uscale) + end if + + if(hdf5_name_exists(iof_hdf5, namespace//"/electrostatics/screening_lists")) then + s%eel%screening_list_done = .true. + allocate(s%eel%list_S_S) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/screening_lists/SS_ri", & + s%eel%list_S_S%ri) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/screening_lists/SS_ci", & + s%eel%list_S_S%ci) + call hdf5_read_scalar(iof_hdf5, & + namespace//"/electrostatics/screening_lists", "SS_n", & + s%eel%list_S_S%n) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/screening_lists/SS_scalef", & + s%eel%scalef_S_S) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/screening_lists/SS_todo", & + s%eel%todo_S_S) + allocate(s%eel%list_P_P) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/screening_lists/PP_ri", & + s%eel%list_P_P%ri) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/screening_lists/PP_ci", & + s%eel%list_P_P%ci) + call hdf5_read_scalar(iof_hdf5, & + namespace//"/electrostatics/screening_lists", "PP_n", & + s%eel%list_P_P%n) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/screening_lists/PP_scalef", & + s%eel%scalef_P_P) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/screening_lists/PP_todo", & + s%eel%todo_P_P) + allocate(s%eel%list_S_P_P) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/screening_lists/SPP_ri", & + s%eel%list_S_P_P%ri) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/screening_lists/SPP_ci", & + s%eel%list_S_P_P%ci) + call hdf5_read_scalar(iof_hdf5, & + namespace//"/electrostatics/screening_lists", "SPP_n", & + s%eel%list_S_P_P%n) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/screening_lists/SPP_scalef", & + s%eel%scalef_S_P_P) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/screening_lists/SPP_todo", & + s%eel%todo_S_P_P) + if(s%eel%amoeba) then + allocate(s%eel%list_S_P_D) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/screening_lists/SPD_ri", & + s%eel%list_S_P_D%ri) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/screening_lists/SPD_ci", & + s%eel%list_S_P_D%ci) + call hdf5_read_scalar(iof_hdf5, & + namespace//"/electrostatics/screening_lists", "SPD_n", & + s%eel%list_S_P_D%n) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/screening_lists/SPD_scalef", & + s%eel%scalef_S_P_D) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/screening_lists/SPD_todo", & + s%eel%todo_S_P_D) + endif + end if + + call mfree('mmpol_init_from_hdf5 [l_mscale]', l_mscale) + call mfree('mmpol_init_from_hdf5 [l_pscale]', l_pscale) + call mfree('mmpol_init_from_hdf5 [l_dscale]', l_dscale) + call mfree('mmpol_init_from_hdf5 [l_uscale]', l_uscale) + call mfree('mmpol_init_from_hdf5 [l_ipscale]', l_ipscale) + + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/polarizable_atoms_idx", s%eel%polar_mm) + call hdf5_read_array(iof_hdf5, & + namespace//"/electrostatics/polarizabilities", s%eel%pol) + + call hdf5_read_array(iof_hdf5, namespace//"/topology/Atoms-Coordinates", s%top%cmm) + + call h5fclose_f(iof_hdf5, eflag) + if( eflag /= 0) then + call ommp_message("fatal_error while closing HDF5 file. Failure in & + &h5fclose_f subroutine.", OMMP_VERBOSE_LOW) + out_fail = -1_ip + return + end if + + call mmpol_prepare(s) + + out_fail = 0_ip +#else + call fatal_error("openmmpol is compiled without HDF5 support") +#endif + end subroutine mmpol_init_from_hdf5 + +end module mod_iohdf5 + diff --git a/src/mod_iohdf5.f90 b/src/mod_iohdf5.f90 deleted file mode 100644 index cf3ffe1..0000000 --- a/src/mod_iohdf5.f90 +++ /dev/null @@ -1,1756 +0,0 @@ -#ifdef USE_HDF5 - -#define H5T_RP H5T_NATIVE_DOUBLE -#define H5T_LP H5T_NATIVE_B8 -#ifdef USE_I8 -#define H5T_IP H5T_STD_I64LE -#else -#define H5T_IP H5T_STD_I32LE -#endif - -module mod_iohdf5 - use hdf5 - use mod_memory, only: ip, rp, lp - use mod_mmpol, only: ommp_system - use mod_topology, only: ommp_topology_type - use mod_electrostatics, only: ommp_electrostatics_type - use mod_nonbonded, only: ommp_nonbonded_type, vdw_init - use mod_bonded, only: ommp_bonded_type - use mod_constants, only: OMMP_VERBOSE_LOW, OMMP_VERBOSE_HIGH - use mod_io, only: ommp_message, fatal_error - - implicit none - private - - public :: save_system_as_hdf5, mmpol_init_from_hdf5 - - interface hdf5_add_scalar - ! Write a scalar as an attribute of the group - module procedure r_hdf5_add_scalar - module procedure i_hdf5_add_scalar - module procedure l_hdf5_add_scalar - end interface hdf5_add_scalar - - interface hdf5_read_scalar - module procedure r_hdf5_read_scalar - module procedure i_hdf5_read_scalar - module procedure l_hdf5_read_scalar - end interface hdf5_read_scalar - - interface hdf5_add_array - ! Write a scalar as an attribute of the group - module procedure r1_hdf5_add_array - module procedure r2_hdf5_add_array - module procedure r3_hdf5_add_array - - module procedure i1_hdf5_add_array - module procedure i2_hdf5_add_array - module procedure i3_hdf5_add_array - - module procedure l1_hdf5_add_array - module procedure l2_hdf5_add_array - end interface hdf5_add_array - - interface hdf5_read_array - module procedure r1_hdf5_read_array - module procedure r2_hdf5_read_array - module procedure r3_hdf5_read_array - - module procedure i1_hdf5_read_array - module procedure i2_hdf5_read_array - module procedure i3_hdf5_read_array - - module procedure l1_hdf5_read_array - module procedure l2_hdf5_read_array - end interface hdf5_read_array - - contains - - ! Subroutines dedicated to HDF5 I/O - - subroutine r_hdf5_add_scalar(hid, label, scalar) - use hdf5 - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: label - real(rp), intent(in) :: scalar - - integer(hsize_t), dimension(1), parameter :: dims = [1] - integer(hid_t) :: cur_dst, cur_dsp - integer(kind=4) :: eflag - - call H5Screate_f(H5S_SCALAR_F, cur_dsp, eflag) - - call H5Acreate_f(hid, & - label, & - H5T_RP, & - cur_dsp, cur_dst, eflag) - call H5Awrite_f(cur_dst, H5T_RP, scalar, dims, eflag) - end subroutine - - subroutine i_hdf5_add_scalar(hid, label, scalar) - use hdf5 - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: label - integer(ip), intent(in) :: scalar - - integer(hsize_t), dimension(1), parameter :: dims = [1] - integer(hid_t) :: cur_dst, cur_dsp - integer(kind=4) :: eflag - - call H5Screate_f(H5S_SCALAR_F, cur_dsp, eflag) - call H5Acreate_f(hid, & - label, & - H5T_IP, & - cur_dsp, cur_dst, eflag) - call H5Awrite_f(cur_dst, H5T_IP, scalar, dims, eflag) - end subroutine - - subroutine l_hdf5_add_scalar(hid, label, scalar) - use hdf5 - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: label - logical(lp), intent(in) :: scalar - - integer(hsize_t), dimension(1), parameter :: dims = [1] - integer(hid_t) :: cur_dst, cur_dsp - integer(kind=4) :: eflag - - call H5Screate_f(H5S_SCALAR_F, cur_dsp, eflag) - call H5Acreate_f(hid, & - label, & - H5T_LP, & - cur_dsp, cur_dst, eflag) - if(scalar) then - call H5Awrite_f(cur_dst, H5T_LP, 1, dims, eflag) - else - call H5Awrite_f(cur_dst, H5T_LP, 0, dims, eflag) - end if - - end subroutine - - subroutine r1_hdf5_add_array(hid, label, v) - use hdf5 - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: label - real(rp), intent(in), dimension(:) :: v - - integer(hsize_t), dimension(1) :: dims - integer(hid_t) :: cur_dst, cur_dsp - integer(kind=4) :: eflag - - dims = shape(v) - call h5screate_simple_f(1, dims, cur_dsp, eflag) - call h5dcreate_f(hid, & - label, & - H5T_RP, & - cur_dsp, cur_dst, eflag) - call h5dwrite_f(cur_dst, H5T_RP, v, dims, eflag) - end subroutine - - subroutine r2_hdf5_add_array(hid, label, v) - use hdf5 - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: label - real(rp), intent(in), dimension(:,:) :: v - - integer(hsize_t), dimension(2) :: dims - integer(hid_t) :: cur_dst, cur_dsp - integer(kind=4) :: eflag - - dims = shape(v) - call h5screate_simple_f(2, dims, cur_dsp, eflag) - call h5dcreate_f(hid, & - label, & - H5T_RP, & - cur_dsp, cur_dst, eflag) - call h5dwrite_f(cur_dst, H5T_RP, v, dims, eflag) - end subroutine - - subroutine r3_hdf5_add_array(hid, label, v) - use hdf5 - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: label - real(rp), intent(in), dimension(:,:,:) :: v - - integer(hsize_t), dimension(3) :: dims - integer(hid_t) :: cur_dst, cur_dsp - integer(kind=4) :: eflag - - dims = shape(v) - call h5screate_simple_f(3, dims, cur_dsp, eflag) - call h5dcreate_f(hid, & - label, & - H5T_RP, & - cur_dsp, cur_dst, eflag) - call h5dwrite_f(cur_dst, H5T_RP, v, dims, eflag) - end subroutine - - subroutine i1_hdf5_add_array(hid, label, v) - use hdf5 - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: label - integer(ip), intent(in), dimension(:) :: v - - integer(hsize_t), dimension(1) :: dims - integer(hid_t) :: cur_dst, cur_dsp - integer(kind=4) :: eflag - - dims = shape(v) - call h5screate_simple_f(1, dims, cur_dsp, eflag) - call h5dcreate_f(hid, & - label, & - H5T_IP, & - cur_dsp, cur_dst, eflag) - call h5dwrite_f(cur_dst, H5T_IP, v, dims, eflag) - end subroutine - - subroutine i2_hdf5_add_array(hid, label, v) - use hdf5 - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: label - integer(ip), intent(in), dimension(:,:) :: v - - integer(hsize_t), dimension(2) :: dims - integer(hid_t) :: cur_dst, cur_dsp - integer(kind=4) :: eflag - - dims = shape(v) - call h5screate_simple_f(2, dims, cur_dsp, eflag) - call h5dcreate_f(hid, & - label, & - H5T_IP, & - cur_dsp, cur_dst, eflag) - call h5dwrite_f(cur_dst, H5T_IP, v, dims, eflag) - end subroutine - - subroutine i3_hdf5_add_array(hid, label, v) - use hdf5 - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: label - integer(ip), intent(in), dimension(:,:,:) :: v - - integer(hsize_t), dimension(3) :: dims - integer(hid_t) :: cur_dst, cur_dsp - integer(kind=4) :: eflag - - dims = shape(v) - call h5screate_simple_f(3, dims, cur_dsp, eflag) - call h5dcreate_f(hid, & - label, & - H5T_IP, & - cur_dsp, cur_dst, eflag) - call h5dwrite_f(cur_dst, H5T_IP, v, dims, eflag) - end subroutine - - subroutine l1_hdf5_add_array(hid, label, v) - use hdf5 - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: label - logical(lp), intent(in), dimension(:) :: v - - integer(hsize_t), dimension(1) :: dims - integer(hid_t) :: cur_dst, cur_dsp - integer(kind=4) :: eflag - - integer(kind=c_int8_t), dimension(:), allocatable :: tmp - integer(hsize_t) :: i - - dims = shape(v) - - allocate(tmp(dims(1))) - do i=1, dims(1) - if(v(i)) then - tmp(i) = 1 - else - tmp(i) = 0 - end if - end do - - call h5screate_simple_f(1, dims, cur_dsp, eflag) - call h5dcreate_f(hid, & - label, & - H5T_LP, & - cur_dsp, cur_dst, eflag) - call h5dwrite_f(cur_dst, H5T_LP, tmp, dims, eflag) - - deallocate(tmp) - end subroutine - - subroutine l2_hdf5_add_array(hid, label, v) - use hdf5 - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: label - logical(lp), intent(in), dimension(:,:) :: v - - integer(hsize_t), dimension(2) :: dims - integer(hid_t) :: cur_dst, cur_dsp - integer(kind=4) :: eflag - - integer(kind=c_int8_t), dimension(:,:), allocatable :: tmp - integer(hsize_t) :: i, j - - dims = shape(v) - - allocate(tmp(dims(1), dims(2))) - do i=1, dims(1) - do j=1, dims(2) - if(v(i,j)) then - tmp(i,j) = 1 - else - tmp(i,j) = 0 - end if - end do - end do - call h5screate_simple_f(2, dims, cur_dsp, eflag) - call h5dcreate_f(hid, & - label, & - H5T_LP, & - cur_dsp, cur_dst, eflag) - call h5dwrite_f(cur_dst, H5T_LP, tmp, dims, eflag) - deallocate(tmp) - end subroutine - - function hdf5_array_len(hid, dataset_name) - use hdf5 - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: dataset_name - integer(ip) :: hdf5_array_len - - integer(hsize_t), dimension(4) :: dims, maxdims - integer(ip) :: rank - integer(hid_t) :: dataset, dataspace - integer(kind=4) :: eflag - - call h5dopen_f(hid, dataset_name, dataset, eflag) - call h5dget_space_f(dataset, dataspace, eflag) - call h5sget_simple_extent_ndims_f(dataspace, rank, eflag) - call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) - hdf5_array_len = int(dims(rank), kind=ip) - end function - - subroutine r1_hdf5_read_array(hid, dataset_name, v) - use hdf5 - use mod_mmpol, only: fatal_error - use mod_memory, only: mallocate - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: dataset_name - real(rp), allocatable, dimension(:) :: v - - integer(hsize_t), dimension(1) :: dims, maxdims - integer(hid_t) :: dataset, dataspace - integer(kind=4) :: eflag - - call h5dopen_f(hid, dataset_name, dataset, eflag) - call h5dget_space_f(dataset, dataspace, eflag) - call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) - if(.not. allocated(v)) then - call mallocate('r1_hdf5_read_array [v]', int(dims(1), ip), v) - else - if(size(v, 1) /= int(dims(1), ip)) then - call fatal_error("Reading HDF5 array on a buffer of wrong size ["//dataset_name//"]") - end if - end if - call h5dread_f(dataset, H5T_RP, v, dims, eflag) - end subroutine - - subroutine r2_hdf5_read_array(hid, dataset_name, v) - use hdf5 - use mod_mmpol, only: fatal_error - use mod_memory, only: mallocate - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: dataset_name - real(rp), allocatable, dimension(:,:) :: v - - integer(hsize_t), dimension(2) :: dims, maxdims - integer(hid_t) :: dataset, dataspace - integer(kind=4) :: eflag - - call h5dopen_f(hid, dataset_name, dataset, eflag) - call h5dget_space_f(dataset, dataspace, eflag) - call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) - if(.not. allocated(v)) then - call mallocate('r2_hdf5_read_array [v]', int(dims(1), ip), & - int(dims(2), ip), v) - else - if(size(v, 1) /= int(dims(1), ip) .or. & - size(v, 2) /= int(dims(2), ip)) then - call fatal_error("Reading HDF5 array on a buffer of wrong size ["//dataset_name//"]") - end if - end if - call h5dread_f(dataset, H5T_RP, v, dims, eflag) - end subroutine - - subroutine r3_hdf5_read_array(hid, dataset_name, v) - use hdf5 - use mod_mmpol, only: fatal_error - use mod_memory, only: mallocate - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: dataset_name - real(rp), allocatable, dimension(:,:,:) :: v - - integer(hsize_t), dimension(3) :: dims, maxdims - integer(hid_t) :: dataset, dataspace - integer(kind=4) :: eflag - - call h5dopen_f(hid, dataset_name, dataset, eflag) - call h5dget_space_f(dataset, dataspace, eflag) - call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) - if(.not. allocated(v)) then - call mallocate('r3_hdf5_read_array [v]', int(dims(1), ip), & - int(dims(2), ip), int(dims(3), ip), v) - else - if(size(v, 1) /= int(dims(1), ip) .or. & - size(v, 2) /= int(dims(2), ip) .or. & - size(v, 3) /= int(dims(3), ip)) then - call fatal_error("Reading HDF5 array on a buffer of wrong size ["//dataset_name//"]") - end if - end if - call h5dread_f(dataset, H5T_RP, v, dims, eflag) - end subroutine - - subroutine i1_hdf5_read_array(hid, dataset_name, v) - use hdf5 - use mod_mmpol, only: fatal_error - use mod_memory, only: mallocate - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: dataset_name - integer(ip), allocatable, dimension(:) :: v - - integer(hsize_t), dimension(1) :: dims, maxdims - integer(hid_t) :: dataset, dataspace - integer(kind=4) :: eflag - - call h5dopen_f(hid, dataset_name, dataset, eflag) - call h5dget_space_f(dataset, dataspace, eflag) - call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) - if(.not. allocated(v)) then - call mallocate('i1_hdf5_read_array [v]', int(dims(1), ip), v) - else - if(size(v, 1) /= int(dims(1), ip)) then - call fatal_error("Reading HDF5 array on a buffer of wrong size ["//dataset_name//"]") - end if - end if - call h5dread_f(dataset, H5T_IP, v, dims, eflag) - end subroutine - - subroutine i2_hdf5_read_array(hid, dataset_name, v) - use hdf5 - use mod_mmpol, only: fatal_error - use mod_memory, only: mallocate - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: dataset_name - integer(ip), allocatable, dimension(:,:) :: v - - integer(hsize_t), dimension(2) :: dims, maxdims - integer(hid_t) :: dataset, dataspace - integer(kind=4) :: eflag - - call h5dopen_f(hid, dataset_name, dataset, eflag) - call h5dget_space_f(dataset, dataspace, eflag) - call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) - if(.not. allocated(v)) then - call mallocate('i2_hdf5_read_array [v]', int(dims(1), ip), & - int(dims(2), ip), v) - else - if(size(v, 1) /= int(dims(1), ip) .or. & - size(v, 2) /= int(dims(2), ip)) then - call fatal_error("Reading HDF5 array on a buffer of wrong size ["//dataset_name//"]") - end if - end if - call h5dread_f(dataset, H5T_IP, v, dims, eflag) - end subroutine - - subroutine i3_hdf5_read_array(hid, dataset_name, v) - use hdf5 - use mod_mmpol, only: fatal_error - use mod_memory, only: mallocate - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: dataset_name - integer(ip), allocatable, dimension(:,:,:) :: v - - integer(hsize_t), dimension(3) :: dims, maxdims - integer(hid_t) :: dataset, dataspace - integer(kind=4) :: eflag - - call h5dopen_f(hid, dataset_name, dataset, eflag) - call h5dget_space_f(dataset, dataspace, eflag) - call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) - if(.not. allocated(v)) then - call mallocate('i3_hdf5_read_array [v]', int(dims(1), ip), & - int(dims(2), ip), int(dims(3), ip), v) - else - if(size(v, 1) /= int(dims(1), ip) .or. & - size(v, 2) /= int(dims(2), ip) .or. & - size(v, 3) /= int(dims(3), ip)) then - call fatal_error("Reading HDF5 array on a buffer of wrong size ["//dataset_name//"]") - end if - end if - call h5dread_f(dataset, H5T_IP, v, dims, eflag) - end subroutine - - subroutine l1_hdf5_read_array(hid, dataset_name, v) - use hdf5 - use mod_mmpol, only: fatal_error - use mod_memory, only: mallocate - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: dataset_name - logical(lp), allocatable, dimension(:) :: v - - integer(hsize_t), dimension(1) :: dims, maxdims - integer(hid_t) :: dataset, dataspace - integer(kind=4) :: eflag - integer(kind=c_int8_t), dimension(:), allocatable :: tmp - integer(hsize_t) :: i - - call h5dopen_f(hid, dataset_name, dataset, eflag) - call h5dget_space_f(dataset, dataspace, eflag) - call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) - if(.not. allocated(v)) then - call mallocate('l1_hdf5_read_array [v]', int(dims(1), ip), v) - else - if(size(v, 1) /= int(dims(1), ip)) then - call fatal_error("Reading HDF5 array on a buffer of wrong size ["//dataset_name//"]") - end if - end if - - allocate(tmp(dims(1))) - call h5dread_f(dataset, H5T_LP, tmp, dims, eflag) - - do i=1, dims(1) - if(tmp(i) == 1) then - v(i) = .true. - else - v(i) = .false. - end if - end do - - deallocate(tmp) - end subroutine - - subroutine l2_hdf5_read_array(hid, dataset_name, v) - use hdf5 - use mod_mmpol, only: fatal_error - use mod_memory, only: mallocate - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: dataset_name - logical(lp), allocatable, dimension(:,:) :: v - - integer(hsize_t), dimension(2) :: dims, maxdims - integer(hid_t) :: dataset, dataspace - integer(kind=4) :: eflag - - integer(kind=c_int8_t), dimension(:,:), allocatable :: tmp - integer(hsize_t) :: i, j - - call h5dopen_f(hid, dataset_name, dataset, eflag) - call h5dget_space_f(dataset, dataspace, eflag) - call h5sget_simple_extent_dims_f(dataspace, dims, maxdims, eflag) - if(.not. allocated(v)) then - call mallocate('i2_hdf5_read_array [v]', int(dims(1), ip), & - int(dims(2), ip), v) - else - if(size(v, 1) /= int(dims(1), ip) .or. & - size(v, 2) /= int(dims(2), ip)) then - call fatal_error("Reading HDF5 array on a buffer of wrong size ["//dataset_name//"]") - end if - end if - - allocate(tmp(dims(1), dims(2))) - call h5dread_f(dataset, H5T_LP, tmp, dims, eflag) - - do i=1, dims(1) - do j=1, dims(2) - if(tmp(i,j) == 1) then - v(i,j) = .true. - else - v(i,j) = .false. - end if - end do - end do - - deallocate(tmp) - end subroutine - - subroutine r_hdf5_read_scalar(hid, location, attname, s) - use hdf5 - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: location, attname - real(rp) :: s - - integer(hsize_t), dimension(1), parameter :: dims = [1] - integer(kind=4) :: eflag - integer(hid_t) :: att_id, dataset - - call h5gopen_f(hid, location, dataset, eflag) - call H5Aopen_name_f(dataset, attname, att_id, eflag) - call H5Aread_f(att_id, H5T_RP, s, dims, eflag) - call h5gclose_f(dataset, eflag) - end subroutine - - subroutine i_hdf5_read_scalar(hid, location, attname, s) - use hdf5 - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: location, attname - integer(ip) :: s - - integer(hsize_t), dimension(1), parameter :: dims = [1] - integer(kind=4) :: eflag - integer(hid_t) :: att_id, dataset - - call h5gopen_f(hid, location, dataset, eflag) - call H5Aopen_name_f(dataset, attname, att_id, eflag) - call H5Aread_f(att_id, H5T_IP, s, dims, eflag) - call h5gclose_f(dataset, eflag) - end subroutine - - subroutine l_hdf5_read_scalar(hid, location, attname, s) - use hdf5 - - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: location, attname - integer(c_int8_t) :: is - logical(lp) :: s - - integer(hsize_t), dimension(1), parameter :: dims = [1] - integer(kind=4) :: eflag - integer(hid_t) :: att_id, dataset - - call h5gopen_f(hid, location, dataset, eflag) - call H5Aopen_name_f(dataset, attname, att_id, eflag) - call H5Aread_f(att_id, H5T_LP, is, dims, eflag) - call h5gclose_f(dataset, eflag) - if(is == 0) then - s = .false. - else - s = .true. - end if - end subroutine - - function hdf5_name_exists(hid, location) result(exists) - implicit none - - integer(hid_t), intent(in) :: hid - character(len=*), intent(in) :: location - logical :: exists - - integer(kind=4) :: eflag - - call h5lexists_f(hid, location, exists, eflag) - end function - - subroutine save_system_as_hdf5(filename, s, out_fail, & - namespace, & - mutable_only) - implicit none - - character(len=*), intent(in) :: filename, namespace - type(ommp_system), intent(in) :: s - integer(ip), intent(out) :: out_fail - logical(lp), intent(in) :: mutable_only - - integer(hid_t) :: hg - integer(kind=4) :: eflag - integer(hid_t) :: iof_hdf5 = 301 - logical :: append - - ! Initialize interface - call h5open_f(eflag) - if(eflag /= 0) then - call ommp_message("Unable to initialize HDF5 module. Failure in & - &h5open_f subroutine.", OMMP_VERBOSE_LOW) - out_fail = -1_ip - return - end if - - inquire(file=filename, exist=append) - if(append) then - call ommp_message("HDF5 file exists, appending.", OMMP_VERBOSE_HIGH) - call h5fopen_f(filename, H5F_ACC_RDWR_F, iof_hdf5, eflag) - if( eflag /= 0) then - call ommp_message("Unable to open HDF5 file. Failure in & - &h5opene_f subroutine.", OMMP_VERBOSE_LOW) - out_fail = -1_ip - return - end if - else - call h5fcreate_f(filename, H5F_ACC_EXCL_F, iof_hdf5, eflag) - if( eflag /= 0) then - call ommp_message("Unable to create HDF5 file. Failure in & - &h5fcreate_f subroutine.", OMMP_VERBOSE_LOW) - out_fail = -1_ip - return - end if - end if - - ! TODO Handle more complex cases like a/b/c in namespace - call h5gcreate_f(iof_hdf5, namespace, hg, eflag) - if( eflag /= 0) then - call ommp_message("Error while creating group.& - &Failure in h5gcreate_f subroutine.", OMMP_VERBOSE_LOW) - out_fail = -1_ip - return - end if - call hdf5_add_scalar(hg, 'mutable_only', mutable_only) - call h5gclose_f(hg, eflag) - - call save_topology_as_hdf5(iof_hdf5, s%top, eflag, & - namespace//'/topology', mutable_only) - call save_electrostatics_as_hdf5(iof_hdf5, s%eel, eflag, & - namespace//'/electrostatics', & - mutable_only) - - if(s%use_nonbonded) & - call save_nonbonded_as_hdf5(iof_hdf5, s%vdw, eflag, & - namespace//'/nonbonded', & - mutable_only) - if(s%use_bonded) & - call save_bonded_as_hdf5(iof_hdf5, s%bds, eflag, & - namespace//'/bonded', & - mutable_only) - - call h5fclose_f(iof_hdf5, eflag) - if( eflag /= 0) then - call ommp_message("Error while closing HDF5 file. Failure in & - &h5fclose_f subroutine.", OMMP_VERBOSE_LOW) - out_fail = -1_ip - return - end if - - out_fail = 0_ip - end subroutine - - subroutine save_topology_as_hdf5(iof_hdf5, top, out_fail, & - namespace, & - mutable_only) - implicit none - - integer(hid_t) :: iof_hdf5 - character(len=*), intent(in) :: namespace - type(ommp_topology_type), intent(in) :: top - integer(ip), intent(out) :: out_fail - logical(lp), intent(in) :: mutable_only - - integer(hid_t) :: hg, hg_cur - integer(kind=4) :: eflag - - call h5gcreate_f(iof_hdf5, namespace, hg, eflag) - if( eflag /= 0) then - call ommp_message("Error while creating group 'system model.'& - &Failure in h5gcreate_f subroutine.", OMMP_VERBOSE_LOW) - out_fail = -1_ip - return - end if - - if(.not. mutable_only) then - call hdf5_add_scalar(hg, "N-atoms", top%mm_atoms) - call h5gcreate_f(hg, "connectivity", hg_cur, eflag) - call hdf5_add_array(hg_cur, "ADJ1-RowIdx", top%conn(1)%ri) - call hdf5_add_array(hg_cur, "ADJ1-ColIdx", top%conn(1)%ci) - call h5gclose_f(hg_cur, eflag) - - if(top%atz_initialized) call hdf5_add_array(hg, "Atoms-Z", top%atz) - if(top%attype_initialized) & - call hdf5_add_array(hg, "Atoms-Type", top%attype) - if(top%atclass_initialized) & - call hdf5_add_array(hg, "Atoms-Class", top%atclass) - end if - - call hdf5_add_array(hg, "Atoms-Coordinates", top%cmm) - call h5gclose_f(hg, eflag) - - out_fail = 0_ip - - end subroutine - - subroutine save_electrostatics_as_hdf5(iof_hdf5, eel, out_fail, & - namespace, & - mutable_only) - - use mod_memory, only: mallocate, mfree - implicit none - - integer(hid_t) :: iof_hdf5 - character(len=*), intent(in) :: namespace - type(ommp_electrostatics_type), intent(in) :: eel - integer(ip), intent(out) :: out_fail - logical(lp), intent(in) :: mutable_only - - integer(hid_t) :: hg, listg - integer(kind=4) :: eflag - real(rp), allocatable :: tmp_q0(:, :) - - call h5gcreate_f(iof_hdf5, namespace, hg, eflag) - if( eflag /= 0) then - call ommp_message("Error while creating group. & - &Failure in h5gcreate_f subroutine.", OMMP_VERBOSE_LOW) - out_fail = -1_ip - return - end if - - if(.not. mutable_only) then - call hdf5_add_scalar(hg, "N-pol-atoms", eel%pol_atoms) - call hdf5_add_scalar(hg, "amoeba", eel%amoeba) - call hdf5_add_scalar(hg, "thole_scale", eel%thole_scale) - - if(eel%amoeba) then - ! Write the unrotated multipoles, that are coordinates independent - ! Since quadrupoles have been multiplied by 1/3 - ! (see [[mod_mmpol::mmpol_prepare]]) we should now save them - ! correctly so we multiply quadrupoles terms by 3 - call mallocate('save_as_hdf5 [tmp_q0]', & - size(eel%q0, 1), size(eel%q0, 2), tmp_q0) - tmp_q0 = eel%q0 - tmp_q0(5:10,:) = tmp_q0(5:10,:) * 3.0 - call hdf5_add_array(hg, "fixed_multipoles_unrotated", tmp_q0) - call mfree('save_as_hdf5 [tmp_q0]', tmp_q0) - - ! Write all the information needed to perform the rotation of the - ! multipoles - call hdf5_add_array(hg, "fixed_mmpoles_rot_Z", eel%iz) - call hdf5_add_array(hg, "fixed_mmpoles_rot_X", eel%ix) - call hdf5_add_array(hg, "fixed_mmpoles_rot_Y", eel%iy) - call hdf5_add_array(hg, "fixed_mmpoles_rot_CONV", eel%mol_frame) - - call hdf5_add_array(hg, "polarization_group_id", eel%mmat_polgrp) - else - call hdf5_add_array(hg, "fixed_multipoles", eel%q) - end if - - call hdf5_add_array(hg, "fixed_fixed_scale_f", eel%mscale) - call hdf5_add_array(hg, "fixed_ipd_scale_f", eel%pscale) - call hdf5_add_array(hg, "ipd_ipd_scale_f", eel%uscale) - if(eel%amoeba) then - call hdf5_add_array(hg, "fixed_direct_ipd_scale_f", eel%dscale) - call hdf5_add_array(hg, "fixed_intragroup_ipd_scale_f", eel%pscale_intra) - end if - - call hdf5_add_array(hg, "polarizable_atoms_idx", eel%polar_mm) - call hdf5_add_array(hg, "polarizabilities", eel%pol) - - if(eel%screening_list_done) then - call h5gcreate_f(iof_hdf5, namespace//"/screening_lists", listg, eflag) - if( eflag /= 0) then - call ommp_message("Error while creating group. & - &Failure in h5gcreate_f subroutine.", OMMP_VERBOSE_LOW) - out_fail = -1_ip - return - end if - - call hdf5_add_scalar(listg, "SS_n", eel%list_S_S%n) - call hdf5_add_array(listg, "SS_ri", eel%list_S_S%ri) - call hdf5_add_array(listg, "SS_ci", eel%list_S_S%ci) - call hdf5_add_array(listg, "SS_scalef", eel%scalef_S_S) - call hdf5_add_array(listg, "SS_todo", eel%todo_S_S) - - call hdf5_add_scalar(listg, "PP_n", eel%list_P_P%n) - call hdf5_add_array(listg, "PP_ri", eel%list_P_P%ri) - call hdf5_add_array(listg, "PP_ci", eel%list_P_P%ci) - call hdf5_add_array(listg, "PP_scalef", eel%scalef_P_P) - call hdf5_add_array(listg, "PP_todo", eel%todo_P_P) - - call hdf5_add_scalar(listg, "SPP_n", eel%list_S_P_P%n) - call hdf5_add_array(listg, "SPP_ri", eel%list_S_P_P%ri) - call hdf5_add_array(listg, "SPP_ci", eel%list_S_P_P%ci) - call hdf5_add_array(listg, "SPP_scalef", eel%scalef_S_P_P) - call hdf5_add_array(listg, "SPP_todo", eel%todo_S_P_P) - - if(eel%amoeba) then - call hdf5_add_scalar(listg, "SPD_n", eel%list_S_P_D%n) - call hdf5_add_array(listg, "SPD_ri", eel%list_S_P_D%ri) - call hdf5_add_array(listg, "SPD_ci", eel%list_S_P_D%ci) - call hdf5_add_array(listg, "SPD_scalef", eel%scalef_S_P_D) - call hdf5_add_array(listg, "SPD_todo", eel%todo_S_P_D) - end if - call h5gclose_f(listg, eflag) - end if - end if - - if(eel%amoeba) then - call hdf5_add_array(hg, "fixed_multipoles_rotated", eel%q) - end if - - if(eel%M2M_done) then - call hdf5_add_array(hg, "potential_M2M", eel%V_M2M) - call hdf5_add_array(hg, "field_M2M", eel%E_M2M) - call hdf5_add_array(hg, "field_grd_M2M", eel%Egrd_M2M) - end if - - if(eel%M2D_done) then - call hdf5_add_array(hg, "field_M2M", eel%E_M2D) - end if - - if(eel%ipd_done) then - call hdf5_add_array(hg, "induced_point_dipoles", eel%ipd) - end if - - call h5gclose_f(hg, eflag) - - out_fail = 0_ip - - end subroutine - - subroutine save_nonbonded_as_hdf5(iof_hdf5, vdw, out_fail, & - namespace, & - mutable_only) - implicit none - - integer(hid_t) :: iof_hdf5 - character(len=*), intent(in) :: namespace - type(ommp_nonbonded_type), intent(in) :: vdw - integer(ip), intent(out) :: out_fail - logical(lp), intent(in) :: mutable_only - - integer(hid_t) :: hg - integer(kind=4) :: eflag - - call h5gcreate_f(iof_hdf5, namespace, hg, eflag) - if( eflag /= 0) then - call ommp_message("Error while creating group. & - &Failure in h5gcreate_f subroutine.", OMMP_VERBOSE_LOW) - out_fail = -1_ip - return - end if - - if(.not. mutable_only) then - call hdf5_add_scalar(hg, "use_nl", vdw%use_nl) - call hdf5_add_scalar(hg, "radrule", vdw%radrule) - call hdf5_add_scalar(hg, "radtype", vdw%radtype) - call hdf5_add_scalar(hg, "vdwtype", vdw%vdwtype) - call hdf5_add_scalar(hg, "epsrule", vdw%epsrule) - call hdf5_add_scalar(hg, "radf", vdw%radf) - - call hdf5_add_array(hg, "screening", vdw%vdw_screening) - call hdf5_add_array(hg, "radius", vdw%vdw_r) - call hdf5_add_array(hg, "energy", vdw%vdw_e) - call hdf5_add_array(hg, "scale_factor", vdw%vdw_f) - call hdf5_add_scalar(hg, "npair", vdw%npair) - call hdf5_add_array(hg, "vdw_pair_mask_a", vdw%vdw_pair_mask_a) - call hdf5_add_array(hg, "vdw_pair_mask_b", vdw%vdw_pair_mask_b) - call hdf5_add_array(hg, "pair_radius", vdw%vdw_pair_r) - call hdf5_add_array(hg, "pair_energy", vdw%vdw_pair_e) - end if - - call h5gclose_f(hg, eflag) - - out_fail = 0_ip - end subroutine - - subroutine save_bonded_as_hdf5(iof_hdf5, bds, out_fail, & - namespace, & - mutable_only) - implicit none - - integer(hid_t) :: iof_hdf5 - character(len=*), intent(in) :: namespace - type(ommp_bonded_type), intent(in) :: bds - integer(ip), intent(out) :: out_fail - logical(lp), intent(in) :: mutable_only - - integer(hid_t) :: hg, hg_cur_bp - integer(kind=4) :: eflag - - call h5gcreate_f(iof_hdf5, namespace, hg, eflag) - if( eflag /= 0) then - call ommp_message("Error while creating group. & - &Failure in h5gcreate_f subroutine.", OMMP_VERBOSE_LOW) - out_fail = -1_ip - return - end if - - if(.not. mutable_only) then - call h5gcreate_f(hg, "stretching", hg_cur_bp, eflag) - call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_bond) - if(bds%use_bond) then - call hdf5_add_scalar(hg_cur_bp, "cubic", bds%bond_cubic) - call hdf5_add_scalar(hg_cur_bp, "quartic", bds%bond_quartic) - call hdf5_add_array(hg_cur_bp, "k", bds%kbond) - call hdf5_add_array(hg_cur_bp, "l0", bds%l0bond) - call hdf5_add_array(hg_cur_bp, "atoms", bds%bondat) - end if - call h5gclose_f(hg_cur_bp, eflag) - - ! Angle bending - call h5gcreate_f(hg, "bending", hg_cur_bp, eflag) - call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_angle) - if(bds%use_angle) then - call hdf5_add_scalar(hg_cur_bp, "cubic", bds%angle_cubic) - call hdf5_add_scalar(hg_cur_bp, "quartic", bds%angle_quartic) - call hdf5_add_scalar(hg_cur_bp, "pentic", bds%angle_pentic) - call hdf5_add_scalar(hg_cur_bp, "sextic", bds%angle_sextic) - call hdf5_add_array(hg_cur_bp, "k", bds%kangle) - call hdf5_add_array(hg_cur_bp, "ang0", bds%eqangle) - call hdf5_add_array(hg_cur_bp, "atoms", bds%angleat) - call hdf5_add_array(hg_cur_bp, "auxatom", bds%angauxat) - call hdf5_add_array(hg_cur_bp, "type", bds%anglety) - end if - call h5gclose_f(hg_cur_bp, eflag) - - ! Dihedral torsion - call h5gcreate_f(hg, "torsion", hg_cur_bp, eflag) - call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_torsion) - if(bds%use_torsion) then - call hdf5_add_array(hg_cur_bp, "amplitudes", bds%torsamp) - call hdf5_add_array(hg_cur_bp, "phase", bds%torsphase) - call hdf5_add_array(hg_cur_bp, "atoms", bds%torsionat) - call hdf5_add_array(hg_cur_bp, "period", bds%torsn) - end if - call h5gclose_f(hg_cur_bp, eflag) - - ! Improper Dihedral torsion - call h5gcreate_f(hg, "improper_torsion", hg_cur_bp, eflag) - call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_imptorsion) - if(bds%use_imptorsion) then - call hdf5_add_array(hg_cur_bp, "amplitudes", bds%imptorsamp) - call hdf5_add_array(hg_cur_bp, "phase", bds%imptorsphase) - call hdf5_add_array(hg_cur_bp, "atoms", bds%imptorsionat) - call hdf5_add_array(hg_cur_bp, "period", bds%imptorsn) - end if - call h5gclose_f(hg_cur_bp, eflag) - - ! Stretching-bending coupling - call h5gcreate_f(hg, "stretching-bending", hg_cur_bp, eflag) - call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_strbnd) - if(bds%use_strbnd) then - call hdf5_add_array(hg_cur_bp, "k1", bds%strbndk1) - call hdf5_add_array(hg_cur_bp, "k2", bds%strbndk2) - call hdf5_add_array(hg_cur_bp, "l1_0", bds%strbndl10) - call hdf5_add_array(hg_cur_bp, "l2_0", bds%strbndl20) - call hdf5_add_array(hg_cur_bp, "ang0", bds%strbndthet0) - call hdf5_add_array(hg_cur_bp, "atoms", bds%strbndat) - end if - call h5gclose_f(hg_cur_bp, eflag) - - ! Stretching-torsion coupling - call h5gcreate_f(hg, "stretching-torsion", hg_cur_bp, eflag) - call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_strtor) - if(bds%use_strtor) then - call hdf5_add_array(hg_cur_bp, "k", bds%strtork) - call hdf5_add_array(hg_cur_bp, "bonds_idx", bds%strtor_b) - call hdf5_add_array(hg_cur_bp, "torsion_idx", bds%strtor_t) - call hdf5_add_array(hg_cur_bp, "atoms", bds%strtorat) - end if - call h5gclose_f(hg_cur_bp, eflag) - - ! Bending-torsion coupling - call h5gcreate_f(hg, "bending-torsion", hg_cur_bp, eflag) - call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_angtor) - if(bds%use_angtor) then - call hdf5_add_array(hg_cur_bp, "k", bds%angtork) - call hdf5_add_array(hg_cur_bp, "angles_idx", bds%angtor_a) - call hdf5_add_array(hg_cur_bp, "torsion_idx", bds%angtor_t) - call hdf5_add_array(hg_cur_bp, "atoms", bds%angtorat) - end if - call h5gclose_f(hg_cur_bp, eflag) - - ! Torsion-torsion coupling - call h5gcreate_f(hg, "torsion-torsion", hg_cur_bp, eflag) - call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_tortor) - if(bds%use_tortor) then - call hdf5_add_array(hg_cur_bp, "atoms", bds%tortorat) - call hdf5_add_array(hg_cur_bp, "map_id", bds%tortorprm) - call hdf5_add_array(hg_cur_bp, "maps_ang1", bds%ttmap_ang1) - call hdf5_add_array(hg_cur_bp, "maps_ang2", bds%ttmap_ang2) - call hdf5_add_array(hg_cur_bp, "maps_pot", bds%ttmap_v) - call hdf5_add_array(hg_cur_bp, "maps_shapes", bds%ttmap_shape) - end if - call h5gclose_f(hg_cur_bp, eflag) - - ! Pi-torsion - call h5gcreate_f(hg, "pi-torsion", hg_cur_bp, eflag) - call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_pitors) - if(bds%use_pitors) then - call hdf5_add_array(hg_cur_bp, "atoms", bds%pitorsat) - call hdf5_add_array(hg_cur_bp, "k", bds%kpitors) - end if - call h5gclose_f(hg_cur_bp, eflag) - - ! Out-of-plane bending - call h5gcreate_f(hg, "out-of-plane-bending", hg_cur_bp, eflag) - call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_opb) - if(bds%use_opb) then - call hdf5_add_scalar(hg_cur_bp, "cubic", bds%opb_cubic) - call hdf5_add_scalar(hg_cur_bp, "quartic", bds%opb_quartic) - call hdf5_add_scalar(hg_cur_bp, "pentic", bds%opb_pentic) - call hdf5_add_scalar(hg_cur_bp, "sextic", bds%opb_sextic) - call hdf5_add_array(hg_cur_bp, "k", bds%kopb) - call hdf5_add_array(hg_cur_bp, "atoms", bds%opbat) - endif - call h5gclose_f(hg_cur_bp, eflag) - - ! Urey-Bradley stretching - call h5gcreate_f(hg, "urey-bradley", hg_cur_bp, eflag) - call hdf5_add_scalar(hg_cur_bp, "enabled", bds%use_urey) - if(bds%use_urey) then - call hdf5_add_scalar(hg_cur_bp, "cubic", bds%urey_cubic) - call hdf5_add_scalar(hg_cur_bp, "quartic", bds%urey_quartic) - call hdf5_add_array(hg_cur_bp, "k", bds%kurey) - call hdf5_add_array(hg_cur_bp, "l0", bds%l0urey) - call hdf5_add_array(hg_cur_bp, "atoms", bds%ureyat) - end if - call h5gclose_f(hg_cur_bp, eflag) - end if - - call h5gclose_f(hg, eflag) - - out_fail = 0_ip - end subroutine - - subroutine mmpol_init_from_hdf5(filename, namespace, s, out_fail) - use hdf5 - use mod_adjacency_mat, only: build_conn_upto_n, yale_sparse - use mod_io, only: ommp_message - use mod_memory, only: mfree, mallocate - use mod_mmpol, only: mmpol_init, & - mmpol_prepare, mmpol_init_nonbonded, mmpol_init_bonded - use mod_electrostatics, only: set_screening_parameters - use mod_constants, only: OMMP_VERBOSE_LOW - use mod_bonded, only: bond_init, angle_init, urey_init, strbnd_init, & - opb_init, pitors_init, torsion_init, tortor_init, & - strtor_init, angtor_init, tortor_newmap, imptorsion_init - use mod_nonbonded, only: vdw_set_pair - - implicit none - - character(len=*), intent(in) :: namespace - type(ommp_system), intent(inout), target :: s - character(len=*), intent(in) :: filename - integer(ip), intent(out) :: out_fail - - integer(hid_t) :: iof_hdf5 = 301 - integer(kind=4) :: eflag - real(rp), dimension(:), allocatable :: l_mscale, l_pscale, l_dscale, & - l_uscale, l_ipscale, l_vdwscale - type(yale_sparse) :: conn_1 - integer(ip) :: mm_atoms, pol_atoms - logical(lp) :: amoeba, mutable_only - - ! For handling torsion maps - integer(ip) :: i, j, ibeg, iend - integer(ip), allocatable, dimension(:,:) :: tmp_shape - real(rp), allocatable, dimension(:) :: tmp_ang1, tmp_ang2, tmp_v - - ! Initialize interface - call h5open_f(eflag) - if(eflag /= 0) then - call ommp_message("Unable to initialize HDF5 module. Failure in & - &h5open_f subroutine.", OMMP_VERBOSE_LOW) - out_fail = -1_ip - return - end if - - call h5fopen_f(filename, H5F_ACC_RDONLY_F, iof_hdf5, eflag) - if( eflag /= 0) then - call ommp_message("Unable to open HDF5 file. Failure in & - &h5fopen_f subroutine.", OMMP_VERBOSE_LOW) - out_fail = -1_ip - return - end if - - call hdf5_read_scalar(iof_hdf5, & - namespace, 'mutable_only', & - mutable_only) - if(mutable_only) then - call ommp_message("Unable to intialize from the selected file/& - &namespace as it is marked mutable only", & - OMMP_VERBOSE_LOW) - out_fail = -1_ip - return - end if - - call hdf5_read_scalar(iof_hdf5, & - namespace//'/topology', 'N-atoms', & - mm_atoms) - call hdf5_read_scalar(iof_hdf5, & - namespace//'/electrostatics', 'N-pol-atoms', & - pol_atoms) - call hdf5_read_scalar(iof_hdf5, & - namespace//'/electrostatics', 'amoeba', & - amoeba) - - if(amoeba) then - call mmpol_init(s, 1_ip, mm_atoms, pol_atoms) - else - call mmpol_init(s, 0_ip, mm_atoms, pol_atoms) - end if - - ! Connectivity - call hdf5_read_array(iof_hdf5, & - namespace//'/topology/connectivity/ADJ1-RowIdx', & - conn_1%ri) - call hdf5_read_array(iof_hdf5, & - namespace//'/topology/connectivity/ADJ1-ColIdx', & - conn_1%ci) - conn_1%n = size(conn_1%ri) - 1 - call build_conn_upto_n(conn_1, 4, s%top%conn, .false.) - - if(hdf5_name_exists(iof_hdf5, namespace//'/topology/Atoms-Type')) then - s%top%attype_initialized = .true. - call hdf5_read_array(iof_hdf5, & - namespace//'/topology/Atoms-Type', & - s%top%attype) - end if - - if(hdf5_name_exists(iof_hdf5, namespace//'/topology/Atoms-Class')) then - s%top%atclass_initialized = .true. - call hdf5_read_array(iof_hdf5, & - namespace//'/topology/Atoms-Class', & - s%top%atclass) - end if - - ! AMOEBA - if(amoeba) then - call hdf5_read_array(iof_hdf5, & - namespace//'/electrostatics/polarization_group_id', & - s%eel%mmat_polgrp) - end if - - ! Bonded Parameters - if(hdf5_name_exists(iof_hdf5, namespace//'/bonded')) then - call mmpol_init_bonded(s) - ! Bond stretching - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/stretching', & - 'enabled', & - s%bds%use_bond) - if(s%bds%use_bond) then - call bond_init(s%bds, hdf5_array_len(iof_hdf5, & - namespace//'/bonded/stretching/atoms')) - - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/stretching', & - 'quartic', & - s%bds%bond_quartic) - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/stretching', & - 'cubic', & - s%bds%bond_cubic) - call hdf5_read_array(iof_hdf5, & - namespace//'/bonded/stretching/k', & - s%bds%kbond) - call hdf5_read_array(iof_hdf5, & - namespace//'/bonded/stretching/l0', & - s%bds%l0bond) - call hdf5_read_array(iof_hdf5, & - namespace//'/bonded/stretching/atoms', & - s%bds%bondat) - end if - - ! Angle bending - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/bending', & - 'enabled', & - s%bds%use_angle) - if(s%bds%use_angle) then - call angle_init(s%bds, hdf5_array_len(iof_hdf5, & - namespace//'/bonded/bending/atoms')) - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/bending', & - "cubic", s%bds%angle_cubic) - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/bending', & - "quartic", s%bds%angle_quartic) - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/bending', & - "pentic", s%bds%angle_pentic) - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/bending', & - "sextic", s%bds%angle_sextic) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/bending/k", & - s%bds%kangle) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/bending/ang0", & - s%bds%eqangle) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/bending/atoms", & - s%bds%angleat) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/bending/auxatom", & - s%bds%angauxat) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/bending/type", & - s%bds%anglety) - end if - - ! Dihedral torsion - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/torsion', & - 'enabled', & - s%bds%use_torsion) - if(s%bds%use_torsion) then - call torsion_init(s%bds, hdf5_array_len(iof_hdf5, & - namespace//'/bonded/torsion/atoms')) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/torsion/amplitudes", & - s%bds%torsamp) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/torsion/phase", & - s%bds%torsphase) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/torsion/atoms", & - s%bds%torsionat) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/torsion/period", & - s%bds%torsn) - end if - - ! Improper Dihedral torsion - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/improper_torsion', & - 'enabled', & - s%bds%use_imptorsion) - if(s%bds%use_imptorsion) then - call imptorsion_init(s%bds, hdf5_array_len(iof_hdf5, & - namespace//'/bonded/improper_torsion/atoms')) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/improper_torsion/amplitudes", & - s%bds%imptorsamp) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/improper_torsion/phase", & - s%bds%imptorsphase) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/improper_torsion/atoms", & - s%bds%imptorsionat) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/improper_torsion/period", & - s%bds%imptorsn) - end if - - ! Stretching-bending coupling - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/stretching-bending', & - 'enabled', & - s%bds%use_strbnd) - if(s%bds%use_strbnd) then - call strbnd_init(s%bds, hdf5_array_len(iof_hdf5, & - namespace//'/bonded/stretching-bending/atoms')) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/stretching-bending/k1", & - s%bds%strbndk1) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/stretching-bending/k2", & - s%bds%strbndk2) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/stretching-bending/l1_0", & - s%bds%strbndl10) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/stretching-bending/l2_0", & - s%bds%strbndl20) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/stretching-bending/ang0", & - s%bds%strbndthet0) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/stretching-bending/atoms", & - s%bds%strbndat) - end if - - ! Stretching-torsion coupling - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/stretching-torsion', & - 'enabled', & - s%bds%use_strtor) - if(s%bds%use_strtor) then - call strtor_init(s%bds, hdf5_array_len(iof_hdf5, & - namespace//'/bonded/stretching-torsion/atoms')) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/stretching-torsion/k", & - s%bds%strtork) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/stretching-torsion/bonds_idx", & - s%bds%strtor_b) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/stretching-torsion/torsion_idx", & - s%bds%strtor_t) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/stretching-torsion/atoms", & - s%bds%strtorat) - end if - - ! Bending-torsion coupling - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/bending-torsion', & - 'enabled', & - s%bds%use_angtor) - if(s%bds%use_angtor) then - call angtor_init(s%bds, hdf5_array_len(iof_hdf5, & - namespace//'/bonded/bending-torsion/atoms')) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/bending-torsion/k", & - s%bds%angtork) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/bending-torsion/angles_idx", & - s%bds%angtor_a) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/bending-torsion/torsion_idx", & - s%bds%angtor_t) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/bending-torsion/atoms", & - s%bds%angtorat) - end if - - ! Torsion-torsion coupling - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/torsion-torsion', & - 'enabled', & - s%bds%use_tortor) - if(s%bds%use_tortor) then - call tortor_init(s%bds, hdf5_array_len(iof_hdf5, & - namespace//'/bonded/torsion-torsion/atoms')) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/torsion-torsion/atoms", & - s%bds%tortorat) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/torsion-torsion/map_id", & - s%bds%tortorprm) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/torsion-torsion/maps_ang1", & - tmp_ang1) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/torsion-torsion/maps_ang2", & - tmp_ang2) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/torsion-torsion/maps_pot", & - tmp_v) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/torsion-torsion/maps_shapes", & - tmp_shape) - - iend = 0 - do i=1, size(tmp_shape, 2) - ibeg = iend + 1 - iend = ibeg + tmp_shape(1,i) * tmp_shape(2,i) - 1 - - call tortor_newmap(s%bds, tmp_shape(1,i), & - tmp_shape(2,i), & - tmp_ang1(ibeg:iend), & - tmp_ang2(ibeg:iend), & - tmp_v(ibeg:iend)) - end do - - call mfree('mmpol_init_from_hdf5 [tmp_ang1]', tmp_ang1) - call mfree('mmpol_init_from_hdf5 [tmp_ang2]', tmp_ang2) - call mfree('mmpol_init_from_hdf5 [tmp_v]', tmp_v) - call mfree('mmpol_init_from_hdf5 [tmp_shape]', tmp_shape) - end if - - ! Pi-torsion - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/pi-torsion', & - 'enabled', & - s%bds%use_pitors) - if(s%bds%use_pitors) then - call pitors_init(s%bds, hdf5_array_len(iof_hdf5, & - namespace//'/bonded/pi-torsion/atoms')) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/pi-torsion/atoms", & - s%bds%pitorsat) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/pi-torsion/k", & - s%bds%kpitors) - end if - - ! Out-of-plane bending - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/out-of-plane-bending', & - 'enabled', & - s%bds%use_opb) - if(s%bds%use_opb) then - call opb_init(s%bds, hdf5_array_len(iof_hdf5, & - namespace//'/bonded/out-of-plane-bending/atoms'), 'allinger') - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/out-of-plane-bending', & - "cubic", s%bds%opb_cubic) - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/out-of-plane-bending', & - "quartic", s%bds%opb_quartic) - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/out-of-plane-bending', & - "pentic", s%bds%opb_pentic) - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/out-of-plane-bending', & - "sextic", s%bds%opb_sextic) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/out-of-plane-bending/k", & - s%bds%kopb) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/out-of-plane-bending/atoms", & - s%bds%opbat) - endif - - ! Urey-Bradley stretching - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/urey-bradley', & - 'enabled', & - s%bds%use_urey) - if(s%bds%use_urey) then - call urey_init(s%bds, hdf5_array_len(iof_hdf5, & - namespace//'/bonded/urey-bradley/atoms')) - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/urey-bradley', & - "cubic", s%bds%urey_cubic) - call hdf5_read_scalar(iof_hdf5, & - namespace//'/bonded/urey-bradley', & - "quartic", s%bds%urey_quartic) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/urey-bradley/k", & - s%bds%kurey) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/urey-bradley/l0", & - s%bds%l0urey) - call hdf5_read_array(iof_hdf5, & - namespace//"/bonded/urey-bradley/atoms", & - s%bds%ureyat) - end if - end if - - if(hdf5_name_exists(iof_hdf5, namespace//"/nonbonded")) then - call mmpol_init_nonbonded(s) - !call vdw_init(s%vdw, s%top, "buffered-14-7", "cubic-mean", "diameter", "r-min", & - ! "hhg") - call hdf5_read_scalar(iof_hdf5, namespace//"/nonbonded", "use_nl", s%vdw%use_nl) - call hdf5_read_scalar(iof_hdf5, namespace//"/nonbonded", "radrule", s%vdw%radrule) - call hdf5_read_scalar(iof_hdf5, namespace//"/nonbonded", "radtype", s%vdw%radtype) - call hdf5_read_scalar(iof_hdf5, namespace//"/nonbonded", "vdwtype", s%vdw%vdwtype) - call hdf5_read_scalar(iof_hdf5, namespace//"/nonbonded", "epsrule", s%vdw%epsrule) - call hdf5_read_scalar(iof_hdf5, namespace//"/nonbonded", "radf", s%vdw%radf) - s%vdw%top => s%top - call hdf5_read_array(iof_hdf5, & - namespace//"/nonbonded/screening", & - l_vdwscale) - - s%vdw%vdw_screening = l_vdwscale - call mfree('mmpol_init_from_hdf5 [l_vdwscale]', l_vdwscale) - - call hdf5_read_array(iof_hdf5, & - namespace//"/nonbonded/radius", & - s%vdw%vdw_r) - call hdf5_read_array(iof_hdf5, & - namespace//"/nonbonded/energy", & - s%vdw%vdw_e) - call hdf5_read_array(iof_hdf5, & - namespace//"/nonbonded/scale_factor", & - s%vdw%vdw_f) - call hdf5_read_scalar(iof_hdf5, & - namespace//"/nonbonded", "npair", & - s%vdw%npair) - call hdf5_read_array(iof_hdf5, & - namespace//"/nonbonded/vdw_pair_mask_a", & - s%vdw%vdw_pair_mask_a) - call hdf5_read_array(iof_hdf5, & - namespace//"/nonbonded/vdw_pair_mask_b", & - s%vdw%vdw_pair_mask_b) - call hdf5_read_array(iof_hdf5, & - namespace//"/nonbonded/pair_radius", & - s%vdw%vdw_pair_r) - call hdf5_read_array(iof_hdf5, & - namespace//"/nonbonded/pair_energy", & - s%vdw%vdw_pair_e) - end if - - if(amoeba) then - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/fixed_multipoles_unrotated", s%eel%q) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/fixed_mmpoles_rot_Z", & - s%eel%iz) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/fixed_mmpoles_rot_X", & - s%eel%ix) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/fixed_mmpoles_rot_Y", & - s%eel%iy) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/fixed_mmpoles_rot_CONV", & - s%eel%mol_frame) - else - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/fixed_multipoles", s%eel%q) - end if - call hdf5_read_scalar(iof_hdf5, namespace//"/electrostatics", "thole_scale", s%eel%thole_scale) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/fixed_fixed_scale_f", l_mscale) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/fixed_ipd_scale_f", l_pscale) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/ipd_ipd_scale_f", l_uscale) - if(amoeba) then - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/fixed_direct_ipd_scale_f", & - l_dscale) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/fixed_intragroup_ipd_scale_f", & - l_ipscale) - call set_screening_parameters(s%eel, l_mscale, l_pscale, l_dscale, l_uscale, & - l_ipscale) - else - call mallocate('l_dscale', 4_ip, l_dscale) - l_dscale = l_pscale - call set_screening_parameters(s%eel, l_mscale, l_pscale, l_dscale, l_uscale) - end if - - if(hdf5_name_exists(iof_hdf5, namespace//"/electrostatics/screening_lists")) then - s%eel%screening_list_done = .true. - allocate(s%eel%list_S_S) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/screening_lists/SS_ri", & - s%eel%list_S_S%ri) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/screening_lists/SS_ci", & - s%eel%list_S_S%ci) - call hdf5_read_scalar(iof_hdf5, & - namespace//"/electrostatics/screening_lists", "SS_n", & - s%eel%list_S_S%n) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/screening_lists/SS_scalef", & - s%eel%scalef_S_S) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/screening_lists/SS_todo", & - s%eel%todo_S_S) - allocate(s%eel%list_P_P) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/screening_lists/PP_ri", & - s%eel%list_P_P%ri) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/screening_lists/PP_ci", & - s%eel%list_P_P%ci) - call hdf5_read_scalar(iof_hdf5, & - namespace//"/electrostatics/screening_lists", "PP_n", & - s%eel%list_P_P%n) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/screening_lists/PP_scalef", & - s%eel%scalef_P_P) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/screening_lists/PP_todo", & - s%eel%todo_P_P) - allocate(s%eel%list_S_P_P) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/screening_lists/SPP_ri", & - s%eel%list_S_P_P%ri) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/screening_lists/SPP_ci", & - s%eel%list_S_P_P%ci) - call hdf5_read_scalar(iof_hdf5, & - namespace//"/electrostatics/screening_lists", "SPP_n", & - s%eel%list_S_P_P%n) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/screening_lists/SPP_scalef", & - s%eel%scalef_S_P_P) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/screening_lists/SPP_todo", & - s%eel%todo_S_P_P) - if(s%eel%amoeba) then - allocate(s%eel%list_S_P_D) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/screening_lists/SPD_ri", & - s%eel%list_S_P_D%ri) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/screening_lists/SPD_ci", & - s%eel%list_S_P_D%ci) - call hdf5_read_scalar(iof_hdf5, & - namespace//"/electrostatics/screening_lists", "SPD_n", & - s%eel%list_S_P_D%n) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/screening_lists/SPD_scalef", & - s%eel%scalef_S_P_D) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/screening_lists/SPD_todo", & - s%eel%todo_S_P_D) - endif - end if - - call mfree('mmpol_init_from_hdf5 [l_mscale]', l_mscale) - call mfree('mmpol_init_from_hdf5 [l_pscale]', l_pscale) - call mfree('mmpol_init_from_hdf5 [l_dscale]', l_dscale) - call mfree('mmpol_init_from_hdf5 [l_uscale]', l_uscale) - call mfree('mmpol_init_from_hdf5 [l_ipscale]', l_ipscale) - - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/polarizable_atoms_idx", s%eel%polar_mm) - call hdf5_read_array(iof_hdf5, & - namespace//"/electrostatics/polarizabilities", s%eel%pol) - - call hdf5_read_array(iof_hdf5, namespace//"/topology/Atoms-Coordinates", s%top%cmm) - - call h5fclose_f(iof_hdf5, eflag) - if( eflag /= 0) then - call ommp_message("Error while closing HDF5 file. Failure in & - &h5fclose_f subroutine.", OMMP_VERBOSE_LOW) - out_fail = -1_ip - return - end if - - call mmpol_prepare(s) - - out_fail = 0_ip - end subroutine mmpol_init_from_hdf5 - -end module mod_iohdf5 -#endif diff --git a/src/mod_jacobian_mat.F90 b/src/mod_jacobian_mat.F90 new file mode 100644 index 0000000..a523178 --- /dev/null +++ b/src/mod_jacobian_mat.F90 @@ -0,0 +1,386 @@ +module mod_jacobian_mat + use mod_memory, only: rp, ip + implicit none + private + + public :: Rij_jacobian + public :: simple_angle_jacobian, inplane_angle_jacobian, & + torsion_angle_jacobian, opb_angle_jacobian, & + pitors_angle_jacobian + +contains + + pure subroutine Rij_jacobian(ci, cj, Rij, J_i, J_j) + !! Compute the Jacobian matrix of distance + !! Rij = sqrt((ci(_x_)-cj(_x_))**2 + (ci(_y_)-cj(_y_))**2 + (ci(_z_)-cj(_z_))**2) + !! Derivatives wrt ci(:) are saved in J_i and wrt cj(:) in J_j; the + !! distance between the two points is also provided in output in Rij. + + implicit none + + real(rp), intent(in) :: ci(3), cj(3) + real(rp), intent(out) :: Rij, J_i(3), J_j(3) + integer(ip) :: i + + Rij = norm2(ci-cj) + do i=1, 3 + J_i(i) = (ci(i) - cj(i))/Rij + J_j(i) = -J_i(i) + end do + end subroutine + + pure subroutine simple_angle_jacobian(ca, cb, cc, thet, J_a, J_b, J_c) + implicit none + + real(rp), intent(in), dimension(3) :: ca, cb, cc + !! Coordinates of the atoms defining the angle + real(rp), intent(out), dimension(3) :: J_a, J_b, J_c + !! The Jacobian components on atoms a, b and c respectively + real(rp), intent(out) :: thet + !! The angle (in rad) defined by ca-cb-cc + + real(rp), dimension(3) :: dr1, dr2 + real(rp) :: l1, l2, dr1_d_dr2, acosd, cost + integer(ip) :: i + + dr1 = ca - cb + dr2 = cc - cb + dr1_d_dr2 = dot_product(dr1, dr2) + l1 = norm2(dr1) + l2 = norm2(dr2) + cost = dr1_d_dr2/(l1*l2) + thet = acos(cost) + acosd = 1.0 / sqrt(1.0 - cost**2) + + do i=1,3 + J_a(i) = -acosd * (dr2(i) * l1 - dr1(i) * dr1_d_dr2 / l1) / (l1**2*l2) + J_c(i) = -acosd * (dr1(i) * l2 - dr2(i) * dr1_d_dr2 / l2) / (l1*l2**2) + J_b(i) = -(J_a(i) + J_c(i)) + end do + end subroutine + + pure subroutine inplane_angle_jacobian(ca, cb, cc, cx, thet, & + J_a, J_b, J_c, J_x) + !! Computes the Jacobian matrix for the inplane angle definition. + !! It computes the Jacobian for the normal angle using the projected + !! point (R) as central point. Then projects + !! \(J_r = \frac{\partial \theta}{\partial \vec{R}} \) onto A, B, C, and X + !! (auxiliary point). The projection is done computing the 3x3 matrices + !! of partial derivative of \(\vec{R}\) wrt any actual point and using + !! them to project \(J_r\). + !! \[\frac{\partial \vec{R}}{\partial \vec{A}} = + !! \begin{bmatrix} + !! \frac{\partial \vec{R}_x}{\partial \vec{A}_x} & + !! \frac{\partial \vec{R}_y}{\partial \vec{A}_x} & + !! \frac{\partial \vec{R}_z}{\partial \vec{A}_x} \\ + !! \frac{\partial \vec{R}_x}{\partial \vec{A}_y} & + !! \frac{\partial \vec{R}_y}{\partial \vec{A}_y} & + !! \frac{\partial \vec{R}_z}{\partial \vec{A}_y} \\ + !! \frac{\partial \vec{R}_x}{\partial \vec{A}_z} & + !! \frac{\partial \vec{R}_y}{\partial \vec{A}_z} & + !! \frac{\partial \vec{R}_z}{\partial \vec{A}_z} \\ + !! \end{bmatrix} \] + !! Those matrices are computed using the chain rule. + !! + !! Exemple: + !! \[\vec{V} = \vec{B} - \vec{X}\] + !! \[\vec{P} = (\vec{A} - \vec{X}) \times (\vec{C} - \vec{X})\] + !! \[\hat{P} = \frac{\vec{P}}{||\vec{P}||}\] + !! \[\vec{R} = \vec{B} - (\vec{V}\cdot\hat{P})\hat{P}\] + !! \[J_a = \frac{\partial \theta}{\partial \vec{A}} + !! = \left( \frac{\partial \theta}{\partial \vec{A}} \right)_\vec{R} + + !! \frac{\partial \vec{R}}{\partial \vec{A}} \times + !! J_r + !! = \left( \frac{\partial \theta}{\partial \vec{A}} \right)_\vec{R} + + !! - \frac{\partial \vec{P}}{\partial \vec{A}} \times + !! \frac{\partial \hat{P}}{\partial \vec{P}} \times + !! \frac{\partial (\vec{V} \cdot \hat{P})}{\partial \hat{P}} \times + !! J_r + !! \] + use mod_utils, only: cross_product, vec_skw, versor_der + + implicit none + + real(rp), intent(in), dimension(3) :: ca, cb, cc, cx + !! Coordinates of the atoms defining the angle + real(rp), intent(out), dimension(3) :: J_a, J_b, J_c, J_x + !! The Jacobian components on atoms a, b and c respectively + real(rp), intent(out) :: thet + !! The angle (in rad) defined by ca-cb-cc + + real(rp), dimension(3) :: cr, cv, cp, cpp, cq, cs, J_r + real(rp), dimension(3,3) :: drda, drdc, drdx, dkpdp, dppda, & + dpdpp, dpda, dpdc, dppdc, dpdx, dppdx, & + dkpdv + real(rp) :: k + integer(ip) :: i + + cq = ca - cx + cs = cc - cx + cv = cb - cx + + cpp = cross_product(cq, cs) + cp = cpp / norm2(cpp) + + k = dot_product(cv, cp) + cr = cb - k * cp + + call simple_angle_jacobian(ca, cr, cc, thet, J_a, J_r, J_c) + + do i=1,3 + dkpdp(i,:) = cv(i) * cp + dkpdp(i,i) = dkpdp(i,i) + k + end do + + dpdpp = versor_der(cpp) + + do i=1,3 + dkpdv(i,:) = cp(i) * cp + end do + + dppda = -vec_skw(cs) + dppdc = vec_skw(cq) + + dppdx = -vec_skw(cs-cq) + + dpda = matmul(dppda, dpdpp) + drda = matmul(dpda, dkpdp) + + dpdc = matmul(dppdc, dpdpp) + drdc = matmul(dpdc, dkpdp) + + dpdx = matmul(dppdx, dpdpp) + drdx = -(matmul(dpdx, dkpdp) - dkpdv) + + J_a = J_a + matmul(drda, J_r) + J_x = matmul(drdx, J_r) + J_c = J_c + matmul(drdc, J_r) + J_b = -(J_a+J_c+J_x) + + end subroutine + + subroutine torsion_angle_jacobian(ca, cb, cc, cd, thet, & + J_a, J_b, J_c, J_d) + !! Computes the Jacobian matrix for torsion angle defined by points + !! \(\vec{A}\), \(\vec{B}\), \(\vec{C}\) and \(\vec{D}\) (connected in + !! this order). The angle is defined as follow: + !! \[ \vec{U} = (\vec{B} - \vec{C}) \times (\vec{D} - \vec{C}) \\ + !! \vec{T} = (\vec{B} - \vec{A}) \times (\vec{B} - \vec{C}) \\ + !! cos(\theta) = \vec{U} \cdot \vec{T} + !! \] + !! Applying the chain rule: + !! \[J_a = \frac{\partial \theta}{\partial \vec{A}} + !! = -\frac{1}{\sqrt{1-\theta^2}} + !! \frac{\partial cos(\theta)}{\partial \vec{A}} + !! = -\frac{1}{\sqrt{1-\theta^2}} + !! \frac{\partial \vec{U} \cdot \vec{T}}{\partial \vec{A}} \\ + !! = -\frac{1}{\sqrt{1-\theta^2}} + !! \frac{\partial (\vec{B} - \vec{A})}{\partial \vec{A}} \times + !! \frac{\partial \vec{T}}{\partial (\vec{B} - \vec{A})} \times + !! \frac{\partial \hat{T}}{\partial \vec{T}} \times \vec{U} \\ + !! = -\frac{1}{\sqrt{1-\theta^2}} + !! (- \mathbb{I}_3) \times + !! skw(B-C) \times + !! \frac{\partial \hat{T}}{\partial \vec{T}} \times \vec{U} + !! \] + !! \[J_d = \frac{\partial \theta}{\partial \vec{D}} = + !! = -\frac{1}{\sqrt{1-\theta^2}} + !! \mathbb{I}_3 \times (-skw(B-C)) \times + !! \frac{\partial \hat{U}}{\partial \vec{U}} \times \vec{T} + !! \] + use mod_utils, only: cross_product, vec_skw, versor_der + use mod_constants, only: pi, eps_rp + + implicit none + + real(rp), intent(inout), dimension(3) :: ca, cb, cc, cd + !! Coordinates of the atoms defining the angle + real(rp), intent(out), dimension(3) :: J_a, J_b, J_c, J_d + !! The Jacobian components on atoms a, b and c and d respectively + real(rp), intent(out) :: thet + !! The torsion angle + + real(rp), dimension(3) :: a_b, c_d, c_b, t, u, ht, hu + real(rp), dimension(3,3) :: dhudu, dhtdt, dtda, dudd, dhudd, dhtda, & + dhudb, dhtdb, dudb, dtdb, & + dhudc, dtdc, dudc + real(rp) :: costhet, dacost, s + + a_b = cb - ca + c_d = cd - cc + c_b = cb - cc + + t = cross_product(a_b,c_b) + ht = t / norm2(t) + + u = cross_product(c_b,c_d) + hu = u / norm2(u) + + costhet = dot_product(hu,ht) + if(costhet + 1.0 <= eps_rp) then + thet = pi + dacost = -1.0 / sin(costhet) + else if(abs(costhet - 1.0) <= eps_rp) then + thet = 0.0 + dacost = -1.0 / sin(costhet) + else + thet = acos(costhet) + dacost = - 1.0/sqrt(1.0-costhet**2) + end if + + s = sign(1.0_rp, -dot_product(a_b, u)) + thet = thet * s + + dacost = dacost * s + + dhtdt = versor_der(t) + dhudu = versor_der(u) + + dtda = vec_skw(c_b) + dudd = dtda + + dhtda = matmul(dtda, dhtdt) + J_a = -dacost * matmul(dhtda,hu) + + + dudb = vec_skw(c_d) + dtdb = vec_skw(ca-cc) + + dhudb = matmul(dudb, dhudu) + dhtdb = matmul(dtdb, dhtdt) + J_b = dacost * (matmul(dhudb,ht) + matmul(dhtdb,hu)) + + dtdc = vec_skw(a_b) + dudc = vec_skw(cb - cd) + + dhtdb = matmul(dtdc, dhtdt) + dhudc = matmul(dudc, dhudu) + J_c = dacost * (matmul(dhudc,ht) + matmul(dhtdb,hu)) + + dhudd = matmul(dudd, dhudu) + J_d = -dacost * matmul(dhudd,ht) + + end subroutine + + subroutine opb_angle_jacobian(ca, cb, cc, cd, thet, & + J_a, J_b, J_c, J_d) + use mod_utils, only: cross_product, vec_skw, versor_der + use mod_constants, only: pi, eps_rp + + implicit none + + real(rp), intent(inout), dimension(3) :: ca, cb, cc, cd + !! Coordinates of the atoms defining the angle + real(rp), intent(out), dimension(3) :: J_a, J_b, J_c, J_d + !! The Jacobian components on atoms a, b and c and d respectively + real(rp), intent(out) :: thet + !! The out-of-plane angle + + real(rp), dimension(3) :: a_b, a_c, v, p, hp, hv + real(rp), dimension(3,3) :: dhpdp, dhvdv, & + dhpdb, dpdb, dhpdc, dpdc, dvdd + real(rp) :: costhet, dacost, thet0 + + a_b = ca - cb + a_c = ca - cc + v = ca - cd + + p = cross_product(a_b,a_c) + + hp = p / norm2(p) + hv = v / norm2(v) + + costhet = dot_product(hv, hp) + if(costhet + 1.0 <= eps_rp) then + thet0 = pi + else + thet0 = acos(costhet) + end if + + thet = abs(pi/2.0 - thet0) + dacost = 1.0/sqrt(1.0-costhet**2) + if(pi/2.0 - thet0 < 0.0) dacost = -dacost + + dhpdp = versor_der(p) + dhvdv = versor_der(v) + + dpdb = vec_skw(a_c) + dhpdb = matmul(dpdb,dhpdp) + J_b = -dacost * matmul(dhpdb,hv) + + dpdc = vec_skw(a_b) + dpdc = -dpdc + dhpdc = matmul(dpdc, dhpdp) + J_c = -dacost * matmul(dhpdc,hv) + + dvdd = -dhvdv + J_d = dacost * matmul(dvdd,hp) + + J_a = -(J_b + J_c +J_d) + end subroutine + + subroutine pitors_angle_jacobian(ca, cb, cc, cd, ce, cf, thet, & + J_a, J_b, J_c, J_d, J_e, J_f) + use mod_utils, only: cross_product, vec_skw, versor_der + + implicit none + + real(rp), dimension(3), intent(inout) :: ca, cb, cc, cd, ce, cf + real(rp), intent(out) :: thet + real(rp), dimension(3), intent(out) :: J_a, J_b, J_c, J_d, J_e, J_f + + real(rp), dimension(3) :: d_b, c_b, f_a, e_a, s, p, r, t, ht, u, hu + real(rp) :: costhet, dcosthet + + real(rp), dimension(3,3) :: skw_s, dhtdt, dhudu, & + skw_c_b, skw_d_b, skw_f_a, skw_e_a, & + skw_r, skw_p, dpdb, dtdb + real(rp), dimension(3) :: dcostdp, dcostdr, dcostdt, dcostdu + + d_b = cd - cb + c_b = cc - cb + f_a = cf - ca + e_a = ce - ca + s = cb - ca + p = cross_product(d_b, c_b) + r = cross_product(f_a, e_a) + + t = cross_product(p, s) + ht = t / norm2(t) + u = cross_product(s, r) + hu = u / norm2(u) + + costhet = dot_product(hu, ht) + thet = acos(costhet) + dcosthet = - 1.0 / sqrt(1.0 - costhet**2) + + skw_s = vec_skw(s) + skw_r = vec_skw(r) + skw_p = vec_skw(p) + + dhudu = versor_der(u) + dhtdt = versor_der(t) + + dcostdt = matmul(dhtdt, hu) + dcostdu = matmul(dhudu, ht) + + dcostdp = matmul(skw_s, dcostdt) + dcostdr = -matmul(skw_s, dcostdu) + + skw_c_b = vec_skw(c_b) + skw_d_b = vec_skw(d_b) + skw_e_a = vec_skw(e_a) + skw_f_a = vec_skw(f_a) + + dpdb = skw_d_b - skw_c_b + dtdb = matmul(dpdb, skw_s) - skw_p + + J_b = dcosthet * (matmul(skw_r, dcostdu) + matmul(dtdb, dcostdt)) + J_c = dcosthet * (-matmul(skw_d_b, dcostdp)) + J_d = dcosthet * (matmul(skw_c_b, dcostdp)) + J_e = dcosthet * (-matmul(skw_f_a, dcostdr)) + J_f = dcosthet * (matmul(skw_e_a, dcostdr)) + + J_a = -(J_b + J_c + J_d + J_e + J_f) + end subroutine +end module mod_jacobian_mat diff --git a/src/mod_jacobian_mat.f90 b/src/mod_jacobian_mat.f90 deleted file mode 100644 index 31eb965..0000000 --- a/src/mod_jacobian_mat.f90 +++ /dev/null @@ -1,386 +0,0 @@ -module mod_jacobian_mat - use mod_memory, only: rp, ip - implicit none - private - - public :: Rij_jacobian - public :: simple_angle_jacobian, inplane_angle_jacobian, & - torsion_angle_jacobian, opb_angle_jacobian, & - pitors_angle_jacobian - - contains - - pure subroutine Rij_jacobian(ci, cj, Rij, J_i, J_j) - !! Compute the Jacobian matrix of distance - !! Rij = sqrt((ci(_x_)-cj(_x_))**2 + (ci(_y_)-cj(_y_))**2 + (ci(_z_)-cj(_z_))**2) - !! Derivatives wrt ci(:) are saved in J_i and wrt cj(:) in J_j; the - !! distance between the two points is also provided in output in Rij. - - implicit none - - real(rp), intent(in) :: ci(3), cj(3) - real(rp), intent(out) :: Rij, J_i(3), J_j(3) - integer(ip) :: i - - Rij = norm2(ci-cj) - do i=1, 3 - J_i(i) = (ci(i) - cj(i))/Rij - J_j(i) = -J_i(i) - end do - end subroutine - - pure subroutine simple_angle_jacobian(ca, cb, cc, thet, J_a, J_b, J_c) - implicit none - - real(rp), intent(in), dimension(3) :: ca, cb, cc - !! Coordinates of the atoms defining the angle - real(rp), intent(out), dimension(3) :: J_a, J_b, J_c - !! The Jacobian components on atoms a, b and c respectively - real(rp), intent(out) :: thet - !! The angle (in rad) defined by ca-cb-cc - - real(rp), dimension(3) :: dr1, dr2 - real(rp) :: l1, l2, dr1_d_dr2, acosd, cost - integer(ip) :: i - - dr1 = ca - cb - dr2 = cc - cb - dr1_d_dr2 = dot_product(dr1, dr2) - l1 = norm2(dr1) - l2 = norm2(dr2) - cost = dr1_d_dr2/(l1*l2) - thet = acos(cost) - acosd = 1.0 / sqrt(1.0 - cost**2) - - do i=1,3 - J_a(i) = -acosd * (dr2(i) * l1 - dr1(i) * dr1_d_dr2 / l1) / (l1**2*l2) - J_c(i) = -acosd * (dr1(i) * l2 - dr2(i) * dr1_d_dr2 / l2) / (l1*l2**2) - J_b(i) = -(J_a(i) + J_c(i)) - end do - end subroutine - - pure subroutine inplane_angle_jacobian(ca, cb, cc, cx, thet, & - J_a, J_b, J_c, J_x) - !! Computes the Jacobian matrix for the inplane angle definition. - !! It computes the Jacobian for the normal angle using the projected - !! point (R) as central point. Then projects - !! \(J_r = \frac{\partial \theta}{\partial \vec{R}} \) onto A, B, C, and X - !! (auxiliary point). The projection is done computing the 3x3 matrices - !! of partial derivative of \(\vec{R}\) wrt any actual point and using - !! them to project \(J_r\). - !! \[\frac{\partial \vec{R}}{\partial \vec{A}} = - !! \begin{bmatrix} - !! \frac{\partial \vec{R}_x}{\partial \vec{A}_x} & - !! \frac{\partial \vec{R}_y}{\partial \vec{A}_x} & - !! \frac{\partial \vec{R}_z}{\partial \vec{A}_x} \\ - !! \frac{\partial \vec{R}_x}{\partial \vec{A}_y} & - !! \frac{\partial \vec{R}_y}{\partial \vec{A}_y} & - !! \frac{\partial \vec{R}_z}{\partial \vec{A}_y} \\ - !! \frac{\partial \vec{R}_x}{\partial \vec{A}_z} & - !! \frac{\partial \vec{R}_y}{\partial \vec{A}_z} & - !! \frac{\partial \vec{R}_z}{\partial \vec{A}_z} \\ - !! \end{bmatrix} \] - !! Those matrices are computed using the chain rule. - !! - !! Exemple: - !! \[\vec{V} = \vec{B} - \vec{X}\] - !! \[\vec{P} = (\vec{A} - \vec{X}) \times (\vec{C} - \vec{X})\] - !! \[\hat{P} = \frac{\vec{P}}{||\vec{P}||}\] - !! \[\vec{R} = \vec{B} - (\vec{V}\cdot\hat{P})\hat{P}\] - !! \[J_a = \frac{\partial \theta}{\partial \vec{A}} - !! = \left( \frac{\partial \theta}{\partial \vec{A}} \right)_\vec{R} + - !! \frac{\partial \vec{R}}{\partial \vec{A}} \times - !! J_r - !! = \left( \frac{\partial \theta}{\partial \vec{A}} \right)_\vec{R} + - !! - \frac{\partial \vec{P}}{\partial \vec{A}} \times - !! \frac{\partial \hat{P}}{\partial \vec{P}} \times - !! \frac{\partial (\vec{V} \cdot \hat{P})}{\partial \hat{P}} \times - !! J_r - !! \] - use mod_utils, only: cross_product, vec_skw, versor_der - - implicit none - - real(rp), intent(in), dimension(3) :: ca, cb, cc, cx - !! Coordinates of the atoms defining the angle - real(rp), intent(out), dimension(3) :: J_a, J_b, J_c, J_x - !! The Jacobian components on atoms a, b and c respectively - real(rp), intent(out) :: thet - !! The angle (in rad) defined by ca-cb-cc - - real(rp), dimension(3) :: cr, cv, cp, cpp, cq, cs, J_r - real(rp), dimension(3,3) :: drda, drdc, drdx, dkpdp, dppda, & - dpdpp, dpda, dpdc, dppdc, dpdx, dppdx, & - dkpdv - real(rp) :: k - integer(ip) :: i - - cq = ca - cx - cs = cc - cx - cv = cb - cx - - cpp = cross_product(cq, cs) - cp = cpp / norm2(cpp) - - k = dot_product(cv, cp) - cr = cb - k * cp - - call simple_angle_jacobian(ca, cr, cc, thet, J_a, J_r, J_c) - - do i=1,3 - dkpdp(i,:) = cv(i) * cp - dkpdp(i,i) = dkpdp(i,i) + k - end do - - dpdpp = versor_der(cpp) - - do i=1,3 - dkpdv(i,:) = cp(i) * cp - end do - - dppda = -vec_skw(cs) - dppdc = vec_skw(cq) - - dppdx = -vec_skw(cs-cq) - - dpda = matmul(dppda, dpdpp) - drda = matmul(dpda, dkpdp) - - dpdc = matmul(dppdc, dpdpp) - drdc = matmul(dpdc, dkpdp) - - dpdx = matmul(dppdx, dpdpp) - drdx = -(matmul(dpdx, dkpdp) - dkpdv) - - J_a = J_a + matmul(drda, J_r) - J_x = matmul(drdx, J_r) - J_c = J_c + matmul(drdc, J_r) - J_b = -(J_a+J_c+J_x) - - end subroutine - - subroutine torsion_angle_jacobian(ca, cb, cc, cd, thet, & - J_a, J_b, J_c, J_d) - !! Computes the Jacobian matrix for torsion angle defined by points - !! \(\vec{A}\), \(\vec{B}\), \(\vec{C}\) and \(\vec{D}\) (connected in - !! this order). The angle is defined as follow: - !! \[ \vec{U} = (\vec{B} - \vec{C}) \times (\vec{D} - \vec{C}) \\ - !! \vec{T} = (\vec{B} - \vec{A}) \times (\vec{B} - \vec{C}) \\ - !! cos(\theta) = \vec{U} \cdot \vec{T} - !! \] - !! Applying the chain rule: - !! \[J_a = \frac{\partial \theta}{\partial \vec{A}} - !! = -\frac{1}{\sqrt{1-\theta^2}} - !! \frac{\partial cos(\theta)}{\partial \vec{A}} - !! = -\frac{1}{\sqrt{1-\theta^2}} - !! \frac{\partial \vec{U} \cdot \vec{T}}{\partial \vec{A}} \\ - !! = -\frac{1}{\sqrt{1-\theta^2}} - !! \frac{\partial (\vec{B} - \vec{A})}{\partial \vec{A}} \times - !! \frac{\partial \vec{T}}{\partial (\vec{B} - \vec{A})} \times - !! \frac{\partial \hat{T}}{\partial \vec{T}} \times \vec{U} \\ - !! = -\frac{1}{\sqrt{1-\theta^2}} - !! (- \mathbb{I}_3) \times - !! skw(B-C) \times - !! \frac{\partial \hat{T}}{\partial \vec{T}} \times \vec{U} - !! \] - !! \[J_d = \frac{\partial \theta}{\partial \vec{D}} = - !! = -\frac{1}{\sqrt{1-\theta^2}} - !! \mathbb{I}_3 \times (-skw(B-C)) \times - !! \frac{\partial \hat{U}}{\partial \vec{U}} \times \vec{T} - !! \] - use mod_utils, only: cross_product, vec_skw, versor_der - use mod_constants, only: pi, eps_rp - - implicit none - - real(rp), intent(inout), dimension(3) :: ca, cb, cc, cd - !! Coordinates of the atoms defining the angle - real(rp), intent(out), dimension(3) :: J_a, J_b, J_c, J_d - !! The Jacobian components on atoms a, b and c and d respectively - real(rp), intent(out) :: thet - !! The torsion angle - - real(rp), dimension(3) :: a_b, c_d, c_b, t, u, ht, hu - real(rp), dimension(3,3) :: dhudu, dhtdt, dtda, dudd, dhudd, dhtda, & - dhudb, dhtdb, dudb, dtdb, & - dhudc, dtdc, dudc - real(rp) :: costhet, dacost, s - - a_b = cb - ca - c_d = cd - cc - c_b = cb - cc - - t = cross_product(a_b,c_b) - ht = t / norm2(t) - - u = cross_product(c_b,c_d) - hu = u / norm2(u) - - costhet = dot_product(hu,ht) - if(costhet + 1.0 <= eps_rp) then - thet = pi - dacost = -1.0 / sin(costhet) - else if(abs(costhet - 1.0) <= eps_rp) then - thet = 0.0 - dacost = -1.0 / sin(costhet) - else - thet = acos(costhet) - dacost = - 1.0/sqrt(1.0-costhet**2) - end if - - s = sign(1.0_rp, -dot_product(a_b, u)) - thet = thet * s - - dacost = dacost * s - - dhtdt = versor_der(t) - dhudu = versor_der(u) - - dtda = vec_skw(c_b) - dudd = dtda - - dhtda = matmul(dtda, dhtdt) - J_a = -dacost * matmul(dhtda,hu) - - - dudb = vec_skw(c_d) - dtdb = vec_skw(ca-cc) - - dhudb = matmul(dudb, dhudu) - dhtdb = matmul(dtdb, dhtdt) - J_b = dacost * (matmul(dhudb,ht) + matmul(dhtdb,hu)) - - dtdc = vec_skw(a_b) - dudc = vec_skw(cb - cd) - - dhtdb = matmul(dtdc, dhtdt) - dhudc = matmul(dudc, dhudu) - J_c = dacost * (matmul(dhudc,ht) + matmul(dhtdb,hu)) - - dhudd = matmul(dudd, dhudu) - J_d = -dacost * matmul(dhudd,ht) - - end subroutine - - subroutine opb_angle_jacobian(ca, cb, cc, cd, thet, & - J_a, J_b, J_c, J_d) - use mod_utils, only: cross_product, vec_skw, versor_der - use mod_constants, only: pi, eps_rp - - implicit none - - real(rp), intent(inout), dimension(3) :: ca, cb, cc, cd - !! Coordinates of the atoms defining the angle - real(rp), intent(out), dimension(3) :: J_a, J_b, J_c, J_d - !! The Jacobian components on atoms a, b and c and d respectively - real(rp), intent(out) :: thet - !! The out-of-plane angle - - real(rp), dimension(3) :: a_b, a_c, v, p, hp, hv - real(rp), dimension(3,3) :: dhpdp, dhvdv, & - dhpdb, dpdb, dhpdc, dpdc, dvdd - real(rp) :: costhet, dacost, thet0 - - a_b = ca - cb - a_c = ca - cc - v = ca - cd - - p = cross_product(a_b,a_c) - - hp = p / norm2(p) - hv = v / norm2(v) - - costhet = dot_product(hv, hp) - if(costhet + 1.0 <= eps_rp) then - thet0 = pi - else - thet0 = acos(costhet) - end if - - thet = abs(pi/2.0 - thet0) - dacost = 1.0/sqrt(1.0-costhet**2) - if(pi/2.0 - thet0 < 0.0) dacost = -dacost - - dhpdp = versor_der(p) - dhvdv = versor_der(v) - - dpdb = vec_skw(a_c) - dhpdb = matmul(dpdb,dhpdp) - J_b = -dacost * matmul(dhpdb,hv) - - dpdc = vec_skw(a_b) - dpdc = -dpdc - dhpdc = matmul(dpdc, dhpdp) - J_c = -dacost * matmul(dhpdc,hv) - - dvdd = -dhvdv - J_d = dacost * matmul(dvdd,hp) - - J_a = -(J_b + J_c +J_d) - end subroutine - - subroutine pitors_angle_jacobian(ca, cb, cc, cd, ce, cf, thet, & - J_a, J_b, J_c, J_d, J_e, J_f) - use mod_utils, only: cross_product, vec_skw, versor_der - - implicit none - - real(rp), dimension(3), intent(inout) :: ca, cb, cc, cd, ce, cf - real(rp), intent(out) :: thet - real(rp), dimension(3), intent(out) :: J_a, J_b, J_c, J_d, J_e, J_f - - real(rp), dimension(3) :: d_b, c_b, f_a, e_a, s, p, r, t, ht, u, hu - real(rp) :: costhet, dcosthet - - real(rp), dimension(3,3) :: skw_s, dhtdt, dhudu, & - skw_c_b, skw_d_b, skw_f_a, skw_e_a, & - skw_r, skw_p, dpdb, dtdb - real(rp), dimension(3) :: dcostdp, dcostdr, dcostdt, dcostdu - - d_b = cd - cb - c_b = cc - cb - f_a = cf - ca - e_a = ce - ca - s = cb - ca - p = cross_product(d_b, c_b) - r = cross_product(f_a, e_a) - - t = cross_product(p, s) - ht = t / norm2(t) - u = cross_product(s, r) - hu = u / norm2(u) - - costhet = dot_product(hu, ht) - thet = acos(costhet) - dcosthet = - 1.0 / sqrt(1.0 - costhet**2) - - skw_s = vec_skw(s) - skw_r = vec_skw(r) - skw_p = vec_skw(p) - - dhudu = versor_der(u) - dhtdt = versor_der(t) - - dcostdt = matmul(dhtdt, hu) - dcostdu = matmul(dhudu, ht) - - dcostdp = matmul(skw_s, dcostdt) - dcostdr = -matmul(skw_s, dcostdu) - - skw_c_b = vec_skw(c_b) - skw_d_b = vec_skw(d_b) - skw_e_a = vec_skw(e_a) - skw_f_a = vec_skw(f_a) - - dpdb = skw_d_b - skw_c_b - dtdb = matmul(dpdb, skw_s) - skw_p - - J_b = dcosthet * (matmul(skw_r, dcostdu) + matmul(dtdb, dcostdt)) - J_c = dcosthet * (-matmul(skw_d_b, dcostdp)) - J_d = dcosthet * (matmul(skw_c_b, dcostdp)) - J_e = dcosthet * (-matmul(skw_f_a, dcostdr)) - J_f = dcosthet * (matmul(skw_e_a, dcostdr)) - - J_a = -(J_b + J_c + J_d + J_e + J_f) - end subroutine -end module mod_jacobian_mat diff --git a/src/mod_link_atom.F90 b/src/mod_link_atom.F90 new file mode 100644 index 0000000..757b617 --- /dev/null +++ b/src/mod_link_atom.F90 @@ -0,0 +1,824 @@ +#define _MM_ 1 +#define _QM_ 2 +#define _LA_ 3 + +module mod_link_atom + + use mod_memory, only: rp, ip, lp, mallocate, mfree + use mod_topology, only: ommp_topology_type + use mod_constants, only: angstrom2au, default_link_atom_dist, & + default_link_atom_n_eel_remove + use mod_nonbonded, only: vdw_geomgrad_inter + use mod_bonded, only: ommp_bonded_type + use mod_io, only: large_file_read + use mod_utils, only: str_to_lower, str_uncomment + + implicit none + private + + integer(ip), parameter :: link_atom_allocation_chunk = 20 + + type ommp_link_atom_type + type(ommp_topology_type), pointer :: mmtop + !! Topology of MM part of the system + type(ommp_topology_type), pointer :: qmtop + !! Topology of QM part of the system + type(ommp_topology_type), allocatable :: qmmmtop + !! Linked QM/MM topology + integer(ip), allocatable :: mm2full(:), qm2full(:) + !! Maps from qm and mm systems to full topology indexes + integer(ip) :: nla + !! Number of link atoms + integer(ip), allocatable :: links(:,:) + !! Indexes of link-involved atoms: + !! links(_MM_,:) contains the index of MM atom in mmtop + !! links(_QM_,:) contains the index of QM atom in qmtop + !! links(_LA_,:) contains the index of link atom in qmtop + real(rp), allocatable :: la_distance(:) + !! Distance of link atom from QM atom + integer(ip), allocatable :: vdw_screening_pairs(:,:) + !! Pairs of vdw interactions that should be screened + real(rp), allocatable :: vdw_screening_f(:) + !! Screening factors for each vdw pair + integer(ip) :: vdw_n_screening + !! Number of screening vdw to be used + type(ommp_bonded_type), allocatable :: bds + end type + + public :: ommp_link_atom_type, init_link_atom, add_link_atom + public :: link_atom_position, init_vdw_for_link_atom, init_bonded_for_link_atom + public :: init_eel_for_link_atom + public :: default_link_atom_dist, default_link_atom_n_eel_remove, link_atom_update_merged_topology + public :: link_atom_bond_geomgrad, link_atom_angle_geomgrad, link_atom_torsion_geomgrad, & + link_atom_project_grd + +contains + subroutine init_link_atom(la, qmtop, mmtop) + use mod_topology, only: merge_top + use mod_constants, only: OMMP_VERBOSE_LOW + use mod_io, only: ommp_message + + implicit none + + type(ommp_link_atom_type), intent(inout) :: la + type(ommp_topology_type), intent(in), target :: qmtop, mmtop + + call mallocate('init_linkatoms [links]', & + 3, link_atom_allocation_chunk, & + la%links) + call mallocate('init_linkatoms [la_distance]', & + link_atom_allocation_chunk, la%la_distance) + call mallocate('init_linkatoms [vdw_screening_f]', & + link_atom_allocation_chunk, la%vdw_screening_f) + call mallocate('init_linkatoms [vdw_screening_pairs]', 2, & + link_atom_allocation_chunk, la%vdw_screening_pairs) + + la%nla = 0 + la%vdw_n_screening = 0 + la%qmtop => qmtop + la%mmtop => mmtop + + call ommp_message("Creating merged topology", OMMP_VERBOSE_LOW, 'linkatom') + allocate(la%qmmmtop) + call merge_top(la%mmtop, la%qmtop, la%qmmmtop, la%mm2full, la%qm2full) + allocate(la%bds) + end subroutine + + subroutine link_atom_update_merged_topology(la) + !! Update merged topology in linkatom object so that its coordinates + !! are the same of mmtop and qmtop. + implicit none + + type(ommp_link_atom_type), intent(inout) :: la + + integer(ip) :: i + + do i=1, la%mmtop%mm_atoms + la%qmmmtop%cmm(:,la%mm2full(i)) = la%mmtop%cmm(:,i) + end do + + do i=1, la%qmtop%mm_atoms + la%qmmmtop%cmm(:,la%qm2full(i)) = la%qmtop%cmm(:,i) + end do + end subroutine + + subroutine add_link_atom(la, imm, iqm, ila, la_dist) + use mod_constants, only: OMMP_STR_CHAR_MAX, OMMP_VERBOSE_LOW + use mod_io, only: ommp_message + use mod_topology, only: create_new_bond + + implicit none + + type(ommp_link_atom_type), intent(inout) :: la + integer(ip), intent(in) :: imm + integer(ip), intent(in) :: iqm + integer(ip), intent(in) :: ila + real(rp), intent(in) :: la_dist + + integer(ip), allocatable :: tmp(:,:) + real(rp), allocatable :: rtmp(:) + integer(ip) :: nmax + character(len=OMMP_STR_CHAR_MAX) :: message + + nmax = size(la%links, 2) + if(la%nla + 1 > nmax) then + ! Reallocate links to accomodate new link atoms + call mallocate('create_link_atom [tmp]', 3, nmax, tmp) + call mallocate('create_link_atom [rtmp]', nmax, rtmp) + tmp = la%links + rtmp = la%la_distance + call mfree('create_link_atom [la%links]', la%links) + call mallocate('create_link_atom [la%links]', 3, nmax+link_atom_allocation_chunk, la%links) + call mfree('create_link_atom [la%la_distance]', la%la_distance) + call mallocate('create_link_atom [la%la_distance]', nmax+link_atom_allocation_chunk, la%la_distance) + la%links = tmp(:,0:nmax) + la%la_distance = rtmp(0:nmax) + call mfree('create_link_atom [tmp]', tmp) + call mfree('create_link_atom [rtmp]', rtmp) + end if + ! 0.2. Link atom creation and positioning + la%nla = la%nla + 1 + la%links(_MM_, la%nla) = imm + la%links(_QM_, la%nla) = iqm + la%links(_LA_, la%nla) = ila + la%la_distance(la%nla) = la_dist + + if(la%qmmmtop%frozen(la%qm2full(iqm)) .and. la%qmmmtop%frozen(la%mm2full(imm))) then + ! if QM atom and MM atoms are frozen, also LA is frozen + la%qmmmtop%frozen(la%qm2full(ila)) = .true. + end if + call create_new_bond(la%qmmmtop, la%mm2full(imm), la%qm2full(iqm)) + + write(message, "(A, I0, A, I0, A, I0, A)") & + "Created link atom MM [", imm, & + "] - (LA) [", ila, "] - QM [", iqm, "]" + + call ommp_message(message, OMMP_VERBOSE_LOW, 'linkatom') + end subroutine + + subroutine init_eel_for_link_atom(la, imm, ila, eel, prmfile) + use mod_memory, only: mallocate, mfree + use mod_prm, only: assign_mpoles + use mod_electrostatics, only: ommp_electrostatics_type, & + electrostatics_init, & + remove_null_pol + use mod_io, only: fatal_error, ommp_message + use mod_constants, only: eps_rp, OMMP_VERBOSE_LOW, & + OMMP_STR_CHAR_MAX, & + OMMP_VERBOSE_DEBUG + + implicit none + + integer(ip), intent(in) :: imm + integer(ip), intent(in) :: ila + type(ommp_link_atom_type), intent(in) :: la + type(ommp_electrostatics_type), intent(inout) :: eel + character(len=*), intent(in) :: prmfile + + real(rp) :: removed_charge, qred, old_q, lastq + integer(ip) :: n_eel_remove = default_link_atom_n_eel_remove + integer(ip) :: ist, i, j, idx, ii + type(ommp_electrostatics_type) :: tmp_eel + character(len=OMMP_STR_CHAR_MAX) :: msg + character(len=OMMP_STR_CHAR_MAX), allocatable :: prm_buf(:) + integer(ip), allocatable :: attocheck(:) + + ! Check if in the complete topology some of the atoms connected + ! to imm or imm itself do change their parameters. This is a + ! problem that affects force-field in which parameters are + ! assigned based on connectivity (AMOEBA). In particular we + ! check only 1,2 and 1,3 neighbours of QM atom that are the ones + ! that could be influenced by the new bond. Moreover we only + ! take care of charges, as multipoles will be removed on those + ! atoms in a while. + + call mallocate('init_eel_for_link_atom [attocheck]', & + eel%top%conn(1)%ri(imm+1) - eel%top%conn(1)%ri(imm)+1, & + attocheck) + attocheck(1) = imm + ii = 2 + do i=eel%top%conn(1)%ri(imm), eel%top%conn(1)%ri(imm+1)-1 + j = eel%top%conn(1)%ci(i) + attocheck(ii) = j + ii = ii + 1 + end do + write(msg, "(A, I0, A)") "Assigning electrostatic parameter to merged& + & topology. Ignore all the warnings on & + &link atom (", la%qm2full(ila), ")." + call ommp_message(msg, OMMP_VERBOSE_LOW, 'linkatom') + + call electrostatics_init(tmp_eel, eel%amoeba, la%qmmmtop%mm_atoms, & + la%qmmmtop) + + call large_file_read(prmfile, prm_buf) + ! Remove comments from prm file + !$omp parallel do + do i=1, size(prm_buf) + prm_buf(i) = str_to_lower(prm_buf(i)) + prm_buf(i) = str_uncomment(prm_buf(i), '!') + end do + + call assign_mpoles(tmp_eel, prm_buf) + deallocate(prm_buf) + + do i=1, size(attocheck) + j = attocheck(i) + if(abs(tmp_eel%q(1,la%mm2full(j)) - eel%q(1,j)) > eps_rp) then + write(msg, "(A, I0)") "Reassigning electrostatic parameter to& + & atom ", j + call ommp_message(msg, OMMP_VERBOSE_LOW, 'linkatom') + write(msg, '(" Old parameters: q=", F6.2)') eel%q(1,j) + call ommp_message(msg, OMMP_VERBOSE_DEBUG, 'linkatom') + write(msg, '(" New parameters: q=", F6.2)') tmp_eel%q(1,la%mm2full(j)) + call ommp_message(msg, OMMP_VERBOSE_DEBUG, 'linkatom') + if(eel%amoeba) then + eel%q0(:,j) = tmp_eel%q(:,la%mm2full(j)) + else + eel%q(:,j) = tmp_eel%q(:,la%mm2full(j)) + end if + end if + end do + call mfree('init_eel_for_link_atom [attocheck]', attocheck) + + ! Remove dipoles, multipoles, charges and polarizabilities + ! on all the atoms that have a distance from (QM) atom less or equal to + ! n_eel_remove. If n_eel_remove is 0, the MM electrostatic is not changed; + ! if n_eel_remove is 1, only the connected atom is removed and so on. + ! Removed charges is distributed to all the atoms 1 bond further away. + + if(n_eel_remove > 0) then + if(n_eel_remove < 2) then + call fatal_error("Electrostatic interaction should be removed at least on 1,2 and & + &1,3 neighbour of linked QM atom") + end if + + if(eel%amoeba) then + old_q = sum(eel%q0(1,:)) + else + old_q = sum(eel%q(1,:)) + end if + removed_charge = 0.0 + + if(n_eel_remove > size(la%mmtop%conn)) then + call fatal_error("Connectivity rebuild is not implemented in link atom") + end if + + ! Remove charges, multipoles and polarizabilities + if(eel%amoeba) then + removed_charge = removed_charge + eel%q0(1,imm) + lastq = eel%q0(1,imm) + eel%q0(:,imm) = 0.0 + if(eel%mm_polar(imm) > 0) & + eel%pol(eel%mm_polar(imm)) = 0.0 + else + removed_charge = removed_charge + eel%q(1,imm) + lastq = eel%q(1,imm) + eel%q(:,imm) = 0.0 + + if(eel%mm_polar(imm) > 0) & + eel%pol(eel%mm_polar(imm)) = 0.0 + end if + write(msg, '("Removed charge, multipoles and polarizabilities on atom ", I0, "[q=", F6.3, "]")') imm, lastq + call ommp_message(msg, OMMP_VERBOSE_LOW, 'linkatom') + + do i=1, n_eel_remove-1 + do j=eel%top%conn(i)%ri(imm), eel%top%conn(i)%ri(imm+1)-1 + idx = eel%top%conn(i)%ci(j) + if(eel%amoeba) then + removed_charge = removed_charge + eel%q0(1,idx) + lastq = eel%q0(1,idx) + eel%q0(:,idx) = 0.0 + if(eel%mm_polar(idx) > 0) & + eel%pol(eel%mm_polar(idx)) = 0.0 + else + removed_charge = removed_charge + eel%q(1,idx) + lastq = eel%q(1,idx) + eel%q(:,idx) = 0.0 + if(eel%mm_polar(idx) > 0) & + eel%pol(eel%mm_polar(idx)) = 0.0 + end if + write(msg, '("Removed charge, multipoles and polarizabilities on atom ", I0, "[q=", F6.3, "]")') idx, lastq + call ommp_message(msg, OMMP_VERBOSE_LOW, 'linkatom') + end do + end do + + ! Redistribute removed charge to preserve neutrality + qred = removed_charge / (eel%top%conn(n_eel_remove)%ri(imm+1) - eel%top%conn(i)%ri(imm)) + + do j=eel%top%conn(n_eel_remove)%ri(imm), & + eel%top%conn(n_eel_remove)%ri(imm+1)-1 + idx = eel%top%conn(n_eel_remove)%ci(j) + if(eel%amoeba) then + eel%q0(1,idx) = eel%q0(1,idx) + qred + else + eel%q(1,idx) = eel%q(1,idx) + qred + end if + write(msg, '("Redistributing charge (", F6.3, " A.U.) on atom ", I0)') qred, idx + call ommp_message(msg, OMMP_VERBOSE_LOW, 'linkatom') + end do + end if + + call remove_null_pol(eel) + + eel%M2M_done = .false. + eel%M2Mgg_done = .false. + eel%M2D_done = .false. + eel%M2Dgg_done = .false. + eel%ipd_done = .false. + if(allocated(eel%TMat)) call mfree('update_coordinates [TMat]',eel%TMat) + if(eel%amoeba) call rotate_multipoles(eel) + write(msg, '("Charge of the systems passed from ", F6.3, " to ", F6.3, "A.U.")') & + old_q, sum(eel%q(1,:)) + call ommp_message(msg, OMMP_VERBOSE_LOW, 'linkatom') + + + end subroutine + + subroutine link_atom_position(la, idx, crd) + !! Compute the cartesian coordinates of link atom idx at + !! the current geometry. + implicit none + + type(ommp_link_atom_type), intent(in) :: la + integer(ip), intent(in) :: idx + real(rp), intent(out) :: crd(3) + + real(rp), dimension(3) :: rmm, rqm, dmmqm + + rmm = la%mmtop%cmm(:,la%links(_MM_,idx)) + rqm = la%qmtop%cmm(:,la%links(_QM_,idx)) + dmmqm = rmm-rqm + dmmqm = dmmqm / norm2(dmmqm) + + crd = rqm + la%la_distance(idx) * dmmqm + end subroutine + + subroutine check_vdw_pairs(la, n) + !! Check if n new screening pairs could be allocated + !! in la structure. If the allocated arrays are too + !! small, they are reallocated on-the-fly. + implicit none + + type(ommp_link_atom_type), intent(inout) :: la + integer(ip), intent(in) :: n + + integer(ip), allocatable :: itmp(:,:) + real(rp), allocatable :: rtmp(:) + integer(ip) :: nnew, nold + + nnew = n + la%vdw_n_screening + nold = size(la%vdw_screening_f) + if(nnew > nold) then + call mallocate('check_vdw_pairs [itmp]', 2, nold, itmp) + call mallocate('check_vdw_pairs [rtmp]', nold, rtmp) + itmp = la%vdw_screening_pairs + rtmp = la%vdw_screening_f + call mfree('check_vdw_pairs [vdw_screening_pairs]', la%vdw_screening_pairs) + call mfree('check_vdw_pairs [vdw_screening_f]', la%vdw_screening_f) + + call mallocate('check_vdw_pairs [vdw_screening_pairs]', 2, nnew, la%vdw_screening_pairs) + call mallocate('check_vdw_pairs [vdw_screening_f]', nnew, la%vdw_screening_f) + + la%vdw_screening_pairs(:,:nold) = itmp + la%vdw_screening_f(:nold) = rtmp + + call mfree('check_vdw_pairs [itmp]', itmp) + call mfree('check_vdw_pairs [rtmp]', rtmp) + end if + end subroutine + + subroutine add_screening_pair(la, iqm, imm, s) + use mod_io, only: ommp_message + use mod_constants, only: OMMP_STR_CHAR_MAX, OMMP_VERBOSE_DEBUG + !! Insert a VdW screening pair in the link atom structure + implicit none + + type(ommp_link_atom_type), intent(inout) :: la + integer(ip), intent(in) :: iqm, imm + real(rp), intent(in) :: s + character(len=OMMP_STR_CHAR_MAX) :: message + + ! Just for safety, it should be done elsewhere for all the pairs + ! ones want to insert in the structure. + call check_vdw_pairs(la, 1) + + la%vdw_n_screening = la%vdw_n_screening + 1 + la%vdw_screening_pairs(_QM_, la%vdw_n_screening) = iqm + la%vdw_screening_pairs(_MM_, la%vdw_n_screening) = imm + la%vdw_screening_f(la%vdw_n_screening) = s + write(message, "(A, I0, A, I0, A, F3.2)") & + "Screening VdW interactions between atoms ", imm, " (MM) & + &and ", iqm, "(QM) by a factor ", 1.0 + s + call ommp_message(message, OMMP_VERBOSE_DEBUG, 'linkatom') + + end subroutine + + subroutine init_vdw_for_link_atom(la, iqm, imm, vdw_screening) + !! Initialize the quantities needed for vdw screening due to the + !! presence of a link atom between iqm and imm + use mod_topology, only: check_conn_matrix + use mod_io, only: fatal_error, ommp_message + use mod_constants, only: eps_rp, OMMP_STR_CHAR_MAX, OMMP_VERBOSE_DEBUG + + + implicit none + + type(ommp_link_atom_type), intent(inout) :: la + integer(ip), intent(in) :: iqm, imm + real(rp), intent(in) :: vdw_screening(:) + + integer(ip) :: i, j, ineigh_qm, ineigh_mm, idist, iscr, & + qmneigh(4), mmneigh(4) + real(rp) :: screen + character(len=OMMP_STR_CHAR_MAX) :: message + + ! Check that the connectivity matrices have been built up to the + ! required order. + call check_conn_matrix(la%qmtop, size(vdw_screening)-1) + call check_conn_matrix(la%mmtop, size(vdw_screening)-1) + + ! Count how many interactions should be screened + qmneigh(1) = 1 + mmneigh(1) = 1 + do i=2, size(vdw_screening) + qmneigh(i) = la%qmtop%conn(i-1)%ri(iqm+1) - & + la%qmtop%conn(i-1)%ri(iqm) + mmneigh(i) = la%mmtop%conn(i-1)%ri(imm+1) - & + la%mmtop%conn(i-1)%ri(imm) + end do + + iscr = 0 + do idist=1, size(vdw_screening) + if(abs(vdw_screening(idist) - 1.0) > eps_rp) then + do i=1, idist + iscr = iscr + qmneigh(i) * mmneigh(idist-i+1) + end do + end if + end do + write(message, "(I0, A)") & + iscr, " VdW interactions will be screened due to link atom" + call ommp_message(message, OMMP_VERBOSE_DEBUG, 'linkatom') + + ! Check the allocation of vectors inside link atom structure + call check_vdw_pairs(la, iscr) + + ! Insert the new screened interactions inside link atom structure + do idist=1, size(vdw_screening) + screen = vdw_screening(idist) - 1.0 + if(abs(screen) > eps_rp) then + do ineigh_qm=1, idist + ineigh_mm = idist - ineigh_qm + 1 + if(ineigh_qm == 1) then + if(ineigh_mm == 1) then + call add_screening_pair(la, iqm, imm, screen) + else + do i=la%mmtop%conn(ineigh_mm-1)%ri(imm), & + la%mmtop%conn(ineigh_mm-1)%ri(imm+1) - 1 + call add_screening_pair(la, & + iqm, & + la%mmtop%conn(ineigh_mm-1)%ci(i), & + screen) + end do + end if + else + if(ineigh_mm == 1) then + do i=la%qmtop%conn(ineigh_qm-1)%ri(iqm), & + la%qmtop%conn(ineigh_qm-1)%ri(iqm+1) -1 + call add_screening_pair(la, & + la%qmtop%conn(ineigh_qm-1)%ci(i), & + imm, & + screen) + end do + else + do i=la%mmtop%conn(ineigh_mm-1)%ri(imm), & + la%mmtop%conn(ineigh_mm-1)%ri(imm+1) - 1 + do j=la%qmtop%conn(ineigh_qm-1)%ri(iqm), & + la%qmtop%conn(ineigh_qm-1)%ri(iqm+1) -1 + call add_screening_pair(la, & + la%qmtop%conn(ineigh_qm-1)%ci(j), & + la%mmtop%conn(ineigh_mm-1)%ci(i), & + screen) + end do + end do + end if + end if + end do + end if + end do + + end subroutine + + subroutine init_bonded_for_link_atom(la, prmfile) + !! Insert in the bonded parameter required for the link atom between iqm and imm + use mod_prm, only: assign_bond, assign_angle, assign_torsion + use mod_bonded, only: bonded_terminate, & + bond_init, angle_init, torsion_init, & + bond_terminate, angle_terminate, torsion_terminate + use mod_bonded, only: OMMP_ANG_SIMPLE, OMMP_ANG_H0, OMMP_ANG_H1, & + OMMP_ANG_H2, OMMP_ANG_INPLANE, & + OMMP_ANG_INPLANE_H0, OMMP_ANG_INPLANE_H1 + use mod_io, only: ommp_message, fatal_error + use mod_constants, only: OMMP_STR_CHAR_MAX, OMMP_VERBOSE_LOW + use mod_topology, only: check_conn_matrix + + implicit none + + type(ommp_link_atom_type), intent(inout), target :: la + character(len=*), intent(in) :: prmfile + + type(ommp_bonded_type) :: tmp_bnd + integer(ip), parameter :: maxt = 1024 + integer(ip) :: ist, i, j, nqm, nterms, iterms(maxt) + character(len=OMMP_STR_CHAR_MAX) :: message + character(len=OMMP_STR_CHAR_MAX), allocatable :: prm_buf(:) + + call check_conn_matrix(la%qmmmtop, 4) + tmp_bnd%top => la%qmmmtop + la%bds%top => la%qmmmtop + + call large_file_read(prmfile, prm_buf) + ! Remove comments from prm file + !$omp parallel do + do i=1, size(prm_buf) + prm_buf(i) = str_to_lower(prm_buf(i)) + prm_buf(i) = str_uncomment(prm_buf(i), '!') + end do + ! Bonded terms + call assign_bond(tmp_bnd, prm_buf, la%qm2full, 2) + if(tmp_bnd%use_bond) then + nterms = 0 + do i=1, tmp_bnd%nbond + nqm = 0 + if(any(la%qm2full == tmp_bnd%bondat(1,i))) nqm = nqm+1 + if(any(la%qm2full == tmp_bnd%bondat(2,i))) nqm = nqm+1 + if(nqm == 1) then + nterms = nterms + 1 + if(nterms > maxt) then + call fatal_error("Maximum number of terms to be added due to link atom & + &exceeded. This is probably a bug.") + end if + iterms(nterms) = i + end if + end do + + if(la%bds%use_bond) then + ! Bond terms are already initializad by a previous + ! link atom + call bond_terminate(la%bds) + end if + + call bond_init(la%bds, nterms) + + do i=1, nterms + la%bds%bondat(:,i) = tmp_bnd%bondat(:,iterms(i)) + la%bds%kbond(i) = tmp_bnd%kbond(iterms(i)) + la%bds%l0bond(i) = tmp_bnd%l0bond(iterms(i)) + end do + la%bds%bond_cubic = tmp_bnd%bond_cubic + la%bds%bond_quartic = tmp_bnd%bond_quartic + + write(message, "(I0, A)") nterms, " bond terms added due to link atoms." + call ommp_message(message, OMMP_VERBOSE_LOW, "linkatom") + end if + + call assign_angle(tmp_bnd, prm_buf, la%qm2full, 2) + if(tmp_bnd%use_angle) then + nterms = 0 + do i=1, tmp_bnd%nangle + if(tmp_bnd%anglety(i) == OMMP_ANG_SIMPLE .or. & + tmp_bnd%anglety(i) == OMMP_ANG_H0 .or. & + tmp_bnd%anglety(i) == OMMP_ANG_H1 .or. & + tmp_bnd%anglety(i) == OMMP_ANG_H2) then + nqm = 0 + if(any(la%qm2full == tmp_bnd%angleat(1,i))) nqm = nqm+1 + if(any(la%qm2full == tmp_bnd%angleat(2,i))) nqm = nqm+1 + if(any(la%qm2full == tmp_bnd%angleat(3,i))) nqm = nqm+1 + + if(nqm == 1) then + nterms = nterms + 1 + if(nterms > maxt) then + call fatal_error("Maximum number of terms to be added due to link atom & + &exceeded. This is probably a bug.") + end if + iterms(nterms) = i + end if + else if(tmp_bnd%anglety(i) == OMMP_ANG_INPLANE .or. & + tmp_bnd%anglety(i) == OMMP_ANG_INPLANE_H0 .or. & + tmp_bnd%anglety(i) == OMMP_ANG_INPLANE_H1) then + nqm = 0 + if(any(la%qm2full == tmp_bnd%angleat(1,i))) nqm = nqm+1 + if(any(la%qm2full == tmp_bnd%angleat(2,i))) nqm = nqm+1 + if(any(la%qm2full == tmp_bnd%angleat(3,i))) nqm = nqm+1 + if(nqm == 1 .and. .not. any(la%qm2full == tmp_bnd%angauxat(i))) then + nterms = nterms + 1 + if(nterms > maxt) then + call fatal_error("Maximum number of terms to be added due to link atom & + &exceeded. This is probably a bug.") + end if + iterms(nterms) = i + end if + end if + end do + + if(la%bds%use_angle) then + call angle_terminate(la%bds) + end if + call angle_init(la%bds, nterms) + + do i=1, nterms + la%bds%angleat(:,i) = tmp_bnd%angleat(:,iterms(i)) + la%bds%anglety(i) = tmp_bnd%anglety(iterms(i)) + la%bds%angauxat(i) = tmp_bnd%angauxat(iterms(i)) + la%bds%kangle(i) = tmp_bnd%kangle(iterms(i)) + la%bds%eqangle(i) = tmp_bnd%eqangle(iterms(i)) + end do + la%bds%angle_cubic = tmp_bnd%angle_cubic + la%bds%angle_quartic = tmp_bnd%angle_quartic + la%bds%angle_pentic = tmp_bnd%angle_pentic + la%bds%angle_sextic = tmp_bnd%angle_sextic + + write(message, "(I0, A)") nterms, " angle terms added due to link atoms." + call ommp_message(message, OMMP_VERBOSE_LOW, "linkatom") + end if + + call assign_torsion(tmp_bnd, prm_buf) + if(tmp_bnd%use_torsion) then + nterms = 0 + do i=1, tmp_bnd%ntorsion + nqm = 0 + if(any(la%qm2full == tmp_bnd%torsionat(1,i))) nqm = nqm+1 + if(any(la%qm2full == tmp_bnd%torsionat(2,i))) nqm = nqm+1 + if(any(la%qm2full == tmp_bnd%torsionat(3,i))) nqm = nqm+1 + if(any(la%qm2full == tmp_bnd%torsionat(4,i))) nqm = nqm+1 + !! Link atoms should never appear in bonded interactions! + do j=1, 4 + if(any(la%qm2full(la%links(_LA_,1:la%nla)) == tmp_bnd%torsionat(j,i))) nqm = -1 + end do + + if(nqm == 1 .or. nqm == 2) then + nterms = nterms + 1 + if(nterms > maxt) then + call fatal_error("Maximum number of terms to be added due to link atom & + &exceeded. This is probably a bug.") + end if + iterms(nterms) = i + end if + end do + + if(la%bds%use_torsion) then + call torsion_terminate(la%bds) + end if + call torsion_init(la%bds, nterms) + + do i=1, nterms + la%bds%torsionat(:,i) = tmp_bnd%torsionat(:,iterms(i)) + la%bds%torsn(:,i) = tmp_bnd%torsn(:,iterms(i)) + la%bds%torsamp(:,i) = tmp_bnd%torsamp(:,iterms(i)) + la%bds%torsphase(:,i) = tmp_bnd%torsphase(:,iterms(i)) + end do + + write(message, "(I0, A)") nterms, " torsion terms added due to link atoms." + call ommp_message(message, OMMP_VERBOSE_LOW, "linkatom") + end if + + deallocate(prm_buf) + call bonded_terminate(tmp_bnd) + end subroutine + + subroutine link_atom_bond_geomgrad(la, qmg, mmg, doqm, domm) + use mod_bonded, only: bond_geomgrad + + implicit none + + type(ommp_link_atom_type), intent(in) :: la + real(rp), intent(inout) :: qmg(:,:), & + mmg(:,:) + logical, intent(in) :: doqm, domm + + real(rp), allocatable :: grd(:,:) + integer(ip) :: i + + call mallocate('link_atom_bond_geomgrad [grd]', & + 3, la%qmmmtop%mm_atoms, grd) + grd = 0.0 + call bond_geomgrad(la%bds, grd) + + if(doqm) then + do i=1, la%qmtop%mm_atoms + qmg(:,i) = qmg(:,i) + grd(:,la%qm2full(i)) + end do + end if + + if(domm) then + do i=1, la%mmtop%mm_atoms + mmg(:,i) = mmg(:,i) + grd(:,la%mm2full(i)) + end do + end if + + call mfree('link_atom_bond_geomgrad [grd]', grd) + end subroutine + + subroutine link_atom_angle_geomgrad(la, qmg, mmg, doqm, domm) + use mod_bonded, only: angle_geomgrad + + implicit none + + type(ommp_link_atom_type), intent(in) :: la + real(rp), intent(inout) :: qmg(:,:), & + mmg(:,:) + logical, intent(in) :: doqm, domm + + real(rp), allocatable :: grd(:,:) + integer(ip) :: i + + call mallocate('link_atom_bond_geomgrad [grd]', & + 3, la%qmmmtop%mm_atoms, grd) + grd = 0.0 + call angle_geomgrad(la%bds, grd) + + if(doqm) then + do i=1, la%qmtop%mm_atoms + qmg(:,i) = qmg(:,i) + grd(:,la%qm2full(i)) + end do + end if + + if(domm) then + do i=1, la%mmtop%mm_atoms + mmg(:,i) = mmg(:,i) + grd(:,la%mm2full(i)) + end do + end if + + call mfree('link_atom_bond_geomgrad [grd]', grd) + end subroutine + + subroutine link_atom_torsion_geomgrad(la, qmg, mmg, doqm, domm) + use mod_bonded, only: torsion_geomgrad + + implicit none + + type(ommp_link_atom_type), intent(in) :: la + real(rp), intent(inout) :: qmg(:,:), & + mmg(:,:) + logical, intent(in) :: doqm, domm + + real(rp), allocatable :: grd(:,:) + integer(ip) :: i + + call mallocate('link_atom_bond_geomgrad [grd]', & + 3, la%qmmmtop%mm_atoms, grd) + grd = 0.0 + call torsion_geomgrad(la%bds, grd) + + if(doqm) then + do i=1, la%qmtop%mm_atoms + qmg(:,i) = qmg(:,i) + grd(:,la%qm2full(i)) + end do + end if + + if(domm) then + do i=1, la%mmtop%mm_atoms + mmg(:,i) = mmg(:,i) + grd(:,la%mm2full(i)) + end do + end if + + call mfree('link_atom_bond_geomgrad [grd]', grd) + end subroutine + + subroutine link_atom_project_grd(la, laforces, qmg, mmg) + use mod_utils, only: versor_der + + implicit none + + type(ommp_link_atom_type), intent(in) :: la + real(rp), intent(in) :: laforces(3, la%nla) + real(rp), intent(inout) :: qmg(3,la%qmtop%mm_atoms), & + mmg(3,la%mmtop%mm_atoms) + + integer(ip) :: i, iqm, imm, ila + real(rp) :: delta(3), rmm(3), rqm(3), dedqm(3,3), dedmm(3,3) + + do i=1, la%nla + iqm = la%links(_QM_,i) + imm = la%links(_MM_,i) + ila = la%links(_LA_,i) + + rmm = la%mmtop%cmm(:,imm) + rqm = la%qmtop%cmm(:,iqm) + delta = rmm-rqm + + dedmm = la%la_distance(i) * versor_der(delta) + + dedqm = 0.0 + dedqm(1,1) = 1.0 + dedqm(2,2) = 1.0 + dedqm(3,3) = 1.0 + dedqm = dedqm - dedmm + + if(.not. la%qmmmtop%frozen(la%qm2full(iqm))) & + qmg(:, iqm) = qmg(:, iqm) + matmul(dedqm, laforces(:,i)) + if(.not. la%qmmmtop%frozen(la%mm2full(imm))) & + mmg(:, imm) = mmg(:, imm) + matmul(dedmm, laforces(:,i)) + qmg(:, ila) = -laforces(:,i) + end do + end subroutine +end module diff --git a/src/mod_link_atom.f90 b/src/mod_link_atom.f90 deleted file mode 100644 index 7a2576a..0000000 --- a/src/mod_link_atom.f90 +++ /dev/null @@ -1,824 +0,0 @@ -#define _MM_ 1 -#define _QM_ 2 -#define _LA_ 3 - -module mod_link_atom - - use mod_memory, only: rp, ip, lp, mallocate, mfree - use mod_topology, only: ommp_topology_type - use mod_constants, only: angstrom2au, default_link_atom_dist, & - default_link_atom_n_eel_remove - use mod_nonbonded, only: vdw_geomgrad_inter - use mod_bonded, only: ommp_bonded_type - use mod_io, only: large_file_read - use mod_utils, only: str_to_lower, str_uncomment - - implicit none - private - - integer(ip), parameter :: link_atom_allocation_chunk = 20 - - type ommp_link_atom_type - type(ommp_topology_type), pointer :: mmtop - !! Topology of MM part of the system - type(ommp_topology_type), pointer :: qmtop - !! Topology of QM part of the system - type(ommp_topology_type), allocatable :: qmmmtop - !! Linked QM/MM topology - integer(ip), allocatable :: mm2full(:), qm2full(:) - !! Maps from qm and mm systems to full topology indexes - integer(ip) :: nla - !! Number of link atoms - integer(ip), allocatable :: links(:,:) - !! Indexes of link-involved atoms: - !! links(_MM_,:) contains the index of MM atom in mmtop - !! links(_QM_,:) contains the index of QM atom in qmtop - !! links(_LA_,:) contains the index of link atom in qmtop - real(rp), allocatable :: la_distance(:) - !! Distance of link atom from QM atom - integer(ip), allocatable :: vdw_screening_pairs(:,:) - !! Pairs of vdw interactions that should be screened - real(rp), allocatable :: vdw_screening_f(:) - !! Screening factors for each vdw pair - integer(ip) :: vdw_n_screening - !! Number of screening vdw to be used - type(ommp_bonded_type), allocatable :: bds - end type - - public :: ommp_link_atom_type, init_link_atom, add_link_atom - public :: link_atom_position, init_vdw_for_link_atom, init_bonded_for_link_atom - public :: init_eel_for_link_atom - public :: default_link_atom_dist, default_link_atom_n_eel_remove, link_atom_update_merged_topology - public :: link_atom_bond_geomgrad, link_atom_angle_geomgrad, link_atom_torsion_geomgrad, & - link_atom_project_grd - - contains - subroutine init_link_atom(la, qmtop, mmtop) - use mod_topology, only: merge_top - use mod_constants, only: OMMP_VERBOSE_LOW - use mod_io, only: ommp_message - - implicit none - - type(ommp_link_atom_type), intent(inout) :: la - type(ommp_topology_type), intent(in), target :: qmtop, mmtop - - call mallocate('init_linkatoms [links]', & - 3, link_atom_allocation_chunk, & - la%links) - call mallocate('init_linkatoms [la_distance]', & - link_atom_allocation_chunk, la%la_distance) - call mallocate('init_linkatoms [vdw_screening_f]', & - link_atom_allocation_chunk, la%vdw_screening_f) - call mallocate('init_linkatoms [vdw_screening_pairs]', 2, & - link_atom_allocation_chunk, la%vdw_screening_pairs) - - la%nla = 0 - la%vdw_n_screening = 0 - la%qmtop => qmtop - la%mmtop => mmtop - - call ommp_message("Creating merged topology", OMMP_VERBOSE_LOW, 'linkatom') - allocate(la%qmmmtop) - call merge_top(la%mmtop, la%qmtop, la%qmmmtop, la%mm2full, la%qm2full) - allocate(la%bds) - end subroutine - - subroutine link_atom_update_merged_topology(la) - !! Update merged topology in linkatom object so that its coordinates - !! are the same of mmtop and qmtop. - implicit none - - type(ommp_link_atom_type), intent(inout) :: la - - integer(ip) :: i - - do i=1, la%mmtop%mm_atoms - la%qmmmtop%cmm(:,la%mm2full(i)) = la%mmtop%cmm(:,i) - end do - - do i=1, la%qmtop%mm_atoms - la%qmmmtop%cmm(:,la%qm2full(i)) = la%qmtop%cmm(:,i) - end do - end subroutine - - subroutine add_link_atom(la, imm, iqm, ila, la_dist) - use mod_constants, only: OMMP_STR_CHAR_MAX, OMMP_VERBOSE_LOW - use mod_io, only: ommp_message - use mod_topology, only: create_new_bond - - implicit none - - type(ommp_link_atom_type), intent(inout) :: la - integer(ip), intent(in) :: imm - integer(ip), intent(in) :: iqm - integer(ip), intent(in) :: ila - real(rp), intent(in) :: la_dist - - integer(ip), allocatable :: tmp(:,:) - real(rp), allocatable :: rtmp(:) - integer(ip) :: nmax - character(len=OMMP_STR_CHAR_MAX) :: message - - nmax = size(la%links, 2) - if(la%nla + 1 > nmax) then - ! Reallocate links to accomodate new link atoms - call mallocate('create_link_atom [tmp]', 3, nmax, tmp) - call mallocate('create_link_atom [rtmp]', nmax, rtmp) - tmp = la%links - rtmp = la%la_distance - call mfree('create_link_atom [la%links]', la%links) - call mallocate('create_link_atom [la%links]', 3, nmax+link_atom_allocation_chunk, la%links) - call mfree('create_link_atom [la%la_distance]', la%la_distance) - call mallocate('create_link_atom [la%la_distance]', nmax+link_atom_allocation_chunk, la%la_distance) - la%links = tmp(:,0:nmax) - la%la_distance = rtmp(0:nmax) - call mfree('create_link_atom [tmp]', tmp) - call mfree('create_link_atom [rtmp]', rtmp) - end if - ! 0.2. Link atom creation and positioning - la%nla = la%nla + 1 - la%links(_MM_, la%nla) = imm - la%links(_QM_, la%nla) = iqm - la%links(_LA_, la%nla) = ila - la%la_distance(la%nla) = la_dist - - if(la%qmmmtop%frozen(la%qm2full(iqm)) .and. la%qmmmtop%frozen(la%mm2full(imm))) then - ! if QM atom and MM atoms are frozen, also LA is frozen - la%qmmmtop%frozen(la%qm2full(ila)) = .true. - end if - call create_new_bond(la%qmmmtop, la%mm2full(imm), la%qm2full(iqm)) - - write(message, "(A, I0, A, I0, A, I0, A)") & - "Created link atom MM [", imm, & - "] - (LA) [", ila, "] - QM [", iqm, "]" - - call ommp_message(message, OMMP_VERBOSE_LOW, 'linkatom') - end subroutine - - subroutine init_eel_for_link_atom(la, imm, ila, eel, prmfile) - use mod_memory, only: mallocate, mfree - use mod_prm, only: assign_mpoles - use mod_electrostatics, only: ommp_electrostatics_type, & - electrostatics_init, & - remove_null_pol - use mod_io, only: fatal_error, ommp_message - use mod_constants, only: eps_rp, OMMP_VERBOSE_LOW, & - OMMP_STR_CHAR_MAX, & - OMMP_VERBOSE_DEBUG - - implicit none - - integer(ip), intent(in) :: imm - integer(ip), intent(in) :: ila - type(ommp_link_atom_type), intent(in) :: la - type(ommp_electrostatics_type), intent(inout) :: eel - character(len=*), intent(in) :: prmfile - - real(rp) :: removed_charge, qred, old_q, lastq - integer(ip) :: n_eel_remove = default_link_atom_n_eel_remove - integer(ip) :: ist, i, j, idx, ii - type(ommp_electrostatics_type) :: tmp_eel - character(len=OMMP_STR_CHAR_MAX) :: msg - character(len=OMMP_STR_CHAR_MAX), allocatable :: prm_buf(:) - integer(ip), allocatable :: attocheck(:) - - ! Check if in the complete topology some of the atoms connected - ! to imm or imm itself do change their parameters. This is a - ! problem that affects force-field in which parameters are - ! assigned based on connectivity (AMOEBA). In particular we - ! check only 1,2 and 1,3 neighbours of QM atom that are the ones - ! that could be influenced by the new bond. Moreover we only - ! take care of charges, as multipoles will be removed on those - ! atoms in a while. - - call mallocate('init_eel_for_link_atom [attocheck]', & - eel%top%conn(1)%ri(imm+1) - eel%top%conn(1)%ri(imm)+1, & - attocheck) - attocheck(1) = imm - ii = 2 - do i=eel%top%conn(1)%ri(imm), eel%top%conn(1)%ri(imm+1)-1 - j = eel%top%conn(1)%ci(i) - attocheck(ii) = j - ii = ii + 1 - end do - write(msg, "(A, I0, A)") "Assigning electrostatic parameter to merged& - & topology. Ignore all the warnings on & - &link atom (", la%qm2full(ila), ")." - call ommp_message(msg, OMMP_VERBOSE_LOW, 'linkatom') - - call electrostatics_init(tmp_eel, eel%amoeba, la%qmmmtop%mm_atoms, & - la%qmmmtop) - - call large_file_read(prmfile, prm_buf) - ! Remove comments from prm file - !$omp parallel do - do i=1, size(prm_buf) - prm_buf(i) = str_to_lower(prm_buf(i)) - prm_buf(i) = str_uncomment(prm_buf(i), '!') - end do - - call assign_mpoles(tmp_eel, prm_buf) - deallocate(prm_buf) - - do i=1, size(attocheck) - j = attocheck(i) - if(abs(tmp_eel%q(1,la%mm2full(j)) - eel%q(1,j)) > eps_rp) then - write(msg, "(A, I0)") "Reassigning electrostatic parameter to& - & atom ", j - call ommp_message(msg, OMMP_VERBOSE_LOW, 'linkatom') - write(msg, '(" Old parameters: q=", F6.2)') eel%q(1,j) - call ommp_message(msg, OMMP_VERBOSE_DEBUG, 'linkatom') - write(msg, '(" New parameters: q=", F6.2)') tmp_eel%q(1,la%mm2full(j)) - call ommp_message(msg, OMMP_VERBOSE_DEBUG, 'linkatom') - if(eel%amoeba) then - eel%q0(:,j) = tmp_eel%q(:,la%mm2full(j)) - else - eel%q(:,j) = tmp_eel%q(:,la%mm2full(j)) - end if - end if - end do - call mfree('init_eel_for_link_atom [attocheck]', attocheck) - - ! Remove dipoles, multipoles, charges and polarizabilities - ! on all the atoms that have a distance from (QM) atom less or equal to - ! n_eel_remove. If n_eel_remove is 0, the MM electrostatic is not changed; - ! if n_eel_remove is 1, only the connected atom is removed and so on. - ! Removed charges is distributed to all the atoms 1 bond further away. - - if(n_eel_remove > 0) then - if(n_eel_remove < 2) then - call fatal_error("Electrostatic interaction should be removed at least on 1,2 and & - &1,3 neighbour of linked QM atom") - end if - - if(eel%amoeba) then - old_q = sum(eel%q0(1,:)) - else - old_q = sum(eel%q(1,:)) - end if - removed_charge = 0.0 - - if(n_eel_remove > size(la%mmtop%conn)) then - call fatal_error("Connectivity rebuild is not implemented in link atom") - end if - - ! Remove charges, multipoles and polarizabilities - if(eel%amoeba) then - removed_charge = removed_charge + eel%q0(1,imm) - lastq = eel%q0(1,imm) - eel%q0(:,imm) = 0.0 - if(eel%mm_polar(imm) > 0) & - eel%pol(eel%mm_polar(imm)) = 0.0 - else - removed_charge = removed_charge + eel%q(1,imm) - lastq = eel%q(1,imm) - eel%q(:,imm) = 0.0 - - if(eel%mm_polar(imm) > 0) & - eel%pol(eel%mm_polar(imm)) = 0.0 - end if - write(msg, '("Removed charge, multipoles and polarizabilities on atom ", I0, "[q=", F6.3, "]")') imm, lastq - call ommp_message(msg, OMMP_VERBOSE_LOW, 'linkatom') - - do i=1, n_eel_remove-1 - do j=eel%top%conn(i)%ri(imm), eel%top%conn(i)%ri(imm+1)-1 - idx = eel%top%conn(i)%ci(j) - if(eel%amoeba) then - removed_charge = removed_charge + eel%q0(1,idx) - lastq = eel%q0(1,idx) - eel%q0(:,idx) = 0.0 - if(eel%mm_polar(idx) > 0) & - eel%pol(eel%mm_polar(idx)) = 0.0 - else - removed_charge = removed_charge + eel%q(1,idx) - lastq = eel%q(1,idx) - eel%q(:,idx) = 0.0 - if(eel%mm_polar(idx) > 0) & - eel%pol(eel%mm_polar(idx)) = 0.0 - end if - write(msg, '("Removed charge, multipoles and polarizabilities on atom ", I0, "[q=", F6.3, "]")') idx, lastq - call ommp_message(msg, OMMP_VERBOSE_LOW, 'linkatom') - end do - end do - - ! Redistribute removed charge to preserve neutrality - qred = removed_charge / (eel%top%conn(n_eel_remove)%ri(imm+1) - eel%top%conn(i)%ri(imm)) - - do j=eel%top%conn(n_eel_remove)%ri(imm), & - eel%top%conn(n_eel_remove)%ri(imm+1)-1 - idx = eel%top%conn(n_eel_remove)%ci(j) - if(eel%amoeba) then - eel%q0(1,idx) = eel%q0(1,idx) + qred - else - eel%q(1,idx) = eel%q(1,idx) + qred - end if - write(msg, '("Redistributing charge (", F6.3, " A.U.) on atom ", I0)') qred, idx - call ommp_message(msg, OMMP_VERBOSE_LOW, 'linkatom') - end do - end if - - call remove_null_pol(eel) - - eel%M2M_done = .false. - eel%M2Mgg_done = .false. - eel%M2D_done = .false. - eel%M2Dgg_done = .false. - eel%ipd_done = .false. - if(allocated(eel%TMat)) call mfree('update_coordinates [TMat]',eel%TMat) - if(eel%amoeba) call rotate_multipoles(eel) - write(msg, '("Charge of the systems passed from ", F6.3, " to ", F6.3, "A.U.")') & - old_q, sum(eel%q(1,:)) - call ommp_message(msg, OMMP_VERBOSE_LOW, 'linkatom') - - - end subroutine - - subroutine link_atom_position(la, idx, crd) - !! Compute the cartesian coordinates of link atom idx at - !! the current geometry. - implicit none - - type(ommp_link_atom_type), intent(in) :: la - integer(ip), intent(in) :: idx - real(rp), intent(out) :: crd(3) - - real(rp), dimension(3) :: rmm, rqm, dmmqm - - rmm = la%mmtop%cmm(:,la%links(_MM_,idx)) - rqm = la%qmtop%cmm(:,la%links(_QM_,idx)) - dmmqm = rmm-rqm - dmmqm = dmmqm / norm2(dmmqm) - - crd = rqm + la%la_distance(idx) * dmmqm - end subroutine - - subroutine check_vdw_pairs(la, n) - !! Check if n new screening pairs could be allocated - !! in la structure. If the allocated arrays are too - !! small, they are reallocated on-the-fly. - implicit none - - type(ommp_link_atom_type), intent(inout) :: la - integer(ip), intent(in) :: n - - integer(ip), allocatable :: itmp(:,:) - real(rp), allocatable :: rtmp(:) - integer(ip) :: nnew, nold - - nnew = n + la%vdw_n_screening - nold = size(la%vdw_screening_f) - if(nnew > nold) then - call mallocate('check_vdw_pairs [itmp]', 2, nold, itmp) - call mallocate('check_vdw_pairs [rtmp]', nold, rtmp) - itmp = la%vdw_screening_pairs - rtmp = la%vdw_screening_f - call mfree('check_vdw_pairs [vdw_screening_pairs]', la%vdw_screening_pairs) - call mfree('check_vdw_pairs [vdw_screening_f]', la%vdw_screening_f) - - call mallocate('check_vdw_pairs [vdw_screening_pairs]', 2, nnew, la%vdw_screening_pairs) - call mallocate('check_vdw_pairs [vdw_screening_f]', nnew, la%vdw_screening_f) - - la%vdw_screening_pairs(:,:nold) = itmp - la%vdw_screening_f(:nold) = rtmp - - call mfree('check_vdw_pairs [itmp]', itmp) - call mfree('check_vdw_pairs [rtmp]', rtmp) - end if - end subroutine - - subroutine add_screening_pair(la, iqm, imm, s) - use mod_io, only: ommp_message - use mod_constants, only: OMMP_STR_CHAR_MAX, OMMP_VERBOSE_DEBUG - !! Insert a VdW screening pair in the link atom structure - implicit none - - type(ommp_link_atom_type), intent(inout) :: la - integer(ip), intent(in) :: iqm, imm - real(rp), intent(in) :: s - character(len=OMMP_STR_CHAR_MAX) :: message - - ! Just for safety, it should be done elsewhere for all the pairs - ! ones want to insert in the structure. - call check_vdw_pairs(la, 1) - - la%vdw_n_screening = la%vdw_n_screening + 1 - la%vdw_screening_pairs(_QM_, la%vdw_n_screening) = iqm - la%vdw_screening_pairs(_MM_, la%vdw_n_screening) = imm - la%vdw_screening_f(la%vdw_n_screening) = s - write(message, "(A, I0, A, I0, A, F3.2)") & - "Screening VdW interactions between atoms ", imm, " (MM) & - &and ", iqm, "(QM) by a factor ", 1.0 + s - call ommp_message(message, OMMP_VERBOSE_DEBUG, 'linkatom') - - end subroutine - - subroutine init_vdw_for_link_atom(la, iqm, imm, vdw_screening) - !! Initialize the quantities needed for vdw screening due to the - !! presence of a link atom between iqm and imm - use mod_topology, only: check_conn_matrix - use mod_io, only: fatal_error, ommp_message - use mod_constants, only: eps_rp, OMMP_STR_CHAR_MAX, OMMP_VERBOSE_DEBUG - - - implicit none - - type(ommp_link_atom_type), intent(inout) :: la - integer(ip), intent(in) :: iqm, imm - real(rp), intent(in) :: vdw_screening(:) - - integer(ip) :: i, j, ineigh_qm, ineigh_mm, idist, iscr, & - qmneigh(4), mmneigh(4) - real(rp) :: screen - character(len=OMMP_STR_CHAR_MAX) :: message - - ! Check that the connectivity matrices have been built up to the - ! required order. - call check_conn_matrix(la%qmtop, size(vdw_screening)-1) - call check_conn_matrix(la%mmtop, size(vdw_screening)-1) - - ! Count how many interactions should be screened - qmneigh(1) = 1 - mmneigh(1) = 1 - do i=2, size(vdw_screening) - qmneigh(i) = la%qmtop%conn(i-1)%ri(iqm+1) - & - la%qmtop%conn(i-1)%ri(iqm) - mmneigh(i) = la%mmtop%conn(i-1)%ri(imm+1) - & - la%mmtop%conn(i-1)%ri(imm) - end do - - iscr = 0 - do idist=1, size(vdw_screening) - if(abs(vdw_screening(idist) - 1.0) > eps_rp) then - do i=1, idist - iscr = iscr + qmneigh(i) * mmneigh(idist-i+1) - end do - end if - end do - write(message, "(I0, A)") & - iscr, " VdW interactions will be screened due to link atom" - call ommp_message(message, OMMP_VERBOSE_DEBUG, 'linkatom') - - ! Check the allocation of vectors inside link atom structure - call check_vdw_pairs(la, iscr) - - ! Insert the new screened interactions inside link atom structure - do idist=1, size(vdw_screening) - screen = vdw_screening(idist) - 1.0 - if(abs(screen) > eps_rp) then - do ineigh_qm=1, idist - ineigh_mm = idist - ineigh_qm + 1 - if(ineigh_qm == 1) then - if(ineigh_mm == 1) then - call add_screening_pair(la, iqm, imm, screen) - else - do i=la%mmtop%conn(ineigh_mm-1)%ri(imm), & - la%mmtop%conn(ineigh_mm-1)%ri(imm+1) - 1 - call add_screening_pair(la, & - iqm, & - la%mmtop%conn(ineigh_mm-1)%ci(i), & - screen) - end do - end if - else - if(ineigh_mm == 1) then - do i=la%qmtop%conn(ineigh_qm-1)%ri(iqm), & - la%qmtop%conn(ineigh_qm-1)%ri(iqm+1) -1 - call add_screening_pair(la, & - la%qmtop%conn(ineigh_qm-1)%ci(i), & - imm, & - screen) - end do - else - do i=la%mmtop%conn(ineigh_mm-1)%ri(imm), & - la%mmtop%conn(ineigh_mm-1)%ri(imm+1) - 1 - do j=la%qmtop%conn(ineigh_qm-1)%ri(iqm), & - la%qmtop%conn(ineigh_qm-1)%ri(iqm+1) -1 - call add_screening_pair(la, & - la%qmtop%conn(ineigh_qm-1)%ci(j), & - la%mmtop%conn(ineigh_mm-1)%ci(i), & - screen) - end do - end do - end if - end if - end do - end if - end do - - end subroutine - - subroutine init_bonded_for_link_atom(la, prmfile) - !! Insert in the bonded parameter required for the link atom between iqm and imm - use mod_prm, only: assign_bond, assign_angle, assign_torsion - use mod_bonded, only: bonded_terminate, & - bond_init, angle_init, torsion_init, & - bond_terminate, angle_terminate, torsion_terminate - use mod_bonded, only: OMMP_ANG_SIMPLE, OMMP_ANG_H0, OMMP_ANG_H1, & - OMMP_ANG_H2, OMMP_ANG_INPLANE, & - OMMP_ANG_INPLANE_H0, OMMP_ANG_INPLANE_H1 - use mod_io, only: ommp_message, fatal_error - use mod_constants, only: OMMP_STR_CHAR_MAX, OMMP_VERBOSE_LOW - use mod_topology, only: check_conn_matrix - - implicit none - - type(ommp_link_atom_type), intent(inout), target :: la - character(len=*), intent(in) :: prmfile - - type(ommp_bonded_type) :: tmp_bnd - integer(ip), parameter :: maxt = 1024 - integer(ip) :: ist, i, j, nqm, nterms, iterms(maxt) - character(len=OMMP_STR_CHAR_MAX) :: message - character(len=OMMP_STR_CHAR_MAX), allocatable :: prm_buf(:) - - call check_conn_matrix(la%qmmmtop, 4) - tmp_bnd%top => la%qmmmtop - la%bds%top => la%qmmmtop - - call large_file_read(prmfile, prm_buf) - ! Remove comments from prm file - !$omp parallel do - do i=1, size(prm_buf) - prm_buf(i) = str_to_lower(prm_buf(i)) - prm_buf(i) = str_uncomment(prm_buf(i), '!') - end do - ! Bonded terms - call assign_bond(tmp_bnd, prm_buf, la%qm2full, 2) - if(tmp_bnd%use_bond) then - nterms = 0 - do i=1, tmp_bnd%nbond - nqm = 0 - if(any(la%qm2full == tmp_bnd%bondat(1,i))) nqm = nqm+1 - if(any(la%qm2full == tmp_bnd%bondat(2,i))) nqm = nqm+1 - if(nqm == 1) then - nterms = nterms + 1 - if(nterms > maxt) then - call fatal_error("Maximum number of terms to be added due to link atom & - &exceeded. This is probably a bug.") - end if - iterms(nterms) = i - end if - end do - - if(la%bds%use_bond) then - ! Bond terms are already initializad by a previous - ! link atom - call bond_terminate(la%bds) - end if - - call bond_init(la%bds, nterms) - - do i=1, nterms - la%bds%bondat(:,i) = tmp_bnd%bondat(:,iterms(i)) - la%bds%kbond(i) = tmp_bnd%kbond(iterms(i)) - la%bds%l0bond(i) = tmp_bnd%l0bond(iterms(i)) - end do - la%bds%bond_cubic = tmp_bnd%bond_cubic - la%bds%bond_quartic = tmp_bnd%bond_quartic - - write(message, "(I0, A)") nterms, " bond terms added due to link atoms." - call ommp_message(message, OMMP_VERBOSE_LOW, "linkatom") - end if - - call assign_angle(tmp_bnd, prm_buf, la%qm2full, 2) - if(tmp_bnd%use_angle) then - nterms = 0 - do i=1, tmp_bnd%nangle - if(tmp_bnd%anglety(i) == OMMP_ANG_SIMPLE .or. & - tmp_bnd%anglety(i) == OMMP_ANG_H0 .or. & - tmp_bnd%anglety(i) == OMMP_ANG_H1 .or. & - tmp_bnd%anglety(i) == OMMP_ANG_H2) then - nqm = 0 - if(any(la%qm2full == tmp_bnd%angleat(1,i))) nqm = nqm+1 - if(any(la%qm2full == tmp_bnd%angleat(2,i))) nqm = nqm+1 - if(any(la%qm2full == tmp_bnd%angleat(3,i))) nqm = nqm+1 - - if(nqm == 1) then - nterms = nterms + 1 - if(nterms > maxt) then - call fatal_error("Maximum number of terms to be added due to link atom & - &exceeded. This is probably a bug.") - end if - iterms(nterms) = i - end if - else if(tmp_bnd%anglety(i) == OMMP_ANG_INPLANE .or. & - tmp_bnd%anglety(i) == OMMP_ANG_INPLANE_H0 .or. & - tmp_bnd%anglety(i) == OMMP_ANG_INPLANE_H1) then - nqm = 0 - if(any(la%qm2full == tmp_bnd%angleat(1,i))) nqm = nqm+1 - if(any(la%qm2full == tmp_bnd%angleat(2,i))) nqm = nqm+1 - if(any(la%qm2full == tmp_bnd%angleat(3,i))) nqm = nqm+1 - if(nqm == 1 .and. .not. any(la%qm2full == tmp_bnd%angauxat(i))) then - nterms = nterms + 1 - if(nterms > maxt) then - call fatal_error("Maximum number of terms to be added due to link atom & - &exceeded. This is probably a bug.") - end if - iterms(nterms) = i - end if - end if - end do - - if(la%bds%use_angle) then - call angle_terminate(la%bds) - end if - call angle_init(la%bds, nterms) - - do i=1, nterms - la%bds%angleat(:,i) = tmp_bnd%angleat(:,iterms(i)) - la%bds%anglety(i) = tmp_bnd%anglety(iterms(i)) - la%bds%angauxat(i) = tmp_bnd%angauxat(iterms(i)) - la%bds%kangle(i) = tmp_bnd%kangle(iterms(i)) - la%bds%eqangle(i) = tmp_bnd%eqangle(iterms(i)) - end do - la%bds%angle_cubic = tmp_bnd%angle_cubic - la%bds%angle_quartic = tmp_bnd%angle_quartic - la%bds%angle_pentic = tmp_bnd%angle_pentic - la%bds%angle_sextic = tmp_bnd%angle_sextic - - write(message, "(I0, A)") nterms, " angle terms added due to link atoms." - call ommp_message(message, OMMP_VERBOSE_LOW, "linkatom") - end if - - call assign_torsion(tmp_bnd, prm_buf) - if(tmp_bnd%use_torsion) then - nterms = 0 - do i=1, tmp_bnd%ntorsion - nqm = 0 - if(any(la%qm2full == tmp_bnd%torsionat(1,i))) nqm = nqm+1 - if(any(la%qm2full == tmp_bnd%torsionat(2,i))) nqm = nqm+1 - if(any(la%qm2full == tmp_bnd%torsionat(3,i))) nqm = nqm+1 - if(any(la%qm2full == tmp_bnd%torsionat(4,i))) nqm = nqm+1 - !! Link atoms should never appear in bonded interactions! - do j=1, 4 - if(any(la%qm2full(la%links(_LA_,1:la%nla)) == tmp_bnd%torsionat(j,i))) nqm = -1 - end do - - if(nqm == 1 .or. nqm == 2) then - nterms = nterms + 1 - if(nterms > maxt) then - call fatal_error("Maximum number of terms to be added due to link atom & - &exceeded. This is probably a bug.") - end if - iterms(nterms) = i - end if - end do - - if(la%bds%use_torsion) then - call torsion_terminate(la%bds) - end if - call torsion_init(la%bds, nterms) - - do i=1, nterms - la%bds%torsionat(:,i) = tmp_bnd%torsionat(:,iterms(i)) - la%bds%torsn(:,i) = tmp_bnd%torsn(:,iterms(i)) - la%bds%torsamp(:,i) = tmp_bnd%torsamp(:,iterms(i)) - la%bds%torsphase(:,i) = tmp_bnd%torsphase(:,iterms(i)) - end do - - write(message, "(I0, A)") nterms, " torsion terms added due to link atoms." - call ommp_message(message, OMMP_VERBOSE_LOW, "linkatom") - end if - - deallocate(prm_buf) - call bonded_terminate(tmp_bnd) - end subroutine - - subroutine link_atom_bond_geomgrad(la, qmg, mmg, doqm, domm) - use mod_bonded, only: bond_geomgrad - - implicit none - - type(ommp_link_atom_type), intent(in) :: la - real(rp), intent(inout) :: qmg(:,:), & - mmg(:,:) - logical, intent(in) :: doqm, domm - - real(rp), allocatable :: grd(:,:) - integer(ip) :: i - - call mallocate('link_atom_bond_geomgrad [grd]', & - 3, la%qmmmtop%mm_atoms, grd) - grd = 0.0 - call bond_geomgrad(la%bds, grd) - - if(doqm) then - do i=1, la%qmtop%mm_atoms - qmg(:,i) = qmg(:,i) + grd(:,la%qm2full(i)) - end do - end if - - if(domm) then - do i=1, la%mmtop%mm_atoms - mmg(:,i) = mmg(:,i) + grd(:,la%mm2full(i)) - end do - end if - - call mfree('link_atom_bond_geomgrad [grd]', grd) - end subroutine - - subroutine link_atom_angle_geomgrad(la, qmg, mmg, doqm, domm) - use mod_bonded, only: angle_geomgrad - - implicit none - - type(ommp_link_atom_type), intent(in) :: la - real(rp), intent(inout) :: qmg(:,:), & - mmg(:,:) - logical, intent(in) :: doqm, domm - - real(rp), allocatable :: grd(:,:) - integer(ip) :: i - - call mallocate('link_atom_bond_geomgrad [grd]', & - 3, la%qmmmtop%mm_atoms, grd) - grd = 0.0 - call angle_geomgrad(la%bds, grd) - - if(doqm) then - do i=1, la%qmtop%mm_atoms - qmg(:,i) = qmg(:,i) + grd(:,la%qm2full(i)) - end do - end if - - if(domm) then - do i=1, la%mmtop%mm_atoms - mmg(:,i) = mmg(:,i) + grd(:,la%mm2full(i)) - end do - end if - - call mfree('link_atom_bond_geomgrad [grd]', grd) - end subroutine - - subroutine link_atom_torsion_geomgrad(la, qmg, mmg, doqm, domm) - use mod_bonded, only: torsion_geomgrad - - implicit none - - type(ommp_link_atom_type), intent(in) :: la - real(rp), intent(inout) :: qmg(:,:), & - mmg(:,:) - logical, intent(in) :: doqm, domm - - real(rp), allocatable :: grd(:,:) - integer(ip) :: i - - call mallocate('link_atom_bond_geomgrad [grd]', & - 3, la%qmmmtop%mm_atoms, grd) - grd = 0.0 - call torsion_geomgrad(la%bds, grd) - - if(doqm) then - do i=1, la%qmtop%mm_atoms - qmg(:,i) = qmg(:,i) + grd(:,la%qm2full(i)) - end do - end if - - if(domm) then - do i=1, la%mmtop%mm_atoms - mmg(:,i) = mmg(:,i) + grd(:,la%mm2full(i)) - end do - end if - - call mfree('link_atom_bond_geomgrad [grd]', grd) - end subroutine - - subroutine link_atom_project_grd(la, laforces, qmg, mmg) - use mod_utils, only: versor_der - - implicit none - - type(ommp_link_atom_type), intent(in) :: la - real(rp), intent(in) :: laforces(3, la%nla) - real(rp), intent(inout) :: qmg(3,la%qmtop%mm_atoms), & - mmg(3,la%mmtop%mm_atoms) - - integer(ip) :: i, iqm, imm, ila - real(rp) :: delta(3), rmm(3), rqm(3), dedqm(3,3), dedmm(3,3) - - do i=1, la%nla - iqm = la%links(_QM_,i) - imm = la%links(_MM_,i) - ila = la%links(_LA_,i) - - rmm = la%mmtop%cmm(:,imm) - rqm = la%qmtop%cmm(:,iqm) - delta = rmm-rqm - - dedmm = la%la_distance(i) * versor_der(delta) - - dedqm = 0.0 - dedqm(1,1) = 1.0 - dedqm(2,2) = 1.0 - dedqm(3,3) = 1.0 - dedqm = dedqm - dedmm - - if(.not. la%qmmmtop%frozen(la%qm2full(iqm))) & - qmg(:, iqm) = qmg(:, iqm) + matmul(dedqm, laforces(:,i)) - if(.not. la%qmmmtop%frozen(la%mm2full(imm))) & - mmg(:, imm) = mmg(:, imm) + matmul(dedmm, laforces(:,i)) - qmg(:, ila) = -laforces(:,i) - end do - end subroutine -end module diff --git a/src/mod_memory.F90 b/src/mod_memory.F90 new file mode 100644 index 0000000..1edbcbb --- /dev/null +++ b/src/mod_memory.F90 @@ -0,0 +1,472 @@ +module mod_memory + !! This module is used to handle the memory, the variable + !! kinds, the dynamic allocation and the optional soft + !! memory limit of the openMMPol library. + + use iso_c_binding + use mod_constants, only: ip, rp, lp, OMMP_STR_CHAR_MAX + use mod_io, only: fatal_error, ommp_message + + implicit none + private + + integer(ip), parameter :: iof_memory = 6 + !! Unit file for memory errors, warning and debug + real(rp) :: maxmem !! Max memory that can be allocated in GB + real(rp) :: usedmem !! Memory that is currently used by the code in GB + real(rp) :: max_used !! Maximum memory used since last reset through mem_stat + integer(ip) :: size_of_int !! Number of bytes for an integer + integer(ip) :: size_of_real !! Number of bytes for a real + integer(ip) :: size_of_logical !! Number of bytes for a logical (?) + logical(lp) :: is_init = .false. + logical :: do_chk_limit !! Decide if the soft memory limit is on + + public :: rp, ip, lp + public :: mallocate, mfree, memory_init, mem_stat + public :: use_8bytes_int + + interface mallocate + !! Interface to perform memory allocation within the + !! openMMPol library, it can be called for 1,2 and + !! 3-dimensional arrays of either integer or real + module procedure r_alloc1 + module procedure r_alloc2 + module procedure r_alloc3 + module procedure i_alloc1 + module procedure i_alloc2 + module procedure i_alloc3 + module procedure l_alloc1 + module procedure l_alloc2 + end interface mallocate + + interface mfree + !! Interface to perform memory deallocation within the + !! openMMPol library, it can be called for 1,2 and + !! 3-dimensional arrays of either integer or real + module procedure r_free1 + module procedure r_free2 + module procedure r_free3 + module procedure i_free1 + module procedure i_free2 + module procedure i_free3 + module procedure l_free1 + module procedure l_free2 + end interface mfree + +contains + + function use_8bytes_int() bind(c, name='__use_8bytes_int') + !! This function is used to know if the library is + !! compiled using integer 8 or 4 bytes long. + logical(kind=c_bool) :: use_8bytes_int + +#ifdef USE_I8 + use_8bytes_int = .true. +#else + use_8bytes_int = .false. +#endif + end function use_8bytes_int + + subroutine memory_init(do_chk, max_Gbytes) + !! Routine used to initialize the memory module. It should + !! be called during the module initialization. + implicit none + + logical :: do_chk !! Switch for memory soft limit + real(rp), intent(in) :: max_Gbytes !! Amount of memory available in bytes + integer(ip) :: my_int !! Integer used only as target for sizeof + real(rp) :: my_real !! Real used only as target for sizeof + logical(lp) :: my_bool + intrinsic :: sizeof + + if(.not. is_init) then + do_chk_limit = do_chk + maxmem = max_Gbytes + usedmem = 0.0 + max_used = 0.0 + size_of_real = sizeof(my_real) + size_of_int = sizeof(my_int) + size_of_logical = sizeof(my_bool) + is_init = .true. + end if + end subroutine memory_init + + function mem_stat(pv) result(mm) + !! Return the current value of maximum used memory, if an + !! argument is present set max_used to that value, otherwise + !! max_used is reset to -1 + implicit none + + real(rp), intent(in), optional :: pv + real(rp) :: mm + + if(.not. is_init) call memory_init(.false., 0.0_rp) + + mm = max_used + if(present(pv)) then + if(max_used < pv) max_used = pv + else + max_used = usedmem + end if + end function + + subroutine r_alloc1(string, len1, v) + !! Allocate a 1-dimensional array of reals + implicit none + + character(len=*), intent(in) :: string + !! Human-readable description string of the allocation + !! operation, just for output purpose. + integer(ip), intent(in) :: len1 + !! Dimension of the vector + real(rp), allocatable, intent(inout) :: v(:) + !! Vector to allocate + + integer(ip) :: istat + + if(.not. is_init) call memory_init(.false., 0.0_rp) + allocate(v(len1), stat=istat) + call chk_alloc(string, len1*size_of_real, istat) + end subroutine r_alloc1 + + subroutine r_alloc2(string, len1, len2, v) + !! Allocate a 2-dimensional array of reals + implicit none + + character(len=*), intent(in) :: string + !! Human-readable description string of the allocation + !! operation, just for output purpose. + integer(ip), intent(in) :: len1, len2 + !! Dimensions of the vector + real(rp), allocatable, intent(inout) :: v(:,:) + !! Vector to allocate + + integer(ip) :: istat + + if(.not. is_init) call memory_init(.false., 0.0_rp) + allocate(v(len1, len2), stat=istat) + call chk_alloc(string, len1*len2*size_of_real, istat) + end subroutine r_alloc2 + + subroutine r_alloc3(string, len1, len2, len3, v) + !! Allocate a 3-dimensional array of reals + implicit none + + character(len=*), intent(in) :: string + !! Human-readable description string of the allocation + !! operation, just for output purpose. + integer(ip), intent(in) :: len1, len2, len3 + !! Dimensions of the vector + real(rp), allocatable, intent(inout) :: v(:,:,:) + !! Vector to allocate + + integer(ip) :: istat + + if(.not. is_init) call memory_init(.false., 0.0_rp) + allocate(v(len1, len2, len3), stat=istat) + call chk_alloc(string, len1*len2*len3*size_of_real, istat) + end subroutine r_alloc3 + + subroutine i_alloc1(string, len1, v) + !! Allocate a 1-dimensional array of integers + implicit none + + character (len=*), intent(in) :: string + !! Human-readable description string of the allocation + !! operation, just for output purpose. + integer(ip), intent(in) :: len1 + !! Dimension of the vector + integer(ip), allocatable, intent(inout) :: v(:) + !! Vector to allocate + + integer(ip) :: istat + + if(.not. is_init) call memory_init(.false., 0.0_rp) + allocate(v(len1), stat=istat) + call chk_alloc(string, len1*size_of_int, istat) + end subroutine i_alloc1 + + subroutine i_alloc2(string, len1, len2, v) + !! Allocate a 2-dimensional array of integers + implicit none + + character (len=*), intent(in) :: string + !! Human-readable description string of the allocation + !! operation, just for output purpose. + integer(ip), intent(in) :: len1, len2 + !! Dimensions of the vector + integer(ip), allocatable, intent(inout) :: v(:,:) + !! Vector to allocate + + integer(ip) :: istat + + if(.not. is_init) call memory_init(.false., 0.0_rp) + allocate(v(len1, len2), stat=istat) + call chk_alloc(string, len1*len2*size_of_int, istat) + end subroutine i_alloc2 + + subroutine i_alloc3(string, len1, len2, len3, v) + !! Allocate a 3-dimensional array of integers + implicit none + + character (len=*), intent(in) :: string + !! Human-readable description string of the allocation + !! operation, just for output purpose. + integer(ip), intent(in) :: len1, len2, len3 + !! Dimensions of the vector + integer(ip), allocatable, intent(inout) :: v(:,:,:) + !! Vector to allocate + + integer(ip) :: istat + + if(.not. is_init) call memory_init(.false., 0.0_rp) + allocate(v(len1, len2, len3), stat=istat) + call chk_alloc(string, len1*len2*len3*size_of_int, istat) + end subroutine i_alloc3 + + subroutine l_alloc1(string, len1, v) + !! Allocate a 1-dimensional array of reals + implicit none + + character(len=*), intent(in) :: string + !! Human-readable description string of the allocation + !! operation, just for output purpose. + integer(ip), intent(in) :: len1 + !! Dimension of the vector + logical(lp), allocatable, intent(inout) :: v(:) + !! Vector to allocate + + integer(ip) :: istat + + if(.not. is_init) call memory_init(.false., 0.0_rp) + allocate(v(len1), stat=istat) + call chk_alloc(string, len1*size_of_logical, istat) + end subroutine l_alloc1 + + subroutine l_alloc2(string, len1, len2, v) + !! Allocate a 2-dimensional array of reals + implicit none + + character(len=*), intent(in) :: string + !! Human-readable description string of the allocation + !! operation, just for output purpose. + integer(ip), intent(in) :: len1, len2 + !! Dimensions of the vector + logical(lp), allocatable, intent(inout) :: v(:,:) + !! Vector to allocate + + integer(ip) :: istat + + if(.not. is_init) call memory_init(.false., 0.0_rp) + allocate(v(len1, len2), stat=istat) + call chk_alloc(string, len1*len2*size_of_logical, istat) + end subroutine l_alloc2 + + subroutine chk_alloc(string, lall, istat) + !! Handles the memory errors (including soft limit) + !! during memory allocation + implicit none + + integer(ip), intent(in) :: lall + !! Amount of allocated memory in bytes + integer(ip), intent(in) :: istat + !! Status flag from allocate() + character(len=*), intent(in) :: string + !! Human-readable description string of the allocation + !! operation, just for output purpose. + + character(len=OMMP_STR_CHAR_MAX) :: msg + !! Message string for errors + + real(rp) :: lall_gb + !! memory allocated in gb + + lall_gb = lall / 1e9 + + if(istat /= 0) then + write(msg, "('Allocation error in subroutine ', a ,'. stat= ', i5)") string, istat + call fatal_error(msg) + else if(do_chk_limit .and. usedmem+lall_gb > maxmem) then + write(msg, "('Allocation error in subroutine ', a ,'. Not enough memory (internal limit ', i8, ' W).')") string, maxmem + call fatal_error(msg) + else + usedmem = usedmem + lall_gb + end if + if(usedmem > max_used) max_used = usedmem + end subroutine chk_alloc + + subroutine r_free1(string, v) + !! Free a 1-dimensional array of reals + + character(len=*), intent(in) :: string + !! Human-readable description string of the deallocation + !! operation, just for output purpose. + real(rp), allocatable, intent(inout) :: v(:) + !! Array to free + + integer(ip) :: istat, ltot + + if(allocated(v)) then + ltot = size(v) * size_of_real + deallocate(v, stat=istat) + call chk_free(string, ltot, istat) + end if + end subroutine r_free1 + + subroutine r_free2(string, v) + !! Free a 2-dimensional array of reals + + character(len=*), intent(in) :: string + !! Human-readable description string of the deallocation + !! operation, just for output purpose. + real(rp), allocatable, intent(inout) :: v(:,:) + !! Array to free + + integer(ip) :: istat, ltot + + if(allocated(v)) then + ltot = size(v) * size_of_real + deallocate(v, stat=istat) + call chk_free(string, ltot, istat) + end if + end subroutine r_free2 + + subroutine r_free3(string, v) + !! Free a 3-dimensional array of reals + + character (len=*), intent(in) :: string + !! Human-readable description string of the deallocation + !! operation, just for output purpose. + real(rp), allocatable, intent(inout) :: v(:,:,:) + !! Array to free + + integer(ip) :: istat, ltot + + if(allocated(v)) then + ltot = size(v) * size_of_real + deallocate(v, stat=istat) + call chk_free(string, ltot, istat) + end if + end subroutine r_free3 + + subroutine i_free1(string, v) + !! Free a 1-dimensional array of integers + + character (len=*), intent(in) :: string + !! Human-readable description string of the deallocation + !! operation, just for output purpose. + integer(ip), allocatable, intent(inout) :: v(:) + !! Array to free + + integer(ip) :: istat, ltot + + if(allocated(v)) then + ltot = size(v) * size_of_int + deallocate(v, stat=istat) + call chk_free(string, ltot, istat) + end if + end subroutine i_free1 + + subroutine i_free2(string, v) + !! Free a 2-dimensional array of integers + + character (len=*), intent(in) :: string + !! Human-readable description string of the deallocation + !! operation, just for output purpose. + integer(ip), allocatable, intent(inout) :: v(:,:) + !! Array to free + + integer(ip) :: istat, ltot + + if(allocated(v)) then + ltot = size(v) * size_of_int + deallocate(v, stat=istat) + call chk_free(string, ltot, istat) + end if + end subroutine i_free2 + + subroutine i_free3(string, v) + !! Free a 3-dimensional array of integers + + character (len=*), intent(in) :: string + !! Human-readable description string of the deallocation + !! operation, just for output purpose. + integer(ip), allocatable, intent(inout) :: v(:,:,:) + !! Array to free + + integer(ip) :: istat, ltot + + if(allocated(v)) then + ltot = size(v) * size_of_int + deallocate (v, stat=istat) + call chk_free(string, ltot, istat) + end if + end subroutine i_free3 + + subroutine l_free1(string, v) + !! Free a 1-dimensional array of integers + + character (len=*), intent(in) :: string + !! Human-readable description string of the deallocation + !! operation, just for output purpose. + logical(lp), allocatable, intent(inout) :: v(:) + !! Array to free + + integer(ip) :: istat, ltot + + if(allocated(v)) then + ltot = size(v) * size_of_logical + deallocate(v, stat=istat) + call chk_free(string, ltot, istat) + end if + end subroutine l_free1 + + subroutine l_free2(string, v) + !! Free a 2-dimensional array of integers + + character (len=*), intent(in) :: string + !! Human-readable description string of the deallocation + !! operation, just for output purpose. + logical(lp), allocatable, intent(inout) :: v(:,:) + !! Array to free + + integer(ip) :: istat, ltot + + if(allocated(v)) then + ltot = size(v) * size_of_logical + deallocate(v, stat=istat) + call chk_free(string, ltot, istat) + end if + end subroutine l_free2 + + subroutine chk_free(string, lfree, istat) + !! Handles the memory errors (including soft limits) + !! during the deallocation + implicit none + + character(len=*), intent(in) :: string + !! Human-readable description string of the deallocation + !! operation, just for output purpose. + integer(ip), intent(in) :: lfree + !! amount of memory (in bytes) to free + integer(ip), intent(in) :: istat + !! return flag of deallocate + + character(len=OMMP_STR_CHAR_MAX) :: msg + !! Message string for errors + + real(rp) :: lfree_gb + !! memory allocated in gb + + lfree_gb = lfree / 1e9 + + if(istat /= 0)then + write(msg, "('Deallocation error in subroutine ', a ,'. stat= ', i5)") string, istat + call fatal_error(msg) + else + usedmem = usedmem - lfree_gb + end if + + end subroutine chk_free + +end module mod_memory diff --git a/src/mod_memory.f90 b/src/mod_memory.f90 deleted file mode 100644 index de639a6..0000000 --- a/src/mod_memory.f90 +++ /dev/null @@ -1,472 +0,0 @@ -module mod_memory - !! This module is used to handle the memory, the variable - !! kinds, the dynamic allocation and the optional soft - !! memory limit of the openMMPol library. - - use iso_c_binding - use mod_constants, only: ip, rp, lp, OMMP_STR_CHAR_MAX - use mod_io, only: fatal_error, ommp_message - - implicit none - private - - integer(ip), parameter :: iof_memory = 6 - !! Unit file for memory errors, warning and debug - real(rp) :: maxmem !! Max memory that can be allocated in GB - real(rp) :: usedmem !! Memory that is currently used by the code in GB - real(rp) :: max_used !! Maximum memory used since last reset through mem_stat - integer(ip) :: size_of_int !! Number of bytes for an integer - integer(ip) :: size_of_real !! Number of bytes for a real - integer(ip) :: size_of_logical !! Number of bytes for a logical (?) - logical(lp) :: is_init = .false. - logical :: do_chk_limit !! Decide if the soft memory limit is on - - public :: rp, ip, lp - public :: mallocate, mfree, memory_init, mem_stat - public :: use_8bytes_int - - interface mallocate - !! Interface to perform memory allocation within the - !! openMMPol library, it can be called for 1,2 and - !! 3-dimensional arrays of either integer or real - module procedure r_alloc1 - module procedure r_alloc2 - module procedure r_alloc3 - module procedure i_alloc1 - module procedure i_alloc2 - module procedure i_alloc3 - module procedure l_alloc1 - module procedure l_alloc2 - end interface mallocate - - interface mfree - !! Interface to perform memory deallocation within the - !! openMMPol library, it can be called for 1,2 and - !! 3-dimensional arrays of either integer or real - module procedure r_free1 - module procedure r_free2 - module procedure r_free3 - module procedure i_free1 - module procedure i_free2 - module procedure i_free3 - module procedure l_free1 - module procedure l_free2 - end interface mfree - - contains - - function use_8bytes_int() bind(c, name='__use_8bytes_int') - !! This function is used to know if the library is - !! compiled using integer 8 or 4 bytes long. - logical(kind=c_bool) :: use_8bytes_int - -#ifdef USE_I8 - use_8bytes_int = .true. -#else - use_8bytes_int = .false. -#endif - end function use_8bytes_int - - subroutine memory_init(do_chk, max_Gbytes) - !! Routine used to initialize the memory module. It should - !! be called during the module initialization. - implicit none - - logical :: do_chk !! Switch for memory soft limit - real(rp), intent(in) :: max_Gbytes !! Amount of memory available in bytes - integer(ip) :: my_int !! Integer used only as target for sizeof - real(rp) :: my_real !! Real used only as target for sizeof - logical(lp) :: my_bool - intrinsic :: sizeof - - if(.not. is_init) then - do_chk_limit = do_chk - maxmem = max_Gbytes - usedmem = 0.0 - max_used = 0.0 - size_of_real = sizeof(my_real) - size_of_int = sizeof(my_int) - size_of_logical = sizeof(my_bool) - is_init = .true. - end if - end subroutine memory_init - - function mem_stat(pv) result(mm) - !! Return the current value of maximum used memory, if an - !! argument is present set max_used to that value, otherwise - !! max_used is reset to -1 - implicit none - - real(rp), intent(in), optional :: pv - real(rp) :: mm - - if(.not. is_init) call memory_init(.false., 0.0_rp) - - mm = max_used - if(present(pv)) then - if(max_used < pv) max_used = pv - else - max_used = usedmem - end if - end function - - subroutine r_alloc1(string, len1, v) - !! Allocate a 1-dimensional array of reals - implicit none - - character(len=*), intent(in) :: string - !! Human-readable description string of the allocation - !! operation, just for output purpose. - integer(ip), intent(in) :: len1 - !! Dimension of the vector - real(rp), allocatable, intent(inout) :: v(:) - !! Vector to allocate - - integer(ip) :: istat - - if(.not. is_init) call memory_init(.false., 0.0_rp) - allocate(v(len1), stat=istat) - call chk_alloc(string, len1*size_of_real, istat) - end subroutine r_alloc1 - - subroutine r_alloc2(string, len1, len2, v) - !! Allocate a 2-dimensional array of reals - implicit none - - character(len=*), intent(in) :: string - !! Human-readable description string of the allocation - !! operation, just for output purpose. - integer(ip), intent(in) :: len1, len2 - !! Dimensions of the vector - real(rp), allocatable, intent(inout) :: v(:,:) - !! Vector to allocate - - integer(ip) :: istat - - if(.not. is_init) call memory_init(.false., 0.0_rp) - allocate(v(len1, len2), stat=istat) - call chk_alloc(string, len1*len2*size_of_real, istat) - end subroutine r_alloc2 - - subroutine r_alloc3(string, len1, len2, len3, v) - !! Allocate a 3-dimensional array of reals - implicit none - - character(len=*), intent(in) :: string - !! Human-readable description string of the allocation - !! operation, just for output purpose. - integer(ip), intent(in) :: len1, len2, len3 - !! Dimensions of the vector - real(rp), allocatable, intent(inout) :: v(:,:,:) - !! Vector to allocate - - integer(ip) :: istat - - if(.not. is_init) call memory_init(.false., 0.0_rp) - allocate(v(len1, len2, len3), stat=istat) - call chk_alloc(string, len1*len2*len3*size_of_real, istat) - end subroutine r_alloc3 - - subroutine i_alloc1(string, len1, v) - !! Allocate a 1-dimensional array of integers - implicit none - - character (len=*), intent(in) :: string - !! Human-readable description string of the allocation - !! operation, just for output purpose. - integer(ip), intent(in) :: len1 - !! Dimension of the vector - integer(ip), allocatable, intent(inout) :: v(:) - !! Vector to allocate - - integer(ip) :: istat - - if(.not. is_init) call memory_init(.false., 0.0_rp) - allocate(v(len1), stat=istat) - call chk_alloc(string, len1*size_of_int, istat) - end subroutine i_alloc1 - - subroutine i_alloc2(string, len1, len2, v) - !! Allocate a 2-dimensional array of integers - implicit none - - character (len=*), intent(in) :: string - !! Human-readable description string of the allocation - !! operation, just for output purpose. - integer(ip), intent(in) :: len1, len2 - !! Dimensions of the vector - integer(ip), allocatable, intent(inout) :: v(:,:) - !! Vector to allocate - - integer(ip) :: istat - - if(.not. is_init) call memory_init(.false., 0.0_rp) - allocate(v(len1, len2), stat=istat) - call chk_alloc(string, len1*len2*size_of_int, istat) - end subroutine i_alloc2 - - subroutine i_alloc3(string, len1, len2, len3, v) - !! Allocate a 3-dimensional array of integers - implicit none - - character (len=*), intent(in) :: string - !! Human-readable description string of the allocation - !! operation, just for output purpose. - integer(ip), intent(in) :: len1, len2, len3 - !! Dimensions of the vector - integer(ip), allocatable, intent(inout) :: v(:,:,:) - !! Vector to allocate - - integer(ip) :: istat - - if(.not. is_init) call memory_init(.false., 0.0_rp) - allocate(v(len1, len2, len3), stat=istat) - call chk_alloc(string, len1*len2*len3*size_of_int, istat) - end subroutine i_alloc3 - - subroutine l_alloc1(string, len1, v) - !! Allocate a 1-dimensional array of reals - implicit none - - character(len=*), intent(in) :: string - !! Human-readable description string of the allocation - !! operation, just for output purpose. - integer(ip), intent(in) :: len1 - !! Dimension of the vector - logical(lp), allocatable, intent(inout) :: v(:) - !! Vector to allocate - - integer(ip) :: istat - - if(.not. is_init) call memory_init(.false., 0.0_rp) - allocate(v(len1), stat=istat) - call chk_alloc(string, len1*size_of_logical, istat) - end subroutine l_alloc1 - - subroutine l_alloc2(string, len1, len2, v) - !! Allocate a 2-dimensional array of reals - implicit none - - character(len=*), intent(in) :: string - !! Human-readable description string of the allocation - !! operation, just for output purpose. - integer(ip), intent(in) :: len1, len2 - !! Dimensions of the vector - logical(lp), allocatable, intent(inout) :: v(:,:) - !! Vector to allocate - - integer(ip) :: istat - - if(.not. is_init) call memory_init(.false., 0.0_rp) - allocate(v(len1, len2), stat=istat) - call chk_alloc(string, len1*len2*size_of_logical, istat) - end subroutine l_alloc2 - - subroutine chk_alloc(string, lall, istat) - !! Handles the memory errors (including soft limit) - !! during memory allocation - implicit none - - integer(ip), intent(in) :: lall - !! Amount of allocated memory in bytes - integer(ip), intent(in) :: istat - !! Status flag from allocate() - character(len=*), intent(in) :: string - !! Human-readable description string of the allocation - !! operation, just for output purpose. - - character(len=OMMP_STR_CHAR_MAX) :: msg - !! Message string for errors - - real(rp) :: lall_gb - !! memory allocated in gb - - lall_gb = lall / 1e9 - - if(istat /= 0) then - write(msg, "('Allocation error in subroutine ', a ,'. stat= ', i5)") string, istat - call fatal_error(msg) - else if(do_chk_limit .and. usedmem+lall_gb > maxmem) then - write(msg, "('Allocation error in subroutine ', a ,'. Not enough memory (internal limit ', i8, ' W).')") string, maxmem - call fatal_error(msg) - else - usedmem = usedmem + lall_gb - end if - if(usedmem > max_used) max_used = usedmem - end subroutine chk_alloc - - subroutine r_free1(string, v) - !! Free a 1-dimensional array of reals - - character(len=*), intent(in) :: string - !! Human-readable description string of the deallocation - !! operation, just for output purpose. - real(rp), allocatable, intent(inout) :: v(:) - !! Array to free - - integer(ip) :: istat, ltot - - if(allocated(v)) then - ltot = size(v) * size_of_real - deallocate(v, stat=istat) - call chk_free(string, ltot, istat) - end if - end subroutine r_free1 - - subroutine r_free2(string, v) - !! Free a 2-dimensional array of reals - - character(len=*), intent(in) :: string - !! Human-readable description string of the deallocation - !! operation, just for output purpose. - real(rp), allocatable, intent(inout) :: v(:,:) - !! Array to free - - integer(ip) :: istat, ltot - - if(allocated(v)) then - ltot = size(v) * size_of_real - deallocate(v, stat=istat) - call chk_free(string, ltot, istat) - end if - end subroutine r_free2 - - subroutine r_free3(string, v) - !! Free a 3-dimensional array of reals - - character (len=*), intent(in) :: string - !! Human-readable description string of the deallocation - !! operation, just for output purpose. - real(rp), allocatable, intent(inout) :: v(:,:,:) - !! Array to free - - integer(ip) :: istat, ltot - - if(allocated(v)) then - ltot = size(v) * size_of_real - deallocate(v, stat=istat) - call chk_free(string, ltot, istat) - end if - end subroutine r_free3 - - subroutine i_free1(string, v) - !! Free a 1-dimensional array of integers - - character (len=*), intent(in) :: string - !! Human-readable description string of the deallocation - !! operation, just for output purpose. - integer(ip), allocatable, intent(inout) :: v(:) - !! Array to free - - integer(ip) :: istat, ltot - - if(allocated(v)) then - ltot = size(v) * size_of_int - deallocate(v, stat=istat) - call chk_free(string, ltot, istat) - end if - end subroutine i_free1 - - subroutine i_free2(string, v) - !! Free a 2-dimensional array of integers - - character (len=*), intent(in) :: string - !! Human-readable description string of the deallocation - !! operation, just for output purpose. - integer(ip), allocatable, intent(inout) :: v(:,:) - !! Array to free - - integer(ip) :: istat, ltot - - if(allocated(v)) then - ltot = size(v) * size_of_int - deallocate(v, stat=istat) - call chk_free(string, ltot, istat) - end if - end subroutine i_free2 - - subroutine i_free3(string, v) - !! Free a 3-dimensional array of integers - - character (len=*), intent(in) :: string - !! Human-readable description string of the deallocation - !! operation, just for output purpose. - integer(ip), allocatable, intent(inout) :: v(:,:,:) - !! Array to free - - integer(ip) :: istat, ltot - - if(allocated(v)) then - ltot = size(v) * size_of_int - deallocate (v, stat=istat) - call chk_free(string, ltot, istat) - end if - end subroutine i_free3 - - subroutine l_free1(string, v) - !! Free a 1-dimensional array of integers - - character (len=*), intent(in) :: string - !! Human-readable description string of the deallocation - !! operation, just for output purpose. - logical(lp), allocatable, intent(inout) :: v(:) - !! Array to free - - integer(ip) :: istat, ltot - - if(allocated(v)) then - ltot = size(v) * size_of_logical - deallocate(v, stat=istat) - call chk_free(string, ltot, istat) - end if - end subroutine l_free1 - - subroutine l_free2(string, v) - !! Free a 2-dimensional array of integers - - character (len=*), intent(in) :: string - !! Human-readable description string of the deallocation - !! operation, just for output purpose. - logical(lp), allocatable, intent(inout) :: v(:,:) - !! Array to free - - integer(ip) :: istat, ltot - - if(allocated(v)) then - ltot = size(v) * size_of_logical - deallocate(v, stat=istat) - call chk_free(string, ltot, istat) - end if - end subroutine l_free2 - - subroutine chk_free(string, lfree, istat) - !! Handles the memory errors (including soft limits) - !! during the deallocation - implicit none - - character(len=*), intent(in) :: string - !! Human-readable description string of the deallocation - !! operation, just for output purpose. - integer(ip), intent(in) :: lfree - !! amount of memory (in bytes) to free - integer(ip), intent(in) :: istat - !! return flag of deallocate - - character(len=OMMP_STR_CHAR_MAX) :: msg - !! Message string for errors - - real(rp) :: lfree_gb - !! memory allocated in gb - - lfree_gb = lfree / 1e9 - - if(istat /= 0)then - write(msg, "('Deallocation error in subroutine ', a ,'. stat= ', i5)") string, istat - call fatal_error(msg) - else - usedmem = usedmem - lfree_gb - end if - - end subroutine chk_free - -end module mod_memory diff --git a/src/mod_mmpol.F90 b/src/mod_mmpol.F90 new file mode 100644 index 0000000..4e680e1 --- /dev/null +++ b/src/mod_mmpol.F90 @@ -0,0 +1,751 @@ +module mod_mmpol + !! Main module for the control of openMMPol library. It contains + !! all the scalar and vector (allocatable) quantities needed to + !! build up the atomistic polarizable embedding model and perform + !! the calculation required from the quantum chemical software. + + use mod_memory, only: ip, rp, lp + use mod_adjacency_mat, only: yale_sparse + use mod_topology, only: ommp_topology_type, topology_init, & + topology_terminate + use mod_electrostatics, only: ommp_electrostatics_type + use mod_nonbonded, only: ommp_nonbonded_type + use mod_bonded, only: ommp_bonded_type + use mod_link_atom, only: ommp_link_atom_type + use mod_io, only: ommp_message, fatal_error + use mod_constants, only: OMMP_STR_CHAR_MAX + + implicit none + + type ommp_system + logical :: mmpol_is_init = .false. + !! Initialization flag + integer(ip) :: ff_type + !! Force field type selection flag (0 for AMBER, 1 for AMOEBA) + logical(lp) :: amoeba + !! AMOEBA FF = True; WANG-AMBER = False + + type(ommp_topology_type), allocatable :: top + !! Data structure containing the topology of the system + type(ommp_electrostatics_type), allocatable :: eel + !! Data structure containing all the information needed to run the + !! elctrostatics related calculations + logical(lp) :: use_bonded = .false. + type(ommp_bonded_type), allocatable :: bds + !! Data structure containing all the information needed to run the + !! bonded terms calculations + logical(lp) :: use_nonbonded = .false. + type(ommp_nonbonded_type), allocatable :: vdw + !! Data structure containing all the information needed to run the + !! non-bonded terms calculations + logical(lp) :: use_linkatoms = .false. + type(ommp_link_atom_type), allocatable :: la + !! Data structure containing all the information needed to handle + !! link atoms with a certain QM part described by a QM Helper object + end type ommp_system + +contains + + subroutine mmpol_init(sys_obj, l_ff_type, l_mm_atoms, l_pol_atoms) + !! Performs all the memory allocation and vector initialization + !! needed to run the openMMPol library + + use mod_constants, only: OMMP_FF_AMBER, OMMP_FF_AMOEBA, OMMP_FF_UNKNOWN + use mod_electrostatics, only: electrostatics_init + use mod_io, only: print_matrix, fatal_error + use mod_profiling, only: time_push, time_pull + + implicit none + + type(ommp_system), intent(inout) :: sys_obj + !! The object to be initialized + integer(ip), intent(in) :: l_ff_type + !! Force field type used in initialization + integer(ip), intent(in) :: l_mm_atoms + !! Number of MM atoms used in initialization + integer(ip), intent(in) :: l_pol_atoms + !! Number of polarizable atoms used in initialization + + call time_push() + + !! Allocation topology... + allocate(sys_obj%top) + !! ... and electrostatics + allocate(sys_obj%eel) + + ! FF related settings + if(l_ff_type == OMMP_FF_UNKNOWN) then + call fatal_error("Cannot initialize an UNKNOWN forcefield!") + end if + sys_obj%ff_type = l_ff_type + + if(sys_obj%ff_type == OMMP_FF_AMOEBA) then + sys_obj%amoeba = .true. + else if(sys_obj%ff_type == OMMP_FF_AMBER) then + sys_obj%amoeba = .false. + end if + + ! Initialization of sub-modules: + ! a. topology + call topology_init(sys_obj%top, l_mm_atoms) + ! b. electrostatics + call electrostatics_init(sys_obj%eel, sys_obj%amoeba, l_pol_atoms, & + sys_obj%top) + + ! Everything is done + sys_obj%mmpol_is_init = .true. + call time_pull('MMPol object creation (mmpol_init)') + end subroutine mmpol_init + + subroutine mmpol_init_nonbonded(sys_obj) + !! Enable nonbonded part of pontential + implicit none + + type(ommp_system), intent(inout) :: sys_obj + !! The object to be initialized + + allocate(sys_obj%vdw) + sys_obj%use_nonbonded = .true. + + end subroutine mmpol_init_nonbonded + + subroutine mmpol_init_bonded(sys_obj) + !! Enable nonbonded part of pontential + implicit none + + type(ommp_system), intent(inout), target :: sys_obj + !! The object to be initialized + + allocate(sys_obj%bds) + sys_obj%use_bonded = .true. + sys_obj%bds%top => sys_obj%top + + end subroutine mmpol_init_bonded + + subroutine mmpol_init_link_atom(sys_obj) + !! Enable link atom + implicit none + + type(ommp_system), intent(inout), target :: sys_obj + !! The object to be initialized + + if(sys_obj%use_linkatoms .and. allocated(sys_obj%la)) return + if(allocated(sys_obj%la)) deallocate(sys_obj%la) + + allocate(sys_obj%la) + sys_obj%use_linkatoms = .true. + end subroutine + + subroutine mmpol_prepare(sys_obj) + !! Compute some derived quantities from the input that + !! are used during the calculation. The upstream code have + !! to provide cmm, q, pol, adjacency matrix and in + !! the case of AMOEBA also multipoles rotation information, and + !! polarization group information. + !! This routine + !! * compute connectivity lists from connected atoms + !! * invert polar_mm list creating mm_polar + !! * populate cpol list of coordinates + !! * compute factors for thole damping + !! * scales by 1/3 AMOEBA quadrupoles (?) + !! * Build list for polarization groups, compute groups connectivity + !! * performs multipoles rotation + + use mod_adjacency_mat, only: build_conn_upto_n, matcpy, reverse_grp_tab + use mod_io, only: ommp_message + use mod_profiling, only: time_push, time_pull + use mod_constants, only: OMMP_VERBOSE_DEBUG + use mod_electrostatics, only: thole_init, remove_null_pol, & + make_screening_lists + + implicit none + + type(ommp_system), intent(inout) :: sys_obj + !! The system object to bi initialized + + integer(ip) :: i + + type(yale_sparse) :: adj, pg_adj + + call time_push() + call ommp_message("Building connectivity lists", OMMP_VERBOSE_DEBUG) + + ! compute connectivity lists from connected atoms + if(size(sys_obj%top%conn) < 4) then + call matcpy(sys_obj%top%conn(1), adj) + deallocate(sys_obj%top%conn) + call build_conn_upto_n(adj, 4, sys_obj%top%conn, .false.) + end if + + call remove_null_pol(sys_obj%eel) + + ! invert mm_polar list creating mm_polar + sys_obj%eel%mm_polar(:) = 0 + if(sys_obj%eel%pol_atoms > 0) then + call ommp_message("Creating MM->polar and polar->MM lists", & + OMMP_VERBOSE_DEBUG) + !$omp parallel do default(shared) private(i) + do i = 1, sys_obj%eel%pol_atoms + sys_obj%eel%mm_polar(sys_obj%eel%polar_mm(i)) = i + end do + + call ommp_message("Populating coordinates of polarizable atoms", & + OMMP_VERBOSE_DEBUG) + ! populate cpol list of coordinates + !$omp parallel do default(shared) private(i) + do i = 1, sys_obj%eel%pol_atoms + sys_obj%eel%cpol(:,i) = sys_obj%top%cmm(:, sys_obj%eel%polar_mm(i)) + end do + + call ommp_message("Setting Thole factors", OMMP_VERBOSE_DEBUG) + ! compute factors for thole damping + call thole_init(sys_obj%eel) + else + sys_obj%eel%thole = 0.0 + end if + + if(sys_obj%amoeba) then + ! Copy multipoles from q to q0 + sys_obj%eel%q0 = sys_obj%eel%q + + ! scales by 1/3 AMOEBA quadrupoles (?) + ! Mysterious division of multipoles by three + ! FL told me that it was done like that in + ! Tinker + sys_obj%eel%q0(5:10,:) = sys_obj%eel%q0(5:10,:) / 3.0_rp + + ! polarization groups connectivity list + call reverse_grp_tab(sys_obj%eel%mmat_polgrp, & + sys_obj%eel%polgrp_mmat) + call build_pg_adjacency_matrix(sys_obj%eel, pg_adj) + call build_conn_upto_n(pg_adj, 3, sys_obj%eel%pg_conn, .true.) + + ! performs multipoles rotation + call rotate_multipoles(sys_obj%eel) + end if + + call ommp_message("Building screening lists", OMMP_VERBOSE_DEBUG) + call time_push() + call make_screening_lists(sys_obj%eel) + call time_pull("Preparing screening lists") + call ommp_message("MMPol initialization (mmpol_prepare) completed.", OMMP_VERBOSE_DEBUG) + call time_pull('MMPol object initialization (mmpol_prepare)') + end subroutine mmpol_prepare + + subroutine mmpol_terminate(sys_obj) + !! Performs all the deallocation needed at the end of the + !! calculation + use mod_memory, only: mfree + use mod_electrostatics, only: electrostatics_terminate + use mod_nonbonded, only: vdw_terminate + use mod_bonded, only: bonded_terminate + + implicit none + + type(ommp_system), intent(inout) :: sys_obj + + call electrostatics_terminate(sys_obj%eel) + deallocate(sys_obj%eel) + + call topology_terminate(sys_obj%top) + deallocate(sys_obj%top) + + if(sys_obj%use_nonbonded) then + call vdw_terminate(sys_obj%vdw) + sys_obj%use_nonbonded = .false. + end if + + if(sys_obj%use_bonded) then + call bonded_terminate(sys_obj%bds) + sys_obj%use_bonded = .false. + end if + + sys_obj%mmpol_is_init = .false. + + end subroutine mmpol_terminate + + !TODO move to eel module + subroutine build_pg_adjacency_matrix(eel, adj) + !! Builds the adjacency matrix of polarization groups starting from + !! atomic adjacency matrix and list of polarization groups indices. + + use mod_adjacency_mat, only: reallocate_mat + + implicit none + + type(ommp_electrostatics_type), intent(in) :: eel + type(yale_sparse), intent(out) :: adj + !! The group adjacency matrix to be saved. + + integer(ip) :: npg, pg1, atm1, atm2, i, j + + npg = eel%polgrp_mmat%n + + adj%n = npg + allocate(adj%ri(adj%n+1)) + allocate(adj%ci(adj%n*2)) + adj%ri(1) = 1 + + do pg1=1, npg + ! For each polarization group + adj%ri(pg1+1) = adj%ri(pg1) + + do i=eel%polgrp_mmat%ri(pg1), eel%polgrp_mmat%ri(pg1+1)-1 + ! Loop on every atom of the group + atm1 = eel%polgrp_mmat%ci(i) + do j=eel%top%conn(1)%ri(atm1), eel%top%conn(1)%ri(atm1+1)-1 + ! Loop on each connected atom... + atm2 = eel%top%conn(1)%ci(j) + + ! If the two atoms are in different PG, then the two + ! polarization groups are connected. + if(eel%mmat_polgrp(atm1) /= eel%mmat_polgrp(atm2) .and. & + ! if the group is not already present in the matrix + all(adj%ci(adj%ri(pg1):adj%ri(pg1+1)-1) /= eel%mmat_polgrp(atm2))) then + adj%ci(adj%ri(pg1+1)) = eel%mmat_polgrp(atm2) + adj%ri(pg1+1) = adj%ri(pg1+1) + 1 + if(adj%ri(pg1+1) > size(adj%ci)) then + ! If matrix is too small, it could be enlarged... + call reallocate_mat(adj, size(adj%ci)+adj%n) + end if + end if + end do + end do + end do + + ! Finally trim the output matrix + call reallocate_mat(adj, adj%ri(adj%n+1)-1) + + end subroutine build_pg_adjacency_matrix + + subroutine update_coordinates(sys_obj, new_c) + !! Interface to change the coordinates of the system (eg. during a + !! MD or a geometry optimization). This function clears all the + !! relevant, flags and update the needed quantities. All those + !! operations are needed for a correct functionality of the program + !! therefore coordinates should never be updated without passing from + !! this interface. + + use mod_memory, only: mfree + use mod_link_atom, only: link_atom_update_merged_topology + implicit none + + type(ommp_system), intent(inout), target :: sys_obj + !! System data structure + real(rp), dimension(3,sys_obj%top%mm_atoms), intent(in) :: new_c + !! New coordinates to be updated + + type(ommp_topology_type), pointer :: top + type(ommp_electrostatics_type), pointer :: eel + integer(ip) :: i + + top => sys_obj%top + eel => sys_obj%eel + + ! 1. Copy coordinates + top%cmm = new_c + + ! 2. Update electrostatics module + ! 2.1 Coordinates + do i=1, eel%pol_atoms + eel%cpol(:,i) = top%cmm(:,eel%polar_mm(i)) + end do + ! 2.2 Flags and allocated quantities + eel%M2M_done = .false. + eel%M2Mgg_done = .false. + eel%M2D_done = .false. + eel%M2Dgg_done = .false. + eel%ipd_done = .false. + eel%ipd_use_guess = .false. + if(allocated(eel%TMat)) call mfree('update_coordinates [TMat]',eel%TMat) + ! 2.3 Multipoles rotation + if(sys_obj%amoeba) call rotate_multipoles(sys_obj%eel) + ! 2.3 Update coordinates inside link atom object + if(sys_obj%use_linkatoms) call link_atom_update_merged_topology(sys_obj%la) + end subroutine + + + subroutine mmpol_ommp_print_summary(sys_obj, of_name) + !! Prints a complete summary of all the quantities stored + !! in the MMPol module + use mod_memory, only: mallocate, mfree + use mod_io, only: iof_mmpol, print_matrix, print_int_vec + use mod_utils, only: sort_ivec + + implicit none + + type(ommp_system), intent(in) :: sys_obj + character(len=*), intent(in), optional :: of_name + + integer(ip) :: of_unit + + integer(ip) :: i, j, grp, igrp, lst(1000), ilst + real(rp), allocatable :: polar(:) ! Polarizabilities of all atoms + integer(ip), allocatable :: tmp(:) + character(len=OMMP_STR_CHAR_MAX) :: str + + if(present(of_name)) then + of_unit = 101 + open(unit=of_unit, & + file=of_name(1:len(trim(of_name))), & + action='write') + else + of_unit = iof_mmpol + end if + + call mallocate('mmpol_ommp_print_summary [polar]', & + sys_obj%top%mm_atoms, polar) + polar = 0.0_rp + do i=1, sys_obj%eel%pol_atoms + polar(sys_obj%eel%polar_mm(i)) = sys_obj%eel%pol(i) + end do + + write(of_unit, '(A, 4F8.4)') 'mscale: ', sys_obj%eel%mscale + if(sys_obj%eel%pol_atoms > 0) then + write(of_unit, '(A, 4F8.4)') 'pscale: ', sys_obj%eel%pscale + if(sys_obj%amoeba) write(of_unit, '(A, 4F8.4)') 'pscale (intra): ', & + sys_obj%eel%pscale_intra + write(of_unit, '(A, 4F8.4)') 'dscale: ', sys_obj%eel%dscale + write(of_unit, '(A, 4F8.4)') 'uscale: ', sys_obj%eel%uscale + end if + + call print_matrix(.true., 'coordinates:', sys_obj%top%cmm, of_unit) + if(sys_obj%amoeba) then + call print_matrix(.true., 'multipoles - non rotated:', & + sys_obj%eel%q0, of_unit) + end if + call print_matrix(.true., 'multipoles :', sys_obj%eel%q, of_unit) + call print_matrix(.true., 'coordinates of polarizable atoms:', & + sys_obj%eel%cpol, of_unit) + call print_matrix(.false., 'polarizabilities:', polar, of_unit) + call print_matrix(.false., 'thole factors:', sys_obj%eel%thole, of_unit) + call print_int_vec('mm_polar list:', sys_obj%eel%mm_polar, & + of_unit) + call print_int_vec('polar_mm list:', sys_obj%eel%polar_mm, & + of_unit) + + ! write the connectivity information for each atom: +1000 format(t3,'connectivity information for the ',i8,'-th atom:') + + do i = 1, sys_obj%top%mm_atoms + write(of_unit, 1000) i + + do j=1, 4 + if(j == 4 .and. .not. sys_obj%amoeba) cycle + + write(str, "('1-', I1, ' neighors:')") j+1 + call sort_ivec(sys_obj%top%conn(j)%ci(& + sys_obj%top%conn(j)%ri(i):& + sys_obj%top%conn(j)%ri(i+1)-1), tmp) + call print_int_vec(trim(str), tmp, of_unit) + end do + + if(sys_obj%amoeba) then + do j=1, 4 + ilst = 1 + do igrp = & + sys_obj%eel%pg_conn(j)%ri(sys_obj%eel%mmat_polgrp(i)), & + sys_obj%eel%pg_conn(j)%ri(sys_obj%eel%mmat_polgrp(i)+1)-1 + + grp = sys_obj%eel%pg_conn(j)%ci(igrp) + lst(ilst:ilst+sys_obj%eel%polgrp_mmat%ri(grp+1) - & + sys_obj%eel%polgrp_mmat%ri(grp)-1) = & + sys_obj%eel%polgrp_mmat%ci(& + sys_obj%eel%polgrp_mmat%ri(grp):& + sys_obj%eel%polgrp_mmat%ri(grp+1)-1) + + ilst = ilst+& + sys_obj%eel%polgrp_mmat%ri(grp+1)- & + sys_obj%eel%polgrp_mmat%ri(grp) + end do + + write(str, "('1-', I1, ' polarization neighors:')") j + if(ilst == 1) ilst = 0 + call sort_ivec(lst(1:ilst-1), tmp) + ! needed to addres the empty array case + call print_int_vec(trim(str), tmp, of_unit) + end do + end if + end do + + if(present(of_name)) close(of_unit) + + if(allocated(tmp)) & + call mfree('mmpol_ommp_print_summary [tmp]', tmp) + call mfree('mmpol_ommp_print_summary [polar]', polar) + + end subroutine mmpol_ommp_print_summary + + + subroutine mmpol_save_as_mmp(sys_obj, of_name, r_version) + !! Save the loaded system in mmpol format. Only the electrostatic part + !! is saved, everything else is just ignored. Version 2 and 3 of the + !! mmp format are supported, 3 is used as default. + + use mod_io, only: ommp_message + use mod_constants, only: mscale_wang_al, & + pscale_wang_al, & + dscale_wang_al, & + uscale_wang_al, & + mscale_wang_dl, & + pscale_wang_dl, & + dscale_wang_dl, & + uscale_wang_dl, & + eps_rp, angstrom2au + + implicit none + + type(ommp_system), target, intent(in) :: sys_obj + !! System data structure to be saved + character(len=*), intent(in) :: of_name + !! Name of the output file + integer(ip), intent(in), optional :: r_version + !! Revision version requested for .mmp + + integer(ip) :: of_unit, version, i, jb, je, igrp, inta(120) + type(ommp_electrostatics_type), pointer :: eel + type(ommp_topology_type), pointer :: top + + eel => sys_obj%eel + top => sys_obj%top + + if(.not. sys_obj%mmpol_is_init) then + call fatal_error('OpenMMPol is not initialized, cannot save .mmp & + &file.') + end if + + if(present(r_version)) then + version = r_version + else + version = 3 + end if + + of_unit = 101 + open(unit=of_unit, & + file=of_name(1:len(trim(of_name))), & + action='write') + ! 1. Integer, revision number used to check if the MMPol.mmp file is + ! consistent with the Gaussian version being used + if(version == 2 .or. version == 3) then + write(of_unit, '(I0,T2)') version + else + call fatal_error("Requested version of .mmp file is not supported & + &by openMMPol") + end if + + ! 2. Integer, MMPol job type: + ! + ! 0: for a QM/MM calculation ( + ! 1: for a Tinker QM/MM calculation + ! 2: for a QM/MM electronic energy transfer (EET) calculation + write(of_unit, '(I0,T2)') 0 + + ! 3. Integer, verbosity flag + write(of_unit, '(I0,T2)') 3 + + ! 4. Integer, force field type: + ! + ! 0: Amber-like + ! 1: AMOEBA-like + if(sys_obj%amoeba) then + write(of_unit, '(I0,T2)') 1 + else + write(of_unit, '(I0,T2)') 0 + end if + + ! 5. Integer, force field sub-type. For AMBER: + ! + ! 0: AMBER Wang-AL + ! 1: AMBER Wang-DL + ! 2: AMBER Thole + ! 0: AMOEBA + if(sys_obj%amoeba) then + write(of_unit, '(I0,T2)') 0 + else + if(all(abs(eel%mscale-mscale_wang_al) < eps_rp) .and. & + all(abs(eel%pscale-pscale_wang_al) < eps_rp) .and. & + all(abs(eel%dscale-dscale_wang_al) < eps_rp) .and. & + all(abs(eel%uscale-uscale_wang_al) < eps_rp)) then + write(of_unit, '(I0,T2)') 0 + else if(all(abs(eel%mscale-mscale_wang_dl) < eps_rp) .and. & + all(abs(eel%pscale-pscale_wang_dl) < eps_rp) .and. & + all(abs(eel%dscale-dscale_wang_dl) < eps_rp) .and. & + all(abs(eel%uscale-uscale_wang_dl) < eps_rp)) then + write(of_unit, '(I0,T2)') 1 + else + call fatal_error("The scaling scheme used is non-standard and & + &therefore cannot be saved in .mmp format") + end if + end if + + ! 6. Integer, disabled flag + write(of_unit, '(I0,T2)') 0 + + ! 7. Real, damping parameter for the dipole-dipole interactions + ! (Angstrom) + write(of_unit, '(F16.8)') 0.0 + + ! 8. Integer, solution method for the polarization equations + ! (suggested 3): + ! + ! 0: default, same as 3 + ! 1: matrix inversion + ! 2: iterative using Jacobi/DIIS + ! 3: iterative using preconditioned CG solver + write(of_unit, '(I0,T2)') 0 + + ! 9. Integer, how to compute the matrix/vector products for + ! MMPol (suggested 3): + ! + ! 0: default (1 for matrix inversion, 3 for iterative) + ! 1: assemble the matrix incore + ! 2: on-the-fly products with O(N^2) scaling + ! 3: on-the-fly products with the use of FMM if the system is large enough + ! 4: on-the-fly products with the use of FMM in all cases + write(of_unit, '(I0,T2)') 0 + + ! 10. Integer, convergence threshold (10^-N) for the iterative + ! solvers (suggested 8) + write(of_unit, '(I0,T2)') 8 + + ! 11. Integer, accuracy of the FMM calculations (suggested 0): + ! + ! <0: 10^-5 RMS 10^-4 Max Error + ! 0: 10^-6 RMS 10^-5 Max Error + ! 1: 10^-7 RMS 10^-6 Max Error + ! >2: maximum accuracy + write(of_unit, '(I0,T2)') 0 + + ! 12. Real, FMM box size for MM interactions (Angstrom) (suggested 12.0) + write(of_unit, '(F16.8)') 12.0 + + ! 13. Real, FMM box size for MM/PCM interactions (Angstrom) + ! (suggested 6.0) + if(version == 3) then + write(of_unit, '(F16.8)') 6.0 + end if + + ! 14. Integer, continuum solvation model: + ! + ! 0: no continuum solvation model + ! 1: ddCOSMO + ! 2: ddPCM + write(of_unit, '(I0,T2)') 0 + + ! 15. Integer, maximum angular momentum for PCM (suggested 10) + write(of_unit, '(I0,T2)') 10 + + ! 16. Integer, number of Lebedev integration points for PCM + ! (suggested 302) + write(of_unit, '(I0,T2)') 302 + + ! 17. Integer, convergence threshold (10^-N) for the PCM + ! iterative solvers (suggested 8) + write(of_unit, '(I0,T2)') 8 + + ! 18. Real, dielectric constant of the solvent for PCM (78.3 for water) + write(of_unit, '(F16.8)') 78.3 + + ! 19. Real, optical dielectric constant of the solvent for PCM + ! (1.7 for water) + if(version == 3) then + write(of_unit, '(F16.8)') 0.00 + end if + + ! 20. Real, relative size of the switching region for PCM + ! (suggested 0.1) + write(of_unit, '(F16.8)') 0.1 + + ! 21. Integer, cavity type for PCM (suggested 3): + ! + ! 0: default, same as 3 + ! 1: SAS cavity using UFF radii plus the probe radius + ! 2: Read the cavity from the input file + ! (the input must contain at least one sphere per atom) + ! 3: VdW cavity using Bondi's radii scaled by 1.1 + ! 4: SAS cavity using Bondi's radii plus the probe radius + write(of_unit, '(I0,T2)') 0 + + ! 22. Real, probe radius for the SAS cavity (Angstrom) (1.4 for water) + write(of_unit, '(F16.8)') 1.4 + + ! 23. Integer, number of MM atoms + write(of_unit, '(I0,T2)') top%mm_atoms + + ! 24. Integer, number of spheres composing the cavity. + ! Mandatory if the cavity type is 2, additional spheres + ! if the cavity is automatically built. + write(of_unit, '(I0,T2)') 0 + + ! 25. Integer array, size (N): atomic numbers + if(top%atz_initialized) then + do i=1, top%mm_atoms + write(of_unit, '(I0,T2)') top%atz(i) + end do + else + do i=1, top%mm_atoms + write(of_unit, '(I0,T2)') 1 + end do + end if + + + ! 26. Real array, size (N, 3): coordinates + do i=1, top%mm_atoms + write(of_unit, '(3F16.8)') top%cmm(:,i) / angstrom2au + end do + + ! 27. Integer array, size (N): residue numbers + do i=1, top%mm_atoms + write(of_unit, '(I0,T2)') 1 + end do + + ! 28. Real array, size (N): charges or fiixed multipoles + do i=1, top%mm_atoms + if(sys_obj%amoeba) then + write(of_unit, '(10F16.8)') eel%q0(:,i) * [1.0, & !q + 1.0, 1.0, 1.0, & !mu + 3.0, 3.0, 3.0, & ! Q + 3.0, 3.0, 3.0] ! Q + + else + write(of_unit, '(F16.8)') eel%q(:,i) + end if + end do + + ! 29. Real array, size (N): polarizabilities + do i=1, top%mm_atoms + if(eel%mm_polar(i) > 0) then + write(of_unit, '(F16.8)') eel%pol(i) / (angstrom2au**3) + else + write(of_unit, '(F16.8)') 0.0 + end if + end do + + ! 30. Integer array, size (N, 8): connectivity matrix + do i=1, top%mm_atoms + jb = top%conn(1)%ri(i) + je = top%conn(1)%ri(i+1)-1 + inta(1:8) = 0 + inta(1:je-jb+1) = top%conn(1)%ci(jb:je) + write(of_unit, '(8I8)') inta(1:8) + end do + + ! 31. Integer array, size (N, 120): polarization group members + do i=1, top%mm_atoms + igrp = eel%mmat_polgrp(i) + jb=eel%polgrp_mmat%ri(igrp) + je=eel%polgrp_mmat%ri(igrp+1)-1 + inta = 0 + inta(1:je-jb+1) = eel%polgrp_mmat%ci(jb:je) + write(of_unit, '(120I8)') inta + end do + ! 32. Integer array, size (N, 4): rotation conventions and + ! reference atoms for the AMOEBA multipoles + do i=1, top%mm_atoms + write(of_unit, '(4I8)') eel%mol_frame(i), eel%iz(i), eel%ix(i), & + eel%iy(i) + end do + + end subroutine mmpol_save_as_mmp + +end module mod_mmpol diff --git a/src/mod_mmpol.f90 b/src/mod_mmpol.f90 deleted file mode 100644 index a643ab0..0000000 --- a/src/mod_mmpol.f90 +++ /dev/null @@ -1,751 +0,0 @@ -module mod_mmpol - !! Main module for the control of openMMPol library. It contains - !! all the scalar and vector (allocatable) quantities needed to - !! build up the atomistic polarizable embedding model and perform - !! the calculation required from the quantum chemical software. - - use mod_memory, only: ip, rp, lp - use mod_adjacency_mat, only: yale_sparse - use mod_topology, only: ommp_topology_type, topology_init, & - topology_terminate - use mod_electrostatics, only: ommp_electrostatics_type - use mod_nonbonded, only: ommp_nonbonded_type - use mod_bonded, only: ommp_bonded_type - use mod_link_atom, only: ommp_link_atom_type - use mod_io, only: ommp_message, fatal_error - use mod_constants, only: OMMP_STR_CHAR_MAX - - implicit none - - type ommp_system - logical :: mmpol_is_init = .false. - !! Initialization flag - integer(ip) :: ff_type - !! Force field type selection flag (0 for AMBER, 1 for AMOEBA) - logical(lp) :: amoeba - !! AMOEBA FF = True; WANG-AMBER = False - - type(ommp_topology_type), allocatable :: top - !! Data structure containing the topology of the system - type(ommp_electrostatics_type), allocatable :: eel - !! Data structure containing all the information needed to run the - !! elctrostatics related calculations - logical(lp) :: use_bonded = .false. - type(ommp_bonded_type), allocatable :: bds - !! Data structure containing all the information needed to run the - !! bonded terms calculations - logical(lp) :: use_nonbonded = .false. - type(ommp_nonbonded_type), allocatable :: vdw - !! Data structure containing all the information needed to run the - !! non-bonded terms calculations - logical(lp) :: use_linkatoms = .false. - type(ommp_link_atom_type), allocatable :: la - !! Data structure containing all the information needed to handle - !! link atoms with a certain QM part described by a QM Helper object - end type ommp_system - - contains - - subroutine mmpol_init(sys_obj, l_ff_type, l_mm_atoms, l_pol_atoms) - !! Performs all the memory allocation and vector initialization - !! needed to run the openMMPol library - - use mod_constants, only: OMMP_FF_AMBER, OMMP_FF_AMOEBA, OMMP_FF_UNKNOWN - use mod_electrostatics, only: electrostatics_init - use mod_io, only: print_matrix, fatal_error - use mod_profiling, only: time_push, time_pull - - implicit none - - type(ommp_system), intent(inout) :: sys_obj - !! The object to be initialized - integer(ip), intent(in) :: l_ff_type - !! Force field type used in initialization - integer(ip), intent(in) :: l_mm_atoms - !! Number of MM atoms used in initialization - integer(ip), intent(in) :: l_pol_atoms - !! Number of polarizable atoms used in initialization - - call time_push() - - !! Allocation topology... - allocate(sys_obj%top) - !! ... and electrostatics - allocate(sys_obj%eel) - - ! FF related settings - if(l_ff_type == OMMP_FF_UNKNOWN) then - call fatal_error("Cannot initialize an UNKNOWN forcefield!") - end if - sys_obj%ff_type = l_ff_type - - if(sys_obj%ff_type == OMMP_FF_AMOEBA) then - sys_obj%amoeba = .true. - else if(sys_obj%ff_type == OMMP_FF_AMBER) then - sys_obj%amoeba = .false. - end if - - ! Initialization of sub-modules: - ! a. topology - call topology_init(sys_obj%top, l_mm_atoms) - ! b. electrostatics - call electrostatics_init(sys_obj%eel, sys_obj%amoeba, l_pol_atoms, & - sys_obj%top) - - ! Everything is done - sys_obj%mmpol_is_init = .true. - call time_pull('MMPol object creation (mmpol_init)') - end subroutine mmpol_init - - subroutine mmpol_init_nonbonded(sys_obj) - !! Enable nonbonded part of pontential - implicit none - - type(ommp_system), intent(inout) :: sys_obj - !! The object to be initialized - - allocate(sys_obj%vdw) - sys_obj%use_nonbonded = .true. - - end subroutine mmpol_init_nonbonded - - subroutine mmpol_init_bonded(sys_obj) - !! Enable nonbonded part of pontential - implicit none - - type(ommp_system), intent(inout), target :: sys_obj - !! The object to be initialized - - allocate(sys_obj%bds) - sys_obj%use_bonded = .true. - sys_obj%bds%top => sys_obj%top - - end subroutine mmpol_init_bonded - - subroutine mmpol_init_link_atom(sys_obj) - !! Enable link atom - implicit none - - type(ommp_system), intent(inout), target :: sys_obj - !! The object to be initialized - - if(sys_obj%use_linkatoms .and. allocated(sys_obj%la)) return - if(allocated(sys_obj%la)) deallocate(sys_obj%la) - - allocate(sys_obj%la) - sys_obj%use_linkatoms = .true. - end subroutine - - subroutine mmpol_prepare(sys_obj) - !! Compute some derived quantities from the input that - !! are used during the calculation. The upstream code have - !! to provide cmm, q, pol, adjacency matrix and in - !! the case of AMOEBA also multipoles rotation information, and - !! polarization group information. - !! This routine - !! * compute connectivity lists from connected atoms - !! * invert polar_mm list creating mm_polar - !! * populate cpol list of coordinates - !! * compute factors for thole damping - !! * scales by 1/3 AMOEBA quadrupoles (?) - !! * Build list for polarization groups, compute groups connectivity - !! * performs multipoles rotation - - use mod_adjacency_mat, only: build_conn_upto_n, matcpy, reverse_grp_tab - use mod_io, only: ommp_message - use mod_profiling, only: time_push, time_pull - use mod_constants, only: OMMP_VERBOSE_DEBUG - use mod_electrostatics, only: thole_init, remove_null_pol, & - make_screening_lists - - implicit none - - type(ommp_system), intent(inout) :: sys_obj - !! The system object to bi initialized - - integer(ip) :: i - - type(yale_sparse) :: adj, pg_adj - - call time_push() - call ommp_message("Building connectivity lists", OMMP_VERBOSE_DEBUG) - - ! compute connectivity lists from connected atoms - if(size(sys_obj%top%conn) < 4) then - call matcpy(sys_obj%top%conn(1), adj) - deallocate(sys_obj%top%conn) - call build_conn_upto_n(adj, 4, sys_obj%top%conn, .false.) - end if - - call remove_null_pol(sys_obj%eel) - - ! invert mm_polar list creating mm_polar - sys_obj%eel%mm_polar(:) = 0 - if(sys_obj%eel%pol_atoms > 0) then - call ommp_message("Creating MM->polar and polar->MM lists", & - OMMP_VERBOSE_DEBUG) - !$omp parallel do default(shared) private(i) - do i = 1, sys_obj%eel%pol_atoms - sys_obj%eel%mm_polar(sys_obj%eel%polar_mm(i)) = i - end do - - call ommp_message("Populating coordinates of polarizable atoms", & - OMMP_VERBOSE_DEBUG) - ! populate cpol list of coordinates - !$omp parallel do default(shared) private(i) - do i = 1, sys_obj%eel%pol_atoms - sys_obj%eel%cpol(:,i) = sys_obj%top%cmm(:, sys_obj%eel%polar_mm(i)) - end do - - call ommp_message("Setting Thole factors", OMMP_VERBOSE_DEBUG) - ! compute factors for thole damping - call thole_init(sys_obj%eel) - else - sys_obj%eel%thole = 0.0 - end if - - if(sys_obj%amoeba) then - ! Copy multipoles from q to q0 - sys_obj%eel%q0 = sys_obj%eel%q - - ! scales by 1/3 AMOEBA quadrupoles (?) - ! Mysterious division of multipoles by three - ! FL told me that it was done like that in - ! Tinker - sys_obj%eel%q0(5:10,:) = sys_obj%eel%q0(5:10,:) / 3.0_rp - - ! polarization groups connectivity list - call reverse_grp_tab(sys_obj%eel%mmat_polgrp, & - sys_obj%eel%polgrp_mmat) - call build_pg_adjacency_matrix(sys_obj%eel, pg_adj) - call build_conn_upto_n(pg_adj, 3, sys_obj%eel%pg_conn, .true.) - - ! performs multipoles rotation - call rotate_multipoles(sys_obj%eel) - end if - - call ommp_message("Building screening lists", OMMP_VERBOSE_DEBUG) - call time_push() - call make_screening_lists(sys_obj%eel) - call time_pull("Preparing screening lists") - call ommp_message("MMPol initialization (mmpol_prepare) completed.", OMMP_VERBOSE_DEBUG) - call time_pull('MMPol object initialization (mmpol_prepare)') - end subroutine mmpol_prepare - - subroutine mmpol_terminate(sys_obj) - !! Performs all the deallocation needed at the end of the - !! calculation - use mod_memory, only: mfree - use mod_electrostatics, only: electrostatics_terminate - use mod_nonbonded, only: vdw_terminate - use mod_bonded, only: bonded_terminate - - implicit none - - type(ommp_system), intent(inout) :: sys_obj - - call electrostatics_terminate(sys_obj%eel) - deallocate(sys_obj%eel) - - call topology_terminate(sys_obj%top) - deallocate(sys_obj%top) - - if(sys_obj%use_nonbonded) then - call vdw_terminate(sys_obj%vdw) - sys_obj%use_nonbonded = .false. - end if - - if(sys_obj%use_bonded) then - call bonded_terminate(sys_obj%bds) - sys_obj%use_bonded = .false. - end if - - sys_obj%mmpol_is_init = .false. - - end subroutine mmpol_terminate - - !TODO move to eel module - subroutine build_pg_adjacency_matrix(eel, adj) - !! Builds the adjacency matrix of polarization groups starting from - !! atomic adjacency matrix and list of polarization groups indices. - - use mod_adjacency_mat, only: reallocate_mat - - implicit none - - type(ommp_electrostatics_type), intent(in) :: eel - type(yale_sparse), intent(out) :: adj - !! The group adjacency matrix to be saved. - - integer(ip) :: npg, pg1, atm1, atm2, i, j - - npg = eel%polgrp_mmat%n - - adj%n = npg - allocate(adj%ri(adj%n+1)) - allocate(adj%ci(adj%n*2)) - adj%ri(1) = 1 - - do pg1=1, npg - ! For each polarization group - adj%ri(pg1+1) = adj%ri(pg1) - - do i=eel%polgrp_mmat%ri(pg1), eel%polgrp_mmat%ri(pg1+1)-1 - ! Loop on every atom of the group - atm1 = eel%polgrp_mmat%ci(i) - do j=eel%top%conn(1)%ri(atm1), eel%top%conn(1)%ri(atm1+1)-1 - ! Loop on each connected atom... - atm2 = eel%top%conn(1)%ci(j) - - ! If the two atoms are in different PG, then the two - ! polarization groups are connected. - if(eel%mmat_polgrp(atm1) /= eel%mmat_polgrp(atm2) .and. & - ! if the group is not already present in the matrix - all(adj%ci(adj%ri(pg1):adj%ri(pg1+1)-1) /= eel%mmat_polgrp(atm2))) then - adj%ci(adj%ri(pg1+1)) = eel%mmat_polgrp(atm2) - adj%ri(pg1+1) = adj%ri(pg1+1) + 1 - if(adj%ri(pg1+1) > size(adj%ci)) then - ! If matrix is too small, it could be enlarged... - call reallocate_mat(adj, size(adj%ci)+adj%n) - end if - end if - end do - end do - end do - - ! Finally trim the output matrix - call reallocate_mat(adj, adj%ri(adj%n+1)-1) - - end subroutine build_pg_adjacency_matrix - - subroutine update_coordinates(sys_obj, new_c) - !! Interface to change the coordinates of the system (eg. during a - !! MD or a geometry optimization). This function clears all the - !! relevant, flags and update the needed quantities. All those - !! operations are needed for a correct functionality of the program - !! therefore coordinates should never be updated without passing from - !! this interface. - - use mod_memory, only: mfree - use mod_link_atom, only: link_atom_update_merged_topology - implicit none - - type(ommp_system), intent(inout), target :: sys_obj - !! System data structure - real(rp), dimension(3,sys_obj%top%mm_atoms), intent(in) :: new_c - !! New coordinates to be updated - - type(ommp_topology_type), pointer :: top - type(ommp_electrostatics_type), pointer :: eel - integer(ip) :: i - - top => sys_obj%top - eel => sys_obj%eel - - ! 1. Copy coordinates - top%cmm = new_c - - ! 2. Update electrostatics module - ! 2.1 Coordinates - do i=1, eel%pol_atoms - eel%cpol(:,i) = top%cmm(:,eel%polar_mm(i)) - end do - ! 2.2 Flags and allocated quantities - eel%M2M_done = .false. - eel%M2Mgg_done = .false. - eel%M2D_done = .false. - eel%M2Dgg_done = .false. - eel%ipd_done = .false. - eel%ipd_use_guess = .false. - if(allocated(eel%TMat)) call mfree('update_coordinates [TMat]',eel%TMat) - ! 2.3 Multipoles rotation - if(sys_obj%amoeba) call rotate_multipoles(sys_obj%eel) - ! 2.3 Update coordinates inside link atom object - if(sys_obj%use_linkatoms) call link_atom_update_merged_topology(sys_obj%la) - end subroutine - - - subroutine mmpol_ommp_print_summary(sys_obj, of_name) - !! Prints a complete summary of all the quantities stored - !! in the MMPol module - use mod_memory, only: mallocate, mfree - use mod_io, only: iof_mmpol, print_matrix, print_int_vec - use mod_utils, only: sort_ivec - - implicit none - - type(ommp_system), intent(in) :: sys_obj - character(len=*), intent(in), optional :: of_name - - integer(ip) :: of_unit - - integer(ip) :: i, j, grp, igrp, lst(1000), ilst - real(rp), allocatable :: polar(:) ! Polarizabilities of all atoms - integer(ip), allocatable :: tmp(:) - character(len=OMMP_STR_CHAR_MAX) :: str - - if(present(of_name)) then - of_unit = 101 - open(unit=of_unit, & - file=of_name(1:len(trim(of_name))), & - action='write') - else - of_unit = iof_mmpol - end if - - call mallocate('mmpol_ommp_print_summary [polar]', & - sys_obj%top%mm_atoms, polar) - polar = 0.0_rp - do i=1, sys_obj%eel%pol_atoms - polar(sys_obj%eel%polar_mm(i)) = sys_obj%eel%pol(i) - end do - - write(of_unit, '(A, 4F8.4)') 'mscale: ', sys_obj%eel%mscale - if(sys_obj%eel%pol_atoms > 0) then - write(of_unit, '(A, 4F8.4)') 'pscale: ', sys_obj%eel%pscale - if(sys_obj%amoeba) write(of_unit, '(A, 4F8.4)') 'pscale (intra): ', & - sys_obj%eel%pscale_intra - write(of_unit, '(A, 4F8.4)') 'dscale: ', sys_obj%eel%dscale - write(of_unit, '(A, 4F8.4)') 'uscale: ', sys_obj%eel%uscale - end if - - call print_matrix(.true., 'coordinates:', sys_obj%top%cmm, of_unit) - if(sys_obj%amoeba) then - call print_matrix(.true., 'multipoles - non rotated:', & - sys_obj%eel%q0, of_unit) - end if - call print_matrix(.true., 'multipoles :', sys_obj%eel%q, of_unit) - call print_matrix(.true., 'coordinates of polarizable atoms:', & - sys_obj%eel%cpol, of_unit) - call print_matrix(.false., 'polarizabilities:', polar, of_unit) - call print_matrix(.false., 'thole factors:', sys_obj%eel%thole, of_unit) - call print_int_vec('mm_polar list:', sys_obj%eel%mm_polar, & - of_unit) - call print_int_vec('polar_mm list:', sys_obj%eel%polar_mm, & - of_unit) - - ! write the connectivity information for each atom: -1000 format(t3,'connectivity information for the ',i8,'-th atom:') - - do i = 1, sys_obj%top%mm_atoms - write(of_unit, 1000) i - - do j=1, 4 - if(j == 4 .and. .not. sys_obj%amoeba) cycle - - write(str, "('1-', I1, ' neighors:')") j+1 - call sort_ivec(sys_obj%top%conn(j)%ci(& - sys_obj%top%conn(j)%ri(i):& - sys_obj%top%conn(j)%ri(i+1)-1), tmp) - call print_int_vec(trim(str), tmp, of_unit) - end do - - if(sys_obj%amoeba) then - do j=1, 4 - ilst = 1 - do igrp = & - sys_obj%eel%pg_conn(j)%ri(sys_obj%eel%mmat_polgrp(i)), & - sys_obj%eel%pg_conn(j)%ri(sys_obj%eel%mmat_polgrp(i)+1)-1 - - grp = sys_obj%eel%pg_conn(j)%ci(igrp) - lst(ilst:ilst+sys_obj%eel%polgrp_mmat%ri(grp+1) - & - sys_obj%eel%polgrp_mmat%ri(grp)-1) = & - sys_obj%eel%polgrp_mmat%ci(& - sys_obj%eel%polgrp_mmat%ri(grp):& - sys_obj%eel%polgrp_mmat%ri(grp+1)-1) - - ilst = ilst+& - sys_obj%eel%polgrp_mmat%ri(grp+1)- & - sys_obj%eel%polgrp_mmat%ri(grp) - end do - - write(str, "('1-', I1, ' polarization neighors:')") j - if(ilst == 1) ilst = 0 - call sort_ivec(lst(1:ilst-1), tmp) - ! needed to addres the empty array case - call print_int_vec(trim(str), tmp, of_unit) - end do - end if - end do - - if(present(of_name)) close(of_unit) - - if(allocated(tmp)) & - call mfree('mmpol_ommp_print_summary [tmp]', tmp) - call mfree('mmpol_ommp_print_summary [polar]', polar) - - end subroutine mmpol_ommp_print_summary - - - subroutine mmpol_save_as_mmp(sys_obj, of_name, r_version) - !! Save the loaded system in mmpol format. Only the electrostatic part - !! is saved, everything else is just ignored. Version 2 and 3 of the - !! mmp format are supported, 3 is used as default. - - use mod_io, only: ommp_message - use mod_constants, only: mscale_wang_al, & - pscale_wang_al, & - dscale_wang_al, & - uscale_wang_al, & - mscale_wang_dl, & - pscale_wang_dl, & - dscale_wang_dl, & - uscale_wang_dl, & - eps_rp, angstrom2au - - implicit none - - type(ommp_system), target, intent(in) :: sys_obj - !! System data structure to be saved - character(len=*), intent(in) :: of_name - !! Name of the output file - integer(ip), intent(in), optional :: r_version - !! Revision version requested for .mmp - - integer(ip) :: of_unit, version, i, jb, je, igrp, inta(120) - type(ommp_electrostatics_type), pointer :: eel - type(ommp_topology_type), pointer :: top - - eel => sys_obj%eel - top => sys_obj%top - - if(.not. sys_obj%mmpol_is_init) then - call fatal_error('OpenMMPol is not initialized, cannot save .mmp & - &file.') - end if - - if(present(r_version)) then - version = r_version - else - version = 3 - end if - - of_unit = 101 - open(unit=of_unit, & - file=of_name(1:len(trim(of_name))), & - action='write') - ! 1. Integer, revision number used to check if the MMPol.mmp file is - ! consistent with the Gaussian version being used - if(version == 2 .or. version == 3) then - write(of_unit, '(I0,T2)') version - else - call fatal_error("Requested version of .mmp file is not supported & - &by openMMPol") - end if - - ! 2. Integer, MMPol job type: - ! - ! 0: for a QM/MM calculation ( - ! 1: for a Tinker QM/MM calculation - ! 2: for a QM/MM electronic energy transfer (EET) calculation - write(of_unit, '(I0,T2)') 0 - - ! 3. Integer, verbosity flag - write(of_unit, '(I0,T2)') 3 - - ! 4. Integer, force field type: - ! - ! 0: Amber-like - ! 1: AMOEBA-like - if(sys_obj%amoeba) then - write(of_unit, '(I0,T2)') 1 - else - write(of_unit, '(I0,T2)') 0 - end if - - ! 5. Integer, force field sub-type. For AMBER: - ! - ! 0: AMBER Wang-AL - ! 1: AMBER Wang-DL - ! 2: AMBER Thole - ! 0: AMOEBA - if(sys_obj%amoeba) then - write(of_unit, '(I0,T2)') 0 - else - if(all(abs(eel%mscale-mscale_wang_al) < eps_rp) .and. & - all(abs(eel%pscale-pscale_wang_al) < eps_rp) .and. & - all(abs(eel%dscale-dscale_wang_al) < eps_rp) .and. & - all(abs(eel%uscale-uscale_wang_al) < eps_rp)) then - write(of_unit, '(I0,T2)') 0 - else if(all(abs(eel%mscale-mscale_wang_dl) < eps_rp) .and. & - all(abs(eel%pscale-pscale_wang_dl) < eps_rp) .and. & - all(abs(eel%dscale-dscale_wang_dl) < eps_rp) .and. & - all(abs(eel%uscale-uscale_wang_dl) < eps_rp)) then - write(of_unit, '(I0,T2)') 1 - else - call fatal_error("The scaling scheme used is non-standard and & - &therefore cannot be saved in .mmp format") - end if - end if - - ! 6. Integer, disabled flag - write(of_unit, '(I0,T2)') 0 - - ! 7. Real, damping parameter for the dipole-dipole interactions - ! (Angstrom) - write(of_unit, '(F16.8)') 0.0 - - ! 8. Integer, solution method for the polarization equations - ! (suggested 3): - ! - ! 0: default, same as 3 - ! 1: matrix inversion - ! 2: iterative using Jacobi/DIIS - ! 3: iterative using preconditioned CG solver - write(of_unit, '(I0,T2)') 0 - - ! 9. Integer, how to compute the matrix/vector products for - ! MMPol (suggested 3): - ! - ! 0: default (1 for matrix inversion, 3 for iterative) - ! 1: assemble the matrix incore - ! 2: on-the-fly products with O(N^2) scaling - ! 3: on-the-fly products with the use of FMM if the system is large enough - ! 4: on-the-fly products with the use of FMM in all cases - write(of_unit, '(I0,T2)') 0 - - ! 10. Integer, convergence threshold (10^-N) for the iterative - ! solvers (suggested 8) - write(of_unit, '(I0,T2)') 8 - - ! 11. Integer, accuracy of the FMM calculations (suggested 0): - ! - ! <0: 10^-5 RMS 10^-4 Max Error - ! 0: 10^-6 RMS 10^-5 Max Error - ! 1: 10^-7 RMS 10^-6 Max Error - ! >2: maximum accuracy - write(of_unit, '(I0,T2)') 0 - - ! 12. Real, FMM box size for MM interactions (Angstrom) (suggested 12.0) - write(of_unit, '(F16.8)') 12.0 - - ! 13. Real, FMM box size for MM/PCM interactions (Angstrom) - ! (suggested 6.0) - if(version == 3) then - write(of_unit, '(F16.8)') 6.0 - end if - - ! 14. Integer, continuum solvation model: - ! - ! 0: no continuum solvation model - ! 1: ddCOSMO - ! 2: ddPCM - write(of_unit, '(I0,T2)') 0 - - ! 15. Integer, maximum angular momentum for PCM (suggested 10) - write(of_unit, '(I0,T2)') 10 - - ! 16. Integer, number of Lebedev integration points for PCM - ! (suggested 302) - write(of_unit, '(I0,T2)') 302 - - ! 17. Integer, convergence threshold (10^-N) for the PCM - ! iterative solvers (suggested 8) - write(of_unit, '(I0,T2)') 8 - - ! 18. Real, dielectric constant of the solvent for PCM (78.3 for water) - write(of_unit, '(F16.8)') 78.3 - - ! 19. Real, optical dielectric constant of the solvent for PCM - ! (1.7 for water) - if(version == 3) then - write(of_unit, '(F16.8)') 0.00 - end if - - ! 20. Real, relative size of the switching region for PCM - ! (suggested 0.1) - write(of_unit, '(F16.8)') 0.1 - - ! 21. Integer, cavity type for PCM (suggested 3): - ! - ! 0: default, same as 3 - ! 1: SAS cavity using UFF radii plus the probe radius - ! 2: Read the cavity from the input file - ! (the input must contain at least one sphere per atom) - ! 3: VdW cavity using Bondi's radii scaled by 1.1 - ! 4: SAS cavity using Bondi's radii plus the probe radius - write(of_unit, '(I0,T2)') 0 - - ! 22. Real, probe radius for the SAS cavity (Angstrom) (1.4 for water) - write(of_unit, '(F16.8)') 1.4 - - ! 23. Integer, number of MM atoms - write(of_unit, '(I0,T2)') top%mm_atoms - - ! 24. Integer, number of spheres composing the cavity. - ! Mandatory if the cavity type is 2, additional spheres - ! if the cavity is automatically built. - write(of_unit, '(I0,T2)') 0 - - ! 25. Integer array, size (N): atomic numbers - if(top%atz_initialized) then - do i=1, top%mm_atoms - write(of_unit, '(I0,T2)') top%atz(i) - end do - else - do i=1, top%mm_atoms - write(of_unit, '(I0,T2)') 1 - end do - end if - - - ! 26. Real array, size (N, 3): coordinates - do i=1, top%mm_atoms - write(of_unit, '(3F16.8)') top%cmm(:,i) / angstrom2au - end do - - ! 27. Integer array, size (N): residue numbers - do i=1, top%mm_atoms - write(of_unit, '(I0,T2)') 1 - end do - - ! 28. Real array, size (N): charges or fiixed multipoles - do i=1, top%mm_atoms - if(sys_obj%amoeba) then - write(of_unit, '(10F16.8)') eel%q0(:,i) * [1.0, & !q - 1.0, 1.0, 1.0, & !mu - 3.0, 3.0, 3.0, & ! Q - 3.0, 3.0, 3.0] ! Q - - else - write(of_unit, '(F16.8)') eel%q(:,i) - end if - end do - - ! 29. Real array, size (N): polarizabilities - do i=1, top%mm_atoms - if(eel%mm_polar(i) > 0) then - write(of_unit, '(F16.8)') eel%pol(i) / (angstrom2au**3) - else - write(of_unit, '(F16.8)') 0.0 - end if - end do - - ! 30. Integer array, size (N, 8): connectivity matrix - do i=1, top%mm_atoms - jb = top%conn(1)%ri(i) - je = top%conn(1)%ri(i+1)-1 - inta(1:8) = 0 - inta(1:je-jb+1) = top%conn(1)%ci(jb:je) - write(of_unit, '(8I8)') inta(1:8) - end do - - ! 31. Integer array, size (N, 120): polarization group members - do i=1, top%mm_atoms - igrp = eel%mmat_polgrp(i) - jb=eel%polgrp_mmat%ri(igrp) - je=eel%polgrp_mmat%ri(igrp+1)-1 - inta = 0 - inta(1:je-jb+1) = eel%polgrp_mmat%ci(jb:je) - write(of_unit, '(120I8)') inta - end do - ! 32. Integer array, size (N, 4): rotation conventions and - ! reference atoms for the AMOEBA multipoles - do i=1, top%mm_atoms - write(of_unit, '(4I8)') eel%mol_frame(i), eel%iz(i), eel%ix(i), & - eel%iy(i) - end do - - end subroutine mmpol_save_as_mmp - -end module mod_mmpol diff --git a/src/mod_neighbors_list.F90 b/src/mod_neighbors_list.F90 new file mode 100644 index 0000000..19c8c1a --- /dev/null +++ b/src/mod_neighbors_list.F90 @@ -0,0 +1,189 @@ +#include "f_cart_components.h" +module mod_neighbor_list + use mod_memory, only: ip, rp, lp, mallocate, mfree + use mod_adjacency_mat, only: yale_sparse + use mod_io, only: ommp_message, fatal_error + + implicit none + private + + type ommp_neigh_list + integer(ip) :: n + !! Number of particles in the system + real(rp) :: cutoff + !! Cutoff distance for the neighbor list + integer(ip) :: cellf = 1 + !! Number of subdivision of 'standard' cell. If you create smaller + !! cells ([[cutoff]]/[[cellf]]) you can sensibly increase the performanc + !! of the algorithm. See 10.1016/S0010-4655(98)00203-3 + real(rp) :: celld + !! Dimension of each cell + integer(ip) :: ncell(3) + !! Number of cell along each dimension + integer(ip) :: ncells + !! Total number of cells + real(rp) :: offset(3) + !! Coordinates offset along each dimension (that is the minimum value of + !! each coordinate. + integer(ip) :: nneigh + !! Number of neighbor cells + integer(ip), allocatable :: neigh_offset(:) + !! Offsets of neighbor cells + integer(ip), allocatable :: p2c(:) + !! Cell of each particle + type(yale_sparse) :: c2p + !! Particles contained in each cell, sparse matrix format + end type ommp_neigh_list + + public :: ommp_neigh_list, nl_init, nl_terminate, nl_update, get_ith_nl + +contains + + subroutine nl_init(nl, c, cutoff, f) + implicit none + + real(rp), intent(in) :: c(:,:) + !! Coordinates in input + real(rp), intent(in) :: cutoff + !! Cut off distance + integer(ip), intent(in) :: f + !! Subdivision required for each cell + + type(ommp_neigh_list), intent(inout) :: nl + !! Neigh list object to initialize + + if(size(c,1) /= 3) then + call fatal_error("In nl_init, coordinates should be shaped 3xn") + end if + nl%n = size(c,2) + nl%cutoff = cutoff + nl%cellf = f + if(nl%cellf > 2 .or. nl%cellf < 0) then + call fatal_error("Subdivision required is not implemented") + end if + nl%nneigh = (nl%cellf*2+1)**3 + call mallocate('nl_init [neigh_offset]', nl%nneigh, nl%neigh_offset) + + nl%celld = nl%cutoff / nl%cellf + call mallocate('nl_init [p2c]', nl%n, nl%p2c) + call nl_update(nl, c) + end subroutine + + subroutine nl_terminate(nl) + use mod_adjacency_mat, only : matfree + + implicit none + + type(ommp_neigh_list), intent(inout) :: nl + + call matfree(nl%c2p) + call mfree('nl_terminate [p2c]', nl%p2c) + call mfree('nl_terminate [neigh_offset]', nl%neigh_offset) + end subroutine + + subroutine nl_update(nl, c) + use mod_io, only: ommp_message + use mod_profiling, only: time_push, time_pull + use mod_adjacency_mat, only: reverse_grp_tab + use mod_constants, only: OMMP_VERBOSE_LOW + implicit none + + type(ommp_neigh_list), intent(inout) :: nl + !! Neigh list object to initialize + real(rp), intent(in) :: c(3,nl%n) + !! Coordinates in input + + integer(ip) :: i, j, k, l, cc(3), ccmap(3) + + call time_push() + call ommp_message('Updating neighbor lists', OMMP_VERBOSE_LOW) + do i=1, 3 + !! TODO this should be improved + nl%offset(i) = minval(c(i,:)) + nl%ncell(i) = ceiling((maxval(c(i,:)) - nl%offset(i)) / nl%celld) + end do + nl%ncells = product(nl%ncell) + + ccmap(_x_) = nl%ncell(_y_) * nl%ncell(_z_) + ccmap(_y_) = nl%ncell(_z_) + ccmap(_z_) = 1 + + l = 1 + do i=-nl%cellf, nl%cellf + do j=-nl%cellf, nl%cellf + do k=-nl%cellf, nl%cellf + nl%neigh_offset(l) = i * ccmap(1) + j * ccmap(2) + k * ccmap(3) + l = l + 1 + end do + end do + end do + + ! Each particle is assigned to a cell + do i=1, nl%n + do j=1, 3 + cc(j) = floor((c(j,i)-nl%offset(j)) / nl%celld) + end do + nl%p2c(i) = dot_product(cc, ccmap) + 1 + end do + + ! Revert assignation to get neighbor list! + ! The number of cell could be different... + if(allocated(nl%c2p%ri)) then + if(size(nl%c2p%ri) /= nl%ncells+1) then + ! This automatically calls for the reallocation in + ! reverse_grp_tab. + call mfree('nl_update [ri]', nl%c2p%ri) + end if + end if + + call reverse_grp_tab(nl%p2c, nl%c2p, nl%ncells) + call time_pull("Neighbor list update") + end subroutine + + subroutine get_ith_nl(nl, i, c, neigh, dist, nn) + !! Once that the neighbor list have been initialized and + !! updated, this function provide a logical array for atom + !! [[i]] with all interactions that should be computed and + !! corresponding distances. + implicit none + + type(ommp_neigh_list), intent(in) :: nl + !! Neigh list object + integer(ip), intent(in) :: i + !! Index of atom for which the neigbor list is required + real(rp), intent(in) :: c(3,nl%n) + !! Coordinates in input + integer(ip), intent(out) :: neigh(nl%n) + !! Integer array with neighbors' indexes. + !! Only the first nn elements are valid + real(rp), intent(out) :: dist(nl%n) + !! Array for returning distances. + !! Only the first nn elements are valid + integer(ip), intent(out) :: nn + !! Number of neighbors + + + integer(ip) :: icell, j, jid, jp, jjp + real(rp) :: vdist(3), d2, thr2 + + icell = nl%p2c(i) + thr2 = nl%cutoff * nl%cutoff + + nn = 0 + do j=1, nl%nneigh + jid = icell + nl%neigh_offset(j) + if(jid > 0 .and. jid <= nl%ncells) then + do jp=nl%c2p%ri(jid), nl%c2p%ri(jid+1)-1 + jjp = nl%c2p%ci(jp) + vdist = c(:,i)-c(:,jjp) + d2 = dot_product(vdist, vdist) + if(d2 < thr2) then + nn = nn + 1 + dist(nn) = sqrt(d2) + neigh(nn) = jjp + end if + end do + end if + end do + end subroutine +end module diff --git a/src/mod_neighbors_list.f90 b/src/mod_neighbors_list.f90 deleted file mode 100644 index 26928d7..0000000 --- a/src/mod_neighbors_list.f90 +++ /dev/null @@ -1,189 +0,0 @@ -#include "f_cart_components.h" -module mod_neighbor_list - use mod_memory, only: ip, rp, lp, mallocate, mfree - use mod_adjacency_mat, only: yale_sparse - use mod_io, only: ommp_message, fatal_error - - implicit none - private - - type ommp_neigh_list - integer(ip) :: n - !! Number of particles in the system - real(rp) :: cutoff - !! Cutoff distance for the neighbor list - integer(ip) :: cellf = 1 - !! Number of subdivision of 'standard' cell. If you create smaller - !! cells ([[cutoff]]/[[cellf]]) you can sensibly increase the performanc - !! of the algorithm. See 10.1016/S0010-4655(98)00203-3 - real(rp) :: celld - !! Dimension of each cell - integer(ip) :: ncell(3) - !! Number of cell along each dimension - integer(ip) :: ncells - !! Total number of cells - real(rp) :: offset(3) - !! Coordinates offset along each dimension (that is the minimum value of - !! each coordinate. - integer(ip) :: nneigh - !! Number of neighbor cells - integer(ip), allocatable :: neigh_offset(:) - !! Offsets of neighbor cells - integer(ip), allocatable :: p2c(:) - !! Cell of each particle - type(yale_sparse) :: c2p - !! Particles contained in each cell, sparse matrix format - end type ommp_neigh_list - - public :: ommp_neigh_list, nl_init, nl_terminate, nl_update, get_ith_nl - - contains - - subroutine nl_init(nl, c, cutoff, f) - implicit none - - real(rp), intent(in) :: c(:,:) - !! Coordinates in input - real(rp), intent(in) :: cutoff - !! Cut off distance - integer(ip), intent(in) :: f - !! Subdivision required for each cell - - type(ommp_neigh_list), intent(inout) :: nl - !! Neigh list object to initialize - - if(size(c,1) /= 3) then - call fatal_error("In nl_init, coordinates should be shaped 3xn") - end if - nl%n = size(c,2) - nl%cutoff = cutoff - nl%cellf = f - if(nl%cellf > 2 .or. nl%cellf < 0) then - call fatal_error("Subdivision required is not implemented") - end if - nl%nneigh = (nl%cellf*2+1)**3 - call mallocate('nl_init [neigh_offset]', nl%nneigh, nl%neigh_offset) - - nl%celld = nl%cutoff / nl%cellf - call mallocate('nl_init [p2c]', nl%n, nl%p2c) - call nl_update(nl, c) - end subroutine - - subroutine nl_terminate(nl) - use mod_adjacency_mat, only : matfree - - implicit none - - type(ommp_neigh_list), intent(inout) :: nl - - call matfree(nl%c2p) - call mfree('nl_terminate [p2c]', nl%p2c) - call mfree('nl_terminate [neigh_offset]', nl%neigh_offset) - end subroutine - - subroutine nl_update(nl, c) - use mod_io, only: ommp_message - use mod_profiling, only: time_push, time_pull - use mod_adjacency_mat, only: reverse_grp_tab - use mod_constants, only: OMMP_VERBOSE_LOW - implicit none - - type(ommp_neigh_list), intent(inout) :: nl - !! Neigh list object to initialize - real(rp), intent(in) :: c(3,nl%n) - !! Coordinates in input - - integer(ip) :: i, j, k, l, cc(3), ccmap(3) - - call time_push() - call ommp_message('Updating neighbor lists', OMMP_VERBOSE_LOW) - do i=1, 3 - !! TODO this should be improved - nl%offset(i) = minval(c(i,:)) - nl%ncell(i) = ceiling((maxval(c(i,:)) - nl%offset(i)) / nl%celld) - end do - nl%ncells = product(nl%ncell) - - ccmap(_x_) = nl%ncell(_y_) * nl%ncell(_z_) - ccmap(_y_) = nl%ncell(_z_) - ccmap(_z_) = 1 - - l = 1 - do i=-nl%cellf, nl%cellf - do j=-nl%cellf, nl%cellf - do k=-nl%cellf, nl%cellf - nl%neigh_offset(l) = i * ccmap(1) + j * ccmap(2) + k * ccmap(3) - l = l + 1 - end do - end do - end do - - ! Each particle is assigned to a cell - do i=1, nl%n - do j=1, 3 - cc(j) = floor((c(j,i)-nl%offset(j)) / nl%celld) - end do - nl%p2c(i) = dot_product(cc, ccmap) + 1 - end do - - ! Revert assignation to get neighbor list! - ! The number of cell could be different... - if(allocated(nl%c2p%ri)) then - if(size(nl%c2p%ri) /= nl%ncells+1) then - ! This automatically calls for the reallocation in - ! reverse_grp_tab. - call mfree('nl_update [ri]', nl%c2p%ri) - end if - end if - - call reverse_grp_tab(nl%p2c, nl%c2p, nl%ncells) - call time_pull("Neighbor list update") - end subroutine - - subroutine get_ith_nl(nl, i, c, neigh, dist, nn) - !! Once that the neighbor list have been initialized and - !! updated, this function provide a logical array for atom - !! [[i]] with all interactions that should be computed and - !! corresponding distances. - implicit none - - type(ommp_neigh_list), intent(in) :: nl - !! Neigh list object - integer(ip), intent(in) :: i - !! Index of atom for which the neigbor list is required - real(rp), intent(in) :: c(3,nl%n) - !! Coordinates in input - integer(ip), intent(out) :: neigh(nl%n) - !! Integer array with neighbors' indexes. - !! Only the first nn elements are valid - real(rp), intent(out) :: dist(nl%n) - !! Array for returning distances. - !! Only the first nn elements are valid - integer(ip), intent(out) :: nn - !! Number of neighbors - - - integer(ip) :: icell, j, jid, jp, jjp - real(rp) :: vdist(3), d2, thr2 - - icell = nl%p2c(i) - thr2 = nl%cutoff * nl%cutoff - - nn = 0 - do j=1, nl%nneigh - jid = icell + nl%neigh_offset(j) - if(jid > 0 .and. jid <= nl%ncells) then - do jp=nl%c2p%ri(jid), nl%c2p%ri(jid+1)-1 - jjp = nl%c2p%ci(jp) - vdist = c(:,i)-c(:,jjp) - d2 = dot_product(vdist, vdist) - if(d2 < thr2) then - nn = nn + 1 - dist(nn) = sqrt(d2) - neigh(nn) = jjp - end if - end do - end if - end do - end subroutine -end module diff --git a/src/mod_nonbonded.F90 b/src/mod_nonbonded.F90 new file mode 100644 index 0000000..184282c --- /dev/null +++ b/src/mod_nonbonded.F90 @@ -0,0 +1,1361 @@ +module mod_nonbonded + + use mod_memory, only: rp, ip, lp + use mod_neighbor_list, only: ommp_neigh_list + use mod_constants, only: OMMP_STR_CHAR_MAX + use mod_adjacency_mat, only: yale_sparse + use mod_topology, only: ommp_topology_type + use mod_constants, only: OMMP_VDWTYPE_LJ, & + OMMP_VDWTYPE_BUF714, & + OMMP_RADRULE_ARITHMETIC, & + OMMP_RADRULE_CUBIC, & + OMMP_RADTYPE_RMIN, & + OMMP_EPSRULE_GEOMETRIC, & + OMMP_EPSRULE_HHG + + implicit none + private + + integer(ip), parameter :: pair_allocation_chunk = 16 + + type ommp_nonbonded_type + !! Derived type for storing the information relative to the calculation + !! of non-bonding interactions + type(ommp_topology_type), pointer :: top + !! Data structure for topology + logical(lp) :: use_nl + !! Flag for using neighbors list + type(ommp_neigh_list) :: nl + !! Neighbor list struture + real(rp), allocatable, dimension(:) :: vdw_r + !! VdW radii for the atoms of the system + real(rp), allocatable, dimension(:) :: vdw_e + !! Vdw energies for the atoms of fthe system + real(rp), allocatable, dimension(:) :: vdw_f + !! Scale factor for displacing the interaction center + + integer(ip) :: npair = 0 + !! Number of nonbonded pair parameters + logical(lp), allocatable :: vdw_pair_mask_a(:,:), vdw_pair_mask_b(:,:) + !! Mask to apply a pair parameter to a pair of atoms dimension is + !! Natoms x Nparams + real(rp), allocatable :: vdw_pair_r(:) + !! Radii for the VdW atom pairs + real(rp), allocatable :: vdw_pair_e(:) + !! VdW energies for atom pairs + + real(rp), dimension(4) :: vdw_screening = [0.0, 0.0, 1.0, 1.0] + !! Screening factors for 1,2 1,3 and 1,4 neighbours. + !! Default vaules from tinker manual. + real(rp) :: radf = 1.0 + !! Scal factor for atomic radii/diameters (1.0 is used for diameters, + !! 2.0 for radii) + integer(ip) :: radrule + !! Flag for the radius rule to be used + integer(ip) :: radtype + !! Flag for the radius type + integer(ip) :: vdwtype + !! Flag for the vdW type + integer(ip) :: epsrule + !! Flag for eps rule !!TODO + end type ommp_nonbonded_type + + abstract interface + subroutine vdw_term(Rij, Rij0, Eij, V) + use mod_memory, only: rp + real(rp), intent(in) :: Rij + real(rp), intent(in) :: Rij0 + real(rp), intent(in) :: Eij + real(rp), intent(inout) :: V + end subroutine + end interface + + abstract interface + subroutine vdw_gterm(Rij, Rij0, Eij, Rijgrad) + use mod_memory, only: rp + real(rp), intent(in) :: Rij + real(rp), intent(in) :: Rij0 + real(rp), intent(in) :: Eij + real(rp), intent(out) :: Rijgrad + end subroutine + end interface + + public :: ommp_nonbonded_type + public :: vdw_init, vdw_terminate, vdw_set_pair, vdw_remove_potential + public :: vdw_set_cutoff + public :: vdw_potential, vdw_geomgrad + public :: vdw_potential_inter, vdw_geomgrad_inter + public :: vdw_potential_inter_restricted, vdw_geomgrad_inter_restricted + +contains + + subroutine vdw_init(vdw, top, vdw_type, radius_rule, radius_size, & + radius_type, epsrule, cutoff) + !! Initialize the non-bonded object allocating the parameters vectors + + use mod_memory, only: mallocate + use mod_io, only: fatal_error + use mod_neighbor_list, only: nl_init + use mod_constants, only: OMMP_DEFAULT_NL_SUB + + implicit none + + type(ommp_nonbonded_type), intent(inout) :: vdw + type(ommp_topology_type), intent(in), target :: top + character(len=*) :: vdw_type, radius_rule, radius_size, radius_type, & + epsrule + real(rp) :: cutoff + + select case(trim(vdw_type)) + case("lennard-jones") + vdw%vdwtype = OMMP_VDWTYPE_LJ + continue + case("buckingham") + call fatal_error("VdW type buckingham is not implemented") + case("buffered-14-7") + vdw%vdwtype = OMMP_VDWTYPE_BUF714 + continue + case("mm3-hbond") + call fatal_error("VdW type mm3-hbond is not implemented") + case("gaussian") + call fatal_error("VdW type gaussian is not implemented") + case default + call fatal_error("VdW type specified is not understood") + end select + + select case(trim(radius_rule)) + case("arithmetic") + vdw%radrule = OMMP_RADRULE_ARITHMETIC + continue + case("geometric") + call fatal_error("radiusrule geometric is not implemented") + case("cubic-mean") + vdw%radrule = OMMP_RADRULE_CUBIC + continue + case default + call fatal_error("radiusrule specified is not understood") + end select + + select case(trim(radius_size)) + case("radius") + vdw%radf = 2.0 + continue + case("diameter") + vdw%radf = 1.0 + continue + case default + call fatal_error("radiussize specified is not understood") + end select + + select case(trim(radius_type)) + case("sigma") + call fatal_error("radiustype sigma is not implemented") + case("r-min") + vdw%radtype = OMMP_RADTYPE_RMIN + continue + case default + call fatal_error("radiustype specified is not understood") + end select + + select case(trim(epsrule)) + case("geometric") + vdw%epsrule = OMMP_EPSRULE_GEOMETRIC + continue + case("arithmetic") + call fatal_error("epsilonrule arithmetic is not implemented") + case("harmonic") + call fatal_error("epsilonrule harmonic is not implemented") + case("w-h") + call fatal_error("epsilonrule w-h is not implemented") + case("hhg") + vdw%epsrule = OMMP_EPSRULE_HHG + continue + case default + call fatal_error("epsilonrule specified is not understood") + end select + + vdw%top => top + call mallocate('vdw_init [vdw_r]', top%mm_atoms, vdw%vdw_r) + call mallocate('vdw_init [vdw_e]', top%mm_atoms, vdw%vdw_e) + call mallocate('vdw_init [vdw_f]', top%mm_atoms, vdw%vdw_f) + + call mallocate('vdw_init [vdw_pair_mask_a]', & + top%mm_atoms, pair_allocation_chunk,vdw%vdw_pair_mask_a) + call mallocate('vdw_init [vdw_pair_mask_b]', & + top%mm_atoms, pair_allocation_chunk,vdw%vdw_pair_mask_b) + call mallocate('vdw_init [vdw_pair_r]', pair_allocation_chunk, & + vdw%vdw_pair_r) + call mallocate('vdw_init [vdw_pair_e]', pair_allocation_chunk, & + vdw%vdw_pair_e) + + vdw%vdw_f = 1.0_rp + + if(cutoff > 0.0) then + vdw%use_nl = .true. + if(vdw%use_nl) call nl_init(vdw%nl, top%cmm, cutoff, OMMP_DEFAULT_NL_SUB) + else + vdw%use_nl = .false. + end if + end subroutine vdw_init + + subroutine vdw_set_cutoff(vdw, cutoff, subdivision) + use mod_neighbor_list, only: nl_terminate, nl_init + implicit none + + type(ommp_nonbonded_type), intent(inout) :: vdw + real(rp), intent(in) :: cutoff + integer(ip), intent(in) :: subdivision + + if(vdw%use_nl) then + ! This is re-initialization, old stuff should be cleaned. + call nl_terminate(vdw%nl) + end if + if(cutoff > 0.0) then + vdw%use_nl = .true. + call nl_init(vdw%nl, vdw%top%cmm, cutoff, subdivision) + else + vdw%use_nl = .false. + end if + end subroutine + + subroutine vdw_terminate(vdw) + use mod_memory, only: mfree + use mod_adjacency_mat, only: matfree + use mod_neighbor_list, only: nl_terminate + + implicit none + + type(ommp_nonbonded_type), intent(inout) :: vdw + + call mfree('vdw_terminate [vdw_r]', vdw%vdw_r) + call mfree('vdw_terminate [vdw_e]', vdw%vdw_e) + call mfree('vdw_terminate [vdw_f]', vdw%vdw_f) + call mfree('vdw_terminate [vdw_pair_r]', vdw%vdw_pair_r) + call mfree('vdw_terminate [vdw_pair_e]', vdw%vdw_pair_e) + call mfree('vdw_terminate [vdw_pair_mask_b]', vdw%vdw_pair_mask_a) + call mfree('vdw_terminate [vdw_pair_mask_b]', vdw%vdw_pair_mask_b) + if(vdw%use_nl) call nl_terminate(vdw%nl) + + end subroutine + + subroutine vdw_remove_potential(vdw, i) + !! Remove the VdW interaction from the specified atom + !! the atom will not interact anymore with any other atom + implicit none + + type(ommp_nonbonded_type), intent(inout) :: vdw + integer(ip), intent(in) :: i + + vdw%vdw_e(i) = 0.0 + + ! TODO do it also for pair interactions + end subroutine + + subroutine vdw_set_pair(vdw, mask_a, mask_b, r, e) + use mod_io, only: ommp_message, fatal_error + use mod_constants, only: OMMP_VERBOSE_LOW + use mod_memory, only: mallocate, mfree + + implicit none + + type(ommp_nonbonded_type), intent(inout) :: vdw + !! Nonbonded data structure + logical(lp), intent(in) :: mask_a(vdw%top%mm_atoms) + logical(lp), intent(in) :: mask_b(vdw%top%mm_atoms) + real(rp), intent(in) :: r + !! Equilibrium distance for the pair + real(rp), intent(in) :: e + !! Depth of the potential + + integer(ip) :: oldsize, newsize + logical(lp), allocatable :: ltmp(:,:) + real(rp), allocatable :: rtmp(:) + character(len=OMMP_STR_CHAR_MAX) :: msg + + oldsize = size(vdw%vdw_pair_r) + if(vdw%npair >= oldsize) then + newsize = oldsize + pair_allocation_chunk + call mallocate('vdw_set_pair [rtmp]', oldsize, rtmp) + call mallocate('vdw_set_pair [ltmp]',vdw%top%mm_atoms, oldsize, ltmp) + + rtmp = vdw%vdw_pair_r + call mfree('vdw_set_pair [vdw%vdw_pair_r]', vdw%vdw_pair_r) + call mallocate('vdw_set_pair [vdw%vdw_pair_r]', newsize, vdw%vdw_pair_r) + vdw%vdw_pair_r(1:oldsize) = rtmp + + rtmp = vdw%vdw_pair_e + call mfree('vdw_set_pair [vdw%vdw_pair_e]', vdw%vdw_pair_e) + call mallocate('vdw_set_pair [vdw%vdw_pair_e]', newsize, vdw%vdw_pair_e) + vdw%vdw_pair_e(1:oldsize) = rtmp + + ltmp = vdw%vdw_pair_mask_a + call mfree('vdw_set_pair [vdw_pair_mask_a]', vdw%vdw_pair_mask_a) + call mallocate('vdw_set_pair [vdw_pair_mask_a]', & + vdw%top%mm_atoms, newsize, vdw%vdw_pair_mask_a) + vdw%vdw_pair_mask_a(:,1:oldsize) = ltmp + + ltmp = vdw%vdw_pair_mask_b + call mfree('vdw_set_pair [vdw_pair_mask_b]', vdw%vdw_pair_mask_b) + call mallocate('vdw_set_pair [vdw_pair_mask_b]', & + vdw%top%mm_atoms, newsize, vdw%vdw_pair_mask_b) + vdw%vdw_pair_mask_b(:,1:oldsize) = ltmp + + call mfree('vdw_set_pair [rtmp]', rtmp) + call mfree('vdw_set_pair [ltmp]', ltmp) + end if + vdw%npair = vdw%npair + 1 + vdw%vdw_pair_mask_a(:,vdw%npair) = mask_a + vdw%vdw_pair_mask_b(:,vdw%npair) = mask_b + vdw%vdw_pair_r(vdw%npair) = r + vdw%vdw_pair_e(vdw%npair) = e + + end subroutine vdw_set_pair + + subroutine vdw_lennard_jones(Rij, Rij0, Eij, V) + implicit none + + real(rp), intent(in) :: Rij + real(rp), intent(in) :: Rij0 + real(rp), intent(in) :: Eij + real(rp), intent(inout) :: V + + real(rp) :: sigma_ov_r + + sigma_ov_r = Rij0 / Rij + V = V + Eij*(sigma_ov_r**12 - 2_rp*sigma_ov_r**6) + + end subroutine vdw_lennard_jones + + subroutine vdw_lennard_jones_Rijgrad(Rij, Rij0, Eij, Rijgrad) + implicit none + + real(rp), intent(in) :: Rij + real(rp), intent(in) :: Rij0 + real(rp), intent(in) :: Eij + real(rp), intent(out) :: Rijgrad + + real(rp) :: sigma_ov_r + + sigma_ov_r = Rij0 / Rij + Rijgrad = -12.0 * Eij * (sigma_ov_r ** 12 - sigma_ov_r ** 6) / Rij + + end subroutine vdw_lennard_jones_Rijgrad + + subroutine vdw_buffered_7_14(Rij, Rij0, Eij, V) + !! Compute the dispersion-repulsion energy using the buffered 7-14 + !! potential. Details can be found in ref: 10.1021/jp027815 + + implicit none + + real(rp), intent(in) :: Rij + real(rp), intent(in) :: Rij0 + real(rp), intent(in) :: Eij + real(rp), intent(inout) :: V + + real(rp) :: rho + real(rp), parameter :: delta = 0.07, gam = 0.12 + integer(ip), parameter :: n = 14, m = 7 + + rho = Rij / Rij0 + V = V + Eij*((1+delta)/(rho+delta))**(n-m) * ((1+gam)/(rho**m+gam)-2) + + end subroutine vdw_buffered_7_14 + + subroutine vdw_buffered_7_14_Rijgrad(Rij, Rij0, Eij, Rijgrad) + !! Compute the gradient of vdw energy (using the buffered 7-14 + !! potential ref: 10.1021/jp027815) with respect to the distance + !! between the two atoms (Rij). + + implicit none + + real(rp), intent(in) :: Rij + real(rp), intent(in) :: Rij0 + real(rp), intent(in) :: Eij + real(rp), intent(out) :: Rijgrad + + real(rp) :: rho, rhom + real(rp), parameter :: delta = 0.07, gam = 0.12 + integer(ip), parameter :: n = 14, m = 7 + + rho = Rij / Rij0 + rhom = rho**m + Rijgrad = Eij * ((delta+1)/(delta+rho))**(n-m) * & + (rho*(gam+rhom)*(m-n)*(1-2*rhom-gam) - & + rhom*m*(delta+rho)*(gam+1)) / & + (rho*(delta+rho)*(gam+rhom)**2) + Rijgrad = Rijgrad / Rij0 + + end subroutine vdw_buffered_7_14_Rijgrad + + pure function get_Rij0(vdw, i, j) result(Rij0) + use mod_constants, only: eps_rp + + implicit none + + type(ommp_nonbonded_type), intent(in), target :: vdw + !! Nonbonded data structure + integer(ip), intent(in) :: i, j + !! Indices of interacting atoms + real(rp) :: Rij0 + + if(vdw%vdw_r(i) < eps_rp .and. vdw%vdw_r(j) < eps_rp) then + Rij0 = 0.0 + return + end if + + select case(vdw%radrule) + case(OMMP_RADRULE_ARITHMETIC) + Rij0 = vdw%radf*(vdw%vdw_r(i) + vdw%vdw_r(j))/2 + case(OMMP_RADRULE_CUBIC) + Rij0 = (vdw%vdw_r(i)**3 + vdw%vdw_r(j)**3) / & + (vdw%vdw_r(i)**2 + vdw%vdw_r(j)**2) + case default + Rij0 = 0.0 + end select + end function + + pure function get_eij(vdw, i, j) result(eij) + use mod_constants, only: eps_rp + + implicit none + + type(ommp_nonbonded_type), intent(in) :: vdw + !! Nonbonded data structure + integer(ip), intent(in) :: i, j + !! Indices of interacting atoms + real(rp) :: eij + + if(vdw%vdw_e(i) < eps_rp .and. vdw%vdw_e(j) < eps_rp) then + eij = 0.0 + return + end if + + select case(vdw%epsrule) + case(OMMP_EPSRULE_GEOMETRIC) + eij = sqrt(vdw%vdw_e(i)*vdw%vdw_e(j)) + case(OMMP_EPSRULE_HHG) + eij = (4*vdw%vdw_e(i)*vdw%vdw_e(j)) / & + (vdw%vdw_e(i)**0.5 + vdw%vdw_e(j)**0.5)**2 + case default + eij = 0.0 + end select + end function + + pure function get_Rij0_inter(vdw1, vdw2, i, j) result(Rij0) + use mod_constants, only: eps_rp + + implicit none + + type(ommp_nonbonded_type), intent(in), target :: vdw1, vdw2 + !! Nonbonded data structure + integer(ip), intent(in) :: i, j + !! Indices of interacting atoms + real(rp) :: Rij0 + + if(abs(vdw1%radrule - vdw2%radrule) > eps_rp .or. & + abs(vdw1%radf - vdw2%radf) > eps_rp) then + Rij0 = 0.0 + return + end if + + if(vdw1%vdw_r(i) < eps_rp .and. vdw2%vdw_r(j) < eps_rp) then + Rij0 = 0.0 + return + end if + + select case(vdw1%radrule) + case(OMMP_RADRULE_ARITHMETIC) + Rij0 = vdw1%radf*(vdw1%vdw_r(i) + vdw2%vdw_r(j))/2 + case(OMMP_RADRULE_CUBIC) + Rij0 = (vdw1%vdw_r(i)**3 + vdw2%vdw_r(j)**3) / & + (vdw1%vdw_r(i)**2 + vdw2%vdw_r(j)**2) + case default + Rij0 = 0.0 + end select + end function + + pure function get_eij_inter(vdw1, vdw2, i, j) result(eij) + use mod_constants, only: eps_rp + + implicit none + + type(ommp_nonbonded_type), intent(in) :: vdw1, vdw2 + !! Nonbonded data structure + integer(ip), intent(in) :: i, j + !! Indices of interacting atoms + real(rp) :: eij + + if(vdw1%epsrule /= vdw2%epsrule) then + eij = 0.0 + return + end if + + if(vdw1%vdw_e(i) < eps_rp .and. vdw2%vdw_e(j) < eps_rp) then + eij = 0.0 + return + end if + + select case(vdw1%epsrule) + case(OMMP_EPSRULE_GEOMETRIC) + eij = sqrt(vdw1%vdw_e(i)*vdw2%vdw_e(j)) + case(OMMP_EPSRULE_HHG) + eij = (4*vdw1%vdw_e(i)*vdw2%vdw_e(j)) / & + (vdw1%vdw_e(i)**0.5 + vdw2%vdw_e(j)**0.5)**2 + case default + eij = 0.0 + end select + end function + + subroutine vdw_potential(vdw, V) + !! Compute the dispersion repulsion energy for the whole system + !! using a double loop algorithm + + use mod_io, only : fatal_error + use mod_profiling, only: time_push, time_pull + use mod_constants, only: eps_rp + use mod_memory, only: mallocate, mfree + use mod_neighbor_list, only: get_ith_nl + implicit none + + type(ommp_nonbonded_type), intent(in), target :: vdw + !! Nonbonded data structure + real(rp), intent(inout) :: V + !! Potential, result will be added + + integer(ip) :: i, j, jc, l, ipair, ineigh, nthreads, ithread, nn + real(rp) :: eij, rij0, rij, ci(3), cj(3), s, vtmp + type(ommp_topology_type), pointer :: top + procedure(vdw_term), pointer :: vdw_func + + integer(ip), allocatable :: nl_neigh(:,:) + real(rp), allocatable :: nl_r(:,:) + + integer :: omp_get_num_threads, omp_get_thread_num + + call time_push() + !$omp parallel + nthreads = omp_get_num_threads() + !$omp end parallel + + top => vdw%top + select case(vdw%vdwtype) + case(OMMP_VDWTYPE_LJ) + vdw_func => vdw_lennard_jones + case(OMMP_VDWTYPE_BUF714) + vdw_func => vdw_buffered_7_14 + case default + vdw_func => vdw_buffered_7_14 + call fatal_error("Unexpected error in vdw_potential") + end select + + if(vdw%use_nl) then + call mallocate('vdw_potential [rneigh]', top%mm_atoms, nthreads, nl_r) + call mallocate('vdw_potential [nl_neigh]', top%mm_atoms, nthreads, nl_neigh) + end if + + !$omp parallel do default(shared) reduction(+:v) schedule(dynamic) & + !$omp private(i,j,jc,ineigh,ithread,nn,s,ci,cj,ipair,l,Eij,Rij0,Rij,vtmp) + do i=1, top%mm_atoms + ithread = omp_get_thread_num() + 1 + if(abs(vdw%vdw_f(i) - 1.0_rp) < eps_rp) then + ci = top%cmm(:,i) + else + ! Scale factors are used only for monovalent atoms, in that + ! case the vdw center is displaced along the axis connecting + ! the atom to its neighbour + if(top%conn(1)%ri(i+1) - top%conn(1)%ri(i) /= 1) then + call fatal_error("Scale factors are only expected for & + &monovalent atoms") + end if + ineigh = top%conn(1)%ci(top%conn(1)%ri(i)) + + ci = top%cmm(:,ineigh) + (top%cmm(:,i) - top%cmm(:,ineigh)) & + * vdw%vdw_f(i) + endif + + ! If neighbor list are enabled get the one for the current + if(vdw%use_nl) call get_ith_nl(vdw%nl, i, top%cmm, & + nl_neigh(:,ithread), & + nl_r(:,ithread), nn) + + do jc=1, top%mm_atoms + ! If the two atoms aren't neighbors, just skip the loop + if(vdw%use_nl) then + if(jc > nn) exit !! All neighbors done! + j = nl_neigh(jc,ithread) + if(j <= i) cycle + else + ! Skip all iteration with j <= i + if(jc > i) then + j = jc + else + cycle + end if + end if + ! Compute the screening factor for this pair + s = 1.0_rp + do ineigh=1,4 + ! Look if j is at distance ineigh from i + if(any(top%conn(ineigh)%ci(top%conn(ineigh)%ri(i): & + top%conn(ineigh)%ri(i+1)-1) == j)) then + + s = vdw%vdw_screening(ineigh) + ! Exit the loop + exit + end if + end do + + if(s > eps_rp) then + ipair = -1 + do l=1, vdw%npair + if((vdw%vdw_pair_mask_a(i,l) .and. vdw%vdw_pair_mask_b(j,l)) .or. & + (vdw%vdw_pair_mask_a(j,l) .and. vdw%vdw_pair_mask_b(i,l))) then + ipair = l + exit + end if + end do + + if(ipair > 0) then + Rij0 = vdw%vdw_pair_r(ipair) + eij = vdw%vdw_pair_e(ipair) + else + Rij0 = get_Rij0(vdw, i, j) + eij = get_eij(vdw, i, j) + end if + + if(abs(vdw%vdw_f(j) - 1.0_rp) < eps_rp) then + cj = top%cmm(:,j) + else + ! Scale factors are used only for monovalent atoms, in that + ! case the vdw center is displaced along the axis connecting + ! the atom to its neighbour + if(top%conn(1)%ri(j+1) - top%conn(1)%ri(j) /= 1) then + call fatal_error("Scale factors are only expected & + & for monovalent atoms") + end if + ineigh = top%conn(1)%ci(top%conn(1)%ri(j)) + + cj = top%cmm(:,ineigh) + & + (top%cmm(:,j) - top%cmm(:,ineigh)) * vdw%vdw_f(j) + endif + Rij = norm2(ci-cj) + if(Rij < eps_rp) then + call fatal_error("Requesting non-bonded potential for two atoms & + &placed in the same point, this could be & + &an internal bug or a problem in your input & + &file, please check.") + end if + + vtmp = 0.0_rp + call vdw_func(Rij, Rij0, Eij, vtmp) + v = v + vtmp*s + end if + end do + end do + + if(vdw%use_nl) then + call mfree('vdw_potential [rneigh]', nl_r) + call mfree('vdw_potential [nl_neigh]', nl_neigh) + end if + call time_pull('VdW potential calculation') + end subroutine vdw_potential + + subroutine vdw_geomgrad(vdw, grad) + !! Compute the dispersion repulsion geometric gradients for the whole system + !! using a double loop algorithm + + use mod_io, only : fatal_error + use mod_constants, only: eps_rp + use mod_jacobian_mat, only: Rij_jacobian + use mod_profiling, only: time_push, time_pull + use mod_memory, only: mallocate, mfree + use mod_neighbor_list, only: get_ith_nl + implicit none + + type(ommp_nonbonded_type), intent(in), target :: vdw + !! Nonbonded data structure + real(rp), intent(inout) :: grad(3,vdw%top%mm_atoms) + !! Gradients, result will be added + + integer(ip) :: i, j, l, ipair, ineigh, ineigh_i, ineigh_j, jc, & + nn, ithread, nthreads + real(rp) :: eij, rij0, rij, ci(3), cj(3), s, J_i(3), J_j(3), Rijg, & + f_i, f_j + logical :: skip + type(ommp_topology_type), pointer :: top + procedure(vdw_gterm), pointer :: vdw_gfunc + + integer(ip), allocatable :: nl_neigh(:,:) + real(rp), allocatable :: nl_r(:,:) + + integer :: omp_get_num_threads, omp_get_thread_num + + call time_push() + !$omp parallel + nthreads = omp_get_num_threads() + !$omp end parallel + + top => vdw%top + select case(vdw%vdwtype) + case(OMMP_VDWTYPE_LJ) + vdw_gfunc => vdw_lennard_jones_Rijgrad + case(OMMP_VDWTYPE_BUF714) + vdw_gfunc => vdw_buffered_7_14_Rijgrad + case default + vdw_gfunc => vdw_buffered_7_14_Rijgrad + call fatal_error("Unexpected error in vdw_geomgrad") + end select + + if(vdw%use_nl) then + call mallocate('vdw_geomgrad [rneigh]', top%mm_atoms, nthreads, nl_r) + call mallocate('vdw_geomgrad [nl_neigh]', top%mm_atoms, nthreads, nl_neigh) + end if + + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,ci,cj,ineigh,ineigh_i,ineigh_j,f_i,f_j,s,ipair,l) & + !$omp private(Eij,Rij0,Rijg,Rij,J_i,J_j,skip,jc,nn,ithread) + do i=1, top%mm_atoms + ithread = omp_get_thread_num() + 1 + if(abs(vdw%vdw_f(i) - 1.0) < eps_rp) then + ci = top%cmm(:,i) + ineigh_i = 0 ! This is needed later for force projection + f_i = 1.0 + else + ! Scale factors are used only for monovalent atoms, in that + ! case the vdw center is displaced along the axis connecting + ! the atom to its neighbour + if(top%conn(1)%ri(i+1) - top%conn(1)%ri(i) /= 1) then + call fatal_error("Scale factors are only expected for & + &monovalent atoms") + end if + ineigh_i = top%conn(1)%ci(top%conn(1)%ri(i)) + f_i = vdw%vdw_f(i) + + ci = top%cmm(:,ineigh_i) + (top%cmm(:,i) - & + top%cmm(:,ineigh_i)) * f_i + endif + + if(vdw%use_nl) call get_ith_nl(vdw%nl, i, top%cmm, & + nl_neigh(:,ithread), & + nl_r(:,ithread), nn) + + do jc=1, top%mm_atoms + ! If the two atoms aren't neighbors, just skip the loop + if(vdw%use_nl) then + if(jc > nn) exit !! All neighbors done! + j = nl_neigh(jc,ithread) + if(j <= i) cycle + else + ! Skip all iteration with j <= i + if(jc > i) then + j = jc + else + cycle + end if + end if + ! Compute the screening factor for this pair + s = 1.0_rp + do ineigh=1,4 + ! Look if j is at distance ineigh from i + if(any(top%conn(ineigh)%ci(top%conn(ineigh)%ri(i): & + top%conn(ineigh)%ri(i+1)-1) == j)) then + + s = vdw%vdw_screening(ineigh) + ! Exit the loop + exit + end if + end do + + if(s > eps_rp) then + if(abs(vdw%vdw_f(j) - 1.0) < eps_rp) then + cj = top%cmm(:,j) + ineigh_j = 0 ! This is needed later for force projection + f_j = 1.0 + else + ! Scale factors are used only for monovalent atoms, in that + ! case the vdw center is displaced along the axis connecting + ! the atom to its neighbour + if(top%conn(1)%ri(j+1) - top%conn(1)%ri(j) /= 1) then + call fatal_error("Scale factors are only expected & + & for monovalent atoms") + end if + ineigh_j = top%conn(1)%ci(top%conn(1)%ri(j)) + f_j = vdw%vdw_f(j) + + cj = top%cmm(:,ineigh_j) + & + (top%cmm(:,j) - top%cmm(:,ineigh_j)) * f_j + endif + + ! if all atoms in the interaction are frozen + ! just skip to next iteration + if(top%use_frozen) then + skip = .true. + skip = skip .and. top%frozen(i) + skip = skip .and. top%frozen(j) + if(ineigh_i > 0) skip = skip .and. top%frozen(ineigh_i) + if(ineigh_j > 0) skip = skip .and. top%frozen(ineigh_j) + if(skip) cycle + end if + + ipair = -1 + do l=1, vdw%npair + if((vdw%vdw_pair_mask_a(i,l) .and. vdw%vdw_pair_mask_b(j,l)) .or. & + (vdw%vdw_pair_mask_a(j,l) .and. vdw%vdw_pair_mask_b(i,l))) then + ipair = l + exit + end if + end do + + if(ipair > 0) then + Rij0 = vdw%vdw_pair_r(ipair) + eij = vdw%vdw_pair_e(ipair) + else + Rij0 = get_Rij0(vdw, i, j) + eij = get_eij(vdw, i, j) + end if + + call Rij_jacobian(ci, cj, Rij, J_i, J_j) + if(Rij < eps_rp) then + call fatal_error("Requesting non-bonded gradients for two atoms & + &placed in the same point, this could be & + &an internal bug or a problem in your input & + &file, please check.") + end if + call vdw_gfunc(Rij, Rij0, Eij, Rijg) + + Rijg = Rijg * s + + if(ineigh_i == 0) then + if(.not. (top%use_frozen .and. top%frozen(i))) then + !$omp atomic update + grad(1,i) = grad(1,i) + J_i(1) * Rijg + !$omp atomic update + grad(2,i) = grad(2,i) + J_i(2) * Rijg + !$omp atomic update + grad(3,i) = grad(3,i) + J_i(3) * Rijg + end if + else + ! If the center is displaced, the forces should be + ! projected onto the two atoms that determine the + ! position of the center + if(.not. (top%use_frozen .and. top%frozen(i))) then + !$omp atomic update + grad(1,i) = grad(1,i) + J_i(1) * Rijg * f_i + !$omp atomic update + grad(2,i) = grad(2,i) + J_i(2) * Rijg * f_i + !$omp atomic update + grad(3,i) = grad(3,i) + J_i(3) * Rijg * f_i + end if + if(.not. (top%use_frozen .and. top%frozen(ineigh_i))) then + !$omp atomic update + grad(1,ineigh_i) = grad(1,ineigh_i) + J_i(1) * Rijg * (1-f_i) + !$omp atomic update + grad(2,ineigh_i) = grad(2,ineigh_i) + J_i(2) * Rijg * (1-f_i) + !$omp atomic update + grad(3,ineigh_i) = grad(3,ineigh_i) + J_i(3) * Rijg * (1-f_i) + end if + end if + + if(ineigh_j == 0) then + if(.not. (top%use_frozen .and. top%frozen(j))) then + !$omp atomic update + grad(1,j) = grad(1,j) + J_j(1) * Rijg + !$omp atomic update + grad(2,j) = grad(2,j) + J_j(2) * Rijg + !$omp atomic update + grad(3,j) = grad(3,j) + J_j(3) * Rijg + end if + else + ! If the center is displaced, the forces should be + ! projected onto the two atoms that determine the + ! position of the center + if(.not. (top%use_frozen .and. top%frozen(j))) then + !$omp atomic update + grad(1,j) = grad(1,j) + J_j(1) * Rijg * f_j + !$omp atomic update + grad(2,j) = grad(2,j) + J_j(2) * Rijg * f_j + !$omp atomic update + grad(3,j) = grad(3,j) + J_j(3) * Rijg * f_j + end if + if(.not. (top%use_frozen .and. top%frozen(ineigh_j))) then + !$omp atomic update + grad(1,ineigh_j) = grad(1,ineigh_j) + J_j(1) * Rijg * (1-f_j) + !$omp atomic update + grad(2,ineigh_j) = grad(2,ineigh_j) + J_j(2) * Rijg * (1-f_j) + !$omp atomic update + grad(3,ineigh_j) = grad(3,ineigh_j) + J_j(3) * Rijg * (1-f_j) + end if + endif + end if + end do + end do + call time_pull('VdW gradients calculation') + end subroutine + + subroutine vdw_potential_inter(vdw1, vdw2, V) + !! Compute the dispersion repulsion energy for the whole system + !! using a double loop algorithm + + use mod_io, only : fatal_error + use mod_constants, only: eps_rp + implicit none + + type(ommp_nonbonded_type), intent(in), target :: vdw1, vdw2 + !! Nonbonded data structure + real(rp), intent(inout) :: V + !! Potential, result will be added + + integer(ip) :: i, j, ineigh + real(rp) :: eij, rij0, rij, ci(3), cj(3), vtmp + type(ommp_topology_type), pointer :: top1, top2 + procedure(vdw_term), pointer :: vdw_func + + top1 => vdw1%top + top2 => vdw2%top + + if(vdw1%vdwtype /= vdw2%vdwtype .or. & + vdw1%radrule /= vdw2%radrule .or. & + vdw1%epsrule /= vdw2%epsrule) then + call fatal_error("Requested VdW potential between two incompatible & + &VdW groups.") + end if + + select case(vdw1%vdwtype) + case(OMMP_VDWTYPE_LJ) + vdw_func => vdw_lennard_jones + case(OMMP_VDWTYPE_BUF714) + vdw_func => vdw_buffered_7_14 + case default + vdw_func => vdw_buffered_7_14 + call fatal_error("Unexpected error in vdw_potential_inter") + end select + + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,ci,cj,ineigh,Rij,Rij0,Eij,vtmp) reduction(+:v) + do i=1, top1%mm_atoms + if(abs(vdw1%vdw_f(i) - 1.0_rp) < eps_rp) then + ci = top1%cmm(:,i) + else + ! Scale factors are used only for monovalent atoms, in that + ! case the vdw center is displaced along the axis connecting + ! the atom to its neighbour + if(top1%conn(1)%ri(i+1) - top1%conn(1)%ri(i) /= 1) then + call fatal_error("Scale factors are only expected for & + &monovalent atoms (top1)") + end if + ineigh = top1%conn(1)%ci(top1%conn(1)%ri(i)) + + ci = top1%cmm(:,ineigh) + (top1%cmm(:,i) - top1%cmm(:,ineigh)) & + * vdw1%vdw_f(i) + endif + + do j=1, top2%mm_atoms + Rij0 = get_Rij0_inter(vdw1, vdw2, i, j) + eij = get_eij_inter(vdw1, vdw2, i, j) + + if(abs(vdw2%vdw_f(j) - 1.0_rp) < eps_rp) then + cj = top2%cmm(:,j) + else + ! Scale factors are used only for monovalent atoms, in that + ! case the vdw center is displaced along the axis connecting + ! the atom to its neighbour + if(top2%conn(1)%ri(j+1) - top2%conn(1)%ri(j) /= 1) then + call fatal_error("Scale factors are only expected & + & for monovalent atoms (top2) atom") + end if + ineigh = top2%conn(1)%ci(top2%conn(1)%ri(j)) + + cj = top2%cmm(:,ineigh) + & + (top2%cmm(:,j) - top2%cmm(:,ineigh)) * vdw2%vdw_f(j) + endif + Rij = norm2(ci-cj) + if(Rij < eps_rp) then + call fatal_error("Requesting inter non-bonded potential for two atoms & + &placed in the same point, this could be & + &an internal bug or a problem in your input & + &file, please check.") + end if + + vtmp = 0.0_rp + call vdw_func(Rij, Rij0, Eij, vtmp) + v = v + vtmp + end do + end do + end subroutine vdw_potential_inter + + subroutine vdw_geomgrad_inter(vdw1, vdw2, grad1, grad2) + !! Compute the dispersion repulsion energy for the whole system + !! using a double loop algorithm + + use mod_io, only : fatal_error + use mod_constants, only: eps_rp + use mod_jacobian_mat, only: Rij_jacobian + implicit none + + type(ommp_nonbonded_type), intent(in), target :: vdw1, vdw2 + !! Nonbonded data structure + real(rp), intent(inout) :: grad1(3,vdw1%top%mm_atoms), & + grad2(3,vdw2%top%mm_atoms) + !! Potential, result will be added + + integer(ip) :: i, j, ineigh_i, ineigh_j + real(rp) :: eij, rij0, rij, ci(3), cj(3), Rijg, f_i, f_j, & + J_i(3), J_j(3) + logical :: skip + type(ommp_topology_type), pointer :: top1, top2 + procedure(vdw_gterm), pointer :: vdw_grad + + top1 => vdw1%top + top2 => vdw2%top + + if(vdw1%vdwtype /= vdw2%vdwtype .or. & + vdw1%radrule /= vdw2%radrule .or. & + vdw1%epsrule /= vdw2%epsrule) then + call fatal_error("Requested VdW potential between two incompatible & + &VdW groups.") + end if + + select case(vdw1%vdwtype) + case(OMMP_VDWTYPE_LJ) + vdw_grad => vdw_lennard_jones_Rijgrad + case(OMMP_VDWTYPE_BUF714) + vdw_grad => vdw_buffered_7_14_Rijgrad + case default + vdw_grad => vdw_buffered_7_14_Rijgrad + call fatal_error("Unexpected error in vdw_geomgrad_inter") + end select + + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,ci,cj,f_i,f_j,ineigh_i,ineigh_j,Eij,Rij0,Rij,Rijg,J_i,J_j,skip) + do i=1, top1%mm_atoms + if(abs(vdw1%vdw_f(i) - 1.0) < eps_rp) then + ci = top1%cmm(:,i) + ineigh_i = 0 + f_i = 1.0 + else + ! Scale factors are used only for monovalent atoms, in that + ! case the vdw center is displaced along the axis connecting + ! the atom to its neighbour + if(top1%conn(1)%ri(i+1) - top1%conn(1)%ri(i) /= 1) then + call fatal_error("Scale factors are only expected for & + &monovalent atoms") + end if + ineigh_i = top1%conn(1)%ci(top1%conn(1)%ri(i)) + f_i = vdw1%vdw_f(i) + ci = top1%cmm(:,ineigh_i) + (top1%cmm(:,i) - top1%cmm(:,ineigh_i)) & + * f_i + endif + + do j=1, top2%mm_atoms + if(abs(vdw2%vdw_f(j) - 1.0) < eps_rp) then + cj = top2%cmm(:,j) + ineigh_j = 0 + f_j = 1.0 + else + ! Scale factors are used only for monovalent atoms, in that + ! case the vdw center is displaced along the axis connecting + ! the atom to its neighbour + if(top2%conn(1)%ri(j+1) - top2%conn(1)%ri(j) /= 1) then + call fatal_error("Scale factors are only expected & + & for monovalent atoms") + end if + ineigh_j = top2%conn(1)%ci(top2%conn(1)%ri(j)) + f_j = vdw2%vdw_f(j) + + cj = top2%cmm(:,ineigh_j) + & + (top2%cmm(:,j) - top2%cmm(:,ineigh_j)) * f_j + endif + + skip = top1%use_frozen .and. top2%use_frozen + if(skip .and. top1%use_frozen) then + skip = skip .and. top1%frozen(i) + if(ineigh_i > 0) skip = skip .and. top1%frozen(ineigh_i) + end if + if(skip .and. top2%use_frozen) then + skip = skip .and. top2%frozen(j) + if(ineigh_j > 0) skip = skip .and. top2%frozen(ineigh_j) + end if + if(skip) cycle + + Rij0 = get_Rij0_inter(vdw1, vdw2, i, j) + eij = get_eij_inter(vdw1, vdw2, i, j) + + call Rij_jacobian(ci, cj, Rij, J_i, J_j) + if(Rij < eps_rp) then + call fatal_error("Requesting inter non-bonded gradients for two atoms & + &placed in the same point, this could be & + &an internal bug or a problem in your input & + &file, please check.") + end if + call vdw_grad(Rij, Rij0, Eij, Rijg) + + !$omp critical + if(ineigh_i == 0) then + if(.not. (top1%use_frozen .and. top1%frozen(i))) & + grad1(:,i) = grad1(:,i) + J_i * Rijg + else + ! If the center is displaced, the forces should be + ! projected onto the two atoms that determine the + ! position of the center + if(.not. (top1%use_frozen .and. top1%frozen(i))) & + grad1(:,i) = grad1(:,i) + J_i * Rijg * f_i + if(.not. (top1%use_frozen .and. top1%frozen(ineigh_i))) & + grad1(:,ineigh_i) = grad1(:,ineigh_i) + J_i * Rijg * (1-f_i) + end if + + if(ineigh_j == 0) then + if(.not. (top2%use_frozen .and. top2%frozen(j))) & + grad2(:,j) = grad2(:,j) + J_j * Rijg + else + ! If the center is displaced, the forces should be + ! projected onto the two atoms that determine the + ! position of the center + if(.not. (top2%use_frozen .and. top2%frozen(j))) & + grad2(:,j) = grad2(:,j) + J_j * Rijg * f_j + if(.not. (top2%use_frozen .and. top2%frozen(ineigh_j))) & + grad2(:,ineigh_j) = grad2(:,ineigh_j) + J_j * Rijg * (1-f_j) + endif + !$omp end critical + end do + end do + end subroutine + + subroutine vdw_potential_inter_restricted(vdw1, vdw2, pairs, s, n, V) + !! Compute the dispersion repulsion energy between two systems vdw1 + !! and vdw2 accounting only for the pairs pairs(1,i)--pairs(2,i) and scaling + !! each interaction by s(i). + + use mod_io, only : fatal_error + use mod_constants, only: eps_rp + implicit none + + type(ommp_nonbonded_type), intent(in), target :: vdw1, vdw2 + !! Nonbonded data structure + integer(ip), intent(in) :: n + !! number of pairs for which the interaction should be computed + integer(ip), intent(in) :: pairs(2,n) + !! pairs of atoms for which the interaction should be computed + real(rp), intent(in) :: s(:) + !! scaling factors for each interaction + real(rp), intent(inout) :: V + !! Potential, result will be added + + integer(ip) :: i, j, ineigh, ip + real(rp) :: eij, rij0, rij, ci(3), cj(3), vtmp + type(ommp_topology_type), pointer :: top1, top2 + procedure(vdw_term), pointer :: vdw_func + + top1 => vdw1%top + top2 => vdw2%top + + if(vdw1%vdwtype /= vdw2%vdwtype .or. & + vdw1%radrule /= vdw2%radrule .or. & + vdw1%epsrule /= vdw2%epsrule) then + call fatal_error("Requested VdW potential between two incompatible & + &VdW groups.") + end if + + select case(vdw1%vdwtype) + case(OMMP_VDWTYPE_LJ) + vdw_func => vdw_lennard_jones + case(OMMP_VDWTYPE_BUF714) + vdw_func => vdw_buffered_7_14 + case default + vdw_func => vdw_buffered_7_14 + call fatal_error("Unexpected error in vdw_potential_inter_restricted") + end select + + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,ip,ci,cj,ineigh,Rij,Rij0,Eij,vtmp) reduction(+:v) + do ip=1, n + i = pairs(1,ip) + j = pairs(2,ip) + + if(abs(vdw1%vdw_f(i) - 1.0_rp) < eps_rp) then + ci = top1%cmm(:,i) + else + ! Scale factors are used only for monovalent atoms, in that + ! case the vdw center is displaced along the axis connecting + ! the atom to its neighbour + if(top1%conn(1)%ri(i+1) - top1%conn(1)%ri(i) /= 1) then + call fatal_error("Scale factors are only expected for & + &monovalent atoms") + end if + ineigh = top1%conn(1)%ci(top1%conn(1)%ri(i)) + + ci = top1%cmm(:,ineigh) + (top1%cmm(:,i) - top1%cmm(:,ineigh)) & + * vdw1%vdw_f(i) + endif + + Rij0 = get_Rij0_inter(vdw1, vdw2, i, j) + eij = get_eij_inter(vdw1, vdw2, i, j) + + if(abs(vdw2%vdw_f(j) - 1.0_rp) < eps_rp) then + cj = top2%cmm(:,j) + else + ! Scale factors are used only for monovalent atoms, in that + ! case the vdw center is displaced along the axis connecting + ! the atom to its neighbour + if(top2%conn(1)%ri(j+1) - top2%conn(1)%ri(j) /= 1) then + call fatal_error("Scale factors are only expected & + & for monovalent atoms") + end if + ineigh = top2%conn(1)%ci(top2%conn(1)%ri(j)) + + cj = top2%cmm(:,ineigh) + & + (top2%cmm(:,j) - top2%cmm(:,ineigh)) * vdw2%vdw_f(j) + endif + Rij = norm2(ci-cj) + if(Rij < eps_rp) then + call fatal_error("Requesting inter non-bonded potential for two atoms & + &placed in the same point, this could be & + &an internal bug or a problem in your input & + &file, please check.") + end if + + vtmp = 0.0_rp + call vdw_func(Rij, Rij0, Eij, vtmp) + v = v + vtmp * s(ip) + end do + end subroutine vdw_potential_inter_restricted + + subroutine vdw_geomgrad_inter_restricted(vdw1, vdw2, pairs, s, n, & + grad1, grad2) + !! Compute the dispersion repulsion energy for the whole system + !! using a double loop algorithm + + use mod_io, only : fatal_error + use mod_constants, only: eps_rp + use mod_jacobian_mat, only: Rij_jacobian + implicit none + + type(ommp_nonbonded_type), intent(in), target :: vdw1, vdw2 + !! Nonbonded data structure + integer(ip), intent(in) :: n + !! number of pairs for which the interaction should be computed + integer(ip), intent(in) :: pairs(2,n) + !! pairs of atoms for which the interaction should be computed + real(rp), intent(in) :: s(:) + !! scaling factors for each interaction + real(rp), intent(inout) :: grad1(3,vdw1%top%mm_atoms), & + grad2(3,vdw2%top%mm_atoms) + !! Potential, result will be added + + integer(ip) :: i, j, ineigh_i, ineigh_j, ip + real(rp) :: eij, rij0, rij, ci(3), cj(3), Rijg, f_i, f_j, & + J_i(3), J_j(3) + logical :: skip + type(ommp_topology_type), pointer :: top1, top2 + procedure(vdw_gterm), pointer :: vdw_grad + + top1 => vdw1%top + top2 => vdw2%top + + if(vdw1%vdwtype /= vdw2%vdwtype .or. & + vdw1%radrule /= vdw2%radrule .or. & + vdw1%epsrule /= vdw2%epsrule) then + call fatal_error("Requested VdW potential between two incompatible & + &VdW groups.") + end if + + select case(vdw1%vdwtype) + case(OMMP_VDWTYPE_LJ) + vdw_grad => vdw_lennard_jones_Rijgrad + case(OMMP_VDWTYPE_BUF714) + vdw_grad => vdw_buffered_7_14_Rijgrad + case default + vdw_grad => vdw_buffered_7_14_Rijgrad + call fatal_error("Unexpected error in vdw_geomgrad_inter_restricted") + end select + + do ip=1, n + i = pairs(1,ip) + j = pairs(2,ip) + + if(abs(vdw1%vdw_f(i) - 1.0) < eps_rp) then + ci = top1%cmm(:,i) + ineigh_i = 0 + else + ! Scale factors are used only for monovalent atoms, in that + ! case the vdw center is displaced along the axis connecting + ! the atom to its neighbour + if(top1%conn(1)%ri(i+1) - top1%conn(1)%ri(i) /= 1) then + call fatal_error("Scale factors are only expected for & + &monovalent atoms") + end if + ineigh_i = top1%conn(1)%ci(top1%conn(1)%ri(i)) + f_i = vdw1%vdw_f(i) + ci = top1%cmm(:,ineigh_i) + (top1%cmm(:,i) - top1%cmm(:,ineigh_i)) & + * f_i + endif + + if(abs(vdw2%vdw_f(j) - 1.0) < eps_rp) then + cj = top2%cmm(:,j) + ineigh_j = 0 + else + ! Scale factors are used only for monovalent atoms, in that + ! case the vdw center is displaced along the axis connecting + ! the atom to its neighbour + if(top2%conn(1)%ri(j+1) - top2%conn(1)%ri(j) /= 1) then + call fatal_error("Scale factors are only expected & + & for monovalent atoms") + end if + ineigh_j = top2%conn(1)%ci(top2%conn(1)%ri(j)) + f_j = vdw2%vdw_f(j) + + cj = top2%cmm(:,ineigh_j) + & + (top2%cmm(:,j) - top2%cmm(:,ineigh_j)) * f_j + endif + + skip = top1%use_frozen .and. top2%use_frozen + if(skip .and. top1%use_frozen) then + skip = skip .and. top1%frozen(i) + if(ineigh_i > 0) skip = skip .and. top1%frozen(ineigh_i) + end if + if(skip .and. top2%use_frozen) then + skip = skip .and. top2%frozen(j) + if(ineigh_j > 0) skip = skip .and. top2%frozen(ineigh_j) + end if + if(skip) cycle + + Rij0 = get_Rij0_inter(vdw1, vdw2, i, j) + eij = get_eij_inter(vdw1, vdw2, i, j) * s(ip) + + call Rij_jacobian(ci, cj, Rij, J_i, J_j) + if(Rij < eps_rp) then + call fatal_error("Requesting inter non-bonded gradients for two atoms & + &placed in the same point, this could be & + &an internal bug or a problem in your input & + &file, please check.") + end if + call vdw_grad(Rij, Rij0, Eij, Rijg) + + if(ineigh_i == 0) then + if(.not. (top1%use_frozen .and. top1%frozen(i))) & + grad1(:,i) = grad1(:,i) + J_i * Rijg + else + ! If the center is displaced, the forces should be + ! projected onto the two atoms that determine the + ! position of the center + if(.not. (top1%use_frozen .and. top1%frozen(i))) & + grad1(:,i) = grad1(:,i) + J_i * Rijg * f_i + if(.not. (top1%use_frozen .and. top1%frozen(ineigh_i))) & + grad1(:,ineigh_i) = grad1(:,ineigh_i) + J_i * Rijg * (1-f_i) + end if + + if(ineigh_j == 0) then + if(.not. (top2%use_frozen .and. top2%frozen(j))) & + grad2(:,j) = grad2(:,j) + J_j * Rijg + else + ! If the center is displaced, the forces should be + ! projected onto the two atoms that determine the + ! position of the center + if(.not. (top2%use_frozen .and. top2%frozen(j))) & + grad2(:,j) = grad2(:,j) + J_j * Rijg * f_j + if(.not. (top2%use_frozen .and. top2%frozen(ineigh_j))) & + grad2(:,ineigh_j) = grad2(:,ineigh_j) + J_j * Rijg * (1-f_j) + endif + end do + end subroutine + +end module mod_nonbonded diff --git a/src/mod_nonbonded.f90 b/src/mod_nonbonded.f90 deleted file mode 100644 index 0181d6a..0000000 --- a/src/mod_nonbonded.f90 +++ /dev/null @@ -1,1361 +0,0 @@ -module mod_nonbonded - - use mod_memory, only: rp, ip, lp - use mod_neighbor_list, only: ommp_neigh_list - use mod_constants, only: OMMP_STR_CHAR_MAX - use mod_adjacency_mat, only: yale_sparse - use mod_topology, only: ommp_topology_type - use mod_constants, only: OMMP_VDWTYPE_LJ, & - OMMP_VDWTYPE_BUF714, & - OMMP_RADRULE_ARITHMETIC, & - OMMP_RADRULE_CUBIC, & - OMMP_RADTYPE_RMIN, & - OMMP_EPSRULE_GEOMETRIC, & - OMMP_EPSRULE_HHG - - implicit none - private - - integer(ip), parameter :: pair_allocation_chunk = 16 - - type ommp_nonbonded_type - !! Derived type for storing the information relative to the calculation - !! of non-bonding interactions - type(ommp_topology_type), pointer :: top - !! Data structure for topology - logical(lp) :: use_nl - !! Flag for using neighbors list - type(ommp_neigh_list) :: nl - !! Neighbor list struture - real(rp), allocatable, dimension(:) :: vdw_r - !! VdW radii for the atoms of the system - real(rp), allocatable, dimension(:) :: vdw_e - !! Vdw energies for the atoms of fthe system - real(rp), allocatable, dimension(:) :: vdw_f - !! Scale factor for displacing the interaction center - - integer(ip) :: npair = 0 - !! Number of nonbonded pair parameters - logical(lp), allocatable :: vdw_pair_mask_a(:,:), vdw_pair_mask_b(:,:) - !! Mask to apply a pair parameter to a pair of atoms dimension is - !! Natoms x Nparams - real(rp), allocatable :: vdw_pair_r(:) - !! Radii for the VdW atom pairs - real(rp), allocatable :: vdw_pair_e(:) - !! VdW energies for atom pairs - - real(rp), dimension(4) :: vdw_screening = [0.0, 0.0, 1.0, 1.0] - !! Screening factors for 1,2 1,3 and 1,4 neighbours. - !! Default vaules from tinker manual. - real(rp) :: radf = 1.0 - !! Scal factor for atomic radii/diameters (1.0 is used for diameters, - !! 2.0 for radii) - integer(ip) :: radrule - !! Flag for the radius rule to be used - integer(ip) :: radtype - !! Flag for the radius type - integer(ip) :: vdwtype - !! Flag for the vdW type - integer(ip) :: epsrule - !! Flag for eps rule !!TODO - end type ommp_nonbonded_type - - abstract interface - subroutine vdw_term(Rij, Rij0, Eij, V) - use mod_memory, only: rp - real(rp), intent(in) :: Rij - real(rp), intent(in) :: Rij0 - real(rp), intent(in) :: Eij - real(rp), intent(inout) :: V - end subroutine - end interface - - abstract interface - subroutine vdw_gterm(Rij, Rij0, Eij, Rijgrad) - use mod_memory, only: rp - real(rp), intent(in) :: Rij - real(rp), intent(in) :: Rij0 - real(rp), intent(in) :: Eij - real(rp), intent(out) :: Rijgrad - end subroutine - end interface - - public :: ommp_nonbonded_type - public :: vdw_init, vdw_terminate, vdw_set_pair, vdw_remove_potential - public :: vdw_set_cutoff - public :: vdw_potential, vdw_geomgrad - public :: vdw_potential_inter, vdw_geomgrad_inter - public :: vdw_potential_inter_restricted, vdw_geomgrad_inter_restricted - - contains - - subroutine vdw_init(vdw, top, vdw_type, radius_rule, radius_size, & - radius_type, epsrule, cutoff) - !! Initialize the non-bonded object allocating the parameters vectors - - use mod_memory, only: mallocate - use mod_io, only: fatal_error - use mod_neighbor_list, only: nl_init - use mod_constants, only: OMMP_DEFAULT_NL_SUB - - implicit none - - type(ommp_nonbonded_type), intent(inout) :: vdw - type(ommp_topology_type), intent(in), target :: top - character(len=*) :: vdw_type, radius_rule, radius_size, radius_type, & - epsrule - real(rp) :: cutoff - - select case(trim(vdw_type)) - case("lennard-jones") - vdw%vdwtype = OMMP_VDWTYPE_LJ - continue - case("buckingham") - call fatal_error("VdW type buckingham is not implemented") - case("buffered-14-7") - vdw%vdwtype = OMMP_VDWTYPE_BUF714 - continue - case("mm3-hbond") - call fatal_error("VdW type mm3-hbond is not implemented") - case("gaussian") - call fatal_error("VdW type gaussian is not implemented") - case default - call fatal_error("VdW type specified is not understood") - end select - - select case(trim(radius_rule)) - case("arithmetic") - vdw%radrule = OMMP_RADRULE_ARITHMETIC - continue - case("geometric") - call fatal_error("radiusrule geometric is not implemented") - case("cubic-mean") - vdw%radrule = OMMP_RADRULE_CUBIC - continue - case default - call fatal_error("radiusrule specified is not understood") - end select - - select case(trim(radius_size)) - case("radius") - vdw%radf = 2.0 - continue - case("diameter") - vdw%radf = 1.0 - continue - case default - call fatal_error("radiussize specified is not understood") - end select - - select case(trim(radius_type)) - case("sigma") - call fatal_error("radiustype sigma is not implemented") - case("r-min") - vdw%radtype = OMMP_RADTYPE_RMIN - continue - case default - call fatal_error("radiustype specified is not understood") - end select - - select case(trim(epsrule)) - case("geometric") - vdw%epsrule = OMMP_EPSRULE_GEOMETRIC - continue - case("arithmetic") - call fatal_error("epsilonrule arithmetic is not implemented") - case("harmonic") - call fatal_error("epsilonrule harmonic is not implemented") - case("w-h") - call fatal_error("epsilonrule w-h is not implemented") - case("hhg") - vdw%epsrule = OMMP_EPSRULE_HHG - continue - case default - call fatal_error("epsilonrule specified is not understood") - end select - - vdw%top => top - call mallocate('vdw_init [vdw_r]', top%mm_atoms, vdw%vdw_r) - call mallocate('vdw_init [vdw_e]', top%mm_atoms, vdw%vdw_e) - call mallocate('vdw_init [vdw_f]', top%mm_atoms, vdw%vdw_f) - - call mallocate('vdw_init [vdw_pair_mask_a]', & - top%mm_atoms, pair_allocation_chunk,vdw%vdw_pair_mask_a) - call mallocate('vdw_init [vdw_pair_mask_b]', & - top%mm_atoms, pair_allocation_chunk,vdw%vdw_pair_mask_b) - call mallocate('vdw_init [vdw_pair_r]', pair_allocation_chunk, & - vdw%vdw_pair_r) - call mallocate('vdw_init [vdw_pair_e]', pair_allocation_chunk, & - vdw%vdw_pair_e) - - vdw%vdw_f = 1.0_rp - - if(cutoff > 0.0) then - vdw%use_nl = .true. - if(vdw%use_nl) call nl_init(vdw%nl, top%cmm, cutoff, OMMP_DEFAULT_NL_SUB) - else - vdw%use_nl = .false. - end if - end subroutine vdw_init - - subroutine vdw_set_cutoff(vdw, cutoff, subdivision) - use mod_neighbor_list, only: nl_terminate, nl_init - implicit none - - type(ommp_nonbonded_type), intent(inout) :: vdw - real(rp), intent(in) :: cutoff - integer(ip), intent(in) :: subdivision - - if(vdw%use_nl) then - ! This is re-initialization, old stuff should be cleaned. - call nl_terminate(vdw%nl) - end if - if(cutoff > 0.0) then - vdw%use_nl = .true. - call nl_init(vdw%nl, vdw%top%cmm, cutoff, subdivision) - else - vdw%use_nl = .false. - end if - end subroutine - - subroutine vdw_terminate(vdw) - use mod_memory, only: mfree - use mod_adjacency_mat, only: matfree - use mod_neighbor_list, only: nl_terminate - - implicit none - - type(ommp_nonbonded_type), intent(inout) :: vdw - - call mfree('vdw_terminate [vdw_r]', vdw%vdw_r) - call mfree('vdw_terminate [vdw_e]', vdw%vdw_e) - call mfree('vdw_terminate [vdw_f]', vdw%vdw_f) - call mfree('vdw_terminate [vdw_pair_r]', vdw%vdw_pair_r) - call mfree('vdw_terminate [vdw_pair_e]', vdw%vdw_pair_e) - call mfree('vdw_terminate [vdw_pair_mask_b]', vdw%vdw_pair_mask_a) - call mfree('vdw_terminate [vdw_pair_mask_b]', vdw%vdw_pair_mask_b) - if(vdw%use_nl) call nl_terminate(vdw%nl) - - end subroutine - - subroutine vdw_remove_potential(vdw, i) - !! Remove the VdW interaction from the specified atom - !! the atom will not interact anymore with any other atom - implicit none - - type(ommp_nonbonded_type), intent(inout) :: vdw - integer(ip), intent(in) :: i - - vdw%vdw_e(i) = 0.0 - - ! TODO do it also for pair interactions - end subroutine - - subroutine vdw_set_pair(vdw, mask_a, mask_b, r, e) - use mod_io, only: ommp_message, fatal_error - use mod_constants, only: OMMP_VERBOSE_LOW - use mod_memory, only: mallocate, mfree - - implicit none - - type(ommp_nonbonded_type), intent(inout) :: vdw - !! Nonbonded data structure - logical(lp), intent(in) :: mask_a(vdw%top%mm_atoms) - logical(lp), intent(in) :: mask_b(vdw%top%mm_atoms) - real(rp), intent(in) :: r - !! Equilibrium distance for the pair - real(rp), intent(in) :: e - !! Depth of the potential - - integer(ip) :: oldsize, newsize - logical(lp), allocatable :: ltmp(:,:) - real(rp), allocatable :: rtmp(:) - character(len=OMMP_STR_CHAR_MAX) :: msg - - oldsize = size(vdw%vdw_pair_r) - if(vdw%npair >= oldsize) then - newsize = oldsize + pair_allocation_chunk - call mallocate('vdw_set_pair [rtmp]', oldsize, rtmp) - call mallocate('vdw_set_pair [ltmp]',vdw%top%mm_atoms, oldsize, ltmp) - - rtmp = vdw%vdw_pair_r - call mfree('vdw_set_pair [vdw%vdw_pair_r]', vdw%vdw_pair_r) - call mallocate('vdw_set_pair [vdw%vdw_pair_r]', newsize, vdw%vdw_pair_r) - vdw%vdw_pair_r(1:oldsize) = rtmp - - rtmp = vdw%vdw_pair_e - call mfree('vdw_set_pair [vdw%vdw_pair_e]', vdw%vdw_pair_e) - call mallocate('vdw_set_pair [vdw%vdw_pair_e]', newsize, vdw%vdw_pair_e) - vdw%vdw_pair_e(1:oldsize) = rtmp - - ltmp = vdw%vdw_pair_mask_a - call mfree('vdw_set_pair [vdw_pair_mask_a]', vdw%vdw_pair_mask_a) - call mallocate('vdw_set_pair [vdw_pair_mask_a]', & - vdw%top%mm_atoms, newsize, vdw%vdw_pair_mask_a) - vdw%vdw_pair_mask_a(:,1:oldsize) = ltmp - - ltmp = vdw%vdw_pair_mask_b - call mfree('vdw_set_pair [vdw_pair_mask_b]', vdw%vdw_pair_mask_b) - call mallocate('vdw_set_pair [vdw_pair_mask_b]', & - vdw%top%mm_atoms, newsize, vdw%vdw_pair_mask_b) - vdw%vdw_pair_mask_b(:,1:oldsize) = ltmp - - call mfree('vdw_set_pair [rtmp]', rtmp) - call mfree('vdw_set_pair [ltmp]', ltmp) - end if - vdw%npair = vdw%npair + 1 - vdw%vdw_pair_mask_a(:,vdw%npair) = mask_a - vdw%vdw_pair_mask_b(:,vdw%npair) = mask_b - vdw%vdw_pair_r(vdw%npair) = r - vdw%vdw_pair_e(vdw%npair) = e - - end subroutine vdw_set_pair - - subroutine vdw_lennard_jones(Rij, Rij0, Eij, V) - implicit none - - real(rp), intent(in) :: Rij - real(rp), intent(in) :: Rij0 - real(rp), intent(in) :: Eij - real(rp), intent(inout) :: V - - real(rp) :: sigma_ov_r - - sigma_ov_r = Rij0 / Rij - V = V + Eij*(sigma_ov_r**12 - 2_rp*sigma_ov_r**6) - - end subroutine vdw_lennard_jones - - subroutine vdw_lennard_jones_Rijgrad(Rij, Rij0, Eij, Rijgrad) - implicit none - - real(rp), intent(in) :: Rij - real(rp), intent(in) :: Rij0 - real(rp), intent(in) :: Eij - real(rp), intent(out) :: Rijgrad - - real(rp) :: sigma_ov_r - - sigma_ov_r = Rij0 / Rij - Rijgrad = -12.0 * Eij * (sigma_ov_r ** 12 - sigma_ov_r ** 6) / Rij - - end subroutine vdw_lennard_jones_Rijgrad - - subroutine vdw_buffered_7_14(Rij, Rij0, Eij, V) - !! Compute the dispersion-repulsion energy using the buffered 7-14 - !! potential. Details can be found in ref: 10.1021/jp027815 - - implicit none - - real(rp), intent(in) :: Rij - real(rp), intent(in) :: Rij0 - real(rp), intent(in) :: Eij - real(rp), intent(inout) :: V - - real(rp) :: rho - real(rp), parameter :: delta = 0.07, gam = 0.12 - integer(ip), parameter :: n = 14, m = 7 - - rho = Rij / Rij0 - V = V + Eij*((1+delta)/(rho+delta))**(n-m) * ((1+gam)/(rho**m+gam)-2) - - end subroutine vdw_buffered_7_14 - - subroutine vdw_buffered_7_14_Rijgrad(Rij, Rij0, Eij, Rijgrad) - !! Compute the gradient of vdw energy (using the buffered 7-14 - !! potential ref: 10.1021/jp027815) with respect to the distance - !! between the two atoms (Rij). - - implicit none - - real(rp), intent(in) :: Rij - real(rp), intent(in) :: Rij0 - real(rp), intent(in) :: Eij - real(rp), intent(out) :: Rijgrad - - real(rp) :: rho, rhom - real(rp), parameter :: delta = 0.07, gam = 0.12 - integer(ip), parameter :: n = 14, m = 7 - - rho = Rij / Rij0 - rhom = rho**m - Rijgrad = Eij * ((delta+1)/(delta+rho))**(n-m) * & - (rho*(gam+rhom)*(m-n)*(1-2*rhom-gam) - & - rhom*m*(delta+rho)*(gam+1)) / & - (rho*(delta+rho)*(gam+rhom)**2) - Rijgrad = Rijgrad / Rij0 - - end subroutine vdw_buffered_7_14_Rijgrad - - pure function get_Rij0(vdw, i, j) result(Rij0) - use mod_constants, only: eps_rp - - implicit none - - type(ommp_nonbonded_type), intent(in), target :: vdw - !! Nonbonded data structure - integer(ip), intent(in) :: i, j - !! Indices of interacting atoms - real(rp) :: Rij0 - - if(vdw%vdw_r(i) < eps_rp .and. vdw%vdw_r(j) < eps_rp) then - Rij0 = 0.0 - return - end if - - select case(vdw%radrule) - case(OMMP_RADRULE_ARITHMETIC) - Rij0 = vdw%radf*(vdw%vdw_r(i) + vdw%vdw_r(j))/2 - case(OMMP_RADRULE_CUBIC) - Rij0 = (vdw%vdw_r(i)**3 + vdw%vdw_r(j)**3) / & - (vdw%vdw_r(i)**2 + vdw%vdw_r(j)**2) - case default - Rij0 = 0.0 - end select - end function - - pure function get_eij(vdw, i, j) result(eij) - use mod_constants, only: eps_rp - - implicit none - - type(ommp_nonbonded_type), intent(in) :: vdw - !! Nonbonded data structure - integer(ip), intent(in) :: i, j - !! Indices of interacting atoms - real(rp) :: eij - - if(vdw%vdw_e(i) < eps_rp .and. vdw%vdw_e(j) < eps_rp) then - eij = 0.0 - return - end if - - select case(vdw%epsrule) - case(OMMP_EPSRULE_GEOMETRIC) - eij = sqrt(vdw%vdw_e(i)*vdw%vdw_e(j)) - case(OMMP_EPSRULE_HHG) - eij = (4*vdw%vdw_e(i)*vdw%vdw_e(j)) / & - (vdw%vdw_e(i)**0.5 + vdw%vdw_e(j)**0.5)**2 - case default - eij = 0.0 - end select - end function - - pure function get_Rij0_inter(vdw1, vdw2, i, j) result(Rij0) - use mod_constants, only: eps_rp - - implicit none - - type(ommp_nonbonded_type), intent(in), target :: vdw1, vdw2 - !! Nonbonded data structure - integer(ip), intent(in) :: i, j - !! Indices of interacting atoms - real(rp) :: Rij0 - - if(abs(vdw1%radrule - vdw2%radrule) > eps_rp .or. & - abs(vdw1%radf - vdw2%radf) > eps_rp) then - Rij0 = 0.0 - return - end if - - if(vdw1%vdw_r(i) < eps_rp .and. vdw2%vdw_r(j) < eps_rp) then - Rij0 = 0.0 - return - end if - - select case(vdw1%radrule) - case(OMMP_RADRULE_ARITHMETIC) - Rij0 = vdw1%radf*(vdw1%vdw_r(i) + vdw2%vdw_r(j))/2 - case(OMMP_RADRULE_CUBIC) - Rij0 = (vdw1%vdw_r(i)**3 + vdw2%vdw_r(j)**3) / & - (vdw1%vdw_r(i)**2 + vdw2%vdw_r(j)**2) - case default - Rij0 = 0.0 - end select - end function - - pure function get_eij_inter(vdw1, vdw2, i, j) result(eij) - use mod_constants, only: eps_rp - - implicit none - - type(ommp_nonbonded_type), intent(in) :: vdw1, vdw2 - !! Nonbonded data structure - integer(ip), intent(in) :: i, j - !! Indices of interacting atoms - real(rp) :: eij - - if(vdw1%epsrule /= vdw2%epsrule) then - eij = 0.0 - return - end if - - if(vdw1%vdw_e(i) < eps_rp .and. vdw2%vdw_e(j) < eps_rp) then - eij = 0.0 - return - end if - - select case(vdw1%epsrule) - case(OMMP_EPSRULE_GEOMETRIC) - eij = sqrt(vdw1%vdw_e(i)*vdw2%vdw_e(j)) - case(OMMP_EPSRULE_HHG) - eij = (4*vdw1%vdw_e(i)*vdw2%vdw_e(j)) / & - (vdw1%vdw_e(i)**0.5 + vdw2%vdw_e(j)**0.5)**2 - case default - eij = 0.0 - end select - end function - - subroutine vdw_potential(vdw, V) - !! Compute the dispersion repulsion energy for the whole system - !! using a double loop algorithm - - use mod_io, only : fatal_error - use mod_profiling, only: time_push, time_pull - use mod_constants, only: eps_rp - use mod_memory, only: mallocate, mfree - use mod_neighbor_list, only: get_ith_nl - implicit none - - type(ommp_nonbonded_type), intent(in), target :: vdw - !! Nonbonded data structure - real(rp), intent(inout) :: V - !! Potential, result will be added - - integer(ip) :: i, j, jc, l, ipair, ineigh, nthreads, ithread, nn - real(rp) :: eij, rij0, rij, ci(3), cj(3), s, vtmp - type(ommp_topology_type), pointer :: top - procedure(vdw_term), pointer :: vdw_func - - integer(ip), allocatable :: nl_neigh(:,:) - real(rp), allocatable :: nl_r(:,:) - - integer :: omp_get_num_threads, omp_get_thread_num - - call time_push() - !$omp parallel - nthreads = omp_get_num_threads() - !$omp end parallel - - top => vdw%top - select case(vdw%vdwtype) - case(OMMP_VDWTYPE_LJ) - vdw_func => vdw_lennard_jones - case(OMMP_VDWTYPE_BUF714) - vdw_func => vdw_buffered_7_14 - case default - vdw_func => vdw_buffered_7_14 - call fatal_error("Unexpected error in vdw_potential") - end select - - if(vdw%use_nl) then - call mallocate('vdw_potential [rneigh]', top%mm_atoms, nthreads, nl_r) - call mallocate('vdw_potential [nl_neigh]', top%mm_atoms, nthreads, nl_neigh) - end if - - !$omp parallel do default(shared) reduction(+:v) schedule(dynamic) & - !$omp private(i,j,jc,ineigh,ithread,nn,s,ci,cj,ipair,l,Eij,Rij0,Rij,vtmp) - do i=1, top%mm_atoms - ithread = omp_get_thread_num() + 1 - if(abs(vdw%vdw_f(i) - 1.0_rp) < eps_rp) then - ci = top%cmm(:,i) - else - ! Scale factors are used only for monovalent atoms, in that - ! case the vdw center is displaced along the axis connecting - ! the atom to its neighbour - if(top%conn(1)%ri(i+1) - top%conn(1)%ri(i) /= 1) then - call fatal_error("Scale factors are only expected for & - &monovalent atoms") - end if - ineigh = top%conn(1)%ci(top%conn(1)%ri(i)) - - ci = top%cmm(:,ineigh) + (top%cmm(:,i) - top%cmm(:,ineigh)) & - * vdw%vdw_f(i) - endif - - ! If neighbor list are enabled get the one for the current - if(vdw%use_nl) call get_ith_nl(vdw%nl, i, top%cmm, & - nl_neigh(:,ithread), & - nl_r(:,ithread), nn) - - do jc=1, top%mm_atoms - ! If the two atoms aren't neighbors, just skip the loop - if(vdw%use_nl) then - if(jc > nn) exit !! All neighbors done! - j = nl_neigh(jc,ithread) - if(j <= i) cycle - else - ! Skip all iteration with j <= i - if(jc > i) then - j = jc - else - cycle - end if - end if - ! Compute the screening factor for this pair - s = 1.0_rp - do ineigh=1,4 - ! Look if j is at distance ineigh from i - if(any(top%conn(ineigh)%ci(top%conn(ineigh)%ri(i): & - top%conn(ineigh)%ri(i+1)-1) == j)) then - - s = vdw%vdw_screening(ineigh) - ! Exit the loop - exit - end if - end do - - if(s > eps_rp) then - ipair = -1 - do l=1, vdw%npair - if((vdw%vdw_pair_mask_a(i,l) .and. vdw%vdw_pair_mask_b(j,l)) .or. & - (vdw%vdw_pair_mask_a(j,l) .and. vdw%vdw_pair_mask_b(i,l))) then - ipair = l - exit - end if - end do - - if(ipair > 0) then - Rij0 = vdw%vdw_pair_r(ipair) - eij = vdw%vdw_pair_e(ipair) - else - Rij0 = get_Rij0(vdw, i, j) - eij = get_eij(vdw, i, j) - end if - - if(abs(vdw%vdw_f(j) - 1.0_rp) < eps_rp) then - cj = top%cmm(:,j) - else - ! Scale factors are used only for monovalent atoms, in that - ! case the vdw center is displaced along the axis connecting - ! the atom to its neighbour - if(top%conn(1)%ri(j+1) - top%conn(1)%ri(j) /= 1) then - call fatal_error("Scale factors are only expected & - & for monovalent atoms") - end if - ineigh = top%conn(1)%ci(top%conn(1)%ri(j)) - - cj = top%cmm(:,ineigh) + & - (top%cmm(:,j) - top%cmm(:,ineigh)) * vdw%vdw_f(j) - endif - Rij = norm2(ci-cj) - if(Rij < eps_rp) then - call fatal_error("Requesting non-bonded potential for two atoms & - &placed in the same point, this could be & - &an internal bug or a problem in your input & - &file, please check.") - end if - - vtmp = 0.0_rp - call vdw_func(Rij, Rij0, Eij, vtmp) - v = v + vtmp*s - end if - end do - end do - - if(vdw%use_nl) then - call mfree('vdw_potential [rneigh]', nl_r) - call mfree('vdw_potential [nl_neigh]', nl_neigh) - end if - call time_pull('VdW potential calculation') - end subroutine vdw_potential - - subroutine vdw_geomgrad(vdw, grad) - !! Compute the dispersion repulsion geometric gradients for the whole system - !! using a double loop algorithm - - use mod_io, only : fatal_error - use mod_constants, only: eps_rp - use mod_jacobian_mat, only: Rij_jacobian - use mod_profiling, only: time_push, time_pull - use mod_memory, only: mallocate, mfree - use mod_neighbor_list, only: get_ith_nl - implicit none - - type(ommp_nonbonded_type), intent(in), target :: vdw - !! Nonbonded data structure - real(rp), intent(inout) :: grad(3,vdw%top%mm_atoms) - !! Gradients, result will be added - - integer(ip) :: i, j, l, ipair, ineigh, ineigh_i, ineigh_j, jc, & - nn, ithread, nthreads - real(rp) :: eij, rij0, rij, ci(3), cj(3), s, J_i(3), J_j(3), Rijg, & - f_i, f_j - logical :: skip - type(ommp_topology_type), pointer :: top - procedure(vdw_gterm), pointer :: vdw_gfunc - - integer(ip), allocatable :: nl_neigh(:,:) - real(rp), allocatable :: nl_r(:,:) - - integer :: omp_get_num_threads, omp_get_thread_num - - call time_push() - !$omp parallel - nthreads = omp_get_num_threads() - !$omp end parallel - - top => vdw%top - select case(vdw%vdwtype) - case(OMMP_VDWTYPE_LJ) - vdw_gfunc => vdw_lennard_jones_Rijgrad - case(OMMP_VDWTYPE_BUF714) - vdw_gfunc => vdw_buffered_7_14_Rijgrad - case default - vdw_gfunc => vdw_buffered_7_14_Rijgrad - call fatal_error("Unexpected error in vdw_geomgrad") - end select - - if(vdw%use_nl) then - call mallocate('vdw_geomgrad [rneigh]', top%mm_atoms, nthreads, nl_r) - call mallocate('vdw_geomgrad [nl_neigh]', top%mm_atoms, nthreads, nl_neigh) - end if - - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,ci,cj,ineigh,ineigh_i,ineigh_j,f_i,f_j,s,ipair,l) & - !$omp private(Eij,Rij0,Rijg,Rij,J_i,J_j,skip,jc,nn,ithread) - do i=1, top%mm_atoms - ithread = omp_get_thread_num() + 1 - if(abs(vdw%vdw_f(i) - 1.0) < eps_rp) then - ci = top%cmm(:,i) - ineigh_i = 0 ! This is needed later for force projection - f_i = 1.0 - else - ! Scale factors are used only for monovalent atoms, in that - ! case the vdw center is displaced along the axis connecting - ! the atom to its neighbour - if(top%conn(1)%ri(i+1) - top%conn(1)%ri(i) /= 1) then - call fatal_error("Scale factors are only expected for & - &monovalent atoms") - end if - ineigh_i = top%conn(1)%ci(top%conn(1)%ri(i)) - f_i = vdw%vdw_f(i) - - ci = top%cmm(:,ineigh_i) + (top%cmm(:,i) - & - top%cmm(:,ineigh_i)) * f_i - endif - - if(vdw%use_nl) call get_ith_nl(vdw%nl, i, top%cmm, & - nl_neigh(:,ithread), & - nl_r(:,ithread), nn) - - do jc=1, top%mm_atoms - ! If the two atoms aren't neighbors, just skip the loop - if(vdw%use_nl) then - if(jc > nn) exit !! All neighbors done! - j = nl_neigh(jc,ithread) - if(j <= i) cycle - else - ! Skip all iteration with j <= i - if(jc > i) then - j = jc - else - cycle - end if - end if - ! Compute the screening factor for this pair - s = 1.0_rp - do ineigh=1,4 - ! Look if j is at distance ineigh from i - if(any(top%conn(ineigh)%ci(top%conn(ineigh)%ri(i): & - top%conn(ineigh)%ri(i+1)-1) == j)) then - - s = vdw%vdw_screening(ineigh) - ! Exit the loop - exit - end if - end do - - if(s > eps_rp) then - if(abs(vdw%vdw_f(j) - 1.0) < eps_rp) then - cj = top%cmm(:,j) - ineigh_j = 0 ! This is needed later for force projection - f_j = 1.0 - else - ! Scale factors are used only for monovalent atoms, in that - ! case the vdw center is displaced along the axis connecting - ! the atom to its neighbour - if(top%conn(1)%ri(j+1) - top%conn(1)%ri(j) /= 1) then - call fatal_error("Scale factors are only expected & - & for monovalent atoms") - end if - ineigh_j = top%conn(1)%ci(top%conn(1)%ri(j)) - f_j = vdw%vdw_f(j) - - cj = top%cmm(:,ineigh_j) + & - (top%cmm(:,j) - top%cmm(:,ineigh_j)) * f_j - endif - - ! if all atoms in the interaction are frozen - ! just skip to next iteration - if(top%use_frozen) then - skip = .true. - skip = skip .and. top%frozen(i) - skip = skip .and. top%frozen(j) - if(ineigh_i > 0) skip = skip .and. top%frozen(ineigh_i) - if(ineigh_j > 0) skip = skip .and. top%frozen(ineigh_j) - if(skip) cycle - end if - - ipair = -1 - do l=1, vdw%npair - if((vdw%vdw_pair_mask_a(i,l) .and. vdw%vdw_pair_mask_b(j,l)) .or. & - (vdw%vdw_pair_mask_a(j,l) .and. vdw%vdw_pair_mask_b(i,l))) then - ipair = l - exit - end if - end do - - if(ipair > 0) then - Rij0 = vdw%vdw_pair_r(ipair) - eij = vdw%vdw_pair_e(ipair) - else - Rij0 = get_Rij0(vdw, i, j) - eij = get_eij(vdw, i, j) - end if - - call Rij_jacobian(ci, cj, Rij, J_i, J_j) - if(Rij < eps_rp) then - call fatal_error("Requesting non-bonded gradients for two atoms & - &placed in the same point, this could be & - &an internal bug or a problem in your input & - &file, please check.") - end if - call vdw_gfunc(Rij, Rij0, Eij, Rijg) - - Rijg = Rijg * s - - if(ineigh_i == 0) then - if(.not. (top%use_frozen .and. top%frozen(i))) then - !$omp atomic update - grad(1,i) = grad(1,i) + J_i(1) * Rijg - !$omp atomic update - grad(2,i) = grad(2,i) + J_i(2) * Rijg - !$omp atomic update - grad(3,i) = grad(3,i) + J_i(3) * Rijg - end if - else - ! If the center is displaced, the forces should be - ! projected onto the two atoms that determine the - ! position of the center - if(.not. (top%use_frozen .and. top%frozen(i))) then - !$omp atomic update - grad(1,i) = grad(1,i) + J_i(1) * Rijg * f_i - !$omp atomic update - grad(2,i) = grad(2,i) + J_i(2) * Rijg * f_i - !$omp atomic update - grad(3,i) = grad(3,i) + J_i(3) * Rijg * f_i - end if - if(.not. (top%use_frozen .and. top%frozen(ineigh_i))) then - !$omp atomic update - grad(1,ineigh_i) = grad(1,ineigh_i) + J_i(1) * Rijg * (1-f_i) - !$omp atomic update - grad(2,ineigh_i) = grad(2,ineigh_i) + J_i(2) * Rijg * (1-f_i) - !$omp atomic update - grad(3,ineigh_i) = grad(3,ineigh_i) + J_i(3) * Rijg * (1-f_i) - end if - end if - - if(ineigh_j == 0) then - if(.not. (top%use_frozen .and. top%frozen(j))) then - !$omp atomic update - grad(1,j) = grad(1,j) + J_j(1) * Rijg - !$omp atomic update - grad(2,j) = grad(2,j) + J_j(2) * Rijg - !$omp atomic update - grad(3,j) = grad(3,j) + J_j(3) * Rijg - end if - else - ! If the center is displaced, the forces should be - ! projected onto the two atoms that determine the - ! position of the center - if(.not. (top%use_frozen .and. top%frozen(j))) then - !$omp atomic update - grad(1,j) = grad(1,j) + J_j(1) * Rijg * f_j - !$omp atomic update - grad(2,j) = grad(2,j) + J_j(2) * Rijg * f_j - !$omp atomic update - grad(3,j) = grad(3,j) + J_j(3) * Rijg * f_j - end if - if(.not. (top%use_frozen .and. top%frozen(ineigh_j))) then - !$omp atomic update - grad(1,ineigh_j) = grad(1,ineigh_j) + J_j(1) * Rijg * (1-f_j) - !$omp atomic update - grad(2,ineigh_j) = grad(2,ineigh_j) + J_j(2) * Rijg * (1-f_j) - !$omp atomic update - grad(3,ineigh_j) = grad(3,ineigh_j) + J_j(3) * Rijg * (1-f_j) - end if - endif - end if - end do - end do - call time_pull('VdW gradients calculation') - end subroutine - - subroutine vdw_potential_inter(vdw1, vdw2, V) - !! Compute the dispersion repulsion energy for the whole system - !! using a double loop algorithm - - use mod_io, only : fatal_error - use mod_constants, only: eps_rp - implicit none - - type(ommp_nonbonded_type), intent(in), target :: vdw1, vdw2 - !! Nonbonded data structure - real(rp), intent(inout) :: V - !! Potential, result will be added - - integer(ip) :: i, j, ineigh - real(rp) :: eij, rij0, rij, ci(3), cj(3), vtmp - type(ommp_topology_type), pointer :: top1, top2 - procedure(vdw_term), pointer :: vdw_func - - top1 => vdw1%top - top2 => vdw2%top - - if(vdw1%vdwtype /= vdw2%vdwtype .or. & - vdw1%radrule /= vdw2%radrule .or. & - vdw1%epsrule /= vdw2%epsrule) then - call fatal_error("Requested VdW potential between two incompatible & - &VdW groups.") - end if - - select case(vdw1%vdwtype) - case(OMMP_VDWTYPE_LJ) - vdw_func => vdw_lennard_jones - case(OMMP_VDWTYPE_BUF714) - vdw_func => vdw_buffered_7_14 - case default - vdw_func => vdw_buffered_7_14 - call fatal_error("Unexpected error in vdw_potential_inter") - end select - - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,ci,cj,ineigh,Rij,Rij0,Eij,vtmp) reduction(+:v) - do i=1, top1%mm_atoms - if(abs(vdw1%vdw_f(i) - 1.0_rp) < eps_rp) then - ci = top1%cmm(:,i) - else - ! Scale factors are used only for monovalent atoms, in that - ! case the vdw center is displaced along the axis connecting - ! the atom to its neighbour - if(top1%conn(1)%ri(i+1) - top1%conn(1)%ri(i) /= 1) then - call fatal_error("Scale factors are only expected for & - &monovalent atoms (top1)") - end if - ineigh = top1%conn(1)%ci(top1%conn(1)%ri(i)) - - ci = top1%cmm(:,ineigh) + (top1%cmm(:,i) - top1%cmm(:,ineigh)) & - * vdw1%vdw_f(i) - endif - - do j=1, top2%mm_atoms - Rij0 = get_Rij0_inter(vdw1, vdw2, i, j) - eij = get_eij_inter(vdw1, vdw2, i, j) - - if(abs(vdw2%vdw_f(j) - 1.0_rp) < eps_rp) then - cj = top2%cmm(:,j) - else - ! Scale factors are used only for monovalent atoms, in that - ! case the vdw center is displaced along the axis connecting - ! the atom to its neighbour - if(top2%conn(1)%ri(j+1) - top2%conn(1)%ri(j) /= 1) then - call fatal_error("Scale factors are only expected & - & for monovalent atoms (top2) atom") - end if - ineigh = top2%conn(1)%ci(top2%conn(1)%ri(j)) - - cj = top2%cmm(:,ineigh) + & - (top2%cmm(:,j) - top2%cmm(:,ineigh)) * vdw2%vdw_f(j) - endif - Rij = norm2(ci-cj) - if(Rij < eps_rp) then - call fatal_error("Requesting inter non-bonded potential for two atoms & - &placed in the same point, this could be & - &an internal bug or a problem in your input & - &file, please check.") - end if - - vtmp = 0.0_rp - call vdw_func(Rij, Rij0, Eij, vtmp) - v = v + vtmp - end do - end do - end subroutine vdw_potential_inter - - subroutine vdw_geomgrad_inter(vdw1, vdw2, grad1, grad2) - !! Compute the dispersion repulsion energy for the whole system - !! using a double loop algorithm - - use mod_io, only : fatal_error - use mod_constants, only: eps_rp - use mod_jacobian_mat, only: Rij_jacobian - implicit none - - type(ommp_nonbonded_type), intent(in), target :: vdw1, vdw2 - !! Nonbonded data structure - real(rp), intent(inout) :: grad1(3,vdw1%top%mm_atoms), & - grad2(3,vdw2%top%mm_atoms) - !! Potential, result will be added - - integer(ip) :: i, j, ineigh_i, ineigh_j - real(rp) :: eij, rij0, rij, ci(3), cj(3), Rijg, f_i, f_j, & - J_i(3), J_j(3) - logical :: skip - type(ommp_topology_type), pointer :: top1, top2 - procedure(vdw_gterm), pointer :: vdw_grad - - top1 => vdw1%top - top2 => vdw2%top - - if(vdw1%vdwtype /= vdw2%vdwtype .or. & - vdw1%radrule /= vdw2%radrule .or. & - vdw1%epsrule /= vdw2%epsrule) then - call fatal_error("Requested VdW potential between two incompatible & - &VdW groups.") - end if - - select case(vdw1%vdwtype) - case(OMMP_VDWTYPE_LJ) - vdw_grad => vdw_lennard_jones_Rijgrad - case(OMMP_VDWTYPE_BUF714) - vdw_grad => vdw_buffered_7_14_Rijgrad - case default - vdw_grad => vdw_buffered_7_14_Rijgrad - call fatal_error("Unexpected error in vdw_geomgrad_inter") - end select - - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,ci,cj,f_i,f_j,ineigh_i,ineigh_j,Eij,Rij0,Rij,Rijg,J_i,J_j,skip) - do i=1, top1%mm_atoms - if(abs(vdw1%vdw_f(i) - 1.0) < eps_rp) then - ci = top1%cmm(:,i) - ineigh_i = 0 - f_i = 1.0 - else - ! Scale factors are used only for monovalent atoms, in that - ! case the vdw center is displaced along the axis connecting - ! the atom to its neighbour - if(top1%conn(1)%ri(i+1) - top1%conn(1)%ri(i) /= 1) then - call fatal_error("Scale factors are only expected for & - &monovalent atoms") - end if - ineigh_i = top1%conn(1)%ci(top1%conn(1)%ri(i)) - f_i = vdw1%vdw_f(i) - ci = top1%cmm(:,ineigh_i) + (top1%cmm(:,i) - top1%cmm(:,ineigh_i)) & - * f_i - endif - - do j=1, top2%mm_atoms - if(abs(vdw2%vdw_f(j) - 1.0) < eps_rp) then - cj = top2%cmm(:,j) - ineigh_j = 0 - f_j = 1.0 - else - ! Scale factors are used only for monovalent atoms, in that - ! case the vdw center is displaced along the axis connecting - ! the atom to its neighbour - if(top2%conn(1)%ri(j+1) - top2%conn(1)%ri(j) /= 1) then - call fatal_error("Scale factors are only expected & - & for monovalent atoms") - end if - ineigh_j = top2%conn(1)%ci(top2%conn(1)%ri(j)) - f_j = vdw2%vdw_f(j) - - cj = top2%cmm(:,ineigh_j) + & - (top2%cmm(:,j) - top2%cmm(:,ineigh_j)) * f_j - endif - - skip = top1%use_frozen .and. top2%use_frozen - if(skip .and. top1%use_frozen) then - skip = skip .and. top1%frozen(i) - if(ineigh_i > 0) skip = skip .and. top1%frozen(ineigh_i) - end if - if(skip .and. top2%use_frozen) then - skip = skip .and. top2%frozen(j) - if(ineigh_j > 0) skip = skip .and. top2%frozen(ineigh_j) - end if - if(skip) cycle - - Rij0 = get_Rij0_inter(vdw1, vdw2, i, j) - eij = get_eij_inter(vdw1, vdw2, i, j) - - call Rij_jacobian(ci, cj, Rij, J_i, J_j) - if(Rij < eps_rp) then - call fatal_error("Requesting inter non-bonded gradients for two atoms & - &placed in the same point, this could be & - &an internal bug or a problem in your input & - &file, please check.") - end if - call vdw_grad(Rij, Rij0, Eij, Rijg) - - !$omp critical - if(ineigh_i == 0) then - if(.not. (top1%use_frozen .and. top1%frozen(i))) & - grad1(:,i) = grad1(:,i) + J_i * Rijg - else - ! If the center is displaced, the forces should be - ! projected onto the two atoms that determine the - ! position of the center - if(.not. (top1%use_frozen .and. top1%frozen(i))) & - grad1(:,i) = grad1(:,i) + J_i * Rijg * f_i - if(.not. (top1%use_frozen .and. top1%frozen(ineigh_i))) & - grad1(:,ineigh_i) = grad1(:,ineigh_i) + J_i * Rijg * (1-f_i) - end if - - if(ineigh_j == 0) then - if(.not. (top2%use_frozen .and. top2%frozen(j))) & - grad2(:,j) = grad2(:,j) + J_j * Rijg - else - ! If the center is displaced, the forces should be - ! projected onto the two atoms that determine the - ! position of the center - if(.not. (top2%use_frozen .and. top2%frozen(j))) & - grad2(:,j) = grad2(:,j) + J_j * Rijg * f_j - if(.not. (top2%use_frozen .and. top2%frozen(ineigh_j))) & - grad2(:,ineigh_j) = grad2(:,ineigh_j) + J_j * Rijg * (1-f_j) - endif - !$omp end critical - end do - end do - end subroutine - - subroutine vdw_potential_inter_restricted(vdw1, vdw2, pairs, s, n, V) - !! Compute the dispersion repulsion energy between two systems vdw1 - !! and vdw2 accounting only for the pairs pairs(1,i)--pairs(2,i) and scaling - !! each interaction by s(i). - - use mod_io, only : fatal_error - use mod_constants, only: eps_rp - implicit none - - type(ommp_nonbonded_type), intent(in), target :: vdw1, vdw2 - !! Nonbonded data structure - integer(ip), intent(in) :: n - !! number of pairs for which the interaction should be computed - integer(ip), intent(in) :: pairs(2,n) - !! pairs of atoms for which the interaction should be computed - real(rp), intent(in) :: s(:) - !! scaling factors for each interaction - real(rp), intent(inout) :: V - !! Potential, result will be added - - integer(ip) :: i, j, ineigh, ip - real(rp) :: eij, rij0, rij, ci(3), cj(3), vtmp - type(ommp_topology_type), pointer :: top1, top2 - procedure(vdw_term), pointer :: vdw_func - - top1 => vdw1%top - top2 => vdw2%top - - if(vdw1%vdwtype /= vdw2%vdwtype .or. & - vdw1%radrule /= vdw2%radrule .or. & - vdw1%epsrule /= vdw2%epsrule) then - call fatal_error("Requested VdW potential between two incompatible & - &VdW groups.") - end if - - select case(vdw1%vdwtype) - case(OMMP_VDWTYPE_LJ) - vdw_func => vdw_lennard_jones - case(OMMP_VDWTYPE_BUF714) - vdw_func => vdw_buffered_7_14 - case default - vdw_func => vdw_buffered_7_14 - call fatal_error("Unexpected error in vdw_potential_inter_restricted") - end select - - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,ip,ci,cj,ineigh,Rij,Rij0,Eij,vtmp) reduction(+:v) - do ip=1, n - i = pairs(1,ip) - j = pairs(2,ip) - - if(abs(vdw1%vdw_f(i) - 1.0_rp) < eps_rp) then - ci = top1%cmm(:,i) - else - ! Scale factors are used only for monovalent atoms, in that - ! case the vdw center is displaced along the axis connecting - ! the atom to its neighbour - if(top1%conn(1)%ri(i+1) - top1%conn(1)%ri(i) /= 1) then - call fatal_error("Scale factors are only expected for & - &monovalent atoms") - end if - ineigh = top1%conn(1)%ci(top1%conn(1)%ri(i)) - - ci = top1%cmm(:,ineigh) + (top1%cmm(:,i) - top1%cmm(:,ineigh)) & - * vdw1%vdw_f(i) - endif - - Rij0 = get_Rij0_inter(vdw1, vdw2, i, j) - eij = get_eij_inter(vdw1, vdw2, i, j) - - if(abs(vdw2%vdw_f(j) - 1.0_rp) < eps_rp) then - cj = top2%cmm(:,j) - else - ! Scale factors are used only for monovalent atoms, in that - ! case the vdw center is displaced along the axis connecting - ! the atom to its neighbour - if(top2%conn(1)%ri(j+1) - top2%conn(1)%ri(j) /= 1) then - call fatal_error("Scale factors are only expected & - & for monovalent atoms") - end if - ineigh = top2%conn(1)%ci(top2%conn(1)%ri(j)) - - cj = top2%cmm(:,ineigh) + & - (top2%cmm(:,j) - top2%cmm(:,ineigh)) * vdw2%vdw_f(j) - endif - Rij = norm2(ci-cj) - if(Rij < eps_rp) then - call fatal_error("Requesting inter non-bonded potential for two atoms & - &placed in the same point, this could be & - &an internal bug or a problem in your input & - &file, please check.") - end if - - vtmp = 0.0_rp - call vdw_func(Rij, Rij0, Eij, vtmp) - v = v + vtmp * s(ip) - end do - end subroutine vdw_potential_inter_restricted - - subroutine vdw_geomgrad_inter_restricted(vdw1, vdw2, pairs, s, n, & - grad1, grad2) - !! Compute the dispersion repulsion energy for the whole system - !! using a double loop algorithm - - use mod_io, only : fatal_error - use mod_constants, only: eps_rp - use mod_jacobian_mat, only: Rij_jacobian - implicit none - - type(ommp_nonbonded_type), intent(in), target :: vdw1, vdw2 - !! Nonbonded data structure - integer(ip), intent(in) :: n - !! number of pairs for which the interaction should be computed - integer(ip), intent(in) :: pairs(2,n) - !! pairs of atoms for which the interaction should be computed - real(rp), intent(in) :: s(:) - !! scaling factors for each interaction - real(rp), intent(inout) :: grad1(3,vdw1%top%mm_atoms), & - grad2(3,vdw2%top%mm_atoms) - !! Potential, result will be added - - integer(ip) :: i, j, ineigh_i, ineigh_j, ip - real(rp) :: eij, rij0, rij, ci(3), cj(3), Rijg, f_i, f_j, & - J_i(3), J_j(3) - logical :: skip - type(ommp_topology_type), pointer :: top1, top2 - procedure(vdw_gterm), pointer :: vdw_grad - - top1 => vdw1%top - top2 => vdw2%top - - if(vdw1%vdwtype /= vdw2%vdwtype .or. & - vdw1%radrule /= vdw2%radrule .or. & - vdw1%epsrule /= vdw2%epsrule) then - call fatal_error("Requested VdW potential between two incompatible & - &VdW groups.") - end if - - select case(vdw1%vdwtype) - case(OMMP_VDWTYPE_LJ) - vdw_grad => vdw_lennard_jones_Rijgrad - case(OMMP_VDWTYPE_BUF714) - vdw_grad => vdw_buffered_7_14_Rijgrad - case default - vdw_grad => vdw_buffered_7_14_Rijgrad - call fatal_error("Unexpected error in vdw_geomgrad_inter_restricted") - end select - - do ip=1, n - i = pairs(1,ip) - j = pairs(2,ip) - - if(abs(vdw1%vdw_f(i) - 1.0) < eps_rp) then - ci = top1%cmm(:,i) - ineigh_i = 0 - else - ! Scale factors are used only for monovalent atoms, in that - ! case the vdw center is displaced along the axis connecting - ! the atom to its neighbour - if(top1%conn(1)%ri(i+1) - top1%conn(1)%ri(i) /= 1) then - call fatal_error("Scale factors are only expected for & - &monovalent atoms") - end if - ineigh_i = top1%conn(1)%ci(top1%conn(1)%ri(i)) - f_i = vdw1%vdw_f(i) - ci = top1%cmm(:,ineigh_i) + (top1%cmm(:,i) - top1%cmm(:,ineigh_i)) & - * f_i - endif - - if(abs(vdw2%vdw_f(j) - 1.0) < eps_rp) then - cj = top2%cmm(:,j) - ineigh_j = 0 - else - ! Scale factors are used only for monovalent atoms, in that - ! case the vdw center is displaced along the axis connecting - ! the atom to its neighbour - if(top2%conn(1)%ri(j+1) - top2%conn(1)%ri(j) /= 1) then - call fatal_error("Scale factors are only expected & - & for monovalent atoms") - end if - ineigh_j = top2%conn(1)%ci(top2%conn(1)%ri(j)) - f_j = vdw2%vdw_f(j) - - cj = top2%cmm(:,ineigh_j) + & - (top2%cmm(:,j) - top2%cmm(:,ineigh_j)) * f_j - endif - - skip = top1%use_frozen .and. top2%use_frozen - if(skip .and. top1%use_frozen) then - skip = skip .and. top1%frozen(i) - if(ineigh_i > 0) skip = skip .and. top1%frozen(ineigh_i) - end if - if(skip .and. top2%use_frozen) then - skip = skip .and. top2%frozen(j) - if(ineigh_j > 0) skip = skip .and. top2%frozen(ineigh_j) - end if - if(skip) cycle - - Rij0 = get_Rij0_inter(vdw1, vdw2, i, j) - eij = get_eij_inter(vdw1, vdw2, i, j) * s(ip) - - call Rij_jacobian(ci, cj, Rij, J_i, J_j) - if(Rij < eps_rp) then - call fatal_error("Requesting inter non-bonded gradients for two atoms & - &placed in the same point, this could be & - &an internal bug or a problem in your input & - &file, please check.") - end if - call vdw_grad(Rij, Rij0, Eij, Rijg) - - if(ineigh_i == 0) then - if(.not. (top1%use_frozen .and. top1%frozen(i))) & - grad1(:,i) = grad1(:,i) + J_i * Rijg - else - ! If the center is displaced, the forces should be - ! projected onto the two atoms that determine the - ! position of the center - if(.not. (top1%use_frozen .and. top1%frozen(i))) & - grad1(:,i) = grad1(:,i) + J_i * Rijg * f_i - if(.not. (top1%use_frozen .and. top1%frozen(ineigh_i))) & - grad1(:,ineigh_i) = grad1(:,ineigh_i) + J_i * Rijg * (1-f_i) - end if - - if(ineigh_j == 0) then - if(.not. (top2%use_frozen .and. top2%frozen(j))) & - grad2(:,j) = grad2(:,j) + J_j * Rijg - else - ! If the center is displaced, the forces should be - ! projected onto the two atoms that determine the - ! position of the center - if(.not. (top2%use_frozen .and. top2%frozen(j))) & - grad2(:,j) = grad2(:,j) + J_j * Rijg * f_j - if(.not. (top2%use_frozen .and. top2%frozen(ineigh_j))) & - grad2(:,ineigh_j) = grad2(:,ineigh_j) + J_j * Rijg * (1-f_j) - endif - end do - end subroutine - -end module mod_nonbonded diff --git a/src/mod_polarization.F90 b/src/mod_polarization.F90 new file mode 100644 index 0000000..3d22846 --- /dev/null +++ b/src/mod_polarization.F90 @@ -0,0 +1,559 @@ +#include "f_cart_components.h" +module mod_polarization + !! Module to handle the calculation of the induced dipoles; this means find + !! the solution of the polarization problem. The polarization problem is + !! defined by the linear system + !! \begin{equation} + !! \mathbf{T}\mathbf{\mu} = \mathbf{E}, + !! \label{eq:pol_ls} + !! \end{equation} + !! where \(\mathbf E\) is the 'external' (here external means the sum of the + !! electric field generated by QM density and the one generated by the MM + !! sites) electric field at induced dipole sites, \(\mathbf{\mu}\) are the + !! induced dipoles - the solution of the linear system -, and \(\mathbf{T}\) + !! is the interaction tensor between the induced point dipoles. + !! + !! Linear system \eqref{eq:pol_ls} can be solved with different methods + !! (see [[mod_solvers]] for further details). Some of them requires to + !! explicitly build \(\mathbf{T}\) in memory (eg. + !! [[mod_solvers::inversion_solver]]), while other only requires to + !! perform matrix-vector multiplication without building explicitly the + !! interaction tensor. + !! Interaction tensor is conveniently tought as a square matrix of dimension + !! number of induced dipoles, of rank 3 tensors expressing the interaction + !! between the two elements. We can distinguish the case of diagonal + !! elements: + !! \begin{equation} + !! \mathbf T_{ii} = \frac{1}{\alpha_i} \mathbf I_3, + !! \label{eq:T_diag} + !! \end{equation} + !! and the off-diagonal elements: + !! \begin{equation} + !! \mathbf T_{ij} = ... + !! \label{eq:T_offdiag} + !! \end{equation} + + use mod_memory, only: ip, rp + use mod_io, only: ommp_message, fatal_error + use mod_mmpol, only: ommp_system + use mod_electrostatics, only: ommp_electrostatics_type + + implicit none + private + + + public :: polarization, polarization_terminate + +contains + + subroutine polarization(sys_obj, e, & + & arg_solver, arg_mvmethod, arg_ipd_mask) + !! Main driver for the calculation of induced dipoles. + !! Takes electric field at induced dipole sites as input and -- if + !! solver converges -- provides induced dipoles as output. + !! Since AMOEBA requires the calculations of two sets of induced dipoles + !! generated from two different electric fields (normally called direct (D) + !! and polarization (P)) both electric field and induced dipoles are shaped + !! with an extra dimension and this routine calls the solver twice to + !! solve the two linear systems in the case of AMOEBA FF. Direct electric + !! field and induced dipoles are stored in e(:,:,1)/ipds(:,:,1) while + !! polarization field/dipole are stored in e(:,:,2)/ipds(:,:,2). + + use mod_solvers, only: jacobi_diis_solver, conjugate_gradient_solver, & + inversion_solver + use mod_memory, only: ip, rp, mallocate, mfree + use mod_io, only: print_matrix + use mod_profiling, only: time_pull, time_push + use mod_constants, only: OMMP_MATV_DIRECT, & + OMMP_MATV_INCORE, & + OMMP_MATV_NONE, & + OMMP_SOLVER_CG, & + OMMP_SOLVER_DIIS, & + OMMP_SOLVER_INVERSION, & + OMMP_SOLVER_NONE, & + OMMP_VERBOSE_DEBUG, & + OMMP_VERBOSE_HIGH + + implicit none + + type(ommp_system), target, intent(inout) :: sys_obj + !! Fundamental data structure for OMMP system + real(rp), dimension(3, sys_obj%eel%pol_atoms, sys_obj%eel%n_ipd), & + & intent(in) :: e + !! Total electric field that induces the dipoles + + integer(ip), intent(in), optional :: arg_solver + !! Flag for the solver to be used; optional, should be one OMMP_SOLVER_ + !! if not provided [[mod_constants:OMMP_SOLVER_DEFAULT]] is used. + integer(ip), intent(in), optional :: arg_mvmethod + !! Flag for the matrix-vector method to be used; optional, should be one of + !! OMMP_MATV_ if not provided [[mod_constants:OMMP_MATV_DEFAULT]] is used. + logical, intent(in), optional :: arg_ipd_mask(sys_obj%eel%n_ipd) + !! Logical mask to skip calculation of one of the two set of dipoles + !! in AMOEBA calculations (eg. when MM part's field is not taken into + !! account, both P and D field are just external field, so there is no + !! reason to compute it twice). If n_ipd == 1 this is always considered + !! true. + + real(rp), dimension(:, :), allocatable :: e_vec, ipd0 + real(rp), dimension(:), allocatable :: inv_diag + integer(ip) :: i, n, solver, mvmethod + logical :: ipd_mask(sys_obj%eel%n_ipd), amoeba + type(ommp_electrostatics_type), pointer :: eel + + abstract interface + subroutine mv(eel, x, y, dodiag) + use mod_memory, only: rp, ip + use mod_electrostatics, only : ommp_electrostatics_type + type(ommp_electrostatics_type), intent(in) :: eel + real(rp), dimension(3*eel%pol_atoms), intent(in) :: x + real(rp), dimension(3*eel%pol_atoms), intent(out) :: y + logical, intent(in) :: dodiag + end subroutine mv + end interface + procedure(mv), pointer :: matvec + + abstract interface + subroutine pc(eel, x, y) + use mod_memory, only: rp, ip + use mod_electrostatics, only : ommp_electrostatics_type + type(ommp_electrostatics_type), intent(in) :: eel + real(rp), dimension(3*eel%pol_atoms), intent(in) :: x + real(rp), dimension(3*eel%pol_atoms), intent(out) :: y + end subroutine pc + end interface + procedure(pc), pointer :: precond + + call time_push() + ! Shortcuts + eel => sys_obj%eel + amoeba = sys_obj%amoeba + + ! Defaults for safety + matvec => TMatVec_incore + precond => PolVec + + if(eel%pol_atoms == 0) then + ! If the system is not polarizable, there is nothing to do. + call time_pull('Polarization routine') + return + end if + + ! Handling of optional arguments + if(present(arg_solver)) then + solver = arg_solver + if(solver == OMMP_SOLVER_NONE) solver = eel%def_solver + else + solver = eel%def_solver + end if + + if(present(arg_mvmethod)) then + mvmethod = arg_mvmethod + if(mvmethod == OMMP_MATV_NONE) mvmethod = eel%def_matv + else + mvmethod = eel%def_matv + end if + + if(present(arg_ipd_mask) .and. eel%n_ipd > 1) then + ipd_mask = arg_ipd_mask + else + ipd_mask = .true. + end if + + ! Dimension of the system + n = 3*eel%pol_atoms + + call mallocate('polarization [ipd0]', n, eel%n_ipd, ipd0) + call mallocate('polarization [e_vec]', n, eel%n_ipd, e_vec) + + ! Allocate and compute dipole polarization tensor, if needed + if(mvmethod == OMMP_MATV_INCORE .or. & + solver == OMMP_SOLVER_INVERSION) then + if(.not. allocated(eel%tmat)) then !TODO move this in create_tmat + call ommp_message("Allocating T matrix.", OMMP_VERBOSE_DEBUG) + call mallocate('polarization [TMat]',n,n,eel%tmat) + call create_TMat(eel) + end if + end if + + ! Reshape electric field matrix into a vector + ! direct field for Wang and Amoeba + ! polarization field just for Amoeba + if(amoeba) then + if(ipd_mask(_amoeba_D_)) & + e_vec(:, _amoeba_D_) = reshape(e(:,:,_amoeba_D_), (/ n /)) + if(ipd_mask(_amoeba_P_)) & + e_vec(:, _amoeba_P_) = reshape(e(:,:,_amoeba_P_), (/ n /)) + else + e_vec(:, 1) = reshape(e(:,:, 1), (/ n /)) + end if + + ! Initialization of dipoles + ipd0 = 0.0_rp + if(solver /= OMMP_SOLVER_INVERSION) then + ! Create a guess for dipoles + if(eel%ipd_use_guess) then + if(amoeba) then + if(ipd_mask(_amoeba_D_)) then + ipd0(:,_amoeba_D_) = & + reshape(eel%ipd(:,:,_amoeba_D_), [n]) + end if + if(ipd_mask(_amoeba_P_)) then + ipd0(:, _amoeba_P_) = & + reshape(eel%ipd(:,:,_amoeba_P_), [n]) + end if + else + ! call PolVec(eel, e_vec(:,1), ipd0(:,1)) + ipd0(:, 1) = & + reshape(eel%ipd(:,:,1), [n]) + end if + end if + + select case(mvmethod) + case(OMMP_MATV_INCORE) + call ommp_message("Matrix-Vector will be performed in-memory", & + OMMP_VERBOSE_HIGH) + matvec => TMatVec_incore + + case(OMMP_MATV_DIRECT) + call ommp_message("Matrix-Vector will be performed on-the-fly", & + OMMP_VERBOSE_HIGH) + matvec => TMatVec_otf + + case default + call fatal_error("Unknown matrix-vector method requested") + end select + end if + select case (solver) + case(OMMP_SOLVER_CG) + ! For now we do not have any other option. + precond => PolVec + + if(amoeba) then + if(ipd_mask(_amoeba_D_)) & + call conjugate_gradient_solver(n, & + e_vec(:,_amoeba_D_), & + ipd0(:,_amoeba_D_), & + eel, matvec, precond) + ! If both sets have to be computed and there is no input + ! guess, just use D as guess for P, not a big gain but still + ! something + if(ipd_mask(_amoeba_D_) .and. ipd_mask(_amoeba_P_) & + .and. .not. eel%ipd_use_guess) & + ipd0(:,_amoeba_P_) = ipd0(:,_amoeba_D_) + if(ipd_mask(_amoeba_P_)) & + call conjugate_gradient_solver(n, & + e_vec(:,_amoeba_P_), & + ipd0(:,_amoeba_P_), & + eel, matvec, precond) + else + call conjugate_gradient_solver(n, e_vec(:,1), ipd0(:,1), & + eel, matvec, precond) + end if + + case(OMMP_SOLVER_DIIS) + ! Create a vector containing inverse of diagonal of T matrix + call mallocate('polarization [inv_diag]', n, inv_diag) + + !$omp parallel do default(shared) private(i) schedule(static) + do i=1, eel%pol_atoms + inv_diag(3*(i-1)+1:3*(i-1)+3) = eel%pol(i) + end do + + if(amoeba) then + if(ipd_mask(_amoeba_D_)) & + call jacobi_diis_solver(n, & + e_vec(:,_amoeba_D_), & + ipd0(:,_amoeba_D_), & + eel, matvec, inv_diag) + ! If both sets have to be computed and there is no input + ! guess, just use D as guess for P, not a big gain but still + ! something + if(ipd_mask(_amoeba_D_) .and. ipd_mask(_amoeba_P_) & + .and. .not. eel%ipd_use_guess) & + ipd0(:,_amoeba_P_) = ipd0(:,_amoeba_D_) + if(ipd_mask(_amoeba_P_)) & + call jacobi_diis_solver(n, & + e_vec(:,_amoeba_P_), & + ipd0(:,_amoeba_P_), & + eel, matvec, inv_diag) + else + call jacobi_diis_solver(n, e_vec(:,1), ipd0(:,1), & + eel, matvec, inv_diag) + end if + call mfree('polarization [inv_diag]', inv_diag) + + case(OMMP_SOLVER_INVERSION) + if(amoeba) then + if(ipd_mask(_amoeba_D_)) & + call inversion_solver(n, & + e_vec(:,_amoeba_D_), & + ipd0(:,_amoeba_D_), eel%TMat) + if(ipd_mask(_amoeba_P_)) & + call inversion_solver(n, & + e_vec(:,_amoeba_P_), & + ipd0(:,_amoeba_P_), eel%TMat) + else + call inversion_solver(n, e_vec(:,1), ipd0(:,1), eel%TMat) + end if + + case default + call fatal_error("Unknown solver for calculation of the induced point dipoles") + end select + + ! Reshape dipole vector into the matrix + eel%ipd = reshape(ipd0, (/3_ip, eel%pol_atoms, eel%n_ipd/)) + eel%ipd_done = .true. !! TODO Maybe check convergence... + eel%ipd_use_guess = .true. + + call mfree('polarization [ipd0]', ipd0) + call mfree('polarization [e_vec]', e_vec) + call time_pull('Polarization routine') + + end subroutine polarization + + subroutine polarization_terminate(eel) + use mod_memory, only: mfree + + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel + + if(allocated(eel%TMat)) & + call mfree('polarization [TMat]', eel%TMat) + + end subroutine polarization_terminate + + subroutine dipole_T(eel, i, j, tens) + !! This subroutine compute the interaction tensor (rank 3) between + !! two polarizable sites i and j. + !! This tensor is built according to the following rules: ... TODO + use mod_electrostatics, only: screening_rules, damped_coulomb_kernel + use mod_constants, only: eps_rp + + implicit none + ! + ! Compute element of the polarization tensor TTens between + ! polarizable cpol atom I and polarizable cpol atom J. On the + ! TTens diagonal (I=J) are inverse polarizabilities and on the + ! off-diagonal dipole field. + ! + ! Polarizabilities pol are defined for polarizable atoms only while + ! Thole factors are defined for all of them + + type(ommp_electrostatics_type), intent(inout) :: eel + !! The electostatic data structure for which the + !! interaction tensor should be computed + integer(ip), intent(in) :: i + !! Index (in the list of polarizable sites) of the source site + integer(ip), intent(in) :: j + !! Index (in the list of polarizable sites) of the target site + real(rp), dimension(3, 3), intent(out) :: tens + !! Interaction tensor between sites i and j + + real(rp) :: dr(3) + real(rp) :: kernel(3), scalf + logical :: to_do, to_scale + + integer(ip) :: ii, jj + + tens = 0.0_rp + + if(i == j) then + tens(1, 1) = 1.0_rp / eel%pol(i) + tens(2, 2) = 1.0_rp / eel%pol(i) + tens(3, 3) = 1.0_rp / eel%pol(i) + else + scalf = screening_rules(eel, i, 'P', j, 'P', '-') + + if(abs(scalf) > eps_rp) then + call damped_coulomb_kernel(eel, eel%polar_mm(i), & + eel%polar_mm(j), 2, kernel, dr) + ! Fill the matrix elemets + do ii=1, 3 + do jj=1, 3 + if(ii == jj) then + tens(ii, ii) = kernel(2) - 3.0_rp * kernel(3) * dr(ii) ** 2 + else + tens(jj, ii) = -3.0_rp * kernel(3) * dr(ii) * dr(jj) + end if + end do + end do + ! Scale if needed + if(abs(scalf-1.0) > eps_rp) tens = tens * scalf + + end if + end if + end subroutine dipole_T + + subroutine create_tmat(eel) + !! Explicitly construct polarization tensor in memory. This routine + !! is only used to accumulate results from [[dipole_T]] and shape it in + !! the correct way. + + use mod_io, only: print_matrix + use mod_constants, only: OMMP_VERBOSE_HIGH + + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel + !! The electostatic data structure for which the + !! interaction tensor should be computed + real(rp), dimension(3, 3) :: tensor + !! Temporary interaction tensor between two sites + + integer(ip) :: i, j, ii, jj + + call ommp_message("Explicitly computing interaction matrix to solve & + &the polarization system", OMMP_VERBOSE_HIGH) + + ! Initialize the tensor with zeros + eel%tmat = 0.0_rp + + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,tensor,ii,jj) + do i = 1, eel%pol_atoms + do j = 1, i + call dipole_T(eel, i, j, tensor) + + do ii=1, 3 + do jj=1, 3 + eel%tmat((j-1)*3+jj, (i-1)*3+ii) = tensor(jj, ii) + eel%tmat((i-1)*3+ii, (j-1)*3+jj) = tensor(jj, ii) + end do + end do + enddo + enddo + + ! Print the matrix if verbose output is requested + ! if(verbose == OMMP_VERBOSE_DEBUG) then + ! call print_matrix(.true., 'Polarization tensor:', & + ! 3*pol_atoms, 3*pol_atoms, & + ! 3*pol_atoms, 3*pol_atoms, TMat) + ! end if + + end subroutine create_TMat + + subroutine TMatVec_incore(eel, x, y, dodiag) + !! Perform matrix vector multiplication y = TMat*x, + !! where TMat is polarization matrix (precomputed and stored in memory) + !! and x and y are column vectors + + implicit none + + type(ommp_electrostatics_type), intent(in) :: eel + !! The electostatic data structure + real(rp), dimension(3*eel%pol_atoms), intent(in) :: x + !! Input vector + real(rp), dimension(3*eel%pol_atoms), intent(out) :: y + !! Output vector + logical, intent(in) :: dodiag + !! Logical flag (.true. = diagonal is computed, .false. = diagonal is + !! skipped) + + call TMatVec_offdiag(eel, x, y) + if(dodiag) call TMatVec_diag(eel, x, y) + + end subroutine TMatVec_incore + + subroutine TMatVec_otf(eel, x, y, dodiag) + !! Perform matrix vector multiplication y = TMat*x, + !! where TMat is polarization matrix (precomputed and stored in memory) + !! and x and y are column vectors + use mod_electrostatics, only: field_extD2D + implicit none + + type(ommp_electrostatics_type), intent(in) :: eel + !! The electostatic data structure + real(rp), dimension(3*eel%pol_atoms), intent(in) :: x + !! Input vector + real(rp), dimension(3*eel%pol_atoms), intent(out) :: y + !! Output vector + logical, intent(in) :: dodiag + !! Logical flag (.true. = diagonal is computed, .false. = diagonal is + !! skipped) + + y = 0.0_rp + call field_extD2D(eel, x, y) + y = -1.0_rp * y ! Why? TODO + if(dodiag) call TMatVec_diag(eel, x, y) + + end subroutine TMatVec_otf + + subroutine TMatVec_diag(eel, x, y) + !! This routine compute the product between the diagonal of T matrix + !! with x, and add it to y. The product is simply computed by + !! each element of x for its inverse polarizability. + + implicit none + + type(ommp_electrostatics_type), intent(in) :: eel + !! The electostatic data structure + real(rp), dimension(3*eel%pol_atoms), intent(in) :: x + !! Input vector + real(rp), dimension(3*eel%pol_atoms), intent(out) :: y + !! Output vector + + integer(ip) :: i, ii + + !$omp parallel do default(shared) private(i,ii) + do i=1, 3*eel%pol_atoms + ii = (i+2)/3 + y(i) = y(i) + x(i) / eel%pol(ii) + end do + end subroutine TMatVec_diag + + subroutine TMatVec_offdiag(eel, x, y) + !! Perform matrix vector multiplication y = [TMat-diag(TMat)]*x, + !! where TMat is polarization matrix (precomputed and stored in memory) + !! and x and y are column vectors + use mod_memory, only: mallocate, mfree + + implicit none + + type(ommp_electrostatics_type), intent(in) :: eel + !! The electostatic data structure + real(rp), dimension(3*eel%pol_atoms), intent(in) :: x + !! Input vector + real(rp), dimension(3*eel%pol_atoms), intent(out) :: y + !! Output vector + + integer(ip) :: i, n + + n = 3*eel%pol_atoms + + ! Compute the matrix vector product + call dgemm('N', 'N', n, 1, n, 1.0_rp, eel%tmat, n, x, n, 0.0_rp, y, n) + ! Subtract the product of diagonal + !$omp parallel do default(shared) private(i) + do i = 1, n + y(i) = y(i) - eel%tmat(i,i) * x(i) + end do + + end subroutine TMatVec_offdiag + + subroutine PolVec(eel, x, y) + !! Perform matrix vector multiplication y = pol*x, + !! where pol is polarizability vector, x and y are + !! column vectors + + implicit none + + type(ommp_electrostatics_type), intent(in) :: eel + !! The electostatic data structure + real(rp), dimension(3*eel%pol_atoms), intent(in) :: x + !! Input vector + real(rp), dimension(3*eel%pol_atoms), intent(out) :: y + !! Output vector + + integer(ip) :: i, indx + + !$omp parallel do default(shared) private(indx,i) + do i = 1, 3*eel%pol_atoms + indx = (i+2)/3 + y(i) = eel%pol(indx)*x(i) + enddo + + end subroutine PolVec + +end module mod_polarization diff --git a/src/mod_polarization.f90 b/src/mod_polarization.f90 deleted file mode 100644 index 16f0df3..0000000 --- a/src/mod_polarization.f90 +++ /dev/null @@ -1,559 +0,0 @@ -#include "f_cart_components.h" -module mod_polarization - !! Module to handle the calculation of the induced dipoles; this means find - !! the solution of the polarization problem. The polarization problem is - !! defined by the linear system - !! \begin{equation} - !! \mathbf{T}\mathbf{\mu} = \mathbf{E}, - !! \label{eq:pol_ls} - !! \end{equation} - !! where \(\mathbf E\) is the 'external' (here external means the sum of the - !! electric field generated by QM density and the one generated by the MM - !! sites) electric field at induced dipole sites, \(\mathbf{\mu}\) are the - !! induced dipoles - the solution of the linear system -, and \(\mathbf{T}\) - !! is the interaction tensor between the induced point dipoles. - !! - !! Linear system \eqref{eq:pol_ls} can be solved with different methods - !! (see [[mod_solvers]] for further details). Some of them requires to - !! explicitly build \(\mathbf{T}\) in memory (eg. - !! [[mod_solvers::inversion_solver]]), while other only requires to - !! perform matrix-vector multiplication without building explicitly the - !! interaction tensor. - !! Interaction tensor is conveniently tought as a square matrix of dimension - !! number of induced dipoles, of rank 3 tensors expressing the interaction - !! between the two elements. We can distinguish the case of diagonal - !! elements: - !! \begin{equation} - !! \mathbf T_{ii} = \frac{1}{\alpha_i} \mathbf I_3, - !! \label{eq:T_diag} - !! \end{equation} - !! and the off-diagonal elements: - !! \begin{equation} - !! \mathbf T_{ij} = ... - !! \label{eq:T_offdiag} - !! \end{equation} - - use mod_memory, only: ip, rp - use mod_io, only: ommp_message, fatal_error - use mod_mmpol, only: ommp_system - use mod_electrostatics, only: ommp_electrostatics_type - - implicit none - private - - - public :: polarization, polarization_terminate - - contains - - subroutine polarization(sys_obj, e, & - & arg_solver, arg_mvmethod, arg_ipd_mask) - !! Main driver for the calculation of induced dipoles. - !! Takes electric field at induced dipole sites as input and -- if - !! solver converges -- provides induced dipoles as output. - !! Since AMOEBA requires the calculations of two sets of induced dipoles - !! generated from two different electric fields (normally called direct (D) - !! and polarization (P)) both electric field and induced dipoles are shaped - !! with an extra dimension and this routine calls the solver twice to - !! solve the two linear systems in the case of AMOEBA FF. Direct electric - !! field and induced dipoles are stored in e(:,:,1)/ipds(:,:,1) while - !! polarization field/dipole are stored in e(:,:,2)/ipds(:,:,2). - - use mod_solvers, only: jacobi_diis_solver, conjugate_gradient_solver, & - inversion_solver - use mod_memory, only: ip, rp, mallocate, mfree - use mod_io, only: print_matrix - use mod_profiling, only: time_pull, time_push - use mod_constants, only: OMMP_MATV_DIRECT, & - OMMP_MATV_INCORE, & - OMMP_MATV_NONE, & - OMMP_SOLVER_CG, & - OMMP_SOLVER_DIIS, & - OMMP_SOLVER_INVERSION, & - OMMP_SOLVER_NONE, & - OMMP_VERBOSE_DEBUG, & - OMMP_VERBOSE_HIGH - - implicit none - - type(ommp_system), target, intent(inout) :: sys_obj - !! Fundamental data structure for OMMP system - real(rp), dimension(3, sys_obj%eel%pol_atoms, sys_obj%eel%n_ipd), & - & intent(in) :: e - !! Total electric field that induces the dipoles - - integer(ip), intent(in), optional :: arg_solver - !! Flag for the solver to be used; optional, should be one OMMP_SOLVER_ - !! if not provided [[mod_constants:OMMP_SOLVER_DEFAULT]] is used. - integer(ip), intent(in), optional :: arg_mvmethod - !! Flag for the matrix-vector method to be used; optional, should be one of - !! OMMP_MATV_ if not provided [[mod_constants:OMMP_MATV_DEFAULT]] is used. - logical, intent(in), optional :: arg_ipd_mask(sys_obj%eel%n_ipd) - !! Logical mask to skip calculation of one of the two set of dipoles - !! in AMOEBA calculations (eg. when MM part's field is not taken into - !! account, both P and D field are just external field, so there is no - !! reason to compute it twice). If n_ipd == 1 this is always considered - !! true. - - real(rp), dimension(:, :), allocatable :: e_vec, ipd0 - real(rp), dimension(:), allocatable :: inv_diag - integer(ip) :: i, n, solver, mvmethod - logical :: ipd_mask(sys_obj%eel%n_ipd), amoeba - type(ommp_electrostatics_type), pointer :: eel - - abstract interface - subroutine mv(eel, x, y, dodiag) - use mod_memory, only: rp, ip - use mod_electrostatics, only : ommp_electrostatics_type - type(ommp_electrostatics_type), intent(in) :: eel - real(rp), dimension(3*eel%pol_atoms), intent(in) :: x - real(rp), dimension(3*eel%pol_atoms), intent(out) :: y - logical, intent(in) :: dodiag - end subroutine mv - end interface - procedure(mv), pointer :: matvec - - abstract interface - subroutine pc(eel, x, y) - use mod_memory, only: rp, ip - use mod_electrostatics, only : ommp_electrostatics_type - type(ommp_electrostatics_type), intent(in) :: eel - real(rp), dimension(3*eel%pol_atoms), intent(in) :: x - real(rp), dimension(3*eel%pol_atoms), intent(out) :: y - end subroutine pc - end interface - procedure(pc), pointer :: precond - - call time_push() - ! Shortcuts - eel => sys_obj%eel - amoeba = sys_obj%amoeba - - ! Defaults for safety - matvec => TMatVec_incore - precond => PolVec - - if(eel%pol_atoms == 0) then - ! If the system is not polarizable, there is nothing to do. - call time_pull('Polarization routine') - return - end if - - ! Handling of optional arguments - if(present(arg_solver)) then - solver = arg_solver - if(solver == OMMP_SOLVER_NONE) solver = eel%def_solver - else - solver = eel%def_solver - end if - - if(present(arg_mvmethod)) then - mvmethod = arg_mvmethod - if(mvmethod == OMMP_MATV_NONE) mvmethod = eel%def_matv - else - mvmethod = eel%def_matv - end if - - if(present(arg_ipd_mask) .and. eel%n_ipd > 1) then - ipd_mask = arg_ipd_mask - else - ipd_mask = .true. - end if - - ! Dimension of the system - n = 3*eel%pol_atoms - - call mallocate('polarization [ipd0]', n, eel%n_ipd, ipd0) - call mallocate('polarization [e_vec]', n, eel%n_ipd, e_vec) - - ! Allocate and compute dipole polarization tensor, if needed - if(mvmethod == OMMP_MATV_INCORE .or. & - solver == OMMP_SOLVER_INVERSION) then - if(.not. allocated(eel%tmat)) then !TODO move this in create_tmat - call ommp_message("Allocating T matrix.", OMMP_VERBOSE_DEBUG) - call mallocate('polarization [TMat]',n,n,eel%tmat) - call create_TMat(eel) - end if - end if - - ! Reshape electric field matrix into a vector - ! direct field for Wang and Amoeba - ! polarization field just for Amoeba - if(amoeba) then - if(ipd_mask(_amoeba_D_)) & - e_vec(:, _amoeba_D_) = reshape(e(:,:,_amoeba_D_), (/ n /)) - if(ipd_mask(_amoeba_P_)) & - e_vec(:, _amoeba_P_) = reshape(e(:,:,_amoeba_P_), (/ n /)) - else - e_vec(:, 1) = reshape(e(:,:, 1), (/ n /)) - end if - - ! Initialization of dipoles - ipd0 = 0.0_rp - if(solver /= OMMP_SOLVER_INVERSION) then - ! Create a guess for dipoles - if(eel%ipd_use_guess) then - if(amoeba) then - if(ipd_mask(_amoeba_D_)) then - ipd0(:,_amoeba_D_) = & - reshape(eel%ipd(:,:,_amoeba_D_), [n]) - end if - if(ipd_mask(_amoeba_P_)) then - ipd0(:, _amoeba_P_) = & - reshape(eel%ipd(:,:,_amoeba_P_), [n]) - end if - else - ! call PolVec(eel, e_vec(:,1), ipd0(:,1)) - ipd0(:, 1) = & - reshape(eel%ipd(:,:,1), [n]) - end if - end if - - select case(mvmethod) - case(OMMP_MATV_INCORE) - call ommp_message("Matrix-Vector will be performed in-memory", & - OMMP_VERBOSE_HIGH) - matvec => TMatVec_incore - - case(OMMP_MATV_DIRECT) - call ommp_message("Matrix-Vector will be performed on-the-fly", & - OMMP_VERBOSE_HIGH) - matvec => TMatVec_otf - - case default - call fatal_error("Unknown matrix-vector method requested") - end select - end if - select case (solver) - case(OMMP_SOLVER_CG) - ! For now we do not have any other option. - precond => PolVec - - if(amoeba) then - if(ipd_mask(_amoeba_D_)) & - call conjugate_gradient_solver(n, & - e_vec(:,_amoeba_D_), & - ipd0(:,_amoeba_D_), & - eel, matvec, precond) - ! If both sets have to be computed and there is no input - ! guess, just use D as guess for P, not a big gain but still - ! something - if(ipd_mask(_amoeba_D_) .and. ipd_mask(_amoeba_P_) & - .and. .not. eel%ipd_use_guess) & - ipd0(:,_amoeba_P_) = ipd0(:,_amoeba_D_) - if(ipd_mask(_amoeba_P_)) & - call conjugate_gradient_solver(n, & - e_vec(:,_amoeba_P_), & - ipd0(:,_amoeba_P_), & - eel, matvec, precond) - else - call conjugate_gradient_solver(n, e_vec(:,1), ipd0(:,1), & - eel, matvec, precond) - end if - - case(OMMP_SOLVER_DIIS) - ! Create a vector containing inverse of diagonal of T matrix - call mallocate('polarization [inv_diag]', n, inv_diag) - - !$omp parallel do default(shared) private(i) schedule(static) - do i=1, eel%pol_atoms - inv_diag(3*(i-1)+1:3*(i-1)+3) = eel%pol(i) - end do - - if(amoeba) then - if(ipd_mask(_amoeba_D_)) & - call jacobi_diis_solver(n, & - e_vec(:,_amoeba_D_), & - ipd0(:,_amoeba_D_), & - eel, matvec, inv_diag) - ! If both sets have to be computed and there is no input - ! guess, just use D as guess for P, not a big gain but still - ! something - if(ipd_mask(_amoeba_D_) .and. ipd_mask(_amoeba_P_) & - .and. .not. eel%ipd_use_guess) & - ipd0(:,_amoeba_P_) = ipd0(:,_amoeba_D_) - if(ipd_mask(_amoeba_P_)) & - call jacobi_diis_solver(n, & - e_vec(:,_amoeba_P_), & - ipd0(:,_amoeba_P_), & - eel, matvec, inv_diag) - else - call jacobi_diis_solver(n, e_vec(:,1), ipd0(:,1), & - eel, matvec, inv_diag) - end if - call mfree('polarization [inv_diag]', inv_diag) - - case(OMMP_SOLVER_INVERSION) - if(amoeba) then - if(ipd_mask(_amoeba_D_)) & - call inversion_solver(n, & - e_vec(:,_amoeba_D_), & - ipd0(:,_amoeba_D_), eel%TMat) - if(ipd_mask(_amoeba_P_)) & - call inversion_solver(n, & - e_vec(:,_amoeba_P_), & - ipd0(:,_amoeba_P_), eel%TMat) - else - call inversion_solver(n, e_vec(:,1), ipd0(:,1), eel%TMat) - end if - - case default - call fatal_error("Unknown solver for calculation of the induced point dipoles") - end select - - ! Reshape dipole vector into the matrix - eel%ipd = reshape(ipd0, (/3_ip, eel%pol_atoms, eel%n_ipd/)) - eel%ipd_done = .true. !! TODO Maybe check convergence... - eel%ipd_use_guess = .true. - - call mfree('polarization [ipd0]', ipd0) - call mfree('polarization [e_vec]', e_vec) - call time_pull('Polarization routine') - - end subroutine polarization - - subroutine polarization_terminate(eel) - use mod_memory, only: mfree - - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel - - if(allocated(eel%TMat)) & - call mfree('polarization [TMat]', eel%TMat) - - end subroutine polarization_terminate - - subroutine dipole_T(eel, i, j, tens) - !! This subroutine compute the interaction tensor (rank 3) between - !! two polarizable sites i and j. - !! This tensor is built according to the following rules: ... TODO - use mod_electrostatics, only: screening_rules, damped_coulomb_kernel - use mod_constants, only: eps_rp - - implicit none - ! - ! Compute element of the polarization tensor TTens between - ! polarizable cpol atom I and polarizable cpol atom J. On the - ! TTens diagonal (I=J) are inverse polarizabilities and on the - ! off-diagonal dipole field. - ! - ! Polarizabilities pol are defined for polarizable atoms only while - ! Thole factors are defined for all of them - - type(ommp_electrostatics_type), intent(inout) :: eel - !! The electostatic data structure for which the - !! interaction tensor should be computed - integer(ip), intent(in) :: i - !! Index (in the list of polarizable sites) of the source site - integer(ip), intent(in) :: j - !! Index (in the list of polarizable sites) of the target site - real(rp), dimension(3, 3), intent(out) :: tens - !! Interaction tensor between sites i and j - - real(rp) :: dr(3) - real(rp) :: kernel(3), scalf - logical :: to_do, to_scale - - integer(ip) :: ii, jj - - tens = 0.0_rp - - if(i == j) then - tens(1, 1) = 1.0_rp / eel%pol(i) - tens(2, 2) = 1.0_rp / eel%pol(i) - tens(3, 3) = 1.0_rp / eel%pol(i) - else - scalf = screening_rules(eel, i, 'P', j, 'P', '-') - - if(abs(scalf) > eps_rp) then - call damped_coulomb_kernel(eel, eel%polar_mm(i), & - eel%polar_mm(j), 2, kernel, dr) - ! Fill the matrix elemets - do ii=1, 3 - do jj=1, 3 - if(ii == jj) then - tens(ii, ii) = kernel(2) - 3.0_rp * kernel(3) * dr(ii) ** 2 - else - tens(jj, ii) = -3.0_rp * kernel(3) * dr(ii) * dr(jj) - end if - end do - end do - ! Scale if needed - if(abs(scalf-1.0) > eps_rp) tens = tens * scalf - - end if - end if - end subroutine dipole_T - - subroutine create_tmat(eel) - !! Explicitly construct polarization tensor in memory. This routine - !! is only used to accumulate results from [[dipole_T]] and shape it in - !! the correct way. - - use mod_io, only: print_matrix - use mod_constants, only: OMMP_VERBOSE_HIGH - - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel - !! The electostatic data structure for which the - !! interaction tensor should be computed - real(rp), dimension(3, 3) :: tensor - !! Temporary interaction tensor between two sites - - integer(ip) :: i, j, ii, jj - - call ommp_message("Explicitly computing interaction matrix to solve & - &the polarization system", OMMP_VERBOSE_HIGH) - - ! Initialize the tensor with zeros - eel%tmat = 0.0_rp - - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,tensor,ii,jj) - do i = 1, eel%pol_atoms - do j = 1, i - call dipole_T(eel, i, j, tensor) - - do ii=1, 3 - do jj=1, 3 - eel%tmat((j-1)*3+jj, (i-1)*3+ii) = tensor(jj, ii) - eel%tmat((i-1)*3+ii, (j-1)*3+jj) = tensor(jj, ii) - end do - end do - enddo - enddo - - ! Print the matrix if verbose output is requested - ! if(verbose == OMMP_VERBOSE_DEBUG) then - ! call print_matrix(.true., 'Polarization tensor:', & - ! 3*pol_atoms, 3*pol_atoms, & - ! 3*pol_atoms, 3*pol_atoms, TMat) - ! end if - - end subroutine create_TMat - - subroutine TMatVec_incore(eel, x, y, dodiag) - !! Perform matrix vector multiplication y = TMat*x, - !! where TMat is polarization matrix (precomputed and stored in memory) - !! and x and y are column vectors - - implicit none - - type(ommp_electrostatics_type), intent(in) :: eel - !! The electostatic data structure - real(rp), dimension(3*eel%pol_atoms), intent(in) :: x - !! Input vector - real(rp), dimension(3*eel%pol_atoms), intent(out) :: y - !! Output vector - logical, intent(in) :: dodiag - !! Logical flag (.true. = diagonal is computed, .false. = diagonal is - !! skipped) - - call TMatVec_offdiag(eel, x, y) - if(dodiag) call TMatVec_diag(eel, x, y) - - end subroutine TMatVec_incore - - subroutine TMatVec_otf(eel, x, y, dodiag) - !! Perform matrix vector multiplication y = TMat*x, - !! where TMat is polarization matrix (precomputed and stored in memory) - !! and x and y are column vectors - use mod_electrostatics, only: field_extD2D - implicit none - - type(ommp_electrostatics_type), intent(in) :: eel - !! The electostatic data structure - real(rp), dimension(3*eel%pol_atoms), intent(in) :: x - !! Input vector - real(rp), dimension(3*eel%pol_atoms), intent(out) :: y - !! Output vector - logical, intent(in) :: dodiag - !! Logical flag (.true. = diagonal is computed, .false. = diagonal is - !! skipped) - - y = 0.0_rp - call field_extD2D(eel, x, y) - y = -1.0_rp * y ! Why? TODO - if(dodiag) call TMatVec_diag(eel, x, y) - - end subroutine TMatVec_otf - - subroutine TMatVec_diag(eel, x, y) - !! This routine compute the product between the diagonal of T matrix - !! with x, and add it to y. The product is simply computed by - !! each element of x for its inverse polarizability. - - implicit none - - type(ommp_electrostatics_type), intent(in) :: eel - !! The electostatic data structure - real(rp), dimension(3*eel%pol_atoms), intent(in) :: x - !! Input vector - real(rp), dimension(3*eel%pol_atoms), intent(out) :: y - !! Output vector - - integer(ip) :: i, ii - - !$omp parallel do default(shared) private(i,ii) - do i=1, 3*eel%pol_atoms - ii = (i+2)/3 - y(i) = y(i) + x(i) / eel%pol(ii) - end do - end subroutine TMatVec_diag - - subroutine TMatVec_offdiag(eel, x, y) - !! Perform matrix vector multiplication y = [TMat-diag(TMat)]*x, - !! where TMat is polarization matrix (precomputed and stored in memory) - !! and x and y are column vectors - use mod_memory, only: mallocate, mfree - - implicit none - - type(ommp_electrostatics_type), intent(in) :: eel - !! The electostatic data structure - real(rp), dimension(3*eel%pol_atoms), intent(in) :: x - !! Input vector - real(rp), dimension(3*eel%pol_atoms), intent(out) :: y - !! Output vector - - integer(ip) :: i, n - - n = 3*eel%pol_atoms - - ! Compute the matrix vector product - call dgemm('N', 'N', n, 1, n, 1.0_rp, eel%tmat, n, x, n, 0.0_rp, y, n) - ! Subtract the product of diagonal - !$omp parallel do default(shared) private(i) - do i = 1, n - y(i) = y(i) - eel%tmat(i,i) * x(i) - end do - - end subroutine TMatVec_offdiag - - subroutine PolVec(eel, x, y) - !! Perform matrix vector multiplication y = pol*x, - !! where pol is polarizability vector, x and y are - !! column vectors - - implicit none - - type(ommp_electrostatics_type), intent(in) :: eel - !! The electostatic data structure - real(rp), dimension(3*eel%pol_atoms), intent(in) :: x - !! Input vector - real(rp), dimension(3*eel%pol_atoms), intent(out) :: y - !! Output vector - - integer(ip) :: i, indx - - !$omp parallel do default(shared) private(indx,i) - do i = 1, 3*eel%pol_atoms - indx = (i+2)/3 - y(i) = eel%pol(indx)*x(i) - enddo - - end subroutine PolVec - -end module mod_polarization diff --git a/src/mod_prm.F90 b/src/mod_prm.F90 new file mode 100644 index 0000000..2a99df7 --- /dev/null +++ b/src/mod_prm.F90 @@ -0,0 +1,3623 @@ +module mod_prm + !! This module handles the reading of a parameter file in .prm format and + !! the asignament of parameters based on atom type and connectivity. + + use mod_memory, only: ip, rp, lp + use mod_io, only: fatal_error, ommp_message + use mod_topology, only: ommp_topology_type + use mod_bonded, only: ommp_bonded_type + use mod_electrostatics, only: ommp_electrostatics_type + use mod_constants, only: OMMP_STR_CHAR_MAX, OMMP_VERBOSE_LOW, & + OMMP_VERBOSE_HIGH + use mod_utils, only: isreal, isint, tokenize, count_substr_occurence, & + str_to_lower, str_uncomment + + implicit none + private + + + !!public :: assign_vdw, assign_pol, assign_mpoles, assign_bond, & + !! assign_angle, assign_urey, assign_strbnd, assign_opb, & + !! assign_pitors, assign_torsion, assign_tortors, & + !! assign_angtor, assign_strtor, terminate_prm + public :: assign_pol, assign_mpoles + public :: assign_vdw + public :: assign_bond, assign_angle, assign_urey, assign_strbnd, assign_opb + public :: assign_pitors, assign_torsion, assign_tortors, assign_angtor + public :: assign_strtor, assign_imptorsion + public :: check_keyword, get_prm_ff_type + +contains + +#include "prm_keywords.F90" + + function get_prm_ff_type(prm_buf) result(ff_type) + !! This function is intended to check if the ff described by prm_type + !! is AMOEBA (or amoeba-like) or AMBER or FF of another kind. + !! A FF is considered to be AMOEBA if: it contains multipole keywords + !! (and no charge keywords) and polarization MUTUAL. + !! A FF is considered do be AMBER if contains charge keyword and no + !! multipole keyword. + use mod_constants, only: OMMP_FF_AMBER, & + OMMP_FF_AMOEBA, & + OMMP_FF_UNKNOWN + use mod_io, only: fatal_error + + implicit none + + character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) + !! Char buffer containing the prm file loaded in RAM + + integer(ip) :: il, nmultipole, ncharge, tokb, toke, ff_type + character(len=OMMP_STR_CHAR_MAX) :: line, polarization + + ! Read all the lines of file just to count how large vector should be + ! allocated + nmultipole = 0 + ncharge = 0 + do il=1, size(prm_buf) + line = prm_buf(il) + if(line(:7) == 'charge ') ncharge = ncharge + 1 + if(line(:10) == 'multipole ') nmultipole = nmultipole + 1 + if(line(:13) == 'polarization ') then + tokb = 13 + toke = tokenize(line, tokb) + read(line(tokb:toke), '(A)') polarization + end if + end do + + if(nmultipole > 0 .and. & + ncharge == 0 .and. & + polarization(:6) == 'mutual') then + ff_type = OMMP_FF_AMOEBA + else if(nmultipole == 0 .and. & + ncharge > 0) then + ff_type = OMMP_FF_AMBER + else + ff_type = OMMP_FF_UNKNOWN + end if + end function + + subroutine read_atom_cards(top, prm_buf) + use mod_memory, only: mallocate, mfree + use mod_io, only: fatal_error + + implicit none + + type(ommp_topology_type), intent(inout) :: top + !! Topology object + character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) + + integer(ip) :: i, il, lc, iat, toke, tokb, tokb1, nquote + character(len=OMMP_STR_CHAR_MAX) :: line, errstring + integer(ip) :: natype + integer(ip), allocatable, dimension(:) :: typez, typeclass + real(rp), allocatable, dimension(:) :: typemass + + + if(.not. top%attype_initialized) then + call fatal_error("Atom type array in topology should be initialized& + & before performing atomclass asignament.") + end if + + ! Read all the lines of file just to count how large vector should be + ! allocated + natype = 0 + do il=1, size(prm_buf) + line = prm_buf(il) + if(line(:5) == 'atom ') then + tokb = 6 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong ATOM card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) iat + natype = max(natype, iat) + end if + end do + + call mallocate('read_prm [typeclass]', natype, typeclass) + call mallocate('read_prm [typez]', natype, typez) + call mallocate('read_prm [typemass]', natype, typemass) + typeclass = 0 + typez = 0 + typemass = 0.0 + + ! Restart the reading from the beginning to actually save the parameters + do il=1, size(prm_buf) + line = prm_buf(il) + + if(line(:5) == 'atom ') then + tokb = 6 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong ATOM card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) iat + + tokb = toke+1 + toke = tokenize(line, tokb) + read(line(tokb:toke), *) typeclass(iat) + + tokb = toke+1 + toke = tokenize(line, tokb) + ! This token contain the atom name + + tokb = toke+1 + toke = tokenize(line, tokb) + nquote = count_substr_occurence(line(tokb:toke), '"') + do while(nquote < 2) + tokb1 = toke+1 + toke = tokenize(line, tokb1) + nquote = nquote + count_substr_occurence(line(tokb1:toke), '"') + end do + ! This token contains the description string + tokb = toke+1 + toke = tokenize(line, tokb) + read(line(tokb:toke), *) typez(iat) + + tokb = toke+1 + toke = tokenize(line, tokb) + read(line(tokb:toke), *) typemass(iat) + + ! Only partial reading of ATOM card is needed for now. + end if + end do + + !$omp parallel do + do i = 1, top%mm_atoms + if(.not. top%atclass_initialized) then + top%atclass(i) = typeclass(top%attype(i)) + end if + + if(.not. top%atz_initialized) then + top%atz(i) = typez(top%attype(i)) + end if + + if(.not. top%atmass_initialized) then + top%atmass(i) = typemass(top%attype(i)) + end if + end do + + top%atclass_initialized = .true. + top%atz_initialized = .true. + top%atmass_initialized = .true. + + call mfree('read_prm [typeclass]', typeclass) + call mfree('read_prm [typez]', typez) + call mfree('read_prm [typemass]', typemass) + + end subroutine read_atom_cards + + subroutine assign_bond(bds, prm_buf, exclude_list, nexc_in) + use mod_memory, only: mallocate, mfree + use mod_io, only: fatal_error + use mod_bonded, only: bond_init, ommp_bonded_type + use mod_constants, only: angstrom2au, kcalmol2au + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + !! Bonded potential data structure + character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) + integer(ip), dimension(:), intent(in), optional :: exclude_list + !! List of atoms for which interactions should not be computed + integer(ip), intent(in), optional :: nexc_in + !! Number of atom in excluded list needed to skip a parameter + + integer(ip), parameter :: nexc_default = 2 + integer(ip) :: il, i, j, l, jat, tokb, toke, ibnd, nbnd, & + cla, clb, nexc, iexc + character(len=OMMP_STR_CHAR_MAX) :: line, errstring + integer(ip), allocatable :: classa(:), classb(:) + real(rp), allocatable :: kbnd(:), l0bnd(:) + logical :: done + type(ommp_topology_type), pointer :: top + + top => bds%top + + nexc = nexc_default + if(present(exclude_list)) then + if(present(nexc_in)) then + if(nexc_in > 0 .and. nexc_in < 4) then + nexc = nexc_in + end if + end if + end if + + if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then + call read_atom_cards(top, prm_buf) + end if + + ! We assume that all pair of bonded atoms have a bonded + ! parameter + call bond_init(bds, (top%conn(1)%ri(top%mm_atoms+1)-1) / 2) + !! If there are no bonds in the system just return, there + !! is nothing to do. + if(.not. bds%use_bond) return + + bds%kbond = 0 + bds%l0bond = 0 + + l=1 + do i=1, top%mm_atoms + do j=top%conn(1)%ri(i), top%conn(1)%ri(i+1)-1 + jat = top%conn(1)%ci(j) + if(i < jat) then + bds%bondat(1,l) = i + bds%bondat(2,l) = jat + l = l+1 + end if + end do + end do + + ! Read all the lines of file just to count how large vector should be + ! allocated + nbnd = 0 + do il=1, size(prm_buf) + line = prm_buf(il) + if(line(:5) == 'bond ') nbnd = nbnd + 1 + end do + + call mallocate('assign_bond [classa]', nbnd, classa) + call mallocate('assign_bond [classb]', nbnd, classb) + call mallocate('assign_bond [l0bnd]', nbnd, l0bnd) + call mallocate('assign_bond [kbnd]', nbnd, kbnd) + + ! Restart the reading from the beginning to actually save the parameters + ibnd = 1 + i=1 + do il=1, size(prm_buf) + line = prm_buf(il) + + if(line(:11) == 'bond-cubic ') then + tokb = 12 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong BOND-CUBIC card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) bds%bond_cubic + ! This parameter is 1/Angstrom + bds%bond_cubic = bds%bond_cubic / angstrom2au + + else if(line(:13) == 'bond-quartic ') then + tokb = 14 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong BOND-QUARTIC card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) bds%bond_quartic + bds%bond_quartic = bds%bond_quartic / (angstrom2au**2) + + else if(line(:5) == 'bond ') then + tokb = 6 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong BOND card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classa(ibnd) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong BOND card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classb(ibnd) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong BOND card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) kbnd(ibnd) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong BOND card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) l0bnd(ibnd) + + ibnd = ibnd + 1 + end if + i = i+1 + end do + + do i=1, size(bds%bondat,2) + ! Atom class for current pair + cla = top%atclass(bds%bondat(1,i)) + clb = top%atclass(bds%bondat(2,i)) + + done = .false. + do j=1, nbnd + if((classa(j)==cla .and. classb(j)==clb) .or. & + (classa(j)==clb .and. classb(j)==cla)) then + done = .true. + bds%kbond(i) = kbnd(j) * kcalmol2au / (angstrom2au**2) + bds%l0bond(i) = l0bnd(j) * angstrom2au + exit + end if + end do + + if(present(exclude_list) .and. .not. done) then + iexc = 0 + if(any(exclude_list == bds%bondat(1,i))) iexc = iexc + 1 + if(any(exclude_list == bds%bondat(2,i))) iexc = iexc + 1 + if(iexc >= nexc) then + done = .true. + write(errstring, '(A,I0,A,I0,A,I0,A)') & + "Bond ", bds%bondat(1,i), '-', bds%bondat(2,i), & + " not found and ignored because ", iexc, " atoms are & + &in excluded list." + call ommp_message(errstring, OMMP_VERBOSE_HIGH) + end if + end if + + if(.not. done) then + call fatal_error("Bond parameter not found!") + end if + end do + + call mfree('assign_bond [classa]', classa) + call mfree('assign_bond [classb]', classb) + call mfree('assign_bond [l0bnd]', l0bnd) + call mfree('assign_bond [kbnd]', kbnd) + + end subroutine assign_bond + + subroutine assign_urey(bds, prm_buf) + use mod_memory, only: mallocate, mfree + use mod_bonded, only: urey_init + use mod_constants, only: angstrom2au, kcalmol2au + + implicit none + + + type(ommp_bonded_type), intent(inout) :: bds + !! Bonded potential data structure + character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) + + integer(ip) :: il, i, j, tokb, toke, iub, nub, & + cla, clb, clc, maxub, a, b, c, jc, jb + character(len=OMMP_STR_CHAR_MAX) :: line, errstring + integer(ip), allocatable :: classa(:), classb(:), classc(:), ubtmp(:) + real(rp), allocatable :: kub(:), l0ub(:) + logical :: done + type(ommp_topology_type), pointer :: top + + top => bds%top + + if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then + call read_atom_cards(top, prm_buf) + end if + + ! Read all the lines of file just to count how large vector should be + ! allocated + nub = 0 + do il=1, size(prm_buf) + line = prm_buf(il) + if(line(:9) == 'ureybrad ') nub = nub + 1 + end do + + maxub = top%conn(2)%ri(top%mm_atoms+1)-1 + ! Maximum number of UB terms (each angle have an UB term) + call mallocate('assign_urey [classa]', nub, classa) + call mallocate('assign_urey [classb]', nub, classb) + call mallocate('assign_urey [classc]', nub, classc) + call mallocate('assign_urey [l0ub]', nub, l0ub) + call mallocate('assign_urey [kub]', nub, kub) + call mallocate('assign_urey [ubtmp]', maxub, ubtmp) + + ! Restart the reading from the beginning to actually save the parameters + iub = 1 + i=1 + do il=1, size(prm_buf) + line = prm_buf(il) + + if(line(:11) == 'urey-cubic ') then + tokb = 12 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong UREY-CUBIC card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) bds%urey_cubic + ! This parameter is 1/Angstrom + bds%urey_cubic = bds%urey_cubic / angstrom2au + + else if(line(:13) == 'urey-quartic ') then + tokb = 14 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong UREY-QUARTIC card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) bds%urey_quartic + bds%urey_quartic = bds%urey_quartic / (angstrom2au**2) + + else if(line(:9) == 'ureybrad ') then + tokb = 10 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong UREYBRAD card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classa(iub) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong UREYBRAD card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classb(iub) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong UREYBRAD card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classc(iub) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong UREYBRAD card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) kub(iub) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong UREYBRAD card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) l0ub(iub) + + iub = iub + 1 + end if + i = i+1 + end do + + ubtmp = -1 + do a=1, top%mm_atoms + cla = top%atclass(a) + do jb=top%conn(2)%ri(a), top%conn(2)%ri(a+1)-1 + b = top%conn(2)%ci(jb) + done = .false. + if(a > b) cycle + clb = top%atclass(b) + + do jc=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 + c = top%conn(1)%ci(jc) + if(all(top%conn(1)%ci(top%conn(1)%ri(b): & + top%conn(1)%ri(b+1)-1) /= c)) cycle + ! There is an angle in the form A-C-B + clc = top%atclass(c) + do j=1, nub + if((cla == classa(j) & + .and. clb == classc(j) & + .and. clc == classb(j)) .or. & + (clb == classa(j) & + .and. cla == classc(j) & + .and. clc == classb(j))) then + + ubtmp(jb) = j + ! Temporary assignament in a sparse matrix logic + done = .true. + exit + end if + end do + + if(done) exit + ! If we have already found a parameter for A-B pair, stop + ! the research + end do + end do + end do + + call urey_init(bds, count(ubtmp > 0)) + iub = 1 + do a=1, top%mm_atoms + do jb=top%conn(2)%ri(a), top%conn(2)%ri(a+1)-1 + if(ubtmp(jb) > 0) then + bds%ureyat(1,iub) = a + bds%ureyat(2,iub) = top%conn(2)%ci(jb) + bds%kurey(iub) = kub(ubtmp(jb)) * kcalmol2au / (angstrom2au**2) + bds%l0urey(iub) = l0ub(ubtmp(jb)) * angstrom2au + iub = iub + 1 + end if + end do + end do + + call mfree('assign_urey [classa]', classa) + call mfree('assign_urey [classb]', classb) + call mfree('assign_urey [classc]', classc) + call mfree('assign_urey [l0ub]', l0ub) + call mfree('assign_urey [kub]', kub) + call mfree('assign_urey [ubtmp]', ubtmp) + + end subroutine assign_urey + + subroutine assign_strbnd(bds, prm_buf) + use mod_memory, only: mallocate, mfree + use mod_bonded, only: strbnd_init + use mod_constants, only: kcalmol2au, angstrom2au + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + !! Bonded potential data structure + character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) + !! Char buffer containing the prm file loaded in RAM + + integer(ip) :: il, i, j, tokb, toke, isb, nstrbnd, & + cla, clb, clc, a, b, c, jc, jb, maxsb, & + l1a, l1b, l2a, l2b + character(len=OMMP_STR_CHAR_MAX) :: line, errstring + integer(ip), allocatable :: classa(:), classb(:), classc(:), sbtmp(:), & + sbattmp(:, :), at2bnd(:), at2ang(:) + real(rp), allocatable :: k1(:), k2(:) + logical :: done, thet_done, l1_done, l2_done + type(ommp_topology_type), pointer :: top + + top => bds%top + + if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then + call read_atom_cards(top, prm_buf) + end if + + ! Read all the lines of file just to count how large vector should be + ! allocated + nstrbnd = 0 + do il=1, size(prm_buf) + line = prm_buf(il) + if(line(:7) == 'strbnd ') nstrbnd = nstrbnd + 1 + end do + + maxsb = (top%conn(2)%ri(top%mm_atoms+1)-1) / 2 + call mallocate('assign_strbnd [classa]', nstrbnd, classa) + call mallocate('assign_strbnd [classb]', nstrbnd, classb) + call mallocate('assign_strbnd [classc]', nstrbnd, classc) + call mallocate('assign_strbnd [eqang]', nstrbnd, k1) + call mallocate('assign_strbnd [kang]', nstrbnd, k2) + call mallocate('assign_strbnd [sbtmp]', maxsb, sbtmp) + call mallocate('assign_strbnd [sbattmp]', 3, maxsb, sbattmp) + call mallocate('assign_strbnd [at2bnd]', top%mm_atoms, at2bnd) + call mallocate('assign_strbnd [at2ang]', top%mm_atoms, at2ang) + + ! Restart the reading from the beginning to actually save the parameters + isb = 1 + i=1 + do il=1, size(prm_buf) + line = prm_buf(il) + + if(line(:7) == 'strbnd ') then + tokb = 8 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong STRBND card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classa(isb) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong STRBND card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classb(isb) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong STRBND card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classc(isb) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong STRBND card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) k1(isb) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong STRBND card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) k2(isb) + + isb = isb + 1 + end if + i = i+1 + end do + + isb = 1 + do a=1, top%mm_atoms + cla = top%atclass(a) + do jb=top%conn(2)%ri(a), top%conn(2)%ri(a+1)-1 + b = top%conn(2)%ci(jb) + if(a > b) cycle + clb = top%atclass(b) + + do jc=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 + c = top%conn(1)%ci(jc) + if(all(top%conn(1)%ci(top%conn(1)%ri(b):& + top%conn(1)%ri(b+1)-1) /= c)) cycle + ! There is an angle in the form A-C-B + clc = top%atclass(c) + done = .false. + + do j=1, nstrbnd + if((cla == classa(j) & + .and. clb == classc(j) & + .and. clc == classb(j)) .or. & + (clb == classa(j) & + .and. cla == classc(j) & + .and. clc == classb(j))) then + sbattmp(1,isb) = a + sbattmp(2,isb) = c + sbattmp(3,isb) = b + if(cla == classa(j)) then + ! Assign the correct k to each bond stretching! + sbtmp(isb) = j + else + sbtmp(isb) = -j + end if + isb = isb + 1 + exit + end if + end do + end do + end do + end do + + call strbnd_init(bds, isb-1) + if(isb-1 < 1) then + !! No parameters are defined, nothing to do. + return + end if + + at2bnd(1) = 1 + do i=1, top%mm_atoms-1 + at2bnd(i+1) = at2bnd(i) + do j=top%conn(1)%ri(i), top%conn(1)%ri(i+1)-1 + if(i < top%conn(1)%ci(j)) then + at2bnd(i+1) = at2bnd(i+1) + 1 + end if + end do + end do + + at2ang = 0 + do j=1, size(bds%angleat, 2) + if(at2ang(bds%angleat(1,j)) == 0) at2ang(bds%angleat(1,j)) = j + end do + + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,l1a,l1b,l2a,l2b,l1_done,l2_done,thet_done) + do i=1, isb-1 + ! First assign the parameters + bds%strbndat(:,i) = sbattmp(:,i) + j = abs(sbtmp(i)) + if(sbtmp(i) > 0) then + bds%strbndk1(i) = k1(j) * kcalmol2au / angstrom2au + bds%strbndk2(i) = k2(j) * kcalmol2au / angstrom2au + else + bds%strbndk1(i) = k2(j) * kcalmol2au / angstrom2au + bds%strbndk2(i) = k1(j) * kcalmol2au / angstrom2au + end if + + l1a = min(bds%strbndat(1,i), bds%strbndat(2,i)) + l1b = max(bds%strbndat(1,i), bds%strbndat(2,i)) + l2a = min(bds%strbndat(3,i), bds%strbndat(2,i)) + l2b = max(bds%strbndat(3,i), bds%strbndat(2,i)) + + ! Now search for the corresponding bond and angle parameters to + ! set the equilibrium distances and angle + l1_done = .false. + l2_done = .false. + thet_done = .false. + + do j=at2bnd(l1a), size(bds%bondat, 2) + if(l1a == bds%bondat(1,j) .and. l1b == bds%bondat(2,j)) then + l1_done = .true. + bds%strbndl10(i) = bds%l0bond(j) + exit + end if + end do + + do j=at2bnd(l2a), size(bds%bondat, 2) + if(l2a == bds%bondat(1,j) .and. l2b == bds%bondat(2,j)) then + l2_done = .true. + bds%strbndl20(i) = bds%l0bond(j) + exit + end if + end do + + do j=at2ang(bds%strbndat(1,i)), size(bds%angleat, 2) + if(all(bds%strbndat(:,i) == bds%angleat(:,j))) then + thet_done = .true. + bds%strbndthet0(i) = bds%eqangle(j) + exit + end if + end do + + if(.not.(l1_done .and. l2_done .and. thet_done)) then + call fatal_error("Ill-defined stretch-bending cross term") + end if + end do + + call mfree('assign_strbnd [classa]', classa) + call mfree('assign_strbnd [classb]', classb) + call mfree('assign_strbnd [classc]', classc) + call mfree('assign_strbnd [eqang]', k1) + call mfree('assign_strbnd [kang]', k2) + call mfree('assign_strbnd [sbtmp]', sbtmp) + call mfree('assign_strbnd [sbattmp]', sbattmp) + call mfree('assign_strbnd [at2bnd]', at2bnd) + call mfree('assign_strbnd [at2ang]', at2ang) + + end subroutine assign_strbnd + + subroutine assign_opb(bds, prm_buf) + use mod_memory, only: mallocate, mfree + use mod_bonded, only: opb_init + + use mod_constants, only: kcalmol2au, rad2deg + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + !! Bonded potential data structure + character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) + + integer(ip) :: il, i, tokb, toke, iopb, nopb, & + cla, clb, clc, cld, maxopb, a, b, c, d, jc, jb, iprm + character(len=OMMP_STR_CHAR_MAX) :: line, errstring, opb_type + integer(ip), allocatable :: classa(:), classb(:), classc(:), & + classd(:), tmpat(:,:) + real(rp), allocatable :: kopbend(:), tmpk(:) + type(ommp_topology_type), pointer :: top + + top => bds%top + + if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then + call read_atom_cards(top, prm_buf) + end if + + ! Tinker manual default + opb_type = "w-d-c" + + ! Read all the lines of file just to count how large vector should be + ! allocated + nopb = 0 + do il=1, size(prm_buf) + line = prm_buf(il) + if(line(:7) == 'opbend ') nopb = nopb + 1 + end do + + + if(nopb == 0) then + ! If there are no OPB terms, just stop here. + return + end if + maxopb = top%mm_atoms*3 + call mallocate('assign_opb [classa]', nopb, classa) + call mallocate('assign_opb [classb]', nopb, classb) + call mallocate('assign_opb [classc]', nopb, classc) + call mallocate('assign_opb [classd]', nopb, classd) + call mallocate('assign_opb [kopbend]', nopb, kopbend) + call mallocate('assign_opb [tmpat]', 4, maxopb, tmpat) + call mallocate('assign_opb [tmpk]', maxopb, tmpk) + + ! Restart the reading from the beginning to actually save the parameters + iopb = 1 + i=1 + do il=1, size(prm_buf) + line = prm_buf(il) + + if(line(:11) == 'opbendtype ') then + tokb = 12 + toke = tokenize(line, tokb) + read(line(tokb:toke), *) opb_type + + else if(line(:13) == 'opbend-cubic ') then + tokb = 14 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong OPBEND-CUBIC card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) bds%opb_cubic + bds%opb_cubic = bds%opb_cubic * rad2deg + + else if(line(:15) == 'opbend-quartic ') then + tokb = 16 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong OPBEND-QUARTIC card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) bds%opb_quartic + bds%opb_quartic = bds%opb_quartic * rad2deg**2 + + else if(line(:14) == 'opbend-pentic ') then + tokb = 15 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong OPBEND-PENTIC card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) bds%opb_pentic + bds%opb_pentic = bds%opb_pentic * rad2deg**3 + + else if(line(:14) == 'opbend-sextic ') then + tokb = 15 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong OPBEND-SEXTIC card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) bds%opb_sextic + bds%opb_sextic = bds%opb_sextic * rad2deg**4 + + else if(line(:7) == 'opbend ') then + tokb = 8 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong OPBEND card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classa(iopb) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong OPBEND card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classb(iopb) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong OPBEND card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classc(iopb) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong OPBEND card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classd(iopb) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong OPBEND card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) kopbend(iopb) + + iopb = iopb + 1 + end if + i = i+1 + end do + + iopb = 1 + do a=1, top%mm_atoms + ! Check if the center is trigonal + if(top%conn(1)%ri(a+1) - top%conn(1)%ri(a) /= 3) cycle + cla = top%atclass(a) + ! Loop over the atoms connected to the trignonal center + do jb=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 + b = top%conn(1)%ci(jb) + clb = top%atclass(b) + + c = -1 + d = -1 + clc = 0 + cld = 0 + do jc=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 + if(top%conn(1)%ci(jc) == b) cycle + if(c < 0) then + c = top%conn(1)%ci(jc) + clc = top%atclass(c) + else if(d < 0) then + d = top%conn(1)%ci(jc) + cld = top%atclass(d) + end if + end do + + do iprm=1, nopb + if((classa(iprm) == clb) .and. & + (classb(iprm) == cla) .and. & + ((classc(iprm) == clc .and. & + classd(iprm) == cld) .or. & + (classd(iprm) == clc .and. & + classc(iprm) == cld) .or. & + (classd(iprm) == 0 .and. & + (classc(iprm) == cld .or. classc(iprm) == clc)) .or. & + (classc(iprm) == 0 .and. & + (classd(iprm) == cld .or. classd(iprm) == clc)) .or. & + (classc(iprm) == 0 .or. classd(iprm) == 0))) then + ! The parameter is ok + tmpat(1,iopb) = a + tmpat(2,iopb) = b + tmpat(3,iopb) = c + tmpat(4,iopb) = d + tmpk(iopb) = kopbend(iprm) + iopb = iopb + 1 + exit + endif + end do + end do + end do + + call opb_init(bds, iopb-1, trim(opb_type)) + + do i=1, iopb-1 + bds%kopb(i) = tmpk(i) * kcalmol2au + bds%opbat(:,i) = tmpat(:,i) + end do + + call mfree('assign_opb [classa]', classa) + call mfree('assign_opb [classb]', classb) + call mfree('assign_opb [classc]', classc) + call mfree('assign_opb [classd]', classd) + call mfree('assign_opb [kopbend]', kopbend) + call mfree('assign_opb [tmpat]', tmpat) + call mfree('assign_opb [tmpk]', tmpk) + + end subroutine assign_opb + + subroutine assign_pitors(bds, prm_buf) + use mod_memory, only: mallocate, mfree + use mod_bonded, only: pitors_init + use mod_constants, only: kcalmol2au + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + !! Bonded potential data structure + character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) + + integer(ip) :: il, i, tokb, toke, ipitors, npitors, & + cla, clb, maxpi, a, b, c, jb, iprm + character(len=OMMP_STR_CHAR_MAX) :: line, errstring + integer(ip), allocatable :: classa(:), classb(:), tmpat(:,:) + real(rp), allocatable :: kpi(:), tmpk(:) + type(ommp_topology_type), pointer :: top + + top => bds%top + + if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then + call read_atom_cards(top, prm_buf) + end if + + ! Read all the lines of file just to count how large vector should be + ! allocated + npitors = 1 + do il=1, size(prm_buf) + line = prm_buf(il) + if(line(:7) == 'pitors ') npitors = npitors + 1 + end do + + maxpi = top%mm_atoms + ! TODO This is maybe excessive, all trivalent atomso should be enough + call mallocate('assign_pitors [classa]', npitors, classa) + call mallocate('assign_pitors [classb]', npitors, classb) + call mallocate('assign_pitors [kpi]', npitors, kpi) + call mallocate('assign_pitors [tmpat]', 6, maxpi, tmpat) + call mallocate('assign_pitors [tmpk]', maxpi, tmpk) + + ! Restart the reading from the beginning to actually save the parameters + ipitors = 1 + i=1 + do il=1, size(prm_buf) + line = prm_buf(il) + + if(line(:7) == 'pitors ') then + tokb = 8 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong PITORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classa(ipitors) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong PITORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classb(ipitors) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong PITORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) kpi(ipitors) + + ipitors = ipitors + 1 + end if + i = i+1 + end do + + ipitors = 1 + do a=1, top%mm_atoms + ! Check if the center is trigonal + if(top%conn(1)%ri(a+1) - top%conn(1)%ri(a) /= 3) cycle + cla = top%atclass(a) + ! Loop over the atoms connected to the trignonal center + do jb=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 + b = top%conn(1)%ci(jb) + ! This avoid to compute the functions two times + if(a > b) cycle + + !Check if the second center is trigonal + if(top%conn(1)%ri(b+1) - top%conn(1)%ri(b) /= 3) cycle + clb = top%atclass(b) + + do iprm=1, npitors + if((cla == classa(iprm) .and. clb == classb(iprm)) .or. & + (clb == classa(iprm) .and. cla == classb(iprm))) then + ! The parameter is the right one + ! Save the atoms in the following way: + ! + ! 2 5 a => 1 + ! \ / b => 4 + ! 1 -- 4 + ! / \ + ! 3 6 + + tmpat(:,ipitors) = 0 + tmpat(1,ipitors) = a + do i=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 + c = top%conn(1)%ci(i) + if(c /= b) then + if(tmpat(2,ipitors) == 0) then + tmpat(2,ipitors) = c + else + tmpat(3,ipitors) = c + end if + end if + end do + + tmpat(4,ipitors) = b + do i=top%conn(1)%ri(b), top%conn(1)%ri(b+1)-1 + c = top%conn(1)%ci(i) + if(c /= a) then + if(tmpat(5,ipitors) == 0) then + tmpat(5,ipitors) = c + else + tmpat(6,ipitors) = c + end if + end if + end do + tmpk(ipitors) = kpi(iprm) + + ipitors = ipitors+1 + exit + end if + end do + end do + end do + + call pitors_init(bds, ipitors-1) + + do i=1, ipitors-1 + bds%kpitors(i) = tmpk(i) * kcalmol2au + bds%pitorsat(:,i) = tmpat(:,i) + end do + + call mfree('assign_pitors [classa]', classa) + call mfree('assign_pitors [classb]', classb) + call mfree('assign_pitors [kpi]', kpi) + call mfree('assign_pitors [tmpat]', tmpat) + call mfree('assign_pitors [tmpk]', tmpk) + + end subroutine assign_pitors + + subroutine assign_torsion(bds, prm_buf) + use mod_memory, only: mallocate, mfree + use mod_bonded, only: torsion_init + use mod_constants, only: kcalmol2au, deg2rad, eps_rp + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + !! Bonded potential data structure + character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) + + integer(ip) :: il, i, j, tokb, toke, it, nt, & + cla, clb, clc, cld, maxt, a, b, c, d, jb, jc, jd, iprm, ji, period + character(len=OMMP_STR_CHAR_MAX) :: line, errstring + integer(ip), allocatable :: classa(:), classb(:), classc(:), classd(:), & + t_n(:,:), tmpat(:,:), tmpprm(:), tmpbuf(:,:) + real(rp), allocatable :: t_amp(:,:), t_pha(:,:) + real(rp) :: amp, phase, torsion_unit = 1.0 + type(ommp_topology_type), pointer :: top + + top => bds%top + + if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then + call read_atom_cards(top, prm_buf) + end if + + ! Read all the lines of file just to count how large vector should be + ! allocated + nt = 1 + do il=1, size(prm_buf) + line = prm_buf(il) + if(line(:8) == 'torsion ') nt = nt + 1 + end do + + maxt = top%conn(3)%ri(top%mm_atoms+1)-1 + call mallocate('assign_torsion [classa]', nt, classa) + call mallocate('assign_torsion [classb]', nt, classb) + call mallocate('assign_torsion [classc]', nt, classc) + call mallocate('assign_torsion [classd]', nt, classd) + call mallocate('assign_torsion [t_amp]', 6, nt, t_amp) + call mallocate('assign_torsion [t_pha]', 6, nt, t_pha) + call mallocate('assign_torsion [t_n]', 6, nt, t_n) + call mallocate('assign_torsion [tmpat]', 4, maxt, tmpat) + call mallocate('assign_torsion [tmpprm]', maxt, tmpprm) + t_amp = 0.0 + t_pha = 0.0 + t_n = 1 + ! Restart the reading from the beginning to actually save the parameters + it = 1 + i=1 + do il=1, size(prm_buf) + line = prm_buf(il) + + if(line(:12) == 'torsionunit ') then + tokb = 13 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong TORSIONUNIT card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) torsion_unit + + else if(line(:8) == 'torsion ') then + tokb = 9 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong TORSION card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classa(it) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong TORSION card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classb(it) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong TORSION card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classc(it) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong TORSION card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classd(it) + + ji = 1 + t_n(:,it) = -1 + do j=1, 6 + tokb = toke + 1 + toke = tokenize(line, tokb) + if(toke < 0) exit + + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong TORSION card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) amp + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong TORSION card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) phase + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong TORSION card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) period + + if(abs(amp) > eps_rp) then + t_amp(ji, it) = amp + t_pha(ji, it) = phase + t_n(ji, it) = period + ji = ji + 1 + end if + end do + + if(j == 1) then + ! No parameter found + write(errstring, *) "Wrong TORSION card" + call fatal_error(errstring) + end if + + it = it + 1 + end if + i = i+1 + end do + + it = 1 + do a=1, top%mm_atoms + cla = top%atclass(a) + do jb=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 + b = top%conn(1)%ci(jb) + clb = top%atclass(b) + do jc=top%conn(1)%ri(b), top%conn(1)%ri(b+1)-1 + c = top%conn(1)%ci(jc) + if(c == a) cycle + clc = top%atclass(c) + do jd=top%conn(1)%ri(c), top%conn(1)%ri(c+1)-1 + d = top%conn(1)%ci(jd) + if(d == a .or. d == b) cycle + if(a > d) cycle + cld = top%atclass(d) + ! There is a dihedral A-B-C-D + do iprm=1, nt + if((classa(iprm) == cla .and. & + classb(iprm) == clb .and. & + classc(iprm) == clc .and. & + classd(iprm) == cld) .or. & + (classa(iprm) == cld .and. & + classb(iprm) == clc .and. & + classc(iprm) == clb .and. & + classd(iprm) == cla)) then + ! The parameter is ok + + ! Extrem check to avoid memory errors. + if(it > maxt) then + call mallocate('assign_torsion [tmpbuf]', 4, maxt, tmpbuf) + tmpbuf(:,:) = tmpat(:,:) + call mfree('assign_torsion [tmpat]', tmpat) + call mallocate('assign_torsion [tmpat]', 4, maxt+maxt+1, tmpat) + tmpat(:,1:maxt) = tmpbuf(:,:) + call mfree('assign_torsion [tmpbuf]', tmpbuf) + + call mallocate('assign_torsion [tmpbuf]', 1, maxt, tmpbuf) + tmpbuf(1,:) = tmpprm(:) + call mfree('assign_torsion [tmpprm]', tmpprm) + call mallocate('assign_torsion [tmpprm]', maxt+maxt+1, tmpprm) + tmpprm(1:maxt) = tmpbuf(1,:) + call mfree('assign_torsion [tmpbuf]', tmpbuf) + + maxt = 2*maxt + 1 + end if + + tmpat(:,it) = [a, b, c, d] + tmpprm(it) = iprm + it = it+1 + exit + end if + end do + end do + end do + end do + end do + + call torsion_init(bds, it-1) + do i=1, it-1 + bds%torsionat(:,i) = tmpat(:,i) + bds%torsamp(:,i) = t_amp(:,tmpprm(i)) * kcalmol2au * torsion_unit + bds%torsphase(:,i) = t_pha(:,tmpprm(i)) * deg2rad + bds%torsn(:,i) = t_n(:,tmpprm(i)) + end do + + call mfree('assign_torsion [classa]', classa) + call mfree('assign_torsion [classb]', classb) + call mfree('assign_torsion [classc]', classc) + call mfree('assign_torsion [classd]', classd) + call mfree('assign_torsion [t_amp]', t_amp) + call mfree('assign_torsion [t_pha]', t_pha) + call mfree('assign_torsion [t_n]', t_n) + call mfree('assign_torsion [tmpat]', tmpat) + call mfree('assign_torsion [tmpprm]', tmpprm) + + end subroutine assign_torsion + + subroutine assign_imptorsion(bds, prm_buf) + use mod_memory, only: mallocate, mfree + use mod_bonded, only: imptorsion_init + use mod_constants, only: kcalmol2au, deg2rad, eps_rp + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + !! Bonded potential data structure + character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) + + integer(ip) :: il, i, j, tokb, toke, it, nt, & + cla, clb, clc, cld, maxt, a, b, c, d, jb, jc, jd, iprm, ji, period + character(len=OMMP_STR_CHAR_MAX) :: line, errstring + integer(ip), allocatable :: classa(:), classb(:), classc(:), classd(:), & + t_n(:,:), tmpat(:,:), tmpprm(:) + real(rp), allocatable :: t_amp(:,:), t_pha(:,:) + real(rp) :: amp, phase, imptorsion_unit = 1.0 + type(ommp_topology_type), pointer :: top + + top => bds%top + + if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then + call read_atom_cards(top, prm_buf) + end if + + ! Read all the lines of file just to count how large vector should be + ! allocated + nt = 1 + do il=1, size(prm_buf) + line = prm_buf(il) + if(line(:8) == 'imptors ') nt = nt + 1 + end do + + maxt = top%conn(4)%ri(top%mm_atoms+1)-1 + call mallocate('assign_imptorsion [classa]', nt, classa) + call mallocate('assign_imptorsion [classb]', nt, classb) + call mallocate('assign_imptorsion [classc]', nt, classc) + call mallocate('assign_imptorsion [classd]', nt, classd) + call mallocate('assign_imptorsion [t_amp]', 3, nt, t_amp) + call mallocate('assign_imptorsion [t_pha]', 3, nt, t_pha) + call mallocate('assign_imptorsion [t_n]', 3, nt, t_n) + call mallocate('assign_imptorsion [tmpat]', 4, maxt, tmpat) + call mallocate('assign_imptorsion [tmpprm]', maxt, tmpprm) + t_amp = 0.0 + t_pha = 0.0 + t_n = 1 + ! Restart the reading from the beginning to actually save the parameters + it = 1 + i=1 + do il=1, size(prm_buf) + line = prm_buf(il) + + if(line(:12) == 'imptorsunit ') then + tokb = 13 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong IMPTORSUNIT card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) imptorsion_unit + + else if(line(:8) == 'imptors ') then + tokb = 9 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong IMPTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classa(it) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong IMPTROS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classb(it) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong IMPTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classc(it) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong IMPTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classd(it) + + ji = 1 + t_n(:,it) = -1 + do j=1, 3 + tokb = toke + 1 + toke = tokenize(line, tokb) + if(toke < 0) exit + + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong IMPTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) amp + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong IMPTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) phase + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong IMPTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) period + + if(abs(amp) > eps_rp) then + t_amp(ji, it) = amp + t_pha(ji, it) = phase + t_n(ji, it) = period + ji = ji + 1 + end if + end do + + if(j == 1) then + ! No parameter found + write(errstring, *) "Wrong IMPTORS card" + call fatal_error(errstring) + end if + + it = it + 1 + end if + i = i+1 + end do + + it = 1 + tmpat = 0 + + do a=1, top%mm_atoms + ! Check if the center is trigonal + if(top%conn(1)%ri(a+1) - top%conn(1)%ri(a) /= 3) cycle + cla = top%atclass(a) + + jb=top%conn(1)%ri(a) + b = top%conn(1)%ci(jb) + clb = top%atclass(b) + + jc=top%conn(1)%ri(a)+1 + c = top%conn(1)%ci(jc) + clc = top%atclass(c) + + jd=top%conn(1)%ri(a)+2 + d = top%conn(1)%ci(jd) + cld = top%atclass(d) + + do iprm=1, nt + if((classc(iprm) == cla)) then + if(clb == classa(iprm) .and. & + clc == classb(iprm) .and. & + cld == classd(iprm)) then + tmpat(1,it) = b + tmpat(2,it) = c + tmpat(3,it) = a + tmpat(4,it) = d + tmpprm(it) = iprm + it = it + 1 + end if + if(clb == classa(iprm) .and. & + cld == classb(iprm) .and. & + clc == classd(iprm)) then + tmpat(1,it) = b + tmpat(2,it) = d + tmpat(3,it) = a + tmpat(4,it) = c + tmpprm(it) = iprm + it = it + 1 + end if + if(clc == classa(iprm) .and. & + clb == classb(iprm) .and. & + cld == classd(iprm)) then + tmpat(1,it) = c + tmpat(2,it) = b + tmpat(3,it) = a + tmpat(4,it) = d + tmpprm(it) = iprm + it = it + 1 + end if + if(clc == classa(iprm) .and. & + cld == classb(iprm) .and. & + clb == classd(iprm)) then + tmpat(1,it) = c + tmpat(2,it) = d + tmpat(3,it) = a + tmpat(4,it) = b + tmpprm(it) = iprm + it = it + 1 + end if + if(cld == classa(iprm) .and. & + clb == classb(iprm) .and. & + clc == classd(iprm)) then + tmpat(1,it) = d + tmpat(2,it) = b + tmpat(3,it) = a + tmpat(4,it) = c + tmpprm(it) = iprm + it = it + 1 + end if + if(cld == classa(iprm) .and. & + clc == classb(iprm) .and. & + clb == classd(iprm)) then + tmpat(1,it) = d + tmpat(2,it) = c + tmpat(3,it) = a + tmpat(4,it) = b + tmpprm(it) = iprm + it = it + 1 + end if + endif + end do + end do + + call imptorsion_init(bds, it-1) + do i=1, it-1 + bds%imptorsionat(:,i) = tmpat(:,i) + bds%imptorsamp(:,i) = t_amp(:,tmpprm(i)) * kcalmol2au * imptorsion_unit + ! If more than one parameter is used for the same trigonal center, + ! then do an average + bds%imptorsamp(:,i) = bds%imptorsamp(:,i) / count(tmpat(3,1:it-1) == tmpat(3,i)) + bds%imptorsphase(:,i) = t_pha(:,tmpprm(i)) * deg2rad + bds%imptorsn(:,i) = t_n(:,tmpprm(i)) + end do + + call mfree('assign_imptorsion [classa]', classa) + call mfree('assign_imptorsion [classb]', classb) + call mfree('assign_imptorsion [classc]', classc) + call mfree('assign_imptorsion [classd]', classd) + call mfree('assign_imptorsion [t_amp]', t_amp) + call mfree('assign_imptorsion [t_pha]', t_pha) + call mfree('assign_imptorsion [t_n]', t_n) + call mfree('assign_imptorsion [tmpat]', tmpat) + call mfree('assign_imptorsion [tmpprm]', tmpprm) + + end subroutine assign_imptorsion + + subroutine assign_strtor(bds, prm_buf) + use mod_memory, only: mallocate, mfree + use mod_bonded, only: strtor_init + use mod_constants, only: kcalmol2au, angstrom2au + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + !! Bonded potential data structure + character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) + + integer(ip) :: il, i, j, tokb, toke, it, nt, & + cla, clb, clc, cld, maxt, a, b, c, d, jb, jc, jd, iprm + character(len=OMMP_STR_CHAR_MAX) :: line, errstring + integer(ip), allocatable :: classa(:), classb(:), classc(:), classd(:), & + tmpat(:,:), tmpprm(:) + real(rp), allocatable :: kat(:,:) + logical :: tor_done, bnd1_done, bnd2_done, bnd3_done + type(ommp_topology_type), pointer :: top + + top => bds%top + + if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then + call read_atom_cards(top, prm_buf) + end if + + + ! Read all the lines of file just to count how large vector should be + ! allocated + nt = 1 + do il=1, size(prm_buf) + line = prm_buf(il) + if(line(:8) == 'strtors ') nt = nt + 1 + end do + + maxt = top%conn(4)%ri(top%mm_atoms+1)-1 + call mallocate('assign_strtor [classa]', nt, classa) + call mallocate('assign_strtor [classb]', nt, classb) + call mallocate('assign_strtor [classc]', nt, classc) + call mallocate('assign_strtor [classd]', nt, classd) + call mallocate('assign_strtor [kat]', 9, nt, kat) + call mallocate('assign_strtor [tmpat]', 4, maxt, tmpat) + call mallocate('assign_strtor [tmpprm]', maxt, tmpprm) + + ! Restart the reading from the beginning to actually save the parameters + it = 1 + i=1 + do il=1, size(prm_buf) + line = prm_buf(il) + + if(line(:8) == 'strtors ') then + tokb = 9 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong STRTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classa(it) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong STRTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classb(it) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong STRTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classc(it) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong STRTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classd(it) + + do j=1, 9 + tokb = toke + 1 + toke = tokenize(line, tokb) + + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong STRTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) kat(j,it) + end do + + it = it + 1 + end if + i = i+1 + end do + + it = 1 + do a=1, top%mm_atoms + cla = top%atclass(a) + do jb=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 + b = top%conn(1)%ci(jb) + clb = top%atclass(b) + do jc=top%conn(1)%ri(b), top%conn(1)%ri(b+1)-1 + c = top%conn(1)%ci(jc) + if(c == a) cycle + clc = top%atclass(c) + do jd=top%conn(1)%ri(c), top%conn(1)%ri(c+1)-1 + d = top%conn(1)%ci(jd) + if(d == a .or. d == b) cycle + if(a > d) cycle + cld = top%atclass(d) + ! There is a dihedral A-B-C-D + do iprm=1, nt + if((classa(iprm) == cla .and. & + classb(iprm) == clb .and. & + classc(iprm) == clc .and. & + classd(iprm) == cld) .or. & + (classa(iprm) == cld .and. & + classb(iprm) == clc .and. & + classc(iprm) == clb .and. & + classd(iprm) == cla)) then + ! The parameter is ok + tmpat(:,it) = [a, b, c, d] + tmpprm(it) = iprm + it = it+1 + exit + end if + end do + end do + end do + end do + end do + + call strtor_init(bds, it-1) + do i=1, it-1 + bds%strtorat(:,i) = tmpat(:,i) + if(classa(tmpprm(i)) == top%atclass(bds%strtorat(1,i))) then + bds%strtork(:,i) = kat(:,tmpprm(i)) + else + bds%strtork(1:3,i) = kat(7:9,tmpprm(i)) + bds%strtork(4:6,i) = kat(4:6,tmpprm(i)) + bds%strtork(7:9,i) = kat(1:3,tmpprm(i)) + end if + bds%strtork(:,i) = bds%strtork(:,i) * kcalmol2au / angstrom2au + + tor_done = .false. + do j=1, size(bds%torsionat, 2) + if(all(bds%strtorat(:,i) == bds%torsionat(:,j))) then + tor_done = .true. + bds%strtor_t(i) = j + exit + end if + end do + + bnd1_done = .false. + bnd2_done = .false. + bnd3_done = .false. + do j=1, size(bds%bondat, 2) + if(all(bds%strtorat(1:2,i) == bds%bondat(:,j)) .or. & + all(bds%strtorat(2:1:-1,i) == bds%bondat(:,j))) then + bnd1_done = .true. + bds%strtor_b(1,i) = j + else if(all(bds%strtorat(2:3,i) == bds%bondat(:,j)) .or. & + all(bds%strtorat(3:2:-1,i) == bds%bondat(:,j))) then + bnd2_done = .true. + bds%strtor_b(2,i) = j + else if(all(bds%strtorat(3:4,i) == bds%bondat(:,j)) .or. & + all(bds%strtorat(4:3:-1,i) == bds%bondat(:,j))) then + bnd3_done = .true. + bds%strtor_b(3,i) = j + end if + if(bnd1_done .and. bnd2_done .and. bnd3_done) exit + end do + + if(.not. (tor_done .and. bnd1_done .and. bnd2_done .and. bnd3_done)) then + call fatal_error('Ill defined stretching-torsion coupling parameter') + end if + end do + + call mfree('assign_strtor [classa]', classa) + call mfree('assign_strtor [classb]', classb) + call mfree('assign_strtor [classc]', classc) + call mfree('assign_strtor [classd]', classd) + call mfree('assign_strtor [kat]', kat) + call mfree('assign_strtor [tmpat]', tmpat) + call mfree('assign_strtor [tmpprm]', tmpprm) + + end subroutine assign_strtor + + subroutine assign_angtor(bds, prm_buf) + use mod_memory, only: mallocate, mfree + use mod_bonded, only: angtor_init + use mod_constants, only: kcalmol2au + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + !! Bonded potential data structure + character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) + + integer(ip) :: il, i, j, tokb, toke, it, nt, & + cla, clb, clc, cld, maxt, a, b, c, d, jb, jc, jd, iprm + character(len=OMMP_STR_CHAR_MAX) :: line, errstring + integer(ip), allocatable :: classa(:), classb(:), classc(:), classd(:), & + tmpat(:,:), tmpprm(:) + real(rp), allocatable :: kat(:,:) + logical :: tor_done, ang1_done, ang2_done + type(ommp_topology_type), pointer :: top + + top => bds%top + + if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then + call read_atom_cards(top, prm_buf) + end if + + ! Read all the lines of file just to count how large vector should be + ! allocated + nt = 1 + do il=1, size(prm_buf) + line = prm_buf(il) + if(line(:8) == 'angtors ') nt = nt + 1 + end do + + maxt = top%conn(4)%ri(top%mm_atoms+1)-1 + call mallocate('assign_angtor [classa]', nt, classa) + call mallocate('assign_angtor [classb]', nt, classb) + call mallocate('assign_angtor [classc]', nt, classc) + call mallocate('assign_angtor [classd]', nt, classd) + call mallocate('assign_angtor [kat]', 6, nt, kat) + call mallocate('assign_angtor [tmpat]', 4, maxt, tmpat) + call mallocate('assign_angtor [tmpprm]', maxt, tmpprm) + + ! Restart the reading from the beginning to actually save the parameters + it = 1 + i=1 + do il=1, size(prm_buf) + line = prm_buf(il) + + if(line(:8) == 'angtors ') then + tokb = 9 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong ANGTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classa(it) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong ANGTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classb(it) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong ANGOTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classc(it) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong ANGTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classd(it) + + do j=1, 6 + tokb = toke + 1 + toke = tokenize(line, tokb) + + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong ANGTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) kat(j,it) + end do + + it = it + 1 + end if + i = i+1 + end do + + it = 1 + do a=1, top%mm_atoms + cla = top%atclass(a) + do jb=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 + b = top%conn(1)%ci(jb) + clb = top%atclass(b) + do jc=top%conn(1)%ri(b), top%conn(1)%ri(b+1)-1 + c = top%conn(1)%ci(jc) + if(c == a) cycle + clc = top%atclass(c) + do jd=top%conn(1)%ri(c), top%conn(1)%ri(c+1)-1 + d = top%conn(1)%ci(jd) + if(d == a .or. d == b) cycle + if(a > d) cycle + cld = top%atclass(d) + ! There is a dihedral A-B-C-D + do iprm=1, nt + if((classa(iprm) == cla .and. & + classb(iprm) == clb .and. & + classc(iprm) == clc .and. & + classd(iprm) == cld) .or. & + (classa(iprm) == cld .and. & + classb(iprm) == clc .and. & + classc(iprm) == clb .and. & + classd(iprm) == cla)) then + ! The parameter is ok + tmpat(:,it) = [a, b, c, d] + tmpprm(it) = iprm + it = it+1 + exit + end if + end do + end do + end do + end do + end do + + call angtor_init(bds, it-1) + do i=1, it-1 + bds%angtorat(:,i) = tmpat(:,i) + if(classa(tmpprm(i)) == top%atclass(bds%angtorat(1,i))) then + bds%angtork(:,i) = kat(:,tmpprm(i)) * kcalmol2au + else + bds%angtork(1:3,i) = kat(4:6,tmpprm(i)) * kcalmol2au + bds%angtork(4:6,i) = kat(1:3,tmpprm(i)) * kcalmol2au + end if + + tor_done = .false. + do j=1, size(bds%torsionat, 2) + if(all(bds%angtorat(:,i) == bds%torsionat(:,j))) then + tor_done = .true. + bds%angtor_t(i) = j + exit + end if + end do + + ang1_done = .false. + ang2_done = .false. + do j=1, size(bds%angleat, 2) + if(all(bds%angtorat(1:3,i) == bds%angleat(:,j)) .or. & + all(bds%angtorat(1:3,i) == bds%angleat(3:1:-1,j))) then + ang1_done = .true. + bds%angtor_a(1,i) = j + else if(all(bds%angtorat(2:4,i) == bds%angleat(:,j)) .or. & + all(bds%angtorat(2:4,i) == bds%angleat(3:1:-1,j))) then + ang2_done = .true. + bds%angtor_a(2,i) = j + end if + if(ang1_done .and. ang2_done) exit + end do + + if(.not. (tor_done .and. ang1_done .and. ang2_done)) then + call fatal_error('Ill defined angle-torsion coupling parameter') + end if + + end do + + call mfree('assign_angtor [classa]', classa) + call mfree('assign_angtor [classb]', classb) + call mfree('assign_angtor [classc]', classc) + call mfree('assign_angtor [classd]', classd) + call mfree('assign_angtor [kat]', kat) + call mfree('assign_angtor [tmpat]', tmpat) + call mfree('assign_angtor [tmpprm]', tmpprm) + + end subroutine assign_angtor + + subroutine assign_angle(bds, prm_buf, exclude_list, nexc_in) + use mod_memory, only: mallocate, mfree + use mod_bonded, only: OMMP_ANG_SIMPLE, & + OMMP_ANG_H0, & + OMMP_ANG_H1, & + OMMP_ANG_H2, & + OMMP_ANG_INPLANE, & + OMMP_ANG_INPLANE_H0, & + OMMP_ANG_INPLANE_H1 + use mod_bonded, only: angle_init + use mod_constants, only: kcalmol2au, rad2deg, deg2rad + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + !! Bonded potential data structure + character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) + !! Char buffer containing the prm file loaded in RAM + integer(ip), dimension(:), intent(in), optional :: exclude_list + !! List of atoms for which interactions should not be computed + integer(ip), intent(in), optional :: nexc_in + !! Number of atom in excluded list needed to skip a parameter + + integer(ip), parameter :: nexc_default = 3 + integer(ip) :: il, i, j, tokb, toke, iang, nang, & + cla, clb, clc, maxang, a, b, c, jc, jb, k, nhenv, & + iexc, nexc + character(len=OMMP_STR_CHAR_MAX) :: line, errstring + integer(ip), allocatable :: classa(:), classb(:), classc(:), angtype(:) + real(rp), allocatable :: kang(:), th0ang(:) + logical :: done + type(ommp_topology_type), pointer :: top + + top => bds%top + + nexc = nexc_default + if(present(exclude_list)) then + if(present(nexc_in)) then + if(nexc_in > 0 .and. nexc_in < 4) then + nexc = nexc_in + end if + end if + end if + + if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then + call read_atom_cards(top, prm_buf) + end if + + ! Read all the lines of file just to count how large vector should be + ! allocated + nang = 1 + do il=1, size(prm_buf) + line = prm_buf(il) + if(line(:6) == 'angle ') nang = nang + 3 + ! One angle keyourd could stand for 3 parameters for different H-env + if(line(:7) == 'anglep ') nang = nang + 2 + ! One angle keyourd could stand for 2 parameters for different H-env + end do + + maxang = (top%conn(2)%ri(top%mm_atoms+1)-1) / 2 + call mallocate('assign_angle [classa]', nang, classa) + call mallocate('assign_angle [classb]', nang, classb) + call mallocate('assign_angle [classc]', nang, classc) + call mallocate('assign_angle [eqang]', nang, th0ang) + call mallocate('assign_angle [kang]', nang, kang) + call mallocate('assign_angle [angtype]', nang, angtype) + call angle_init(bds, maxang) + + ! Restart the reading from the beginning to actually save the parameters + iang = 1 + i=1 + do il=1, size(prm_buf) + line = prm_buf(il) + + if(line(:12) == 'angle-cubic ') then + tokb = 13 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong ANGLE-CUBIC card " + call fatal_error(errstring) + end if + read(line(tokb:toke), *) bds%angle_cubic + bds%angle_cubic = bds%angle_cubic * rad2deg + + else if(line(:14) == 'angle-quartic ') then + tokb = 15 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong ANGLE-QUARTIC card " + call fatal_error(errstring) + end if + read(line(tokb:toke), *) bds%angle_quartic + bds%angle_quartic = bds%angle_quartic * rad2deg**2 + + else if(line(:13) == 'angle-pentic ') then + tokb = 13 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong ANGLE-PENTIC card " + call fatal_error(errstring) + end if + read(line(tokb:toke), *) bds%angle_pentic + bds%angle_pentic = bds%angle_pentic * rad2deg**3 + + else if(line(:13) == 'angle-sextic ') then + tokb = 14 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong ANGLE-SEXTIC card " + call fatal_error(errstring) + end if + read(line(tokb:toke), *) bds%angle_sextic + bds%angle_sextic = bds%angle_sextic * rad2deg**4 + + else if(line(:6) == 'angle ') then + tokb = 7 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong ANGLE card " + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classa(iang) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong ANGLE card " + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classb(iang) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong ANGLE card " + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classc(iang) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong ANGLE card " + call fatal_error(errstring) + end if + read(line(tokb:toke), *) kang(iang) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong ANGLE card " + call fatal_error(errstring) + end if + read(line(tokb:toke), *) th0ang(iang) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(toke < 0) then + ! Only one angle parameter is specified so it is good + ! for all the H-envirnoment + angtype(iang) = OMMP_ANG_SIMPLE + iang = iang + 1 + else + ! Three equilibrim angles are specified for three different + ! H-environment + angtype(iang) = OMMP_ANG_H0 + iang = iang + 1 + + classa(iang) = classa(iang-1) + classb(iang) = classb(iang-1) + classc(iang) = classc(iang-1) + kang(iang) = kang(iang-1) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong ANGLE card " + call fatal_error(errstring) + end if + read(line(tokb:toke), *) th0ang(iang) + angtype(iang) = OMMP_ANG_H1 + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(toke > 0) then + iang = iang + 1 + + classa(iang) = classa(iang-1) + classb(iang) = classb(iang-1) + classc(iang) = classc(iang-1) + kang(iang) = kang(iang-1) + angtype(iang) = OMMP_ANG_H2 + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong ANGLE card " + call fatal_error(errstring) + end if + read(line(tokb:toke), *) th0ang(iang) + end if + iang = iang + 1 + end if + + else if(line(:7) == 'anglep ') then + tokb = 8 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong ANGLEP card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classa(iang) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong ANGLEP card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classb(iang) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong ANGLEP card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classc(iang) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong ANGLEP card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) kang(iang) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong ANGLEP card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) th0ang(iang) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(toke < 0) then + ! Only one angle parameter is specified so it is good + ! for all the H-envirnoment + angtype(iang) = OMMP_ANG_INPLANE + iang = iang + 1 + else + ! Three equilibrim angles are specified for three different + ! H-environment + angtype(iang) = OMMP_ANG_INPLANE_H0 + iang = iang + 1 + + classa(iang) = classa(iang-1) + classb(iang) = classb(iang-1) + classc(iang) = classc(iang-1) + kang(iang) = kang(iang-1) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong ANGLEP card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) th0ang(iang) + angtype(iang) = OMMP_ANG_INPLANE_H1 + + iang = iang + 1 + end if + end if + i = i+1 + end do + nang = iang + + iang = 1 + do a=1, top%mm_atoms + cla = top%atclass(a) + do jb=top%conn(2)%ri(a), top%conn(2)%ri(a+1)-1 + b = top%conn(2)%ci(jb) + if(a > b) cycle + clb = top%atclass(b) + + do jc=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 + c = top%conn(1)%ci(jc) + if(all(top%conn(1)%ci(top%conn(1)%ri(b):top%conn(1)%ri(b+1)-1) /= c)) cycle + ! There is an angle in the form A-C-B + clc = top%atclass(c) + done = .false. + + do j=1, nang + if((cla == classa(j) & + .and. clb == classc(j) & + .and. clc == classb(j)) .or. & + (clb == classa(j) & + .and. cla == classc(j) & + .and. clc == classb(j))) then + + if(angtype(j) == OMMP_ANG_SIMPLE .or. & + angtype(j) == OMMP_ANG_INPLANE) then + ! For those types no check of the H + ! environment is required + done = .true. + exit + else + ! Check the H-environment + nhenv = 0 + do k=top%conn(1)%ri(c), top%conn(1)%ri(c+1)-1 + if(top%atz(top%conn(1)%ci(k)) == 1) & + nhenv = nhenv + 1 + end do + if(top%atz(a) == 1) nhenv = nhenv-1 + if(top%atz(b) == 1) nhenv = nhenv-1 + + if(nhenv == 0 .and. ( & + angtype(j) == OMMP_ANG_H0 .or. & + angtype(j) == OMMP_ANG_INPLANE_H0)) then + done = .true. + exit + else if(nhenv == 1 .and. ( & + angtype(j) == OMMP_ANG_H1 .or. & + angtype(j) == OMMP_ANG_INPLANE_H1)) then + done = .true. + exit + else if(nhenv == 2 .and. (& + angtype(j) == OMMP_ANG_H2)) then + done = .true. + exit + end if + end if + end if + end do + + if(present(exclude_list) .and. .not. done) then + iexc = 0 + if(any(exclude_list == a)) iexc = iexc + 1 + if(any(exclude_list == b)) iexc = iexc + 1 + if(any(exclude_list == c)) iexc = iexc + 1 + if(iexc >= nexc) then + write(errstring, '(A,I0,A,I0,A,I0,A,I0,A)') & + "Angle ", a, '-', b, '-', c, " not found & + &and ignored because ", iexc, " atoms are & + &in excluded list." + call ommp_message(errstring, OMMP_VERBOSE_HIGH) + done = .true. + end if + end if + + if(done) then + bds%angleat(1,iang) = a + bds%angleat(2,iang) = c + bds%angleat(3,iang) = b + bds%anglety(iang) = angtype(j) + bds%kangle(iang) = kang(j) * kcalmol2au + bds%eqangle(iang) = th0ang(j) * deg2rad + ! Find the auxiliary atom for inplane angles + if(bds%anglety(iang) == OMMP_ANG_INPLANE .or. & + bds%anglety(iang) == OMMP_ANG_INPLANE_H0 .or. & + bds%anglety(iang) == OMMP_ANG_INPLANE_H1) then + ! Find the auxiliary atom used to define the + ! projection plane + if(bds%top%conn(1)%ri(bds%angleat(2,iang)+1) - & + bds%top%conn(1)%ri(bds%angleat(2,iang)) /= 3) & + then + call ommp_message("Angle IN-PLANE defined for a & + &non-trigonal center, this is only & + &acceptable if link-atoms should be & + &defined later.", OMMP_VERBOSE_LOW) + bds%kangle(iang) = 0.0 + else + do j=bds%top%conn(1)%ri(bds%angleat(2,iang)), & + bds%top%conn(1)%ri(bds%angleat(2,iang)+1)-1 + if(bds%top%conn(1)%ci(j) /= bds%angleat(1,iang) .and. & + bds%top%conn(1)%ci(j) /= bds%angleat(3,iang)) then + bds%angauxat(iang) = bds%top%conn(1)%ci(j) + endif + end do + end if + end if + + iang = iang + 1 + else + write(errstring, *) "No angle parameter found for & + &atoms ", a, b, c + call fatal_error(errstring) + end if + end do + end do + end do + + call mfree('assign_angle [classa]', classa) + call mfree('assign_angle [classb]', classb) + call mfree('assign_angle [classc]', classc) + call mfree('assign_angle [eqang]', th0ang) + call mfree('assign_angle [kang]', kang) + call mfree('assign_angle [angtype]', angtype) + + end subroutine assign_angle + + subroutine assign_vdw(vdw, top, prm_buf) + use mod_memory, only: mallocate, mfree + use mod_io, only: fatal_error + use mod_nonbonded, only: ommp_nonbonded_type, vdw_init, vdw_set_pair + use mod_constants, only: angstrom2au, kcalmol2au, OMMP_DEFAULT_NL_CUTOFF + + implicit none + + type(ommp_nonbonded_type), intent(inout) :: vdw + !! Non-bonded structure to be initialized + type(ommp_topology_type), intent(inout) :: top + !! Topology structure + character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) + !! Char buffer containing the prm file loaded in RAM + + integer(ip) :: il, i, j, l, tokb, toke + character(len=OMMP_STR_CHAR_MAX) :: line, errstring + character(len=20) :: radrule, radsize, radtype, vdwtype, epsrule + integer(ip), allocatable :: vdwat(:), vdwpr_a(:), vdwpr_b(:) + real(rp), allocatable :: vdw_e_prm(:), vdw_r_prm(:), vdw_f_prm(:), & + vdwpr_r(:), vdwpr_e(:) + integer(ip) :: nvdw, ivdw, atc, nvdwpr, ivdwpr + logical :: done + logical(lp), allocatable :: maska(:), maskb(:) + + if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then + call read_atom_cards(top, prm_buf) + end if + + ! Read all the lines of file just to count how large vector should be + ! allocated + nvdw = 0 + nvdwpr = 0 + do il=1, size(prm_buf) + line = prm_buf(il) + if(line(:4) == 'vdw ') nvdw = nvdw + 1 + if(line(:6) == 'vdwpr ' .or. line(:8) == 'vdwpair ') & + nvdwpr = nvdwpr + 1 + end do + + ! VDW + call mallocate('read_prm [vdwat]', nvdw, vdwat) + call mallocate('read_prm [vdw_r_prm]', nvdw, vdw_r_prm) + call mallocate('read_prm [vdw_e_prm]', nvdw, vdw_e_prm) + call mallocate('read_prm [vdw_f_prm]', nvdw, vdw_f_prm) + vdw_f_prm = 1.0_rp + ivdw = 1 + + ! VDWPR + call mallocate('read_prm [vdwpr_a]', nvdwpr, vdwpr_a) + call mallocate('read_prm [vdwpr_b]', nvdwpr, vdwpr_b) + call mallocate('read_prm [vdwpr_e]', nvdwpr, vdwpr_e) + call mallocate('read_prm [vdwpr_r]', nvdwpr, vdwpr_r) + allocate(maska(top%mm_atoms), maskb(top%mm_atoms)) + ivdwpr = 1 + + ! Default rules for VDW (from Tinker Manual) + radrule = "arithmetic" + radsize = "radius" + radtype = "r-min" + vdwtype = "lennard-jones" + epsrule = "geometric" + ! Those are defaults defined in Tinker manual + vdw%vdw_screening = [0.0, 0.0, 1.0, 1.0] + + ! Restart the reading from the beginning to actually save the parameters + i=1 + do il=1, size(prm_buf) + line = prm_buf(il) + + if(line(:13) == 'vdw-12-scale ') then + tokb = 14 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong VDW-12-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) vdw%vdw_screening(1) + if(vdw%vdw_screening(1) > 1.0) & + vdw%vdw_screening(1) = 1/vdw%vdw_screening(1) + + else if(line(:13) == 'vdw-13-scale ') then + tokb = 14 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong VDW-13-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) vdw%vdw_screening(2) + if(vdw%vdw_screening(2) > 1.0) & + vdw%vdw_screening(2) = 1/vdw%vdw_screening(2) + + else if(line(:13) == 'vdw-14-scale ') then + tokb = 14 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong VDW-14-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) vdw%vdw_screening(3) + if(vdw%vdw_screening(3) > 1.0) & + vdw%vdw_screening(3) = 1/vdw%vdw_screening(3) + + else if(line(:13) == 'vdw-15-scale ') then + tokb = 14 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong VDW-15-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) vdw%vdw_screening(4) + if(vdw%vdw_screening(4) > 1.0) & + vdw%vdw_screening(4) = 1/vdw%vdw_screening(4) + + else if(line(:12) == 'epsilonrule ') then + tokb = 12 + toke = tokenize(line, tokb) + read(line(tokb:toke), *) epsrule + + else if(line(:8) == 'vdwtype ') then + tokb = 9 + toke = tokenize(line, tokb) + read(line(tokb:toke), *) vdwtype + + else if(line(:11) == 'radiusrule ') then + tokb = 12 + toke = tokenize(line, tokb) + read(line(tokb:toke), *) radrule + + else if(line(:11) == 'radiussize ') then + tokb = 12 + toke = tokenize(line, tokb) + read(line(tokb:toke), *) radsize + + else if(line(:11) == 'radiustype ') then + tokb = 12 + toke = tokenize(line, tokb) + read(line(tokb:toke), *) radtype + + else if(line(:4) == 'vdw ') then + tokb = 5 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong VDW card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) vdwat(ivdw) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong VDW card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) vdw_r_prm(ivdw) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong VDW card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) vdw_e_prm(ivdw) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(toke > 0) then + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong VDW card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) vdw_f_prm(ivdw) + endif + + ivdw = ivdw + 1 + else if(line(:6) == 'vdwpr ' .or. line(:8) == 'vdwpair ') then + if(line(:6) == 'vdwpr ') then + tokb = 7 + else + tokb = 9 + end if + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong VDWPR card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) vdwpr_a(ivdwpr) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong VDWPR card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) vdwpr_b(ivdwpr) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong VDWPR card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) vdwpr_r(ivdwpr) + + tokb = toke + 1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong VDWPR card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) vdwpr_e(ivdwpr) + + ivdwpr = ivdwpr + 1 + end if + i = i+1 + end do + + call vdw_init(vdw, top, vdwtype, radrule, radsize, & + radtype, epsrule, OMMP_DEFAULT_NL_CUTOFF) + + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,j,atc,done) + do i=1, top%mm_atoms + ! Atom class for current atom + atc = top%atclass(i) + + ! VdW parameters + done = .false. + do j=1, nvdw + if(vdwat(j) == atc) then + done = .true. + vdw%vdw_e(i) = vdw_e_prm(j) * kcalmol2au + vdw%vdw_r(i) = vdw_r_prm(j) * angstrom2au + vdw%vdw_f(i) = vdw_f_prm(j) + exit + end if + end do + if(.not. done) then + call fatal_error("VdW parameter not found!") + end if + end do + + ! VdW pair parameters + do l=1, nvdwpr + maska = (top%atclass == vdwpr_a(l)) + maskb = (top%atclass == vdwpr_b(l)) + call vdw_set_pair(vdw, maska, maskb, & + vdwpr_r(l) * angstrom2au, & + vdwpr_e(l) * kcalmol2au) + end do + + call mfree('read_prm [vdwat]', vdwat) + call mfree('read_prm [vdw_r_prm]', vdw_r_prm) + call mfree('read_prm [vdw_e_prm]', vdw_e_prm) + call mfree('read_prm [vdw_f_prm]', vdw_f_prm) + call mfree('read_prm [vdwpr_a]', vdwpr_a) + call mfree('read_prm [vdwpr_b]', vdwpr_b) + call mfree('read_prm [vdwpr_e]', vdwpr_e) + call mfree('read_prm [vdwpr_r]', vdwpr_r) + deallocate(maska, maskb) + + end subroutine assign_vdw + + subroutine assign_pol(eel, prm_buf) + use mod_memory, only: mallocate, mfree, ip, rp + use mod_electrostatics, only: set_screening_parameters + use mod_constants, only: angstrom2au + + implicit none + + type(ommp_electrostatics_type), intent(inout), target :: eel + !! Electrostatics data structure to be initialized + character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) + !! Char buffer containing the prm file loaded in RAM + + integer(ip) :: il, i, j, k, l, iat, tokb, toke, ipg + character(len=OMMP_STR_CHAR_MAX) :: line, errstring + + integer(ip), allocatable :: polat(:), pgspec(:,:) + real(rp), allocatable :: thf(:), isopol(:) + real(rp) :: usc(4), psc(4), pisc(4), dsc(4) + + integer(ip) :: npolarize, ipolarize + + type(ommp_topology_type), pointer :: top + + top => eel%top + + if(.not. top%attype_initialized) then + call fatal_error("Atom type array in topology should be initialized& + & before performing polarization asignament.") + end if + + ! Read all the lines of file just to count how large vector should be + ! allocated + npolarize = 0 + do il=1, size(prm_buf) + line = prm_buf(il) + if(line(:9) == 'polarize ') npolarize = npolarize + 1 + end do + + call mallocate('read_prm [polat]', npolarize, polat) + call mallocate('read_prm [isopol]', npolarize, isopol) + call mallocate('read_prm [thf]', npolarize, thf) + call mallocate('read_prm [pgspec]', 8, npolarize, pgspec) + pgspec = 0 + ipolarize = 1 + + ! Restart the reading from the beginning to actually save the parameters + i=1 + do il=1, size(prm_buf) + line = prm_buf(il) + + if(line(:13) == 'polarization ') then + tokb = 14 + toke = tokenize(line, tokb) + select case(line(tokb:toke)) + case('mutual') + continue + case('direct') + call fatal_error("Polarization DIRECT is not supported") + case default + call fatal_error("Wrong POLARIZATION card") + end select + + else if(line(:15) == 'polar-12-intra ') then + tokb = 16 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong POLAR-12-INTRA card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) pisc(1) + + else if(line(:15) == 'polar-13-intra ') then + tokb = 16 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong POLAR-13-INTRA card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) pisc(2) + + else if(line(:15) == 'polar-14-intra ') then + tokb = 16 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong POLAR-14-INTRA card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) pisc(3) + + else if(line(:15) == 'polar-15-intra ') then + tokb = 16 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong POLAR-15-INTRA card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) pisc(4) + + else if(line(:15) == 'polar-12-scale ') then + tokb = 16 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong POLAR-12-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) psc(1) + + else if(line(:15) == 'polar-13-scale ') then + tokb = 16 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong POLAR-13-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) psc(2) + + else if(line(:15) == 'polar-14-scale ') then + tokb = 16 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong POLAR-14-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) psc(3) + + else if(line(:15) == 'polar-15-scale ') then + tokb = 16 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong POLAR-15-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) psc(4) + + else if(line(:16) == 'direct-11-scale ') then + tokb = 17 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong DIRECT-11-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) dsc(1) + + else if(line(:16) == 'direct-12-scale ') then + tokb = 17 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong DIRECT-12-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) dsc(2) + + else if(line(:16) == 'direct-13-scale ') then + tokb = 17 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong DIRECT-13-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) dsc(3) + + else if(line(:16) == 'direct-14-scale ') then + tokb = 17 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong DIRECT-14-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) dsc(4) + + else if(line(:16) == 'mutual-11-scale ') then + tokb = 17 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong MUTUAL-11-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) usc(1) + else if(line(:16) == 'mutual-12-scale ') then + tokb = 17 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong MUTUAL-12-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) usc(2) + + else if(line(:16) == 'mutual-13-scale ') then + tokb = 17 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong MUTUAL-13-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) usc(3) + + else if(line(:16) == 'mutual-14-scale ') then + tokb = 17 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong MUTUAL-14-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) usc(4) + + else if(line(:9) == 'polarize ') then + tokb = 10 ! len of keyword + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong POLARIZE card" + call fatal_error(errstring) + endif + read(line(tokb:toke), *) polat(ipolarize) + if(polat(ipolarize) < 0) then + write(errstring, *) "Wrong POLARIZE card (specific atom not supported)" + call fatal_error(errstring) + end if + + ! Isotropic polarizability + tokb = toke+1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong POLARIZE card" + call fatal_error(errstring) + endif + read(line(tokb:toke), *) isopol(ipolarize) + + ! Thole dumping factor + tokb = toke+1 + toke = tokenize(line, tokb) + if(isint(line(tokb:toke))) then + ! If this card is skipped then it is HIPPO + write(errstring, *) "HIPPO FF is not currently supported" + call fatal_error(errstring) + else if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong POLARIZE card" + call fatal_error(errstring) + endif + read(line(tokb:toke), *) thf(ipolarize) + + ! Polarization group information + tokb = toke+1 + toke = tokenize(line, tokb) + if(isreal(line(tokb:toke)) .and. .not. isint(line(tokb:toke))) then + ! If there is an additional real modifier then it is AMOEBA+ + write(errstring, *) "AMOEBA+ FF is not currently supported" + call fatal_error(errstring) + end if + j = 1 + do while(toke > 0) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong POLARIZE card" + call fatal_error(errstring) + endif + read(line(tokb:toke), *) pgspec(j,ipolarize) + + tokb = toke+1 + toke = tokenize(line, tokb) + j = j + 1 + end do + ipolarize = ipolarize + 1 + end if + i = i+1 + end do + + if(eel%amoeba) then + call set_screening_parameters(eel, eel%mscale, psc, dsc, usc, pisc) + eel%mmat_polgrp = 0 + else + call set_screening_parameters(eel, eel%mscale, psc, dsc, usc) + end if + + ipg = 0 + ! Now assign the parameters to the atoms + do i=1, size(top%attype) + ! Polarization + do j=1, npolarize + if(polat(j) == top%attype(i)) then + eel%pol(i) = isopol(j) * angstrom2au**3 + !TODO Thole factors. + ! Assign a polgroup label to each atom + if(eel%mmat_polgrp(i) == 0) then + ipg = ipg+1 + eel%mmat_polgrp(i) = ipg + end if + + ! loop over the atoms connected to ith atom + do k=top%conn(1)%ri(i), top%conn(1)%ri(i+1)-1 + iat = top%conn(1)%ci(k) + if(any(top%attype(iat) == pgspec(:,j))) then + ! The two atoms are in the same group + if(eel%mmat_polgrp(iat) == 0) then + eel%mmat_polgrp(iat) = eel%mmat_polgrp(i) + else if(eel%mmat_polgrp(iat) /= eel%mmat_polgrp(i)) then + ! TODO This code have never been tested, as no + ! suitable case have been found + do l=1, top%mm_atoms + if(eel%mmat_polgrp(l) == 0) then + continue + else if(eel%mmat_polgrp(l) == eel%mmat_polgrp(iat) & + .or. eel%mmat_polgrp(l) == eel%mmat_polgrp(i)) then + eel%mmat_polgrp(l) = min(eel%mmat_polgrp(iat), eel%mmat_polgrp(i)) + else if(eel%mmat_polgrp(l) > max(eel%mmat_polgrp(iat),eel%mmat_polgrp(i))) then + eel%mmat_polgrp(l) = eel%mmat_polgrp(l) - 1 + else + continue + end if + end do + end if + end if + end do + end if + end do + end do + + call mfree('read_prm [polat]', polat) + call mfree('read_prm [isopol]', isopol) + call mfree('read_prm [thf]', thf) + call mfree('read_prm [pgspec]', pgspec) + + end subroutine assign_pol + + subroutine assign_mpoles(eel, prm_buf) + use mod_memory, only: mallocate, mfree + use mod_electrostatics, only: set_screening_parameters + use mod_constants, only: AMOEBA_ROT_NONE, & + AMOEBA_ROT_Z_THEN_X, & + AMOEBA_ROT_BISECTOR, & + AMOEBA_ROT_Z_ONLY, & + AMOEBA_ROT_Z_BISECT, & + AMOEBA_ROT_3_FOLD, & + eps_rp, & + OMMP_VERBOSE_DEBUG + + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel + !! The electrostatic object to be initialized + character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) + !! Char buffer containing the prm file loaded in RAM + + integer(ip) :: il, i, j, k, iat, tokb, toke + character(len=OMMP_STR_CHAR_MAX) :: line, errstring + integer(ip), allocatable :: multat(:), multax(:,:), multframe(:) + real(rp), allocatable :: cmult(:,:) + real(rp) :: msc(4), csc(4) + real(rp) :: eel_au2kcalmol, eel_scale + real(rp) :: default_eel_au2kcalmol = 332.063713 + ! Default conversion from A.U. to kcal/mol used in electrostatics of + ! Tinker, only used to handle electric keyword + integer(ip) :: nmult, nchg, imult, iax(3) + logical :: ax_found(3), found13, only12, done + type(ommp_topology_type), pointer :: top + + top => eel%top + + if(.not. top%attype_initialized) then + call fatal_error("Atom type array in topology should be initialized& + & before performing multipoles asignament.") + end if + + ! Read all the lines of file just to count how large vector should be + ! allocated + nmult = 0 + nchg = 0 + do il=1, size(prm_buf) + line = prm_buf(il) + if(line(:11) == 'multipole ') nmult = nmult + 1 + if(line(:7) == 'charge ') nchg = nchg + 1 + end do + + ! MULTIPOLE + call mallocate('read_prm [multat]', nmult+nchg, multat) + call mallocate('read_prm [multframe]', nmult+nchg, multframe) + call mallocate('read_prm [multax]', 3, nmult+nchg, multax) + call mallocate('read_prm [cmult]', 10, nmult+nchg, cmult) + multax = AMOEBA_ROT_NONE + imult = 1 + + ! Default values from Tinker manual + msc = [0.0, 0.0, 1.0, 1.0] + csc = [0.0, 0.0, 1.0, 1.0] + eel_scale = 1.0 + + ! Restart the reading from the beginning to actually save the parameters + do il=1, size(prm_buf) + line = prm_buf(il) + + if(line(:13) == 'chg-12-scale ') then + tokb = 14 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong CHG-12-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) csc(1) + if(csc(1) > 1.0) csc(1) = 1/csc(1) + + else if(line(:13) == 'chg-13-scale ') then + tokb = 14 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong CHG-13-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) csc(2) + if(csc(2) > 1.0) csc(2) = 1/csc(2) + + else if(line(:13) == 'chg-14-scale ') then + tokb = 14 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong CHG-14-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) csc(3) + if(csc(3) > 1.0) csc(3) = 1/csc(3) + + else if(line(:13) == 'chg-15-scale ') then + tokb = 14 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong CHG-15-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) csc(4) + if(csc(4) > 1.0) csc(4) = 1/csc(4) + + else if(line(:15) == 'mpole-12-scale ') then + tokb = 16 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong MPOLE-12-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) msc(1) + if(msc(1) > 1.0) msc(1) = 1/msc(1) + + else if(line(:15) == 'mpole-13-scale ') then + tokb = 16 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong MPOLE-13-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) msc(2) + if(msc(2) > 1.0) msc(2) = 1/msc(2) + + else if(line(:15) == 'mpole-14-scale ') then + tokb = 16 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong MPOLE-14-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) msc(3) + if(msc(3) > 1.0) msc(3) = 1/msc(3) + + else if(line(:15) == 'mpole-15-scale ') then + tokb = 16 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong MPOLE-15-SCALE card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) msc(4) + if(msc(4) > 1.0) msc(4) = 1/msc(4) + + else if(line(:9) == 'electric ') then + tokb = 10 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong ELECTRIC card" + call fatal_error(errstring) + end if + ! This keyword is used to change the conversion from A.U. to + ! kcal/mol for the electrostatic interaction. + ! It is a bit creepy and unclear what it's correct to do here, + ! I think that best thing is to scale the electrostatic itself + ! by a factor (electric/default_electric) ** 0.5 + read(line(tokb:toke), *) eel_au2kcalmol + eel_scale = (eel_au2kcalmol/default_eel_au2kcalmol) ** 0.5 + + else if(line(:7) == 'charge ') then + tokb = 8 ! len of keyword + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong CHARGE card" + call fatal_error(errstring) + endif + read(line(tokb:toke), *) multat(imult) + if(multat(imult) < 0) then + write(errstring, *) "Wrong CHARGE card (specific atom not supported)" + call fatal_error(errstring) + end if + ! Rotation axis information, charge does not contain any + multax(:,imult) = 0 + multframe(imult) = AMOEBA_ROT_NONE + + tokb = toke+1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong CHARGE card" + call fatal_error(errstring) + end if + + read(line(tokb:toke), *) cmult(1, imult) + cmult(2:10, imult) = 0.0 ! Fixed dipole and quadrupole are not present + imult = imult + 1 + + else if(line(:11) == 'multipole ') then + tokb = 12 ! len of keyword + 1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong MULTIPOLE card" + call fatal_error(errstring) + endif + read(line(tokb:toke), *) multat(imult) + if(multat(imult) < 0) then + write(errstring, *) "Wrong MULTIPOLE card (specific atom not supported)" + call fatal_error(errstring) + end if + + ! Rotation axis information + tokb = toke+1 + toke = tokenize(line, tokb, 1) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong MULTIPOLE card at least two & + &integers for axys specification expected." + call fatal_error(errstring) + end if + read(line(tokb:toke), *) multax(1,imult) + + tokb = toke+1 + toke = tokenize(line, tokb, 1) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong MULTIPOLE card at least two & + &integers for axys specification expected." + call fatal_error(errstring) + end if + read(line(tokb:toke), *) multax(2,imult) + + ! For some centers also y axis is specified (integer) otherwise + ! this is the zeroth-order multipole (charge) + tokb = toke+1 + toke = tokenize(line, tokb) + if(isint(line(tokb:toke))) then + ! Read the y axis + read(line(tokb:toke), *) multax(3,imult) + ! Get another token, this should be the charge. + tokb = toke+1 + toke = tokenize(line, tokb) + end if + + ! The type of rotation is encoded in the sign/nullness of + ! of the axis specification + if(multax(1,imult) == 0) then + multframe(imult) = AMOEBA_ROT_NONE + else if(multax(2, imult) == 0) then + multframe(imult) = AMOEBA_ROT_Z_ONLY + else if(multax(1,imult) < 0 .and. multax(2,imult) < 0 & + .and. multax(3,imult) < 0) then + multframe(imult) = AMOEBA_ROT_3_FOLD + else if(multax(1,imult) < 0 .or. multax(2,imult) < 0) then + multframe(imult) = AMOEBA_ROT_BISECTOR + else if(multax(2,imult) < 0 .and. multax(3,imult) < 0) then + multframe(imult) = AMOEBA_ROT_Z_BISECT + else + multframe(imult) = AMOEBA_ROT_Z_THEN_X + end if + ! Remove the encoded information after saving it in a reasonable + ! way + multax(:,imult) = abs(multax(:,imult)) + + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong MULTIPOLE card" + call fatal_error(errstring) + end if + + read(line(tokb:toke), *) cmult(1, imult) + + read(prm_buf(il+1), *) cmult(2:4, imult) + read(prm_buf(il+2), *) cmult(5, imult) + read(prm_buf(il+3), *) cmult(6:7, imult) + read(prm_buf(il+4), *) cmult(8:10, imult) + !il = il+4 + + imult = imult + 1 + end if + end do + + if(nmult > 0 .and. nchg == 0) then + call set_screening_parameters(eel, msc, eel%pscale, eel%dscale, & + eel%uscale, eel%pscale_intra) + else if(nmult == 0 .and. nchg > 0) then + call set_screening_parameters(eel, csc, eel%pscale, eel%dscale, & + eel%uscale) + else if(nmult > 0 .and. nchg > 0) then + write(errstring, *) "Unexpected FF with both multipoles and charges" + call fatal_error(errstring) + end if + + + !$omp parallel do default(shared) schedule(dynamic) & + !$omp private(i,only12,j,found13,ax_found,iax,iat,done) + do i=1, size(top%attype) + if(eel%amoeba) then + eel%mol_frame(i) = 0 + eel%ix(i) = 0 + eel%iy(i) = 0 + eel%iz(i) = 0 + eel%q0(:,i) = 0.0 + end if + eel%q(:,i) = 0.0 + + ! Flag to check assignament + done = .false. + + ! Multipoles + only12 = .false. ! Only search for params based on 12 connectivity + do j=1, max(nmult, nchg) + found13 = .false. ! Parameter found is based on 13 connectivity + if(multat(j) == top%attype(i)) then + ! For each center different multipoles are defined for + ! different environment. So first check if the environment + ! is the correct one + + ! Assignament with only 1,2-neighbours. + ax_found = .false. + iax = 0_ip + + if(multframe(j) == AMOEBA_ROT_NONE) then + ! No axis needed + ax_found = .true. + else if(multframe(j) == AMOEBA_ROT_Z_ONLY) then + ! Assignament with only-z + ax_found(2:3) = .true. + do k=top%conn(1)%ri(i), top%conn(1)%ri(i+1)-1 + iat = top%conn(1)%ci(k) + if(top%attype(iat) == multax(1,j) & + .and. .not. ax_found(1)) then + ax_found(1) = .true. + iax(1) = iat + end if + end do + else + ! 2 or 3 axis needed + if(multax(3,j) == 0) ax_found(3) = .true. + + ! Using only 1,2 connectivity + do k=top%conn(1)%ri(i), top%conn(1)%ri(i+1)-1 + iat = top%conn(1)%ci(k) + if(top%attype(iat) == multax(1,j) & + .and. .not. ax_found(1)) then + ax_found(1) = .true. + iax(1) = iat + else if(top%attype(iat) == multax(2,j) & + .and. .not. ax_found(2)) then + ax_found(2) = .true. + iax(2) = iat + else if(top%attype(iat) == multax(3,j) & + .and. .not. ax_found(3)) then + ax_found(3) = .true. + iax(3) = iat + end if + end do + + ! Using also 1,3 connectivity + if(ax_found(1) .and. .not. ax_found(2)) then + do k=top%conn(1)%ri(iax(1)), top%conn(1)%ri(iax(1)+1)-1 + iat = top%conn(1)%ci(k) + if(iat == i .or. iat == iax(1)) cycle + if(top%attype(iat) == multax(2,j) & + .and. .not. ax_found(2) & + .and. iat /= iax(1)) then + ax_found(2) = .true. + iax(2) = iat + else if(top%attype(iat) == multax(3,j) & + .and. .not. ax_found(3) & + .and. iat /= iax(1) & + .and. iat /= iax(2)) then + ax_found(3) = .true. + iax(3) = iat + end if + end do + if(all(ax_found)) found13 = .true. + end if + end if + + ! Everything is done, no further improvement is possible + if(all(ax_found) .and. .not. (only12 .and. found13)) then + if(eel%amoeba) then + eel%ix(i) = iax(2) + eel%iy(i) = iax(3) + eel%iz(i) = iax(1) + eel%mol_frame(i) = multframe(j) + eel%q(:,i) = cmult(:,j) + else + eel%q(1,i) = cmult(1,j) + end if + if(.not. done) then + done = .true. + else + write(errstring, "(A, I0)") & + "Reassigning multipoles for atom ", i + call ommp_message(errstring, OMMP_VERBOSE_DEBUG) + end if + + write(errstring, "(A, I0, A, I0, A, I0, A, I0, A, I0, A)") & + "Atom ", i, " is assigned multipole set ", j, & + " axes [ ", iax(2), "-", iax(3), "-", iax(1), " ]" + call ommp_message(errstring, OMMP_VERBOSE_DEBUG) + + + if(.not. found13) then + exit ! No further improvement is possible + else + only12 = .true. + end if + end if + end if + end do + if(.not. done) then + write(errstring, "(A, I0)") & + "No multipoles parameter found for atom ", i + call ommp_message(errstring, OMMP_VERBOSE_LOW) + call ommp_message("Previous error is only acceptable & + &if link atom is used to fix those & + ¶meter later on", OMMP_VERBOSE_LOW) + end if + end do + + if(abs(eel_scale - 1.0) > eps_rp) then + write(errstring, '(A, F10.6)') "Scaling charges by", eel_scale + call ommp_message(errstring, OMMP_VERBOSE_LOW) + eel%q = eel%q * eel_scale + end if + + call mfree('read_prm [multat]', multat) + call mfree('read_prm [multframe]', multframe) + call mfree('read_prm [multax]', multax) + call mfree('read_prm [cmult]', cmult) + + end subroutine assign_mpoles + + subroutine assign_tortors(bds, prm_buf) + use mod_memory, only: mallocate, mfree + use mod_bonded, only: tortor_newmap, tortor_init + use mod_constants, only: deg2rad, kcalmol2au + + implicit none + + type(ommp_bonded_type), intent(inout) :: bds + !! Bonded potential data structure + character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) + !! Char buffer containing the prm file loaded in RAM + + integer(ip) :: il, i, j, tokb, toke, iprm, jd, je, e, d, cle,it,cld,& + cla, clb, clc, a, b, c, jc, jb, itt, ndata, ntt, ibeg, iend, maxtt + character(len=OMMP_STR_CHAR_MAX) :: line, errstring + integer(ip), allocatable :: classx(:,:), map_dimension(:,:), tmpat(:,:), tmpprm(:), savedmap(:) + real(rp), allocatable :: data_map(:), ang_map(:,:) + type(ommp_topology_type), pointer :: top + + top => bds%top + + if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then + call read_atom_cards(top, prm_buf) + end if + + ! Read all the lines of file just to count how large vector should be + ! allocated + ntt = 0 + do il=1, size(prm_buf) + line = prm_buf(il) + if(line(:8) == 'tortors ') ntt = ntt + 1 + end do + + maxtt = top%conn(4)%ri(top%mm_atoms+1)-1 + call mallocate('assign_tortors [classx]', 5, ntt, classx) + call mallocate('assign_tortors [map_dimension]', 2, ntt, map_dimension) + call mallocate('assign_tortors [savedmap]', ntt, savedmap) + call mallocate('assign_tortors [tmpat]', 5, maxtt, tmpat) + call mallocate('assign_tortors [tmpprm]', maxtt, tmpprm) + + ! Restart the reading from the beginning to actually save the parameters + itt = 1 + i=1 + do il=1, size(prm_buf) + line = prm_buf(il) + + if(line(:8) == 'tortors ') then + tokb = 9 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong TORTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classx(1,itt) + + tokb = toke+1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong TORTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classx(2,itt) + + tokb = toke+1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong TORTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classx(3,itt) + + tokb = toke+1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong TORTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classx(4,itt) + + tokb = toke+1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong TORTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) classx(5,itt) + + tokb = toke+1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong TORTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) map_dimension(1,itt) + + tokb = toke+1 + toke = tokenize(line, tokb) + if(.not. isint(line(tokb:toke))) then + write(errstring, *) "Wrong TORTORS card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) map_dimension(2,itt) + + itt = itt + 1 + end if + i = i+1 + end do + + ! Allocate data space and finally read the map + ndata = dot_product(map_dimension(1,:), map_dimension(2,:)) + call mallocate('assign_tortors [data_map]', ndata, data_map) + call mallocate('assign_tortors [ang_map]', 2, ndata, ang_map) + + itt = 1 + i=1 + do il=1, size(prm_buf) + line = prm_buf(il) + + if(line(:8) == 'tortors ') then + ndata = map_dimension(1,itt)*map_dimension(2,itt) + do j=1, ndata + line = prm_buf(il+j) + + tokb = tokenize(line) + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong TORTORS data card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) ang_map(1, i) + + tokb = toke+1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong TORTORS data card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) ang_map(2, i) + + tokb = toke+1 + toke = tokenize(line, tokb) + if(.not. isreal(line(tokb:toke))) then + write(errstring, *) "Wrong TORTORS data card" + call fatal_error(errstring) + end if + read(line(tokb:toke), *) data_map(i) + i = i + 1 + end do + itt = itt + 1 + end if + end do + + it = 1 + do a=1, top%mm_atoms + cla = top%atclass(a) + do jb=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 + b = top%conn(1)%ci(jb) + clb = top%atclass(b) + do jc=top%conn(1)%ri(b), top%conn(1)%ri(b+1)-1 + c = top%conn(1)%ci(jc) + if(c == a) cycle + clc = top%atclass(c) + do jd=top%conn(1)%ri(c), top%conn(1)%ri(c+1)-1 + d = top%conn(1)%ci(jd) + if(d == a .or. d == b) cycle + cld = top%atclass(d) + do je=top%conn(1)%ri(d), top%conn(1)%ri(d+1)-1 + e = top%conn(1)%ci(je) + if(e == a .or. e == b .or. e == c) cycle + if(a > e) cycle + cle = top%atclass(e) + ! There is a dihedral pair A-B-C-D-E + do iprm=1, ntt + if((classx(1,iprm) == cla .and. & + classx(2,iprm) == clb .and. & + classx(3,iprm) == clc .and. & + classx(4,iprm) == cld .and. & + classx(5,iprm) == cle) .or. & + (classx(1,iprm) == cle .and. & + classx(2,iprm) == cld .and. & + classx(3,iprm) == clc .and. & + classx(4,iprm) == clb .and. & + classx(5,iprm) == cla)) then + ! The parameter is ok + tmpat(:,it) = [a, b, c, d, e] + tmpprm(it) = iprm + it = it+1 + exit + end if + end do + end do + end do + end do + end do + end do + + call tortor_init(bds, it-1) + savedmap = -1 + iprm = 1 + do i=1, it-1 + if(savedmap(tmpprm(i)) < 0) then + ! If needed, save the map in the module + ibeg = 1 + do j=1, tmpprm(i)-1 + ibeg = ibeg + map_dimension(1,j)*map_dimension(2,j) + end do + iend = ibeg + map_dimension(1,tmpprm(i))*map_dimension(2,tmpprm(i)) - 1 + call tortor_newmap(bds, map_dimension(1,tmpprm(i)), & + map_dimension(2,tmpprm(i)), & + ang_map(1,ibeg:iend) * deg2rad, & + ang_map(2,ibeg:iend) * deg2rad, & + data_map(ibeg:iend) * kcalmol2au) + savedmap(tmpprm(i)) = iprm + iprm = iprm + 1 + end if + + bds%tortorat(:,i) = tmpat(:,i) + bds%tortorprm(i) = savedmap(tmpprm(i)) + end do + + call mfree('assign_tortors [classx]', classx) + call mfree('assign_tortors [map_dimension]', map_dimension) + call mfree('assign_tortors [savedmap]', savedmap) + call mfree('assign_tortors [data_map]', data_map) + call mfree('assign_tortors [ang_map]', ang_map) + call mfree('assign_tortors [tmpat]', tmpat) + call mfree('assign_tortors [tmpprm]', tmpprm) + + end subroutine assign_tortors + +end module mod_prm diff --git a/src/mod_prm.f90 b/src/mod_prm.f90 deleted file mode 100644 index 471b240..0000000 --- a/src/mod_prm.f90 +++ /dev/null @@ -1,3623 +0,0 @@ -module mod_prm - !! This module handles the reading of a parameter file in .prm format and - !! the asignament of parameters based on atom type and connectivity. - - use mod_memory, only: ip, rp, lp - use mod_io, only: fatal_error, ommp_message - use mod_topology, only: ommp_topology_type - use mod_bonded, only: ommp_bonded_type - use mod_electrostatics, only: ommp_electrostatics_type - use mod_constants, only: OMMP_STR_CHAR_MAX, OMMP_VERBOSE_LOW, & - OMMP_VERBOSE_HIGH - use mod_utils, only: isreal, isint, tokenize, count_substr_occurence, & - str_to_lower, str_uncomment - - implicit none - private - - - !!public :: assign_vdw, assign_pol, assign_mpoles, assign_bond, & - !! assign_angle, assign_urey, assign_strbnd, assign_opb, & - !! assign_pitors, assign_torsion, assign_tortors, & - !! assign_angtor, assign_strtor, terminate_prm - public :: assign_pol, assign_mpoles - public :: assign_vdw - public :: assign_bond, assign_angle, assign_urey, assign_strbnd, assign_opb - public :: assign_pitors, assign_torsion, assign_tortors, assign_angtor - public :: assign_strtor, assign_imptorsion - public :: check_keyword, get_prm_ff_type - - contains - -#include "prm_keywords.f90" - - function get_prm_ff_type(prm_buf) result(ff_type) - !! This function is intended to check if the ff described by prm_type - !! is AMOEBA (or amoeba-like) or AMBER or FF of another kind. - !! A FF is considered to be AMOEBA if: it contains multipole keywords - !! (and no charge keywords) and polarization MUTUAL. - !! A FF is considered do be AMBER if contains charge keyword and no - !! multipole keyword. - use mod_constants, only: OMMP_FF_AMBER, & - OMMP_FF_AMOEBA, & - OMMP_FF_UNKNOWN - use mod_io, only: fatal_error - - implicit none - - character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) - !! Char buffer containing the prm file loaded in RAM - - integer(ip) :: il, nmultipole, ncharge, tokb, toke, ff_type - character(len=OMMP_STR_CHAR_MAX) :: line, polarization - - ! Read all the lines of file just to count how large vector should be - ! allocated - nmultipole = 0 - ncharge = 0 - do il=1, size(prm_buf) - line = prm_buf(il) - if(line(:7) == 'charge ') ncharge = ncharge + 1 - if(line(:10) == 'multipole ') nmultipole = nmultipole + 1 - if(line(:13) == 'polarization ') then - tokb = 13 - toke = tokenize(line, tokb) - read(line(tokb:toke), '(A)') polarization - end if - end do - - if(nmultipole > 0 .and. & - ncharge == 0 .and. & - polarization(:6) == 'mutual') then - ff_type = OMMP_FF_AMOEBA - else if(nmultipole == 0 .and. & - ncharge > 0) then - ff_type = OMMP_FF_AMBER - else - ff_type = OMMP_FF_UNKNOWN - end if - end function - - subroutine read_atom_cards(top, prm_buf) - use mod_memory, only: mallocate, mfree - use mod_io, only: fatal_error - - implicit none - - type(ommp_topology_type), intent(inout) :: top - !! Topology object - character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) - - integer(ip) :: i, il, lc, iat, toke, tokb, tokb1, nquote - character(len=OMMP_STR_CHAR_MAX) :: line, errstring - integer(ip) :: natype - integer(ip), allocatable, dimension(:) :: typez, typeclass - real(rp), allocatable, dimension(:) :: typemass - - - if(.not. top%attype_initialized) then - call fatal_error("Atom type array in topology should be initialized& - & before performing atomclass asignament.") - end if - - ! Read all the lines of file just to count how large vector should be - ! allocated - natype = 0 - do il=1, size(prm_buf) - line = prm_buf(il) - if(line(:5) == 'atom ') then - tokb = 6 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong ATOM card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) iat - natype = max(natype, iat) - end if - end do - - call mallocate('read_prm [typeclass]', natype, typeclass) - call mallocate('read_prm [typez]', natype, typez) - call mallocate('read_prm [typemass]', natype, typemass) - typeclass = 0 - typez = 0 - typemass = 0.0 - - ! Restart the reading from the beginning to actually save the parameters - do il=1, size(prm_buf) - line = prm_buf(il) - - if(line(:5) == 'atom ') then - tokb = 6 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong ATOM card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) iat - - tokb = toke+1 - toke = tokenize(line, tokb) - read(line(tokb:toke), *) typeclass(iat) - - tokb = toke+1 - toke = tokenize(line, tokb) - ! This token contain the atom name - - tokb = toke+1 - toke = tokenize(line, tokb) - nquote = count_substr_occurence(line(tokb:toke), '"') - do while(nquote < 2) - tokb1 = toke+1 - toke = tokenize(line, tokb1) - nquote = nquote + count_substr_occurence(line(tokb1:toke), '"') - end do - ! This token contains the description string - tokb = toke+1 - toke = tokenize(line, tokb) - read(line(tokb:toke), *) typez(iat) - - tokb = toke+1 - toke = tokenize(line, tokb) - read(line(tokb:toke), *) typemass(iat) - - ! Only partial reading of ATOM card is needed for now. - end if - end do - - !$omp parallel do - do i = 1, top%mm_atoms - if(.not. top%atclass_initialized) then - top%atclass(i) = typeclass(top%attype(i)) - end if - - if(.not. top%atz_initialized) then - top%atz(i) = typez(top%attype(i)) - end if - - if(.not. top%atmass_initialized) then - top%atmass(i) = typemass(top%attype(i)) - end if - end do - - top%atclass_initialized = .true. - top%atz_initialized = .true. - top%atmass_initialized = .true. - - call mfree('read_prm [typeclass]', typeclass) - call mfree('read_prm [typez]', typez) - call mfree('read_prm [typemass]', typemass) - - end subroutine read_atom_cards - - subroutine assign_bond(bds, prm_buf, exclude_list, nexc_in) - use mod_memory, only: mallocate, mfree - use mod_io, only: fatal_error - use mod_bonded, only: bond_init, ommp_bonded_type - use mod_constants, only: angstrom2au, kcalmol2au - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - !! Bonded potential data structure - character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) - integer(ip), dimension(:), intent(in), optional :: exclude_list - !! List of atoms for which interactions should not be computed - integer(ip), intent(in), optional :: nexc_in - !! Number of atom in excluded list needed to skip a parameter - - integer(ip), parameter :: nexc_default = 2 - integer(ip) :: il, i, j, l, jat, tokb, toke, ibnd, nbnd, & - cla, clb, nexc, iexc - character(len=OMMP_STR_CHAR_MAX) :: line, errstring - integer(ip), allocatable :: classa(:), classb(:) - real(rp), allocatable :: kbnd(:), l0bnd(:) - logical :: done - type(ommp_topology_type), pointer :: top - - top => bds%top - - nexc = nexc_default - if(present(exclude_list)) then - if(present(nexc_in)) then - if(nexc_in > 0 .and. nexc_in < 4) then - nexc = nexc_in - end if - end if - end if - - if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then - call read_atom_cards(top, prm_buf) - end if - - ! We assume that all pair of bonded atoms have a bonded - ! parameter - call bond_init(bds, (top%conn(1)%ri(top%mm_atoms+1)-1) / 2) - !! If there are no bonds in the system just return, there - !! is nothing to do. - if(.not. bds%use_bond) return - - bds%kbond = 0 - bds%l0bond = 0 - - l=1 - do i=1, top%mm_atoms - do j=top%conn(1)%ri(i), top%conn(1)%ri(i+1)-1 - jat = top%conn(1)%ci(j) - if(i < jat) then - bds%bondat(1,l) = i - bds%bondat(2,l) = jat - l = l+1 - end if - end do - end do - - ! Read all the lines of file just to count how large vector should be - ! allocated - nbnd = 0 - do il=1, size(prm_buf) - line = prm_buf(il) - if(line(:5) == 'bond ') nbnd = nbnd + 1 - end do - - call mallocate('assign_bond [classa]', nbnd, classa) - call mallocate('assign_bond [classb]', nbnd, classb) - call mallocate('assign_bond [l0bnd]', nbnd, l0bnd) - call mallocate('assign_bond [kbnd]', nbnd, kbnd) - - ! Restart the reading from the beginning to actually save the parameters - ibnd = 1 - i=1 - do il=1, size(prm_buf) - line = prm_buf(il) - - if(line(:11) == 'bond-cubic ') then - tokb = 12 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong BOND-CUBIC card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) bds%bond_cubic - ! This parameter is 1/Angstrom - bds%bond_cubic = bds%bond_cubic / angstrom2au - - else if(line(:13) == 'bond-quartic ') then - tokb = 14 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong BOND-QUARTIC card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) bds%bond_quartic - bds%bond_quartic = bds%bond_quartic / (angstrom2au**2) - - else if(line(:5) == 'bond ') then - tokb = 6 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong BOND card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classa(ibnd) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong BOND card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classb(ibnd) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong BOND card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) kbnd(ibnd) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong BOND card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) l0bnd(ibnd) - - ibnd = ibnd + 1 - end if - i = i+1 - end do - - do i=1, size(bds%bondat,2) - ! Atom class for current pair - cla = top%atclass(bds%bondat(1,i)) - clb = top%atclass(bds%bondat(2,i)) - - done = .false. - do j=1, nbnd - if((classa(j)==cla .and. classb(j)==clb) .or. & - (classa(j)==clb .and. classb(j)==cla)) then - done = .true. - bds%kbond(i) = kbnd(j) * kcalmol2au / (angstrom2au**2) - bds%l0bond(i) = l0bnd(j) * angstrom2au - exit - end if - end do - - if(present(exclude_list) .and. .not. done) then - iexc = 0 - if(any(exclude_list == bds%bondat(1,i))) iexc = iexc + 1 - if(any(exclude_list == bds%bondat(2,i))) iexc = iexc + 1 - if(iexc >= nexc) then - done = .true. - write(errstring, '(A,I0,A,I0,A,I0,A)') & - "Bond ", bds%bondat(1,i), '-', bds%bondat(2,i), & - " not found and ignored because ", iexc, " atoms are & - &in excluded list." - call ommp_message(errstring, OMMP_VERBOSE_HIGH) - end if - end if - - if(.not. done) then - call fatal_error("Bond parameter not found!") - end if - end do - - call mfree('assign_bond [classa]', classa) - call mfree('assign_bond [classb]', classb) - call mfree('assign_bond [l0bnd]', l0bnd) - call mfree('assign_bond [kbnd]', kbnd) - - end subroutine assign_bond - - subroutine assign_urey(bds, prm_buf) - use mod_memory, only: mallocate, mfree - use mod_bonded, only: urey_init - use mod_constants, only: angstrom2au, kcalmol2au - - implicit none - - - type(ommp_bonded_type), intent(inout) :: bds - !! Bonded potential data structure - character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) - - integer(ip) :: il, i, j, tokb, toke, iub, nub, & - cla, clb, clc, maxub, a, b, c, jc, jb - character(len=OMMP_STR_CHAR_MAX) :: line, errstring - integer(ip), allocatable :: classa(:), classb(:), classc(:), ubtmp(:) - real(rp), allocatable :: kub(:), l0ub(:) - logical :: done - type(ommp_topology_type), pointer :: top - - top => bds%top - - if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then - call read_atom_cards(top, prm_buf) - end if - - ! Read all the lines of file just to count how large vector should be - ! allocated - nub = 0 - do il=1, size(prm_buf) - line = prm_buf(il) - if(line(:9) == 'ureybrad ') nub = nub + 1 - end do - - maxub = top%conn(2)%ri(top%mm_atoms+1)-1 - ! Maximum number of UB terms (each angle have an UB term) - call mallocate('assign_urey [classa]', nub, classa) - call mallocate('assign_urey [classb]', nub, classb) - call mallocate('assign_urey [classc]', nub, classc) - call mallocate('assign_urey [l0ub]', nub, l0ub) - call mallocate('assign_urey [kub]', nub, kub) - call mallocate('assign_urey [ubtmp]', maxub, ubtmp) - - ! Restart the reading from the beginning to actually save the parameters - iub = 1 - i=1 - do il=1, size(prm_buf) - line = prm_buf(il) - - if(line(:11) == 'urey-cubic ') then - tokb = 12 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong UREY-CUBIC card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) bds%urey_cubic - ! This parameter is 1/Angstrom - bds%urey_cubic = bds%urey_cubic / angstrom2au - - else if(line(:13) == 'urey-quartic ') then - tokb = 14 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong UREY-QUARTIC card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) bds%urey_quartic - bds%urey_quartic = bds%urey_quartic / (angstrom2au**2) - - else if(line(:9) == 'ureybrad ') then - tokb = 10 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong UREYBRAD card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classa(iub) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong UREYBRAD card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classb(iub) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong UREYBRAD card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classc(iub) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong UREYBRAD card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) kub(iub) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong UREYBRAD card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) l0ub(iub) - - iub = iub + 1 - end if - i = i+1 - end do - - ubtmp = -1 - do a=1, top%mm_atoms - cla = top%atclass(a) - do jb=top%conn(2)%ri(a), top%conn(2)%ri(a+1)-1 - b = top%conn(2)%ci(jb) - done = .false. - if(a > b) cycle - clb = top%atclass(b) - - do jc=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 - c = top%conn(1)%ci(jc) - if(all(top%conn(1)%ci(top%conn(1)%ri(b): & - top%conn(1)%ri(b+1)-1) /= c)) cycle - ! There is an angle in the form A-C-B - clc = top%atclass(c) - do j=1, nub - if((cla == classa(j) & - .and. clb == classc(j) & - .and. clc == classb(j)) .or. & - (clb == classa(j) & - .and. cla == classc(j) & - .and. clc == classb(j))) then - - ubtmp(jb) = j - ! Temporary assignament in a sparse matrix logic - done = .true. - exit - end if - end do - - if(done) exit - ! If we have already found a parameter for A-B pair, stop - ! the research - end do - end do - end do - - call urey_init(bds, count(ubtmp > 0)) - iub = 1 - do a=1, top%mm_atoms - do jb=top%conn(2)%ri(a), top%conn(2)%ri(a+1)-1 - if(ubtmp(jb) > 0) then - bds%ureyat(1,iub) = a - bds%ureyat(2,iub) = top%conn(2)%ci(jb) - bds%kurey(iub) = kub(ubtmp(jb)) * kcalmol2au / (angstrom2au**2) - bds%l0urey(iub) = l0ub(ubtmp(jb)) * angstrom2au - iub = iub + 1 - end if - end do - end do - - call mfree('assign_urey [classa]', classa) - call mfree('assign_urey [classb]', classb) - call mfree('assign_urey [classc]', classc) - call mfree('assign_urey [l0ub]', l0ub) - call mfree('assign_urey [kub]', kub) - call mfree('assign_urey [ubtmp]', ubtmp) - - end subroutine assign_urey - - subroutine assign_strbnd(bds, prm_buf) - use mod_memory, only: mallocate, mfree - use mod_bonded, only: strbnd_init - use mod_constants, only: kcalmol2au, angstrom2au - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - !! Bonded potential data structure - character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) - !! Char buffer containing the prm file loaded in RAM - - integer(ip) :: il, i, j, tokb, toke, isb, nstrbnd, & - cla, clb, clc, a, b, c, jc, jb, maxsb, & - l1a, l1b, l2a, l2b - character(len=OMMP_STR_CHAR_MAX) :: line, errstring - integer(ip), allocatable :: classa(:), classb(:), classc(:), sbtmp(:), & - sbattmp(:, :), at2bnd(:), at2ang(:) - real(rp), allocatable :: k1(:), k2(:) - logical :: done, thet_done, l1_done, l2_done - type(ommp_topology_type), pointer :: top - - top => bds%top - - if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then - call read_atom_cards(top, prm_buf) - end if - - ! Read all the lines of file just to count how large vector should be - ! allocated - nstrbnd = 0 - do il=1, size(prm_buf) - line = prm_buf(il) - if(line(:7) == 'strbnd ') nstrbnd = nstrbnd + 1 - end do - - maxsb = (top%conn(2)%ri(top%mm_atoms+1)-1) / 2 - call mallocate('assign_strbnd [classa]', nstrbnd, classa) - call mallocate('assign_strbnd [classb]', nstrbnd, classb) - call mallocate('assign_strbnd [classc]', nstrbnd, classc) - call mallocate('assign_strbnd [eqang]', nstrbnd, k1) - call mallocate('assign_strbnd [kang]', nstrbnd, k2) - call mallocate('assign_strbnd [sbtmp]', maxsb, sbtmp) - call mallocate('assign_strbnd [sbattmp]', 3, maxsb, sbattmp) - call mallocate('assign_strbnd [at2bnd]', top%mm_atoms, at2bnd) - call mallocate('assign_strbnd [at2ang]', top%mm_atoms, at2ang) - - ! Restart the reading from the beginning to actually save the parameters - isb = 1 - i=1 - do il=1, size(prm_buf) - line = prm_buf(il) - - if(line(:7) == 'strbnd ') then - tokb = 8 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong STRBND card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classa(isb) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong STRBND card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classb(isb) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong STRBND card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classc(isb) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong STRBND card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) k1(isb) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong STRBND card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) k2(isb) - - isb = isb + 1 - end if - i = i+1 - end do - - isb = 1 - do a=1, top%mm_atoms - cla = top%atclass(a) - do jb=top%conn(2)%ri(a), top%conn(2)%ri(a+1)-1 - b = top%conn(2)%ci(jb) - if(a > b) cycle - clb = top%atclass(b) - - do jc=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 - c = top%conn(1)%ci(jc) - if(all(top%conn(1)%ci(top%conn(1)%ri(b):& - top%conn(1)%ri(b+1)-1) /= c)) cycle - ! There is an angle in the form A-C-B - clc = top%atclass(c) - done = .false. - - do j=1, nstrbnd - if((cla == classa(j) & - .and. clb == classc(j) & - .and. clc == classb(j)) .or. & - (clb == classa(j) & - .and. cla == classc(j) & - .and. clc == classb(j))) then - sbattmp(1,isb) = a - sbattmp(2,isb) = c - sbattmp(3,isb) = b - if(cla == classa(j)) then - ! Assign the correct k to each bond stretching! - sbtmp(isb) = j - else - sbtmp(isb) = -j - end if - isb = isb + 1 - exit - end if - end do - end do - end do - end do - - call strbnd_init(bds, isb-1) - if(isb-1 < 1) then - !! No parameters are defined, nothing to do. - return - end if - - at2bnd(1) = 1 - do i=1, top%mm_atoms-1 - at2bnd(i+1) = at2bnd(i) - do j=top%conn(1)%ri(i), top%conn(1)%ri(i+1)-1 - if(i < top%conn(1)%ci(j)) then - at2bnd(i+1) = at2bnd(i+1) + 1 - end if - end do - end do - - at2ang = 0 - do j=1, size(bds%angleat, 2) - if(at2ang(bds%angleat(1,j)) == 0) at2ang(bds%angleat(1,j)) = j - end do - - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,l1a,l1b,l2a,l2b,l1_done,l2_done,thet_done) - do i=1, isb-1 - ! First assign the parameters - bds%strbndat(:,i) = sbattmp(:,i) - j = abs(sbtmp(i)) - if(sbtmp(i) > 0) then - bds%strbndk1(i) = k1(j) * kcalmol2au / angstrom2au - bds%strbndk2(i) = k2(j) * kcalmol2au / angstrom2au - else - bds%strbndk1(i) = k2(j) * kcalmol2au / angstrom2au - bds%strbndk2(i) = k1(j) * kcalmol2au / angstrom2au - end if - - l1a = min(bds%strbndat(1,i), bds%strbndat(2,i)) - l1b = max(bds%strbndat(1,i), bds%strbndat(2,i)) - l2a = min(bds%strbndat(3,i), bds%strbndat(2,i)) - l2b = max(bds%strbndat(3,i), bds%strbndat(2,i)) - - ! Now search for the corresponding bond and angle parameters to - ! set the equilibrium distances and angle - l1_done = .false. - l2_done = .false. - thet_done = .false. - - do j=at2bnd(l1a), size(bds%bondat, 2) - if(l1a == bds%bondat(1,j) .and. l1b == bds%bondat(2,j)) then - l1_done = .true. - bds%strbndl10(i) = bds%l0bond(j) - exit - end if - end do - - do j=at2bnd(l2a), size(bds%bondat, 2) - if(l2a == bds%bondat(1,j) .and. l2b == bds%bondat(2,j)) then - l2_done = .true. - bds%strbndl20(i) = bds%l0bond(j) - exit - end if - end do - - do j=at2ang(bds%strbndat(1,i)), size(bds%angleat, 2) - if(all(bds%strbndat(:,i) == bds%angleat(:,j))) then - thet_done = .true. - bds%strbndthet0(i) = bds%eqangle(j) - exit - end if - end do - - if(.not.(l1_done .and. l2_done .and. thet_done)) then - call fatal_error("Ill-defined stretch-bending cross term") - end if - end do - - call mfree('assign_strbnd [classa]', classa) - call mfree('assign_strbnd [classb]', classb) - call mfree('assign_strbnd [classc]', classc) - call mfree('assign_strbnd [eqang]', k1) - call mfree('assign_strbnd [kang]', k2) - call mfree('assign_strbnd [sbtmp]', sbtmp) - call mfree('assign_strbnd [sbattmp]', sbattmp) - call mfree('assign_strbnd [at2bnd]', at2bnd) - call mfree('assign_strbnd [at2ang]', at2ang) - - end subroutine assign_strbnd - - subroutine assign_opb(bds, prm_buf) - use mod_memory, only: mallocate, mfree - use mod_bonded, only: opb_init - - use mod_constants, only: kcalmol2au, rad2deg - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - !! Bonded potential data structure - character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) - - integer(ip) :: il, i, tokb, toke, iopb, nopb, & - cla, clb, clc, cld, maxopb, a, b, c, d, jc, jb, iprm - character(len=OMMP_STR_CHAR_MAX) :: line, errstring, opb_type - integer(ip), allocatable :: classa(:), classb(:), classc(:), & - classd(:), tmpat(:,:) - real(rp), allocatable :: kopbend(:), tmpk(:) - type(ommp_topology_type), pointer :: top - - top => bds%top - - if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then - call read_atom_cards(top, prm_buf) - end if - - ! Tinker manual default - opb_type = "w-d-c" - - ! Read all the lines of file just to count how large vector should be - ! allocated - nopb = 0 - do il=1, size(prm_buf) - line = prm_buf(il) - if(line(:7) == 'opbend ') nopb = nopb + 1 - end do - - - if(nopb == 0) then - ! If there are no OPB terms, just stop here. - return - end if - maxopb = top%mm_atoms*3 - call mallocate('assign_opb [classa]', nopb, classa) - call mallocate('assign_opb [classb]', nopb, classb) - call mallocate('assign_opb [classc]', nopb, classc) - call mallocate('assign_opb [classd]', nopb, classd) - call mallocate('assign_opb [kopbend]', nopb, kopbend) - call mallocate('assign_opb [tmpat]', 4, maxopb, tmpat) - call mallocate('assign_opb [tmpk]', maxopb, tmpk) - - ! Restart the reading from the beginning to actually save the parameters - iopb = 1 - i=1 - do il=1, size(prm_buf) - line = prm_buf(il) - - if(line(:11) == 'opbendtype ') then - tokb = 12 - toke = tokenize(line, tokb) - read(line(tokb:toke), *) opb_type - - else if(line(:13) == 'opbend-cubic ') then - tokb = 14 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong OPBEND-CUBIC card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) bds%opb_cubic - bds%opb_cubic = bds%opb_cubic * rad2deg - - else if(line(:15) == 'opbend-quartic ') then - tokb = 16 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong OPBEND-QUARTIC card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) bds%opb_quartic - bds%opb_quartic = bds%opb_quartic * rad2deg**2 - - else if(line(:14) == 'opbend-pentic ') then - tokb = 15 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong OPBEND-PENTIC card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) bds%opb_pentic - bds%opb_pentic = bds%opb_pentic * rad2deg**3 - - else if(line(:14) == 'opbend-sextic ') then - tokb = 15 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong OPBEND-SEXTIC card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) bds%opb_sextic - bds%opb_sextic = bds%opb_sextic * rad2deg**4 - - else if(line(:7) == 'opbend ') then - tokb = 8 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong OPBEND card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classa(iopb) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong OPBEND card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classb(iopb) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong OPBEND card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classc(iopb) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong OPBEND card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classd(iopb) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong OPBEND card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) kopbend(iopb) - - iopb = iopb + 1 - end if - i = i+1 - end do - - iopb = 1 - do a=1, top%mm_atoms - ! Check if the center is trigonal - if(top%conn(1)%ri(a+1) - top%conn(1)%ri(a) /= 3) cycle - cla = top%atclass(a) - ! Loop over the atoms connected to the trignonal center - do jb=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 - b = top%conn(1)%ci(jb) - clb = top%atclass(b) - - c = -1 - d = -1 - clc = 0 - cld = 0 - do jc=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 - if(top%conn(1)%ci(jc) == b) cycle - if(c < 0) then - c = top%conn(1)%ci(jc) - clc = top%atclass(c) - else if(d < 0) then - d = top%conn(1)%ci(jc) - cld = top%atclass(d) - end if - end do - - do iprm=1, nopb - if((classa(iprm) == clb) .and. & - (classb(iprm) == cla) .and. & - ((classc(iprm) == clc .and. & - classd(iprm) == cld) .or. & - (classd(iprm) == clc .and. & - classc(iprm) == cld) .or. & - (classd(iprm) == 0 .and. & - (classc(iprm) == cld .or. classc(iprm) == clc)) .or. & - (classc(iprm) == 0 .and. & - (classd(iprm) == cld .or. classd(iprm) == clc)) .or. & - (classc(iprm) == 0 .or. classd(iprm) == 0))) then - ! The parameter is ok - tmpat(1,iopb) = a - tmpat(2,iopb) = b - tmpat(3,iopb) = c - tmpat(4,iopb) = d - tmpk(iopb) = kopbend(iprm) - iopb = iopb + 1 - exit - endif - end do - end do - end do - - call opb_init(bds, iopb-1, trim(opb_type)) - - do i=1, iopb-1 - bds%kopb(i) = tmpk(i) * kcalmol2au - bds%opbat(:,i) = tmpat(:,i) - end do - - call mfree('assign_opb [classa]', classa) - call mfree('assign_opb [classb]', classb) - call mfree('assign_opb [classc]', classc) - call mfree('assign_opb [classd]', classd) - call mfree('assign_opb [kopbend]', kopbend) - call mfree('assign_opb [tmpat]', tmpat) - call mfree('assign_opb [tmpk]', tmpk) - - end subroutine assign_opb - - subroutine assign_pitors(bds, prm_buf) - use mod_memory, only: mallocate, mfree - use mod_bonded, only: pitors_init - use mod_constants, only: kcalmol2au - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - !! Bonded potential data structure - character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) - - integer(ip) :: il, i, tokb, toke, ipitors, npitors, & - cla, clb, maxpi, a, b, c, jb, iprm - character(len=OMMP_STR_CHAR_MAX) :: line, errstring - integer(ip), allocatable :: classa(:), classb(:), tmpat(:,:) - real(rp), allocatable :: kpi(:), tmpk(:) - type(ommp_topology_type), pointer :: top - - top => bds%top - - if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then - call read_atom_cards(top, prm_buf) - end if - - ! Read all the lines of file just to count how large vector should be - ! allocated - npitors = 1 - do il=1, size(prm_buf) - line = prm_buf(il) - if(line(:7) == 'pitors ') npitors = npitors + 1 - end do - - maxpi = top%mm_atoms - ! TODO This is maybe excessive, all trivalent atomso should be enough - call mallocate('assign_pitors [classa]', npitors, classa) - call mallocate('assign_pitors [classb]', npitors, classb) - call mallocate('assign_pitors [kpi]', npitors, kpi) - call mallocate('assign_pitors [tmpat]', 6, maxpi, tmpat) - call mallocate('assign_pitors [tmpk]', maxpi, tmpk) - - ! Restart the reading from the beginning to actually save the parameters - ipitors = 1 - i=1 - do il=1, size(prm_buf) - line = prm_buf(il) - - if(line(:7) == 'pitors ') then - tokb = 8 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong PITORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classa(ipitors) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong PITORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classb(ipitors) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong PITORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) kpi(ipitors) - - ipitors = ipitors + 1 - end if - i = i+1 - end do - - ipitors = 1 - do a=1, top%mm_atoms - ! Check if the center is trigonal - if(top%conn(1)%ri(a+1) - top%conn(1)%ri(a) /= 3) cycle - cla = top%atclass(a) - ! Loop over the atoms connected to the trignonal center - do jb=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 - b = top%conn(1)%ci(jb) - ! This avoid to compute the functions two times - if(a > b) cycle - - !Check if the second center is trigonal - if(top%conn(1)%ri(b+1) - top%conn(1)%ri(b) /= 3) cycle - clb = top%atclass(b) - - do iprm=1, npitors - if((cla == classa(iprm) .and. clb == classb(iprm)) .or. & - (clb == classa(iprm) .and. cla == classb(iprm))) then - ! The parameter is the right one - ! Save the atoms in the following way: - ! - ! 2 5 a => 1 - ! \ / b => 4 - ! 1 -- 4 - ! / \ - ! 3 6 - - tmpat(:,ipitors) = 0 - tmpat(1,ipitors) = a - do i=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 - c = top%conn(1)%ci(i) - if(c /= b) then - if(tmpat(2,ipitors) == 0) then - tmpat(2,ipitors) = c - else - tmpat(3,ipitors) = c - end if - end if - end do - - tmpat(4,ipitors) = b - do i=top%conn(1)%ri(b), top%conn(1)%ri(b+1)-1 - c = top%conn(1)%ci(i) - if(c /= a) then - if(tmpat(5,ipitors) == 0) then - tmpat(5,ipitors) = c - else - tmpat(6,ipitors) = c - end if - end if - end do - tmpk(ipitors) = kpi(iprm) - - ipitors = ipitors+1 - exit - end if - end do - end do - end do - - call pitors_init(bds, ipitors-1) - - do i=1, ipitors-1 - bds%kpitors(i) = tmpk(i) * kcalmol2au - bds%pitorsat(:,i) = tmpat(:,i) - end do - - call mfree('assign_pitors [classa]', classa) - call mfree('assign_pitors [classb]', classb) - call mfree('assign_pitors [kpi]', kpi) - call mfree('assign_pitors [tmpat]', tmpat) - call mfree('assign_pitors [tmpk]', tmpk) - - end subroutine assign_pitors - - subroutine assign_torsion(bds, prm_buf) - use mod_memory, only: mallocate, mfree - use mod_bonded, only: torsion_init - use mod_constants, only: kcalmol2au, deg2rad, eps_rp - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - !! Bonded potential data structure - character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) - - integer(ip) :: il, i, j, tokb, toke, it, nt, & - cla, clb, clc, cld, maxt, a, b, c, d, jb, jc, jd, iprm, ji, period - character(len=OMMP_STR_CHAR_MAX) :: line, errstring - integer(ip), allocatable :: classa(:), classb(:), classc(:), classd(:), & - t_n(:,:), tmpat(:,:), tmpprm(:), tmpbuf(:,:) - real(rp), allocatable :: t_amp(:,:), t_pha(:,:) - real(rp) :: amp, phase, torsion_unit = 1.0 - type(ommp_topology_type), pointer :: top - - top => bds%top - - if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then - call read_atom_cards(top, prm_buf) - end if - - ! Read all the lines of file just to count how large vector should be - ! allocated - nt = 1 - do il=1, size(prm_buf) - line = prm_buf(il) - if(line(:8) == 'torsion ') nt = nt + 1 - end do - - maxt = top%conn(3)%ri(top%mm_atoms+1)-1 - call mallocate('assign_torsion [classa]', nt, classa) - call mallocate('assign_torsion [classb]', nt, classb) - call mallocate('assign_torsion [classc]', nt, classc) - call mallocate('assign_torsion [classd]', nt, classd) - call mallocate('assign_torsion [t_amp]', 6, nt, t_amp) - call mallocate('assign_torsion [t_pha]', 6, nt, t_pha) - call mallocate('assign_torsion [t_n]', 6, nt, t_n) - call mallocate('assign_torsion [tmpat]', 4, maxt, tmpat) - call mallocate('assign_torsion [tmpprm]', maxt, tmpprm) - t_amp = 0.0 - t_pha = 0.0 - t_n = 1 - ! Restart the reading from the beginning to actually save the parameters - it = 1 - i=1 - do il=1, size(prm_buf) - line = prm_buf(il) - - if(line(:12) == 'torsionunit ') then - tokb = 13 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong TORSIONUNIT card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) torsion_unit - - else if(line(:8) == 'torsion ') then - tokb = 9 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong TORSION card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classa(it) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong TORSION card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classb(it) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong TORSION card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classc(it) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong TORSION card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classd(it) - - ji = 1 - t_n(:,it) = -1 - do j=1, 6 - tokb = toke + 1 - toke = tokenize(line, tokb) - if(toke < 0) exit - - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong TORSION card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) amp - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong TORSION card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) phase - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong TORSION card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) period - - if(abs(amp) > eps_rp) then - t_amp(ji, it) = amp - t_pha(ji, it) = phase - t_n(ji, it) = period - ji = ji + 1 - end if - end do - - if(j == 1) then - ! No parameter found - write(errstring, *) "Wrong TORSION card" - call fatal_error(errstring) - end if - - it = it + 1 - end if - i = i+1 - end do - - it = 1 - do a=1, top%mm_atoms - cla = top%atclass(a) - do jb=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 - b = top%conn(1)%ci(jb) - clb = top%atclass(b) - do jc=top%conn(1)%ri(b), top%conn(1)%ri(b+1)-1 - c = top%conn(1)%ci(jc) - if(c == a) cycle - clc = top%atclass(c) - do jd=top%conn(1)%ri(c), top%conn(1)%ri(c+1)-1 - d = top%conn(1)%ci(jd) - if(d == a .or. d == b) cycle - if(a > d) cycle - cld = top%atclass(d) - ! There is a dihedral A-B-C-D - do iprm=1, nt - if((classa(iprm) == cla .and. & - classb(iprm) == clb .and. & - classc(iprm) == clc .and. & - classd(iprm) == cld) .or. & - (classa(iprm) == cld .and. & - classb(iprm) == clc .and. & - classc(iprm) == clb .and. & - classd(iprm) == cla)) then - ! The parameter is ok - - ! Extrem check to avoid memory errors. - if(it > maxt) then - call mallocate('assign_torsion [tmpbuf]', 4, maxt, tmpbuf) - tmpbuf(:,:) = tmpat(:,:) - call mfree('assign_torsion [tmpat]', tmpat) - call mallocate('assign_torsion [tmpat]', 4, maxt+maxt+1, tmpat) - tmpat(:,1:maxt) = tmpbuf(:,:) - call mfree('assign_torsion [tmpbuf]', tmpbuf) - - call mallocate('assign_torsion [tmpbuf]', 1, maxt, tmpbuf) - tmpbuf(1,:) = tmpprm(:) - call mfree('assign_torsion [tmpprm]', tmpprm) - call mallocate('assign_torsion [tmpprm]', maxt+maxt+1, tmpprm) - tmpprm(1:maxt) = tmpbuf(1,:) - call mfree('assign_torsion [tmpbuf]', tmpbuf) - - maxt = 2*maxt + 1 - end if - - tmpat(:,it) = [a, b, c, d] - tmpprm(it) = iprm - it = it+1 - exit - end if - end do - end do - end do - end do - end do - - call torsion_init(bds, it-1) - do i=1, it-1 - bds%torsionat(:,i) = tmpat(:,i) - bds%torsamp(:,i) = t_amp(:,tmpprm(i)) * kcalmol2au * torsion_unit - bds%torsphase(:,i) = t_pha(:,tmpprm(i)) * deg2rad - bds%torsn(:,i) = t_n(:,tmpprm(i)) - end do - - call mfree('assign_torsion [classa]', classa) - call mfree('assign_torsion [classb]', classb) - call mfree('assign_torsion [classc]', classc) - call mfree('assign_torsion [classd]', classd) - call mfree('assign_torsion [t_amp]', t_amp) - call mfree('assign_torsion [t_pha]', t_pha) - call mfree('assign_torsion [t_n]', t_n) - call mfree('assign_torsion [tmpat]', tmpat) - call mfree('assign_torsion [tmpprm]', tmpprm) - - end subroutine assign_torsion - - subroutine assign_imptorsion(bds, prm_buf) - use mod_memory, only: mallocate, mfree - use mod_bonded, only: imptorsion_init - use mod_constants, only: kcalmol2au, deg2rad, eps_rp - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - !! Bonded potential data structure - character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) - - integer(ip) :: il, i, j, tokb, toke, it, nt, & - cla, clb, clc, cld, maxt, a, b, c, d, jb, jc, jd, iprm, ji, period - character(len=OMMP_STR_CHAR_MAX) :: line, errstring - integer(ip), allocatable :: classa(:), classb(:), classc(:), classd(:), & - t_n(:,:), tmpat(:,:), tmpprm(:) - real(rp), allocatable :: t_amp(:,:), t_pha(:,:) - real(rp) :: amp, phase, imptorsion_unit = 1.0 - type(ommp_topology_type), pointer :: top - - top => bds%top - - if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then - call read_atom_cards(top, prm_buf) - end if - - ! Read all the lines of file just to count how large vector should be - ! allocated - nt = 1 - do il=1, size(prm_buf) - line = prm_buf(il) - if(line(:8) == 'imptors ') nt = nt + 1 - end do - - maxt = top%conn(4)%ri(top%mm_atoms+1)-1 - call mallocate('assign_imptorsion [classa]', nt, classa) - call mallocate('assign_imptorsion [classb]', nt, classb) - call mallocate('assign_imptorsion [classc]', nt, classc) - call mallocate('assign_imptorsion [classd]', nt, classd) - call mallocate('assign_imptorsion [t_amp]', 3, nt, t_amp) - call mallocate('assign_imptorsion [t_pha]', 3, nt, t_pha) - call mallocate('assign_imptorsion [t_n]', 3, nt, t_n) - call mallocate('assign_imptorsion [tmpat]', 4, maxt, tmpat) - call mallocate('assign_imptorsion [tmpprm]', maxt, tmpprm) - t_amp = 0.0 - t_pha = 0.0 - t_n = 1 - ! Restart the reading from the beginning to actually save the parameters - it = 1 - i=1 - do il=1, size(prm_buf) - line = prm_buf(il) - - if(line(:12) == 'imptorsunit ') then - tokb = 13 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong IMPTORSUNIT card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) imptorsion_unit - - else if(line(:8) == 'imptors ') then - tokb = 9 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong IMPTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classa(it) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong IMPTROS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classb(it) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong IMPTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classc(it) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong IMPTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classd(it) - - ji = 1 - t_n(:,it) = -1 - do j=1, 3 - tokb = toke + 1 - toke = tokenize(line, tokb) - if(toke < 0) exit - - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong IMPTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) amp - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong IMPTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) phase - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong IMPTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) period - - if(abs(amp) > eps_rp) then - t_amp(ji, it) = amp - t_pha(ji, it) = phase - t_n(ji, it) = period - ji = ji + 1 - end if - end do - - if(j == 1) then - ! No parameter found - write(errstring, *) "Wrong IMPTORS card" - call fatal_error(errstring) - end if - - it = it + 1 - end if - i = i+1 - end do - - it = 1 - tmpat = 0 - - do a=1, top%mm_atoms - ! Check if the center is trigonal - if(top%conn(1)%ri(a+1) - top%conn(1)%ri(a) /= 3) cycle - cla = top%atclass(a) - - jb=top%conn(1)%ri(a) - b = top%conn(1)%ci(jb) - clb = top%atclass(b) - - jc=top%conn(1)%ri(a)+1 - c = top%conn(1)%ci(jc) - clc = top%atclass(c) - - jd=top%conn(1)%ri(a)+2 - d = top%conn(1)%ci(jd) - cld = top%atclass(d) - - do iprm=1, nt - if((classc(iprm) == cla)) then - if(clb == classa(iprm) .and. & - clc == classb(iprm) .and. & - cld == classd(iprm)) then - tmpat(1,it) = b - tmpat(2,it) = c - tmpat(3,it) = a - tmpat(4,it) = d - tmpprm(it) = iprm - it = it + 1 - end if - if(clb == classa(iprm) .and. & - cld == classb(iprm) .and. & - clc == classd(iprm)) then - tmpat(1,it) = b - tmpat(2,it) = d - tmpat(3,it) = a - tmpat(4,it) = c - tmpprm(it) = iprm - it = it + 1 - end if - if(clc == classa(iprm) .and. & - clb == classb(iprm) .and. & - cld == classd(iprm)) then - tmpat(1,it) = c - tmpat(2,it) = b - tmpat(3,it) = a - tmpat(4,it) = d - tmpprm(it) = iprm - it = it + 1 - end if - if(clc == classa(iprm) .and. & - cld == classb(iprm) .and. & - clb == classd(iprm)) then - tmpat(1,it) = c - tmpat(2,it) = d - tmpat(3,it) = a - tmpat(4,it) = b - tmpprm(it) = iprm - it = it + 1 - end if - if(cld == classa(iprm) .and. & - clb == classb(iprm) .and. & - clc == classd(iprm)) then - tmpat(1,it) = d - tmpat(2,it) = b - tmpat(3,it) = a - tmpat(4,it) = c - tmpprm(it) = iprm - it = it + 1 - end if - if(cld == classa(iprm) .and. & - clc == classb(iprm) .and. & - clb == classd(iprm)) then - tmpat(1,it) = d - tmpat(2,it) = c - tmpat(3,it) = a - tmpat(4,it) = b - tmpprm(it) = iprm - it = it + 1 - end if - endif - end do - end do - - call imptorsion_init(bds, it-1) - do i=1, it-1 - bds%imptorsionat(:,i) = tmpat(:,i) - bds%imptorsamp(:,i) = t_amp(:,tmpprm(i)) * kcalmol2au * imptorsion_unit - ! If more than one parameter is used for the same trigonal center, - ! then do an average - bds%imptorsamp(:,i) = bds%imptorsamp(:,i) / count(tmpat(3,1:it-1) == tmpat(3,i)) - bds%imptorsphase(:,i) = t_pha(:,tmpprm(i)) * deg2rad - bds%imptorsn(:,i) = t_n(:,tmpprm(i)) - end do - - call mfree('assign_imptorsion [classa]', classa) - call mfree('assign_imptorsion [classb]', classb) - call mfree('assign_imptorsion [classc]', classc) - call mfree('assign_imptorsion [classd]', classd) - call mfree('assign_imptorsion [t_amp]', t_amp) - call mfree('assign_imptorsion [t_pha]', t_pha) - call mfree('assign_imptorsion [t_n]', t_n) - call mfree('assign_imptorsion [tmpat]', tmpat) - call mfree('assign_imptorsion [tmpprm]', tmpprm) - - end subroutine assign_imptorsion - - subroutine assign_strtor(bds, prm_buf) - use mod_memory, only: mallocate, mfree - use mod_bonded, only: strtor_init - use mod_constants, only: kcalmol2au, angstrom2au - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - !! Bonded potential data structure - character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) - - integer(ip) :: il, i, j, tokb, toke, it, nt, & - cla, clb, clc, cld, maxt, a, b, c, d, jb, jc, jd, iprm - character(len=OMMP_STR_CHAR_MAX) :: line, errstring - integer(ip), allocatable :: classa(:), classb(:), classc(:), classd(:), & - tmpat(:,:), tmpprm(:) - real(rp), allocatable :: kat(:,:) - logical :: tor_done, bnd1_done, bnd2_done, bnd3_done - type(ommp_topology_type), pointer :: top - - top => bds%top - - if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then - call read_atom_cards(top, prm_buf) - end if - - - ! Read all the lines of file just to count how large vector should be - ! allocated - nt = 1 - do il=1, size(prm_buf) - line = prm_buf(il) - if(line(:8) == 'strtors ') nt = nt + 1 - end do - - maxt = top%conn(4)%ri(top%mm_atoms+1)-1 - call mallocate('assign_strtor [classa]', nt, classa) - call mallocate('assign_strtor [classb]', nt, classb) - call mallocate('assign_strtor [classc]', nt, classc) - call mallocate('assign_strtor [classd]', nt, classd) - call mallocate('assign_strtor [kat]', 9, nt, kat) - call mallocate('assign_strtor [tmpat]', 4, maxt, tmpat) - call mallocate('assign_strtor [tmpprm]', maxt, tmpprm) - - ! Restart the reading from the beginning to actually save the parameters - it = 1 - i=1 - do il=1, size(prm_buf) - line = prm_buf(il) - - if(line(:8) == 'strtors ') then - tokb = 9 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong STRTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classa(it) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong STRTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classb(it) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong STRTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classc(it) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong STRTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classd(it) - - do j=1, 9 - tokb = toke + 1 - toke = tokenize(line, tokb) - - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong STRTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) kat(j,it) - end do - - it = it + 1 - end if - i = i+1 - end do - - it = 1 - do a=1, top%mm_atoms - cla = top%atclass(a) - do jb=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 - b = top%conn(1)%ci(jb) - clb = top%atclass(b) - do jc=top%conn(1)%ri(b), top%conn(1)%ri(b+1)-1 - c = top%conn(1)%ci(jc) - if(c == a) cycle - clc = top%atclass(c) - do jd=top%conn(1)%ri(c), top%conn(1)%ri(c+1)-1 - d = top%conn(1)%ci(jd) - if(d == a .or. d == b) cycle - if(a > d) cycle - cld = top%atclass(d) - ! There is a dihedral A-B-C-D - do iprm=1, nt - if((classa(iprm) == cla .and. & - classb(iprm) == clb .and. & - classc(iprm) == clc .and. & - classd(iprm) == cld) .or. & - (classa(iprm) == cld .and. & - classb(iprm) == clc .and. & - classc(iprm) == clb .and. & - classd(iprm) == cla)) then - ! The parameter is ok - tmpat(:,it) = [a, b, c, d] - tmpprm(it) = iprm - it = it+1 - exit - end if - end do - end do - end do - end do - end do - - call strtor_init(bds, it-1) - do i=1, it-1 - bds%strtorat(:,i) = tmpat(:,i) - if(classa(tmpprm(i)) == top%atclass(bds%strtorat(1,i))) then - bds%strtork(:,i) = kat(:,tmpprm(i)) - else - bds%strtork(1:3,i) = kat(7:9,tmpprm(i)) - bds%strtork(4:6,i) = kat(4:6,tmpprm(i)) - bds%strtork(7:9,i) = kat(1:3,tmpprm(i)) - end if - bds%strtork(:,i) = bds%strtork(:,i) * kcalmol2au / angstrom2au - - tor_done = .false. - do j=1, size(bds%torsionat, 2) - if(all(bds%strtorat(:,i) == bds%torsionat(:,j))) then - tor_done = .true. - bds%strtor_t(i) = j - exit - end if - end do - - bnd1_done = .false. - bnd2_done = .false. - bnd3_done = .false. - do j=1, size(bds%bondat, 2) - if(all(bds%strtorat(1:2,i) == bds%bondat(:,j)) .or. & - all(bds%strtorat(2:1:-1,i) == bds%bondat(:,j))) then - bnd1_done = .true. - bds%strtor_b(1,i) = j - else if(all(bds%strtorat(2:3,i) == bds%bondat(:,j)) .or. & - all(bds%strtorat(3:2:-1,i) == bds%bondat(:,j))) then - bnd2_done = .true. - bds%strtor_b(2,i) = j - else if(all(bds%strtorat(3:4,i) == bds%bondat(:,j)) .or. & - all(bds%strtorat(4:3:-1,i) == bds%bondat(:,j))) then - bnd3_done = .true. - bds%strtor_b(3,i) = j - end if - if(bnd1_done .and. bnd2_done .and. bnd3_done) exit - end do - - if(.not. (tor_done .and. bnd1_done .and. bnd2_done .and. bnd3_done)) then - call fatal_error('Ill defined stretching-torsion coupling parameter') - end if - end do - - call mfree('assign_strtor [classa]', classa) - call mfree('assign_strtor [classb]', classb) - call mfree('assign_strtor [classc]', classc) - call mfree('assign_strtor [classd]', classd) - call mfree('assign_strtor [kat]', kat) - call mfree('assign_strtor [tmpat]', tmpat) - call mfree('assign_strtor [tmpprm]', tmpprm) - - end subroutine assign_strtor - - subroutine assign_angtor(bds, prm_buf) - use mod_memory, only: mallocate, mfree - use mod_bonded, only: angtor_init - use mod_constants, only: kcalmol2au - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - !! Bonded potential data structure - character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) - - integer(ip) :: il, i, j, tokb, toke, it, nt, & - cla, clb, clc, cld, maxt, a, b, c, d, jb, jc, jd, iprm - character(len=OMMP_STR_CHAR_MAX) :: line, errstring - integer(ip), allocatable :: classa(:), classb(:), classc(:), classd(:), & - tmpat(:,:), tmpprm(:) - real(rp), allocatable :: kat(:,:) - logical :: tor_done, ang1_done, ang2_done - type(ommp_topology_type), pointer :: top - - top => bds%top - - if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then - call read_atom_cards(top, prm_buf) - end if - - ! Read all the lines of file just to count how large vector should be - ! allocated - nt = 1 - do il=1, size(prm_buf) - line = prm_buf(il) - if(line(:8) == 'angtors ') nt = nt + 1 - end do - - maxt = top%conn(4)%ri(top%mm_atoms+1)-1 - call mallocate('assign_angtor [classa]', nt, classa) - call mallocate('assign_angtor [classb]', nt, classb) - call mallocate('assign_angtor [classc]', nt, classc) - call mallocate('assign_angtor [classd]', nt, classd) - call mallocate('assign_angtor [kat]', 6, nt, kat) - call mallocate('assign_angtor [tmpat]', 4, maxt, tmpat) - call mallocate('assign_angtor [tmpprm]', maxt, tmpprm) - - ! Restart the reading from the beginning to actually save the parameters - it = 1 - i=1 - do il=1, size(prm_buf) - line = prm_buf(il) - - if(line(:8) == 'angtors ') then - tokb = 9 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong ANGTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classa(it) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong ANGTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classb(it) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong ANGOTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classc(it) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong ANGTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classd(it) - - do j=1, 6 - tokb = toke + 1 - toke = tokenize(line, tokb) - - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong ANGTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) kat(j,it) - end do - - it = it + 1 - end if - i = i+1 - end do - - it = 1 - do a=1, top%mm_atoms - cla = top%atclass(a) - do jb=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 - b = top%conn(1)%ci(jb) - clb = top%atclass(b) - do jc=top%conn(1)%ri(b), top%conn(1)%ri(b+1)-1 - c = top%conn(1)%ci(jc) - if(c == a) cycle - clc = top%atclass(c) - do jd=top%conn(1)%ri(c), top%conn(1)%ri(c+1)-1 - d = top%conn(1)%ci(jd) - if(d == a .or. d == b) cycle - if(a > d) cycle - cld = top%atclass(d) - ! There is a dihedral A-B-C-D - do iprm=1, nt - if((classa(iprm) == cla .and. & - classb(iprm) == clb .and. & - classc(iprm) == clc .and. & - classd(iprm) == cld) .or. & - (classa(iprm) == cld .and. & - classb(iprm) == clc .and. & - classc(iprm) == clb .and. & - classd(iprm) == cla)) then - ! The parameter is ok - tmpat(:,it) = [a, b, c, d] - tmpprm(it) = iprm - it = it+1 - exit - end if - end do - end do - end do - end do - end do - - call angtor_init(bds, it-1) - do i=1, it-1 - bds%angtorat(:,i) = tmpat(:,i) - if(classa(tmpprm(i)) == top%atclass(bds%angtorat(1,i))) then - bds%angtork(:,i) = kat(:,tmpprm(i)) * kcalmol2au - else - bds%angtork(1:3,i) = kat(4:6,tmpprm(i)) * kcalmol2au - bds%angtork(4:6,i) = kat(1:3,tmpprm(i)) * kcalmol2au - end if - - tor_done = .false. - do j=1, size(bds%torsionat, 2) - if(all(bds%angtorat(:,i) == bds%torsionat(:,j))) then - tor_done = .true. - bds%angtor_t(i) = j - exit - end if - end do - - ang1_done = .false. - ang2_done = .false. - do j=1, size(bds%angleat, 2) - if(all(bds%angtorat(1:3,i) == bds%angleat(:,j)) .or. & - all(bds%angtorat(1:3,i) == bds%angleat(3:1:-1,j))) then - ang1_done = .true. - bds%angtor_a(1,i) = j - else if(all(bds%angtorat(2:4,i) == bds%angleat(:,j)) .or. & - all(bds%angtorat(2:4,i) == bds%angleat(3:1:-1,j))) then - ang2_done = .true. - bds%angtor_a(2,i) = j - end if - if(ang1_done .and. ang2_done) exit - end do - - if(.not. (tor_done .and. ang1_done .and. ang2_done)) then - call fatal_error('Ill defined angle-torsion coupling parameter') - end if - - end do - - call mfree('assign_angtor [classa]', classa) - call mfree('assign_angtor [classb]', classb) - call mfree('assign_angtor [classc]', classc) - call mfree('assign_angtor [classd]', classd) - call mfree('assign_angtor [kat]', kat) - call mfree('assign_angtor [tmpat]', tmpat) - call mfree('assign_angtor [tmpprm]', tmpprm) - - end subroutine assign_angtor - - subroutine assign_angle(bds, prm_buf, exclude_list, nexc_in) - use mod_memory, only: mallocate, mfree - use mod_bonded, only: OMMP_ANG_SIMPLE, & - OMMP_ANG_H0, & - OMMP_ANG_H1, & - OMMP_ANG_H2, & - OMMP_ANG_INPLANE, & - OMMP_ANG_INPLANE_H0, & - OMMP_ANG_INPLANE_H1 - use mod_bonded, only: angle_init - use mod_constants, only: kcalmol2au, rad2deg, deg2rad - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - !! Bonded potential data structure - character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) - !! Char buffer containing the prm file loaded in RAM - integer(ip), dimension(:), intent(in), optional :: exclude_list - !! List of atoms for which interactions should not be computed - integer(ip), intent(in), optional :: nexc_in - !! Number of atom in excluded list needed to skip a parameter - - integer(ip), parameter :: nexc_default = 3 - integer(ip) :: il, i, j, tokb, toke, iang, nang, & - cla, clb, clc, maxang, a, b, c, jc, jb, k, nhenv, & - iexc, nexc - character(len=OMMP_STR_CHAR_MAX) :: line, errstring - integer(ip), allocatable :: classa(:), classb(:), classc(:), angtype(:) - real(rp), allocatable :: kang(:), th0ang(:) - logical :: done - type(ommp_topology_type), pointer :: top - - top => bds%top - - nexc = nexc_default - if(present(exclude_list)) then - if(present(nexc_in)) then - if(nexc_in > 0 .and. nexc_in < 4) then - nexc = nexc_in - end if - end if - end if - - if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then - call read_atom_cards(top, prm_buf) - end if - - ! Read all the lines of file just to count how large vector should be - ! allocated - nang = 1 - do il=1, size(prm_buf) - line = prm_buf(il) - if(line(:6) == 'angle ') nang = nang + 3 - ! One angle keyourd could stand for 3 parameters for different H-env - if(line(:7) == 'anglep ') nang = nang + 2 - ! One angle keyourd could stand for 2 parameters for different H-env - end do - - maxang = (top%conn(2)%ri(top%mm_atoms+1)-1) / 2 - call mallocate('assign_angle [classa]', nang, classa) - call mallocate('assign_angle [classb]', nang, classb) - call mallocate('assign_angle [classc]', nang, classc) - call mallocate('assign_angle [eqang]', nang, th0ang) - call mallocate('assign_angle [kang]', nang, kang) - call mallocate('assign_angle [angtype]', nang, angtype) - call angle_init(bds, maxang) - - ! Restart the reading from the beginning to actually save the parameters - iang = 1 - i=1 - do il=1, size(prm_buf) - line = prm_buf(il) - - if(line(:12) == 'angle-cubic ') then - tokb = 13 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong ANGLE-CUBIC card " - call fatal_error(errstring) - end if - read(line(tokb:toke), *) bds%angle_cubic - bds%angle_cubic = bds%angle_cubic * rad2deg - - else if(line(:14) == 'angle-quartic ') then - tokb = 15 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong ANGLE-QUARTIC card " - call fatal_error(errstring) - end if - read(line(tokb:toke), *) bds%angle_quartic - bds%angle_quartic = bds%angle_quartic * rad2deg**2 - - else if(line(:13) == 'angle-pentic ') then - tokb = 13 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong ANGLE-PENTIC card " - call fatal_error(errstring) - end if - read(line(tokb:toke), *) bds%angle_pentic - bds%angle_pentic = bds%angle_pentic * rad2deg**3 - - else if(line(:13) == 'angle-sextic ') then - tokb = 14 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong ANGLE-SEXTIC card " - call fatal_error(errstring) - end if - read(line(tokb:toke), *) bds%angle_sextic - bds%angle_sextic = bds%angle_sextic * rad2deg**4 - - else if(line(:6) == 'angle ') then - tokb = 7 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong ANGLE card " - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classa(iang) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong ANGLE card " - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classb(iang) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong ANGLE card " - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classc(iang) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong ANGLE card " - call fatal_error(errstring) - end if - read(line(tokb:toke), *) kang(iang) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong ANGLE card " - call fatal_error(errstring) - end if - read(line(tokb:toke), *) th0ang(iang) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(toke < 0) then - ! Only one angle parameter is specified so it is good - ! for all the H-envirnoment - angtype(iang) = OMMP_ANG_SIMPLE - iang = iang + 1 - else - ! Three equilibrim angles are specified for three different - ! H-environment - angtype(iang) = OMMP_ANG_H0 - iang = iang + 1 - - classa(iang) = classa(iang-1) - classb(iang) = classb(iang-1) - classc(iang) = classc(iang-1) - kang(iang) = kang(iang-1) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong ANGLE card " - call fatal_error(errstring) - end if - read(line(tokb:toke), *) th0ang(iang) - angtype(iang) = OMMP_ANG_H1 - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(toke > 0) then - iang = iang + 1 - - classa(iang) = classa(iang-1) - classb(iang) = classb(iang-1) - classc(iang) = classc(iang-1) - kang(iang) = kang(iang-1) - angtype(iang) = OMMP_ANG_H2 - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong ANGLE card " - call fatal_error(errstring) - end if - read(line(tokb:toke), *) th0ang(iang) - end if - iang = iang + 1 - end if - - else if(line(:7) == 'anglep ') then - tokb = 8 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong ANGLEP card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classa(iang) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong ANGLEP card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classb(iang) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong ANGLEP card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classc(iang) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong ANGLEP card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) kang(iang) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong ANGLEP card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) th0ang(iang) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(toke < 0) then - ! Only one angle parameter is specified so it is good - ! for all the H-envirnoment - angtype(iang) = OMMP_ANG_INPLANE - iang = iang + 1 - else - ! Three equilibrim angles are specified for three different - ! H-environment - angtype(iang) = OMMP_ANG_INPLANE_H0 - iang = iang + 1 - - classa(iang) = classa(iang-1) - classb(iang) = classb(iang-1) - classc(iang) = classc(iang-1) - kang(iang) = kang(iang-1) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong ANGLEP card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) th0ang(iang) - angtype(iang) = OMMP_ANG_INPLANE_H1 - - iang = iang + 1 - end if - end if - i = i+1 - end do - nang = iang - - iang = 1 - do a=1, top%mm_atoms - cla = top%atclass(a) - do jb=top%conn(2)%ri(a), top%conn(2)%ri(a+1)-1 - b = top%conn(2)%ci(jb) - if(a > b) cycle - clb = top%atclass(b) - - do jc=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 - c = top%conn(1)%ci(jc) - if(all(top%conn(1)%ci(top%conn(1)%ri(b):top%conn(1)%ri(b+1)-1) /= c)) cycle - ! There is an angle in the form A-C-B - clc = top%atclass(c) - done = .false. - - do j=1, nang - if((cla == classa(j) & - .and. clb == classc(j) & - .and. clc == classb(j)) .or. & - (clb == classa(j) & - .and. cla == classc(j) & - .and. clc == classb(j))) then - - if(angtype(j) == OMMP_ANG_SIMPLE .or. & - angtype(j) == OMMP_ANG_INPLANE) then - ! For those types no check of the H - ! environment is required - done = .true. - exit - else - ! Check the H-environment - nhenv = 0 - do k=top%conn(1)%ri(c), top%conn(1)%ri(c+1)-1 - if(top%atz(top%conn(1)%ci(k)) == 1) & - nhenv = nhenv + 1 - end do - if(top%atz(a) == 1) nhenv = nhenv-1 - if(top%atz(b) == 1) nhenv = nhenv-1 - - if(nhenv == 0 .and. ( & - angtype(j) == OMMP_ANG_H0 .or. & - angtype(j) == OMMP_ANG_INPLANE_H0)) then - done = .true. - exit - else if(nhenv == 1 .and. ( & - angtype(j) == OMMP_ANG_H1 .or. & - angtype(j) == OMMP_ANG_INPLANE_H1)) then - done = .true. - exit - else if(nhenv == 2 .and. (& - angtype(j) == OMMP_ANG_H2)) then - done = .true. - exit - end if - end if - end if - end do - - if(present(exclude_list) .and. .not. done) then - iexc = 0 - if(any(exclude_list == a)) iexc = iexc + 1 - if(any(exclude_list == b)) iexc = iexc + 1 - if(any(exclude_list == c)) iexc = iexc + 1 - if(iexc >= nexc) then - write(errstring, '(A,I0,A,I0,A,I0,A,I0,A)') & - "Angle ", a, '-', b, '-', c, " not found & - &and ignored because ", iexc, " atoms are & - &in excluded list." - call ommp_message(errstring, OMMP_VERBOSE_HIGH) - done = .true. - end if - end if - - if(done) then - bds%angleat(1,iang) = a - bds%angleat(2,iang) = c - bds%angleat(3,iang) = b - bds%anglety(iang) = angtype(j) - bds%kangle(iang) = kang(j) * kcalmol2au - bds%eqangle(iang) = th0ang(j) * deg2rad - ! Find the auxiliary atom for inplane angles - if(bds%anglety(iang) == OMMP_ANG_INPLANE .or. & - bds%anglety(iang) == OMMP_ANG_INPLANE_H0 .or. & - bds%anglety(iang) == OMMP_ANG_INPLANE_H1) then - ! Find the auxiliary atom used to define the - ! projection plane - if(bds%top%conn(1)%ri(bds%angleat(2,iang)+1) - & - bds%top%conn(1)%ri(bds%angleat(2,iang)) /= 3) & - then - call ommp_message("Angle IN-PLANE defined for a & - &non-trigonal center, this is only & - &acceptable if link-atoms should be & - &defined later.", OMMP_VERBOSE_LOW) - bds%kangle(iang) = 0.0 - else - do j=bds%top%conn(1)%ri(bds%angleat(2,iang)), & - bds%top%conn(1)%ri(bds%angleat(2,iang)+1)-1 - if(bds%top%conn(1)%ci(j) /= bds%angleat(1,iang) .and. & - bds%top%conn(1)%ci(j) /= bds%angleat(3,iang)) then - bds%angauxat(iang) = bds%top%conn(1)%ci(j) - endif - end do - end if - end if - - iang = iang + 1 - else - write(errstring, *) "No angle parameter found for & - &atoms ", a, b, c - call fatal_error(errstring) - end if - end do - end do - end do - - call mfree('assign_angle [classa]', classa) - call mfree('assign_angle [classb]', classb) - call mfree('assign_angle [classc]', classc) - call mfree('assign_angle [eqang]', th0ang) - call mfree('assign_angle [kang]', kang) - call mfree('assign_angle [angtype]', angtype) - - end subroutine assign_angle - - subroutine assign_vdw(vdw, top, prm_buf) - use mod_memory, only: mallocate, mfree - use mod_io, only: fatal_error - use mod_nonbonded, only: ommp_nonbonded_type, vdw_init, vdw_set_pair - use mod_constants, only: angstrom2au, kcalmol2au, OMMP_DEFAULT_NL_CUTOFF - - implicit none - - type(ommp_nonbonded_type), intent(inout) :: vdw - !! Non-bonded structure to be initialized - type(ommp_topology_type), intent(inout) :: top - !! Topology structure - character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) - !! Char buffer containing the prm file loaded in RAM - - integer(ip) :: il, i, j, l, tokb, toke - character(len=OMMP_STR_CHAR_MAX) :: line, errstring - character(len=20) :: radrule, radsize, radtype, vdwtype, epsrule - integer(ip), allocatable :: vdwat(:), vdwpr_a(:), vdwpr_b(:) - real(rp), allocatable :: vdw_e_prm(:), vdw_r_prm(:), vdw_f_prm(:), & - vdwpr_r(:), vdwpr_e(:) - integer(ip) :: nvdw, ivdw, atc, nvdwpr, ivdwpr - logical :: done - logical(lp), allocatable :: maska(:), maskb(:) - - if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then - call read_atom_cards(top, prm_buf) - end if - - ! Read all the lines of file just to count how large vector should be - ! allocated - nvdw = 0 - nvdwpr = 0 - do il=1, size(prm_buf) - line = prm_buf(il) - if(line(:4) == 'vdw ') nvdw = nvdw + 1 - if(line(:6) == 'vdwpr ' .or. line(:8) == 'vdwpair ') & - nvdwpr = nvdwpr + 1 - end do - - ! VDW - call mallocate('read_prm [vdwat]', nvdw, vdwat) - call mallocate('read_prm [vdw_r_prm]', nvdw, vdw_r_prm) - call mallocate('read_prm [vdw_e_prm]', nvdw, vdw_e_prm) - call mallocate('read_prm [vdw_f_prm]', nvdw, vdw_f_prm) - vdw_f_prm = 1.0_rp - ivdw = 1 - - ! VDWPR - call mallocate('read_prm [vdwpr_a]', nvdwpr, vdwpr_a) - call mallocate('read_prm [vdwpr_b]', nvdwpr, vdwpr_b) - call mallocate('read_prm [vdwpr_e]', nvdwpr, vdwpr_e) - call mallocate('read_prm [vdwpr_r]', nvdwpr, vdwpr_r) - allocate(maska(top%mm_atoms), maskb(top%mm_atoms)) - ivdwpr = 1 - - ! Default rules for VDW (from Tinker Manual) - radrule = "arithmetic" - radsize = "radius" - radtype = "r-min" - vdwtype = "lennard-jones" - epsrule = "geometric" - ! Those are defaults defined in Tinker manual - vdw%vdw_screening = [0.0, 0.0, 1.0, 1.0] - - ! Restart the reading from the beginning to actually save the parameters - i=1 - do il=1, size(prm_buf) - line = prm_buf(il) - - if(line(:13) == 'vdw-12-scale ') then - tokb = 14 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong VDW-12-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) vdw%vdw_screening(1) - if(vdw%vdw_screening(1) > 1.0) & - vdw%vdw_screening(1) = 1/vdw%vdw_screening(1) - - else if(line(:13) == 'vdw-13-scale ') then - tokb = 14 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong VDW-13-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) vdw%vdw_screening(2) - if(vdw%vdw_screening(2) > 1.0) & - vdw%vdw_screening(2) = 1/vdw%vdw_screening(2) - - else if(line(:13) == 'vdw-14-scale ') then - tokb = 14 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong VDW-14-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) vdw%vdw_screening(3) - if(vdw%vdw_screening(3) > 1.0) & - vdw%vdw_screening(3) = 1/vdw%vdw_screening(3) - - else if(line(:13) == 'vdw-15-scale ') then - tokb = 14 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong VDW-15-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) vdw%vdw_screening(4) - if(vdw%vdw_screening(4) > 1.0) & - vdw%vdw_screening(4) = 1/vdw%vdw_screening(4) - - else if(line(:12) == 'epsilonrule ') then - tokb = 12 - toke = tokenize(line, tokb) - read(line(tokb:toke), *) epsrule - - else if(line(:8) == 'vdwtype ') then - tokb = 9 - toke = tokenize(line, tokb) - read(line(tokb:toke), *) vdwtype - - else if(line(:11) == 'radiusrule ') then - tokb = 12 - toke = tokenize(line, tokb) - read(line(tokb:toke), *) radrule - - else if(line(:11) == 'radiussize ') then - tokb = 12 - toke = tokenize(line, tokb) - read(line(tokb:toke), *) radsize - - else if(line(:11) == 'radiustype ') then - tokb = 12 - toke = tokenize(line, tokb) - read(line(tokb:toke), *) radtype - - else if(line(:4) == 'vdw ') then - tokb = 5 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong VDW card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) vdwat(ivdw) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong VDW card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) vdw_r_prm(ivdw) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong VDW card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) vdw_e_prm(ivdw) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(toke > 0) then - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong VDW card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) vdw_f_prm(ivdw) - endif - - ivdw = ivdw + 1 - else if(line(:6) == 'vdwpr ' .or. line(:8) == 'vdwpair ') then - if(line(:6) == 'vdwpr ') then - tokb = 7 - else - tokb = 9 - end if - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong VDWPR card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) vdwpr_a(ivdwpr) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong VDWPR card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) vdwpr_b(ivdwpr) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong VDWPR card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) vdwpr_r(ivdwpr) - - tokb = toke + 1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong VDWPR card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) vdwpr_e(ivdwpr) - - ivdwpr = ivdwpr + 1 - end if - i = i+1 - end do - - call vdw_init(vdw, top, vdwtype, radrule, radsize, & - radtype, epsrule, OMMP_DEFAULT_NL_CUTOFF) - - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,j,atc,done) - do i=1, top%mm_atoms - ! Atom class for current atom - atc = top%atclass(i) - - ! VdW parameters - done = .false. - do j=1, nvdw - if(vdwat(j) == atc) then - done = .true. - vdw%vdw_e(i) = vdw_e_prm(j) * kcalmol2au - vdw%vdw_r(i) = vdw_r_prm(j) * angstrom2au - vdw%vdw_f(i) = vdw_f_prm(j) - exit - end if - end do - if(.not. done) then - call fatal_error("VdW parameter not found!") - end if - end do - - ! VdW pair parameters - do l=1, nvdwpr - maska = (top%atclass == vdwpr_a(l)) - maskb = (top%atclass == vdwpr_b(l)) - call vdw_set_pair(vdw, maska, maskb, & - vdwpr_r(l) * angstrom2au, & - vdwpr_e(l) * kcalmol2au) - end do - - call mfree('read_prm [vdwat]', vdwat) - call mfree('read_prm [vdw_r_prm]', vdw_r_prm) - call mfree('read_prm [vdw_e_prm]', vdw_e_prm) - call mfree('read_prm [vdw_f_prm]', vdw_f_prm) - call mfree('read_prm [vdwpr_a]', vdwpr_a) - call mfree('read_prm [vdwpr_b]', vdwpr_b) - call mfree('read_prm [vdwpr_e]', vdwpr_e) - call mfree('read_prm [vdwpr_r]', vdwpr_r) - deallocate(maska, maskb) - - end subroutine assign_vdw - - subroutine assign_pol(eel, prm_buf) - use mod_memory, only: mallocate, mfree, ip, rp - use mod_electrostatics, only: set_screening_parameters - use mod_constants, only: angstrom2au - - implicit none - - type(ommp_electrostatics_type), intent(inout), target :: eel - !! Electrostatics data structure to be initialized - character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) - !! Char buffer containing the prm file loaded in RAM - - integer(ip) :: il, i, j, k, l, iat, tokb, toke, ipg - character(len=OMMP_STR_CHAR_MAX) :: line, errstring - - integer(ip), allocatable :: polat(:), pgspec(:,:) - real(rp), allocatable :: thf(:), isopol(:) - real(rp) :: usc(4), psc(4), pisc(4), dsc(4) - - integer(ip) :: npolarize, ipolarize - - type(ommp_topology_type), pointer :: top - - top => eel%top - - if(.not. top%attype_initialized) then - call fatal_error("Atom type array in topology should be initialized& - & before performing polarization asignament.") - end if - - ! Read all the lines of file just to count how large vector should be - ! allocated - npolarize = 0 - do il=1, size(prm_buf) - line = prm_buf(il) - if(line(:9) == 'polarize ') npolarize = npolarize + 1 - end do - - call mallocate('read_prm [polat]', npolarize, polat) - call mallocate('read_prm [isopol]', npolarize, isopol) - call mallocate('read_prm [thf]', npolarize, thf) - call mallocate('read_prm [pgspec]', 8, npolarize, pgspec) - pgspec = 0 - ipolarize = 1 - - ! Restart the reading from the beginning to actually save the parameters - i=1 - do il=1, size(prm_buf) - line = prm_buf(il) - - if(line(:13) == 'polarization ') then - tokb = 14 - toke = tokenize(line, tokb) - select case(line(tokb:toke)) - case('mutual') - continue - case('direct') - call fatal_error("Polarization DIRECT is not supported") - case default - call fatal_error("Wrong POLARIZATION card") - end select - - else if(line(:15) == 'polar-12-intra ') then - tokb = 16 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong POLAR-12-INTRA card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) pisc(1) - - else if(line(:15) == 'polar-13-intra ') then - tokb = 16 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong POLAR-13-INTRA card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) pisc(2) - - else if(line(:15) == 'polar-14-intra ') then - tokb = 16 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong POLAR-14-INTRA card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) pisc(3) - - else if(line(:15) == 'polar-15-intra ') then - tokb = 16 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong POLAR-15-INTRA card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) pisc(4) - - else if(line(:15) == 'polar-12-scale ') then - tokb = 16 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong POLAR-12-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) psc(1) - - else if(line(:15) == 'polar-13-scale ') then - tokb = 16 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong POLAR-13-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) psc(2) - - else if(line(:15) == 'polar-14-scale ') then - tokb = 16 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong POLAR-14-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) psc(3) - - else if(line(:15) == 'polar-15-scale ') then - tokb = 16 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong POLAR-15-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) psc(4) - - else if(line(:16) == 'direct-11-scale ') then - tokb = 17 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong DIRECT-11-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) dsc(1) - - else if(line(:16) == 'direct-12-scale ') then - tokb = 17 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong DIRECT-12-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) dsc(2) - - else if(line(:16) == 'direct-13-scale ') then - tokb = 17 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong DIRECT-13-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) dsc(3) - - else if(line(:16) == 'direct-14-scale ') then - tokb = 17 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong DIRECT-14-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) dsc(4) - - else if(line(:16) == 'mutual-11-scale ') then - tokb = 17 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong MUTUAL-11-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) usc(1) - else if(line(:16) == 'mutual-12-scale ') then - tokb = 17 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong MUTUAL-12-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) usc(2) - - else if(line(:16) == 'mutual-13-scale ') then - tokb = 17 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong MUTUAL-13-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) usc(3) - - else if(line(:16) == 'mutual-14-scale ') then - tokb = 17 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong MUTUAL-14-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) usc(4) - - else if(line(:9) == 'polarize ') then - tokb = 10 ! len of keyword + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong POLARIZE card" - call fatal_error(errstring) - endif - read(line(tokb:toke), *) polat(ipolarize) - if(polat(ipolarize) < 0) then - write(errstring, *) "Wrong POLARIZE card (specific atom not supported)" - call fatal_error(errstring) - end if - - ! Isotropic polarizability - tokb = toke+1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong POLARIZE card" - call fatal_error(errstring) - endif - read(line(tokb:toke), *) isopol(ipolarize) - - ! Thole dumping factor - tokb = toke+1 - toke = tokenize(line, tokb) - if(isint(line(tokb:toke))) then - ! If this card is skipped then it is HIPPO - write(errstring, *) "HIPPO FF is not currently supported" - call fatal_error(errstring) - else if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong POLARIZE card" - call fatal_error(errstring) - endif - read(line(tokb:toke), *) thf(ipolarize) - - ! Polarization group information - tokb = toke+1 - toke = tokenize(line, tokb) - if(isreal(line(tokb:toke)) .and. .not. isint(line(tokb:toke))) then - ! If there is an additional real modifier then it is AMOEBA+ - write(errstring, *) "AMOEBA+ FF is not currently supported" - call fatal_error(errstring) - end if - j = 1 - do while(toke > 0) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong POLARIZE card" - call fatal_error(errstring) - endif - read(line(tokb:toke), *) pgspec(j,ipolarize) - - tokb = toke+1 - toke = tokenize(line, tokb) - j = j + 1 - end do - ipolarize = ipolarize + 1 - end if - i = i+1 - end do - - if(eel%amoeba) then - call set_screening_parameters(eel, eel%mscale, psc, dsc, usc, pisc) - eel%mmat_polgrp = 0 - else - call set_screening_parameters(eel, eel%mscale, psc, dsc, usc) - end if - - ipg = 0 - ! Now assign the parameters to the atoms - do i=1, size(top%attype) - ! Polarization - do j=1, npolarize - if(polat(j) == top%attype(i)) then - eel%pol(i) = isopol(j) * angstrom2au**3 - !TODO Thole factors. - ! Assign a polgroup label to each atom - if(eel%mmat_polgrp(i) == 0) then - ipg = ipg+1 - eel%mmat_polgrp(i) = ipg - end if - - ! loop over the atoms connected to ith atom - do k=top%conn(1)%ri(i), top%conn(1)%ri(i+1)-1 - iat = top%conn(1)%ci(k) - if(any(top%attype(iat) == pgspec(:,j))) then - ! The two atoms are in the same group - if(eel%mmat_polgrp(iat) == 0) then - eel%mmat_polgrp(iat) = eel%mmat_polgrp(i) - else if(eel%mmat_polgrp(iat) /= eel%mmat_polgrp(i)) then - ! TODO This code have never been tested, as no - ! suitable case have been found - do l=1, top%mm_atoms - if(eel%mmat_polgrp(l) == 0) then - continue - else if(eel%mmat_polgrp(l) == eel%mmat_polgrp(iat) & - .or. eel%mmat_polgrp(l) == eel%mmat_polgrp(i)) then - eel%mmat_polgrp(l) = min(eel%mmat_polgrp(iat), eel%mmat_polgrp(i)) - else if(eel%mmat_polgrp(l) > max(eel%mmat_polgrp(iat),eel%mmat_polgrp(i))) then - eel%mmat_polgrp(l) = eel%mmat_polgrp(l) - 1 - else - continue - end if - end do - end if - end if - end do - end if - end do - end do - - call mfree('read_prm [polat]', polat) - call mfree('read_prm [isopol]', isopol) - call mfree('read_prm [thf]', thf) - call mfree('read_prm [pgspec]', pgspec) - - end subroutine assign_pol - - subroutine assign_mpoles(eel, prm_buf) - use mod_memory, only: mallocate, mfree - use mod_electrostatics, only: set_screening_parameters - use mod_constants, only: AMOEBA_ROT_NONE, & - AMOEBA_ROT_Z_THEN_X, & - AMOEBA_ROT_BISECTOR, & - AMOEBA_ROT_Z_ONLY, & - AMOEBA_ROT_Z_BISECT, & - AMOEBA_ROT_3_FOLD, & - eps_rp, & - OMMP_VERBOSE_DEBUG - - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel - !! The electrostatic object to be initialized - character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) - !! Char buffer containing the prm file loaded in RAM - - integer(ip) :: il, i, j, k, iat, tokb, toke - character(len=OMMP_STR_CHAR_MAX) :: line, errstring - integer(ip), allocatable :: multat(:), multax(:,:), multframe(:) - real(rp), allocatable :: cmult(:,:) - real(rp) :: msc(4), csc(4) - real(rp) :: eel_au2kcalmol, eel_scale - real(rp) :: default_eel_au2kcalmol = 332.063713 - ! Default conversion from A.U. to kcal/mol used in electrostatics of - ! Tinker, only used to handle electric keyword - integer(ip) :: nmult, nchg, imult, iax(3) - logical :: ax_found(3), found13, only12, done - type(ommp_topology_type), pointer :: top - - top => eel%top - - if(.not. top%attype_initialized) then - call fatal_error("Atom type array in topology should be initialized& - & before performing multipoles asignament.") - end if - - ! Read all the lines of file just to count how large vector should be - ! allocated - nmult = 0 - nchg = 0 - do il=1, size(prm_buf) - line = prm_buf(il) - if(line(:11) == 'multipole ') nmult = nmult + 1 - if(line(:7) == 'charge ') nchg = nchg + 1 - end do - - ! MULTIPOLE - call mallocate('read_prm [multat]', nmult+nchg, multat) - call mallocate('read_prm [multframe]', nmult+nchg, multframe) - call mallocate('read_prm [multax]', 3, nmult+nchg, multax) - call mallocate('read_prm [cmult]', 10, nmult+nchg, cmult) - multax = AMOEBA_ROT_NONE - imult = 1 - - ! Default values from Tinker manual - msc = [0.0, 0.0, 1.0, 1.0] - csc = [0.0, 0.0, 1.0, 1.0] - eel_scale = 1.0 - - ! Restart the reading from the beginning to actually save the parameters - do il=1, size(prm_buf) - line = prm_buf(il) - - if(line(:13) == 'chg-12-scale ') then - tokb = 14 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong CHG-12-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) csc(1) - if(csc(1) > 1.0) csc(1) = 1/csc(1) - - else if(line(:13) == 'chg-13-scale ') then - tokb = 14 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong CHG-13-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) csc(2) - if(csc(2) > 1.0) csc(2) = 1/csc(2) - - else if(line(:13) == 'chg-14-scale ') then - tokb = 14 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong CHG-14-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) csc(3) - if(csc(3) > 1.0) csc(3) = 1/csc(3) - - else if(line(:13) == 'chg-15-scale ') then - tokb = 14 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong CHG-15-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) csc(4) - if(csc(4) > 1.0) csc(4) = 1/csc(4) - - else if(line(:15) == 'mpole-12-scale ') then - tokb = 16 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong MPOLE-12-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) msc(1) - if(msc(1) > 1.0) msc(1) = 1/msc(1) - - else if(line(:15) == 'mpole-13-scale ') then - tokb = 16 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong MPOLE-13-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) msc(2) - if(msc(2) > 1.0) msc(2) = 1/msc(2) - - else if(line(:15) == 'mpole-14-scale ') then - tokb = 16 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong MPOLE-14-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) msc(3) - if(msc(3) > 1.0) msc(3) = 1/msc(3) - - else if(line(:15) == 'mpole-15-scale ') then - tokb = 16 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong MPOLE-15-SCALE card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) msc(4) - if(msc(4) > 1.0) msc(4) = 1/msc(4) - - else if(line(:9) == 'electric ') then - tokb = 10 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong ELECTRIC card" - call fatal_error(errstring) - end if - ! This keyword is used to change the conversion from A.U. to - ! kcal/mol for the electrostatic interaction. - ! It is a bit creepy and unclear what it's correct to do here, - ! I think that best thing is to scale the electrostatic itself - ! by a factor (electric/default_electric) ** 0.5 - read(line(tokb:toke), *) eel_au2kcalmol - eel_scale = (eel_au2kcalmol/default_eel_au2kcalmol) ** 0.5 - - else if(line(:7) == 'charge ') then - tokb = 8 ! len of keyword + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong CHARGE card" - call fatal_error(errstring) - endif - read(line(tokb:toke), *) multat(imult) - if(multat(imult) < 0) then - write(errstring, *) "Wrong CHARGE card (specific atom not supported)" - call fatal_error(errstring) - end if - ! Rotation axis information, charge does not contain any - multax(:,imult) = 0 - multframe(imult) = AMOEBA_ROT_NONE - - tokb = toke+1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong CHARGE card" - call fatal_error(errstring) - end if - - read(line(tokb:toke), *) cmult(1, imult) - cmult(2:10, imult) = 0.0 ! Fixed dipole and quadrupole are not present - imult = imult + 1 - - else if(line(:11) == 'multipole ') then - tokb = 12 ! len of keyword + 1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong MULTIPOLE card" - call fatal_error(errstring) - endif - read(line(tokb:toke), *) multat(imult) - if(multat(imult) < 0) then - write(errstring, *) "Wrong MULTIPOLE card (specific atom not supported)" - call fatal_error(errstring) - end if - - ! Rotation axis information - tokb = toke+1 - toke = tokenize(line, tokb, 1) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong MULTIPOLE card at least two & - &integers for axys specification expected." - call fatal_error(errstring) - end if - read(line(tokb:toke), *) multax(1,imult) - - tokb = toke+1 - toke = tokenize(line, tokb, 1) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong MULTIPOLE card at least two & - &integers for axys specification expected." - call fatal_error(errstring) - end if - read(line(tokb:toke), *) multax(2,imult) - - ! For some centers also y axis is specified (integer) otherwise - ! this is the zeroth-order multipole (charge) - tokb = toke+1 - toke = tokenize(line, tokb) - if(isint(line(tokb:toke))) then - ! Read the y axis - read(line(tokb:toke), *) multax(3,imult) - ! Get another token, this should be the charge. - tokb = toke+1 - toke = tokenize(line, tokb) - end if - - ! The type of rotation is encoded in the sign/nullness of - ! of the axis specification - if(multax(1,imult) == 0) then - multframe(imult) = AMOEBA_ROT_NONE - else if(multax(2, imult) == 0) then - multframe(imult) = AMOEBA_ROT_Z_ONLY - else if(multax(1,imult) < 0 .and. multax(2,imult) < 0 & - .and. multax(3,imult) < 0) then - multframe(imult) = AMOEBA_ROT_3_FOLD - else if(multax(1,imult) < 0 .or. multax(2,imult) < 0) then - multframe(imult) = AMOEBA_ROT_BISECTOR - else if(multax(2,imult) < 0 .and. multax(3,imult) < 0) then - multframe(imult) = AMOEBA_ROT_Z_BISECT - else - multframe(imult) = AMOEBA_ROT_Z_THEN_X - end if - ! Remove the encoded information after saving it in a reasonable - ! way - multax(:,imult) = abs(multax(:,imult)) - - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong MULTIPOLE card" - call fatal_error(errstring) - end if - - read(line(tokb:toke), *) cmult(1, imult) - - read(prm_buf(il+1), *) cmult(2:4, imult) - read(prm_buf(il+2), *) cmult(5, imult) - read(prm_buf(il+3), *) cmult(6:7, imult) - read(prm_buf(il+4), *) cmult(8:10, imult) - !il = il+4 - - imult = imult + 1 - end if - end do - - if(nmult > 0 .and. nchg == 0) then - call set_screening_parameters(eel, msc, eel%pscale, eel%dscale, & - eel%uscale, eel%pscale_intra) - else if(nmult == 0 .and. nchg > 0) then - call set_screening_parameters(eel, csc, eel%pscale, eel%dscale, & - eel%uscale) - else if(nmult > 0 .and. nchg > 0) then - write(errstring, *) "Unexpected FF with both multipoles and charges" - call fatal_error(errstring) - end if - - - !$omp parallel do default(shared) schedule(dynamic) & - !$omp private(i,only12,j,found13,ax_found,iax,iat,done) - do i=1, size(top%attype) - if(eel%amoeba) then - eel%mol_frame(i) = 0 - eel%ix(i) = 0 - eel%iy(i) = 0 - eel%iz(i) = 0 - eel%q0(:,i) = 0.0 - end if - eel%q(:,i) = 0.0 - - ! Flag to check assignament - done = .false. - - ! Multipoles - only12 = .false. ! Only search for params based on 12 connectivity - do j=1, max(nmult, nchg) - found13 = .false. ! Parameter found is based on 13 connectivity - if(multat(j) == top%attype(i)) then - ! For each center different multipoles are defined for - ! different environment. So first check if the environment - ! is the correct one - - ! Assignament with only 1,2-neighbours. - ax_found = .false. - iax = 0_ip - - if(multframe(j) == AMOEBA_ROT_NONE) then - ! No axis needed - ax_found = .true. - else if(multframe(j) == AMOEBA_ROT_Z_ONLY) then - ! Assignament with only-z - ax_found(2:3) = .true. - do k=top%conn(1)%ri(i), top%conn(1)%ri(i+1)-1 - iat = top%conn(1)%ci(k) - if(top%attype(iat) == multax(1,j) & - .and. .not. ax_found(1)) then - ax_found(1) = .true. - iax(1) = iat - end if - end do - else - ! 2 or 3 axis needed - if(multax(3,j) == 0) ax_found(3) = .true. - - ! Using only 1,2 connectivity - do k=top%conn(1)%ri(i), top%conn(1)%ri(i+1)-1 - iat = top%conn(1)%ci(k) - if(top%attype(iat) == multax(1,j) & - .and. .not. ax_found(1)) then - ax_found(1) = .true. - iax(1) = iat - else if(top%attype(iat) == multax(2,j) & - .and. .not. ax_found(2)) then - ax_found(2) = .true. - iax(2) = iat - else if(top%attype(iat) == multax(3,j) & - .and. .not. ax_found(3)) then - ax_found(3) = .true. - iax(3) = iat - end if - end do - - ! Using also 1,3 connectivity - if(ax_found(1) .and. .not. ax_found(2)) then - do k=top%conn(1)%ri(iax(1)), top%conn(1)%ri(iax(1)+1)-1 - iat = top%conn(1)%ci(k) - if(iat == i .or. iat == iax(1)) cycle - if(top%attype(iat) == multax(2,j) & - .and. .not. ax_found(2) & - .and. iat /= iax(1)) then - ax_found(2) = .true. - iax(2) = iat - else if(top%attype(iat) == multax(3,j) & - .and. .not. ax_found(3) & - .and. iat /= iax(1) & - .and. iat /= iax(2)) then - ax_found(3) = .true. - iax(3) = iat - end if - end do - if(all(ax_found)) found13 = .true. - end if - end if - - ! Everything is done, no further improvement is possible - if(all(ax_found) .and. .not. (only12 .and. found13)) then - if(eel%amoeba) then - eel%ix(i) = iax(2) - eel%iy(i) = iax(3) - eel%iz(i) = iax(1) - eel%mol_frame(i) = multframe(j) - eel%q(:,i) = cmult(:,j) - else - eel%q(1,i) = cmult(1,j) - end if - if(.not. done) then - done = .true. - else - write(errstring, "(A, I0)") & - "Reassigning multipoles for atom ", i - call ommp_message(errstring, OMMP_VERBOSE_DEBUG) - end if - - write(errstring, "(A, I0, A, I0, A, I0, A, I0, A, I0, A)") & - "Atom ", i, " is assigned multipole set ", j, & - " axes [ ", iax(2), "-", iax(3), "-", iax(1), " ]" - call ommp_message(errstring, OMMP_VERBOSE_DEBUG) - - - if(.not. found13) then - exit ! No further improvement is possible - else - only12 = .true. - end if - end if - end if - end do - if(.not. done) then - write(errstring, "(A, I0)") & - "No multipoles parameter found for atom ", i - call ommp_message(errstring, OMMP_VERBOSE_LOW) - call ommp_message("Previous error is only acceptable & - &if link atom is used to fix those & - ¶meter later on", OMMP_VERBOSE_LOW) - end if - end do - - if(abs(eel_scale - 1.0) > eps_rp) then - write(errstring, '(A, F10.6)') "Scaling charges by", eel_scale - call ommp_message(errstring, OMMP_VERBOSE_LOW) - eel%q = eel%q * eel_scale - end if - - call mfree('read_prm [multat]', multat) - call mfree('read_prm [multframe]', multframe) - call mfree('read_prm [multax]', multax) - call mfree('read_prm [cmult]', cmult) - - end subroutine assign_mpoles - - subroutine assign_tortors(bds, prm_buf) - use mod_memory, only: mallocate, mfree - use mod_bonded, only: tortor_newmap, tortor_init - use mod_constants, only: deg2rad, kcalmol2au - - implicit none - - type(ommp_bonded_type), intent(inout) :: bds - !! Bonded potential data structure - character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) - !! Char buffer containing the prm file loaded in RAM - - integer(ip) :: il, i, j, tokb, toke, iprm, jd, je, e, d, cle,it,cld,& - cla, clb, clc, a, b, c, jc, jb, itt, ndata, ntt, ibeg, iend, maxtt - character(len=OMMP_STR_CHAR_MAX) :: line, errstring - integer(ip), allocatable :: classx(:,:), map_dimension(:,:), tmpat(:,:), tmpprm(:), savedmap(:) - real(rp), allocatable :: data_map(:), ang_map(:,:) - type(ommp_topology_type), pointer :: top - - top => bds%top - - if(.not. top%atclass_initialized .or. .not. top%atz_initialized) then - call read_atom_cards(top, prm_buf) - end if - - ! Read all the lines of file just to count how large vector should be - ! allocated - ntt = 0 - do il=1, size(prm_buf) - line = prm_buf(il) - if(line(:8) == 'tortors ') ntt = ntt + 1 - end do - - maxtt = top%conn(4)%ri(top%mm_atoms+1)-1 - call mallocate('assign_tortors [classx]', 5, ntt, classx) - call mallocate('assign_tortors [map_dimension]', 2, ntt, map_dimension) - call mallocate('assign_tortors [savedmap]', ntt, savedmap) - call mallocate('assign_tortors [tmpat]', 5, maxtt, tmpat) - call mallocate('assign_tortors [tmpprm]', maxtt, tmpprm) - - ! Restart the reading from the beginning to actually save the parameters - itt = 1 - i=1 - do il=1, size(prm_buf) - line = prm_buf(il) - - if(line(:8) == 'tortors ') then - tokb = 9 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong TORTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classx(1,itt) - - tokb = toke+1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong TORTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classx(2,itt) - - tokb = toke+1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong TORTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classx(3,itt) - - tokb = toke+1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong TORTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classx(4,itt) - - tokb = toke+1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong TORTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) classx(5,itt) - - tokb = toke+1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong TORTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) map_dimension(1,itt) - - tokb = toke+1 - toke = tokenize(line, tokb) - if(.not. isint(line(tokb:toke))) then - write(errstring, *) "Wrong TORTORS card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) map_dimension(2,itt) - - itt = itt + 1 - end if - i = i+1 - end do - - ! Allocate data space and finally read the map - ndata = dot_product(map_dimension(1,:), map_dimension(2,:)) - call mallocate('assign_tortors [data_map]', ndata, data_map) - call mallocate('assign_tortors [ang_map]', 2, ndata, ang_map) - - itt = 1 - i=1 - do il=1, size(prm_buf) - line = prm_buf(il) - - if(line(:8) == 'tortors ') then - ndata = map_dimension(1,itt)*map_dimension(2,itt) - do j=1, ndata - line = prm_buf(il+j) - - tokb = tokenize(line) - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong TORTORS data card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) ang_map(1, i) - - tokb = toke+1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong TORTORS data card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) ang_map(2, i) - - tokb = toke+1 - toke = tokenize(line, tokb) - if(.not. isreal(line(tokb:toke))) then - write(errstring, *) "Wrong TORTORS data card" - call fatal_error(errstring) - end if - read(line(tokb:toke), *) data_map(i) - i = i + 1 - end do - itt = itt + 1 - end if - end do - - it = 1 - do a=1, top%mm_atoms - cla = top%atclass(a) - do jb=top%conn(1)%ri(a), top%conn(1)%ri(a+1)-1 - b = top%conn(1)%ci(jb) - clb = top%atclass(b) - do jc=top%conn(1)%ri(b), top%conn(1)%ri(b+1)-1 - c = top%conn(1)%ci(jc) - if(c == a) cycle - clc = top%atclass(c) - do jd=top%conn(1)%ri(c), top%conn(1)%ri(c+1)-1 - d = top%conn(1)%ci(jd) - if(d == a .or. d == b) cycle - cld = top%atclass(d) - do je=top%conn(1)%ri(d), top%conn(1)%ri(d+1)-1 - e = top%conn(1)%ci(je) - if(e == a .or. e == b .or. e == c) cycle - if(a > e) cycle - cle = top%atclass(e) - ! There is a dihedral pair A-B-C-D-E - do iprm=1, ntt - if((classx(1,iprm) == cla .and. & - classx(2,iprm) == clb .and. & - classx(3,iprm) == clc .and. & - classx(4,iprm) == cld .and. & - classx(5,iprm) == cle) .or. & - (classx(1,iprm) == cle .and. & - classx(2,iprm) == cld .and. & - classx(3,iprm) == clc .and. & - classx(4,iprm) == clb .and. & - classx(5,iprm) == cla)) then - ! The parameter is ok - tmpat(:,it) = [a, b, c, d, e] - tmpprm(it) = iprm - it = it+1 - exit - end if - end do - end do - end do - end do - end do - end do - - call tortor_init(bds, it-1) - savedmap = -1 - iprm = 1 - do i=1, it-1 - if(savedmap(tmpprm(i)) < 0) then - ! If needed, save the map in the module - ibeg = 1 - do j=1, tmpprm(i)-1 - ibeg = ibeg + map_dimension(1,j)*map_dimension(2,j) - end do - iend = ibeg + map_dimension(1,tmpprm(i))*map_dimension(2,tmpprm(i)) - 1 - call tortor_newmap(bds, map_dimension(1,tmpprm(i)), & - map_dimension(2,tmpprm(i)), & - ang_map(1,ibeg:iend) * deg2rad, & - ang_map(2,ibeg:iend) * deg2rad, & - data_map(ibeg:iend) * kcalmol2au) - savedmap(tmpprm(i)) = iprm - iprm = iprm + 1 - end if - - bds%tortorat(:,i) = tmpat(:,i) - bds%tortorprm(i) = savedmap(tmpprm(i)) - end do - - call mfree('assign_tortors [classx]', classx) - call mfree('assign_tortors [map_dimension]', map_dimension) - call mfree('assign_tortors [savedmap]', savedmap) - call mfree('assign_tortors [data_map]', data_map) - call mfree('assign_tortors [ang_map]', ang_map) - call mfree('assign_tortors [tmpat]', tmpat) - call mfree('assign_tortors [tmpprm]', tmpprm) - - end subroutine assign_tortors - -end module mod_prm diff --git a/src/mod_profiling.F90 b/src/mod_profiling.F90 new file mode 100644 index 0000000..7b5c649 --- /dev/null +++ b/src/mod_profiling.F90 @@ -0,0 +1,73 @@ +#include "version.h" +#define OMMP_TIMING + +module mod_profiling + !! Unified Input/Output handling across the code. + + use mod_constants, only: OMMP_VERBOSE_DEBUG, & + OMMP_VERBOSE_HIGH, & + OMMP_VERBOSE_LOW, & + OMMP_VERBOSE_NONE, & + OMMP_VERBOSE_DEFAULT, & + OMMP_STR_CHAR_MAX, & + ip, rp + use mod_io, only: fatal_error, ommp_message + use mod_memory, only: mem_stat + + implicit none + private + +#ifdef OMMP_TIMING + integer(ip), parameter :: ntimes = 128 + integer(ip) :: tcnt = 1 + real(rp) :: times(ntimes) + real(rp) :: maxmem(ntimes) +#endif + + public :: time_pull, time_push + +contains + + subroutine time_push() + implicit none +#ifdef OMMP_TIMING + real(rp) :: omp_get_wtime + + if(tcnt <= ntimes) then + times(tcnt) = omp_get_wtime() + ! Reset the memory counter, and save current value. + maxmem(tcnt) = mem_stat() + tcnt = tcnt + 1 + else + call fatal_error('time_push Cannot push another time in the buffer.') + end if +#endif + end subroutine + + subroutine time_pull(s) + implicit none + + character(len=*), intent(in) :: s +#ifdef OMMP_TIMING + real(rp) :: elap, mm + character(len=OMMP_STR_CHAR_MAX) :: msg + + real(rp) :: omp_get_wtime + + if(tcnt > 1) then + elap = omp_get_wtime() - times(tcnt-1) + !! Get maximum memory usage since last time push in + !! GB, also make it ready for the next push/pull + mm = mem_stat(maxmem(tcnt-1)) + tcnt = tcnt - 1 + write(msg, "(3a, ': ', e14.6E2, ' s')") repeat('-', tcnt), '> ', s, elap + call ommp_message(msg, OMMP_VERBOSE_HIGH, 'time') + write(msg, "(3a, ': ', e14.6E2, ' GB')") repeat('-', tcnt), '> ', s, mm + call ommp_message(msg, OMMP_VERBOSE_HIGH, 'memory') + else + call fatal_error('time_pull Cannot pull any value.') + end if +#endif + end subroutine + +end module mod_profiling diff --git a/src/mod_profiling.f90 b/src/mod_profiling.f90 deleted file mode 100644 index 1073532..0000000 --- a/src/mod_profiling.f90 +++ /dev/null @@ -1,73 +0,0 @@ -#include "version.h" -#define OMMP_TIMING - -module mod_profiling - !! Unified Input/Output handling across the code. - - use mod_constants, only: OMMP_VERBOSE_DEBUG, & - OMMP_VERBOSE_HIGH, & - OMMP_VERBOSE_LOW, & - OMMP_VERBOSE_NONE, & - OMMP_VERBOSE_DEFAULT, & - OMMP_STR_CHAR_MAX, & - ip, rp - use mod_io, only: fatal_error, ommp_message - use mod_memory, only: mem_stat - - implicit none - private - -#ifdef OMMP_TIMING - integer(ip), parameter :: ntimes = 128 - integer(ip) :: tcnt = 1 - real(rp) :: times(ntimes) - real(rp) :: maxmem(ntimes) -#endif - - public :: time_pull, time_push - - contains - - subroutine time_push() - implicit none -#ifdef OMMP_TIMING - real(rp) :: omp_get_wtime - - if(tcnt <= ntimes) then - times(tcnt) = omp_get_wtime() - ! Reset the memory counter, and save current value. - maxmem(tcnt) = mem_stat() - tcnt = tcnt + 1 - else - call fatal_error('time_push Cannot push another time in the buffer.') - end if -#endif - end subroutine - - subroutine time_pull(s) - implicit none - - character(len=*), intent(in) :: s -#ifdef OMMP_TIMING - real(rp) :: elap, mm - character(len=OMMP_STR_CHAR_MAX) :: msg - - real(rp) :: omp_get_wtime - - if(tcnt > 1) then - elap = omp_get_wtime() - times(tcnt-1) - !! Get maximum memory usage since last time push in - !! GB, also make it ready for the next push/pull - mm = mem_stat(maxmem(tcnt-1)) - tcnt = tcnt - 1 - write(msg, "(3a, ': ', e14.6E2, ' s')") repeat('-', tcnt), '> ', s, elap - call ommp_message(msg, OMMP_VERBOSE_HIGH, 'time') - write(msg, "(3a, ': ', e14.6E2, ' GB')") repeat('-', tcnt), '> ', s, mm - call ommp_message(msg, OMMP_VERBOSE_HIGH, 'memory') - else - call fatal_error('time_pull Cannot pull any value.') - end if -#endif - end subroutine - -end module mod_profiling diff --git a/src/mod_qm_helper.F90 b/src/mod_qm_helper.F90 new file mode 100644 index 0000000..e12477f --- /dev/null +++ b/src/mod_qm_helper.F90 @@ -0,0 +1,521 @@ +module mod_qm_helper +!! This is an utility module, that is not actually used my openMMpol itself, +!! but can be initialized and used by a QM program interfaced with openMMPol +!! to simplify certain steps of the interface using already well tested code. + + use mod_memory, only: ip, rp, lp + use mod_mmpol, only: ommp_system + use mod_topology, only: ommp_topology_type + use mod_nonbonded, only: ommp_nonbonded_type + + implicit none + private + + type ommp_qm_helper + type(ommp_topology_type), allocatable :: qm_top + !! Topology of the QM system + logical(lp) :: reconnect = .false. + !! Flag to decide if the topology should be rebuily + !! at each change of geometry. + real(rp), allocatable :: qqm(:) + !! Charges of QM nuclei + logical(lp) :: E_n2p_done = .false. + !! Flag for [[E_n2p]] + real(rp), allocatable :: E_n2p(:,:) + !! Electric field of nuclei at polarizable sites + logical(lp) :: G_n2p_done = .false. + !! Flag for [[G_n2p]] + real(rp), allocatable :: G_n2p(:,:) + !! Electric field gradients of nuclei at polarizable sites + logical(lp) :: E_n2m_done = .false. + !! Flag for [[E_n2m]] + real(rp), allocatable :: E_n2m(:,:) + !! Electric field of nuclei at static sites + logical(lp) :: G_n2m_done = .false. + !! Flag for [[G_n2m]] + real(rp), allocatable :: G_n2m(:,:) + !! Electric field gradients of nuclei at static sites + logical(lp) :: H_n2m_done = .false. + !! Flag for [[H_n2m]] + real(rp), allocatable :: H_n2m(:,:) + !! Electric field Hessian of nuclei at static sites + logical(lp) :: V_m2n_done = .false. + !! Flag for [[V_m2n]] + real(rp), allocatable :: V_m2n(:) + !! Electrostatic potential of MMPol atoms (static) at QM nuclei + logical(lp) :: E_m2n_done = .false. + !! Flag for [[E_m2n]] + real(rp), allocatable :: E_m2n(:,:) + !! Electrostatic potential of MMPol atoms (static) at QM nuclei + logical(lp) :: V_p2n_done = .false. + !! Flag for [[V_p2n]] + real(rp), allocatable :: V_p2n(:) + !! Electrostatic potential of MMPol atoms (polarizable) at QM nuclei + logical(lp) :: V_pp2n_done = .false. + !! Flag for [[V_pp2n]] + logical(lp) :: V_pp2n_req = .false. + !! Flag to enable the computation of V_pp2n, this is only needed in some + !! wired cases like when using qm_helper as driver for DFTB + real(rp), allocatable :: V_pp2n(:) + !! Electrostatic potential of MMPol atoms (polarizable, AMOEBA P dipoles) at QM nuclei + logical(lp) :: E_p2n_done = .false. + !! Flag for [[E_p2n]] + real(rp), allocatable :: E_p2n(:,:) + !! Electrostatic potential of MMPol atoms (polarizable) at QM nuclei + logical(lp) :: use_nonbonded = .false. + !! Flag for using QM nonbonded terms + type(ommp_nonbonded_type), allocatable :: qm_vdw + !! Structure to store VdW parameter for QM atoms + end type ommp_qm_helper + + public :: ommp_qm_helper + public :: qm_helper_init, qm_helper_terminate + public :: qm_helper_init_vdw, qm_helper_init_vdw_prm, & + qm_helper_vdw_energy, qm_helper_vdw_geomgrad, & + qm_helper_update_coord, qm_helper_set_attype, & + qm_helper_link_atom_geomgrad + public :: electrostatic_for_ene, electrostatic_for_grad + +contains + subroutine qm_helper_init(qm, qmat, cqm, qqm, zqm) + use mod_memory, only: mallocate + use mod_topology, only: topology_init, guess_connectivity + + implicit none + type(ommp_qm_helper), intent(inout) :: qm + !! [[ommp_qm_helper]] object to be initialized + real(rp), intent(in) :: cqm(:,:) + !! Coordinates of QM atoms + real(rp), intent(in) :: qqm(:) + !! Nuclear charges of QM atoms + integer(ip), intent(in) :: zqm(:) + !! Atomic number of QM atoms + integer(ip), intent(in) :: qmat + !! Number of QM atoms + + allocate(qm%qm_top) + call mallocate('qm_helper_init [qqm]', qmat, qm%qqm) + + call topology_init(qm%qm_top, qmat) + qm%qm_top%cmm = cqm + qm%qm_top%atz = zqm + qm%qm_top%atz_initialized = .true. + qm%qqm = qqm + + call guess_connectivity(qm%qm_top) + end subroutine + + subroutine qm_helper_set_attype(qm, attype) + implicit none + + type(ommp_qm_helper), intent(inout) :: qm + integer(ip), intent(in) :: attype(qm%qm_top%mm_atoms) + + qm%qm_top%attype = attype + qm%qm_top%attype_initialized = .true. + end subroutine + + subroutine qm_helper_update_coord(qm, cnew, reconnect_in, linkatoms) + use mod_adjacency_mat, only: matfree + use mod_topology, only: guess_connectivity + use mod_io, only: ommp_message + use mod_constants, only: OMMP_VERBOSE_LOW + + implicit none + type(ommp_qm_helper), intent(inout) :: qm + !! [[ommp_qm_helper]] object to be initialized + real(rp), intent(in) :: cnew(3,qm%qm_top%mm_atoms) + !! Coordinates of QM atoms + logical(lp), intent(in), optional :: reconnect_in + !! Flag to rebuil connectivity + integer(ip), intent(in), optional :: linkatoms(:) + !! Atoms that should be considered link atoms + + integer(ip) :: i + logical(lp) :: rc + + if(present(reconnect_in)) then + rc = reconnect_in + else + rc = qm%reconnect + end if + + qm%qm_top%cmm = cnew + qm%E_n2p_done = .false. + qm%G_n2p_done = .false. + qm%E_n2m_done = .false. + qm%G_n2m_done = .false. + qm%H_n2m_done = .false. + qm%V_m2n_done = .false. + qm%E_m2n_done = .false. + if(rc) then + call ommp_message("Rebuilding connectivity.", OMMP_VERBOSE_LOW, 'linkatom') + do i=1, size(qm%qm_top%conn) + call matfree(qm%qm_top%conn(i)) + end do + deallocate(qm%qm_top%conn) + allocate(qm%qm_top%conn(1)) + + call guess_connectivity(qm%qm_top, linkatoms) + end if + end subroutine + + subroutine qm_helper_init_vdw(qm, eps, rad, fac, & + vdw_type, radius_rule, radius_size, & + radius_type, epsrule) + use mod_memory, only: mallocate + use mod_nonbonded, only: vdw_init + use mod_io, only: fatal_error + use mod_constants, only: OMMP_DEFAULT_NL_CUTOFF + + implicit none + + type(ommp_qm_helper), intent(inout) :: qm + real(rp), intent(in) :: eps(qm%qm_top%mm_atoms) + real(rp), intent(in) :: rad(qm%qm_top%mm_atoms) + real(rp), intent(in) :: fac(qm%qm_top%mm_atoms) + character(len=*) :: vdw_type, radius_rule, radius_size, & + radius_type, epsrule + + if(qm%use_nonbonded) then + call fatal_error("VdW is already initialized!") + end if + + allocate(qm%qm_vdw) + + call vdw_init(qm%qm_vdw, qm%qm_top, vdw_type, radius_rule, & + radius_size, radius_type, epsrule, OMMP_DEFAULT_NL_CUTOFF) + + qm%qm_vdw%vdw_e = eps + qm%qm_vdw%vdw_r = rad + qm%qm_vdw%vdw_f = fac + qm%use_nonbonded = .true. + + end subroutine + + subroutine qm_helper_init_vdw_prm(qm, prmfile) + !! Assign vdw parameters of the QM part from attype and prm file + use mod_prm, only: assign_vdw + use mod_io, only: fatal_error, large_file_read + use mod_constants, only: OMMP_STR_CHAR_MAX + use mod_utils, only: str_to_lower, str_uncomment + + implicit none + + type(ommp_qm_helper), intent(inout) :: qm + character(len=*), intent(in) :: prmfile + + character(len=OMMP_STR_CHAR_MAX), allocatable :: prm_buf(:) + integer(ip) :: ist, i + + if(qm%use_nonbonded) then + call fatal_error("VdW is already initialized!") + end if + + if(.not. qm%qm_top%attype_initialized) then + call fatal_error("Set the types for QM helper atoms before & + &requesting creation of VdW.") + end if + + call large_file_read(prmfile, prm_buf) + ! Remove comments from prm file + !$omp parallel do + do i=1, size(prm_buf) + prm_buf(i) = str_to_lower(prm_buf(i)) + prm_buf(i) = str_uncomment(prm_buf(i), '!') + end do + + allocate(qm%qm_vdw) + call assign_vdw(qm%qm_vdw, qm%qm_top, prm_buf) + qm%use_nonbonded = .true. + deallocate(prm_buf) + end subroutine + + subroutine qm_helper_vdw_energy(qm, mm, V) + use mod_nonbonded, only: vdw_potential_inter, vdw_potential_inter_restricted + use mod_mmpol, only: ommp_system + use mod_link_atom, only: link_atom_update_merged_topology + + implicit none + + type(ommp_system), intent(inout) :: mm + type(ommp_qm_helper), intent(in) :: qm + real(rp), intent(inout) :: V + + + if(mm%use_nonbonded .and. qm%use_nonbonded) then + call vdw_potential_inter(mm%vdw, qm%qm_vdw, V) + if(mm%use_linkatoms) then + call link_atom_update_merged_topology(mm%la) + ! Screening due to the presence of link atom + call vdw_potential_inter_restricted(mm%vdw, qm%qm_vdw, & + mm%la%vdw_screening_pairs,& + mm%la%vdw_screening_f, & + mm%la%vdw_n_screening, V) + end if + end if + + end subroutine + + subroutine qm_helper_vdw_geomgrad(qm, mm, qmg, mmg) + use mod_nonbonded, only: vdw_geomgrad_inter, & + vdw_geomgrad_inter_restricted + use mod_mmpol, only: ommp_system + use mod_link_atom, only: link_atom_update_merged_topology + + implicit none + + type(ommp_system), intent(inout) :: mm + type(ommp_qm_helper), intent(in) :: qm + real(rp), intent(inout) :: qmg(3,qm%qm_top%mm_atoms), & + mmg(3,mm%top%mm_atoms) + + if(mm%use_nonbonded .and. qm%use_nonbonded) then + call vdw_geomgrad_inter(mm%vdw, qm%qm_vdw, mmg, qmg) + if(mm%use_linkatoms) then + call link_atom_update_merged_topology(mm%la) + ! Screening due to the presence of link atom + call vdw_geomgrad_inter_restricted(mm%vdw, qm%qm_vdw, & + mm%la%vdw_screening_pairs,& + mm%la%vdw_screening_f, & + mm%la%vdw_n_screening, & + mmg, qmg) + end if + end if + end subroutine + + subroutine qm_helper_link_atom_geomgrad(qm, mm, qmg, mmg, original_qmg) + !! Computes the missing gradients for QM/MM linkatoms + !! that is bonded terms on QM atoms, LA forces projection on QM and MM + !! atoms. To obtain the correct forces in output, qmg should already + !! contain the QM forces, so that LA forces could be projected on + !! QM and MM force vectors + + use mod_mmpol, only: ommp_system + use mod_link_atom, only: link_atom_update_merged_topology, & + link_atom_bond_geomgrad, & + link_atom_angle_geomgrad, & + link_atom_torsion_geomgrad, & + link_atom_project_grd + use mod_memory, only: mallocate, mfree + + implicit none + + type(ommp_system), intent(inout) :: mm + type(ommp_qm_helper), intent(in) :: qm + real(rp), intent(inout) :: qmg(3,qm%qm_top%mm_atoms), & + mmg(3,mm%top%mm_atoms) + real(rp), intent(in) :: original_qmg(3,qm%qm_top%mm_atoms) + + real(rp), allocatable :: lagrad(:,:) + integer(ip) :: i + + if(mm%use_linkatoms) then + call link_atom_update_merged_topology(mm%la) + + call mallocate('qm_helper_linkatom_geomgrad [lagrad]', 3, mm%la%nla, lagrad) + do i=1, mm%la%nla + lagrad(:,i) = original_qmg(:,mm%la%links(3,i)) + end do + call link_atom_project_grd(mm%la, lagrad, qmg, mmg) + call mfree('qm_helper_linkatom_geomgrad [lagrad]', lagrad) + + call link_atom_bond_geomgrad(mm%la, & + qmg, mmg, & + .true., .false.) + call link_atom_angle_geomgrad(mm%la, & + qmg, mmg, & + .true., .false.) + call link_atom_torsion_geomgrad(mm%la, & + qmg, mmg, & + .true., .false.) + + end if + end subroutine + + subroutine qm_helper_terminate(qm) + use mod_memory, only: mfree + use mod_topology, only: topology_terminate + use mod_nonbonded, only: vdw_terminate + + implicit none + type(ommp_qm_helper), intent(inout) :: qm + + call mfree('qm_helper_terminate [qqm]', qm%qqm) + if(allocated(qm%qm_vdw)) then + call vdw_terminate(qm%qm_vdw) + deallocate(qm%qm_vdw) + qm%use_nonbonded = .false. + end if + if(allocated(qm%qm_top)) then + call topology_terminate(qm%qm_top) + deallocate(qm%qm_top) + end if + end subroutine + + subroutine electrostatic_for_ene(system, qm) + !! Computes the electrostatic quantities (that means nuclear-MM + !! interaction terms) needed to perform an energy calculation. + !! Computes: + !! (1) EF of nuclei at polarizable sites + !! (2) V of the whole MM system at QM sites + use mod_memory, only: mallocate + use mod_electrostatics, only: potential_M2E, potential_D2E, & + q_elec_prop, coulomb_kernel + + implicit none + + type(ommp_system), intent(in) :: system + type(ommp_qm_helper), intent(inout) :: qm + + real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), & + tmpHE(10) + integer(ip) :: i, j + + if(.not. qm%E_n2p_done) then + if(.not. allocated(qm%E_n2p)) then + call mallocate('electrostatic_for_ene [E_n2p]', & + 3, system%eel%pol_atoms, qm%E_n2p) + end if + + qm%E_n2p = 0.0 + do i=1, qm%qm_top%mm_atoms + do j=1, system%eel%pol_atoms + dr = system%eel%cpol(:,j) - qm%qm_top%cmm(:,i) + call coulomb_kernel(dr, 1, kernel) + + tmpE = 0.0 + call q_elec_prop(qm%qqm(i), dr, kernel, & + .false., tmpV, & + .true., tmpE, & + .false., tmpEgr, & + .false., tmpHE) + + qm%E_n2p(:,j) = qm%E_n2p(:,j) + tmpE + end do + end do + qm%E_n2p_done = .true. + end if + + if(.not. qm%V_m2n_done) then + if(.not. allocated(qm%V_m2n)) then + call mallocate('electrostatic_for_ene [V_m2n]', & + qm%qm_top%mm_atoms, qm%V_m2n) + end if + + qm%V_m2n = 0.0 + call potential_M2E(system%eel, qm%qm_top%cmm, qm%V_m2n) + qm%V_m2n_done = .true. + end if + + if(.not. qm%V_p2n_done .and. system%eel%ipd_done) then + if(.not. allocated(qm%V_p2n)) then + call mallocate('electrostatic_for_ene [V_p2n]', & + qm%qm_top%mm_atoms, qm%V_p2n) + end if + + qm%V_p2n = 0.0 + call potential_D2E(system%eel, qm%qm_top%cmm, qm%V_p2n) + qm%V_p2n_done = .true. + endif + + if(.not. qm%V_pp2n_done .and. system%eel%ipd_done .and. qm%V_pp2n_req) then + if(.not. allocated(qm%V_pp2n)) then + call mallocate('electrostatic_for_ene [V_pp2n]', & + qm%qm_top%mm_atoms, qm%V_pp2n) + end if + + qm%V_pp2n = 0.0 + call potential_D2E(system%eel, qm%qm_top%cmm, qm%V_pp2n, .true.) + qm%V_pp2n_done = .true. + endif + + end subroutine + + subroutine electrostatic_for_grad(system, qm) + !! Computes the electrostatic quantities (that means nuclear-MM + !! interaction terms) needed to perform a gradient calculation. + !! Computes: + !! (1) GEF on nuclei at polarizable sites + !! (2) EF, GEF, HEF of nuclei at static sites + !! (3) EF of whole MM system at QM sites + use mod_memory, only: mallocate + use mod_electrostatics, only: field_M2E, field_D2E, & + q_elec_prop, coulomb_kernel + + implicit none + + type(ommp_system), intent(in) :: system + type(ommp_qm_helper), intent(inout) :: qm + + real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), & + tmpHE(10) + integer(ip) :: i, j + + if(.not. allocated(qm%G_n2p)) then + call mallocate('electrostatic_for_ene [G_n2p]', & + 6, system%eel%pol_atoms, qm%G_n2p) + end if + if(.not. allocated(qm%E_n2m)) then + call mallocate('electrostatic_for_ene [E_n2m]', & + 3, system%top%mm_atoms, qm%E_n2m) + end if + if(.not. allocated(qm%G_n2m)) then + call mallocate('electrostatic_for_ene [G_n2m]', & + 6, system%top%mm_atoms, qm%G_n2m) + end if + if(.not. allocated(qm%H_n2m)) then + call mallocate('electrostatic_for_ene [H_n2m]', & + 10, system%top%mm_atoms, qm%H_n2m) + end if + + qm%E_n2m = 0.0 + qm%G_n2m = 0.0 + qm%H_n2m = 0.0 + + do i=1, qm%qm_top%mm_atoms + do j=1, system%top%mm_atoms + dr = system%top%cmm(:,j) - qm%qm_top%cmm(:,i) + call coulomb_kernel(dr, 3, kernel) + + tmpE = 0.0 + tmpEgr = 0.0 + tmpHE = 0.0 + call q_elec_prop(qm%qqm(i), dr, kernel, & + .false., tmpV, & + .true., tmpE, & + .true., tmpEgr, & + .true., tmpHE) + + qm%E_n2m(:,j) = qm%E_n2m(:,j) + tmpE + qm%G_n2m(:,j) = qm%G_n2m(:,j) + tmpEgr + qm%H_n2m(:,j) = qm%H_n2m(:,j) + tmpHE + end do + end do + + qm%E_n2m_done = .true. + qm%G_n2m_done = .true. + qm%H_n2m_done = .true. + + do j=1, system%eel%pol_atoms + qm%G_n2p(:,j) = qm%G_n2m(:,system%eel%polar_mm(j)) + end do + qm%G_n2p_done = .true. + + if(.not. allocated(qm%E_m2n)) then + call mallocate('electrostatic_for_ene [E_m2n]', & + 3, qm%qm_top%mm_atoms, qm%E_m2n) + end if + qm%E_m2n = 0.0 + call field_M2E(system%eel, qm%qm_top%cmm, qm%E_m2n) + qm%E_m2n_done = .true. + + if(.not. allocated(qm%E_p2n)) then + call mallocate('electrostatic_for_ene [E_p2n]', & + 3, qm%qm_top%mm_atoms, qm%E_p2n) + end if + qm%E_p2n = 0.0 + call field_D2E(system%eel, qm%qm_top%cmm, qm%E_p2n) + qm%E_p2n_done = .true. + end subroutine +end module diff --git a/src/mod_qm_helper.f90 b/src/mod_qm_helper.f90 deleted file mode 100644 index 2be54c7..0000000 --- a/src/mod_qm_helper.f90 +++ /dev/null @@ -1,521 +0,0 @@ -module mod_qm_helper -!! This is an utility module, that is not actually used my openMMpol itself, -!! but can be initialized and used by a QM program interfaced with openMMPol -!! to simplify certain steps of the interface using already well tested code. - - use mod_memory, only: ip, rp, lp - use mod_mmpol, only: ommp_system - use mod_topology, only: ommp_topology_type - use mod_nonbonded, only: ommp_nonbonded_type - - implicit none - private - - type ommp_qm_helper - type(ommp_topology_type), allocatable :: qm_top - !! Topology of the QM system - logical(lp) :: reconnect = .false. - !! Flag to decide if the topology should be rebuily - !! at each change of geometry. - real(rp), allocatable :: qqm(:) - !! Charges of QM nuclei - logical(lp) :: E_n2p_done = .false. - !! Flag for [[E_n2p]] - real(rp), allocatable :: E_n2p(:,:) - !! Electric field of nuclei at polarizable sites - logical(lp) :: G_n2p_done = .false. - !! Flag for [[G_n2p]] - real(rp), allocatable :: G_n2p(:,:) - !! Electric field gradients of nuclei at polarizable sites - logical(lp) :: E_n2m_done = .false. - !! Flag for [[E_n2m]] - real(rp), allocatable :: E_n2m(:,:) - !! Electric field of nuclei at static sites - logical(lp) :: G_n2m_done = .false. - !! Flag for [[G_n2m]] - real(rp), allocatable :: G_n2m(:,:) - !! Electric field gradients of nuclei at static sites - logical(lp) :: H_n2m_done = .false. - !! Flag for [[H_n2m]] - real(rp), allocatable :: H_n2m(:,:) - !! Electric field Hessian of nuclei at static sites - logical(lp) :: V_m2n_done = .false. - !! Flag for [[V_m2n]] - real(rp), allocatable :: V_m2n(:) - !! Electrostatic potential of MMPol atoms (static) at QM nuclei - logical(lp) :: E_m2n_done = .false. - !! Flag for [[E_m2n]] - real(rp), allocatable :: E_m2n(:,:) - !! Electrostatic potential of MMPol atoms (static) at QM nuclei - logical(lp) :: V_p2n_done = .false. - !! Flag for [[V_p2n]] - real(rp), allocatable :: V_p2n(:) - !! Electrostatic potential of MMPol atoms (polarizable) at QM nuclei - logical(lp) :: V_pp2n_done = .false. - !! Flag for [[V_pp2n]] - logical(lp) :: V_pp2n_req = .false. - !! Flag to enable the computation of V_pp2n, this is only needed in some - !! wired cases like when using qm_helper as driver for DFTB - real(rp), allocatable :: V_pp2n(:) - !! Electrostatic potential of MMPol atoms (polarizable, AMOEBA P dipoles) at QM nuclei - logical(lp) :: E_p2n_done = .false. - !! Flag for [[E_p2n]] - real(rp), allocatable :: E_p2n(:,:) - !! Electrostatic potential of MMPol atoms (polarizable) at QM nuclei - logical(lp) :: use_nonbonded = .false. - !! Flag for using QM nonbonded terms - type(ommp_nonbonded_type), allocatable :: qm_vdw - !! Structure to store VdW parameter for QM atoms - end type ommp_qm_helper - - public :: ommp_qm_helper - public :: qm_helper_init, qm_helper_terminate - public :: qm_helper_init_vdw, qm_helper_init_vdw_prm, & - qm_helper_vdw_energy, qm_helper_vdw_geomgrad, & - qm_helper_update_coord, qm_helper_set_attype, & - qm_helper_link_atom_geomgrad - public :: electrostatic_for_ene, electrostatic_for_grad - - contains - subroutine qm_helper_init(qm, qmat, cqm, qqm, zqm) - use mod_memory, only: mallocate - use mod_topology, only: topology_init, guess_connectivity - - implicit none - type(ommp_qm_helper), intent(inout) :: qm - !! [[ommp_qm_helper]] object to be initialized - real(rp), intent(in) :: cqm(:,:) - !! Coordinates of QM atoms - real(rp), intent(in) :: qqm(:) - !! Nuclear charges of QM atoms - integer(ip), intent(in) :: zqm(:) - !! Atomic number of QM atoms - integer(ip), intent(in) :: qmat - !! Number of QM atoms - - allocate(qm%qm_top) - call mallocate('qm_helper_init [qqm]', qmat, qm%qqm) - - call topology_init(qm%qm_top, qmat) - qm%qm_top%cmm = cqm - qm%qm_top%atz = zqm - qm%qm_top%atz_initialized = .true. - qm%qqm = qqm - - call guess_connectivity(qm%qm_top) - end subroutine - - subroutine qm_helper_set_attype(qm, attype) - implicit none - - type(ommp_qm_helper), intent(inout) :: qm - integer(ip), intent(in) :: attype(qm%qm_top%mm_atoms) - - qm%qm_top%attype = attype - qm%qm_top%attype_initialized = .true. - end subroutine - - subroutine qm_helper_update_coord(qm, cnew, reconnect_in, linkatoms) - use mod_adjacency_mat, only: matfree - use mod_topology, only: guess_connectivity - use mod_io, only: ommp_message - use mod_constants, only: OMMP_VERBOSE_LOW - - implicit none - type(ommp_qm_helper), intent(inout) :: qm - !! [[ommp_qm_helper]] object to be initialized - real(rp), intent(in) :: cnew(3,qm%qm_top%mm_atoms) - !! Coordinates of QM atoms - logical(lp), intent(in), optional :: reconnect_in - !! Flag to rebuil connectivity - integer(ip), intent(in), optional :: linkatoms(:) - !! Atoms that should be considered link atoms - - integer(ip) :: i - logical(lp) :: rc - - if(present(reconnect_in)) then - rc = reconnect_in - else - rc = qm%reconnect - end if - - qm%qm_top%cmm = cnew - qm%E_n2p_done = .false. - qm%G_n2p_done = .false. - qm%E_n2m_done = .false. - qm%G_n2m_done = .false. - qm%H_n2m_done = .false. - qm%V_m2n_done = .false. - qm%E_m2n_done = .false. - if(rc) then - call ommp_message("Rebuilding connectivity.", OMMP_VERBOSE_LOW, 'linkatom') - do i=1, size(qm%qm_top%conn) - call matfree(qm%qm_top%conn(i)) - end do - deallocate(qm%qm_top%conn) - allocate(qm%qm_top%conn(1)) - - call guess_connectivity(qm%qm_top, linkatoms) - end if - end subroutine - - subroutine qm_helper_init_vdw(qm, eps, rad, fac, & - vdw_type, radius_rule, radius_size, & - radius_type, epsrule) - use mod_memory, only: mallocate - use mod_nonbonded, only: vdw_init - use mod_io, only: fatal_error - use mod_constants, only: OMMP_DEFAULT_NL_CUTOFF - - implicit none - - type(ommp_qm_helper), intent(inout) :: qm - real(rp), intent(in) :: eps(qm%qm_top%mm_atoms) - real(rp), intent(in) :: rad(qm%qm_top%mm_atoms) - real(rp), intent(in) :: fac(qm%qm_top%mm_atoms) - character(len=*) :: vdw_type, radius_rule, radius_size, & - radius_type, epsrule - - if(qm%use_nonbonded) then - call fatal_error("VdW is already initialized!") - end if - - allocate(qm%qm_vdw) - - call vdw_init(qm%qm_vdw, qm%qm_top, vdw_type, radius_rule, & - radius_size, radius_type, epsrule, OMMP_DEFAULT_NL_CUTOFF) - - qm%qm_vdw%vdw_e = eps - qm%qm_vdw%vdw_r = rad - qm%qm_vdw%vdw_f = fac - qm%use_nonbonded = .true. - - end subroutine - - subroutine qm_helper_init_vdw_prm(qm, prmfile) - !! Assign vdw parameters of the QM part from attype and prm file - use mod_prm, only: assign_vdw - use mod_io, only: fatal_error, large_file_read - use mod_constants, only: OMMP_STR_CHAR_MAX - use mod_utils, only: str_to_lower, str_uncomment - - implicit none - - type(ommp_qm_helper), intent(inout) :: qm - character(len=*), intent(in) :: prmfile - - character(len=OMMP_STR_CHAR_MAX), allocatable :: prm_buf(:) - integer(ip) :: ist, i - - if(qm%use_nonbonded) then - call fatal_error("VdW is already initialized!") - end if - - if(.not. qm%qm_top%attype_initialized) then - call fatal_error("Set the types for QM helper atoms before & - &requesting creation of VdW.") - end if - - call large_file_read(prmfile, prm_buf) - ! Remove comments from prm file - !$omp parallel do - do i=1, size(prm_buf) - prm_buf(i) = str_to_lower(prm_buf(i)) - prm_buf(i) = str_uncomment(prm_buf(i), '!') - end do - - allocate(qm%qm_vdw) - call assign_vdw(qm%qm_vdw, qm%qm_top, prm_buf) - qm%use_nonbonded = .true. - deallocate(prm_buf) - end subroutine - - subroutine qm_helper_vdw_energy(qm, mm, V) - use mod_nonbonded, only: vdw_potential_inter, vdw_potential_inter_restricted - use mod_mmpol, only: ommp_system - use mod_link_atom, only: link_atom_update_merged_topology - - implicit none - - type(ommp_system), intent(inout) :: mm - type(ommp_qm_helper), intent(in) :: qm - real(rp), intent(inout) :: V - - - if(mm%use_nonbonded .and. qm%use_nonbonded) then - call vdw_potential_inter(mm%vdw, qm%qm_vdw, V) - if(mm%use_linkatoms) then - call link_atom_update_merged_topology(mm%la) - ! Screening due to the presence of link atom - call vdw_potential_inter_restricted(mm%vdw, qm%qm_vdw, & - mm%la%vdw_screening_pairs,& - mm%la%vdw_screening_f, & - mm%la%vdw_n_screening, V) - end if - end if - - end subroutine - - subroutine qm_helper_vdw_geomgrad(qm, mm, qmg, mmg) - use mod_nonbonded, only: vdw_geomgrad_inter, & - vdw_geomgrad_inter_restricted - use mod_mmpol, only: ommp_system - use mod_link_atom, only: link_atom_update_merged_topology - - implicit none - - type(ommp_system), intent(inout) :: mm - type(ommp_qm_helper), intent(in) :: qm - real(rp), intent(inout) :: qmg(3,qm%qm_top%mm_atoms), & - mmg(3,mm%top%mm_atoms) - - if(mm%use_nonbonded .and. qm%use_nonbonded) then - call vdw_geomgrad_inter(mm%vdw, qm%qm_vdw, mmg, qmg) - if(mm%use_linkatoms) then - call link_atom_update_merged_topology(mm%la) - ! Screening due to the presence of link atom - call vdw_geomgrad_inter_restricted(mm%vdw, qm%qm_vdw, & - mm%la%vdw_screening_pairs,& - mm%la%vdw_screening_f, & - mm%la%vdw_n_screening, & - mmg, qmg) - end if - end if - end subroutine - - subroutine qm_helper_link_atom_geomgrad(qm, mm, qmg, mmg, original_qmg) - !! Computes the missing gradients for QM/MM linkatoms - !! that is bonded terms on QM atoms, LA forces projection on QM and MM - !! atoms. To obtain the correct forces in output, qmg should already - !! contain the QM forces, so that LA forces could be projected on - !! QM and MM force vectors - - use mod_mmpol, only: ommp_system - use mod_link_atom, only: link_atom_update_merged_topology, & - link_atom_bond_geomgrad, & - link_atom_angle_geomgrad, & - link_atom_torsion_geomgrad, & - link_atom_project_grd - use mod_memory, only: mallocate, mfree - - implicit none - - type(ommp_system), intent(inout) :: mm - type(ommp_qm_helper), intent(in) :: qm - real(rp), intent(inout) :: qmg(3,qm%qm_top%mm_atoms), & - mmg(3,mm%top%mm_atoms) - real(rp), intent(in) :: original_qmg(3,qm%qm_top%mm_atoms) - - real(rp), allocatable :: lagrad(:,:) - integer(ip) :: i - - if(mm%use_linkatoms) then - call link_atom_update_merged_topology(mm%la) - - call mallocate('qm_helper_linkatom_geomgrad [lagrad]', 3, mm%la%nla, lagrad) - do i=1, mm%la%nla - lagrad(:,i) = original_qmg(:,mm%la%links(3,i)) - end do - call link_atom_project_grd(mm%la, lagrad, qmg, mmg) - call mfree('qm_helper_linkatom_geomgrad [lagrad]', lagrad) - - call link_atom_bond_geomgrad(mm%la, & - qmg, mmg, & - .true., .false.) - call link_atom_angle_geomgrad(mm%la, & - qmg, mmg, & - .true., .false.) - call link_atom_torsion_geomgrad(mm%la, & - qmg, mmg, & - .true., .false.) - - end if - end subroutine - - subroutine qm_helper_terminate(qm) - use mod_memory, only: mfree - use mod_topology, only: topology_terminate - use mod_nonbonded, only: vdw_terminate - - implicit none - type(ommp_qm_helper), intent(inout) :: qm - - call mfree('qm_helper_terminate [qqm]', qm%qqm) - if(allocated(qm%qm_vdw)) then - call vdw_terminate(qm%qm_vdw) - deallocate(qm%qm_vdw) - qm%use_nonbonded = .false. - end if - if(allocated(qm%qm_top)) then - call topology_terminate(qm%qm_top) - deallocate(qm%qm_top) - end if - end subroutine - - subroutine electrostatic_for_ene(system, qm) - !! Computes the electrostatic quantities (that means nuclear-MM - !! interaction terms) needed to perform an energy calculation. - !! Computes: - !! (1) EF of nuclei at polarizable sites - !! (2) V of the whole MM system at QM sites - use mod_memory, only: mallocate - use mod_electrostatics, only: potential_M2E, potential_D2E, & - q_elec_prop, coulomb_kernel - - implicit none - - type(ommp_system), intent(in) :: system - type(ommp_qm_helper), intent(inout) :: qm - - real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), & - tmpHE(10) - integer(ip) :: i, j - - if(.not. qm%E_n2p_done) then - if(.not. allocated(qm%E_n2p)) then - call mallocate('electrostatic_for_ene [E_n2p]', & - 3, system%eel%pol_atoms, qm%E_n2p) - end if - - qm%E_n2p = 0.0 - do i=1, qm%qm_top%mm_atoms - do j=1, system%eel%pol_atoms - dr = system%eel%cpol(:,j) - qm%qm_top%cmm(:,i) - call coulomb_kernel(dr, 1, kernel) - - tmpE = 0.0 - call q_elec_prop(qm%qqm(i), dr, kernel, & - .false., tmpV, & - .true., tmpE, & - .false., tmpEgr, & - .false., tmpHE) - - qm%E_n2p(:,j) = qm%E_n2p(:,j) + tmpE - end do - end do - qm%E_n2p_done = .true. - end if - - if(.not. qm%V_m2n_done) then - if(.not. allocated(qm%V_m2n)) then - call mallocate('electrostatic_for_ene [V_m2n]', & - qm%qm_top%mm_atoms, qm%V_m2n) - end if - - qm%V_m2n = 0.0 - call potential_M2E(system%eel, qm%qm_top%cmm, qm%V_m2n) - qm%V_m2n_done = .true. - end if - - if(.not. qm%V_p2n_done .and. system%eel%ipd_done) then - if(.not. allocated(qm%V_p2n)) then - call mallocate('electrostatic_for_ene [V_p2n]', & - qm%qm_top%mm_atoms, qm%V_p2n) - end if - - qm%V_p2n = 0.0 - call potential_D2E(system%eel, qm%qm_top%cmm, qm%V_p2n) - qm%V_p2n_done = .true. - endif - - if(.not. qm%V_pp2n_done .and. system%eel%ipd_done .and. qm%V_pp2n_req) then - if(.not. allocated(qm%V_pp2n)) then - call mallocate('electrostatic_for_ene [V_pp2n]', & - qm%qm_top%mm_atoms, qm%V_pp2n) - end if - - qm%V_pp2n = 0.0 - call potential_D2E(system%eel, qm%qm_top%cmm, qm%V_pp2n, .true.) - qm%V_pp2n_done = .true. - endif - - end subroutine - - subroutine electrostatic_for_grad(system, qm) - !! Computes the electrostatic quantities (that means nuclear-MM - !! interaction terms) needed to perform a gradient calculation. - !! Computes: - !! (1) GEF on nuclei at polarizable sites - !! (2) EF, GEF, HEF of nuclei at static sites - !! (3) EF of whole MM system at QM sites - use mod_memory, only: mallocate - use mod_electrostatics, only: field_M2E, field_D2E, & - q_elec_prop, coulomb_kernel - - implicit none - - type(ommp_system), intent(in) :: system - type(ommp_qm_helper), intent(inout) :: qm - - real(rp) :: kernel(5), dr(3), tmpV, tmpE(3), tmpEgr(6), & - tmpHE(10) - integer(ip) :: i, j - - if(.not. allocated(qm%G_n2p)) then - call mallocate('electrostatic_for_ene [G_n2p]', & - 6, system%eel%pol_atoms, qm%G_n2p) - end if - if(.not. allocated(qm%E_n2m)) then - call mallocate('electrostatic_for_ene [E_n2m]', & - 3, system%top%mm_atoms, qm%E_n2m) - end if - if(.not. allocated(qm%G_n2m)) then - call mallocate('electrostatic_for_ene [G_n2m]', & - 6, system%top%mm_atoms, qm%G_n2m) - end if - if(.not. allocated(qm%H_n2m)) then - call mallocate('electrostatic_for_ene [H_n2m]', & - 10, system%top%mm_atoms, qm%H_n2m) - end if - - qm%E_n2m = 0.0 - qm%G_n2m = 0.0 - qm%H_n2m = 0.0 - - do i=1, qm%qm_top%mm_atoms - do j=1, system%top%mm_atoms - dr = system%top%cmm(:,j) - qm%qm_top%cmm(:,i) - call coulomb_kernel(dr, 3, kernel) - - tmpE = 0.0 - tmpEgr = 0.0 - tmpHE = 0.0 - call q_elec_prop(qm%qqm(i), dr, kernel, & - .false., tmpV, & - .true., tmpE, & - .true., tmpEgr, & - .true., tmpHE) - - qm%E_n2m(:,j) = qm%E_n2m(:,j) + tmpE - qm%G_n2m(:,j) = qm%G_n2m(:,j) + tmpEgr - qm%H_n2m(:,j) = qm%H_n2m(:,j) + tmpHE - end do - end do - - qm%E_n2m_done = .true. - qm%G_n2m_done = .true. - qm%H_n2m_done = .true. - - do j=1, system%eel%pol_atoms - qm%G_n2p(:,j) = qm%G_n2m(:,system%eel%polar_mm(j)) - end do - qm%G_n2p_done = .true. - - if(.not. allocated(qm%E_m2n)) then - call mallocate('electrostatic_for_ene [E_m2n]', & - 3, qm%qm_top%mm_atoms, qm%E_m2n) - end if - qm%E_m2n = 0.0 - call field_M2E(system%eel, qm%qm_top%cmm, qm%E_m2n) - qm%E_m2n_done = .true. - - if(.not. allocated(qm%E_p2n)) then - call mallocate('electrostatic_for_ene [E_p2n]', & - 3, qm%qm_top%mm_atoms, qm%E_p2n) - end if - qm%E_p2n = 0.0 - call field_D2E(system%eel, qm%qm_top%cmm, qm%E_p2n) - qm%E_p2n_done = .true. - end subroutine -end module diff --git a/src/mod_solvers.F90 b/src/mod_solvers.F90 new file mode 100644 index 0000000..32d8b62 --- /dev/null +++ b/src/mod_solvers.F90 @@ -0,0 +1,496 @@ +module mod_solvers + !! Module that contains the routines used to solve the polarization linear + !! system \(\mathbf A \mathbf x = \mathbf B\). + !! Currently three methods are implemented: + !! 1. __matrix inversion__; + !! 2. __(preconditioned) conjugate gradients__ - since polarization equations + !! are symmetric and positive definite, this is the optimal choice; + !! 3. __jacobi iterations__ accelerated with Pulay's direct inversion + !! in the iterative subspace (__DIIS__): this is a pretty robust solver that + !! can be use for general systems and that is less sensitive to small + !! errors in the symmetry of the matrix. + !! + !! Iterative solvers need two additional routines to be passed as arguments, + !! namely matvec that computes a generic product + !! \(\mathbf y = \mathbf A \mathbf v\) + !! and precond that computes \(\mathbf y = \mathbf M \mathbf v\), where + !! \(M\) is a precontioner + + use mod_memory, only: ip, rp + use mod_constants, only: OMMP_VERBOSE_HIGH, & + OMMP_VERBOSE_LOW, & + OMMP_VERBOSE_DEBUG, & + OMMP_STR_CHAR_MAX + use mod_io, only: ommp_message, fatal_error + use mod_electrostatics, only: ommp_electrostatics_type + + implicit none + private + + real(rp), parameter :: OMMP_DEFAULT_SOLVER_TOL = 1e-8_rp + !! Default tolerance for iterative solvers + integer(ip), parameter :: OMMP_DEFAULT_SOLVER_ITER = 200 + !! Default maximum number of iteration for iterative solvers + integer(ip), parameter :: OMMP_DEFAULT_DIIS_MAX_POINTS = 20 + !! Default maximum number of points in DIIS extrapolation + + public :: inversion_solver, conjugate_gradient_solver, jacobi_diis_solver + +contains + + subroutine inversion_solver(n, rhs, x, tmat) + !! Solve the linear system directly inverting the matrix: + !! $$\mathbf A \mathbf x = \mathbf B $$ + !! $$ \mathbf x = \mathbf A ^-1 \mathbf B $$ + !! This is highly unefficient and should only be used for testing + !! other methods of solution. + + use mod_memory, only: mallocate, mfree + + implicit none + + integer(ip), intent(in) :: n + !! Size of the matrix + real(rp), dimension(n), intent(in) :: rhs + !! Right hand side of the linear system + real(rp), dimension(n), intent(out) :: x + !! In output the solution of the linear system + real(rp), dimension(n, n), intent(in) :: tmat + !! Polarization matrix TODO + + integer(ip) :: info + integer(ip), dimension(:), allocatable :: ipiv + real(rp), dimension(:), allocatable :: work + real(rp), dimension(:,:), allocatable :: TMatI + + call mallocate('inversion_solver [TMatI]', n, n, TMatI) + call mallocate('inversion_solver [work]', n, work) + call mallocate('inversion_solver [ipiv]', n, ipiv) + + ! Initialize inverse polarization matrix + TMatI = TMat + + !Compute the inverse of TMat + call dgetrf(n, n, TMatI, n, iPiv, info) + call dgetri(n, TMatI, n, iPiv, Work, n, info) + + ! Calculate dipoles with matrix inversion + call dgemm('N', 'N', n, 1, n, 1.0_rp, TMatI, n, rhs, n, 0.0_rp, x, n) + + call mfree('inversion_solver [TMatI]', TMatI) + call mfree('inversion_solver [work]', work) + call mfree('inversion_solver [ipiv]', ipiv) + + end subroutine inversion_solver + + subroutine conjugate_gradient_solver(n, rhs, x, eel, matvec, precnd, & + arg_tol, arg_n_iter) + !! Conjugate gradient solver (TODO) + ! TODO add more printing + + use mod_constants, only: eps_rp + use mod_memory, only: mallocate, mfree + + implicit none + + integer(ip), intent(in) :: n + !! Size of the matrix + real(rp), intent(in), optional :: arg_tol + !! Optional convergence criterion in input, if not present + !! OMMP_DEFAULT_SOLVER_TOL is used. + real(rp) :: tol + !! Convergence criterion, it is required that RMS norm < tol + + integer(ip), intent(in), optional :: arg_n_iter + !! Optional maximum number of iterations for the solver, if not present + !! OMMP_DEFAULT_SOLVER_ITER is used. + integer(ip) :: n_iter + !! Maximum number of iterations for the solver + + real(rp), dimension(n), intent(in) :: rhs + !! Right hand side of the linear system + real(rp), dimension(n), intent(inout) :: x + !! In input, initial guess for the solver, in output the solution + type(ommp_electrostatics_type), intent(in) :: eel + !! Electrostatics data structure + external :: matvec + !! Routine to perform matrix-vector product + external :: precnd + !! Preconditioner routine + + integer(ip) :: it + real(rp) :: rms_norm, alpha, gnew, gold, gama + real(rp), allocatable :: r(:), p(:), h(:), z(:) + character(len=OMMP_STR_CHAR_MAX) :: msg + + ! Optional arguments handling + if(present(arg_tol)) then + tol = arg_tol + else + tol = OMMP_DEFAULT_SOLVER_TOL + end if + + if(present(arg_n_iter)) then + n_iter = arg_n_iter + else + n_iter = OMMP_DEFAULT_SOLVER_ITER + end if + + call ommp_message("Solving linear system with CG solver", OMMP_VERBOSE_LOW) + write(msg, "(A, I4)") "Max iter:", n_iter + call ommp_message(msg, OMMP_VERBOSE_LOW) + write(msg, "(A, E8.1)") "Tolerance: ", tol + call ommp_message(msg, OMMP_VERBOSE_LOW) + + call mallocate('conjugate_gradient_solver [r]', n, r) + call mallocate('conjugate_gradient_solver [p]', n, p) + call mallocate('conjugate_gradient_solver [h]', n, h) + call mallocate('conjugate_gradient_solver [z]', n, z) + + ! compute a guess, if required: + rms_norm = dot_product(x,x) + if(rms_norm < eps_rp) then + call ommp_message("Input guess has zero norm, generating a guess& + & from preconditioner.", OMMP_VERBOSE_HIGH) + call precnd(eel, x, x) + else + call ommp_message("Using input guess as a starting point for& + & iterative solver.", OMMP_VERBOSE_HIGH) + end if + + ! compute the residual: + call matvec(eel, x, z, .true.) + r = rhs - z + ! apply the preconditioner and get the first direction: + call precnd(eel, r, z) + p = z + gold = dot_product(r, z) + gama = 0.0_rp + + do it = 1, n_iter + ! compute the step: + call matvec(eel, p, h, .true.) + gama = dot_product(h, p) + + ! unlikely quick return: + if(abs(gama) < eps_rp) then + call ommp_message("Direction vector with zero norm, exiting & + &iterative solver.", OMMP_VERBOSE_HIGH) + exit + end if + + alpha = gold / gama + x = x + alpha * p + r = r - alpha * h + + ! apply the preconditioner: + call precnd(eel, r, z) + gnew = dot_product(r, z) + rms_norm = sqrt(gnew/dble(n)) + + write(msg, "('iter=',i4,' residual rms norm: ', d14.4)") it, rms_norm + call ommp_message(msg, OMMP_VERBOSE_HIGH) + + ! Check convergence + if(rms_norm < tol) then + call ommp_message("Required convergence threshold reached, & + &exiting iterative solver.", OMMP_VERBOSE_HIGH) + exit + end if + + ! compute the next direction: + gama = gnew/gold + p = gama*p + z + gold = gnew + end do + + call mfree('conjugate_gradient_solver [r]', r) + call mfree('conjugate_gradient_solver [p]', p) + call mfree('conjugate_gradient_solver [h]', h) + call mfree('conjugate_gradient_solver [z]', z) + + if(rms_norm > tol .and. abs(gama) > eps_rp) then + call fatal_error("Iterative solver did not converged") + end if + + end subroutine conjugate_gradient_solver + + subroutine jacobi_diis_solver(n, rhs, x, eel, matvec, inv_diag, arg_tol, & + arg_n_iter, arg_diis_max) + + use mod_constants, only: eps_rp + use mod_memory, only: mallocate, mfree + + implicit none + + integer(ip), intent(in) :: n + !! Size of the matrix + real(rp), intent(in), optional :: arg_tol + !! Optional convergence criterion in input, if not present + !! OMMP_DEFAULT_SOLVER_TOL is used. + real(rp) :: tol + !! Convergence criterion, it is required that RMS norm < tol + + integer(ip), intent(in), optional :: arg_n_iter + !! Optional maximum number of iterations for the solver, if not present + !! OMMP_DEFAULT_SOLVER_ITER is used. + integer(ip) :: n_iter + !! Maximum number of iterations for the solver + + integer(ip), intent(in), optional :: arg_diis_max + !! Optional maximum number of points for diis extrapolation, if not present + !! OMMP_DEFAULT_DIIS_MAX_POINTS is used. + integer(ip) :: diis_max + !! Maximum number of points for diis extrapolation, if zero or negative, + !! diis extrapolation is not used. + + real(rp), dimension(n), intent(in) :: rhs + !! Right hand side of the linear system + real(rp), dimension(n), intent(inout) :: x + !! In input, initial guess for the solver, in output the solution + type(ommp_electrostatics_type), intent(in) :: eel + !! Electrostatics data structure + real(rp), dimension(n), intent(in) :: inv_diag + !! Element-wise inverse of diagonal of LHS matrix + external :: matvec + !! Routine to perform matrix-vector product + + integer(ip) :: it, nmat + real(rp) :: rms_norm, max_norm + logical :: do_diis + real(rp), allocatable :: x_new(:), y(:), x_diis(:,:), e_diis(:,:), bmat(:,:) + character(len=OMMP_STR_CHAR_MAX) :: msg + + ! Optional arguments handling + if(present(arg_tol)) then + tol = arg_tol + else + tol = OMMP_DEFAULT_SOLVER_TOL + end if + + if(present(arg_n_iter)) then + n_iter = arg_n_iter + else + n_iter = OMMP_DEFAULT_SOLVER_ITER + end if + + if(present(arg_diis_max)) then + diis_max = arg_diis_max + else + diis_max = OMMP_DEFAULT_DIIS_MAX_POINTS + end if + + do_diis = (diis_max > 0) + + call ommp_message("Solving linear system with jacobi solver", OMMP_VERBOSE_LOW) + write(msg, "(A, I4)") "Max iter:", n_iter + call ommp_message(msg, OMMP_VERBOSE_LOW) + write(msg, "(A, E8.1)") "Tolerance: ", tol + call ommp_message(msg, OMMP_VERBOSE_LOW) + if(do_diis) then + write(msg, "(A, I4)") "DIIS is enabled with n = ", diis_max + else + write(msg, "(A)") "DIIS is disabled" + endif + call ommp_message(msg, OMMP_VERBOSE_LOW) + + ! Memory allocation + call mallocate('jacobi_diis_solver [x_new]', n, x_new) + call mallocate('jacobi_diis_solver [y]', n, y) + if(do_diis) then + call mallocate('jacobi_diis_solver [x_diis]', n, diis_max, x_diis) + call mallocate('jacobi_diis_solver [e_diis]', n, diis_max, e_diis) + call mallocate('jacobi_diis_solver [bmat]', diis_max+1, diis_max+1, bmat) + nmat = 1 + endif + + ! if required, compute a guess + rms_norm = dot_product(x, x) + if(rms_norm < eps_rp) then + call ommp_message("Input guess has zero norm, generating a guess& + & from preconditioner.", OMMP_VERBOSE_HIGH) + x = inv_diag * rhs + else + call ommp_message("Using input guess as a starting point for& + & iterative solver.", OMMP_VERBOSE_HIGH) + end if + + ! Jacobi iterations + do it = 1, n_iter + ! y = rhs - O x + call matvec(eel, x, y, .false.) + y = rhs - y + + ! x_new = D^-1 y + x_new = inv_diag * y + !call precnd(y, x_new) + + ! DIIS extrapolation + if(do_diis) then + x_diis(:,nmat) = x_new + e_diis(:,nmat) = x_new - x + call diis(n, nmat, diis_max, x_diis, e_diis, bmat, x_new) + endif + + ! increment + x = x_new - x + ! compute norm + call rmsvec(n, x, rms_norm, max_norm) + ! update + x = x_new + + write(msg, "('iter=',i4,' residual norm (rms, max): ', 2d14.4)") it, rms_norm, max_norm + call ommp_message(msg, OMMP_VERBOSE_HIGH) + + ! Check convergence + if(max_norm < tol) then + call ommp_message("Required convergence threshold reached, & + &exiting iterative solver.", OMMP_VERBOSE_HIGH) + exit + end if + enddo + + call mfree('jacobi_diis_solver [x_new]', x_new) + call mfree('jacobi_diis_solver [y]', y) + if(do_diis) then + call mfree('jacobi_diis_solver [x_diis]', x_diis) + call mfree('jacobi_diis_solver [e_diis]', e_diis) + call mfree('jacobi_diis_solver [bmat]', bmat) + endif + + if(max_norm > tol) then + call fatal_error("Iterative solver did not converged") + end if + + end subroutine jacobi_diis_solver + + subroutine diis(n,nmat,ndiis,x,e,b,xnew) + !! perform Pulay's direct inversion in the iterative subspace extrapolation: + use mod_memory, only: mallocate, mfree + + implicit none + ! TODO doc + integer(ip), intent(in) :: n, ndiis + integer(ip), intent(inout) :: nmat + real(rp), dimension(n, ndiis), intent(inout) :: x, e + real(rp), dimension(ndiis+1, ndiis+1), intent(inout) :: b + real(rp), dimension(n), intent(inout) :: xnew + + integer(ip) :: nmat1, i, info + integer(ip) :: j, k + + real(rp), allocatable :: bloc(:,:), cex(:) + integer(ip), allocatable :: ipiv(:) + + if (nmat.ge.ndiis) then + do j = 2, nmat - 10 + do k = 2, nmat - 10 + b(j,k) = b(j+10,k+10) + end do + end do + + do j = 1, nmat - 10 + x(:,j) = x(:,j+10) + e(:,j) = e(:,j+10) + end do + + nmat = nmat - 10 + end if + + nmat1 = nmat + 1 + + call mallocate('diis [bloc]', nmat1, nmat1, bloc) + call mallocate('diis [cex]', nmat1, cex) + call mallocate('diis [ipiv]', nmat1, ipiv) + + call makeb(n, nmat, ndiis, e, b) + bloc = b(1:nmat1,1:nmat1) + cex = 0.0_rp + cex(1) = 1.0_rp + + call dgesv(nmat1, 1, bloc, nmat1, ipiv, cex, nmat1, info) + + if(info /= 0) then + ! inversion failed. discard the previous points and restart. + nmat = 1 + call mfree('diis [bloc]', bloc) + call mfree('diis [cex]', cex) + call mfree('diis [ipiv]', ipiv) + return + end if + + xnew = 0.0_rp + do i = 1, nmat + xnew = xnew + cex(i+1)*x(:,i) + end do + nmat = nmat + 1 + + call mfree('diis [bloc]', bloc) + call mfree('diis [cex]', cex) + call mfree('diis [ipiv]', ipiv) + + end subroutine diis + + subroutine makeb(n,nmat,ndiis,e,b) + !! assemble the DIIS B matrix: + implicit none + + integer(ip), intent(in) :: n, nmat, ndiis + real(rp), dimension(n, ndiis), intent(in) :: e + real(rp), dimension(ndiis+1, ndiis+1), intent(inout) :: b + + integer(ip) :: i + real(rp) :: bij + + if(nmat == 1) then + ! 1st built: + ! [ 0 | 1 ] + ! b = [ --+---- ] + ! [ 1 | e*e ] + b(1,1) = 0.0_rp + b(1,2) = 1.0_rp + b(2,1) = 1.0_rp + b(2,2) = dot_product(e(:,1),e(:,1)) + else + ! subsequent builts + ! first, update the lagrangian line: + b(nmat+1,1) = 1.0_rp + b(1,nmat+1) = 1.0_rp + + ! now, compute the new matrix elements: + do i = 1, nmat - 1 + bij = dot_product(e(:,i),e(:,nmat)) + b(nmat+1,i+1) = bij + b(i+1,nmat+1) = bij + end do + + b(nmat+1,nmat+1) = dot_product(e(:,nmat),e(:,nmat)) + end if + end subroutine makeb + + subroutine rmsvec( n, v, vrms, vmax ) + !! compute root-mean-square and max norms of a vector. + implicit none + + integer(ip), intent(in) :: n + real(rp), dimension(n), intent(in) :: v + real(rp), intent(inout) :: vrms, vmax + + integer(ip) :: i + + ! initialize + vrms = 0.0_rp + vmax = 0.0_rp + + ! loop over entries + do i = 1, n + ! max norm + vmax = max(vmax,abs(v(i))) + ! rms norm + vrms = vrms + v(i)*v(i) + enddo + + vrms = sqrt(vrms/dble(n)) + end subroutine rmsvec + +end module mod_solvers diff --git a/src/mod_solvers.f90 b/src/mod_solvers.f90 deleted file mode 100644 index e949771..0000000 --- a/src/mod_solvers.f90 +++ /dev/null @@ -1,496 +0,0 @@ -module mod_solvers - !! Module that contains the routines used to solve the polarization linear - !! system \(\mathbf A \mathbf x = \mathbf B\). - !! Currently three methods are implemented: - !! 1. __matrix inversion__; - !! 2. __(preconditioned) conjugate gradients__ - since polarization equations - !! are symmetric and positive definite, this is the optimal choice; - !! 3. __jacobi iterations__ accelerated with Pulay's direct inversion - !! in the iterative subspace (__DIIS__): this is a pretty robust solver that - !! can be use for general systems and that is less sensitive to small - !! errors in the symmetry of the matrix. - !! - !! Iterative solvers need two additional routines to be passed as arguments, - !! namely matvec that computes a generic product - !! \(\mathbf y = \mathbf A \mathbf v\) - !! and precond that computes \(\mathbf y = \mathbf M \mathbf v\), where - !! \(M\) is a precontioner - - use mod_memory, only: ip, rp - use mod_constants, only: OMMP_VERBOSE_HIGH, & - OMMP_VERBOSE_LOW, & - OMMP_VERBOSE_DEBUG, & - OMMP_STR_CHAR_MAX - use mod_io, only: ommp_message, fatal_error - use mod_electrostatics, only: ommp_electrostatics_type - - implicit none - private - - real(rp), parameter :: OMMP_DEFAULT_SOLVER_TOL = 1e-8_rp - !! Default tolerance for iterative solvers - integer(ip), parameter :: OMMP_DEFAULT_SOLVER_ITER = 200 - !! Default maximum number of iteration for iterative solvers - integer(ip), parameter :: OMMP_DEFAULT_DIIS_MAX_POINTS = 20 - !! Default maximum number of points in DIIS extrapolation - - public :: inversion_solver, conjugate_gradient_solver, jacobi_diis_solver - - contains - - subroutine inversion_solver(n, rhs, x, tmat) - !! Solve the linear system directly inverting the matrix: - !! $$\mathbf A \mathbf x = \mathbf B $$ - !! $$ \mathbf x = \mathbf A ^-1 \mathbf B $$ - !! This is highly unefficient and should only be used for testing - !! other methods of solution. - - use mod_memory, only: mallocate, mfree - - implicit none - - integer(ip), intent(in) :: n - !! Size of the matrix - real(rp), dimension(n), intent(in) :: rhs - !! Right hand side of the linear system - real(rp), dimension(n), intent(out) :: x - !! In output the solution of the linear system - real(rp), dimension(n, n), intent(in) :: tmat - !! Polarization matrix TODO - - integer(ip) :: info - integer(ip), dimension(:), allocatable :: ipiv - real(rp), dimension(:), allocatable :: work - real(rp), dimension(:,:), allocatable :: TMatI - - call mallocate('inversion_solver [TMatI]', n, n, TMatI) - call mallocate('inversion_solver [work]', n, work) - call mallocate('inversion_solver [ipiv]', n, ipiv) - - ! Initialize inverse polarization matrix - TMatI = TMat - - !Compute the inverse of TMat - call dgetrf(n, n, TMatI, n, iPiv, info) - call dgetri(n, TMatI, n, iPiv, Work, n, info) - - ! Calculate dipoles with matrix inversion - call dgemm('N', 'N', n, 1, n, 1.0_rp, TMatI, n, rhs, n, 0.0_rp, x, n) - - call mfree('inversion_solver [TMatI]', TMatI) - call mfree('inversion_solver [work]', work) - call mfree('inversion_solver [ipiv]', ipiv) - - end subroutine inversion_solver - - subroutine conjugate_gradient_solver(n, rhs, x, eel, matvec, precnd, & - arg_tol, arg_n_iter) - !! Conjugate gradient solver (TODO) - ! TODO add more printing - - use mod_constants, only: eps_rp - use mod_memory, only: mallocate, mfree - - implicit none - - integer(ip), intent(in) :: n - !! Size of the matrix - real(rp), intent(in), optional :: arg_tol - !! Optional convergence criterion in input, if not present - !! OMMP_DEFAULT_SOLVER_TOL is used. - real(rp) :: tol - !! Convergence criterion, it is required that RMS norm < tol - - integer(ip), intent(in), optional :: arg_n_iter - !! Optional maximum number of iterations for the solver, if not present - !! OMMP_DEFAULT_SOLVER_ITER is used. - integer(ip) :: n_iter - !! Maximum number of iterations for the solver - - real(rp), dimension(n), intent(in) :: rhs - !! Right hand side of the linear system - real(rp), dimension(n), intent(inout) :: x - !! In input, initial guess for the solver, in output the solution - type(ommp_electrostatics_type), intent(in) :: eel - !! Electrostatics data structure - external :: matvec - !! Routine to perform matrix-vector product - external :: precnd - !! Preconditioner routine - - integer(ip) :: it - real(rp) :: rms_norm, alpha, gnew, gold, gama - real(rp), allocatable :: r(:), p(:), h(:), z(:) - character(len=OMMP_STR_CHAR_MAX) :: msg - - ! Optional arguments handling - if(present(arg_tol)) then - tol = arg_tol - else - tol = OMMP_DEFAULT_SOLVER_TOL - end if - - if(present(arg_n_iter)) then - n_iter = arg_n_iter - else - n_iter = OMMP_DEFAULT_SOLVER_ITER - end if - - call ommp_message("Solving linear system with CG solver", OMMP_VERBOSE_LOW) - write(msg, "(A, I4)") "Max iter:", n_iter - call ommp_message(msg, OMMP_VERBOSE_LOW) - write(msg, "(A, E8.1)") "Tolerance: ", tol - call ommp_message(msg, OMMP_VERBOSE_LOW) - - call mallocate('conjugate_gradient_solver [r]', n, r) - call mallocate('conjugate_gradient_solver [p]', n, p) - call mallocate('conjugate_gradient_solver [h]', n, h) - call mallocate('conjugate_gradient_solver [z]', n, z) - - ! compute a guess, if required: - rms_norm = dot_product(x,x) - if(rms_norm < eps_rp) then - call ommp_message("Input guess has zero norm, generating a guess& - & from preconditioner.", OMMP_VERBOSE_HIGH) - call precnd(eel, x, x) - else - call ommp_message("Using input guess as a starting point for& - & iterative solver.", OMMP_VERBOSE_HIGH) - end if - - ! compute the residual: - call matvec(eel, x, z, .true.) - r = rhs - z - ! apply the preconditioner and get the first direction: - call precnd(eel, r, z) - p = z - gold = dot_product(r, z) - gama = 0.0_rp - - do it = 1, n_iter - ! compute the step: - call matvec(eel, p, h, .true.) - gama = dot_product(h, p) - - ! unlikely quick return: - if(abs(gama) < eps_rp) then - call ommp_message("Direction vector with zero norm, exiting & - &iterative solver.", OMMP_VERBOSE_HIGH) - exit - end if - - alpha = gold / gama - x = x + alpha * p - r = r - alpha * h - - ! apply the preconditioner: - call precnd(eel, r, z) - gnew = dot_product(r, z) - rms_norm = sqrt(gnew/dble(n)) - - write(msg, "('iter=',i4,' residual rms norm: ', d14.4)") it, rms_norm - call ommp_message(msg, OMMP_VERBOSE_HIGH) - - ! Check convergence - if(rms_norm < tol) then - call ommp_message("Required convergence threshold reached, & - &exiting iterative solver.", OMMP_VERBOSE_HIGH) - exit - end if - - ! compute the next direction: - gama = gnew/gold - p = gama*p + z - gold = gnew - end do - - call mfree('conjugate_gradient_solver [r]', r) - call mfree('conjugate_gradient_solver [p]', p) - call mfree('conjugate_gradient_solver [h]', h) - call mfree('conjugate_gradient_solver [z]', z) - - if(rms_norm > tol .and. abs(gama) > eps_rp) then - call fatal_error("Iterative solver did not converged") - end if - - end subroutine conjugate_gradient_solver - - subroutine jacobi_diis_solver(n, rhs, x, eel, matvec, inv_diag, arg_tol, & - arg_n_iter, arg_diis_max) - - use mod_constants, only: eps_rp - use mod_memory, only: mallocate, mfree - - implicit none - - integer(ip), intent(in) :: n - !! Size of the matrix - real(rp), intent(in), optional :: arg_tol - !! Optional convergence criterion in input, if not present - !! OMMP_DEFAULT_SOLVER_TOL is used. - real(rp) :: tol - !! Convergence criterion, it is required that RMS norm < tol - - integer(ip), intent(in), optional :: arg_n_iter - !! Optional maximum number of iterations for the solver, if not present - !! OMMP_DEFAULT_SOLVER_ITER is used. - integer(ip) :: n_iter - !! Maximum number of iterations for the solver - - integer(ip), intent(in), optional :: arg_diis_max - !! Optional maximum number of points for diis extrapolation, if not present - !! OMMP_DEFAULT_DIIS_MAX_POINTS is used. - integer(ip) :: diis_max - !! Maximum number of points for diis extrapolation, if zero or negative, - !! diis extrapolation is not used. - - real(rp), dimension(n), intent(in) :: rhs - !! Right hand side of the linear system - real(rp), dimension(n), intent(inout) :: x - !! In input, initial guess for the solver, in output the solution - type(ommp_electrostatics_type), intent(in) :: eel - !! Electrostatics data structure - real(rp), dimension(n), intent(in) :: inv_diag - !! Element-wise inverse of diagonal of LHS matrix - external :: matvec - !! Routine to perform matrix-vector product - - integer(ip) :: it, nmat - real(rp) :: rms_norm, max_norm - logical :: do_diis - real(rp), allocatable :: x_new(:), y(:), x_diis(:,:), e_diis(:,:), bmat(:,:) - character(len=OMMP_STR_CHAR_MAX) :: msg - - ! Optional arguments handling - if(present(arg_tol)) then - tol = arg_tol - else - tol = OMMP_DEFAULT_SOLVER_TOL - end if - - if(present(arg_n_iter)) then - n_iter = arg_n_iter - else - n_iter = OMMP_DEFAULT_SOLVER_ITER - end if - - if(present(arg_diis_max)) then - diis_max = arg_diis_max - else - diis_max = OMMP_DEFAULT_DIIS_MAX_POINTS - end if - - do_diis = (diis_max > 0) - - call ommp_message("Solving linear system with jacobi solver", OMMP_VERBOSE_LOW) - write(msg, "(A, I4)") "Max iter:", n_iter - call ommp_message(msg, OMMP_VERBOSE_LOW) - write(msg, "(A, E8.1)") "Tolerance: ", tol - call ommp_message(msg, OMMP_VERBOSE_LOW) - if(do_diis) then - write(msg, "(A, I4)") "DIIS is enabled with n = ", diis_max - else - write(msg, "(A)") "DIIS is disabled" - endif - call ommp_message(msg, OMMP_VERBOSE_LOW) - - ! Memory allocation - call mallocate('jacobi_diis_solver [x_new]', n, x_new) - call mallocate('jacobi_diis_solver [y]', n, y) - if(do_diis) then - call mallocate('jacobi_diis_solver [x_diis]', n, diis_max, x_diis) - call mallocate('jacobi_diis_solver [e_diis]', n, diis_max, e_diis) - call mallocate('jacobi_diis_solver [bmat]', diis_max+1, diis_max+1, bmat) - nmat = 1 - endif - - ! if required, compute a guess - rms_norm = dot_product(x, x) - if(rms_norm < eps_rp) then - call ommp_message("Input guess has zero norm, generating a guess& - & from preconditioner.", OMMP_VERBOSE_HIGH) - x = inv_diag * rhs - else - call ommp_message("Using input guess as a starting point for& - & iterative solver.", OMMP_VERBOSE_HIGH) - end if - - ! Jacobi iterations - do it = 1, n_iter - ! y = rhs - O x - call matvec(eel, x, y, .false.) - y = rhs - y - - ! x_new = D^-1 y - x_new = inv_diag * y - !call precnd(y, x_new) - - ! DIIS extrapolation - if(do_diis) then - x_diis(:,nmat) = x_new - e_diis(:,nmat) = x_new - x - call diis(n, nmat, diis_max, x_diis, e_diis, bmat, x_new) - endif - - ! increment - x = x_new - x - ! compute norm - call rmsvec(n, x, rms_norm, max_norm) - ! update - x = x_new - - write(msg, "('iter=',i4,' residual norm (rms, max): ', 2d14.4)") it, rms_norm, max_norm - call ommp_message(msg, OMMP_VERBOSE_HIGH) - - ! Check convergence - if(max_norm < tol) then - call ommp_message("Required convergence threshold reached, & - &exiting iterative solver.", OMMP_VERBOSE_HIGH) - exit - end if - enddo - - call mfree('jacobi_diis_solver [x_new]', x_new) - call mfree('jacobi_diis_solver [y]', y) - if(do_diis) then - call mfree('jacobi_diis_solver [x_diis]', x_diis) - call mfree('jacobi_diis_solver [e_diis]', e_diis) - call mfree('jacobi_diis_solver [bmat]', bmat) - endif - - if(max_norm > tol) then - call fatal_error("Iterative solver did not converged") - end if - - end subroutine jacobi_diis_solver - - subroutine diis(n,nmat,ndiis,x,e,b,xnew) - !! perform Pulay's direct inversion in the iterative subspace extrapolation: - use mod_memory, only: mallocate, mfree - - implicit none - ! TODO doc - integer(ip), intent(in) :: n, ndiis - integer(ip), intent(inout) :: nmat - real(rp), dimension(n, ndiis), intent(inout) :: x, e - real(rp), dimension(ndiis+1, ndiis+1), intent(inout) :: b - real(rp), dimension(n), intent(inout) :: xnew - - integer(ip) :: nmat1, i, info - integer(ip) :: j, k - - real(rp), allocatable :: bloc(:,:), cex(:) - integer(ip), allocatable :: ipiv(:) - - if (nmat.ge.ndiis) then - do j = 2, nmat - 10 - do k = 2, nmat - 10 - b(j,k) = b(j+10,k+10) - end do - end do - - do j = 1, nmat - 10 - x(:,j) = x(:,j+10) - e(:,j) = e(:,j+10) - end do - - nmat = nmat - 10 - end if - - nmat1 = nmat + 1 - - call mallocate('diis [bloc]', nmat1, nmat1, bloc) - call mallocate('diis [cex]', nmat1, cex) - call mallocate('diis [ipiv]', nmat1, ipiv) - - call makeb(n, nmat, ndiis, e, b) - bloc = b(1:nmat1,1:nmat1) - cex = 0.0_rp - cex(1) = 1.0_rp - - call dgesv(nmat1, 1, bloc, nmat1, ipiv, cex, nmat1, info) - - if(info /= 0) then - ! inversion failed. discard the previous points and restart. - nmat = 1 - call mfree('diis [bloc]', bloc) - call mfree('diis [cex]', cex) - call mfree('diis [ipiv]', ipiv) - return - end if - - xnew = 0.0_rp - do i = 1, nmat - xnew = xnew + cex(i+1)*x(:,i) - end do - nmat = nmat + 1 - - call mfree('diis [bloc]', bloc) - call mfree('diis [cex]', cex) - call mfree('diis [ipiv]', ipiv) - - end subroutine diis - - subroutine makeb(n,nmat,ndiis,e,b) - !! assemble the DIIS B matrix: - implicit none - - integer(ip), intent(in) :: n, nmat, ndiis - real(rp), dimension(n, ndiis), intent(in) :: e - real(rp), dimension(ndiis+1, ndiis+1), intent(inout) :: b - - integer(ip) :: i - real(rp) :: bij - - if(nmat == 1) then - ! 1st built: - ! [ 0 | 1 ] - ! b = [ --+---- ] - ! [ 1 | e*e ] - b(1,1) = 0.0_rp - b(1,2) = 1.0_rp - b(2,1) = 1.0_rp - b(2,2) = dot_product(e(:,1),e(:,1)) - else - ! subsequent builts - ! first, update the lagrangian line: - b(nmat+1,1) = 1.0_rp - b(1,nmat+1) = 1.0_rp - - ! now, compute the new matrix elements: - do i = 1, nmat - 1 - bij = dot_product(e(:,i),e(:,nmat)) - b(nmat+1,i+1) = bij - b(i+1,nmat+1) = bij - end do - - b(nmat+1,nmat+1) = dot_product(e(:,nmat),e(:,nmat)) - end if - end subroutine makeb - - subroutine rmsvec( n, v, vrms, vmax ) - !! compute root-mean-square and max norms of a vector. - implicit none - - integer(ip), intent(in) :: n - real(rp), dimension(n), intent(in) :: v - real(rp), intent(inout) :: vrms, vmax - - integer(ip) :: i - - ! initialize - vrms = 0.0_rp - vmax = 0.0_rp - - ! loop over entries - do i = 1, n - ! max norm - vmax = max(vmax,abs(v(i))) - ! rms norm - vrms = vrms + v(i)*v(i) - enddo - - vrms = sqrt(vrms/dble(n)) - end subroutine rmsvec - -end module mod_solvers diff --git a/src/mod_topology.f90 b/src/mod_topology.F90 similarity index 100% rename from src/mod_topology.f90 rename to src/mod_topology.F90 diff --git a/src/mod_utils.f90 b/src/mod_utils.F90 similarity index 100% rename from src/mod_utils.f90 rename to src/mod_utils.F90 diff --git a/src/prm_keywords.F90 b/src/prm_keywords.F90 new file mode 100644 index 0000000..d726892 --- /dev/null +++ b/src/prm_keywords.F90 @@ -0,0 +1,383 @@ +function keyword_is_implemented(kw) + implicit none + + character(len=*), parameter :: imp_kwd(72) = ["angle ", & + "angle-cubic ", & + "anglep ", & + "angle-pentic ", & + "angle-quartic ", & + "angle-sextic ", & + "angtors ", & + "atom ", & + "bond ", & + "bond-cubic ", & + "bond-quartic ", & + "charge ", & + "chg-12-scale ", & + "chg-13-scale ", & + "chg-14-scale ", & + "chg-15-scale ", & + "direct-11-scale ", & + "direct-12-scale ", & + "direct-13-scale ", & + "direct-14-scale ", & + "electric ", & + "epsilonrule ", & + "imptors ", & + "induce-12-scale ", & + "induce-13-scale ", & + "induce-14-scale ", & + "induce-15-scale ", & + "mpole-12-scale ", & + "mpole-13-scale ", & + "mpole-14-scale ", & + "mpole-15-scale ", & + "multipole ", & + "mutual-11-scale ", & + "mutual-12-scale ", & + "mutual-13-scale ", & + "mutual-14-scale ", & + "opbend ", & + "opbend-cubic ", & + "opbend-pentic ", & + "opbend-quartic ", & + "opbend-sextic ", & + "opbendtype ", & + "pitors ", & + "polar-12-intra ", & + "polar-12-scale ", & + "polar-13-intra ", & + "polar-13-scale ", & + "polar-14-intra ", & + "polar-14-scale ", & + "polar-15-intra ", & + "polar-15-scale ", & + "polarization ", & + "polarize ", & + "radiusrule ", & + "radiustype ", & + "radiussize ", & + "strbnd ", & + "strtors ", & + "torsion ", & + "torsionunit ", & + "tortors ", & + "ureybrad ", & + "urey-cubic ", & + "urey-quartic ", & + "vdw ", & + "vdw-12-scale ", & + "vdw-13-scale ", & + "vdw-14-scale ", & + "vdw-15-scale ", & + "vdwtype ", & + "vdwpr ", & + "vdwpair "] + character(len=*) :: kw + integer(ip) :: i, l + logical :: keyword_is_implemented + + keyword_is_implemented = .false. + + do i = 1, size(imp_kwd) + l = len(trim(imp_kwd(i))) + if(imp_kwd(i)(1:l) == kw) then + keyword_is_implemented = .true. + exit + end if + end do +end function + + +function keyword_is_ignored(kw) + implicit none + + character(len=*), parameter :: ign_kwd(5) = [& + "biotype ", & + "forcefield ", & + "solute ", & + "dielectric ", & ! TODO + "anglef " & ! TODO + ] + character(len=*) :: kw + integer(ip) :: i, l + logical :: keyword_is_ignored + + keyword_is_ignored = .false. + + do i = 1, size(ign_kwd) + l = len(trim(ign_kwd(i))) + if(ign_kwd(i)(1:l) == kw) then + keyword_is_ignored = .true. + exit + end if + end do +end function + +function keyword_is_recognized(kw) + implicit none + + character(len=*), parameter :: rec_kwd(172) = ["a-expterm ", & + "angang ", & + "angangunit ", & + "angcflux ", & + "angle ", & + "angle3 ", & + "angle4 ", & + "angle5 ", & + "angle-cubic ", & + "anglef ", & + "anglep ", & + "angle-pentic ", & + "angle-quartic ", & + "angle-sextic ", & + "angleunit ", & + "angtors ", & + "angtorunit ", & + "atom ", & + "b-expterm ", & + "biotype ", & + "bond ", & + "bond3 ", & + "bond4 ", & + "bond5 ", & + "bond-cubic ", & + "bond-quartic ", & + "bondtype ", & + "bondunit ", & + "born-radius ", & + "c-expterm ", & + "charge ", & + "chargetransfer ", & + "chg-11-scale ", & + "chg-12-scale ", & + "chg-13-scale ", & + "chg-14-scale ", & + "chg-15-scale ", & + "chg-buffer ", & + "chgpen ", & + "chgtrn ", & + "deform ", & + "delta-halgren ", & + "d-equals-p ", & + "dielectric ", & + "dielectric-offset ", & + "diffuse-charge ", & + "diffuse-torsion ", & + "diffuse-vdw ", & + "dipole ", & + "dipole3 ", & + "dipole4 ", & + "dipole5 ", & + "direct-11-scale ", & + "direct-12-scale ", & + "direct-13-scale ", & + "direct-14-scale ", & + "disp-12-scale ", & + "disp-13-scale ", & + "disp-14-scale ", & + "disp-15-scale ", & + "disp-correction ", & + "dispersion ", & + "electneg ", & + "electric ", & + "epsilonrule ", & + "forcefield ", & + "gamma-halgren ", & + "gausstype ", & + "hbond ", & + "improper ", & + "impropterm ", & + "impropunit ", & + "imptors ", & + "imptorterm ", & + "imptorunit ", & + "induce-12-scale ", & + "induce-13-scale ", & + "induce-14-scale ", & + "induce-15-scale ", & + "mmffangle ", & + "mmffarom ", & + "mmffbci ", & + "mmffbond ", & + "mmffbonder ", & + "mmffcovrad ", & + "mmffdefstbn ", & + "mmffequiv ", & + "mmffopbend ", & + "mmffpbci ", & + "mmff-pibond ", & + "mmffprop ", & + "mmffstrbnd ", & + "mmfftorsion ", & + "mmffvdw ", & + "mpole-12-scale ", & + "mpole-13-scale ", & + "mpole-14-scale ", & + "mpole-15-scale ", & + "multipole ", & + "mutual-11-scale ", & + "mutual-12-scale ", & + "mutual-13-scale ", & + "mutual-14-scale ", & + "opbend ", & + "opbend-cubic ", & + "opbend-pentic ", & + "opbend-quartic ", & + "opbend-sextic ", & + "opbendtype ", & + "opbendunit ", & + "opdist ", & + "opdist-cubic ", & + "opdist-pentic ", & + "opdist-quartic ", & + "opdist-sextic ", & + "opdistunit ", & + "parameters ", & + "penetration ", & + "piatom ", & + "pibond ", & + "pibond4 ", & + "pibond5 ", & + "pisystem ", & + "pitors ", & + "pitorsunit ", & + "polar-12-intra ", & + "polar-12-scale ", & + "polar-13-intra ", & + "polar-13-scale ", & + "polar-14-intra ", & + "polar-14-scale ", & + "polar-15-intra ", & + "polar-15-scale ", & + "polar-eps ", & + "polarization ", & + "polarize ", & + "radiusrule ", & + "radiussize ", & + "radiustype ", & + "rep-12-scale ", & + "rep-13-scale ", & + "rep-14-scale ", & + "rep-15-scale ", & + "repulsion ", & + "smoothing ", & + "solute ", & + "solvate ", & + "strbnd ", & + "strbndunit ", & + "strtors ", & + "strtorunit ", & + "torsion ", & + "torsion4 ", & + "torsion5 ", & + "torsionunit ", & + "tortors ", & + "tortorunit ", & + "ureybrad ", & + "urey-cubic ", & + "urey-quartic ", & + "ureyunit ", & + "vdw ", & + "vdw-12-scale ", & + "vdw-13-scale ", & + "vdw14 ", & + "vdw-14-scale ", & + "vdw-15-scale ", & + "vdwindex ", & + "vdwpr ", & + "vdwpair ", & + "vdwterm ", & + "vdwtype "] + character(len=*) :: kw + integer(ip) :: i, l + logical :: keyword_is_recognized + + keyword_is_recognized = .false. + + do i = 1, size(rec_kwd) + l = len(trim(rec_kwd(i))) + if(rec_kwd(i)(1:l) == kw) then + keyword_is_recognized = .true. + exit + end if + end do +end function + +function check_keyword(prm_buf) + use mod_memory, only : ip + use mod_utils, only : starts_with_alpha, str_to_lower, tokenize + use mod_io, only : ommp_message + use mod_constants, only: OMMP_VERBOSE_HIGH, OMMP_VERBOSE_LOW + + implicit none + + character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) + !! name of the input PRM file + logical :: check_keyword + + integer(ip), parameter :: iof_prminp = 201 + integer(ip) :: ist, ibeg, iend + character(len=OMMP_STR_CHAR_MAX) :: line, kw, msg + + integer(ip), parameter :: nalready = 256 + character(len=OMMP_STR_CHAR_MAX) :: unrecog(nalready), ignored(nalready) + integer(ip) :: nunrecog = 0, nignored = 0, i,il + logical :: already_unr, already_ign + + check_keyword = .true. + + do il=1, size(prm_buf) + line = str_to_lower(prm_buf(il)) + + ! Only lines that start with a char do contain keyword + if(starts_with_alpha(line)) then + ibeg = 1 + iend = tokenize(line, ibeg) + kw = line(ibeg:iend) + if(keyword_is_recognized(kw)) then + if(.not. keyword_is_implemented(kw)) then + if(keyword_is_ignored(kw)) then + already_ign = .false. + do i=1, nignored + if(ignored(i) == trim(kw)) already_ign = .true. + end do + + if(.not. already_ign) then + write(msg, "(A)") "'"//trim(kw)//"' - keyword& + & ignored" + call ommp_message(msg, OMMP_VERBOSE_HIGH) + if(nignored < nalready) then + nignored = nignored + 1 + ignored(nignored) = trim(kw) + end if + end if + else + write(msg, "(A)") "'"//trim(kw)//"' - keyword& + & is not implemented and & + &cannot be ignored." + call ommp_message(msg, OMMP_VERBOSE_LOW) + check_keyword = .false. + end if + end if + else + already_unr = .false. + do i=1, nunrecog + if(unrecog(i) == trim(kw)) already_unr = .true. + end do + + if(.not. already_unr) then + write(msg, "(A)") "'"//trim(kw)//"' - keyword& + & is not recognized." + call ommp_message(msg, OMMP_VERBOSE_HIGH) + if(nunrecog < nalready) then + nunrecog = nunrecog + 1 + unrecog(nunrecog) = trim(kw) + end if + end if + end if + end if + end do + + close(iof_prminp) +end function diff --git a/src/prm_keywords.f90 b/src/prm_keywords.f90 deleted file mode 100644 index 8e6c31a..0000000 --- a/src/prm_keywords.f90 +++ /dev/null @@ -1,383 +0,0 @@ -function keyword_is_implemented(kw) - implicit none - - character(len=*), parameter :: imp_kwd(72) = ["angle ", & - "angle-cubic ", & - "anglep ", & - "angle-pentic ", & - "angle-quartic ", & - "angle-sextic ", & - "angtors ", & - "atom ", & - "bond ", & - "bond-cubic ", & - "bond-quartic ", & - "charge ", & - "chg-12-scale ", & - "chg-13-scale ", & - "chg-14-scale ", & - "chg-15-scale ", & - "direct-11-scale ", & - "direct-12-scale ", & - "direct-13-scale ", & - "direct-14-scale ", & - "electric ", & - "epsilonrule ", & - "imptors ", & - "induce-12-scale ", & - "induce-13-scale ", & - "induce-14-scale ", & - "induce-15-scale ", & - "mpole-12-scale ", & - "mpole-13-scale ", & - "mpole-14-scale ", & - "mpole-15-scale ", & - "multipole ", & - "mutual-11-scale ", & - "mutual-12-scale ", & - "mutual-13-scale ", & - "mutual-14-scale ", & - "opbend ", & - "opbend-cubic ", & - "opbend-pentic ", & - "opbend-quartic ", & - "opbend-sextic ", & - "opbendtype ", & - "pitors ", & - "polar-12-intra ", & - "polar-12-scale ", & - "polar-13-intra ", & - "polar-13-scale ", & - "polar-14-intra ", & - "polar-14-scale ", & - "polar-15-intra ", & - "polar-15-scale ", & - "polarization ", & - "polarize ", & - "radiusrule ", & - "radiustype ", & - "radiussize ", & - "strbnd ", & - "strtors ", & - "torsion ", & - "torsionunit ", & - "tortors ", & - "ureybrad ", & - "urey-cubic ", & - "urey-quartic ", & - "vdw ", & - "vdw-12-scale ", & - "vdw-13-scale ", & - "vdw-14-scale ", & - "vdw-15-scale ", & - "vdwtype ", & - "vdwpr ", & - "vdwpair "] - character(len=*) :: kw - integer(ip) :: i, l - logical :: keyword_is_implemented - - keyword_is_implemented = .false. - - do i = 1, size(imp_kwd) - l = len(trim(imp_kwd(i))) - if(imp_kwd(i)(1:l) == kw) then - keyword_is_implemented = .true. - exit - end if - end do -end function - - -function keyword_is_ignored(kw) - implicit none - - character(len=*), parameter :: ign_kwd(5) = [& - "biotype ", & - "forcefield ", & - "solute ", & - "dielectric ", & ! TODO - "anglef " & ! TODO - ] - character(len=*) :: kw - integer(ip) :: i, l - logical :: keyword_is_ignored - - keyword_is_ignored = .false. - - do i = 1, size(ign_kwd) - l = len(trim(ign_kwd(i))) - if(ign_kwd(i)(1:l) == kw) then - keyword_is_ignored = .true. - exit - end if - end do -end function - -function keyword_is_recognized(kw) - implicit none - - character(len=*), parameter :: rec_kwd(172) = ["a-expterm ", & - "angang ", & - "angangunit ", & - "angcflux ", & - "angle ", & - "angle3 ", & - "angle4 ", & - "angle5 ", & - "angle-cubic ", & - "anglef ", & - "anglep ", & - "angle-pentic ", & - "angle-quartic ", & - "angle-sextic ", & - "angleunit ", & - "angtors ", & - "angtorunit ", & - "atom ", & - "b-expterm ", & - "biotype ", & - "bond ", & - "bond3 ", & - "bond4 ", & - "bond5 ", & - "bond-cubic ", & - "bond-quartic ", & - "bondtype ", & - "bondunit ", & - "born-radius ", & - "c-expterm ", & - "charge ", & - "chargetransfer ", & - "chg-11-scale ", & - "chg-12-scale ", & - "chg-13-scale ", & - "chg-14-scale ", & - "chg-15-scale ", & - "chg-buffer ", & - "chgpen ", & - "chgtrn ", & - "deform ", & - "delta-halgren ", & - "d-equals-p ", & - "dielectric ", & - "dielectric-offset ", & - "diffuse-charge ", & - "diffuse-torsion ", & - "diffuse-vdw ", & - "dipole ", & - "dipole3 ", & - "dipole4 ", & - "dipole5 ", & - "direct-11-scale ", & - "direct-12-scale ", & - "direct-13-scale ", & - "direct-14-scale ", & - "disp-12-scale ", & - "disp-13-scale ", & - "disp-14-scale ", & - "disp-15-scale ", & - "disp-correction ", & - "dispersion ", & - "electneg ", & - "electric ", & - "epsilonrule ", & - "forcefield ", & - "gamma-halgren ", & - "gausstype ", & - "hbond ", & - "improper ", & - "impropterm ", & - "impropunit ", & - "imptors ", & - "imptorterm ", & - "imptorunit ", & - "induce-12-scale ", & - "induce-13-scale ", & - "induce-14-scale ", & - "induce-15-scale ", & - "mmffangle ", & - "mmffarom ", & - "mmffbci ", & - "mmffbond ", & - "mmffbonder ", & - "mmffcovrad ", & - "mmffdefstbn ", & - "mmffequiv ", & - "mmffopbend ", & - "mmffpbci ", & - "mmff-pibond ", & - "mmffprop ", & - "mmffstrbnd ", & - "mmfftorsion ", & - "mmffvdw ", & - "mpole-12-scale ", & - "mpole-13-scale ", & - "mpole-14-scale ", & - "mpole-15-scale ", & - "multipole ", & - "mutual-11-scale ", & - "mutual-12-scale ", & - "mutual-13-scale ", & - "mutual-14-scale ", & - "opbend ", & - "opbend-cubic ", & - "opbend-pentic ", & - "opbend-quartic ", & - "opbend-sextic ", & - "opbendtype ", & - "opbendunit ", & - "opdist ", & - "opdist-cubic ", & - "opdist-pentic ", & - "opdist-quartic ", & - "opdist-sextic ", & - "opdistunit ", & - "parameters ", & - "penetration ", & - "piatom ", & - "pibond ", & - "pibond4 ", & - "pibond5 ", & - "pisystem ", & - "pitors ", & - "pitorsunit ", & - "polar-12-intra ", & - "polar-12-scale ", & - "polar-13-intra ", & - "polar-13-scale ", & - "polar-14-intra ", & - "polar-14-scale ", & - "polar-15-intra ", & - "polar-15-scale ", & - "polar-eps ", & - "polarization ", & - "polarize ", & - "radiusrule ", & - "radiussize ", & - "radiustype ", & - "rep-12-scale ", & - "rep-13-scale ", & - "rep-14-scale ", & - "rep-15-scale ", & - "repulsion ", & - "smoothing ", & - "solute ", & - "solvate ", & - "strbnd ", & - "strbndunit ", & - "strtors ", & - "strtorunit ", & - "torsion ", & - "torsion4 ", & - "torsion5 ", & - "torsionunit ", & - "tortors ", & - "tortorunit ", & - "ureybrad ", & - "urey-cubic ", & - "urey-quartic ", & - "ureyunit ", & - "vdw ", & - "vdw-12-scale ", & - "vdw-13-scale ", & - "vdw14 ", & - "vdw-14-scale ", & - "vdw-15-scale ", & - "vdwindex ", & - "vdwpr ", & - "vdwpair ", & - "vdwterm ", & - "vdwtype "] - character(len=*) :: kw - integer(ip) :: i, l - logical :: keyword_is_recognized - - keyword_is_recognized = .false. - - do i = 1, size(rec_kwd) - l = len(trim(rec_kwd(i))) - if(rec_kwd(i)(1:l) == kw) then - keyword_is_recognized = .true. - exit - end if - end do -end function - -function check_keyword(prm_buf) - use mod_memory, only : ip - use mod_utils, only : starts_with_alpha, str_to_lower, tokenize - use mod_io, only : ommp_message - use mod_constants, only: OMMP_VERBOSE_HIGH, OMMP_VERBOSE_LOW - - implicit none - - character(len=OMMP_STR_CHAR_MAX), intent(in) :: prm_buf(:) - !! name of the input PRM file - logical :: check_keyword - - integer(ip), parameter :: iof_prminp = 201 - integer(ip) :: ist, ibeg, iend - character(len=OMMP_STR_CHAR_MAX) :: line, kw, msg - - integer(ip), parameter :: nalready = 256 - character(len=OMMP_STR_CHAR_MAX) :: unrecog(nalready), ignored(nalready) - integer(ip) :: nunrecog = 0, nignored = 0, i,il - logical :: already_unr, already_ign - - check_keyword = .true. - - do il=1, size(prm_buf) - line = str_to_lower(prm_buf(il)) - - ! Only lines that start with a char do contain keyword - if(starts_with_alpha(line)) then - ibeg = 1 - iend = tokenize(line, ibeg) - kw = line(ibeg:iend) - if(keyword_is_recognized(kw)) then - if(.not. keyword_is_implemented(kw)) then - if(keyword_is_ignored(kw)) then - already_ign = .false. - do i=1, nignored - if(ignored(i) == trim(kw)) already_ign = .true. - end do - - if(.not. already_ign) then - write(msg, "(A)") "'"//trim(kw)//"' - keyword& - & ignored" - call ommp_message(msg, OMMP_VERBOSE_HIGH) - if(nignored < nalready) then - nignored = nignored + 1 - ignored(nignored) = trim(kw) - end if - end if - else - write(msg, "(A)") "'"//trim(kw)//"' - keyword& - & is not implemented and & - &cannot be ignored." - call ommp_message(msg, OMMP_VERBOSE_LOW) - check_keyword = .false. - end if - end if - else - already_unr = .false. - do i=1, nunrecog - if(unrecog(i) == trim(kw)) already_unr = .true. - end do - - if(.not. already_unr) then - write(msg, "(A)") "'"//trim(kw)//"' - keyword& - & is not recognized." - call ommp_message(msg, OMMP_VERBOSE_HIGH) - if(nunrecog < nalready) then - nunrecog = nunrecog + 1 - unrecog(nunrecog) = trim(kw) - end if - end if - end if - end if - end do - - close(iof_prminp) -end function diff --git a/src/pyommp_interface.cpp b/src/pyommp_interface.cpp deleted file mode 100644 index 7e4f041..0000000 --- a/src/pyommp_interface.cpp +++ /dev/null @@ -1,1589 +0,0 @@ -#include "openmmpol.h" -#include -#include -#include -#include - -namespace py = pybind11; - -std::map solvers{ - {"none", OMMP_SOLVER_NONE}, - {"default", OMMP_SOLVER_DEFAULT}, - {"conjugate gradient", OMMP_SOLVER_CG}, - {"cg", OMMP_SOLVER_CG}, - {"inversion", OMMP_SOLVER_INVERSION}, - {"diis", OMMP_SOLVER_DIIS} -}; - -std::map matvs{ - {"none", OMMP_MATV_NONE}, - {"default", OMMP_MATV_DEFAULT}, - {"incore", OMMP_MATV_INCORE}, - {"direct", OMMP_MATV_DIRECT} -}; - -std::map verbosity{ - {"none", OMMP_VERBOSE_NONE}, - {"low", OMMP_VERBOSE_LOW}, - {"high", OMMP_VERBOSE_HIGH}, - {"debug", OMMP_VERBOSE_DEBUG} -}; - -typedef typename py::array_t py_ciarray; -typedef typename py::array_t py_cdarray; -typedef typename py::array_t py_cbarray; - -int getMaxValue(py_ciarray inputArray) { - if(inputArray.ndim() != 1){ - throw py::value_error("maximum can only be computed on 1-dimensional array."); - } - if (inputArray.size() == 0) { - throw py::value_error("input array is empty"); - } - - const int *ptr = inputArray.data(); - int size = inputArray.size(); - int maxVal = ptr[0]; - - for (int i = 1; i < size; i++) { - if (ptr[i] > maxVal) { - maxVal = ptr[i]; - } - } - - return maxVal; -} - -int getMinValue(py_ciarray inputArray) { - if(inputArray.ndim() != 1){ - throw py::value_error("maximum can only be computed on 1-dimensional array."); - } - if (inputArray.size() == 0) { - throw py::value_error("input array is empty"); - } - - const int *ptr = inputArray.data(); - int size = inputArray.size(); - int minVal = ptr[0]; - - for (int i = 1; i < size; i++) { - if (ptr[i] < minVal) { - minVal = ptr[i]; - } - } - - return minVal; -} - -double getMaxValue(py_cdarray inputArray) { - if(inputArray.ndim() != 1){ - throw py::value_error("maximum can only be computed on 1-dimensional array."); - } - if (inputArray.size() == 0) { - throw py::value_error("input array is empty"); - } - - const double *ptr = inputArray.data(); - int size = inputArray.size(); - double maxVal = ptr[0]; - - for (int i = 1; i < size; i++) { - if (ptr[i] > maxVal) { - maxVal = ptr[i]; - } - } - - return maxVal; -} - -double getMinValue(py_cdarray inputArray) { - if(inputArray.ndim() != 1){ - throw py::value_error("maximum can only be computed on 1-dimensional array."); - } - if (inputArray.size() == 0) { - throw py::value_error("input array is empty"); - } - - const double *ptr = inputArray.data(); - int size = inputArray.size(); - double minVal = ptr[0]; - - for (int i = 1; i < size; i++) { - if (ptr[i] < minVal) { - minVal = ptr[i]; - } - } - - return minVal; -} - - -class OMMPSystem; - -class OMMPQmHelper{ - public: - OMMPQmHelper(); - OMMPQmHelper(OMMP_QM_HELPER_PRT); - OMMPQmHelper(py_cdarray, py_cdarray, py_ciarray); - ~OMMPQmHelper(); - OMMP_QM_HELPER_PRT get_handler(void); - void set_frozen_atoms(py_ciarray frozen); - void update_coord(py_cdarray qmc); - void update_link_atoms_position(OMMPSystem& s); - void init_vdw_prm(std::string prmfile); - void set_attype(py_ciarray qm_attype); - void init_vdw(py_cdarray eps, py_cdarray rad, py_cdarray fac, - std::string vdw_type, std::string radius_rule, - std::string radius_size, std::string radius_type, - std::string eps_rule); - double vdw_energy(OMMPSystem& s); - std::map vdw_geomgrad(OMMPSystem& s); - std::map link_atom_geomgrad(OMMPSystem& s, py_cdarray old_qmg); - void prepare_qm_ele_ene(OMMPSystem& s); - void prepare_qm_ele_grd(OMMPSystem& s); - int32_t get_qm_atoms(void); - int32_t get_npol(void); - int32_t get_nmm(void); - py_cdarray get_cqm(void); - py_cdarray get_E_n2p(void); - py_cdarray get_G_n2p(void); - py_cdarray get_E_n2m(void); - py_cdarray get_G_n2m(void); - py_cdarray get_H_n2m(void); - py_cdarray get_V_m2n(void); - py_cdarray get_E_m2n(void); - py_cdarray get_V_p2n(void); - py_cdarray get_E_p2n(void); - bool get_use_nonbonded(void); - py_cbarray get_frozen(); - bool get_use_frozen(void); - - private: - OMMP_QM_HELPER_PRT handler; -}; - -class OMMPSystem{ - public: - OMMPSystem(){ - handler = nullptr; - } - - OMMPSystem(OMMP_SYSTEM_PRT s){ - handler = s; - } - - OMMPSystem(std::string mmp_filename){ - handler = ommp_init_mmp(mmp_filename.c_str()); - } - - OMMPSystem(std::string xyz_filename, std::string prm_filename){ - handler = ommp_init_xyz(xyz_filename.c_str(), prm_filename.c_str()); - } - - ~OMMPSystem(){ - if(is_init()) ommp_terminate(handler); - handler = nullptr; - return; - } - - bool is_init(){ - return handler != nullptr; - } - - void print_summary(std::string outfile = ""){ - if(outfile.empty()) - ommp_print_summary(handler); - else - ommp_print_summary_to_file(handler, - outfile.c_str()); - return; - } - - void save_mmp(std::string outfile, int version = 3){ - ommp_save_mmp(handler, outfile.c_str(), version); - return; - } - - void set_frozen_atoms(py_ciarray frozen){ - if(frozen.ndim() != 1){ - throw py::value_error("frozen should be shaped [:]"); - } - if(getMinValue(frozen) < 1){ - throw py::value_error("Atom index are 1-based, so they should all be grater than 0"); - } - - ommp_set_frozen_atoms(handler, frozen.shape(0), frozen.data()); - } - - void turn_pol_off(py_ciarray nopol){ - if(nopol.ndim() != 1){ - throw py::value_error("nopol should be shaped [:]"); - } - if(getMinValue(nopol) < 1){ - throw py::value_error("Atom index are 1-based, so they should all be grater than 0"); - } - - ommp_turn_pol_off(handler, nopol.shape(0), nopol.data()); - } - - int get_n_ipd(){ - return ommp_get_n_ipd(handler); - } - - int get_pol_atoms(){ - return ommp_get_pol_atoms(handler); - } - - int get_mm_atoms(){ - return ommp_get_mm_atoms(handler); - } - - int get_ld_cart(){ - return ommp_get_ld_cart(handler); - } - - bool is_amoeba(){ - return ommp_ff_is_amoeba(handler); - } - - bool use_frozen(){ - return ommp_use_frozen(handler); - } - - bool use_linkatoms(){ - return ommp_use_linkatoms(handler); - } - - py_cdarray get_ipd(){ - double *mem = ommp_get_ipd(handler); - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 3, - {get_n_ipd(), get_pol_atoms(), 3}, - {get_pol_atoms()*3*sizeof(double), 3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray get_cmm(){ - double *mem = ommp_get_cmm(handler); - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_ciarray get_zmm(){ - int32_t *mem = ommp_get_zmm(handler); - py::buffer_info bufinfo(mem, sizeof(int32_t), - py::format_descriptor::format(), - 1, - {get_mm_atoms()}, - {sizeof(int32_t)}); - return py_ciarray(bufinfo); - } - - py_cdarray get_cpol(){ - double *mem = ommp_get_cpol(handler); - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_pol_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray get_q(){ - double *mem = ommp_get_q(handler); - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), get_ld_cart()}, - {get_ld_cart()*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray get_static_charges(){ - double *mem = ommp_get_q(handler); - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 1, - {get_mm_atoms()}, - {get_ld_cart()*sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray get_static_dipoles(){ - if(! is_amoeba()) return py::none(); - - double *mem = ommp_get_q(handler); - py::buffer_info bufinfo(&(mem[1]), sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {get_ld_cart()*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray get_static_quadrupoles(){ - if(! is_amoeba()) return py::none(); - - double *mem = ommp_get_q(handler); - py::buffer_info bufinfo(&(mem[4]), sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 6}, - {get_ld_cart()*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_ciarray get_polar_mm(){ - int32_t *mem = ommp_get_polar_mm(handler); - py::buffer_info bufinfo(mem, sizeof(int), - py::format_descriptor::format(), - 1, - {get_pol_atoms()}, - {sizeof(int)}); - return py_cdarray(bufinfo); - } - - py_cbarray get_frozen(){ - bool *mem = ommp_get_frozen(handler); - py::buffer_info bufinfo(mem, sizeof(bool), - py::format_descriptor::format(), - 1, - {get_mm_atoms()}, - {sizeof(bool)}); - return py_cbarray(bufinfo); - } - - py_cdarray potential_pol2ext(py_cdarray cext){ - if(cext.ndim() != 2 || - cext.shape(1) != 3){ - throw py::value_error("cext should be shaped [:, 3]"); - } - double *mem = new double[cext.shape(0)]; - for(int i=0; i < cext.shape(0); i++) - mem[i] = 0.0; - - ommp_potential_pol2ext(handler, cext.shape(0), cext.data(), mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 1, - {cext.shape(0)}, - {sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray potential_mm2ext(py_cdarray cext){ - if(cext.ndim() != 2 || - cext.shape(1) != 3){ - throw py::value_error("cext should be shaped [:, 3]"); - } - double *mem = new double[cext.shape(0)]; - for(int i=0; i < cext.shape(0); i++) - mem[i] = 0.0; - - ommp_potential_mm2ext(handler, cext.shape(0), cext.data(), mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 1, - {cext.shape(0)}, - {sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray potential_mmpol2ext(py_cdarray cext){ - if(cext.ndim() != 2 || - cext.shape(1) != 3){ - throw py::value_error("cext should be shaped [:, 3]"); - } - double *mem = new double[cext.shape(0)]; - for(int i=0; i < cext.shape(0); i++) - mem[i] = 0.0; - - ommp_potential_mmpol2ext(handler, cext.shape(0), cext.data(), mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 1, - {cext.shape(0)}, - {sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray field_mmpol2ext(py_cdarray cext){ - if(cext.ndim() != 2 || - cext.shape(1) != 3){ - throw py::value_error("cext should be shaped [:, 3]"); - } - - int n = cext.shape(0); - double *mem = new double[n*3]; - for(int i=0; i < n*3; i++) - mem[i] = 0.0; - - ommp_field_mmpol2ext(handler, cext.shape(0), cext.data(), mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {n, 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray field_mm2ext(py_cdarray cext){ - if(cext.ndim() != 2 || - cext.shape(1) != 3){ - throw py::value_error("cext should be shaped [:, 3]"); - } - - int n = cext.shape(0); - double *mem = new double[n*3]; - for(int i=0; i < n*3; i++) - mem[i] = 0.0; - - ommp_field_mm2ext(handler, cext.shape(0), cext.data(), mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {n, 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray field_pol2ext(py_cdarray cext){ - if(cext.ndim() != 2 || - cext.shape(1) != 3){ - throw py::value_error("cext should be shaped [:, 3]"); - } - - int n = cext.shape(0); - double *mem = new double[n*3]; - for(int i=0; i < n*3; i++) - mem[i] = 0.0; - - ommp_field_pol2ext(handler, cext.shape(0), cext.data(), mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {n, 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - void set_external_field(py_cdarray ext_field, - bool nomm = false, - std::string solver = "none", - std::string matv = "none"){ - if(ext_field.ndim() != 2 || - ext_field.shape(0) != get_pol_atoms() || - ext_field.shape(1) != 3){ - throw py::value_error("ext_field should be shaped [pol_atoms, 3]"); - } - - if(solvers.find(solver) == solvers.end()){ - throw py::value_error("Selected solver is not available!"); - } - - if(matvs.find(matv) == matvs.end()){ - throw py::value_error("Selected matrix-vector method is not available!"); - } - - if(! nomm) - ommp_set_external_field(handler, ext_field.data(), solvers[solver], matvs[matv]); - else - ommp_set_external_field_nomm(handler, ext_field.data(), solvers[solver], matvs[matv]); - return ; - } - - void update_coordinates(py_cdarray c){ - if(c.ndim() != 2 || - c.shape(0) != get_mm_atoms() || - c.shape(1) != 3){ - throw py::value_error("ext_field should be shaped [mm_atoms, 3]"); - } - - ommp_update_coordinates(handler, c.data()); - return ; - } - - void numerical_grad(double (OMMPSystem::*ene_f)(void), double *g, double dd=1e-5){ - double *new_c = new double[get_mm_atoms()*3]; - double *_cmm = ommp_get_cmm(handler); - bool *frozen; - double tmp; - - if(use_frozen()) frozen = ommp_get_frozen(handler); - - for(int i=0; i < get_mm_atoms()*3; i++) - new_c[i] = _cmm[i]; - - for(int i=0; i < get_mm_atoms()*3; i++){ - if(!(use_frozen() && frozen[i/3])){ - new_c[i] += dd; - ommp_update_coordinates(handler, new_c); - tmp = (this->*ene_f)(); - - new_c[i] -= 2*dd; - ommp_update_coordinates(handler, new_c); - g[i] += (tmp-(this->*ene_f)()) / (2*dd); - - new_c[i] += dd; - ommp_update_coordinates(handler, new_c); - } - } - } - - py_cdarray full_geomgrad(bool numerical=false){ - double *mem = new double[get_mm_atoms()*3]; - - if(!numerical) - ommp_full_geomgrad(handler, mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray rotation_geomgrad(py_cdarray E, py_cdarray Egrd){ - double *mem = new double[get_mm_atoms()*3]; - for(int i=0; i < get_mm_atoms()*3; i++) - mem[i] = 0.0; - - ommp_rotation_geomgrad(handler, E.data(), Egrd.data(), mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray fixedelec_geomgrad(bool numerical=false){ - double *mem = new double[get_mm_atoms()*3]; - for(int i=0; i < get_mm_atoms()*3; i++) - mem[i] = 0.0; - - if(numerical) - numerical_grad(&OMMPSystem::get_fixedelec_energy, mem); - else - ommp_fixedelec_geomgrad(handler, mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray polelec_geomgrad(bool numerical=false){ - double *mem = new double[get_mm_atoms()*3]; - for(int i=0; i < get_mm_atoms()*3; i++) - mem[i] = 0.0; - - if(numerical) - numerical_grad(&OMMPSystem::get_polelec_energy, mem); - else - ommp_polelec_geomgrad(handler, mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray vdw_geomgrad(bool numerical=false){ - double *mem = new double[get_mm_atoms()*3]; - for(int i=0; i < get_mm_atoms()*3; i++) - mem[i] = 0.0; - - if(numerical) - numerical_grad(&OMMPSystem::get_vdw_energy, mem); - else - ommp_vdw_geomgrad(handler, mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray bond_geomgrad(bool numerical=false){ - double *mem = new double[get_mm_atoms()*3]; - for(int i=0; i < get_mm_atoms()*3; i++) - mem[i] = 0.0; - - if(numerical) - numerical_grad(&OMMPSystem::get_bond_energy, mem); - else - ommp_bond_geomgrad(handler, mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray angle_geomgrad(bool numerical=false){ - double *mem = new double[get_mm_atoms()*3]; - for(int i=0; i < get_mm_atoms()*3; i++) - mem[i] = 0.0; - - if(numerical) - numerical_grad(&OMMPSystem::get_angle_energy, mem); - else - ommp_angle_geomgrad(handler, mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray strbnd_geomgrad(bool numerical=false){ - double *mem = new double[get_mm_atoms()*3]; - for(int i=0; i < get_mm_atoms()*3; i++) - mem[i] = 0.0; - - if(numerical) - numerical_grad(&OMMPSystem::get_strbnd_energy, mem); - else - ommp_strbnd_geomgrad(handler, mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray urey_geomgrad(bool numerical=false){ - double *mem = new double[get_mm_atoms()*3]; - for(int i=0; i < get_mm_atoms()*3; i++) - mem[i] = 0.0; - - if(numerical) - numerical_grad(&OMMPSystem::get_urey_energy, mem); - else - ommp_urey_geomgrad(handler, mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray torsion_geomgrad(bool numerical=false){ - double *mem = new double[get_mm_atoms()*3]; - for(int i=0; i < get_mm_atoms()*3; i++) - mem[i] = 0.0; - - if(numerical) - numerical_grad(&OMMPSystem::get_torsion_energy, mem); - else - ommp_torsion_geomgrad(handler, mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray imptorsion_geomgrad(bool numerical=false){ - double *mem = new double[get_mm_atoms()*3]; - for(int i=0; i < get_mm_atoms()*3; i++) - mem[i] = 0.0; - - if(numerical) - numerical_grad(&OMMPSystem::get_imptorsion_energy, mem); - else - ommp_imptorsion_geomgrad(handler, mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray angtor_geomgrad(bool numerical=false){ - double *mem = new double[get_mm_atoms()*3]; - for(int i=0; i < get_mm_atoms()*3; i++) - mem[i] = 0.0; - - if(numerical) - numerical_grad(&OMMPSystem::get_angtor_energy, mem); - else - ommp_angtor_geomgrad(handler, mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray opb_geomgrad(bool numerical=false){ - double *mem = new double[get_mm_atoms()*3]; - for(int i=0; i < get_mm_atoms()*3; i++) - mem[i] = 0.0; - - if(numerical) - numerical_grad(&OMMPSystem::get_opb_energy, mem); - else - ommp_opb_geomgrad(handler, mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray strtor_geomgrad(bool numerical=false){ - double *mem = new double[get_mm_atoms()*3]; - for(int i=0; i < get_mm_atoms()*3; i++) - mem[i] = 0.0; - - if(numerical) - numerical_grad(&OMMPSystem::get_strtor_energy, mem); - else - ommp_strtor_geomgrad(handler, mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray tortor_geomgrad(bool numerical=false){ - double *mem = new double[get_mm_atoms()*3]; - for(int i=0; i < get_mm_atoms()*3; i++) - mem[i] = 0.0; - - if(numerical) - numerical_grad(&OMMPSystem::get_tortor_energy, mem); - else - ommp_tortor_geomgrad(handler, mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray pitors_geomgrad(bool numerical=false){ - double *mem = new double[get_mm_atoms()*3]; - for(int i=0; i < get_mm_atoms()*3; i++) - mem[i] = 0.0; - - if(numerical) - numerical_grad(&OMMPSystem::get_pitors_energy, mem); - else - ommp_pitors_geomgrad(handler, mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - py_cdarray full_bnd_geomgrad(bool numerical=false){ - double *mem = new double[get_mm_atoms()*3]; - for(int i=0; i < get_mm_atoms()*3; i++) - mem[i] = 0.0; - - if(numerical) - numerical_grad(&OMMPSystem::get_full_bnd_energy, mem); - else - ommp_full_bnd_geomgrad(handler, mem); - - py::buffer_info bufinfo(mem, sizeof(double), - py::format_descriptor::format(), - 2, - {get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } - - double get_bond_energy(void){ - return ommp_get_bond_energy(handler); - } - - double get_angle_energy(void){ - return ommp_get_angle_energy(handler); - } - - double get_angtor_energy(void){ - return ommp_get_angtor_energy(handler); - } - - double get_strtor_energy(void){ - return ommp_get_strtor_energy(handler); - } - - double get_strbnd_energy(void){ - return ommp_get_strbnd_energy(handler); - } - - double get_opb_energy(void){ - return ommp_get_opb_energy(handler); - } - - double get_pitors_energy(void){ - return ommp_get_pitors_energy(handler); - } - - double get_imptorsion_energy(void){ - return ommp_get_imptorsion_energy(handler); - } - - double get_torsion_energy(void){ - return ommp_get_torsion_energy(handler); - } - - double get_tortor_energy(void){ - return ommp_get_tortor_energy(handler); - } - - double get_urey_energy(void){ - return ommp_get_urey_energy(handler); - } - - double get_polelec_energy(void){ - return ommp_get_polelec_energy(handler); - } - - double get_fixedelec_energy(void){ - return ommp_get_fixedelec_energy(handler); - } - - double get_vdw_energy(void){ - return ommp_get_vdw_energy(handler); - } - - double get_full_ele_energy(void){ - return ommp_get_full_ele_energy(handler); - } - - double get_full_bnd_energy(void){ - return ommp_get_full_bnd_energy(handler); - } - - double get_full_energy(void){ - return ommp_get_full_energy(handler); - } - OMMP_SYSTEM_PRT get_handler(void){ - return handler; - } - - int32_t create_link_atom(OMMPQmHelper& qm, int imm, int iqm, int ila, - std::string prmfile, - double la_dist=OMMP_DEFAULT_LA_DIST, - int neel_remove=OMMP_DEFAULT_LA_N_EEL_REMOVE){ - if(imm < 1 || iqm < 1 || ila < 1) - throw py::value_error("Atom index are 1-based, so they should all be grater than 0"); - int nmm = get_mm_atoms(), nqm = qm.get_qm_atoms(); - - if(iqm > nqm || ila > nqm || imm > nmm) - throw py::value_error("Atom index should be inside the topology"); - - return ommp_create_link_atom(qm.get_handler(), handler, imm, iqm, ila, - prmfile.c_str(), la_dist, neel_remove); - } - - py_cdarray get_link_atom_coordinates(int la_idx){ - double *c = new double[3]; - ommp_get_link_atom_coordinates(handler, la_idx, c); - - py::buffer_info bufinfo(c, sizeof(double), - py::format_descriptor::format(), - 1, - {3}, - {sizeof(double)}); - return py_cdarray(bufinfo); - } - - private: - OMMP_SYSTEM_PRT handler; -}; - -OMMPQmHelper::OMMPQmHelper(){ - handler = nullptr; -} - -OMMPQmHelper::OMMPQmHelper(OMMP_QM_HELPER_PRT qm){ - handler = qm; -} - -OMMPQmHelper::OMMPQmHelper(py_cdarray coord_qm, py_cdarray charge_qm, py_ciarray z_qm){ - if(coord_qm.ndim() != 2 || - coord_qm.shape(1) != 3){ - throw py::value_error("coord_qm should be shaped [:, 3]"); - } - if(charge_qm.ndim() != 1 || - charge_qm.shape(0) != coord_qm.shape(0)){ - throw py::value_error("charge_qm should be shaped [coord_qm.shape[0]]"); - } - - if(z_qm.ndim() != 1 || - z_qm.shape(0) != z_qm.shape(0)){ - throw py::value_error("z_qm should be shaped [coord_qm.shape[0]]"); - } - - handler = ommp_init_qm_helper(coord_qm.shape(0), coord_qm.data(), charge_qm.data(), z_qm.data()); -} - -OMMPQmHelper::~OMMPQmHelper(){ - ommp_terminate_qm_helper(handler); - handler = nullptr; - return; -} - -OMMP_QM_HELPER_PRT OMMPQmHelper::get_handler(void){ - return handler; -} - -void OMMPQmHelper::set_frozen_atoms(py_ciarray frozen){ - if(frozen.ndim() != 1){ - throw py::value_error("frozen should be shaped [:]"); - } - if(getMinValue(frozen) < 1){ - throw py::value_error("Atom index are 1-based, so they should all be grater than 0"); - } - - ommp_qm_helper_set_frozen_atoms(handler, frozen.shape(0), frozen.data()); -} - -void OMMPQmHelper::update_coord(py_cdarray qmc){ - if(qmc.ndim() != 2 || - qmc.shape(0) != get_qm_atoms() || qmc.shape(1) != 3){ - throw py::value_error("QM coordinates should be shaped [n_qm_atoms,3]"); - } - ommp_qm_helper_update_coord(handler, qmc.data()); -} - -void OMMPQmHelper::update_link_atoms_position(OMMPSystem& s){ - OMMP_SYSTEM_PRT s_handler = s.get_handler(); - ommp_update_link_atoms_position(handler, s_handler); -} - -void OMMPQmHelper::set_attype(py_ciarray qm_attype){ - - if(qm_attype.ndim() != 1 || - qm_attype.shape(0) != get_qm_atoms()){ - throw py::value_error("QM attype should be shaped [n_qm_atoms]"); - } - - ommp_qm_helper_set_attype(handler, qm_attype.data()); -} - -void OMMPQmHelper::init_vdw_prm(std::string prmfile){ - ommp_qm_helper_init_vdw_prm(handler, prmfile.c_str()); -} - -void OMMPQmHelper::init_vdw(py_cdarray eps, py_cdarray rad, py_cdarray fac, - std::string vdw_type, std::string radius_rule, - std::string radius_size, std::string radius_type, - std::string eps_rule){ - - if(eps.ndim() != 1 || - eps.shape(0) != get_qm_atoms()){ - throw py::value_error("eps should be shaped [n_qm_atoms]"); - } - if(rad.ndim() != 1 || - eps.shape(0) != get_qm_atoms()){ - throw py::value_error("eps should be shaped [n_qm_atoms]"); - } - if(fac.ndim() != 1 || - eps.shape(0) != get_qm_atoms()){ - throw py::value_error("eps should be shaped [n_qm_atoms]"); - } - - ommp_qm_helper_init_vdw(handler, eps.data(), rad.data(), fac.data(), - vdw_type.c_str(), radius_rule.c_str(), radius_size.c_str(), - radius_type.c_str(), eps_rule.c_str()); -} - -double OMMPQmHelper::vdw_energy(OMMPSystem& s){ - OMMP_SYSTEM_PRT s_handler = s.get_handler(); - return ommp_qm_helper_vdw_energy(handler, s_handler); -} - -std::map OMMPQmHelper::vdw_geomgrad(OMMPSystem& s){ - OMMP_SYSTEM_PRT s_handler = s.get_handler(); - - double *mmg = new double[s.get_mm_atoms()*3]; - double *qmg = new double[get_qm_atoms()*3]; - ommp_qm_helper_vdw_geomgrad(handler, s_handler, qmg, mmg); - - py::buffer_info bufinfo_mm(mmg, sizeof(double), - py::format_descriptor::format(), - 2, - {s.get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - py::buffer_info bufinfo_qm(qmg, sizeof(double), - py::format_descriptor::format(), - 2, - {get_qm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - std::map res{ - {"MM", py_cdarray(bufinfo_mm)}, - {"QM", py_cdarray(bufinfo_qm)} - }; - - return res; -} - -std::map OMMPQmHelper::link_atom_geomgrad(OMMPSystem& s, py_cdarray old_qmg){ - OMMP_SYSTEM_PRT s_handler = s.get_handler(); - - double *mmg = new double[s.get_mm_atoms()*3]; - double *qmg = new double[get_qm_atoms()*3]; - ommp_qm_helper_link_atom_geomgrad(handler, s_handler, qmg, mmg, old_qmg.data()); - py::buffer_info bufinfo_mm(mmg, sizeof(double), - py::format_descriptor::format(), - 2, - {s.get_mm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - py::buffer_info bufinfo_qm(qmg, sizeof(double), - py::format_descriptor::format(), - 2, - {get_qm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - std::map res{ - {"MM", py_cdarray(bufinfo_mm)}, - {"QM", py_cdarray(bufinfo_qm)} - }; - - return res; -} - -void OMMPQmHelper::prepare_qm_ele_ene(OMMPSystem& s){ - OMMP_SYSTEM_PRT s_handler = s.get_handler(); - ommp_prepare_qm_ele_ene(s_handler, handler); -} - - -void OMMPQmHelper::prepare_qm_ele_grd(OMMPSystem& s){ - OMMP_SYSTEM_PRT s_handler = s.get_handler(); - ommp_prepare_qm_ele_grd(s_handler, handler); -} - -int32_t OMMPQmHelper::get_qm_atoms(void){ - return ommp_qm_helper_get_qm_atoms(handler); -} - -int32_t OMMPQmHelper::get_npol(void){ - return ommp_qm_helper_get_npol(handler); -} - -int32_t OMMPQmHelper::get_nmm(void){ - return ommp_qm_helper_get_nmm(handler); -} - -py_cdarray OMMPQmHelper::get_cqm(void){ - double *memory = ommp_qm_helper_get_cqm(handler); - if(!memory){ - throw py::attribute_error("cqm cannot be accessed for a memory error"); - } - else{ - py::buffer_info bufinfo(memory, sizeof(double), - py::format_descriptor::format(), - 2, - {get_qm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } -} - -py_cdarray OMMPQmHelper::get_E_n2p(void){ - double *memory = ommp_qm_helper_get_E_n2p(handler); - if(!memory){ - throw py::attribute_error("E_n2p is not available. OMMPQmHelper.prepare_energy() should be called before!"); - } - else{ - py::buffer_info bufinfo(memory, sizeof(double), - py::format_descriptor::format(), - 2, - {get_npol(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } -} - -py_cdarray OMMPQmHelper::get_G_n2p(void){ - double *memory = ommp_qm_helper_get_G_n2p(handler); - if(!memory){ - throw py::attribute_error("G_n2p is not available. OMMPQmHelper.prepare_geomgrad() should be called before!"); - } - else{ - py::buffer_info bufinfo(memory, sizeof(double), - py::format_descriptor::format(), - 2, - {get_npol(), 6}, - {6*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } -} - -py_cdarray OMMPQmHelper::get_E_n2m(void){ - double *memory = ommp_qm_helper_get_E_n2m(handler); - if(!memory){ - throw py::attribute_error("E_n2m is not available. OMMPQmHelper.prepare_geomgrad() should be called before!"); - } - else{ - py::buffer_info bufinfo(memory, sizeof(double), - py::format_descriptor::format(), - 2, - {get_nmm(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } -} - -py_cdarray OMMPQmHelper::get_G_n2m(void){ - double *memory = ommp_qm_helper_get_G_n2m(handler); - if(!memory){ - throw py::attribute_error("G_n2m is not available. OMMPQmHelper.prepare_geomgrad() should be called before!"); - } - else{ - py::buffer_info bufinfo(memory, sizeof(double), - py::format_descriptor::format(), - 2, - {get_nmm(), 6}, - {6*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } -} - -py_cdarray OMMPQmHelper::get_H_n2m(void){ - double *memory = ommp_qm_helper_get_H_n2m(handler); - if(!memory){ - throw py::attribute_error("H_n2m is not available. OMMPQmHelper.prepare_geomgrad() should be called before!"); - } - else{ - py::buffer_info bufinfo(memory, sizeof(double), - py::format_descriptor::format(), - 2, - {get_nmm(), 10}, - {10*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } -} - -py_cdarray OMMPQmHelper::get_V_m2n(void){ - double *memory = ommp_qm_helper_get_V_m2n(handler); - if(!memory){ - throw py::attribute_error("V_m2n is not available. OMMPQmHelper.prepare_energy() should be called before!"); - } - else{ - py::buffer_info bufinfo(memory, sizeof(double), - py::format_descriptor::format(), - 1, - {get_qm_atoms()}, - {sizeof(double)}); - return py_cdarray(bufinfo); - } -} - -py_cdarray OMMPQmHelper::get_E_m2n(void){ - double *memory = ommp_qm_helper_get_E_m2n(handler); - if(!memory){ - throw py::attribute_error("E_m2n is not available. OMMPQmHelper.prepare_geomgrad() should be called before!"); - } - else{ - py::buffer_info bufinfo(memory, sizeof(double), - py::format_descriptor::format(), - 2, - {get_qm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } -} - -py_cdarray OMMPQmHelper::get_V_p2n(void){ - double *memory = ommp_qm_helper_get_V_p2n(handler); - if(!memory){ - throw py::attribute_error("V_p2n is not available. OMMPQmHelper.prepare_energy() should be called before!"); - } - else{ - py::buffer_info bufinfo(memory, sizeof(double), - py::format_descriptor::format(), - 1, - {get_qm_atoms()}, - {sizeof(double)}); - return py_cdarray(bufinfo); - } -} - -py_cdarray OMMPQmHelper::get_E_p2n(void){ - double *memory = ommp_qm_helper_get_E_p2n(handler); - if(!memory){ - throw py::attribute_error("E_p2n is not available. OMMPQmHelper.prepare_geomgrad() should be called before!"); - } - else{ - py::buffer_info bufinfo(memory, sizeof(double), - py::format_descriptor::format(), - 2, - {get_qm_atoms(), 3}, - {3*sizeof(double), sizeof(double)}); - return py_cdarray(bufinfo); - } -} - -bool OMMPQmHelper::get_use_nonbonded(void){ - return ommp_qm_helper_use_nonbonded(handler); -} - -py_cbarray OMMPQmHelper::get_frozen(){ - bool *mem = ommp_qm_helper_get_frozen(handler); - py::buffer_info bufinfo(mem, sizeof(bool), - py::format_descriptor::format(), - 1, - {get_qm_atoms()}, - {sizeof(bool)}); - return py_cbarray(bufinfo); -} - -bool OMMPQmHelper::get_use_frozen(void){ - return ommp_qm_helper_use_frozen(handler); -} - -void set_verbose(int32_t v){ - ommp_set_verbose(v); -} - -void time_push(void){ - ommp_time_push(); -} - -void time_pull(std::string s){ - ommp_time_pull(s.c_str()); -} - -void set_outputfile(std::string of){ - ommp_set_outputfile(of.c_str()); -} - -void close_outputfile(void){ - ommp_close_outputfile(); -} - -void message(std::string m, int32_t l, std::string p){ - ommp_message(m.c_str(), l, p.c_str()); -} - -void fatal(std::string m){ - ommp_fatal(m.c_str()); -} - -py::list smartinput(std::string json_file){ - OMMP_SYSTEM_PRT s; - OMMP_QM_HELPER_PRT q; - py::list res; - - ommp_smartinput(json_file.c_str(), &s, &q); - OMMPSystem *my_sys = new OMMPSystem(s); - res.append(my_sys); - - if(q != nullptr){ - OMMPQmHelper *my_qmh = new OMMPQmHelper(q); - res.append(my_qmh); - } - else{ - res.append(py::none()); - } - return res; -} - -PYBIND11_MODULE(pyopenmmpol, m){ - m.def("set_verbose", &set_verbose); - m.def("time_push", &time_push); - m.def("time_pull", &time_pull); - m.def("set_outputfile", &set_outputfile); - m.def("close_outputfile", &close_outputfile); - m.def("message", &message); - m.def("fatal", &fatal); - m.def("smartinput", &smartinput, py::return_value_policy::copy); - m.attr("available_solvers") = solvers; - m.attr("available_matrix_vector") = matvs; - m.attr("verbosity") = verbosity; - m.attr("__version__") = OMMP_VERSION_STRING; - py::class_>(m, "OMMPSystem", "System of OMMP library.") - .def(py::init(), - "pyOpenMMPol creator, takes the path to a .mmp file as input.", - py::arg("mmp_filename")) - .def(py::init(), - "pyOpenMMPol creator, takes the path to a Tinker .xyz and .prm files as input.", - py::arg("xyz_filename"), - py::arg("prm_filename")) - .def("set_frozen_atoms", - &OMMPSystem::set_frozen_atoms, - "Set the atoms of the system that should be frozen (1-based list) that is unable to move.", - py::arg("frozen_list")) - .def("turn_pol_off", - &OMMPSystem::turn_pol_off, - "Turn off polarizabilities of atoms in nopol list.", - py::arg("npol_list")) - .def("print_summary", - &OMMPSystem::print_summary, - "Output a summary of loaded quantites, if outfile is specified, it is printed on file.", - py::arg("outfile") = "") - .def("save_mmp", - &OMMPSystem::save_mmp, - "Save the data of OMMPSystem into a .mmp file (note that some informations are dropped in the process).", - py::arg("outfile"), - py::arg("version") = 3) - .def("potential_mm2ext", - &OMMPSystem::potential_mm2ext, - "Compute the electrostatic potential of the static part of the system to arbitrary coordinates.", - py::arg("coord")) - .def("potential_pol2ext", - &OMMPSystem::potential_pol2ext, - "Compute the electrostatic field of the polarizable part of the system to arbitrary coordinates.", - py::arg("cext")) - .def("potential_mmpol2ext", - &OMMPSystem::potential_mmpol2ext, - "Compute the electrostatic field of the polarizable and static part of the system to arbitrary coordinates.", - py::arg("cext")) - .def("field_mm2ext", - &OMMPSystem::field_mm2ext, - "Compute the electrostatic field of the static part of the system to arbitrary coordinates.", - py::arg("cext")) - .def("field_pol2ext", - &OMMPSystem::field_pol2ext, - "Compute the electrostatic field of the polarizable part of the system to arbitrary coordinates.", - py::arg("cext")) - .def("field_mmpol2ext", - &OMMPSystem::field_mmpol2ext, - "Compute the electrostatic field of the static and polarizable part of the system to arbitrary coordinates.", - py::arg("cext")) - - .def("set_external_field", - &OMMPSystem::set_external_field, - "Set the external electric field and solves the linear system.", - py::arg("external_field"), - py::arg("nomm") = false, - py::arg("solver") = "none", - py::arg("matv") = "none") - - .def("get_bond_energy", &OMMPSystem::get_bond_energy, "Compute the energy of bond stretching") - .def("get_angle_energy", &OMMPSystem::get_angle_energy, "Compute the energy of angle bending") - .def("get_torsion_energy", &OMMPSystem::get_torsion_energy, "Compute the energy of dihedral torsion") - .def("get_imptorsion_energy", &OMMPSystem::get_imptorsion_energy, "Compute the energy of improper torsion") - .def("get_opb_energy", &OMMPSystem::get_opb_energy, "Compute the energy of out-of-plane bending") - .def("get_urey_energy", &OMMPSystem::get_urey_energy, "Compute the energy of Urey-Bradley terms") - .def("get_pitors_energy", &OMMPSystem::get_pitors_energy, "Compute the energy of Pi-system torsion terms") - .def("get_strbnd_energy", &OMMPSystem::get_strbnd_energy, "Compute the energy of stretching-bending couplings") - .def("get_strtor_energy", &OMMPSystem::get_strtor_energy, "Compute the energy of stretching torsion couplings") - .def("get_angtor_energy", &OMMPSystem::get_angtor_energy, "Compute the energy of bending torsion couplings") - .def("get_tortor_energy", &OMMPSystem::get_tortor_energy, "Compute the energy of torsion-torsion cmap") - .def("get_full_bnd_energy", &OMMPSystem::get_full_bnd_energy, "Compute the sum of all bonded components") - .def("get_full_ele_energy", &OMMPSystem::get_full_ele_energy, "Compute the sum of all electrostatic components") - .def("get_full_energy", &OMMPSystem::get_full_energy, "Compute the sum of all energy components") - .def("get_vdw_energy", &OMMPSystem::get_vdw_energy, "Compute the energy of Van der Waals terms") - .def("get_fixedelec_energy", &OMMPSystem::get_fixedelec_energy, "Compute the energy of fixed electrostatics") - .def("get_polelec_energy", &OMMPSystem::get_polelec_energy, "Compute the energy of polarizable electrostatics") - - .def("update_coordinates", - &OMMPSystem::update_coordinates, - "Update system's coordinates.", - py::arg("coord")) - .def("full_geomgrad", - &OMMPSystem::full_geomgrad, - "Compute the geometrical gradients of all the active MM components of the energy.", - py::arg("numerical") = false) - .def("fixedelec_geomgrad", - &OMMPSystem::fixedelec_geomgrad, - "Compute the geometrical gradients of fixed electrostatic energy.", - py::arg("numerical") = false) - .def("polelec_geomgrad", - &OMMPSystem::polelec_geomgrad, - "Compute the geometrical gradients of polarizable electrostatic energy.", - py::arg("numerical") = false) - .def("rotation_geomgrad", - &OMMPSystem::rotation_geomgrad, - "Compute the geometrical gradients on MM atoms due to the rotation of multipoles in an external electric field.", - py::arg("electric_field"), py::arg("electric_field_gradients")) - .def("full_bnd_geomgrad", - &OMMPSystem::full_bnd_geomgrad, - "Compute the geometrical gradients of bonded energy.", - py::arg("numerical") = false) - .def("bond_geomgrad", - &OMMPSystem::bond_geomgrad, - "Compute the geometrical gradients of bond stretching energy.", - py::arg("numerical") = false) - .def("angle_geomgrad", - &OMMPSystem::angle_geomgrad, - "Compute the geometrical gradients of angle bending energy.", - py::arg("numerical") = false) - .def("angtor_geomgrad", - &OMMPSystem::angtor_geomgrad, - "Compute the geometrical gradients of bending-torsion coupling energy.", - py::arg("numerical") = false) - .def("strtor_geomgrad", - &OMMPSystem::strtor_geomgrad, - "Compute the geometrical gradients of stretching-torsion coupling energy.", - py::arg("numerical") = false) - .def("strbnd_geomgrad", - &OMMPSystem::strbnd_geomgrad, - "Compute the geometrical gradients of stretching-bending coupling energy.", - py::arg("numerical") = false) - .def("opb_geomgrad", - &OMMPSystem::opb_geomgrad, - "Compute the geometrical gradients of out-of-plane bending energy.", - py::arg("numerical") = false) - .def("pitors_geomgrad", - &OMMPSystem::pitors_geomgrad, - "Compute the geometrical gradients of pi-torsion energy.", - py::arg("numerical") = false) - .def("torsion_geomgrad", - &OMMPSystem::torsion_geomgrad, - "Compute the geometrical gradients of torsion energy.", - py::arg("numerical") = false) - .def("imptorsion_geomgrad", - &OMMPSystem::imptorsion_geomgrad, - "Compute the geometrical gradients of improper torsion energy.", - py::arg("numerical") = false) - .def("tortor_geomgrad", - &OMMPSystem::tortor_geomgrad, - "Compute the geometrical gradients of torsion-torsion coupling energy.", - py::arg("numerical") = false) - .def("urey_geomgrad", - &OMMPSystem::urey_geomgrad, - "Compute the geometrical gradients of Urey-Bradley energy.", - py::arg("numerical") = false) - .def("vdw_geomgrad", - &OMMPSystem::vdw_geomgrad, - "Compute the geometrical gradients of Van der Waal energy.", - py::arg("numerical") = false) - .def("create_link_atom", - &OMMPSystem::create_link_atom, - "Create a link atom between QM and MM system", - py::arg("OMMP_QM_Helper"), py::arg("i_mm"), py::arg("i_qm"), py::arg("i_la"), - py::arg("prmfile"), - py::arg("la_distance")=OMMP_DEFAULT_LA_DIST, - py::arg("n_eel_remove")=OMMP_DEFAULT_LA_N_EEL_REMOVE) - .def_property_readonly("is_init", &OMMPSystem::is_init, "Flag to check system initialization.") - .def_property_readonly("pol_atoms", &OMMPSystem::get_pol_atoms, "Number of polarizable atoms") - .def_property_readonly("mm_atoms", &OMMPSystem::get_mm_atoms, "Number of atoms") - .def_property_readonly("_ld_cart", &OMMPSystem::get_ld_cart, "Dimension of static site descriptor; 1 for Wang FF, 10 for Amoeba FF.") - .def_property_readonly("n_ipd", &OMMPSystem::get_n_ipd, "Number of induced dipoles sets; 1 for Wang FF, 2 for Amoeba FF.") - .def_property_readonly("is_amoeba", &OMMPSystem::is_amoeba, "Flag for Amoeba FF") - .def_property_readonly("ipd", &OMMPSystem::get_ipd, "Induced dipoles (read only)") - .def_property_readonly("cmm", &OMMPSystem::get_cmm, "Coordinates of atoms (read only) [mm_atoms, 3]") - .def_property_readonly("zmm", &OMMPSystem::get_zmm, "Atomic number of MM atoms (read only) [mm_atoms]") - .def_property_readonly("cpol", &OMMPSystem::get_cpol, "Coordinates of polarizable atoms (read only) [pol_atoms, 3]") - .def_property_readonly("_q", &OMMPSystem::get_q, "Full descriptor of static sites (read only) [mm_atoms, _ld_cart]") - .def_property_readonly("static_charges", &OMMPSystem::get_static_charges, "Static charges (read only) [mm_atoms]") - .def_property_readonly("static_dipoles", &OMMPSystem::get_static_dipoles, "Static dipoles (read only) if is_amoeba [mm_atoms, 3], else None") - .def_property_readonly("static_quadrupoles", &OMMPSystem::get_static_quadrupoles, "Static dipoles (read only) if is_amoeba [mm_atoms, 6], else None") - .def_property_readonly("polar_mm", &OMMPSystem::get_polar_mm, "Index of polarizable atoms in atom list [pol_atoms]") - .def_property_readonly("use_frozen", &OMMPSystem::use_frozen, "Flag to check if frozen atoms are used") - .def_property_readonly("frozen", &OMMPSystem::get_frozen, "Logical array, for each atom True means frozen False means mobile.") - .def_property_readonly("use_linkatoms", &OMMPSystem::use_linkatoms, "Flag to check if link atoms are used"); - - py::class_>(m, "OMMPQmHelper", "Object to handle information about the QM system and simplify the QM/MM interface.") - .def(py::init(), - "OMMPQmHelper creator, takes the coordinates and nuclear charges of QM system as input.", - py::arg("coord_qm"), py::arg("charge_qm"), py::arg("z_qm")) - .def("update_coord", - &OMMPQmHelper::update_coord, - "Update the coordinates of QM atoms", - py::arg("qm_atoms_coordinates")) - .def("set_attype", - &OMMPQmHelper::set_attype, - "Set atomtypes for QM atoms.", - py::arg("qm_attype")) - .def("init_vdw_prm", - &OMMPQmHelper::init_vdw_prm, - "Set the VdW parameters for the QM atoms using a prm forcefield and atomtypes of QM atoms.", - py::arg("prmfile")) - .def("set_frozen_atoms", - &OMMPQmHelper::set_frozen_atoms, - "Set the atoms of the system that should be frozen (1-based list) that is unable to move.", - py::arg("frozen_list")) - .def("init_vdw", - &OMMPQmHelper::init_vdw, - "Set the VdW parameters for the QM atoms, this is needed in geometry optimization and MD to avoid clashes between QM and MM atoms", - py::arg("eps"), - py::arg("rad"), - py::arg("fac"), - py::arg("vdw_type")="buffered-14-7", - py::arg("radius_rule")="cubic-mean", - py::arg("radius_size")="diameter", - py::arg("radius_type")="r-min", - py::arg("eps_rule")="hhg") - .def("vdw_geomgrad", - &OMMPQmHelper::vdw_geomgrad, - "Compute the geometrical gradients of VdW interaction between QM and MM parts of the system", - py::arg("OMMP_system")) - .def("vdw_energy", - &OMMPQmHelper::vdw_energy, - "Compute the VdW interaction energy between QM and MM parts of the system", - py::arg("OMMP_system")) - .def("link_atom_geomgrad", - &OMMPQmHelper::link_atom_geomgrad, - "Compute the geometrical gradients of link atoms contribution to energy on QM and MM parts of the system", - py::arg("OMMP_system"), py::arg("old_qm_grad")) - .def("update_link_atoms_position", - &OMMPQmHelper::update_link_atoms_position, - "Update the positions of all link atoms") - .def("prepare_qm_ele_ene", - &OMMPQmHelper::prepare_qm_ele_ene, - "Prepeare the quantities available in helper for a single point SCF calculation (electric field of nuclei at polarizable sites, potential of MM system (polarizable and static) at nuclei) with the MM system passed as argument.", - py::arg("OMMP_system")) - .def("prepare_qm_ele_grd", - &OMMPQmHelper::prepare_qm_ele_grd, - "Prepeare the quantities available in helper for a gradients SCF calculation (electric field gradients of nuclei at polarizable sites, electric field of MM system (polarizable and static) at nuclei, electric field, gradients and Hessian of nuclei at static sites) with the MM system passed as argument.", - py::arg("OMMP_system")) - .def_property_readonly("use_nonbonded", &OMMPQmHelper::get_use_nonbonded, "Flag for enable/disable usage of QM-MM VdW potential") - .def_property_readonly("cqm", &OMMPQmHelper::get_cqm, "Get the coordinates of QM nuclei") - .def_property_readonly("E_n2p", &OMMPQmHelper::get_E_n2p, "Electric field of nuclei at polarizable sites") - .def_property_readonly("G_n2p", &OMMPQmHelper::get_G_n2p, "Electric field gradients of nuclei at polarizable sites") - .def_property_readonly("V_m2n", &OMMPQmHelper::get_V_m2n, "Electrostatic potential of MM system (static part) at QM nuclei") - .def_property_readonly("V_p2n", &OMMPQmHelper::get_V_p2n, "Electrostatic potential of MM system (polarizable part) at QM nuclei") - .def_property_readonly("E_m2n", &OMMPQmHelper::get_E_m2n, "Electric field of MM system (static part) at QM nuclei") - .def_property_readonly("E_p2n", &OMMPQmHelper::get_E_p2n, "Electric field of MM system (polarizable part) at QM nuclei") - .def_property_readonly("E_n2m", &OMMPQmHelper::get_E_n2m, "Electric field of MM system at QM nuclei") - .def_property_readonly("G_n2m", &OMMPQmHelper::get_G_n2m, "Electric field gradients of MM system at QM nuclei") - .def_property_readonly("H_n2m", &OMMPQmHelper::get_H_n2m, "Electric field Hessian of MM system at QM nuclei") - .def_property_readonly("frozen", &OMMPQmHelper::get_frozen, "Logical array, for each atom True means frozen False means mobile.") - .def_property_readonly("use_frozen", &OMMPQmHelper::get_use_frozen, "If frozen atoms are used or not.") - ; -} diff --git a/src/rotate_multipoles.F90 b/src/rotate_multipoles.F90 new file mode 100644 index 0000000..4225794 --- /dev/null +++ b/src/rotate_multipoles.F90 @@ -0,0 +1,643 @@ +#include "f_cart_components.h" + +subroutine rotation_geomgrad(eel, E, Egrd, grad) + + use mod_memory, only: ip, rp + use mod_electrostatics, only: ommp_electrostatics_type + + implicit none + + type(ommp_electrostatics_type), intent(in) :: eel + real(rp), intent(in) :: E(3, eel%top%mm_atoms), Egrd(6, eel%top%mm_atoms) + real(rp), dimension(3, eel%top%mm_atoms), intent(inout) :: grad + + integer(ip) :: j, jx, jy, jz, k, l, m, n + real(rp), dimension(3) :: dip + real(rp), dimension(3,3) :: r, rt, qua, rqua, ddip + real(rp), dimension(3,3,3) :: dri, driz, drix, driy, dqua, dtmp + logical :: frozen_j, frozen_jx, frozen_jy, frozen_jz + + ! TODO prepare_fixedelec + + ! loop over the mm sites and build the derivatives of the rotation + ! matrices with respect to the positions of all the relevant atoms. + do j = 1, eel%top%mm_atoms + jz = eel%iz(j) + if(jz == 0) jz = j + jx = eel%ix(j) + if(jx == 0) jx = j + jy = eel%iy(j) + if(jy == 0) jy = j + + if(eel%top%use_frozen) then + if(eel%top%frozen(j) .and. & + eel%top%frozen(jx) .and. & + eel%top%frozen(jy) .and. & + eel%top%frozen(jz)) cycle + end if + + frozen_j = .false. + frozen_jx = .false. + frozen_jy = .false. + frozen_jz = .false. + if(eel%top%use_frozen) then + frozen_j = eel%top%frozen(j) + frozen_jx = eel%top%frozen(jx) + frozen_jy = eel%top%frozen(jy) + frozen_jz = eel%top%frozen(jz) + end if + + call rotation_matrix(.true., & + eel%top%cmm(:,j), eel%top%cmm(:,jx), & + eel%top%cmm(:,jy), eel%top%cmm(:,jz), & + eel%mol_frame(j), & + r, dri, driz, drix, driy) + + rt = transpose(r) + + ! get the multipoles. we also need the rotated quadrupoles: + dip(_x_) = eel%q0(1+_x_,j) + dip(_y_) = eel%q0(1+_y_,j) + dip(_z_) = eel%q0(1+_z_,j) + + qua(_x_,_x_) = eel%q0(4+_xx_,j) + qua(_x_,_y_) = eel%q0(4+_xy_,j) + qua(_x_,_z_) = eel%q0(4+_xz_,j) + qua(_y_,_x_) = eel%q0(4+_yx_,j) + qua(_y_,_y_) = eel%q0(4+_yy_,j) + qua(_y_,_z_) = eel%q0(4+_yz_,j) + qua(_z_,_x_) = eel%q0(4+_zx_,j) + qua(_z_,_y_) = eel%q0(4+_zy_,j) + qua(_z_,_z_) = eel%q0(4+_zz_,j) + + rqua(_x_,_x_) = eel%q(4+_xx_,j) + rqua(_x_,_y_) = eel%q(4+_xy_,j) + rqua(_x_,_z_) = eel%q(4+_xz_,j) + rqua(_y_,_x_) = eel%q(4+_yx_,j) + rqua(_y_,_y_) = eel%q(4+_yy_,j) + rqua(_y_,_z_) = eel%q(4+_yz_,j) + rqua(_z_,_x_) = eel%q(4+_zx_,j) + rqua(_z_,_y_) = eel%q(4+_zy_,j) + rqua(_z_,_z_) = eel%q(4+_zz_,j) + + ! contributions to the forces on the j-th atoms: + + ddip = 0.0_rp + dqua = 0.0_rp + dtmp = 0.0_rp + ! compute the differentiated multipoles: + do k = 1, 3 + do l = 1, 3 + ddip(:,k) = ddip(:,k) + dri(:,k,l)*dip(l) + end do + end do + + do k = 1, 3 + do l = 1, 3 + do m = 1, 3 + do n = 1, 3 + !dtmp(:,l,m)*rt(m,k) + dqua(:,k,l) = dqua(:,k,l) + (dri(:,k,m)*qua(m,n) - & + rqua(k,m)*dri(:,m,n))*rt(n,l) + end do + end do + end do + end do + + if(.not. frozen_j) then + ! increment the forces for the dipoles... + grad(:,j) = grad(:,j) - ddip(:,_x_)*E(_x_,j) & + - ddip(:,_y_)*E(_y_,j) & + - ddip(:,_z_)*E(_z_,j) + ! ... and for the quadrupoles: + grad(:,j) = grad(:,j) + dqua(:,_x_,_x_)*Egrd(_xx_,j) & + + dqua(:,_y_,_y_)*Egrd(_yy_,j) & + + dqua(:,_z_,_z_)*Egrd(_zz_,j) & + + 2*(dqua(:,_x_,_y_)*Egrd(_xy_,j) & + + dqua(:,_x_,_z_)*Egrd(_xz_,j) & + + dqua(:,_y_,_z_)*Egrd(_yz_,j)) + end if + + ! do jx + ddip = 0.0_rp + dqua = 0.0_rp + dtmp = 0.0_rp + do k = 1, 3 + do l = 1, 3 + ddip(:,k) = ddip(:,k) + drix(:,k,l)*dip(l) + end do + end do + + do k = 1, 3 + do l = 1, 3 + do m = 1, 3 + do n = 1, 3 + !dtmp(:,l,m)*rt(m,k) + dqua(:,k,l) = dqua(:,k,l) + (drix(:,k,m)*qua(m,n) -& + rqua(k,m)*drix(:,m,n))*rt(n,l) + end do + end do + end do + end do + + if(.not. frozen_jx) then + ! increment the forces for the dipoles... + grad(:,jx) = grad(:,jx) - ddip(:,_x_)*E(_x_,j) & + - ddip(:,_y_)*E(_y_,j) & + - ddip(:,_z_)*E(_z_,j) + ! ... and for the quadrupoles: + grad(:,jx) = grad(:,jx) + dqua(:,_x_,_x_)*Egrd(_xx_,j) & + + dqua(:,_y_,_y_)*Egrd(_yy_,j) & + + dqua(:,_z_,_z_)*Egrd(_zz_,j) & + + 2*(dqua(:,_x_,_y_)*Egrd(_xy_,j) & + + dqua(:,_x_,_z_)*Egrd(_xz_,j) & + + dqua(:,_y_,_z_)*Egrd(_yz_,j)) + end if + + ! do jy + ddip = 0.0_rp + dqua = 0.0_rp + dtmp = 0.0_rp + do k = 1, 3 + do l = 1, 3 + ddip(:,k) = ddip(:,k) + driy(:,k,l)*dip(l) + end do + end do + + do k = 1, 3 + do l = 1, 3 + do m = 1, 3 + do n = 1, 3 + ! dtmp(:,l,m)*rt(m,k) + dqua(:,k,l) = dqua(:,k,l) + (driy(:,k,m)*qua(m,n) -& + rqua(k,m)*driy(:,m,n))*rt(n,l) + end do + end do + end do + end do + + if(.not. frozen_jy) then + ! increment the forces for the dipoles... + grad(:,jy) = grad(:,jy) - ddip(:,_x_)*E(_x_,j) & + - ddip(:,_y_)*E(_y_,j) & + - ddip(:,_z_)*E(_z_,j) + ! ... and for the quadrupoles: + grad(:,jy) = grad(:,jy) + dqua(:,_x_,_x_)*Egrd(_xx_,j) & + + dqua(:,_y_,_y_)*Egrd(_yy_,j) & + + dqua(:,_z_,_z_)*Egrd(_zz_,j) & + + 2*(dqua(:,_x_,_y_)*Egrd(_xy_,j) & + + dqua(:,_x_,_z_)*Egrd(_xz_,j) & + + dqua(:,_y_,_z_)*Egrd(_yz_,j)) + end if + + ! Do jz + ddip = 0.0_rp + dqua = 0.0_rp + dtmp = 0.0_rp + do k = 1, 3 + do l = 1, 3 + ddip(:,k) = ddip(:,k) + driz(:,k,l)*dip(l) + end do + end do + + do k = 1, 3 + do l = 1, 3 + do m = 1, 3 + do n = 1, 3 + ! tmp(:,l,m)*rt(m,k) + dqua(:,k,l) = dqua(:,k,l) + (driz(:,k,m)*qua(m,n) -& + rqua(k,m)*driz(:,m,n))*rt(n,l) + end do + end do + end do + end do + + if(.not. frozen_jz) then + ! increment the forces for the dipoles... + grad(:,jz) = grad(:,jz) - ddip(:,_x_)*E(_x_,j) & + - ddip(:,_y_)*E(_y_,j) & + - ddip(:,_z_)*E(_z_,j) + ! ... and for the quadrupoles: + grad(:,jz) = grad(:,jz) + dqua(:,_x_,_x_)*Egrd(_xx_,j) & + + dqua(:,_y_,_y_)*Egrd(_yy_,j) & + + dqua(:,_z_,_z_)*Egrd(_zz_,j) & + + 2*(dqua(:,_x_,_y_)*Egrd(_xy_,j) & + + dqua(:,_x_,_z_)*Egrd(_xz_,j) & + + dqua(:,_y_,_z_)*Egrd(_yz_,j)) + end if + + end do +end subroutine rotation_geomgrad + +subroutine rotate_multipoles(eel) + !! this routine rotates the atomic multipoles from the molecular frame + !! where they are defined as force field parameters to the lab frame. + !! if required, it also computes the contribution to the forces that + !! stems from the derivatives of the rotation matrices, sometimes + !! referred to as "torques". + !! for the latter task, it uses the field and field gradient from + !! at the multipoles, which is passed in def. + !! for consistency reasons, def is dimensioned (ld_cder,mm_atoms). + + use mod_memory, only: ip, rp + use mod_electrostatics, only: ommp_electrostatics_type + + implicit none + + type(ommp_electrostatics_type), intent(inout) :: eel + + integer(ip) :: j, jx, jy, jz + real(rp), dimension(3,3) :: r, rt, qua, rqua, tmp + real(rp), dimension(3,3,3) :: dri, driz, drix, driy + + ! loop over the mm sites and build the rotation matrices. + do j = 1, eel%top%mm_atoms + jz = eel%iz(j) + if(jz == 0) jz = j + jx = eel%ix(j) + if(jx == 0) jx = j + jy = eel%iy(j) + if(jy == 0) jy = j + + call rotation_matrix(.false., & + eel%top%cmm(:,j), eel%top%cmm(:,jx), & + eel%top%cmm(:,jy), eel%top%cmm(:,jz), & + eel%mol_frame(j), & + r, dri, driz, drix, driy) + + rt = transpose(r) + ! copy the monopole: + eel%q(1,j) = eel%q0(1,j) + + ! rotate the dipole + eel%q(2:4,j) = matmul(r,eel%q0(2:4,j)) + + ! exctract, rotate and put back the quadrupole: + qua(_x_,_x_) = eel%q0(4+_xx_,j) + qua(_x_,_y_) = eel%q0(4+_xy_,j) + qua(_x_,_z_) = eel%q0(4+_xz_,j) + qua(_y_,_x_) = eel%q0(4+_yx_,j) + qua(_y_,_y_) = eel%q0(4+_yy_,j) + qua(_y_,_z_) = eel%q0(4+_yz_,j) + qua(_z_,_x_) = eel%q0(4+_zx_,j) + qua(_z_,_y_) = eel%q0(4+_zy_,j) + qua(_z_,_z_) = eel%q0(4+_zz_,j) + + tmp = matmul(r,qua) + rqua = matmul(tmp,rt) + eel%q(4+_xx_,j) = rqua(_x_,_x_) + eel%q(4+_yy_,j) = rqua(_y_,_y_) + eel%q(4+_zz_,j) = rqua(_z_,_z_) + eel%q(4+_xy_,j) = rqua(_x_,_y_) + eel%q(4+_xz_,j) = rqua(_x_,_z_) + eel%q(4+_yz_,j) = rqua(_y_,_z_) + end do +end subroutine rotate_multipoles + + +subroutine rotation_matrix(doder,c,cx,cy,cz,mol_frame,r,dri,driz,drix,driy) + use mod_io, only: fatal_error + use mod_memory, only: ip, rp + use mod_constants, only: eps_rp + + implicit none + !! given an atom j and the reference atoms jx, jy, and jz, this routine + !! computes the rotation matrix needed to rotate the multipoles on the + !! i-th atom from the molecular frame to the lab frame. + !! if required, it also return the derivative of the rotation matrices + !! with respect to the coordinates of all the atoms involved in its + !! definition. + !! + !! this routine is completely general and can be easily augmented with + !! new rotation conventions. + !! + !! given the atoms used to define the molecolar frame, identified by the + !! indices jx, jy, jz, this routine builds the vectors + !! + !! xi = cmm(:,jz) - cmm(:,i) + !! eta = cmm(:,jx) - cmm(:,i) + !! zeta = cmm(:,jy) - cmm(:,i) + !! + !! it then decodes the rotatoin conventions by introducing two vectors, + !! u and v, that span the xz plane. + !! this is the only convention-dependent part: everything else works + !! automatically in a general way. + !! + !! for the definition of u and v, the unit vectors that identify the + !! orthogonal molecular systems are built as follows: + !! + !! ez = u/|u| + !! ex = gram-schmidt (v,ez) + !! ey = ez x ex + !! + !! output: + !! ======= + !! + !! r(i,j) is the rotation matrix, whose columns are (ex,ey,ez) + !! + !! dri(i,j,k) contains the derivative of the i-th component of e_k + !! with respect to ri_j + + logical, intent(in) :: doder + real(rp), intent(in), dimension(3) :: c, cx, cy, cz + integer(ip), intent(in) :: mol_frame + + real(rp), dimension(3,3), intent(out) :: r + real(rp), dimension(3,3,3), intent(inout) :: dri, driz, drix, driy + + integer(ip) :: k + real(rp) :: dot + real(rp) :: xi(3), eta(3), zeta(3), xi_norm, eta_norm, zeta_norm + real(rp) :: u(3), v(3), u_norm, ex(3), ey(3), ez(3), ex_nrm, ex_sq, & + u_sq, u_cube, vez + real(rp), dimension(3,3) :: ez_u, ex_v, ex_ez, ey_ez, ey_ex, u_ri, u_riz, & + u_rix, u_riy, v_ri, v_rix, v_riy, ez_ri, & + ez_riz, ez_rix, ez_riy, ex_ri, ex_riz, & + ex_rix, ex_riy, ey_ri, ey_riz, ey_rix, ey_riy + + real(rp), parameter :: zofac = 0.866_rp + + r = 0.0_rp + + ! get the xi, eta and zeta vectors and their norms: + xi = cz - c + xi_norm = sqrt(dot_product(xi,xi)) + + eta = cx - c + eta_norm = sqrt(dot_product(eta,eta)) + + zeta = cy-c + zeta_norm = sqrt(dot_product(zeta,zeta)) +! +! build the u and v vectors, that span the xz plane according to the specific +! convention: +! + u = 0.0_rp + v = 0.0_rp + if (mol_frame.eq.0) then +! +! do nothing. +! + r(1,1) = 1.0_rp + r(2,2) = 1.0_rp + r(3,3) = 1.0_rp + if (doder) then + dri = 0.0_rp + driz = 0.0_rp + drix = 0.0_rp + driy = 0.0_rp + end if + return +! + else if (mol_frame.eq.1) then +! +! z-then-x convention: +! + u = xi + v = eta +! + else if (mol_frame.eq.2) then +! +! bisector convention: +! + u = eta_norm*xi + xi_norm*eta + v = eta +! + else if (mol_frame.eq.3) then +! +! z-only convention: +! + u = xi + dot = u(3)/xi_norm + if (dot.le.zofac .and. abs(u(2)) > eps_rp) then + v(1) = 1.0_rp + else + v(2) = 1.0_rp + end if +! + else if (mol_frame.eq.4) then +! +! z-bisector convention: +! + u = xi + v = zeta_norm*eta + eta_norm*zeta +! + else if (mol_frame.eq.5) then +! +! 3-fold convention: +! + u = eta_norm*zeta_norm*xi + xi_norm*zeta_norm*eta + xi_norm*eta_norm*zeta + v = eta +! + else +! +! convention not yet implemented. +! + !!TODO call fatal_error('the required rotation convention is not implemented.') + end if +! +! build the unit vectors: +! + if(norm2(u) < eps_rp .or. norm2(v) < eps_rp) then + call fatal_error("Ill defined rotation axis (either u or v vectors have & + &0 norm.") + end if + + u_sq = dot_product(u,u) + u_norm = sqrt(u_sq) + ez = u/u_norm +! + vez = dot_product(v,ez) + ex = v - vez*ez + ex_sq = dot_product(ex,ex) + ex_nrm = sqrt(ex_sq) + ex = ex/ex_nrm +! + ey(1) = ez(2)*ex(3) - ez(3)*ex(2) + ey(2) = ez(3)*ex(1) - ez(1)*ex(3) + ey(3) = ez(1)*ex(2) - ez(2)*ex(1) +! + r(:,1) = ex + r(:,2) = ey + r(:,3) = ez +! +! return if derivatives are not requested: +! + if (.not. doder) return +! +! derivatives code +! ================ +! +! the derivatives of the rotation matrices can be computed using chain-rule +! differentiation. +! please, see JCTC 2014, 10, 1638−1651 for details. +! +! clean interemediates: +! + ez_u = 0.0_rp + ex_v = 0.0_rp + ex_ez = 0.0_rp + ey_ez = 0.0_rp + ey_ex = 0.0_rp + u_ri = 0.0_rp + u_riz = 0.0_rp + u_rix = 0.0_rp + u_riy = 0.0_rp + v_ri = 0.0_rp + v_rix = 0.0_rp + v_riy = 0.0_rp +! +! start by assembling the intermediates that do not depend on the sepcific convention: +! + u_cube = u_sq*u_norm + do k = 1, 3 + ez_u(k,k) = 1.0_rp/u_norm + ex_v(k,k) = 1.0_rp/ex_nrm + ex_ez(k,k) = - vez/ex_nrm + end do + do k = 1, 3 + ez_u(:,k) = ez_u(:,k) - u(:)*u(k)/u_cube + ex_v(:,k) = ex_v(:,k) - ez(:)*ez(k)/ex_nrm - ex(:)*ex(k)/ex_nrm + ex_ez(:,k) = ex_ez(:,k) + ex(:)*vez*v(k)/ex_sq - ez(:)*v(k)/ex_nrm + end do +! + ey_ez(1,1) = 0.0_rp + ey_ez(1,2) = ex(3) + ey_ez(1,3) = - ex(2) + ey_ez(2,1) = - ex(3) + ey_ez(2,2) = 0.0_rp + ey_ez(2,3) = ex(1) + ey_ez(3,1) = ex(2) + ey_ez(3,2) = - ex(1) + ey_ez(3,3) = 0.0_rp +! + ey_ex(1,1) = 0.0_rp + ey_ex(1,2) = - ez(3) + ey_ex(1,3) = ez(2) + ey_ex(2,1) = ez(3) + ey_ex(2,2) = 0.0_rp + ey_ex(2,3) = - ez(1) + ey_ex(3,1) = - ez(2) + ey_ex(3,2) = ez(1) + ey_ex(3,3) = 0.0_rp +! +! now compute the convention-specific terms: +! + if (mol_frame.eq.1) then +! +! z-then-x: +! + do k = 1, 3 + u_ri(k,k) = - 1.0_rp + u_riz(k,k) = 1.0_rp + v_ri(k,k) = - 1.0_rp + v_rix(k,k) = 1.0_rp + end do +! + else if (mol_frame.eq.2) then +! +! bisector: +! + do k = 1, 3 + u_ri(k,k) = - xi_norm - eta_norm + u_riz(k,k) = eta_norm + u_rix(k,k) = xi_norm + v_ri(k,k) = - 1.0_rp + v_rix(k,k) = 1.0_rp + end do +! + do k = 1, 3 + u_ri(:,k) = u_ri(:,k) - eta(:)*xi(k)/xi_norm - xi(:)*eta(k)/eta_norm + u_riz(:,k) = u_riz(:,k) + eta(:)*xi(k)/xi_norm + u_rix(:,k) = u_rix(:,k) + xi(:)*eta(k)/eta_norm + end do +! + else if (mol_frame.eq.3) then +! +! z-only: +! + do k = 1, 3 + u_ri(k,k) = - 1.0_rp + u_riz(k,k) = 1.0_rp + end do +! + else if (mol_frame.eq.4) then +! +! z-bisector: +! + do k = 1, 3 + u_ri(k,k) = - 1.0_rp + u_riz(k,k) = 1.0_rp + v_ri(k,k) = - eta_norm - zeta_norm + v_rix(k,k) = zeta_norm + u_riy(k,k) = eta_norm + end do +! + do k = 1, 3 + v_ri(:,k) = v_ri(:,k) - eta(:)*zeta(k)/zeta_norm - zeta(:)*eta(k)/eta_norm + v_rix(:,k) = v_rix(:,k) + zeta(:)*eta(k)/eta_norm + v_riy(:,k) = v_riy(:,k) + eta(:)*zeta(k)/zeta_norm + end do +! + else if (mol_frame.eq.5) then +! +! 3-fold: +! + do k = 1, 3 + u_ri(k,k) = - xi_norm*eta_norm - xi_norm*zeta_norm - eta_norm*zeta_norm + u_riz(k,k) = eta_norm*zeta_norm + u_rix(k,k) = xi_norm*zeta_norm + u_riy(k,k) = xi_norm*eta_norm + v_ri(k,k) = - 1.0_rp + v_rix(k,k) = 1.0_rp + end do +! + do k = 1, 3 + u_ri(:,k) = u_ri(:,k) - (eta*zeta_norm + zeta*eta_norm)*xi(k)/xi_norm & + - (xi*zeta_norm + zeta*xi_norm )*eta(k)/eta_norm & + - (xi*eta_norm + eta*xi_norm )*zeta(k)/zeta_norm + u_riz(:,k) = u_riz(:,k) + (eta*zeta_norm + zeta*eta_norm)*xi(k)/xi_norm + u_rix(:,k) = u_rix(:,k) + (xi*zeta_norm + zeta*xi_norm )*eta(k)/eta_norm + u_riy(:,k) = u_riy(:,k) + (xi*eta_norm + eta*xi_norm )*zeta(k)/zeta_norm + end do +! + end if +! +! proceed assembling the derivatives of the unit vectors: +! +! ez: +! + ez_ri = matmul(ez_u,u_ri) + ez_riz = matmul(ez_u,u_riz) + ez_rix = matmul(ez_u,u_rix) + ez_riy = matmul(ez_u,u_riy) +! +! ex: +! + ex_ri = matmul(ex_v,v_ri) + matmul(ex_ez,ez_ri) + ex_riz = matmul(ex_ez,ez_riz) + ex_rix = matmul(ex_v,v_rix) + matmul(ex_ez,ez_rix) + ex_riy = matmul(ex_v,v_riy) + matmul(ex_ez,ez_riy) +! +! ey: +! + ey_ri = matmul(ey_ex,ex_ri) + matmul(ey_ez,ez_ri) + ey_riz = matmul(ey_ex,ex_riz) + matmul(ey_ez,ez_riz) + ey_rix = matmul(ey_ex,ex_rix) + matmul(ey_ez,ez_rix) + ey_riy = matmul(ey_ex,ex_riy) + matmul(ey_ez,ez_riy) +! +! finally, assemble the derivatives of the rotation matrices: +! + dri(:,:,1) = transpose(ex_ri) + dri(:,:,2) = transpose(ey_ri) + dri(:,:,3) = transpose(ez_ri) + driz(:,:,1) = transpose(ex_riz) + driz(:,:,2) = transpose(ey_riz) + driz(:,:,3) = transpose(ez_riz) + drix(:,:,1) = transpose(ex_rix) + drix(:,:,2) = transpose(ey_rix) + drix(:,:,3) = transpose(ez_rix) + driy(:,:,1) = transpose(ex_riy) + driy(:,:,2) = transpose(ey_riy) + driy(:,:,3) = transpose(ez_riy) +end subroutine rotation_matrix diff --git a/src/rotate_multipoles.f90 b/src/rotate_multipoles.f90 deleted file mode 100644 index 6625e2f..0000000 --- a/src/rotate_multipoles.f90 +++ /dev/null @@ -1,643 +0,0 @@ -#include "f_cart_components.h" - -subroutine rotation_geomgrad(eel, E, Egrd, grad) - - use mod_memory, only: ip, rp - use mod_electrostatics, only: ommp_electrostatics_type - - implicit none - - type(ommp_electrostatics_type), intent(in) :: eel - real(rp), intent(in) :: E(3, eel%top%mm_atoms), Egrd(6, eel%top%mm_atoms) - real(rp), dimension(3, eel%top%mm_atoms), intent(inout) :: grad - - integer(ip) :: j, jx, jy, jz, k, l, m, n - real(rp), dimension(3) :: dip - real(rp), dimension(3,3) :: r, rt, qua, rqua, ddip - real(rp), dimension(3,3,3) :: dri, driz, drix, driy, dqua, dtmp - logical :: frozen_j, frozen_jx, frozen_jy, frozen_jz - - ! TODO prepare_fixedelec - - ! loop over the mm sites and build the derivatives of the rotation - ! matrices with respect to the positions of all the relevant atoms. - do j = 1, eel%top%mm_atoms - jz = eel%iz(j) - if(jz == 0) jz = j - jx = eel%ix(j) - if(jx == 0) jx = j - jy = eel%iy(j) - if(jy == 0) jy = j - - if(eel%top%use_frozen) then - if(eel%top%frozen(j) .and. & - eel%top%frozen(jx) .and. & - eel%top%frozen(jy) .and. & - eel%top%frozen(jz)) cycle - end if - - frozen_j = .false. - frozen_jx = .false. - frozen_jy = .false. - frozen_jz = .false. - if(eel%top%use_frozen) then - frozen_j = eel%top%frozen(j) - frozen_jx = eel%top%frozen(jx) - frozen_jy = eel%top%frozen(jy) - frozen_jz = eel%top%frozen(jz) - end if - - call rotation_matrix(.true., & - eel%top%cmm(:,j), eel%top%cmm(:,jx), & - eel%top%cmm(:,jy), eel%top%cmm(:,jz), & - eel%mol_frame(j), & - r, dri, driz, drix, driy) - - rt = transpose(r) - - ! get the multipoles. we also need the rotated quadrupoles: - dip(_x_) = eel%q0(1+_x_,j) - dip(_y_) = eel%q0(1+_y_,j) - dip(_z_) = eel%q0(1+_z_,j) - - qua(_x_,_x_) = eel%q0(4+_xx_,j) - qua(_x_,_y_) = eel%q0(4+_xy_,j) - qua(_x_,_z_) = eel%q0(4+_xz_,j) - qua(_y_,_x_) = eel%q0(4+_yx_,j) - qua(_y_,_y_) = eel%q0(4+_yy_,j) - qua(_y_,_z_) = eel%q0(4+_yz_,j) - qua(_z_,_x_) = eel%q0(4+_zx_,j) - qua(_z_,_y_) = eel%q0(4+_zy_,j) - qua(_z_,_z_) = eel%q0(4+_zz_,j) - - rqua(_x_,_x_) = eel%q(4+_xx_,j) - rqua(_x_,_y_) = eel%q(4+_xy_,j) - rqua(_x_,_z_) = eel%q(4+_xz_,j) - rqua(_y_,_x_) = eel%q(4+_yx_,j) - rqua(_y_,_y_) = eel%q(4+_yy_,j) - rqua(_y_,_z_) = eel%q(4+_yz_,j) - rqua(_z_,_x_) = eel%q(4+_zx_,j) - rqua(_z_,_y_) = eel%q(4+_zy_,j) - rqua(_z_,_z_) = eel%q(4+_zz_,j) - - ! contributions to the forces on the j-th atoms: - - ddip = 0.0_rp - dqua = 0.0_rp - dtmp = 0.0_rp - ! compute the differentiated multipoles: - do k = 1, 3 - do l = 1, 3 - ddip(:,k) = ddip(:,k) + dri(:,k,l)*dip(l) - end do - end do - - do k = 1, 3 - do l = 1, 3 - do m = 1, 3 - do n = 1, 3 - !dtmp(:,l,m)*rt(m,k) - dqua(:,k,l) = dqua(:,k,l) + (dri(:,k,m)*qua(m,n) - & - rqua(k,m)*dri(:,m,n))*rt(n,l) - end do - end do - end do - end do - - if(.not. frozen_j) then - ! increment the forces for the dipoles... - grad(:,j) = grad(:,j) - ddip(:,_x_)*E(_x_,j) & - - ddip(:,_y_)*E(_y_,j) & - - ddip(:,_z_)*E(_z_,j) - ! ... and for the quadrupoles: - grad(:,j) = grad(:,j) + dqua(:,_x_,_x_)*Egrd(_xx_,j) & - + dqua(:,_y_,_y_)*Egrd(_yy_,j) & - + dqua(:,_z_,_z_)*Egrd(_zz_,j) & - + 2*(dqua(:,_x_,_y_)*Egrd(_xy_,j) & - + dqua(:,_x_,_z_)*Egrd(_xz_,j) & - + dqua(:,_y_,_z_)*Egrd(_yz_,j)) - end if - - ! do jx - ddip = 0.0_rp - dqua = 0.0_rp - dtmp = 0.0_rp - do k = 1, 3 - do l = 1, 3 - ddip(:,k) = ddip(:,k) + drix(:,k,l)*dip(l) - end do - end do - - do k = 1, 3 - do l = 1, 3 - do m = 1, 3 - do n = 1, 3 - !dtmp(:,l,m)*rt(m,k) - dqua(:,k,l) = dqua(:,k,l) + (drix(:,k,m)*qua(m,n) -& - rqua(k,m)*drix(:,m,n))*rt(n,l) - end do - end do - end do - end do - - if(.not. frozen_jx) then - ! increment the forces for the dipoles... - grad(:,jx) = grad(:,jx) - ddip(:,_x_)*E(_x_,j) & - - ddip(:,_y_)*E(_y_,j) & - - ddip(:,_z_)*E(_z_,j) - ! ... and for the quadrupoles: - grad(:,jx) = grad(:,jx) + dqua(:,_x_,_x_)*Egrd(_xx_,j) & - + dqua(:,_y_,_y_)*Egrd(_yy_,j) & - + dqua(:,_z_,_z_)*Egrd(_zz_,j) & - + 2*(dqua(:,_x_,_y_)*Egrd(_xy_,j) & - + dqua(:,_x_,_z_)*Egrd(_xz_,j) & - + dqua(:,_y_,_z_)*Egrd(_yz_,j)) - end if - - ! do jy - ddip = 0.0_rp - dqua = 0.0_rp - dtmp = 0.0_rp - do k = 1, 3 - do l = 1, 3 - ddip(:,k) = ddip(:,k) + driy(:,k,l)*dip(l) - end do - end do - - do k = 1, 3 - do l = 1, 3 - do m = 1, 3 - do n = 1, 3 - ! dtmp(:,l,m)*rt(m,k) - dqua(:,k,l) = dqua(:,k,l) + (driy(:,k,m)*qua(m,n) -& - rqua(k,m)*driy(:,m,n))*rt(n,l) - end do - end do - end do - end do - - if(.not. frozen_jy) then - ! increment the forces for the dipoles... - grad(:,jy) = grad(:,jy) - ddip(:,_x_)*E(_x_,j) & - - ddip(:,_y_)*E(_y_,j) & - - ddip(:,_z_)*E(_z_,j) - ! ... and for the quadrupoles: - grad(:,jy) = grad(:,jy) + dqua(:,_x_,_x_)*Egrd(_xx_,j) & - + dqua(:,_y_,_y_)*Egrd(_yy_,j) & - + dqua(:,_z_,_z_)*Egrd(_zz_,j) & - + 2*(dqua(:,_x_,_y_)*Egrd(_xy_,j) & - + dqua(:,_x_,_z_)*Egrd(_xz_,j) & - + dqua(:,_y_,_z_)*Egrd(_yz_,j)) - end if - - ! Do jz - ddip = 0.0_rp - dqua = 0.0_rp - dtmp = 0.0_rp - do k = 1, 3 - do l = 1, 3 - ddip(:,k) = ddip(:,k) + driz(:,k,l)*dip(l) - end do - end do - - do k = 1, 3 - do l = 1, 3 - do m = 1, 3 - do n = 1, 3 - ! tmp(:,l,m)*rt(m,k) - dqua(:,k,l) = dqua(:,k,l) + (driz(:,k,m)*qua(m,n) -& - rqua(k,m)*driz(:,m,n))*rt(n,l) - end do - end do - end do - end do - - if(.not. frozen_jz) then - ! increment the forces for the dipoles... - grad(:,jz) = grad(:,jz) - ddip(:,_x_)*E(_x_,j) & - - ddip(:,_y_)*E(_y_,j) & - - ddip(:,_z_)*E(_z_,j) - ! ... and for the quadrupoles: - grad(:,jz) = grad(:,jz) + dqua(:,_x_,_x_)*Egrd(_xx_,j) & - + dqua(:,_y_,_y_)*Egrd(_yy_,j) & - + dqua(:,_z_,_z_)*Egrd(_zz_,j) & - + 2*(dqua(:,_x_,_y_)*Egrd(_xy_,j) & - + dqua(:,_x_,_z_)*Egrd(_xz_,j) & - + dqua(:,_y_,_z_)*Egrd(_yz_,j)) - end if - - end do -end subroutine rotation_geomgrad - -subroutine rotate_multipoles(eel) - !! this routine rotates the atomic multipoles from the molecular frame - !! where they are defined as force field parameters to the lab frame. - !! if required, it also computes the contribution to the forces that - !! stems from the derivatives of the rotation matrices, sometimes - !! referred to as "torques". - !! for the latter task, it uses the field and field gradient from - !! at the multipoles, which is passed in def. - !! for consistency reasons, def is dimensioned (ld_cder,mm_atoms). - - use mod_memory, only: ip, rp - use mod_electrostatics, only: ommp_electrostatics_type - - implicit none - - type(ommp_electrostatics_type), intent(inout) :: eel - - integer(ip) :: j, jx, jy, jz - real(rp), dimension(3,3) :: r, rt, qua, rqua, tmp - real(rp), dimension(3,3,3) :: dri, driz, drix, driy - - ! loop over the mm sites and build the rotation matrices. - do j = 1, eel%top%mm_atoms - jz = eel%iz(j) - if(jz == 0) jz = j - jx = eel%ix(j) - if(jx == 0) jx = j - jy = eel%iy(j) - if(jy == 0) jy = j - - call rotation_matrix(.false., & - eel%top%cmm(:,j), eel%top%cmm(:,jx), & - eel%top%cmm(:,jy), eel%top%cmm(:,jz), & - eel%mol_frame(j), & - r, dri, driz, drix, driy) - - rt = transpose(r) - ! copy the monopole: - eel%q(1,j) = eel%q0(1,j) - - ! rotate the dipole - eel%q(2:4,j) = matmul(r,eel%q0(2:4,j)) - - ! exctract, rotate and put back the quadrupole: - qua(_x_,_x_) = eel%q0(4+_xx_,j) - qua(_x_,_y_) = eel%q0(4+_xy_,j) - qua(_x_,_z_) = eel%q0(4+_xz_,j) - qua(_y_,_x_) = eel%q0(4+_yx_,j) - qua(_y_,_y_) = eel%q0(4+_yy_,j) - qua(_y_,_z_) = eel%q0(4+_yz_,j) - qua(_z_,_x_) = eel%q0(4+_zx_,j) - qua(_z_,_y_) = eel%q0(4+_zy_,j) - qua(_z_,_z_) = eel%q0(4+_zz_,j) - - tmp = matmul(r,qua) - rqua = matmul(tmp,rt) - eel%q(4+_xx_,j) = rqua(_x_,_x_) - eel%q(4+_yy_,j) = rqua(_y_,_y_) - eel%q(4+_zz_,j) = rqua(_z_,_z_) - eel%q(4+_xy_,j) = rqua(_x_,_y_) - eel%q(4+_xz_,j) = rqua(_x_,_z_) - eel%q(4+_yz_,j) = rqua(_y_,_z_) - end do -end subroutine rotate_multipoles - - -subroutine rotation_matrix(doder,c,cx,cy,cz,mol_frame,r,dri,driz,drix,driy) - use mod_io, only: fatal_error - use mod_memory, only: ip, rp - use mod_constants, only: eps_rp - - implicit none - !! given an atom j and the reference atoms jx, jy, and jz, this routine - !! computes the rotation matrix needed to rotate the multipoles on the - !! i-th atom from the molecular frame to the lab frame. - !! if required, it also return the derivative of the rotation matrices - !! with respect to the coordinates of all the atoms involved in its - !! definition. - !! - !! this routine is completely general and can be easily augmented with - !! new rotation conventions. - !! - !! given the atoms used to define the molecolar frame, identified by the - !! indices jx, jy, jz, this routine builds the vectors - !! - !! xi = cmm(:,jz) - cmm(:,i) - !! eta = cmm(:,jx) - cmm(:,i) - !! zeta = cmm(:,jy) - cmm(:,i) - !! - !! it then decodes the rotatoin conventions by introducing two vectors, - !! u and v, that span the xz plane. - !! this is the only convention-dependent part: everything else works - !! automatically in a general way. - !! - !! for the definition of u and v, the unit vectors that identify the - !! orthogonal molecular systems are built as follows: - !! - !! ez = u/|u| - !! ex = gram-schmidt (v,ez) - !! ey = ez x ex - !! - !! output: - !! ======= - !! - !! r(i,j) is the rotation matrix, whose columns are (ex,ey,ez) - !! - !! dri(i,j,k) contains the derivative of the i-th component of e_k - !! with respect to ri_j - - logical, intent(in) :: doder - real(rp), intent(in), dimension(3) :: c, cx, cy, cz - integer(ip), intent(in) :: mol_frame - - real(rp), dimension(3,3), intent(out) :: r - real(rp), dimension(3,3,3), intent(inout) :: dri, driz, drix, driy - - integer(ip) :: k - real(rp) :: dot - real(rp) :: xi(3), eta(3), zeta(3), xi_norm, eta_norm, zeta_norm - real(rp) :: u(3), v(3), u_norm, ex(3), ey(3), ez(3), ex_nrm, ex_sq, & - u_sq, u_cube, vez - real(rp), dimension(3,3) :: ez_u, ex_v, ex_ez, ey_ez, ey_ex, u_ri, u_riz, & - u_rix, u_riy, v_ri, v_rix, v_riy, ez_ri, & - ez_riz, ez_rix, ez_riy, ex_ri, ex_riz, & - ex_rix, ex_riy, ey_ri, ey_riz, ey_rix, ey_riy - - real(rp), parameter :: zofac = 0.866_rp - - r = 0.0_rp - - ! get the xi, eta and zeta vectors and their norms: - xi = cz - c - xi_norm = sqrt(dot_product(xi,xi)) - - eta = cx - c - eta_norm = sqrt(dot_product(eta,eta)) - - zeta = cy-c - zeta_norm = sqrt(dot_product(zeta,zeta)) -! -! build the u and v vectors, that span the xz plane according to the specific -! convention: -! - u = 0.0_rp - v = 0.0_rp - if (mol_frame.eq.0) then -! -! do nothing. -! - r(1,1) = 1.0_rp - r(2,2) = 1.0_rp - r(3,3) = 1.0_rp - if (doder) then - dri = 0.0_rp - driz = 0.0_rp - drix = 0.0_rp - driy = 0.0_rp - end if - return -! - else if (mol_frame.eq.1) then -! -! z-then-x convention: -! - u = xi - v = eta -! - else if (mol_frame.eq.2) then -! -! bisector convention: -! - u = eta_norm*xi + xi_norm*eta - v = eta -! - else if (mol_frame.eq.3) then -! -! z-only convention: -! - u = xi - dot = u(3)/xi_norm - if (dot.le.zofac .and. abs(u(2)) > eps_rp) then - v(1) = 1.0_rp - else - v(2) = 1.0_rp - end if -! - else if (mol_frame.eq.4) then -! -! z-bisector convention: -! - u = xi - v = zeta_norm*eta + eta_norm*zeta -! - else if (mol_frame.eq.5) then -! -! 3-fold convention: -! - u = eta_norm*zeta_norm*xi + xi_norm*zeta_norm*eta + xi_norm*eta_norm*zeta - v = eta -! - else -! -! convention not yet implemented. -! - !!TODO call fatal_error('the required rotation convention is not implemented.') - end if -! -! build the unit vectors: -! - if(norm2(u) < eps_rp .or. norm2(v) < eps_rp) then - call fatal_error("Ill defined rotation axis (either u or v vectors have & - &0 norm.") - end if - - u_sq = dot_product(u,u) - u_norm = sqrt(u_sq) - ez = u/u_norm -! - vez = dot_product(v,ez) - ex = v - vez*ez - ex_sq = dot_product(ex,ex) - ex_nrm = sqrt(ex_sq) - ex = ex/ex_nrm -! - ey(1) = ez(2)*ex(3) - ez(3)*ex(2) - ey(2) = ez(3)*ex(1) - ez(1)*ex(3) - ey(3) = ez(1)*ex(2) - ez(2)*ex(1) -! - r(:,1) = ex - r(:,2) = ey - r(:,3) = ez -! -! return if derivatives are not requested: -! - if (.not. doder) return -! -! derivatives code -! ================ -! -! the derivatives of the rotation matrices can be computed using chain-rule -! differentiation. -! please, see JCTC 2014, 10, 1638−1651 for details. -! -! clean interemediates: -! - ez_u = 0.0_rp - ex_v = 0.0_rp - ex_ez = 0.0_rp - ey_ez = 0.0_rp - ey_ex = 0.0_rp - u_ri = 0.0_rp - u_riz = 0.0_rp - u_rix = 0.0_rp - u_riy = 0.0_rp - v_ri = 0.0_rp - v_rix = 0.0_rp - v_riy = 0.0_rp -! -! start by assembling the intermediates that do not depend on the sepcific convention: -! - u_cube = u_sq*u_norm - do k = 1, 3 - ez_u(k,k) = 1.0_rp/u_norm - ex_v(k,k) = 1.0_rp/ex_nrm - ex_ez(k,k) = - vez/ex_nrm - end do - do k = 1, 3 - ez_u(:,k) = ez_u(:,k) - u(:)*u(k)/u_cube - ex_v(:,k) = ex_v(:,k) - ez(:)*ez(k)/ex_nrm - ex(:)*ex(k)/ex_nrm - ex_ez(:,k) = ex_ez(:,k) + ex(:)*vez*v(k)/ex_sq - ez(:)*v(k)/ex_nrm - end do -! - ey_ez(1,1) = 0.0_rp - ey_ez(1,2) = ex(3) - ey_ez(1,3) = - ex(2) - ey_ez(2,1) = - ex(3) - ey_ez(2,2) = 0.0_rp - ey_ez(2,3) = ex(1) - ey_ez(3,1) = ex(2) - ey_ez(3,2) = - ex(1) - ey_ez(3,3) = 0.0_rp -! - ey_ex(1,1) = 0.0_rp - ey_ex(1,2) = - ez(3) - ey_ex(1,3) = ez(2) - ey_ex(2,1) = ez(3) - ey_ex(2,2) = 0.0_rp - ey_ex(2,3) = - ez(1) - ey_ex(3,1) = - ez(2) - ey_ex(3,2) = ez(1) - ey_ex(3,3) = 0.0_rp -! -! now compute the convention-specific terms: -! - if (mol_frame.eq.1) then -! -! z-then-x: -! - do k = 1, 3 - u_ri(k,k) = - 1.0_rp - u_riz(k,k) = 1.0_rp - v_ri(k,k) = - 1.0_rp - v_rix(k,k) = 1.0_rp - end do -! - else if (mol_frame.eq.2) then -! -! bisector: -! - do k = 1, 3 - u_ri(k,k) = - xi_norm - eta_norm - u_riz(k,k) = eta_norm - u_rix(k,k) = xi_norm - v_ri(k,k) = - 1.0_rp - v_rix(k,k) = 1.0_rp - end do -! - do k = 1, 3 - u_ri(:,k) = u_ri(:,k) - eta(:)*xi(k)/xi_norm - xi(:)*eta(k)/eta_norm - u_riz(:,k) = u_riz(:,k) + eta(:)*xi(k)/xi_norm - u_rix(:,k) = u_rix(:,k) + xi(:)*eta(k)/eta_norm - end do -! - else if (mol_frame.eq.3) then -! -! z-only: -! - do k = 1, 3 - u_ri(k,k) = - 1.0_rp - u_riz(k,k) = 1.0_rp - end do -! - else if (mol_frame.eq.4) then -! -! z-bisector: -! - do k = 1, 3 - u_ri(k,k) = - 1.0_rp - u_riz(k,k) = 1.0_rp - v_ri(k,k) = - eta_norm - zeta_norm - v_rix(k,k) = zeta_norm - u_riy(k,k) = eta_norm - end do -! - do k = 1, 3 - v_ri(:,k) = v_ri(:,k) - eta(:)*zeta(k)/zeta_norm - zeta(:)*eta(k)/eta_norm - v_rix(:,k) = v_rix(:,k) + zeta(:)*eta(k)/eta_norm - v_riy(:,k) = v_riy(:,k) + eta(:)*zeta(k)/zeta_norm - end do -! - else if (mol_frame.eq.5) then -! -! 3-fold: -! - do k = 1, 3 - u_ri(k,k) = - xi_norm*eta_norm - xi_norm*zeta_norm - eta_norm*zeta_norm - u_riz(k,k) = eta_norm*zeta_norm - u_rix(k,k) = xi_norm*zeta_norm - u_riy(k,k) = xi_norm*eta_norm - v_ri(k,k) = - 1.0_rp - v_rix(k,k) = 1.0_rp - end do -! - do k = 1, 3 - u_ri(:,k) = u_ri(:,k) - (eta*zeta_norm + zeta*eta_norm)*xi(k)/xi_norm & - - (xi*zeta_norm + zeta*xi_norm )*eta(k)/eta_norm & - - (xi*eta_norm + eta*xi_norm )*zeta(k)/zeta_norm - u_riz(:,k) = u_riz(:,k) + (eta*zeta_norm + zeta*eta_norm)*xi(k)/xi_norm - u_rix(:,k) = u_rix(:,k) + (xi*zeta_norm + zeta*xi_norm )*eta(k)/eta_norm - u_riy(:,k) = u_riy(:,k) + (xi*eta_norm + eta*xi_norm )*zeta(k)/zeta_norm - end do -! - end if -! -! proceed assembling the derivatives of the unit vectors: -! -! ez: -! - ez_ri = matmul(ez_u,u_ri) - ez_riz = matmul(ez_u,u_riz) - ez_rix = matmul(ez_u,u_rix) - ez_riy = matmul(ez_u,u_riy) -! -! ex: -! - ex_ri = matmul(ex_v,v_ri) + matmul(ex_ez,ez_ri) - ex_riz = matmul(ex_ez,ez_riz) - ex_rix = matmul(ex_v,v_rix) + matmul(ex_ez,ez_rix) - ex_riy = matmul(ex_v,v_riy) + matmul(ex_ez,ez_riy) -! -! ey: -! - ey_ri = matmul(ey_ex,ex_ri) + matmul(ey_ez,ez_ri) - ey_riz = matmul(ey_ex,ex_riz) + matmul(ey_ez,ez_riz) - ey_rix = matmul(ey_ex,ex_rix) + matmul(ey_ez,ez_rix) - ey_riy = matmul(ey_ex,ex_riy) + matmul(ey_ez,ez_riy) -! -! finally, assemble the derivatives of the rotation matrices: -! - dri(:,:,1) = transpose(ex_ri) - dri(:,:,2) = transpose(ey_ri) - dri(:,:,3) = transpose(ez_ri) - driz(:,:,1) = transpose(ex_riz) - driz(:,:,2) = transpose(ey_riz) - driz(:,:,3) = transpose(ez_riz) - drix(:,:,1) = transpose(ex_rix) - drix(:,:,2) = transpose(ey_rix) - drix(:,:,3) = transpose(ez_rix) - driy(:,:,1) = transpose(ex_riy) - driy(:,:,2) = transpose(ey_riy) - driy(:,:,3) = transpose(ez_riy) -end subroutine rotation_matrix diff --git a/src/smartinput.c b/src/smartinput.c index cff7026..e761542 100644 --- a/src/smartinput.c +++ b/src/smartinput.c @@ -8,18 +8,21 @@ #include #define NELEM 19 -char ELEMENTS[NELEM][2] = {"X", - "H", "He", +char ELEMENTS[NELEM][2] = {"X", + "H", "He", "Li", "Be", "B", "C", "N", "O", "F", "Ne", "Na", "Mg", "Al", "Si", "P", "S", "Cl", "Ar"}; -int element_to_Z(char *elem){ - for(int i=0; i slen) return false; + if (elen > slen) + return false; - if(strcmp(&(s[slen-elen]), e) != 0) return false; + if (strcmp(&(s[slen - elen]), e) != 0) + return false; return true; } -semversion str_to_semversion(char *strin){ +semversion str_to_semversion(char *strin) +{ semversion v; v.major = -1; v.minor = -1; @@ -59,29 +66,31 @@ semversion str_to_semversion(char *strin){ sprintf(msg, "Major \"%s\".", major); ommp_message(msg, OMMP_VERBOSE_DEBUG, "SemVersDB"); - for(i = 0; major[i] != '\0' && major_ok; i++) + for (i = 0; major[i] != '\0' && major_ok; i++) major_ok = (major_ok && isdigit(major[i])); - major_ok = (major_ok && i>0); + major_ok = (major_ok && i > 0); - if(!major_ok){ + if (!major_ok) + { sprintf(msg, "Malformed major version in \"%s\".", strin); ommp_message(msg, OMMP_VERBOSE_LOW, "SemVers"); return v_err; } v.major = atoi(major); - + char *minor = strtok(NULL, "."); bool minor_ok = (minor != NULL); - + sprintf(msg, "Minor \"%s\".", minor); ommp_message(msg, OMMP_VERBOSE_DEBUG, "SemVersDB"); - for(i = 0; minor[i] != '\0' && minor_ok; i++) + for (i = 0; minor[i] != '\0' && minor_ok; i++) minor_ok = (minor_ok && isdigit(minor[i])); - minor_ok = (minor_ok && i>0); + minor_ok = (minor_ok && i > 0); - if(!minor_ok){ + if (!minor_ok) + { sprintf(msg, "Malformed minor version in \"%s\".", strin); ommp_message(msg, OMMP_VERBOSE_LOW, "SemVers"); return v_err; @@ -98,11 +107,12 @@ semversion str_to_semversion(char *strin){ sprintf(msg, "Patch \"%s\".", patch); ommp_message(msg, OMMP_VERBOSE_DEBUG, "SemVersDB"); - for(i = 0; patch[i] != '\0' && patch_ok; i++) + for (i = 0; patch[i] != '\0' && patch_ok; i++) patch_ok = (patch_ok && isdigit(patch[i])); - patch_ok = (patch_ok && i>0); + patch_ok = (patch_ok && i > 0); - if(!patch_ok){ + if (!patch_ok) + { sprintf(msg, "Malformed patch version in \"%s\".", strin); ommp_message(msg, OMMP_VERBOSE_LOW, "SemVers"); return v_err; @@ -110,8 +120,10 @@ semversion str_to_semversion(char *strin){ v.patch = atoi(patch); - if(plus != NULL){ - if(strtok(NULL, "+") != NULL || plus[0] != 'r'){ + if (plus != NULL) + { + if (strtok(NULL, "+") != NULL || plus[0] != 'r') + { sprintf(msg, "Malformed pre-release string in \"%s\".", strin); ommp_message(msg, OMMP_VERBOSE_LOW, "SemVers"); return v_err; @@ -123,30 +135,35 @@ semversion str_to_semversion(char *strin){ plus = &(plus[1]); char *ncommits = strtok(plus, "."); bool ncommits_ok = (ncommits != NULL); - if(ncommits_ok && strcmp(ncommits, "dirty") == 0){ + if (ncommits_ok && strcmp(ncommits, "dirty") == 0) + { v.clean = false; v.ncommit = 0; } - else{ - for(i = 0; ncommits[i] != '\0' && ncommits_ok; i++) + else + { + for (i = 0; ncommits[i] != '\0' && ncommits_ok; i++) ncommits_ok = (ncommits_ok && isdigit(ncommits[i])); - ncommits_ok = (ncommits_ok && i>0); - - if(!ncommits_ok){ + ncommits_ok = (ncommits_ok && i > 0); + + if (!ncommits_ok) + { sprintf(msg, "Malformed pre-release string in \"%s\".", strin); ommp_message(msg, OMMP_VERBOSE_LOW, "SemVers"); return v_err; } v.ncommit = atoi(&(ncommits[0])); - + char *commithash = strtok(NULL, "."); bool commithash_ok = (commithash != NULL); - for(i = 0; commithash[i] != '\0' && commithash_ok; i++); + for (i = 0; commithash[i] != '\0' && commithash_ok; i++) + ; commithash_ok = (commithash_ok && i == 8); - - if(!commithash_ok){ + + if (!commithash_ok) + { sprintf(msg, "Malformed pre-release string in \"%s\".", strin); ommp_message(msg, OMMP_VERBOSE_LOW, "SemVers"); return v_err; @@ -155,10 +172,12 @@ semversion str_to_semversion(char *strin){ strcpy(v.commit, commithash); char *clean = strtok(NULL, "."); - if(clean != NULL){ - if(strcmp(clean, "dirty") == 0) + if (clean != NULL) + { + if (strcmp(clean, "dirty") == 0) v.clean = false; - else{ + else + { sprintf(msg, "Malformed pre-release string in \"%s\".", strin); ommp_message(msg, OMMP_VERBOSE_LOW, "SemVers"); return v_err; @@ -166,121 +185,146 @@ semversion str_to_semversion(char *strin){ } } } - else{ + else + { v.ncommit = 0; } return v; } -bool md5_file_check(const char* my_file, const char *md5_sum){ - // This function verifies if the file at the address of my_file has +bool md5_file_check(const char *my_file, const char *md5_sum) +{ + // This function verifies if the file at the address of my_file has // the md5 sum defined by md5_sum. Return false if the check fail. unsigned char c[MD5_DIGEST_LENGTH]; FILE *fp = fopen(my_file, "rb"); MD5_CTX mdContext; - if(fp == NULL) return false; + if (fp == NULL) + return false; #define BUF_SIZE 1024 unsigned char buf[BUF_SIZE]; MD5_Init(&mdContext); - for(size_t nrd; (nrd = fread(buf, 1, BUF_SIZE, fp)) > 0;) - MD5_Update (&mdContext, buf, nrd); - MD5_Final (c, &mdContext); + for (size_t nrd; (nrd = fread(buf, 1, BUF_SIZE, fp)) > 0;) + MD5_Update(&mdContext, buf, nrd); + MD5_Final(c, &mdContext); #undef BUF_SIZE unsigned int l; - - for(int i = 0; i < MD5_DIGEST_LENGTH; i++){ - sscanf(&(md5_sum[i*2]), "%2x", &l); - if(l != c[i]) return false; + + for (int i = 0; i < MD5_DIGEST_LENGTH; i++) + { + sscanf(&(md5_sum[i * 2]), "%2x", &l); + if (l != c[i]) + return false; } fclose(fp); return true; } -bool check_file(cJSON *file_json, char **path, char *outmode){ +bool check_file(cJSON *file_json, char **path, char *outmode) +{ // It should be a structure - if(!cJSON_IsObject(file_json)){ + if (!cJSON_IsObject(file_json)) + { ommp_message("Unexpected errror: qm_json is not a cJSON object.", OMMP_VERBOSE_LOW, "SI file"); return false; } - + cJSON *file_data = file_json->child; char *md5sum = NULL; char errstring[OMMP_STR_CHAR_MAX]; char accessmode = 'r'; *path = NULL; - while(file_data != NULL){ - if(strcmp(file_data->string, "path") == 0){ - if(cJSON_IsString(file_data)) + while (file_data != NULL) + { + if (strcmp(file_data->string, "path") == 0) + { + if (cJSON_IsString(file_data)) *path = file_data->valuestring; - else{ + else + { ommp_message("File's path should be a string.", OMMP_VERBOSE_LOW, "SI file"); return false; } } - else if(strcmp(file_data->string, "md5sum") == 0){ - if(cJSON_IsString(file_data)) + else if (strcmp(file_data->string, "md5sum") == 0) + { + if (cJSON_IsString(file_data)) md5sum = file_data->valuestring; - else{ + else + { ommp_message("File's md5sum should be a string.", OMMP_VERBOSE_LOW, "SI file"); return false; } } - else if(strcmp(file_data->string, "mode") == 0){ + else if (strcmp(file_data->string, "mode") == 0) + { // Default mode is read, for output either append or write or overwrite should be specified. - if(strcmp(file_data->valuestring, "read") == 0){ + if (strcmp(file_data->valuestring, "read") == 0) + { accessmode = 'r'; } - else if(strcmp(file_data->valuestring, "write") == 0){ + else if (strcmp(file_data->valuestring, "write") == 0) + { accessmode = 'w'; } - else{ + else + { sprintf(errstring, "Unrecognized file access mode %s; assuming read.", file_data->valuestring); ommp_message(errstring, OMMP_VERBOSE_LOW, "SIfile"); } } - else{ + else + { sprintf(errstring, "Unrecognized file attribute %s", file_data->string); ommp_message(errstring, OMMP_VERBOSE_LOW, "SIfile"); } file_data = file_data->next; } // It should contain a path - if(*path == NULL){ + if (*path == NULL) + { ommp_message("File entry does not contain a path.", OMMP_VERBOSE_LOW, "SI file"); return false; } FILE *fp = fopen(*path, "r"); - if(fp == NULL && accessmode == 'r'){ + if (fp == NULL && accessmode == 'r') + { sprintf(errstring, "File %s in read mode does not exist.", *path); ommp_message(errstring, OMMP_VERBOSE_LOW, "SI file"); return false; } - - if(fp != NULL && accessmode == 'w'){ + + if (fp != NULL && accessmode == 'w') + { sprintf(errstring, "File %s in write mode already exists, cannot overwrite.", *path); ommp_message(errstring, OMMP_VERBOSE_LOW, "SI file"); return false; } - if(fp != NULL) fclose(fp); + if (fp != NULL) + fclose(fp); *outmode = accessmode; // It could contain an md5sum - if(md5sum != NULL){ - if(accessmode == 'w'){ + if (md5sum != NULL) + { + if (accessmode == 'w') + { sprintf(errstring, "md5sum check does not make any sense for output files; skipping."); ommp_message(errstring, OMMP_VERBOSE_LOW, "SI file"); } - else{ + else + { // The md5 sum should be correct bool md5chk = md5_file_check(*path, md5sum); - if(!md5chk){ + if (!md5chk) + { sprintf(errstring, "File %s does not correspond to md5sum %s.", *path, md5sum); ommp_message(errstring, OMMP_VERBOSE_LOW, "SI file"); return false; @@ -290,27 +334,38 @@ bool check_file(cJSON *file_json, char **path, char *outmode){ return true; } -bool check_version(char *verstr){ +bool check_version(char *verstr) +{ semversion vreq = str_to_semversion(verstr); - if(vreq.major < 0) return false; - + if (vreq.major < 0) + return false; + char ommp_vstr[256]; sprintf(ommp_vstr, "%s", OMMP_VERSION_STRING); semversion vommp = str_to_semversion(ommp_vstr); - if(vommp.major < 0) return false; - - if(vreq.major < vommp.major) return true; - if(vreq.major > vommp.major) return false; - - if(vreq.minor < vommp.minor) return true; - if(vreq.minor > vommp.minor) return false; - - if(vreq.patch < vommp.patch) return true; - if(vreq.patch > vommp.patch) return false; - if(vreq.ncommit == 0 && vommp.ncommit > 0) return true; - if(vreq.ncommit > 0 && vommp.ncommit > 0){ - if(vreq.ncommit == vommp.ncommit && - strcmp(vreq.commit, vommp.commit) == 0) + if (vommp.major < 0) + return false; + + if (vreq.major < vommp.major) + return true; + if (vreq.major > vommp.major) + return false; + + if (vreq.minor < vommp.minor) + return true; + if (vreq.minor > vommp.minor) + return false; + + if (vreq.patch < vommp.patch) + return true; + if (vreq.patch > vommp.patch) + return false; + if (vreq.ncommit == 0 && vommp.ncommit > 0) + return true; + if (vreq.ncommit > 0 && vommp.ncommit > 0) + { + if (vreq.ncommit == vommp.ncommit && + strcmp(vreq.commit, vommp.commit) == 0) return true; else return false; @@ -319,13 +374,15 @@ bool check_version(char *verstr){ return true; } -bool smartinput_qm(cJSON *qm_json, OMMP_QM_HELPER_PRT *qmh){ +bool smartinput_qm(cJSON *qm_json, OMMP_QM_HELPER_PRT *qmh) +{ // It should be a structure - if(!cJSON_IsObject(qm_json)){ + if (!cJSON_IsObject(qm_json)) + { ommp_message("Unexpected errror: qm_json is not a cJSON object.", OMMP_VERBOSE_LOW, "SI QMH"); return false; } - + cJSON *qm_data = qm_json->child; char errstring[OMMP_STR_CHAR_MAX]; unsigned int natoms = 0; @@ -333,202 +390,246 @@ bool smartinput_qm(cJSON *qm_json, OMMP_QM_HELPER_PRT *qmh){ double *coords = NULL, *nucq = NULL; char *xyz_path = NULL, *prm_path = NULL; char mode, *path; - int32_t nfrozen=0, *frozenat=NULL; - - while(qm_data != NULL){ - if(str_ends_with(qm_data->string, "_file")){ - if(! check_file(qm_data, &path, &mode)){ + int32_t nfrozen = 0, *frozenat = NULL; + + while (qm_data != NULL) + { + if (str_ends_with(qm_data->string, "_file")) + { + if (!check_file(qm_data, &path, &mode)) + { sprintf(errstring, "File check on \"%s\" has failed.", qm_data->string); ommp_fatal(errstring); }; - - if(mode != 'r' && mode != 'w'){ + + if (mode != 'r' && mode != 'w') + { sprintf(errstring, "Unrecognized file access mode (unexpected error) '%c'.", mode); ommp_fatal(errstring); } } - if(strcmp(qm_data->string, "xyz_file") == 0){ - if(mode != 'r'){ + if (strcmp(qm_data->string, "xyz_file") == 0) + { + if (mode != 'r') + { sprintf(errstring, "xyz_file should be in read mode."); ommp_fatal(errstring); } xyz_path = path; } - else if(strcmp(qm_data->string, "prm_file") == 0){ - if(mode != 'r'){ + else if (strcmp(qm_data->string, "prm_file") == 0) + { + if (mode != 'r') + { sprintf(errstring, "prm_file should be in read mode."); ommp_fatal(errstring); } prm_path = path; } - else if(strcmp(qm_data->string, "qm_atoms") == 0){ - if(cJSON_IsArray(qm_data)){ + else if (strcmp(qm_data->string, "qm_atoms") == 0) + { + if (cJSON_IsArray(qm_data)) + { cJSON *qmat_array = qm_data->child; unsigned int nat; // Check number of elements in array - for(nat = 0; qmat_array != NULL; qmat_array = qmat_array->next) nat++; - if(natoms == 0){ - if(nat == 0){ + for (nat = 0; qmat_array != NULL; qmat_array = qmat_array->next) + nat++; + if (natoms == 0) + { + if (nat == 0) + { ommp_message("qm_atoms length is zero, that is wired!", OMMP_VERBOSE_LOW, "SI QMH"); return false; } natoms = nat; } - else if(natoms != nat){ - ommp_message("qm_atoms length does not match the length of other arrays in qm", + else if (natoms != nat) + { + ommp_message("qm_atoms length does not match the length of other arrays in qm", OMMP_VERBOSE_LOW, "SI QMH"); return false; } - qmz = (int32_t *) malloc((int32_t) sizeof(int32_t) * natoms); - nucq = (double *) malloc(sizeof(double) * natoms); + qmz = (int32_t *)malloc((int32_t)sizeof(int32_t) * natoms); + nucq = (double *)malloc(sizeof(double) * natoms); qmat_array = qm_data->child; - for(int i=0; qmat_array != NULL; i++){ - if(!cJSON_IsString(qmat_array)){ + for (int i = 0; qmat_array != NULL; i++) + { + if (!cJSON_IsString(qmat_array)) + { ommp_message("qm_atoms should be an array of strings.", OMMP_VERBOSE_LOW, "SI QMH"); return false; } qmz[i] = element_to_Z(qmat_array->valuestring); - if(qmz[i] <= 0){ + if (qmz[i] <= 0) + { sprintf(errstring, "%s is not a recognized element.", qmat_array->valuestring); ommp_message(errstring, OMMP_VERBOSE_LOW, "SI QMH"); return false; } - nucq[i] = (double) qmz[i]; + nucq[i] = (double)qmz[i]; qmat_array = qmat_array->next; } - } - else{ + else + { ommp_message("qm_atoms should be an array of strings.", OMMP_VERBOSE_LOW, "SI QMH"); return false; } } - else if(strcmp(qm_data->string, "qm_coords") == 0){ - if(cJSON_IsArray(qm_data)){ + else if (strcmp(qm_data->string, "qm_coords") == 0) + { + if (cJSON_IsArray(qm_data)) + { cJSON *qc_array = qm_data->child; unsigned int nat; // Check number of elements in array - for(nat = 0; qc_array != NULL; qc_array = qc_array->next) nat++; - if(natoms == 0){ - if(nat == 0){ + for (nat = 0; qc_array != NULL; qc_array = qc_array->next) + nat++; + if (natoms == 0) + { + if (nat == 0) + { ommp_message("qm_coords length is zero, that is wired!", OMMP_VERBOSE_LOW, "SI QMH"); return false; } natoms = nat; } - else if(natoms != nat){ - ommp_message("qm_coords length does not match the length of other arrays in qm", + else if (natoms != nat) + { + ommp_message("qm_coords length does not match the length of other arrays in qm", OMMP_VERBOSE_LOW, "SI QMH"); return false; } - coords = (double *) malloc(sizeof(double) * natoms * 3); + coords = (double *)malloc(sizeof(double) * natoms * 3); qc_array = qm_data->child; - for(int i=0; qc_array != NULL; i++){ - if(!cJSON_IsArray(qc_array)){ - ommp_message("qm_coords should be a 3 x natoms matrix of double.", + for (int i = 0; qc_array != NULL; i++) + { + if (!cJSON_IsArray(qc_array)) + { + ommp_message("qm_coords should be a 3 x natoms matrix of double.", OMMP_VERBOSE_LOW, "SI QMH"); return false; } cJSON *rowel = qc_array->child; - for(int j=0; j < 3; j++){ - if(!cJSON_IsNumber(rowel) || (j==2 && rowel->next != NULL)){ - ommp_message("qm_coords should be a 3 x natoms matrix of double.", - OMMP_VERBOSE_LOW, "SI QMH"); + for (int j = 0; j < 3; j++) + { + if (!cJSON_IsNumber(rowel) || (j == 2 && rowel->next != NULL)) + { + ommp_message("qm_coords should be a 3 x natoms matrix of double.", + OMMP_VERBOSE_LOW, "SI QMH"); return false; } - coords[3*i+j] = rowel->valuedouble * OMMP_ANG2AU; + coords[3 * i + j] = rowel->valuedouble * OMMP_ANG2AU; rowel = rowel->next; } qc_array = qc_array->next; } } - else{ - ommp_message("qm_coords should be a 3 x natoms matrix of double.", - OMMP_VERBOSE_LOW, "SI QMH"); + else + { + ommp_message("qm_coords should be a 3 x natoms matrix of double.", + OMMP_VERBOSE_LOW, "SI QMH"); return false; } } - else if(strcmp(qm_data->string, "qm_atom_types") == 0){ - if(cJSON_IsArray(qm_data)){ + else if (strcmp(qm_data->string, "qm_atom_types") == 0) + { + if (cJSON_IsArray(qm_data)) + { cJSON *qmat_array = qm_data->child; unsigned int nat; // Check number of elements in array - for(nat = 0; qmat_array != NULL; qmat_array = qmat_array->next) nat++; - if(natoms == 0){ - if(nat == 0){ + for (nat = 0; qmat_array != NULL; qmat_array = qmat_array->next) + nat++; + if (natoms == 0) + { + if (nat == 0) + { ommp_message("qm_atom_types length is zero, that is wired!", OMMP_VERBOSE_LOW, "SI QMH"); return false; } natoms = nat; } - else if(natoms != nat){ - ommp_message("qm_atom_types length does not match the length of other arrays in qm", + else if (natoms != nat) + { + ommp_message("qm_atom_types length does not match the length of other arrays in qm", OMMP_VERBOSE_LOW, "SI QMH"); return false; } - qmt = (int32_t *) malloc(sizeof(int32_t) * natoms); + qmt = (int32_t *)malloc(sizeof(int32_t) * natoms); qmat_array = qm_data->child; - for(int i=0; qmat_array != NULL; i++){ - if(!cJSON_IsNumber(qmat_array)){ + for (int i = 0; qmat_array != NULL; i++) + { + if (!cJSON_IsNumber(qmat_array)) + { ommp_message("qm_atom_types should be an array of integers.", OMMP_VERBOSE_LOW, "SI QMH"); return false; } qmt[i] = qmat_array->valueint; - if(qmt[i] <= 0){ + if (qmt[i] <= 0) + { sprintf(errstring, "Atom types should be positive (found %d).", qmat_array->valueint); ommp_message(errstring, OMMP_VERBOSE_LOW, "SI QMH"); return false; } qmat_array = qmat_array->next; } - } - else{ + else + { ommp_message("qm_atom_types should be an array of integers.", OMMP_VERBOSE_LOW, "SI QMH"); return false; } } - else if(strcmp(qm_data->string, "qm_frozen_atoms") == 0){ - if(!cJSON_IsArray(qm_data)) + else if (strcmp(qm_data->string, "qm_frozen_atoms") == 0) + { + if (!cJSON_IsArray(qm_data)) ommp_fatal("qm_frozen_atoms should be an array of integers!"); - if(nfrozen > 0) + if (nfrozen > 0) ommp_fatal("Only a single frozen_atoms section should be present"); cJSON *_arr = qm_data->child; - for(nfrozen = 0; _arr != NULL; _arr = _arr->next){ - if(!cJSON_IsNumber(_arr)) + for (nfrozen = 0; _arr != NULL; _arr = _arr->next) + { + if (!cJSON_IsNumber(_arr)) ommp_fatal("frozen_atoms should be an array of integers!"); nfrozen++; } - - frozenat = (int32_t *) malloc(sizeof(int32_t) * nfrozen); - + + frozenat = (int32_t *)malloc(sizeof(int32_t) * nfrozen); + _arr = qm_data->child; - for(int i = 0; _arr != NULL; i++){ + for (int i = 0; _arr != NULL; i++) + { frozenat[i] = _arr->valueint; _arr = _arr->next; } } - else{ + else + { sprintf(errstring, "Unrecognized qm attribute %s", qm_data->string); ommp_message(errstring, OMMP_VERBOSE_LOW, "SI QMH"); } qm_data = qm_data->next; } - - if(qmz != NULL && nucq != NULL){ - if(xyz_path != NULL){ - ommp_message("Both qm_atoms, qm_coords and xyz_file are set, this is ambiguous.", + + if (qmz != NULL && nucq != NULL) + { + if (xyz_path != NULL) + { + ommp_message("Both qm_atoms, qm_coords and xyz_file are set, this is ambiguous.", OMMP_VERBOSE_LOW, "SI QMH"); return false; } - if(coords == NULL){ + if (coords == NULL) + { ommp_message("Both qm_atoms and qm_coords should be set in a correct input.", OMMP_VERBOSE_LOW, "SI QMH"); return false; @@ -536,309 +637,365 @@ bool smartinput_qm(cJSON *qm_json, OMMP_QM_HELPER_PRT *qmh){ *qmh = ommp_init_qm_helper(natoms, coords, nucq, qmz); } - else if(coords != NULL){ + else if (coords != NULL) + { ommp_message("Both qm_atoms and qm_coords should be set in a correct input.", OMMP_VERBOSE_LOW, "SI QMH"); return false; } - else if(xyz_path != NULL){ + else if (xyz_path != NULL) + { ommp_message("QM input from xyz is currently unsupported!", OMMP_VERBOSE_LOW, "SI QMH"); return false; - } - else{ + else + { ommp_message("Either qm_atoms and qm_coords or xyz_file should be set in qm section!", OMMP_VERBOSE_LOW, "SI QMH"); return false; } - if(qmt != NULL){ + if (qmt != NULL) + { ommp_qm_helper_set_attype(*qmh, qmt); - if(prm_path != NULL){ + if (prm_path != NULL) + { ommp_qm_helper_init_vdw_prm(*qmh, prm_path); } - else{ + else + { ommp_message("Since qm_atom_types is present but prm_file is not, atom types are set, while VdW are not.", OMMP_VERBOSE_LOW, "SI QMH"); } free(qmt); } - else if(prm_path != NULL){ + else if (prm_path != NULL) + { ommp_message("prm_file is only needed when qm_atom_types is set, your config does not make any sense.", OMMP_VERBOSE_LOW, "SI QMH"); return false; } - if(frozenat != NULL){ + if (frozenat != NULL) + { ommp_qm_helper_set_frozen_atoms(*qmh, nfrozen, frozenat); } - if(qmz != NULL) free(qmz); - if(nucq != NULL) free(nucq); - if(coords != NULL) free(coords); - if(frozenat != NULL) free(frozenat); + if (qmz != NULL) + free(qmz); + if (nucq != NULL) + free(nucq); + if (coords != NULL) + free(coords); + if (frozenat != NULL) + free(frozenat); return true; } -void c_smartinput(const char *json_file, OMMP_SYSTEM_PRT *ommp_sys, OMMP_QM_HELPER_PRT *ommp_qmh){ +void c_smartinput(const char *json_file, OMMP_SYSTEM_PRT *ommp_sys, OMMP_QM_HELPER_PRT *ommp_qmh) +{ char msg[OMMP_STR_CHAR_MAX]; - + // Read the whole file content sprintf(msg, "Parsing JSON file \"%s\".", json_file); ommp_message(msg, OMMP_VERBOSE_LOW, "SI"); FILE *fp = fopen(json_file, "r"); - if(fp == NULL){ + if (fp == NULL) + { sprintf(msg, "Unable to open %s", json_file); ommp_fatal(msg); } // Get file size ... size_t fsize; - for(fsize = 0; getc(fp) != EOF; fsize++); + for (fsize = 0; getc(fp) != EOF; fsize++) + ; rewind(fp); - char *file_content = (char *) malloc(fsize * sizeof(char)); + char *file_content = (char *)malloc(fsize * sizeof(char)); fread(file_content, sizeof(char), fsize, fp); // Parse the input json cJSON *input_json = cJSON_ParseWithLength(file_content, fsize); free(file_content); - if(input_json == NULL){ + if (input_json == NULL) + { const char *err = cJSON_GetErrorPtr(); - if(err != NULL) + if (err != NULL) sprintf(msg, "Error before %s.", err); else sprintf(msg, "Unexpected error during JSON parsing."); ommp_fatal(msg); } - + cJSON *cur = input_json->child; char *path, *xyz_path = NULL, *prm_path = NULL, - *hdf5_path = NULL, *mmpol_path = NULL, - *output_path = NULL, mode; - char *json_name=NULL, *json_description=NULL; + *hdf5_path = NULL, *mmpol_path = NULL, + *output_path = NULL, mode; + char *json_name = NULL, *json_description = NULL; int32_t req_verbosity = OMMP_VERBOSE_DEFAULT, req_solver = OMMP_SOLVER_DEFAULT, req_matv = OMMP_MATV_DEFAULT; - - int32_t *la_mm=NULL, *la_qm=NULL, *la_la=NULL, *la_ner=NULL; - unsigned int nfrozen = 0, nla = 0, nremovepol=0; - int32_t *frozenat=NULL, *removepolat=NULL; - double *la_bl=NULL; + + int32_t *la_mm = NULL, *la_qm = NULL, *la_la = NULL, *la_ner = NULL; + unsigned int nfrozen = 0, nla = 0, nremovepol = 0; + int32_t *frozenat = NULL, *removepolat = NULL; + double *la_bl = NULL; double vdw_cutoff = OMMP_DEFAULT_NL_CUTOFF; *ommp_qmh = NULL; - while(cur != NULL){ + while (cur != NULL) + { sprintf(msg, "Parsing JSON element \"%s\".", cur->string); ommp_message(msg, OMMP_VERBOSE_DEBUG, "SIDB"); - if(str_ends_with(cur->string, "_file")){ - if(! check_file(cur, &path, &mode)){ + if (str_ends_with(cur->string, "_file")) + { + if (!check_file(cur, &path, &mode)) + { sprintf(msg, "File check on \"%s\" has failed.", cur->string); ommp_fatal(msg); }; - - if(mode != 'r' && mode != 'w'){ + + if (mode != 'r' && mode != 'w') + { sprintf(msg, "Unrecognized file access mode (unexpected error) '%c'.", mode); ommp_fatal(msg); } } - if(strcmp(cur->string, "xyz_file") == 0){ - if(mode != 'r'){ + if (strcmp(cur->string, "xyz_file") == 0) + { + if (mode != 'r') + { sprintf(msg, "xyz_file should be in read mode."); ommp_fatal(msg); } xyz_path = path; } - else if(strcmp(cur->string, "prm_file") == 0){ - if(mode != 'r'){ + else if (strcmp(cur->string, "prm_file") == 0) + { + if (mode != 'r') + { sprintf(msg, "prm_file should be in read mode."); ommp_fatal(msg); } prm_path = path; } - else if(strcmp(cur->string, "hdf5_file") == 0){ - if(mode != 'r'){ + else if (strcmp(cur->string, "hdf5_file") == 0) + { + if (mode != 'r') + { sprintf(msg, "hdf5_file should be in read mode."); ommp_fatal(msg); } hdf5_path = path; } - else if(strcmp(cur->string, "mmpol_file") == 0){ - if(mode != 'r'){ + else if (strcmp(cur->string, "mmpol_file") == 0) + { + if (mode != 'r') + { sprintf(msg, "mmpol_file should be in read mode."); ommp_fatal(msg); } mmpol_path = path; } - else if(strcmp(cur->string, "output_file") == 0){ - if(mode != 'w'){ + else if (strcmp(cur->string, "output_file") == 0) + { + if (mode != 'w') + { sprintf(msg, "output_file should be in write mode."); ommp_fatal(msg); } output_path = path; } - else if(strcmp(cur->string, "qm") == 0){ + else if (strcmp(cur->string, "qm") == 0) + { ommp_message("Initializing QM object", OMMP_VERBOSE_DEBUG, "SI"); - if(*ommp_qmh == NULL){ - if(!smartinput_qm(cur, ommp_qmh)) + if (*ommp_qmh == NULL) + { + if (!smartinput_qm(cur, ommp_qmh)) ommp_fatal("Error during creation of QM Helper object"); } else ommp_fatal("Only a single qm section can be present in smart input"); } - else if(strcmp(cur->string, "version") == 0){ - if(!check_version(cur->valuestring)){ + else if (strcmp(cur->string, "version") == 0) + { + if (!check_version(cur->valuestring)) + { sprintf(msg, "Required version (%s) is not compatible with OMMP version (%s).", cur->valuestring, OMMP_VERSION_STRING); ommp_message(msg, OMMP_VERBOSE_LOW, "SI"); ommp_fatal("Cannot complete Smart Input initialization."); } - sprintf(msg, "Required version (%s) is compatible with OMMP version (%s).", cur->valuestring, OMMP_VERSION_STRING); - ommp_message(msg, OMMP_VERBOSE_LOW, "SI"); + sprintf(msg, "Required version (%s) is compatible with OMMP version (%s).", cur->valuestring, OMMP_VERSION_STRING); + ommp_message(msg, OMMP_VERBOSE_LOW, "SI"); } - else if(strcmp(cur->string, "verbosity") == 0){ - if(strcmp(cur->valuestring, "none") == 0) + else if (strcmp(cur->string, "verbosity") == 0) + { + if (strcmp(cur->valuestring, "none") == 0) req_verbosity = OMMP_VERBOSE_NONE; - else if(strcmp(cur->valuestring, "low") == 0) + else if (strcmp(cur->valuestring, "low") == 0) req_verbosity = OMMP_VERBOSE_LOW; - else if(strcmp(cur->valuestring, "high") == 0) + else if (strcmp(cur->valuestring, "high") == 0) req_verbosity = OMMP_VERBOSE_HIGH; - else if(strcmp(cur->valuestring, "debug") == 0) + else if (strcmp(cur->valuestring, "debug") == 0) req_verbosity = OMMP_VERBOSE_DEBUG; } - else if(strcmp(cur->string, "name") == 0){ + else if (strcmp(cur->string, "name") == 0) + { json_name = cur->valuestring; } - else if(strcmp(cur->string, "description") == 0){ + else if (strcmp(cur->string, "description") == 0) + { json_description = cur->valuestring; } - else if(strcmp(cur->string, "solver") == 0){ - if(strcmp(cur->valuestring, "default") == 0) + else if (strcmp(cur->string, "solver") == 0) + { + if (strcmp(cur->valuestring, "default") == 0) req_solver = OMMP_SOLVER_DEFAULT; - else if(strcmp(cur->valuestring, "conjugate gradient") == 0 || strcmp(cur->valuestring, "cg") == 0) + else if (strcmp(cur->valuestring, "conjugate gradient") == 0 || strcmp(cur->valuestring, "cg") == 0) req_solver = OMMP_SOLVER_CG; - else if(strcmp(cur->valuestring, "inversion") == 0) + else if (strcmp(cur->valuestring, "inversion") == 0) req_solver = OMMP_SOLVER_INVERSION; - else if(strcmp(cur->valuestring, "diis") == 0) + else if (strcmp(cur->valuestring, "diis") == 0) req_solver = OMMP_SOLVER_DIIS; - else{ + else + { sprintf(msg, "Unrecognized option \"%s\" for solver; Available solvers are default, conjugate gradient, cg, inversion, diis.", cur->valuestring); ommp_fatal(msg); } } - else if(strcmp(cur->string, "matrix_vector") == 0){ - if(strcmp(cur->valuestring, "default") == 0) + else if (strcmp(cur->string, "matrix_vector") == 0) + { + if (strcmp(cur->valuestring, "default") == 0) req_matv = OMMP_MATV_DEFAULT; - else if(strcmp(cur->valuestring, "direct") == 0) + else if (strcmp(cur->valuestring, "direct") == 0) req_matv = OMMP_MATV_DIRECT; - else if(strcmp(cur->valuestring, "incore") == 0) + else if (strcmp(cur->valuestring, "incore") == 0) req_matv = OMMP_MATV_INCORE; - else{ + else + { sprintf(msg, "Unrecognized option \"%s\" for matrix_vector; Available solvers are default, direct, incore.", cur->valuestring); ommp_fatal(msg); } } - else if(strcmp(cur->string, "frozen_atoms") == 0){ - if(!cJSON_IsArray(cur)) + else if (strcmp(cur->string, "frozen_atoms") == 0) + { + if (!cJSON_IsArray(cur)) ommp_fatal("frozen_atoms should be an array of integers!"); - if(nfrozen > 0) + if (nfrozen > 0) ommp_fatal("Only a single frozen_atoms section should be present"); cJSON *_arr = cur->child; - for(nfrozen = 0; _arr != NULL; _arr = _arr->next){ - if(!cJSON_IsNumber(_arr)) + for (nfrozen = 0; _arr != NULL; _arr = _arr->next) + { + if (!cJSON_IsNumber(_arr)) ommp_fatal("frozen_atoms should be an array of integers!"); nfrozen++; } - - frozenat = (int32_t *) malloc(sizeof(int32_t) * nfrozen); - + + frozenat = (int32_t *)malloc(sizeof(int32_t) * nfrozen); + _arr = cur->child; - for(int i = 0; _arr != NULL; i++){ + for (int i = 0; _arr != NULL; i++) + { frozenat[i] = _arr->valueint; _arr = _arr->next; } } - else if(strcmp(cur->string, "remove_pol") == 0){ - if(!cJSON_IsArray(cur)) + else if (strcmp(cur->string, "remove_pol") == 0) + { + if (!cJSON_IsArray(cur)) ommp_fatal("remove_pol should be an array of integers!"); - if(nremovepol > 0) + if (nremovepol > 0) ommp_fatal("Only a single remove_pol section should be present"); cJSON *_arr = cur->child; - for(nremovepol = 0; _arr != NULL; _arr = _arr->next){ - if(!cJSON_IsNumber(_arr)) + for (nremovepol = 0; _arr != NULL; _arr = _arr->next) + { + if (!cJSON_IsNumber(_arr)) ommp_fatal("remove_pol should be an array of integers!"); nremovepol++; } - - removepolat = (int32_t *) malloc(sizeof(int32_t) * nremovepol); - + + removepolat = (int32_t *)malloc(sizeof(int32_t) * nremovepol); + _arr = cur->child; - for(int i = 0; _arr != NULL; i++){ + for (int i = 0; _arr != NULL; i++) + { removepolat[i] = _arr->valueint; _arr = _arr->next; } } - else if(strcmp(cur->string, "vdw_cutoff") == 0){ - if(!cJSON_IsNumber(cur)) + else if (strcmp(cur->string, "vdw_cutoff") == 0) + { + if (!cJSON_IsNumber(cur)) ommp_fatal("Van der Walls cutoff should be a number."); vdw_cutoff = cur->valuedouble * OMMP_ANG2AU; } - else if(strcmp(cur->string, "link_atoms") == 0){ - if(!cJSON_IsArray(cur)) + else if (strcmp(cur->string, "link_atoms") == 0) + { + if (!cJSON_IsArray(cur)) ommp_fatal("link_atoms should be an array of structures!"); - if(nla > 0) + if (nla > 0) ommp_fatal("Only a single link_atoms section should be present"); cJSON *linkatom_arr = cur->child; - for(nla = 0; linkatom_arr != NULL; linkatom_arr = linkatom_arr -> next){ - if(!cJSON_IsObject(linkatom_arr)) + for (nla = 0; linkatom_arr != NULL; linkatom_arr = linkatom_arr->next) + { + if (!cJSON_IsObject(linkatom_arr)) ommp_fatal("link_atoms should be an array of structures!"); nla++; } - la_mm = (int32_t *) malloc(sizeof(int32_t) * nla); - la_qm = (int32_t *) malloc(sizeof(int32_t) * nla); - la_la = (int32_t *) malloc(sizeof(int32_t) * nla); - la_ner = (int32_t *) malloc(sizeof(int32_t) * nla); - la_bl = (double *) malloc(sizeof(double) * nla); + la_mm = (int32_t *)malloc(sizeof(int32_t) * nla); + la_qm = (int32_t *)malloc(sizeof(int32_t) * nla); + la_la = (int32_t *)malloc(sizeof(int32_t) * nla); + la_ner = (int32_t *)malloc(sizeof(int32_t) * nla); + la_bl = (double *)malloc(sizeof(double) * nla); linkatom_arr = cur->child; - for(int i=0; linkatom_arr != NULL; i++){ + for (int i = 0; linkatom_arr != NULL; i++) + { la_mm[i] = la_qm[i] = la_la[i] = 0; la_bl[i] = -1.0; la_ner[i] = 0; cJSON *tmp; - for(tmp = linkatom_arr->child; tmp != NULL; tmp = tmp->next){ - if(strcmp(tmp->string, "MM_id") == 0 && cJSON_IsNumber(tmp)) + for (tmp = linkatom_arr->child; tmp != NULL; tmp = tmp->next) + { + if (strcmp(tmp->string, "MM_id") == 0 && cJSON_IsNumber(tmp)) la_mm[i] = tmp->valueint; - else if(strcmp(tmp->string, "QM_id") == 0 && cJSON_IsNumber(tmp)) + else if (strcmp(tmp->string, "QM_id") == 0 && cJSON_IsNumber(tmp)) la_qm[i] = tmp->valueint; - else if(strcmp(tmp->string, "LA_id") == 0 && cJSON_IsNumber(tmp)) + else if (strcmp(tmp->string, "LA_id") == 0 && cJSON_IsNumber(tmp)) la_la[i] = tmp->valueint; - else if(strcmp(tmp->string, "bond_length") == 0 && cJSON_IsNumber(tmp)) + else if (strcmp(tmp->string, "bond_length") == 0 && cJSON_IsNumber(tmp)) la_bl[i] = tmp->valuedouble * OMMP_ANG2AU; - else if(strcmp(tmp->string, "eel_remove") == 0 && cJSON_IsNumber(tmp)) + else if (strcmp(tmp->string, "eel_remove") == 0 && cJSON_IsNumber(tmp)) la_ner[i] = tmp->valueint; - else{ + else + { sprintf(msg, "Unrecognized field %s in link atom %d.", tmp->string, i); ommp_message(msg, OMMP_VERBOSE_LOW, "SI"); } } - if(la_mm[i] == 0){ + if (la_mm[i] == 0) + { sprintf(msg, "MM_id missing in link atom %d.", i); ommp_fatal(msg); } - if(la_qm[i] == 0){ + if (la_qm[i] == 0) + { sprintf(msg, "QM_id missing in link atom %d.", i); ommp_fatal(msg); } - if(la_la[i] == 0){ + if (la_la[i] == 0) + { sprintf(msg, "LA_id missing in link atom %d.", i); ommp_fatal(msg); } - linkatom_arr = linkatom_arr -> next; + linkatom_arr = linkatom_arr->next; } } - else{ + else + { sprintf(msg, "Unrecognized JSON element \"%s\".", cur->string); ommp_message(msg, OMMP_VERBOSE_LOW, "SI"); } @@ -849,55 +1006,56 @@ void c_smartinput(const char *json_file, OMMP_SYSTEM_PRT *ommp_sys, OMMP_QM_HELP // Set verbosity ommp_set_verbose(req_verbosity); // Set output file - if(output_path != NULL) + if (output_path != NULL) ommp_set_outputfile(output_path); // Print information from JSON - if(json_name != NULL){ + if (json_name != NULL) + { sprintf(msg, "Smart Input Name: %s", json_name); ommp_message(msg, OMMP_VERBOSE_LOW, "SI"); } - - if(json_description != NULL){ + + if (json_description != NULL) + { sprintf(msg, "Smart Input Description: %s", json_description); ommp_message(msg, OMMP_VERBOSE_LOW, "SI"); } - + ommp_message("Initializing main object", OMMP_VERBOSE_DEBUG, "SI"); // Input for MM - if(xyz_path != NULL){ + if (xyz_path != NULL) + { ommp_message("Trying initialization from Tinker .xyz file.", OMMP_VERBOSE_LOW, "SI"); - if(prm_path == NULL) + if (prm_path == NULL) ommp_fatal("xyz_file set but prm_file is missing."); - if(hdf5_path != NULL) + if (hdf5_path != NULL) ommp_fatal("xyz_file set but also hdf5_file is set, this is ambiguous."); - if(mmpol_path != NULL) + if (mmpol_path != NULL) ommp_fatal("xyz_file set but also mmpol_file is set, this is ambiguous."); *ommp_sys = ommp_init_xyz(xyz_path, prm_path); } - else if(mmpol_path != NULL){ - if(prm_path != NULL) + else if (mmpol_path != NULL) + { + if (prm_path != NULL) ommp_fatal("prm_file set but it is not needed for mmpol input, this is ambiguous."); - if(hdf5_path != NULL) + if (hdf5_path != NULL) ommp_fatal("mmpol_file set but also hdf5_file is set, this is ambiguous."); *ommp_sys = ommp_init_mmp(mmpol_path); } - else if(hdf5_path != NULL){ - //if(prm_path != NULL) - // ommp_fatal("prm_file set but it is not needed for mmpol input, this is ambiguous."); - -#ifdef USE_HDF5 + else if (hdf5_path != NULL) + { + // if(prm_path != NULL) + // ommp_fatal("prm_file set but it is not needed for mmpol input, this is ambiguous."); *ommp_sys = ommp_init_hdf5(hdf5_path, "system"); -#else - ommp_fatal("This version of OpenMMPol does not have HDF5 support, the required input operation cannot be performed."); -#endif } - else{ + else + { ommp_fatal("No input for MM system found in Smart Input file, set one of xyz_file+prm_file, mmpol_file, hdf5_file"); } - + ommp_message("Setting solver and matrix-vector in main object", OMMP_VERBOSE_DEBUG, "SI"); // Set solver in ommp_sys ommp_set_default_solver(*ommp_sys, req_solver); @@ -907,41 +1065,48 @@ void c_smartinput(const char *json_file, OMMP_SYSTEM_PRT *ommp_sys, OMMP_QM_HELP ommp_set_vdw_cutoff(*ommp_sys, vdw_cutoff); // Handle QM part of the system - if(*ommp_qmh == NULL){ + if (*ommp_qmh == NULL) + { ommp_message("qm section not present in smart input JSON: QMHelper object is not set.", OMMP_VERBOSE_LOW, "SI"); } // Handle frozen atoms - if(nfrozen > 0){ + if (nfrozen > 0) + { ommp_message("Setting frozen atoms", OMMP_VERBOSE_DEBUG, "SI"); ommp_set_frozen_atoms(*ommp_sys, nfrozen, frozenat); free(frozenat); } - if(nremovepol > 0){ + if (nremovepol > 0) + { ommp_message("Removing polarizabilities from requested atoms", OMMP_VERBOSE_DEBUG, "SI"); ommp_turn_pol_off(*ommp_sys, nremovepol, removepolat); free(removepolat); } // Handle link atoms - if(nla > 0){ + if (nla > 0) + { ommp_message("Initializing link atoms", OMMP_VERBOSE_DEBUG, "SI"); - if(*ommp_qmh == NULL) + if (*ommp_qmh == NULL) ommp_fatal("Link atoms requested but no qm section is defined!"); - if(prm_path == NULL) + if (prm_path == NULL) ommp_fatal("Link atoms require to set a prm file!"); - if(la_bl == NULL || la_ner == NULL || la_mm == NULL || la_qm == NULL || la_la == NULL) + if (la_bl == NULL || la_ner == NULL || la_mm == NULL || la_qm == NULL || la_la == NULL) ommp_fatal("Unexpected error in linkatom initialization in SI function."); - for(unsigned int i=0; ichild; - + int32_t *outi = NULL; char *outs = NULL; double *outd = NULL; char *field = strtok(path, "/"); - - while(field != NULL){ - while(cur != NULL){ - if(strcmp(cur->string, field) == 0) + + while (field != NULL) + { + while (cur != NULL) + { + if (strcmp(cur->string, field) == 0) break; cur = cur->next; } field = strtok(NULL, "/"); - - if(cur == NULL){ + + if (cur == NULL) + { ommp_message("Path not found!", - OMMP_VERBOSE_LOW, "SI"); + OMMP_VERBOSE_LOW, "SI"); return NULL; } - - if(cJSON_IsObject(cur)){ + + if (cJSON_IsObject(cur)) + { // This is not a leaf - if(field == NULL){ + if (field == NULL) + { ommp_message("Incomplete path provided for SI cherry picking.", OMMP_VERBOSE_LOW, "SI"); return NULL; } cur = cur->child; } - else{ + else + { // This is a leaf - if(field == NULL){ + if (field == NULL) + { // Here we are, we found it finally! - switch(type){ - case 'i': - if(cJSON_IsNumber(cur)){ - outi = (int32_t *) malloc(sizeof(int32_t)); - *outi = cur->valueint; - cJSON_Delete(input_json); - return (void *) outi; - } - break; - case 'd': - if(cJSON_IsNumber(cur)){ - outd = (double *) malloc(sizeof(double)); - *outd = cur->valuedouble; - cJSON_Delete(input_json); - return (void *) outd; - } - break; - case 's': - if(cJSON_IsString(cur)){ - outs = (char *) malloc(sizeof(char) * (strlen(cur->valuestring)+1)); - strcpy(outs, cur->valuestring); - cJSON_Delete(input_json); - return (void *) outs; - } - break; - default: - break; + switch (type) + { + case 'i': + if (cJSON_IsNumber(cur)) + { + outi = (int32_t *)malloc(sizeof(int32_t)); + *outi = cur->valueint; + cJSON_Delete(input_json); + return (void *)outi; + } + break; + case 'd': + if (cJSON_IsNumber(cur)) + { + outd = (double *)malloc(sizeof(double)); + *outd = cur->valuedouble; + cJSON_Delete(input_json); + return (void *)outd; + } + break; + case 's': + if (cJSON_IsString(cur)) + { + outs = (char *)malloc(sizeof(char) * (strlen(cur->valuestring) + 1)); + strcpy(outs, cur->valuestring); + cJSON_Delete(input_json); + return (void *)outs; + } + break; + default: + break; } cJSON_Delete(input_json); return NULL; } - else{ + else + { ommp_message("Path not found!", OMMP_VERBOSE_LOW, "SI"); cJSON_Delete(input_json); @@ -1060,22 +1241,26 @@ void *c_json_cherrypick(const char *json_file, char *path, char type){ } } ommp_message("Unexpected error in JSON cherry pick!", - OMMP_VERBOSE_LOW, "SI"); + OMMP_VERBOSE_LOW, "SI"); return NULL; } -void c_smartinput_cpstr(const char *json_file, char *path, char **s){ +void c_smartinput_cpstr(const char *json_file, char *path, char **s) +{ *s = c_json_cherrypick(json_file, path, 's'); - if(*s == NULL){ + if (*s == NULL) + { ommp_fatal("JSON cherry picking failed."); } } -void ommp_smartinput_cpstr(const char *json_file, char *path, char **s){ +void ommp_smartinput_cpstr(const char *json_file, char *path, char **s) +{ c_smartinput_cpstr(json_file, path, s); } -void ommp_smartinput(const char *json_file, OMMP_SYSTEM_PRT *ommp_sys, OMMP_QM_HELPER_PRT *ommp_qmh){ +void ommp_smartinput(const char *json_file, OMMP_SYSTEM_PRT *ommp_sys, OMMP_QM_HELPER_PRT *ommp_qmh) +{ // Just an interface function to expose same names and functionalities in C and Fortran c_smartinput(json_file, ommp_sys, ommp_qmh); } diff --git a/tests/CMakeLists.txt b/tests/CMakeLists.txt index f0e2ace..5d78ad8 100644 --- a/tests/CMakeLists.txt +++ b/tests/CMakeLists.txt @@ -11,7 +11,6 @@ file(DOWNLOAD https://raw.githubusercontent.com/TinkerTools/tinker/release/param file(CREATE_LINK ${CMAKE_SOURCE_DIR}/tests ${CMAKE_BINARY_DIR}/tests SYMBOLIC) set(VALGRINDOPT --track-origins=yes --leak-check=full --show-leak-kinds=all) -set(TESTLANG "C" CACHE STRING "Language to be used for the test suite, the very same test programs are implemented in C99 (C) and Fortran2003 (F03).") - +include(tests/test_programs/CMakeLists.txt) include(tests/TestsCmake.txt) diff --git a/tests/TestsCmake.txt b/tests/TestsCmake.txt index eaec2b2..fee89b6 100644 --- a/tests/TestsCmake.txt +++ b/tests/TestsCmake.txt @@ -1,8 +1,8 @@ -if (HDF5_WORKS) - add_test(NAME NMA_AMOEBA_MMP_HDF5_convert - COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/NMA_amoeba_mmp.json Testing/NMA_AMOEBA_MMP_HDF5 ./bin/ommp_pp) - endif () +if (WITH_HDF5) +add_test(NAME NMA_AMOEBA_MMP_HDF5_convert + COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py + ${CMAKE_SOURCE_DIR}/tests/NMA_amoeba_mmp.json Testing/NMA_AMOEBA_MMP_HDF5 ./app/ommp_pp) + add_test(NAME NMA_AMOEBA_MMP_init COMMAND bin/${TESTLANG}_test_SI_init ${CMAKE_SOURCE_DIR}/tests/NMA_amoeba_mmp.json @@ -11,7 +11,7 @@ add_test(NAME NMA_AMOEBA_MMP_init_comp COMMAND ${CMAKE_COMMAND} -E compare_files Testing/NMA_AMOEBA_MMP_init.out ${CMAKE_SOURCE_DIR}/tests/N-methylacetamide/summary_AMOEBA.ref) -if (HDF5_WORKS) + add_test(NAME NMA_AMOEBA_MMP_init_HDF5 COMMAND bin/${TESTLANG}_test_SI_init Testing/NMA_AMOEBA_MMP_HDF5.json @@ -20,12 +20,11 @@ add_test(NAME NMA_AMOEBA_MMP_init_comp_HDF5 COMMAND ${CMAKE_COMMAND} -E compare_files Testing/NMA_AMOEBA_MMP_init.out_HDF5 ${CMAKE_SOURCE_DIR}/tests/N-methylacetamide/summary_AMOEBA.ref) -endif () -if (HDF5_WORKS) - add_test(NAME NMA_AMOEBA_XYZ_HDF5_convert - COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/NMA_amoeba_xyz.json Testing/NMA_AMOEBA_XYZ_HDF5 ./bin/ommp_pp) - endif () + +add_test(NAME NMA_AMOEBA_XYZ_HDF5_convert + COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py + ${CMAKE_SOURCE_DIR}/tests/NMA_amoeba_xyz.json Testing/NMA_AMOEBA_XYZ_HDF5 ./app/ommp_pp) + add_test(NAME NMA_AMOEBA_XYZ_init COMMAND bin/${TESTLANG}_test_SI_init ${CMAKE_SOURCE_DIR}/tests/NMA_amoeba_xyz.json @@ -34,7 +33,7 @@ add_test(NAME NMA_AMOEBA_XYZ_init_comp COMMAND ${CMAKE_COMMAND} -E compare_files Testing/NMA_AMOEBA_XYZ_init.out ${CMAKE_SOURCE_DIR}/tests/N-methylacetamide/summary_AMOEBA.ref) -if (HDF5_WORKS) + add_test(NAME NMA_AMOEBA_XYZ_init_HDF5 COMMAND bin/${TESTLANG}_test_SI_init Testing/NMA_AMOEBA_XYZ_HDF5.json @@ -43,12 +42,11 @@ add_test(NAME NMA_AMOEBA_XYZ_init_comp_HDF5 COMMAND ${CMAKE_COMMAND} -E compare_files Testing/NMA_AMOEBA_XYZ_init.out_HDF5 ${CMAKE_SOURCE_DIR}/tests/N-methylacetamide/summary_AMOEBA.ref) -endif () -if (HDF5_WORKS) - add_test(NAME NMA_AMBER_MMP_HDF5_convert - COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/NMA_amber_mmp.json Testing/NMA_AMBER_MMP_HDF5 ./bin/ommp_pp) - endif () + +add_test(NAME NMA_AMBER_MMP_HDF5_convert + COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py + ${CMAKE_SOURCE_DIR}/tests/NMA_amber_mmp.json Testing/NMA_AMBER_MMP_HDF5 ./app/ommp_pp) + add_test(NAME NMA_AMBER_MMP_init COMMAND bin/${TESTLANG}_test_SI_init ${CMAKE_SOURCE_DIR}/tests/NMA_amber_mmp.json @@ -57,7 +55,7 @@ add_test(NAME NMA_AMBER_MMP_init_comp COMMAND ${CMAKE_COMMAND} -E compare_files Testing/NMA_AMBER_MMP_init.out ${CMAKE_SOURCE_DIR}/tests/N-methylacetamide/summary_WANG_AL.ref) -if (HDF5_WORKS) + add_test(NAME NMA_AMBER_MMP_init_HDF5 COMMAND bin/${TESTLANG}_test_SI_init Testing/NMA_AMBER_MMP_HDF5.json @@ -66,7 +64,7 @@ add_test(NAME NMA_AMBER_MMP_init_comp_HDF5 COMMAND ${CMAKE_COMMAND} -E compare_files Testing/NMA_AMBER_MMP_init.out_HDF5 ${CMAKE_SOURCE_DIR}/tests/N-methylacetamide/summary_WANG_AL.ref) -endif () + add_test(NAME NMA_AMOEBA_MMP_energy COMMAND bin/${TESTLANG}_test_SI_potential ${CMAKE_SOURCE_DIR}/tests/NMA_amoeba_mmp.json @@ -76,7 +74,7 @@ add_test(NAME NMA_AMOEBA_MMP_energy_comp Testing/NMA_AMOEBA_MMP_energy.out ${CMAKE_SOURCE_DIR}/tests/N-methylacetamide/ENE_0_AMOEBA.ref 1e-06 1e-06) -if (HDF5_WORKS) + add_test(NAME NMA_AMOEBA_MMP_energy_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/NMA_AMOEBA_MMP_HDF5.json @@ -86,7 +84,7 @@ add_test(NAME NMA_AMOEBA_MMP_energy_comp_HDF5 Testing/NMA_AMOEBA_MMP_energy.out_HDF5 ${CMAKE_SOURCE_DIR}/tests/N-methylacetamide/ENE_0_AMOEBA.ref 1e-06 1e-06) -endif () + add_test(NAME NMA_AMOEBA_MMP_energy_EF_1 COMMAND bin/${TESTLANG}_test_SI_potential ${CMAKE_SOURCE_DIR}/tests/NMA_amoeba_mmp.json @@ -96,7 +94,7 @@ add_test(NAME NMA_AMOEBA_MMP_energy_EF_1_comp Testing/NMA_AMOEBA_MMP_energy_EF_1.out ${CMAKE_SOURCE_DIR}/tests/N-methylacetamide/ENE_1_AMOEBA.ref 1e-06 1e-06) -if (HDF5_WORKS) + add_test(NAME NMA_AMOEBA_MMP_energy_EF_1_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/NMA_AMOEBA_MMP_HDF5.json @@ -116,7 +114,7 @@ add_test(NAME NMA_AMBER_MMP_energy_comp Testing/NMA_AMBER_MMP_energy.out ${CMAKE_SOURCE_DIR}/tests/N-methylacetamide/ENE_0_WANG_AL.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME NMA_AMBER_MMP_energy_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/NMA_AMBER_MMP_HDF5.json @@ -136,7 +134,7 @@ add_test(NAME NMA_AMBER_MMP_energy_EF_1_comp Testing/NMA_AMBER_MMP_energy_EF_1.out ${CMAKE_SOURCE_DIR}/tests/N-methylacetamide/ENE_1_WANG_AL.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME NMA_AMBER_MMP_energy_EF_1_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/NMA_AMBER_MMP_HDF5.json @@ -156,7 +154,7 @@ add_test(NAME NMA_AMOEBA_XYZ_energy_comp Testing/NMA_AMOEBA_XYZ_energy.out ${CMAKE_SOURCE_DIR}/tests/N-methylacetamide/FULL_POTENTIAL.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME NMA_AMOEBA_XYZ_energy_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/NMA_AMOEBA_XYZ_HDF5.json @@ -185,10 +183,10 @@ add_test(NAME NMA_AMOEBA_MMP_ipd_EF_1_comp Testing/NMA_AMOEBA_MMP_ipd_EF_1.out ${CMAKE_SOURCE_DIR}/tests/N-methylacetamide/IPD_1_AMOEBA.ref 1e-06 1e-05) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME NMACUT_AMOEBA_MMP_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/NMA_cut_amoeba_mmp.json Testing/NMACUT_AMOEBA_MMP_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/NMA_cut_amoeba_mmp.json Testing/NMACUT_AMOEBA_MMP_HDF5 ./app/ommp_pp) endif () add_test(NAME NMACUT_AMOEBA_MMP_ipd COMMAND bin/${TESTLANG}_test_SI_potential @@ -226,10 +224,10 @@ add_test(NAME NMA_AMBER_MMP_ipd_EF_1_comp Testing/NMA_AMBER_MMP_ipd_EF_1.out ${CMAKE_SOURCE_DIR}/tests/N-methylacetamide/IPD_1_WANG_AL.ref 1e-06 1e-05) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME NMACUT_AMBER_MMP_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/NMA_cut_amber_mmp.json Testing/NMACUT_AMBER_MMP_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/NMA_cut_amber_mmp.json Testing/NMACUT_AMBER_MMP_HDF5 ./app/ommp_pp) endif () add_test(NAME NMACUT_AMBER_MMP_ipd COMMAND bin/${TESTLANG}_test_SI_potential @@ -262,7 +260,7 @@ add_test(NAME NMA_AMOEBA_MMP_geomgrad_comp_num_ana Testing/NMA_AMOEBA_MMP_geomgrad_num.out Testing/NMA_AMOEBA_MMP_geomgrad_ana.out 0.001 0.0001) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME NMA_AMOEBA_MMP_geomgrad_num_HDF5 COMMAND bin/${TESTLANG}_test_SI_geomgrad_num Testing/NMA_AMOEBA_MMP_HDF5.json @@ -290,7 +288,7 @@ add_test(NAME NMACUT_AMOEBA_MMP_geomgrad_comp_num_ana Testing/NMACUT_AMOEBA_MMP_geomgrad_num.out Testing/NMACUT_AMOEBA_MMP_geomgrad_ana.out 0.001 0.0001) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME NMACUT_AMOEBA_MMP_geomgrad_num_HDF5 COMMAND bin/${TESTLANG}_test_SI_geomgrad_num Testing/NMACUT_AMOEBA_MMP_HDF5.json @@ -318,7 +316,7 @@ add_test(NAME NMA_AMBER_MMP_geomgrad_comp_num_ana Testing/NMA_AMBER_MMP_geomgrad_num.out Testing/NMA_AMBER_MMP_geomgrad_ana.out 0.001 0.0001) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME NMA_AMBER_MMP_geomgrad_num_HDF5 COMMAND bin/${TESTLANG}_test_SI_geomgrad_num Testing/NMA_AMBER_MMP_HDF5.json @@ -346,7 +344,7 @@ add_test(NAME NMACUT_AMBER_MMP_geomgrad_comp_num_ana Testing/NMACUT_AMBER_MMP_geomgrad_num.out Testing/NMACUT_AMBER_MMP_geomgrad_ana.out 0.001 0.0001) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME NMACUT_AMBER_MMP_geomgrad_num_HDF5 COMMAND bin/${TESTLANG}_test_SI_geomgrad_num Testing/NMACUT_AMBER_MMP_HDF5.json @@ -374,7 +372,7 @@ add_test(NAME NMA_AMOEBA_XYZ_geomgrad_comp_num_ana Testing/NMA_AMOEBA_XYZ_geomgrad_num.out Testing/NMA_AMOEBA_XYZ_geomgrad_ana.out 0.001 0.0001) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME NMA_AMOEBA_XYZ_geomgrad_num_HDF5 COMMAND bin/${TESTLANG}_test_SI_geomgrad_num Testing/NMA_AMOEBA_XYZ_HDF5.json @@ -389,10 +387,10 @@ add_test(NAME NMA_AMOEBA_XYZ_geomgrad_comp_num_ana_HDF5 Testing/NMA_AMOEBA_XYZ_geomgrad_ana.out_HDF5 0.001 0.0001) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1CRN_AMBER_MMP_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/1crn_amber_mmp.json Testing/1CRN_AMBER_MMP_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/1crn_amber_mmp.json Testing/1CRN_AMBER_MMP_HDF5 ./app/ommp_pp) endif () add_test(NAME 1CRN_AMBER_MMP_init COMMAND bin/${TESTLANG}_test_SI_init @@ -402,7 +400,7 @@ add_test(NAME 1CRN_AMBER_MMP_init_comp COMMAND ${CMAKE_COMMAND} -E compare_files Testing/1CRN_AMBER_MMP_init.out ${CMAKE_SOURCE_DIR}/tests/1crn/summary_WANG_AL.ref) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1CRN_AMBER_MMP_init_HDF5 COMMAND bin/${TESTLANG}_test_SI_init Testing/1CRN_AMBER_MMP_HDF5.json @@ -412,10 +410,10 @@ add_test(NAME 1CRN_AMBER_MMP_init_comp_HDF5 Testing/1CRN_AMBER_MMP_init.out_HDF5 ${CMAKE_SOURCE_DIR}/tests/1crn/summary_WANG_AL.ref) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1CRN_AMOEBA_MMP_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/1crn_amoeba_mmp.json Testing/1CRN_AMOEBA_MMP_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/1crn_amoeba_mmp.json Testing/1CRN_AMOEBA_MMP_HDF5 ./app/ommp_pp) endif () add_test(NAME 1CRN_AMOEBA_MMP_init COMMAND bin/${TESTLANG}_test_SI_init @@ -425,7 +423,7 @@ add_test(NAME 1CRN_AMOEBA_MMP_init_comp COMMAND ${CMAKE_COMMAND} -E compare_files Testing/1CRN_AMOEBA_MMP_init.out ${CMAKE_SOURCE_DIR}/tests/1crn/summary_AMOEBA.ref) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1CRN_AMOEBA_MMP_init_HDF5 COMMAND bin/${TESTLANG}_test_SI_init Testing/1CRN_AMOEBA_MMP_HDF5.json @@ -435,10 +433,10 @@ add_test(NAME 1CRN_AMOEBA_MMP_init_comp_HDF5 Testing/1CRN_AMOEBA_MMP_init.out_HDF5 ${CMAKE_SOURCE_DIR}/tests/1crn/summary_AMOEBA.ref) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1CRN_AMOEBA_XYZ_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/1crn_amoeba_xyz.json Testing/1CRN_AMOEBA_XYZ_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/1crn_amoeba_xyz.json Testing/1CRN_AMOEBA_XYZ_HDF5 ./app/ommp_pp) endif () add_test(NAME 1CRN_AMOEBA_XYZ_init COMMAND bin/${TESTLANG}_test_SI_init @@ -448,7 +446,7 @@ add_test(NAME 1CRN_AMOEBA_XYZ_init_comp COMMAND ${CMAKE_COMMAND} -E compare_files Testing/1CRN_AMOEBA_XYZ_init.out ${CMAKE_SOURCE_DIR}/tests/1crn/summary_AMOEBA.ref) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1CRN_AMOEBA_XYZ_init_HDF5 COMMAND bin/${TESTLANG}_test_SI_init Testing/1CRN_AMOEBA_XYZ_HDF5.json @@ -458,10 +456,10 @@ add_test(NAME 1CRN_AMOEBA_XYZ_init_comp_HDF5 Testing/1CRN_AMOEBA_XYZ_init.out_HDF5 ${CMAKE_SOURCE_DIR}/tests/1crn/summary_AMOEBA.ref) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1CRN_AMBER_XYZ_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/1crn_amber_xyz.json Testing/1CRN_AMBER_XYZ_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/1crn_amber_xyz.json Testing/1CRN_AMBER_XYZ_HDF5 ./app/ommp_pp) endif () add_test(NAME 1CRN_AMBER_XYZ_init COMMAND bin/${TESTLANG}_test_SI_init @@ -471,7 +469,7 @@ add_test(NAME 1CRN_AMBER_XYZ_init_comp COMMAND ${CMAKE_COMMAND} -E compare_files Testing/1CRN_AMBER_XYZ_init.out ${CMAKE_SOURCE_DIR}/tests/1crn/summary_AMBER99SB.ref) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1CRN_AMBER_XYZ_init_HDF5 COMMAND bin/${TESTLANG}_test_SI_init Testing/1CRN_AMBER_XYZ_HDF5.json @@ -490,7 +488,7 @@ add_test(NAME 1CRN_AMBER_MMP_energy_comp Testing/1CRN_AMBER_MMP_energy.out ${CMAKE_SOURCE_DIR}/tests/1crn/ENE_0_WANG_AL.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1CRN_AMBER_MMP_energy_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/1CRN_AMBER_MMP_HDF5.json @@ -510,7 +508,7 @@ add_test(NAME 1CRN_AMBER_MMP_energy_EF_1_comp Testing/1CRN_AMBER_MMP_energy_EF_1.out ${CMAKE_SOURCE_DIR}/tests/1crn/ENE_1_WANG_AL.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1CRN_AMBER_MMP_energy_EF_1_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/1CRN_AMBER_MMP_HDF5.json @@ -530,7 +528,7 @@ add_test(NAME 1CRN_AMOEBA_MMP_energy_comp Testing/1CRN_AMOEBA_MMP_energy.out ${CMAKE_SOURCE_DIR}/tests/1crn/ENE_0_AMOEBA.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1CRN_AMOEBA_MMP_energy_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/1CRN_AMOEBA_MMP_HDF5.json @@ -550,7 +548,7 @@ add_test(NAME 1CRN_AMOEBA_MMP_energy_EF_1_comp Testing/1CRN_AMOEBA_MMP_energy_EF_1.out ${CMAKE_SOURCE_DIR}/tests/1crn/ENE_1_AMOEBA.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1CRN_AMOEBA_MMP_energy_EF_1_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/1CRN_AMOEBA_MMP_HDF5.json @@ -570,7 +568,7 @@ add_test(NAME 1CRN_AMOEBA_XYZ_energy_comp Testing/1CRN_AMOEBA_XYZ_energy.out ${CMAKE_SOURCE_DIR}/tests/1crn/FULL_POTENTIAL.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1CRN_AMOEBA_XYZ_energy_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/1CRN_AMOEBA_XYZ_HDF5.json @@ -590,7 +588,7 @@ add_test(NAME 1CRN_AMBER_XYZ_energy_comp Testing/1CRN_AMBER_XYZ_energy.out ${CMAKE_SOURCE_DIR}/tests/1crn/FULL_POTENTIAL_AMBER99SB.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1CRN_AMBER_XYZ_energy_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/1CRN_AMBER_XYZ_HDF5.json @@ -646,7 +644,7 @@ add_test(NAME 1CRN_AMOEBA_XYZ_geomgrad_comp_ana_ref Testing/1CRN_AMOEBA_XYZ_geomgrad_ana.out ${CMAKE_SOURCE_DIR}/tests/1crn/FULL_POTENTIAL.ref 0.001 0.0001) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1CRN_AMOEBA_XYZ_geomgrad_ana_HDF5 COMMAND bin/${TESTLANG}_test_SI_geomgrad Testing/1CRN_AMOEBA_XYZ_HDF5.json @@ -666,7 +664,7 @@ add_test(NAME 1CRN_AMBER_XYZ_geomgrad_comp_ana_ref Testing/1CRN_AMBER_XYZ_geomgrad_ana.out ${CMAKE_SOURCE_DIR}/tests/1crn/FULL_POTENTIAL_AMBER99SB.ref 0.001 0.0001) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1CRN_AMBER_XYZ_geomgrad_ana_HDF5 COMMAND bin/${TESTLANG}_test_SI_geomgrad Testing/1CRN_AMBER_XYZ_HDF5.json @@ -677,10 +675,10 @@ add_test(NAME 1CRN_AMBER_XYZ_geomgrad_comp_ana_ref_HDF5 ${CMAKE_SOURCE_DIR}/tests/1crn/FULL_POTENTIAL_AMBER99SB.ref 0.001 0.0001) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1UBQ_AMBER_MMP_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/1ubq_amber_mmp.json Testing/1UBQ_AMBER_MMP_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/1ubq_amber_mmp.json Testing/1UBQ_AMBER_MMP_HDF5 ./app/ommp_pp) endif () add_test(NAME 1UBQ_AMBER_MMP_init COMMAND bin/${TESTLANG}_test_SI_init @@ -690,7 +688,7 @@ add_test(NAME 1UBQ_AMBER_MMP_init_comp COMMAND ${CMAKE_COMMAND} -E compare_files Testing/1UBQ_AMBER_MMP_init.out ${CMAKE_SOURCE_DIR}/tests/1ubq/summary_WANG_AL.ref) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1UBQ_AMBER_MMP_init_HDF5 COMMAND bin/${TESTLANG}_test_SI_init Testing/1UBQ_AMBER_MMP_HDF5.json @@ -700,10 +698,10 @@ add_test(NAME 1UBQ_AMBER_MMP_init_comp_HDF5 Testing/1UBQ_AMBER_MMP_init.out_HDF5 ${CMAKE_SOURCE_DIR}/tests/1ubq/summary_WANG_AL.ref) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1UBQ_AMOEBA_MMP_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/1ubq_amoeba_mmp.json Testing/1UBQ_AMOEBA_MMP_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/1ubq_amoeba_mmp.json Testing/1UBQ_AMOEBA_MMP_HDF5 ./app/ommp_pp) endif () add_test(NAME 1UBQ_AMOEBA_MMP_init COMMAND bin/${TESTLANG}_test_SI_init @@ -713,7 +711,7 @@ add_test(NAME 1UBQ_AMOEBA_MMP_init_comp COMMAND ${CMAKE_COMMAND} -E compare_files Testing/1UBQ_AMOEBA_MMP_init.out ${CMAKE_SOURCE_DIR}/tests/1ubq/summary_AMOEBA.ref) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1UBQ_AMOEBA_MMP_init_HDF5 COMMAND bin/${TESTLANG}_test_SI_init Testing/1UBQ_AMOEBA_MMP_HDF5.json @@ -723,10 +721,10 @@ add_test(NAME 1UBQ_AMOEBA_MMP_init_comp_HDF5 Testing/1UBQ_AMOEBA_MMP_init.out_HDF5 ${CMAKE_SOURCE_DIR}/tests/1ubq/summary_AMOEBA.ref) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1UBQ_AMOEBA_XYZ_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/1ubq_amoeba_xyz.json Testing/1UBQ_AMOEBA_XYZ_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/1ubq_amoeba_xyz.json Testing/1UBQ_AMOEBA_XYZ_HDF5 ./app/ommp_pp) endif () add_test(NAME 1UBQ_AMOEBA_XYZ_init COMMAND bin/${TESTLANG}_test_SI_init @@ -736,7 +734,7 @@ add_test(NAME 1UBQ_AMOEBA_XYZ_init_comp COMMAND ${CMAKE_COMMAND} -E compare_files Testing/1UBQ_AMOEBA_XYZ_init.out ${CMAKE_SOURCE_DIR}/tests/1ubq/summary_AMOEBA.ref) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1UBQ_AMOEBA_XYZ_init_HDF5 COMMAND bin/${TESTLANG}_test_SI_init Testing/1UBQ_AMOEBA_XYZ_HDF5.json @@ -755,7 +753,7 @@ add_test(NAME 1UBQ_AMBER_MMP_energy_comp Testing/1UBQ_AMBER_MMP_energy.out ${CMAKE_SOURCE_DIR}/tests/1ubq/ENE_0_WANG_AL.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1UBQ_AMBER_MMP_energy_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/1UBQ_AMBER_MMP_HDF5.json @@ -775,7 +773,7 @@ add_test(NAME 1UBQ_AMBER_MMP_energy_EF_1_comp Testing/1UBQ_AMBER_MMP_energy_EF_1.out ${CMAKE_SOURCE_DIR}/tests/1ubq/ENE_1_WANG_AL.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1UBQ_AMBER_MMP_energy_EF_1_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/1UBQ_AMBER_MMP_HDF5.json @@ -795,7 +793,7 @@ add_test(NAME 1UBQ_AMOEBA_MMP_energy_comp Testing/1UBQ_AMOEBA_MMP_energy.out ${CMAKE_SOURCE_DIR}/tests/1ubq/ENE_0_AMOEBA.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1UBQ_AMOEBA_MMP_energy_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/1UBQ_AMOEBA_MMP_HDF5.json @@ -815,7 +813,7 @@ add_test(NAME 1UBQ_AMOEBA_MMP_energy_EF_1_comp Testing/1UBQ_AMOEBA_MMP_energy_EF_1.out ${CMAKE_SOURCE_DIR}/tests/1ubq/ENE_1_AMOEBA.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1UBQ_AMOEBA_MMP_energy_EF_1_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/1UBQ_AMOEBA_MMP_HDF5.json @@ -835,7 +833,7 @@ add_test(NAME 1UBQ_AMOEBA_XYZ_energy_comp Testing/1UBQ_AMOEBA_XYZ_energy.out ${CMAKE_SOURCE_DIR}/tests/1ubq/FULL_POTENTIAL.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1UBQ_AMOEBA_XYZ_energy_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/1UBQ_AMOEBA_XYZ_HDF5.json @@ -891,7 +889,7 @@ add_test(NAME 1UBQ_AMOEBA_XYZ_geomgrad_comp_ana_ref Testing/1UBQ_AMOEBA_XYZ_geomgrad_ana.out ${CMAKE_SOURCE_DIR}/tests/1ubq/FULL_POTENTIAL.ref 0.001 0.0001) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1UBQ_AMOEBA_XYZ_geomgrad_ana_HDF5 COMMAND bin/${TESTLANG}_test_SI_geomgrad Testing/1UBQ_AMOEBA_XYZ_HDF5.json @@ -902,10 +900,10 @@ add_test(NAME 1UBQ_AMOEBA_XYZ_geomgrad_comp_ana_ref_HDF5 ${CMAKE_SOURCE_DIR}/tests/1ubq/FULL_POTENTIAL.ref 0.001 0.0001) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1UBQ_AMOEBA_XYZ_LS_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/1ubq_amoeba_xyz_LS.json Testing/1UBQ_AMOEBA_XYZ_LS_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/1ubq_amoeba_xyz_LS.json Testing/1UBQ_AMOEBA_XYZ_LS_HDF5 ./app/ommp_pp) endif () add_test(NAME 1UBQ_AMOEBA_XYZ_LS_energy COMMAND bin/${TESTLANG}_test_SI_potential @@ -916,7 +914,7 @@ add_test(NAME 1UBQ_AMOEBA_XYZ_LS_energy_comp Testing/1UBQ_AMOEBA_XYZ_LS_energy.out ${CMAKE_SOURCE_DIR}/tests/1ubq/FULL_POTENTIAL_LS.ref 1e-05 1e-05) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1UBQ_AMOEBA_XYZ_LS_energy_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/1UBQ_AMOEBA_XYZ_LS_HDF5.json @@ -936,7 +934,7 @@ add_test(NAME 1UBQ_AMOEBA_XYZ_LS_geomgrad_comp_ana_ref Testing/1UBQ_AMOEBA_XYZ_LS_geomgrad_ana.out ${CMAKE_SOURCE_DIR}/tests/1ubq/FULL_POTENTIAL_LS.ref 0.001 0.0001) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1UBQ_AMOEBA_XYZ_LS_geomgrad_ana_HDF5 COMMAND bin/${TESTLANG}_test_SI_geomgrad Testing/1UBQ_AMOEBA_XYZ_LS_HDF5.json @@ -947,10 +945,10 @@ add_test(NAME 1UBQ_AMOEBA_XYZ_LS_geomgrad_comp_ana_ref_HDF5 ${CMAKE_SOURCE_DIR}/tests/1ubq/FULL_POTENTIAL_LS.ref 0.001 0.0001) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1AO6_AMBER_MMP_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/1ao6_amber_mmp.json Testing/1AO6_AMBER_MMP_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/1ao6_amber_mmp.json Testing/1AO6_AMBER_MMP_HDF5 ./app/ommp_pp) endif () add_test(NAME 1AO6_AMBER_MMP_init COMMAND bin/${TESTLANG}_test_SI_init @@ -960,7 +958,7 @@ add_test(NAME 1AO6_AMBER_MMP_init_comp COMMAND ${CMAKE_COMMAND} -E compare_files Testing/1AO6_AMBER_MMP_init.out ${CMAKE_SOURCE_DIR}/tests/1ao6/summary_WANG_AL.ref) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1AO6_AMBER_MMP_init_HDF5 COMMAND bin/${TESTLANG}_test_SI_init Testing/1AO6_AMBER_MMP_HDF5.json @@ -970,10 +968,10 @@ add_test(NAME 1AO6_AMBER_MMP_init_comp_HDF5 Testing/1AO6_AMBER_MMP_init.out_HDF5 ${CMAKE_SOURCE_DIR}/tests/1ao6/summary_WANG_AL.ref) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1AO6CUT_AMBER_MMP_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/1ao6_cut_amber_mmp.json Testing/1AO6CUT_AMBER_MMP_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/1ao6_cut_amber_mmp.json Testing/1AO6CUT_AMBER_MMP_HDF5 ./app/ommp_pp) endif () add_test(NAME 1AO6CUT_AMBER_MMP_init COMMAND bin/${TESTLANG}_test_SI_init @@ -983,7 +981,7 @@ add_test(NAME 1AO6CUT_AMBER_MMP_init_comp COMMAND ${CMAKE_COMMAND} -E compare_files Testing/1AO6CUT_AMBER_MMP_init.out ${CMAKE_SOURCE_DIR}/tests/1ao6/summary_WANG_AL_CUT10.ref) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1AO6CUT_AMBER_MMP_init_HDF5 COMMAND bin/${TESTLANG}_test_SI_init Testing/1AO6CUT_AMBER_MMP_HDF5.json @@ -993,10 +991,10 @@ add_test(NAME 1AO6CUT_AMBER_MMP_init_comp_HDF5 Testing/1AO6CUT_AMBER_MMP_init.out_HDF5 ${CMAKE_SOURCE_DIR}/tests/1ao6/summary_WANG_AL_CUT10.ref) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1AO6_AMOEBA_MMP_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/1ao6_amoeba_mmp.json Testing/1AO6_AMOEBA_MMP_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/1ao6_amoeba_mmp.json Testing/1AO6_AMOEBA_MMP_HDF5 ./app/ommp_pp) endif () add_test(NAME 1AO6_AMOEBA_MMP_init COMMAND bin/${TESTLANG}_test_SI_init @@ -1006,7 +1004,7 @@ add_test(NAME 1AO6_AMOEBA_MMP_init_comp COMMAND ${CMAKE_COMMAND} -E compare_files Testing/1AO6_AMOEBA_MMP_init.out ${CMAKE_SOURCE_DIR}/tests/1ao6/summary_AMOEBA.ref) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1AO6_AMOEBA_MMP_init_HDF5 COMMAND bin/${TESTLANG}_test_SI_init Testing/1AO6_AMOEBA_MMP_HDF5.json @@ -1016,10 +1014,10 @@ add_test(NAME 1AO6_AMOEBA_MMP_init_comp_HDF5 Testing/1AO6_AMOEBA_MMP_init.out_HDF5 ${CMAKE_SOURCE_DIR}/tests/1ao6/summary_AMOEBA.ref) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1AO6CUT_AMOEBA_MMP_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/1ao6_cut_amoeba_mmp.json Testing/1AO6CUT_AMOEBA_MMP_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/1ao6_cut_amoeba_mmp.json Testing/1AO6CUT_AMOEBA_MMP_HDF5 ./app/ommp_pp) endif () add_test(NAME 1AO6CUT_AMOEBA_MMP_init COMMAND bin/${TESTLANG}_test_SI_init @@ -1029,7 +1027,7 @@ add_test(NAME 1AO6CUT_AMOEBA_MMP_init_comp COMMAND ${CMAKE_COMMAND} -E compare_files Testing/1AO6CUT_AMOEBA_MMP_init.out ${CMAKE_SOURCE_DIR}/tests/1ao6/summary_AMOEBA_CUT10.ref) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1AO6CUT_AMOEBA_MMP_init_HDF5 COMMAND bin/${TESTLANG}_test_SI_init Testing/1AO6CUT_AMOEBA_MMP_HDF5.json @@ -1039,10 +1037,10 @@ add_test(NAME 1AO6CUT_AMOEBA_MMP_init_comp_HDF5 Testing/1AO6CUT_AMOEBA_MMP_init.out_HDF5 ${CMAKE_SOURCE_DIR}/tests/1ao6/summary_AMOEBA_CUT10.ref) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1AO6_AMOEBA_XYZ_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/1ao6_amoeba_xyz.json Testing/1AO6_AMOEBA_XYZ_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/1ao6_amoeba_xyz.json Testing/1AO6_AMOEBA_XYZ_HDF5 ./app/ommp_pp) endif () add_test(NAME 1AO6_AMOEBA_XYZ_init COMMAND bin/${TESTLANG}_test_SI_init @@ -1052,7 +1050,7 @@ add_test(NAME 1AO6_AMOEBA_XYZ_init_comp COMMAND ${CMAKE_COMMAND} -E compare_files Testing/1AO6_AMOEBA_XYZ_init.out ${CMAKE_SOURCE_DIR}/tests/1ao6/summary_AMOEBA.ref) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1AO6_AMOEBA_XYZ_init_HDF5 COMMAND bin/${TESTLANG}_test_SI_init Testing/1AO6_AMOEBA_XYZ_HDF5.json @@ -1071,7 +1069,7 @@ add_test(NAME 1AO6CUT_AMBER_MMP_energy_comp Testing/1AO6CUT_AMBER_MMP_energy.out ${CMAKE_SOURCE_DIR}/tests/1ao6/ENE_0_WANG_AL_CUT10.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1AO6CUT_AMBER_MMP_energy_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/1AO6CUT_AMBER_MMP_HDF5.json @@ -1091,7 +1089,7 @@ add_test(NAME 1AO6CUT_AMBER_MMP_energy_EF_1_comp Testing/1AO6CUT_AMBER_MMP_energy_EF_1.out ${CMAKE_SOURCE_DIR}/tests/1ao6/ENE_1_WANG_AL_CUT10.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1AO6CUT_AMBER_MMP_energy_EF_1_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/1AO6CUT_AMBER_MMP_HDF5.json @@ -1111,7 +1109,7 @@ add_test(NAME 1AO6CUT_AMOEBA_MMP_energy_comp Testing/1AO6CUT_AMOEBA_MMP_energy.out ${CMAKE_SOURCE_DIR}/tests/1ao6/ENE_0_AMOEBA_CUT10.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1AO6CUT_AMOEBA_MMP_energy_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/1AO6CUT_AMOEBA_MMP_HDF5.json @@ -1131,7 +1129,7 @@ add_test(NAME 1AO6CUT_AMOEBA_MMP_energy_EF_1_comp Testing/1AO6CUT_AMOEBA_MMP_energy_EF_1.out ${CMAKE_SOURCE_DIR}/tests/1ao6/ENE_1_AMOEBA_CUT10.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1AO6CUT_AMOEBA_MMP_energy_EF_1_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/1AO6CUT_AMOEBA_MMP_HDF5.json @@ -1151,7 +1149,7 @@ add_test(NAME 1AO6_AMOEBA_XYZ_energy_comp Testing/1AO6_AMOEBA_XYZ_energy.out ${CMAKE_SOURCE_DIR}/tests/1ao6/FULL_POTENTIAL.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1AO6_AMOEBA_XYZ_energy_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/1AO6_AMOEBA_XYZ_HDF5.json @@ -1207,7 +1205,7 @@ add_test(NAME 1AO6_AMOEBA_XYZ_geomgrad_comp_ana_ref Testing/1AO6_AMOEBA_XYZ_geomgrad_ana.out ${CMAKE_SOURCE_DIR}/tests/1ao6/FULL_POTENTIAL.ref 0.001 0.0001) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 1AO6_AMOEBA_XYZ_geomgrad_ana_HDF5 COMMAND bin/${TESTLANG}_test_SI_geomgrad Testing/1AO6_AMOEBA_XYZ_HDF5.json @@ -1218,10 +1216,10 @@ add_test(NAME 1AO6_AMOEBA_XYZ_geomgrad_comp_ana_ref_HDF5 ${CMAKE_SOURCE_DIR}/tests/1ao6/FULL_POTENTIAL.ref 0.001 0.0001) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 2D94_AMOEBA_XYZ_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/2d94_amoeba_xyz.json Testing/2D94_AMOEBA_XYZ_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/2d94_amoeba_xyz.json Testing/2D94_AMOEBA_XYZ_HDF5 ./app/ommp_pp) endif () add_test(NAME 2D94_AMOEBA_XYZ_energy COMMAND bin/${TESTLANG}_test_SI_potential @@ -1232,7 +1230,7 @@ add_test(NAME 2D94_AMOEBA_XYZ_energy_comp Testing/2D94_AMOEBA_XYZ_energy.out ${CMAKE_SOURCE_DIR}/tests/2d94/FULL_POTENTIAL.ref 1e-06 1e-06) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 2D94_AMOEBA_XYZ_energy_HDF5 COMMAND bin/${TESTLANG}_test_SI_potential Testing/2D94_AMOEBA_XYZ_HDF5.json @@ -1252,7 +1250,7 @@ add_test(NAME 2D94_AMOEBA_XYZ_geomgrad_comp_ana_ref Testing/2D94_AMOEBA_XYZ_geomgrad_ana.out ${CMAKE_SOURCE_DIR}/tests/2d94/FULL_POTENTIAL.ref 0.001 0.0001) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME 2D94_AMOEBA_XYZ_geomgrad_ana_HDF5 COMMAND bin/${TESTLANG}_test_SI_geomgrad Testing/2D94_AMOEBA_XYZ_HDF5.json @@ -1263,10 +1261,10 @@ add_test(NAME 2D94_AMOEBA_XYZ_geomgrad_comp_ana_ref_HDF5 ${CMAKE_SOURCE_DIR}/tests/2d94/FULL_POTENTIAL.ref 0.001 0.0001) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME ALACAP_AMOEBA_XYZ_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/alacap_amoeba_xyz.json Testing/ALACAP_AMOEBA_XYZ_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/alacap_amoeba_xyz.json Testing/ALACAP_AMOEBA_XYZ_HDF5 ./app/ommp_pp) endif () add_test(NAME ALACAP_AMOEBA_XYZ_geomgrad_num COMMAND bin/${TESTLANG}_test_SI_geomgrad_num @@ -1281,7 +1279,7 @@ add_test(NAME ALACAP_AMOEBA_XYZ_geomgrad_comp_num_ana Testing/ALACAP_AMOEBA_XYZ_geomgrad_num.out Testing/ALACAP_AMOEBA_XYZ_geomgrad_ana.out 0.001 0.0001) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME ALACAP_AMOEBA_XYZ_geomgrad_num_HDF5 COMMAND bin/${TESTLANG}_test_SI_geomgrad_num Testing/ALACAP_AMOEBA_XYZ_HDF5.json @@ -1296,10 +1294,10 @@ add_test(NAME ALACAP_AMOEBA_XYZ_geomgrad_comp_num_ana_HDF5 Testing/ALACAP_AMOEBA_XYZ_geomgrad_ana.out_HDF5 0.001 0.0001) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME TYRCAP_AMOEBA_XYZ_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/tyrcap_amoeba_xyz.json Testing/TYRCAP_AMOEBA_XYZ_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/tyrcap_amoeba_xyz.json Testing/TYRCAP_AMOEBA_XYZ_HDF5 ./app/ommp_pp) endif () add_test(NAME TYRCAP_AMOEBA_XYZ_geomgrad_num COMMAND bin/${TESTLANG}_test_SI_geomgrad_num @@ -1314,7 +1312,7 @@ add_test(NAME TYRCAP_AMOEBA_XYZ_geomgrad_comp_num_ana Testing/TYRCAP_AMOEBA_XYZ_geomgrad_num.out Testing/TYRCAP_AMOEBA_XYZ_geomgrad_ana.out 0.001 0.0001) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME TYRCAP_AMOEBA_XYZ_geomgrad_num_HDF5 COMMAND bin/${TESTLANG}_test_SI_geomgrad_num Testing/TYRCAP_AMOEBA_XYZ_HDF5.json @@ -1329,10 +1327,10 @@ add_test(NAME TYRCAP_AMOEBA_XYZ_geomgrad_comp_num_ana_HDF5 Testing/TYRCAP_AMOEBA_XYZ_geomgrad_ana.out_HDF5 0.001 0.0001) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME TYR2CAP_AMOEBA_XYZ_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/tyr2cap_amoeba_xyz.json Testing/TYR2CAP_AMOEBA_XYZ_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/tyr2cap_amoeba_xyz.json Testing/TYR2CAP_AMOEBA_XYZ_HDF5 ./app/ommp_pp) endif () add_test(NAME TYR2CAP_AMOEBA_XYZ_geomgrad_num COMMAND bin/${TESTLANG}_test_SI_geomgrad_num @@ -1347,7 +1345,7 @@ add_test(NAME TYR2CAP_AMOEBA_XYZ_geomgrad_comp_num_ana Testing/TYR2CAP_AMOEBA_XYZ_geomgrad_num.out Testing/TYR2CAP_AMOEBA_XYZ_geomgrad_ana.out 0.001 0.0001) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME TYR2CAP_AMOEBA_XYZ_geomgrad_num_HDF5 COMMAND bin/${TESTLANG}_test_SI_geomgrad_num Testing/TYR2CAP_AMOEBA_XYZ_HDF5.json @@ -1362,10 +1360,10 @@ add_test(NAME TYR2CAP_AMOEBA_XYZ_geomgrad_comp_num_ana_HDF5 Testing/TYR2CAP_AMOEBA_XYZ_geomgrad_ana.out_HDF5 0.001 0.0001) endif () -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME PNA4H2O_AMOEBA_XYZ_HDF5_convert COMMAND python3 ${CMAKE_SOURCE_DIR}/tests/convert_test_to_hdf5.py - ${CMAKE_SOURCE_DIR}/tests/pna_amoeba_mmp.json Testing/PNA4H2O_AMOEBA_XYZ_HDF5 ./bin/ommp_pp) + ${CMAKE_SOURCE_DIR}/tests/pna_amoeba_mmp.json Testing/PNA4H2O_AMOEBA_XYZ_HDF5 ./app/ommp_pp) endif () add_test(NAME PNA4H2O_AMOEBA_XYZ_geomgrad_num COMMAND bin/${TESTLANG}_test_SI_geomgrad_num @@ -1380,7 +1378,7 @@ add_test(NAME PNA4H2O_AMOEBA_XYZ_geomgrad_comp_num_ana Testing/PNA4H2O_AMOEBA_XYZ_geomgrad_num.out Testing/PNA4H2O_AMOEBA_XYZ_geomgrad_ana.out 0.001 0.0001) -if (HDF5_WORKS) +if (WITH_HDF5) add_test(NAME PNA4H2O_AMOEBA_XYZ_geomgrad_num_HDF5 COMMAND bin/${TESTLANG}_test_SI_geomgrad_num Testing/PNA4H2O_AMOEBA_XYZ_HDF5.json diff --git a/src/test_programs/C/test_SI_geomgrad.c b/tests/test_programs/C/test_SI_geomgrad.c similarity index 100% rename from src/test_programs/C/test_SI_geomgrad.c rename to tests/test_programs/C/test_SI_geomgrad.c diff --git a/src/test_programs/C/test_SI_geomgrad_num.c b/tests/test_programs/C/test_SI_geomgrad_num.c similarity index 100% rename from src/test_programs/C/test_SI_geomgrad_num.c rename to tests/test_programs/C/test_SI_geomgrad_num.c diff --git a/src/test_programs/C/test_SI_init.c b/tests/test_programs/C/test_SI_init.c similarity index 100% rename from src/test_programs/C/test_SI_init.c rename to tests/test_programs/C/test_SI_init.c diff --git a/src/test_programs/C/test_SI_potential.c b/tests/test_programs/C/test_SI_potential.c similarity index 100% rename from src/test_programs/C/test_SI_potential.c rename to tests/test_programs/C/test_SI_potential.c diff --git a/src/test_programs/C/test_timing.c b/tests/test_programs/C/test_timing.c similarity index 100% rename from src/test_programs/C/test_timing.c rename to tests/test_programs/C/test_timing.c diff --git a/tests/test_programs/CMakeLists.txt b/tests/test_programs/CMakeLists.txt new file mode 100644 index 0000000..9b4364f --- /dev/null +++ b/tests/test_programs/CMakeLists.txt @@ -0,0 +1,46 @@ +# Add executable targets +add_executable(C_test_SI_init "tests/test_programs/C/test_SI_init.c") +add_executable(C_test_SI_potential "tests/test_programs/C/test_SI_potential.c") +add_executable(C_test_SI_geomgrad "tests/test_programs/C/test_SI_geomgrad.c") +add_executable(C_test_SI_geomgrad_num "tests/test_programs/C/test_SI_geomgrad_num.c") + +# Link all executables to openmmpol +target_link_libraries(C_test_SI_init openmmpol) +target_link_libraries(C_test_SI_potential openmmpol) +target_link_libraries(C_test_SI_geomgrad openmmpol) +target_link_libraries(C_test_SI_geomgrad_num openmmpol) + +# Put all targets into a proper directory +set_target_properties(C_test_SI_init + C_test_SI_potential + C_test_SI_geomgrad + C_test_SI_geomgrad_num + PROPERTIES + RUNTIME_OUTPUT_DIRECTORY "${CMAKE_BINARY_DIR}/bin") + +# CI custom targets; do not touch +add_custom_target(C_test_programs DEPENDS C_test_SI_init + C_test_SI_potential + C_test_SI_geomgrad + C_test_SI_geomgrad_num) + + +# Add executable targets +# add_executable(F03_test_SI_init "tests/test_programs/F03/test_SI_init.f90") +# add_executable(F03_test_SI_potential "tests/test_programs/F03/test_SI_potential.f90") +# add_executable(F03_test_SI_geomgrad "tests/test_programs/F03/test_SI_geomgrad.f90") +# add_executable(F03_test_SI_geomgrad_num "tests/test_programs/F03/test_SI_geomgrad_num.f90") + +# # Link all executables to openmmpol +# target_link_libraries(F03_test_SI_init openmmpol) +# target_link_libraries(F03_test_SI_potential openmmpol) +# target_link_libraries(F03_test_SI_geomgrad openmmpol) +# target_link_libraries(F03_test_SI_geomgrad_num openmmpol) + +# # Put all targets into a proper directory +# set_target_properties(F03_test_SI_init +# F03_test_SI_potential +# F03_test_SI_geomgrad +# F03_test_SI_geomgrad_num +# PROPERTIES +# RUNTIME_OUTPUT_DIRECTORY "${CMAKE_BINARY_DIR}/bin") diff --git a/src/test_programs/F03/test_SI_geomgrad.f90 b/tests/test_programs/F03/test_SI_geomgrad.f90 similarity index 100% rename from src/test_programs/F03/test_SI_geomgrad.f90 rename to tests/test_programs/F03/test_SI_geomgrad.f90 diff --git a/src/test_programs/F03/test_SI_geomgrad_num.f90 b/tests/test_programs/F03/test_SI_geomgrad_num.f90 similarity index 100% rename from src/test_programs/F03/test_SI_geomgrad_num.f90 rename to tests/test_programs/F03/test_SI_geomgrad_num.f90 diff --git a/src/test_programs/F03/test_SI_init.f90 b/tests/test_programs/F03/test_SI_init.f90 similarity index 100% rename from src/test_programs/F03/test_SI_init.f90 rename to tests/test_programs/F03/test_SI_init.f90 diff --git a/src/test_programs/F03/test_SI_potential.f90 b/tests/test_programs/F03/test_SI_potential.f90 similarity index 100% rename from src/test_programs/F03/test_SI_potential.f90 rename to tests/test_programs/F03/test_SI_potential.f90 diff --git a/src/test_programs/Python/test_SI_init.py b/tests/test_programs/Python/test_SI_init.py similarity index 100% rename from src/test_programs/Python/test_SI_init.py rename to tests/test_programs/Python/test_SI_init.py diff --git a/src/test_programs/Python/test_SI_potential.py b/tests/test_programs/Python/test_SI_potential.py similarity index 100% rename from src/test_programs/Python/test_SI_potential.py rename to tests/test_programs/Python/test_SI_potential.py diff --git a/src/test_programs/Python/test_energy.py b/tests/test_programs/Python/test_energy.py similarity index 100% rename from src/test_programs/Python/test_energy.py rename to tests/test_programs/Python/test_energy.py diff --git a/src/test_programs/Python/test_geomgrad_xyz_num.py b/tests/test_programs/Python/test_geomgrad_xyz_num.py similarity index 100% rename from src/test_programs/Python/test_geomgrad_xyz_num.py rename to tests/test_programs/Python/test_geomgrad_xyz_num.py diff --git a/src/test_programs/Python/test_init_xyz.py b/tests/test_programs/Python/test_init_xyz.py similarity index 100% rename from src/test_programs/Python/test_init_xyz.py rename to tests/test_programs/Python/test_init_xyz.py diff --git a/src/test_programs/Python/test_ipd.py b/tests/test_programs/Python/test_ipd.py similarity index 100% rename from src/test_programs/Python/test_ipd.py rename to tests/test_programs/Python/test_ipd.py diff --git a/src/test_programs/Python/test_potential_xyz.py b/tests/test_programs/Python/test_potential_xyz.py similarity index 100% rename from src/test_programs/Python/test_potential_xyz.py rename to tests/test_programs/Python/test_potential_xyz.py diff --git a/toolchain/generic.cmake b/toolchain/generic.cmake new file mode 100644 index 0000000..8d57bb2 --- /dev/null +++ b/toolchain/generic.cmake @@ -0,0 +1,29 @@ +# +# Fortran compiler settings +# +set(Fortran_FLAGS "${CMAKE_Fortran_FLAGS}" + CACHE STRING "Build type independent Fortran compiler flags") + +set(Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}" + CACHE STRING "Fortran compiler flags for Release build") + +set(Fortran_FLAGS_RELWITHDEBINFO "${CMAKE_Fortran_FLAGS_RELWITHDEBINFO}" + CACHE STRING "Fortran compiler flags for Release build") + +set(Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG}" + CACHE STRING "Fortran compiler flags for Debug build") + +# Use intrinsic Fortran 2008 erf/erfc functions +set(INTERNAL_ERFC CACHE BOOL 0) + +# +# C compiler settings +# +set(C_FLAGS "${CMAKE_C_FLAGS}" + CACHE STRING "Build type independent C compiler flags") + +set(C_FLAGS_RELEASE "${CMAKE_C_FLAGS_RELEASE}" + CACHE STRING "C compiler flags for Release build") + +set(C_FLAGS_DEBUG "${CMAKE_C_FLAGS_DEBUG}" + CACHE STRING "C compiler flags for Debug build") \ No newline at end of file diff --git a/toolchain/gnu.cmake b/toolchain/gnu.cmake new file mode 100644 index 0000000..9ec63a1 --- /dev/null +++ b/toolchain/gnu.cmake @@ -0,0 +1,41 @@ +# +# Fortran compiler settings +# +set(Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -std=f2008ts -fno-realloc-lhs -fall-intrinsics -Wall -Wextra -pedantic" + CACHE STRING "Build type independent Fortran compiler flags") + +set(Fortran_FLAGS_RELEASE "-O3 -funroll-all-loops" + CACHE STRING "Fortran compiler flags for Release build") + +set(Fortran_FLAGS_RELWITHDEBINFO "-g ${Fortran_FLAGS_RELEASE}" + CACHE STRING "Fortran compiler flags for Release build") + +set(Fortran_FLAGS_DEBUG "-g -Wall -std=f2008ts -fbounds-check " + CACHE STRING "Fortran compiler flags for Debug build") + +set(Fortran_FLAGS_COVERAGE "-O0 -g --coverage") + +# Use intrinsic Fortran 2008 erf/erfc functions +set(INTERNAL_ERFC CACHE BOOL 0) + +# +# C compiler settings +# +set(C_FLAGS "${CMAKE_C_FLAGS}" + CACHE STRING "Build type independent C compiler flags") + +set(C_FLAGS_RELEASE "-O2 -funroll-all-loops" + CACHE STRING "C compiler flags for Release build") + +set(C_FLAGS_RELWITDEBINFO "-g ${C_FLAGS_RELEASE}" + CACHE STRING "C compiler flags for RelWithDebInfo build") + +set(C_FLAGS_DEBUG "-g -Wall -pedantic -fbounds-check" + CACHE STRING "C compiler flags for Debug build") + +set(C_FLAGS_COVERAGE "-O0 -g --coverage") + +# if(${CMAKE_Fortran_COMPILER_VERSION} VERSION_LESS 8.0) +# set(OpenMP_Fortran_FLAGS "-fopenmp") +# set(OpenMP_Fortran_LIB_NAMES "${OpenMP_C_LIB_NAMES}") +# endif() diff --git a/toolchain/intel.cmake b/toolchain/intel.cmake new file mode 100644 index 0000000..fc816f3 --- /dev/null +++ b/toolchain/intel.cmake @@ -0,0 +1,108 @@ +# +# Toolchain file for +# +# Intel compiler, MKL library +# +# Notes: +# +# * CMake format: Command line options (e.g. compiler flags) space separated, other kind +# of lists semicolon separated. +# +# * Variables containing library search paths are empty by default. The CMAKE_PREFIX_PATH +# environment variable should be set up correctly, so that CMake can find those libraries +# automatically. If that is not the case, override those variables to add search paths +# manually +# + +# TODO: incomplete, check flags twice more +# +# Fortran compiler settings +# + +set(Fortran_FLAGS_RELEASE "-O3 -funroll-loops -standard-realloc-lhs -std18 -fpp" + CACHE STRING "Fortran compiler flags for Release build") + +set(Fortran_FLAGS_RELWITHDEBINFO "-g ${Fortran_FLAGS_RELEASE}" + CACHE STRING "Fortran compiler flags for Release build") + +set(Fortran_FLAGS_DEBUG "-g -warn all -std18 -check -diag-error-limit 1 -traceback -fpp" + CACHE STRING "Fortran compiler flags for Debug build") + +# Use intrinsic Fortran 2008 erf/erfc functions +set(INTERNAL_ERFC CACHE BOOL 0) + +# +# C compiler settings +# +set(C_FLAGS "${CMAKE_C_FLAGS}" + CACHE STRING "Build type independent C compiler flags") + +set(C_FLAGS_RELEASE "-O2 -ip" + CACHE STRING "C compiler flags for Release build") + +set(C_FLAGS_DEBUG "-g -Wall" + CACHE STRING "C compiler flags for Debug build") + + +# +# External libraries +# + +# NOTE: Libraries with CMake export files (e.g. ELSI and if the HYBRID_CONFIG_METHODS variable +# contains the "Find" method also libNEGF, libMBD, ScalapackFx and MpiFx) are included by searching +# for the export file in the paths defined in the CMAKE_PREFIX_PATH **environment** variable. Make +# sure your CMAKE_PREFIX_PATH variable is set up accordingly. + +# LAPACK and BLAS +# (if the BLAS library contains the LAPACK functions, set LAPACK_LIBRARY to "NONE") + +# if(WITH_OMP) +# set(BLAS_LIBRARY "mkl_intel_lp64;mkl_intel_thread;mkl_core" CACHE STRING "BLAS library to link") +# else() +# set(BLAS_LIBRARY "mkl_intel_lp64;mkl_sequential;mkl_core" CACHE STRING "BLAS libraries to link") +# endif() +# set(BLAS_LIBRARY_DIR "$ENV{MKLROOT}/lib/intel64" CACHE STRING +# "Directories where BLAS libraries can be found") + +# Automatic CMake LAPACK/BLAS finder settings. If they don't work out, you may try to use the +# manual settings above instead. +if ("${BLAS_LIBRARY}" STREQUAL "") + # In order to load the library via dlopen() in Python, special MKL library must be linked. + if(BUILD_SHARED_LIBS AND ENABLE_DYNAMIC_LOADING) + if(WITH_MPI) + message(FATAL_ERROR + "Don't know how to link MKL as shared library with MPI and dlopen (Python API) support. " + "Set BLAS_LIBRARY, LAPACK_LIBRARY and SCALAPACK_LIBRARY manually, if you know how.") + endif() + if(CMAKE_VERSION VERSION_GREATER_EQUAL "3.17") + set(BLA_VENDOR Intel10_64_dyn) + else() + set(BLAS_LIBRARY "mkl_rt") + set(BLAS_LIBRARY_DIR "$ENV{MKLROOT}/lib/intel64" CACHE STRING + "Directories where BLAS libraries can be found") + endif() + elseif(WITH_OMP) + set(BLA_VENDOR Intel10_64lp) + else() + set(BLA_VENDOR Intel10_64lp_seq) + endif() +endif() + +#set(LAPACK_LIBRARY_DIR "$ENV{MKLROOT}/lib/intel64" CACHE STRING +# "Directories where LAPACK libraries can be found") +set(LAPACK_LIBRARY "NONE") + +# ScaLAPACK -- only needed for MPI-parallel build +#set(SCALAPACK_LIBRARY "mkl_scalapack_lp64;mkl_blacs_intelmpi_lp64" CACHE STRING +# "Scalapack libraries to link") +#set(SCALAPACK_LIBRARY_DIR "$ENV{MKLROOT}/lib/intel64" CACHE STRING +# "Directories where Scalapack libraries can be found") + +# NOTE: The libraries below provide Pkg-Conf export files. If your PKG_CONFIG_PATH environment +# variable has been set up correctly (containing the paths to these libraries), no adjustment should +# be necessary below. + +# MAGMA -- only needed when compiled with GPU support +#set(MAGMA_LIBRARY "magma" CACHE STRING "Magma library") +#set(MAGMA_LIBRARY_DIR "" CACHE STRING "Directories to scan for MAGMA library") +#set(MAGMA_INCLUDE_DIRECTORY "" CACHE STRING "Directories to scan for MAGMA include files")