diff --git a/README.md b/README.md index 4a0c7239..b6616fbb 100644 --- a/README.md +++ b/README.md @@ -5,7 +5,7 @@ [![CI](https://github.com/grimme-lab/multicharge/workflows/CI/badge.svg)](https://github.com/grimme-lab/multicharge/actions) [![codecov](https://codecov.io/gh/grimme-lab/multicharge/branch/main/graph/badge.svg)](https://codecov.io/gh/grimme-lab/multicharge) -Electronegativity equilibration model for atomic partial charges. +Electronegativity equilibration models for atomic partial charges. ## Installation @@ -135,6 +135,33 @@ multicharge.git = "https://github.com/grimme-lab/multicharge" For an overview over all command line arguments use the ``--help`` argument or checkout the [``multicharge(1)``](man/multicharge.1.adoc) manpage. +## Citation + +For the electronegativity equilibration model (EEQ): + +Eike Caldeweyher, Sebastian Ehlert, Andreas Hansen, Hagen Neugebauer, Sebastian Spicher, Christoph Bannwarth and Stefan Grimme, *J. Chem Phys*, **2019**, 150, 154122. +DOI: [10.1063/1.5090222](https://doi.org/10.1063/1.5090222) +chemrxiv: [10.26434/chemrxiv.7430216](https://doi.org/10.26434/chemrxiv.7430216.v2) + +... the EEQ extention to Fr, Ra, and the full Actinide series: + +Lukas Wittmann, Igor Gordiy, Marvin Friede, Benjamin Helmich-Paris, Stefan Grimme, Andreas Hansen and Markus Bursch, *Phys. Chem. Chem. Phys.*, **2024**, 26, 21379-21394. +DOI: [10.1039/D4CP01514B](10.1039/D4CP01514B) + +... the periodic EEQ implementation: + +Eike Caldeweyher, Jan-Michael Mewes, Sebastian Ehlert and Stefan Grimme, *Phys. Chem. Chem. Phys.*, **2020**, 22, 8499-8512. +DOI: [10.1039/D0CP00502A](https://doi.org/10.1039/D0CP00502A) +chemrxiv: [10.26434/chemrxiv.10299428](https://doi.org/10.26434/chemrxiv.10299428.v1) + +
+ +For the bond capacity electronegativity equilibration charge model (EEQBC): + +Thomas Froitzheim, Marcel Müller, Andreas Hansen, and Stefan Grimme, *J. Chem. Phys.*, **2025**, 162, 214109. +DOI: [10.1039/10.1063/5.0268978](https://doi.org/10.1063/5.0268978) +chemrxiv: [10.26434/chemrxiv-2025-1nxwg](https://doi.org/10.26434/chemrxiv-2025-1nxwg) + ## License diff --git a/app/main.f90 b/app/main.f90 index 8329485b..e12191d6 100644 --- a/app/main.f90 +++ b/app/main.f90 @@ -14,38 +14,42 @@ ! limitations under the License. program main - use, intrinsic :: iso_fortran_env, only : output_unit, error_unit, input_unit - use mctc_env, only : error_type, fatal_error, get_argument, wp - use mctc_io, only : structure_type, read_structure, filetype, get_filetype - use multicharge, only : mchrg_model_type, new_eeq2019_model, & - & write_ascii_model, write_ascii_properties, write_ascii_results, & - & get_multicharge_version - use multicharge_output, only : json_results + use, intrinsic :: iso_fortran_env, only: output_unit, error_unit, input_unit + use mctc_env, only: error_type, fatal_error, get_argument, wp + use mctc_io, only: structure_type, read_structure, filetype, get_filetype + use mctc_cutoff, only: get_lattice_points + use multicharge, only: mchrg_model_type, mchrg_model, new_eeq2019_model, & + & new_eeqbc2025_model, get_multicharge_version, & + & write_ascii_model, write_ascii_properties, write_ascii_results + use multicharge_output, only: json_results implicit none character(len=*), parameter :: prog_name = "multicharge" character(len=*), parameter :: json_output = "multicharge.json" character(len=:), allocatable :: input, chargeinput integer, allocatable :: input_format - integer :: stat, unit + integer :: stat, unit, model_id type(error_type), allocatable :: error type(structure_type) :: mol - type(mchrg_model_type) :: model + class(mchrg_model_type), allocatable :: model logical :: grad, json, exist real(wp), parameter :: cn_max = 8.0_wp, cutoff = 25.0_wp - real(wp), allocatable :: cn(:), dcndr(:, :, :), dcndL(:, :, :) + real(wp), allocatable :: cn(:), rcov(:), trans(:, :) + real(wp), allocatable :: qloc(:) + real(wp), allocatable :: dcndr(:, :, :), dcndL(:, :, :), dqlocdr(:, :, :), dqlocdL(:, :, :) real(wp), allocatable :: energy(:), gradient(:, :), sigma(:, :) - real(wp), allocatable :: qvec(:), dqdr(:, :, :), dqdL(:, :, :) + real(wp), allocatable :: qvec(:) + real(wp), allocatable :: dqdr(:, :, :), dqdL(:, :, :) real(wp), allocatable :: charge - call get_arguments(input, input_format, grad, charge, json, error) + call get_arguments(input, model_id, input_format, grad, charge, json, error) if (allocated(error)) then write(error_unit, '(a)') error%message error stop end if if (input == "-") then - if (.not.allocated(input_format)) input_format = filetype%xyz + if (.not. allocated(input_format)) input_format = filetype%xyz call read_structure(mol, input_unit, input_format, error) else call read_structure(mol, input, error, input_format) @@ -76,36 +80,47 @@ program main end if end if - call new_eeq2019_model(mol, model, error) - if(allocated(error)) then + if (model_id == mchrg_model%eeq2019) then + call new_eeq2019_model(mol, model, error) + else if (model_id == mchrg_model%eeqbc2025) then + call new_eeqbc2025_model(mol, model, error) + else + call fatal_error(error, "Invalid model was choosen.") + end if + if (allocated(error)) then write(error_unit, '(a)') error%message error stop end if call write_ascii_model(output_unit, mol, model) - allocate(cn(mol%nat)) - if (grad) then - allocate(dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat)) - end if - - call model%ncoord%get_cn(mol, cn, dcndr, dcndL) - allocate(energy(mol%nat), qvec(mol%nat)) energy(:) = 0.0_wp + + allocate(cn(mol%nat), qloc(mol%nat)) if (grad) then allocate(gradient(3, mol%nat), sigma(3, 3)) gradient(:, :) = 0.0_wp sigma(:, :) = 0.0_wp + + allocate(dqdr(3, mol%nat, mol%nat), dqdL(3, 3, mol%nat)) + dqdr(:, :, :) = 0.0_wp + dqdL(:, :, :) = 0.0_wp + + allocate(dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat)) + allocate(dqlocdr(3, mol%nat, mol%nat), dqlocdL(3, 3, mol%nat)) end if - call model%solve(mol, error, cn, dcndr, dcndL, energy, gradient, sigma, & - & qvec, dqdr, dqdL) + call get_lattice_points(mol%periodic, mol%lattice, model%ncoord%cutoff, trans) + call model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) + call model%solve(mol, error, cn, qloc, dcndr, dcndL, dqlocdr, dqlocdL, & + & energy, gradient, sigma, qvec, dqdr, dqdL) + if (allocated(error)) then write(error_unit, '(a)') error%message error stop end if - call write_ascii_properties(output_unit, mol, model, cn, qvec) call write_ascii_results(output_unit, mol, energy, gradient, sigma) @@ -115,12 +130,11 @@ program main call json_results(unit, " ", energy=sum(energy), gradient=gradient, charges=qvec, cn=cn) close(unit) write(output_unit, '(a)') & - "[Info] JSON dump of results written to '"// json_output //"'" + "[Info] JSON dump of results written to '"//json_output//"'" end if contains - subroutine help(unit) integer, intent(in) :: unit @@ -133,7 +147,8 @@ subroutine help(unit) "higher multipole moments", & "" - write(unit, '(2x, a, t25, a)') & + write(unit, '(2x, a, t35, a)') & + "-m, -model, --model ", "Choose the charge model", & "-i, -input, --input ", "Hint for the format of the input file", & "-c, -charge, --charge ", "Set the molecular charge", & "-g, -grad, --grad", "Evaluate molecular gradient and virial", & @@ -145,7 +160,6 @@ subroutine help(unit) end subroutine help - subroutine version(unit) integer, intent(in) :: unit character(len=:), allocatable :: version_string @@ -156,12 +170,15 @@ subroutine version(unit) end subroutine version - -subroutine get_arguments(input, input_format, grad, charge, json, error) +subroutine get_arguments(input, model_id, input_format, grad, charge, & + & json, error) !> Input file name character(len=:), allocatable :: input + !> ID of choosen model type + integer, intent(out) :: model_id + !> Input file format integer, allocatable, intent(out) :: input_format @@ -180,6 +197,7 @@ subroutine get_arguments(input, input_format, grad, charge, json, error) integer :: iarg, narg, iostat character(len=:), allocatable :: arg + model_id = mchrg_model%eeq2019 grad = .false. json = .false. iarg = 0 @@ -195,16 +213,31 @@ subroutine get_arguments(input, input_format, grad, charge, json, error) call version(output_unit) stop case default - if (.not.allocated(input)) then + if (.not. allocated(input)) then call move_alloc(arg, input) cycle end if call fatal_error(error, "Too many positional arguments present") exit + case("-m", "-model", "--model") + iarg = iarg + 1 + call get_argument(iarg, arg) + if (.not. allocated(arg)) then + call fatal_error(error, "Missing argument for model") + exit + end if + if (arg == "eeq2019" .or. arg == "eeq") then + model_id = mchrg_model%eeq2019 + else if (arg == "eeqbc2025" .or. arg == "eeqbc") then + model_id = mchrg_model%eeqbc2025 + else + call fatal_error(error, "Invalid model") + exit + end if case("-i", "-input", "--input") iarg = iarg + 1 call get_argument(iarg, arg) - if (.not.allocated(arg)) then + if (.not. allocated(arg)) then call fatal_error(error, "Missing argument for input format") exit end if @@ -212,7 +245,7 @@ subroutine get_arguments(input, input_format, grad, charge, json, error) case("-c", "-charge", "--charge") iarg = iarg + 1 call get_argument(iarg, arg) - if (.not.allocated(arg)) then + if (.not. allocated(arg)) then call fatal_error(error, "Missing argument for charge") exit end if @@ -229,8 +262,8 @@ subroutine get_arguments(input, input_format, grad, charge, json, error) end select end do - if (.not.allocated(input)) then - if (.not.allocated(error)) then + if (.not. allocated(input)) then + if (.not. allocated(error)) then call help(output_unit) error stop end if diff --git a/man/multicharge.1.adoc b/man/multicharge.1.adoc index e7128d8b..d5a12d80 100644 --- a/man/multicharge.1.adoc +++ b/man/multicharge.1.adoc @@ -14,18 +14,21 @@ Electronegativity equilibration model for atomic partial charges. == Options +*-m, -model, --model* _model_:: +Choose the charge model (eeq or eeqbc) + *-i, -input, --input* _format_:: Hint for the format of the input file *-c, -charge, --charge* _value_:: Provide the molecular charge -*-j, -json, --json*:: -Provide output in JSON format to the file 'multicharge.json' - *-g, -grad, --grad*:: Evaluate molecular gradient and virial +*-j, -json, --json*:: +Provide output in JSON format to the file 'multicharge.json' + *-v, -version, --version*:: Print program version and exit diff --git a/src/multicharge.f90 b/src/multicharge.f90 index d5b9cd43..2e8893bd 100644 --- a/src/multicharge.f90 +++ b/src/multicharge.f90 @@ -14,11 +14,11 @@ ! limitations under the License. module multicharge - use multicharge_cutoff, only : get_lattice_points + use multicharge_charge, only : get_charges, get_eeq_charges, get_eeqbc_charges use multicharge_model, only : mchrg_model_type use multicharge_output, only : write_ascii_model, write_ascii_properties, & & write_ascii_results - use multicharge_param, only : new_eeq2019_model + use multicharge_param, only : new_eeq2019_model, new_eeqbc2025_model, mchrg_model use multicharge_version, only : get_multicharge_version implicit none public diff --git a/src/multicharge/CMakeLists.txt b/src/multicharge/CMakeLists.txt index c5154d40..378e6902 100644 --- a/src/multicharge/CMakeLists.txt +++ b/src/multicharge/CMakeLists.txt @@ -13,6 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. +add_subdirectory("model") add_subdirectory("param") set(dir "${CMAKE_CURRENT_SOURCE_DIR}") @@ -20,14 +21,15 @@ set(dir "${CMAKE_CURRENT_SOURCE_DIR}") list( APPEND srcs "${dir}/blas.F90" - "${dir}/cutoff.f90" + "${dir}/charge.f90" "${dir}/ewald.f90" "${dir}/lapack.F90" - "${dir}/model.F90" + "${dir}/model.f90" "${dir}/output.f90" "${dir}/param.f90" "${dir}/version.f90" "${dir}/wignerseitz.f90" + "${dir}/cache.f90" ) set(srcs "${srcs}" PARENT_SCOPE) diff --git a/src/multicharge/cache.f90 b/src/multicharge/cache.f90 new file mode 100644 index 00000000..0ca48625 --- /dev/null +++ b/src/multicharge/cache.f90 @@ -0,0 +1,46 @@ +! This file is part of multicharge. +! SPDX-Identifier: Apache-2.0 +! +! Licensed under the Apache License, Version 2.0 (the "License"); +! you may not use this file except in compliance with the License. +! You may obtain a copy of the License at +! +! http://www.apache.org/licenses/LICENSE-2.0 +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> @file multicharge/cache.f90 +!> Contains the cache baseclass for the charge models and a container for mutable cache data + +!> Cache for charge models +module multicharge_model_cache + use mctc_env, only: wp + use mctc_io, only: structure_type + use multicharge_wignerseitz, only: wignerseitz_cell_type + implicit none + private + + type, public :: cache_container + !> Mutable data attribute + class(*), allocatable :: raw + end type cache_container + + !> Cache for the charge model + type, abstract, public :: model_cache + !> Coordination number array + real(wp), allocatable :: cn(:) + !> Coordination number gradient w.r.t the positions + real(wp), allocatable :: dcndr(:, :, :) + !> Coordination number gradient w.r.t the lattice vectors + real(wp), allocatable :: dcndL(:, :, :) + !> Ewald separation parameter + real(wp) :: alpha + !> Wigner-Seitz cell + type(wignerseitz_cell_type) :: wsc + end type model_cache + +end module multicharge_model_cache diff --git a/src/multicharge/charge.f90 b/src/multicharge/charge.f90 new file mode 100644 index 00000000..29cefc13 --- /dev/null +++ b/src/multicharge/charge.f90 @@ -0,0 +1,134 @@ +! This file is part of multicharge. +! SPDX-Identifier: Apache-2.0 +! +! Licensed under the Apache License, Version 2.0 (the "License"); +! you may not use this file except in compliance with the License. +! You may obtain a copy of the License at +! +! http://www.apache.org/licenses/LICENSE-2.0 +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> @file multicharge/charge.f90 +!> Contains functions to calculate the partial charges with and without +!> separate charge model setup + +!> Interface to the charge models +module multicharge_charge + use mctc_env, only : error_type, wp + use mctc_io, only : structure_type + use mctc_cutoff, only : get_lattice_points + use multicharge_model, only : mchrg_model_type + use multicharge_param, only : new_eeq2019_model, new_eeqbc2025_model + implicit none + private + + public :: get_charges, get_eeq_charges, get_eeqbc_charges + + +contains + + +!> Classical electronegativity equilibration charges +subroutine get_charges(mchrg_model, mol, error, qvec, dqdr, dqdL) + + !> Multicharge model + class(mchrg_model_type), intent(in) :: mchrg_model + + !> Molecular structure data + type(structure_type), intent(in) :: mol + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Atomic partial charges + real(wp), intent(out), contiguous :: qvec(:) + + !> Derivative of the partial charges w.r.t. the Cartesian coordinates + real(wp), intent(out), contiguous, optional :: dqdr(:, :, :) + + !> Derivative of the partial charges w.r.t. strain deformations + real(wp), intent(out), contiguous, optional :: dqdL(:, :, :) + + logical :: grad + real(wp), allocatable :: cn(:), dcndr(:, :, :), dcndL(:, :, :) + real(wp), allocatable :: qloc(:), dqlocdr(:, :, :), dqlocdL(:, :, :) + real(wp), allocatable :: trans(:, :) + + grad = present(dqdr) .and. present(dqdL) + + allocate(cn(mol%nat), qloc(mol%nat)) + if (grad) then + allocate(dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat)) + allocate (dqlocdr(3, mol%nat, mol%nat), dqlocdL(3, 3, mol%nat)) + end if + + call get_lattice_points(mol%periodic, mol%lattice, mchrg_model%ncoord%cutoff, trans) + call mchrg_model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call mchrg_model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) + + call mchrg_model%solve(mol, error, cn, qloc, dcndr, dcndL, dqlocdr, dqlocdL, & + & qvec=qvec, dqdr=dqdr, dqdL=dqdL) + +end subroutine get_charges + + +!> Obtain charges from electronegativity equilibration model +subroutine get_eeq_charges(mol, error, qvec, dqdr, dqdL) + + !> Molecular structure data + type(structure_type), intent(in) :: mol + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Atomic partial charges + real(wp), intent(out), contiguous :: qvec(:) + + !> Derivative of the partial charges w.r.t. the Cartesian coordinates + real(wp), intent(out), contiguous, optional :: dqdr(:, :, :) + + !> Derivative of the partial charges w.r.t. strain deformations + real(wp), intent(out), contiguous, optional :: dqdL(:, :, :) + + class(mchrg_model_type), allocatable :: eeq_model + + call new_eeq2019_model(mol, eeq_model, error) + + call get_charges(eeq_model, mol, error, qvec, dqdr, dqdL) + +end subroutine get_eeq_charges + + +!> Obtain charges from bond capacity electronegativity equilibration model +subroutine get_eeqbc_charges(mol, error, qvec, dqdr, dqdL) + + !> Molecular structure data + type(structure_type), intent(in) :: mol + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Atomic partial charges + real(wp), intent(out), contiguous :: qvec(:) + + !> Derivative of the partial charges w.r.t. the Cartesian coordinates + real(wp), intent(out), contiguous, optional :: dqdr(:, :, :) + + !> Derivative of the partial charges w.r.t. strain deformations + real(wp), intent(out), contiguous, optional :: dqdL(:, :, :) + + class(mchrg_model_type), allocatable :: eeqbc_model + + call new_eeqbc2025_model(mol, eeqbc_model, error) + + call get_charges(eeqbc_model, mol, error, qvec, dqdr, dqdL) + +end subroutine get_eeqbc_charges + + +end module multicharge_charge diff --git a/src/multicharge/cutoff.f90 b/src/multicharge/cutoff.f90 deleted file mode 100644 index 31ee2b86..00000000 --- a/src/multicharge/cutoff.f90 +++ /dev/null @@ -1,136 +0,0 @@ -! This file is part of multicharge. -! SPDX-Identifier: Apache-2.0 -! -! Licensed under the Apache License, Version 2.0 (the "License"); -! you may not use this file except in compliance with the License. -! You may obtain a copy of the License at -! -! http://www.apache.org/licenses/LICENSE-2.0 -! -! Unless required by applicable law or agreed to in writing, software -! distributed under the License is distributed on an "AS IS" BASIS, -! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -! See the License for the specific language governing permissions and -! limitations under the License. - -module multicharge_cutoff - use mctc_env, only : wp - implicit none - private - - public :: get_lattice_points - - interface get_lattice_points - module procedure :: get_lattice_points_cutoff - module procedure :: get_lattice_points_rep_3d - end interface get_lattice_points - - -contains - - -subroutine get_lattice_points_rep_3d(lat, rep, origin, trans) - real(wp), intent(in) :: lat(:, :) - integer, intent(in) :: rep(:) - logical, intent(in) :: origin - real(wp), allocatable, intent(out) :: trans(:, :) - integer :: itr, ix, iy, iz, jx, jy, jz - - itr = 0 - if (origin) then - allocate(trans(3, product(2*rep+1))) - do ix = 0, rep(1) - do iy = 0, rep(2) - do iz = 0, rep(3) - do jx = 1, merge(-1, 1, ix > 0), -2 - do jy = 1, merge(-1, 1, iy > 0), -2 - do jz = 1, merge(-1, 1, iz > 0), -2 - itr = itr + 1 - trans(:, itr) = lat(:, 1)*ix*jx & - & + lat(:, 2)*iy*jy + lat(:, 3)*iz*jz - end do - end do - end do - end do - end do - end do - else - allocate(trans(3, product(2*rep+1)-1)) - do ix = 0, rep(1) - do iy = 0, rep(2) - do iz = 0, rep(3) - if (ix == 0 .and. iy == 0 .and. iz == 0) cycle - do jx = 1, merge(-1, 1, ix > 0), -2 - do jy = 1, merge(-1, 1, iy > 0), -2 - do jz = 1, merge(-1, 1, iz > 0), -2 - itr = itr + 1 - trans(:, itr) = lat(:, 1)*ix*jx & - & + lat(:, 2)*iy*jy + lat(:, 3)*iz*jz - end do - end do - end do - end do - end do - end do - end if -end subroutine get_lattice_points_rep_3d - - -subroutine get_lattice_points_cutoff(periodic, lat, rthr, trans) - logical, intent(in) :: periodic(:) - real(wp), intent(in) :: rthr - real(wp), intent(in) :: lat(:, :) - real(wp), allocatable, intent(out) :: trans(:, :) - integer :: rep(3) - - if (.not.any(periodic)) then - allocate(trans(3, 1)) - trans(:, :) = 0.0_wp - else - call get_translations(lat, rthr, rep) - call get_lattice_points(lat, rep, .true., trans) - end if - -end subroutine get_lattice_points_cutoff - - -!> generate a supercell based on a realspace cutoff, this subroutine -! doesn't know anything about the convergence behaviour of the -! associated property. -pure subroutine get_translations(lat, rthr, rep) - real(wp), intent(in) :: rthr - real(wp), intent(in) :: lat(3, 3) - integer, intent(out) :: rep(3) - real(wp) :: normx(3), normy(3), normz(3) - real(wp) :: cos10, cos21, cos32 - - ! find normal to the plane... - call crossproduct(lat(:, 2), lat(:, 3), normx) - call crossproduct(lat(:, 3), lat(:, 1), normy) - call crossproduct(lat(:, 1), lat(:, 2), normz) - ! ...normalize it... - normx = normx/norm2(normx) - normy = normy/norm2(normy) - normz = normz/norm2(normz) - ! cos angles between normals and lattice vectors - cos10 = sum(normx*lat(:, 1)) - cos21 = sum(normy*lat(:, 2)) - cos32 = sum(normz*lat(:, 3)) - rep(1) = ceiling(abs(rthr/cos10)) - rep(2) = ceiling(abs(rthr/cos21)) - rep(3) = ceiling(abs(rthr/cos32)) - -contains - - pure subroutine crossproduct(a, b, c) - real(wp), intent(in) :: a(3), b(3) - real(wp), intent(out) :: c(3) - c(1)=a(2)*b(3)-b(2)*a(3) - c(2)=a(3)*b(1)-b(3)*a(1) - c(3)=a(1)*b(2)-b(1)*a(2) - end subroutine crossproduct - -end subroutine get_translations - - -end module multicharge_cutoff diff --git a/src/multicharge/meson.build b/src/multicharge/meson.build index 8167f194..fb09be43 100644 --- a/src/multicharge/meson.build +++ b/src/multicharge/meson.build @@ -13,16 +13,18 @@ # See the License for the specific language governing permissions and # limitations under the License. +subdir('model') subdir('param') srcs += files( 'blas.F90', - 'cutoff.f90', + 'charge.f90', 'ewald.f90', 'lapack.F90', - 'model.F90', + 'model.f90', 'output.f90', 'param.f90', 'version.f90', 'wignerseitz.f90', + 'cache.f90', ) diff --git a/src/multicharge/model.f90 b/src/multicharge/model.f90 new file mode 100644 index 00000000..208c156b --- /dev/null +++ b/src/multicharge/model.f90 @@ -0,0 +1,34 @@ +! This file is part of multicharge. +! SPDX-Identifier: Apache-2.0 +! +! Licensed under the Apache License, Version 2.0 (the "License"); +! you may not use this file except in compliance with the License. +! You may obtain a copy of the License at +! +! http://www.apache.org/licenses/LICENSE-2.0 +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> @dir multicharge/model +!> Contains the implementation of the charge models + +!> @file multicharge/model.f90 +!> Provides a reexport of the charge model implementations + +!> Proxy module to reexport the charge model implementations +module multicharge_model + use multicharge_model_type, only : mchrg_model_type + use multicharge_model_eeq, only : eeq_model, new_eeq_model + use multicharge_model_eeqbc, only : eeqbc_model, new_eeqbc_model + implicit none + private + + public :: mchrg_model_type + public :: eeq_model, new_eeq_model + public :: eeqbc_model, new_eeqbc_model + +end module multicharge_model diff --git a/src/multicharge/model/CMakeLists.txt b/src/multicharge/model/CMakeLists.txt new file mode 100644 index 00000000..9cff0e6b --- /dev/null +++ b/src/multicharge/model/CMakeLists.txt @@ -0,0 +1,26 @@ +# This file is part of multicharge. +# SPDX-Identifier: Apache-2.0 +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + + +set(dir "${CMAKE_CURRENT_SOURCE_DIR}") + +list( + APPEND srcs + "${dir}/eeq.f90" + "${dir}/eeqbc.f90" + "${dir}/type.F90" +) + +set(srcs "${srcs}" PARENT_SCOPE) diff --git a/src/multicharge/model.F90 b/src/multicharge/model/eeq.f90 similarity index 56% rename from src/multicharge/model.F90 rename to src/multicharge/model/eeq.f90 index 08338135..d0569ab5 100644 --- a/src/multicharge/model.F90 +++ b/src/multicharge/model/eeq.f90 @@ -13,68 +13,68 @@ ! See the License for the specific language governing permissions and ! limitations under the License. -#ifndef IK -#define IK i4 -#endif - -module multicharge_model - use mctc_env, only : error_type, fatal_error, wp, ik => IK - use mctc_io, only : structure_type - use mctc_io_constants, only : pi - use mctc_io_math, only : matdet_3x3, matinv_3x3 - use multicharge_blas, only : gemv, symv, gemm - use multicharge_cutoff, only : get_lattice_points - use mctc_ncoord, only: ncoord_type, new_ncoord, cn_count - use multicharge_ewald, only : get_alpha - use multicharge_lapack, only : sytrf, sytrs, sytri - use multicharge_wignerseitz, only : wignerseitz_cell_type, new_wignerseitz_cell +!> @file multicharge/model/eeq.f90 +!> Provides implementation of the electronegativity equilibration model (EEQ) + +!> Electronegativity equlibration charge model published in +!> +!> E. Caldeweyher, S. Ehlert, A. Hansen, H. Neugebauer, S. Spicher, C. Bannwarth +!> and S. Grimme, *J. Chem. Phys.*, **2019**, 150, 154122. +!> DOI: [10.1063/1.5090222](https://dx.doi.org/10.1063/1.5090222) +module multicharge_model_eeq + use mctc_env, only: error_type, wp + use mctc_io, only: structure_type + use mctc_io_constants, only: pi + use mctc_io_math, only: matdet_3x3 + use mctc_ncoord, only: new_ncoord, cn_count + use multicharge_wignerseitz, only: wignerseitz_cell_type, new_wignerseitz_cell + use multicharge_ewald, only: get_alpha + use multicharge_model_type, only: mchrg_model_type, get_dir_trans, get_rec_trans + use multicharge_model_cache, only: cache_container, model_cache implicit none private - public :: mchrg_model_type, new_mchrg_model - - - !> Electronegativity equilibration model type - type :: mchrg_model_type - !> Exponent gaussian charge - real(wp), allocatable :: rad(:) - !> Electronegativity - real(wp), allocatable :: chi(:) - !> Chemical hardness - real(wp), allocatable :: eta(:) - !> CN scaling factor for electronegativity - real(wp), allocatable :: kcn(:) - !> Coordination number - class(ncoord_type), allocatable :: ncoord - contains - procedure :: solve - end type mchrg_model_type + public :: eeq_model, new_eeq_model + + type, extends(model_cache), public :: eeq_cache + end type eeq_cache + type, extends(mchrg_model_type) :: eeq_model + contains + !> Update and allocate cache + procedure :: update + !> Calculate Coulomb matrix + procedure :: get_coulomb_matrix + !> Calculate derivatives of Coulomb matrix + procedure :: get_coulomb_derivs + !> Calculate right-hand side (electronegativity vector) + procedure :: get_xvec + !> Calculate EN vector derivatives + procedure :: get_xvec_derivs + end type eeq_model - real(wp), parameter :: twopi = 2 * pi real(wp), parameter :: sqrtpi = sqrt(pi) real(wp), parameter :: sqrt2pi = sqrt(2.0_wp/pi) real(wp), parameter :: eps = sqrt(epsilon(0.0_wp)) contains - -subroutine new_mchrg_model(self, mol, error, chi, rad, eta, kcn, & +subroutine new_eeq_model(self, mol, error, chi, rad, eta, kcnchi, & & cutoff, cn_exp, rcov, cn_max) !> Electronegativity equilibration model - type(mchrg_model_type), intent(out) :: self + type(eeq_model), intent(out) :: self !> Molecular structure data type(structure_type), intent(in) :: mol !> Error handling type(error_type), allocatable, intent(out) :: error - !> Exponent gaussian charge - real(wp), intent(in) :: rad(:) !> Electronegativity real(wp), intent(in) :: chi(:) + !> Exponent gaussian charge + real(wp), intent(in) :: rad(:) !> Chemical hardness real(wp), intent(in) :: eta(:) !> CN scaling factor for electronegativity - real(wp), intent(in) :: kcn(:) + real(wp), intent(in) :: kcnchi(:) !> Cutoff radius for coordination number real(wp), intent(in), optional :: cutoff !> Steepness of the CN counting function @@ -84,75 +84,120 @@ subroutine new_mchrg_model(self, mol, error, chi, rad, eta, kcn, & !> Maximum CN cutoff for CN real(wp), intent(in), optional :: cn_max - self%rad = rad self%chi = chi + self%rad = rad self%eta = eta - self%kcn = kcn - - call new_ncoord(self%ncoord, mol, cn_count%erf, error, cutoff=cutoff, & - & kcn=cn_exp, rcov=rcov, cut=cn_max) + self%kcnchi = kcnchi -end subroutine new_mchrg_model + call new_ncoord(self%ncoord, mol, cn_count%erf, error, & + & cutoff=cutoff, kcn=cn_exp, rcov=rcov, cut=cn_max) +end subroutine new_eeq_model -subroutine get_vrhs(self, mol, cn, xvec, dxdcn) - type(mchrg_model_type), intent(in) :: self +subroutine update(self, mol, cache, cn, qloc, dcndr, dcndL, dqlocdr, dqlocdL) + class(eeq_model), intent(in) :: self type(structure_type), intent(in) :: mol + type(cache_container), intent(inout) :: cache real(wp), intent(in) :: cn(:) + real(wp), intent(in), optional :: qloc(:) + real(wp), intent(in), optional :: dcndr(:, :, :) + real(wp), intent(in), optional :: dcndL(:, :, :) + real(wp), intent(in), optional :: dqlocdr(:, :, :) + real(wp), intent(in), optional :: dqlocdL(:, :, :) + + type(eeq_cache), pointer :: ptr + + call taint(cache, ptr) + + ! Refer CN arrays in cache + ptr%cn = cn + if (present(dcndr) .and. present(dcndL)) then + ptr%dcndr = dcndr + ptr%dcndL = dcndL + end if + + if (any(mol%periodic)) then + ! Create WSC + call new_wignerseitz_cell(ptr%wsc, mol) + call get_alpha(mol%lattice, ptr%alpha) + end if + +end subroutine update + +subroutine get_xvec(self, mol, cache, xvec) + class(eeq_model), intent(in) :: self + type(structure_type), intent(in) :: mol + type(cache_container), intent(inout) :: cache real(wp), intent(out) :: xvec(:) - real(wp), intent(out), optional :: dxdcn(:) real(wp), parameter :: reg = 1.0e-14_wp integer :: iat, izp real(wp) :: tmp - if (present(dxdcn)) then - !$omp parallel do default(none) schedule(runtime) & - !$omp shared(mol, self, cn, xvec, dxdcn) private(iat, izp, tmp) - do iat = 1, mol%nat - izp = mol%id(iat) - tmp = self%kcn(izp) / sqrt(cn(iat) + reg) - xvec(iat) = -self%chi(izp) + tmp*cn(iat) - dxdcn(iat) = 0.5_wp*tmp - end do - dxdcn(mol%nat+1) = 0.0_wp - else - !$omp parallel do default(none) schedule(runtime) & - !$omp shared(mol, self, cn, xvec) private(iat, izp, tmp) - do iat = 1, mol%nat - izp = mol%id(iat) - tmp = self%kcn(izp) / sqrt(cn(iat) + reg) - xvec(iat) = -self%chi(izp) + tmp*cn(iat) - end do - end if - xvec(mol%nat+1) = mol%charge + type(eeq_cache), pointer :: ptr + + call view(cache, ptr) + + !$omp parallel do default(none) schedule(runtime) & + !$omp shared(mol, self, xvec, ptr) private(iat, izp, tmp) + do iat = 1, mol%nat + izp = mol%id(iat) + tmp = self%kcnchi(izp) / sqrt(ptr%cn(iat) + reg) + xvec(iat) = -self%chi(izp) + tmp * ptr%cn(iat) + end do + xvec(mol%nat + 1) = mol%charge + +end subroutine get_xvec + +subroutine get_xvec_derivs(self, mol, cache, dxdr, dxdL) + class(eeq_model), intent(in) :: self + type(structure_type), intent(in) :: mol + type(cache_container), intent(inout) :: cache + real(wp), intent(out), contiguous :: dxdr(:, :, :) + real(wp), intent(out), contiguous :: dxdL(:, :, :) + real(wp), parameter :: reg = 1.0e-14_wp -end subroutine get_vrhs + integer :: iat, izp + real(wp) :: tmp + type(eeq_cache), pointer :: ptr -subroutine get_dir_trans(lattice, trans) - real(wp), intent(in) :: lattice(:, :) - real(wp), allocatable, intent(out) :: trans(:, :) - integer, parameter :: rep(3) = 2 + call view(cache, ptr) - call get_lattice_points(lattice, rep, .true., trans) + dxdr(:, :, :) = 0.0_wp + dxdL(:, :, :) = 0.0_wp -end subroutine get_dir_trans + !$omp parallel do default(none) schedule(runtime) & + !$omp shared(mol, self, ptr, dxdr, dxdL) & + !$omp private(iat, izp, tmp) + do iat = 1, mol%nat + izp = mol%id(iat) + tmp = self%kcnchi(izp) / sqrt(ptr%cn(iat) + reg) + dxdr(:, :, iat) = 0.5_wp * tmp * ptr%dcndr(:, :, iat) + dxdr(:, :, iat) + dxdL(:, :, iat) = 0.5_wp * tmp * ptr%dcndL(:, :, iat) + dxdL(:, :, iat) + end do -subroutine get_rec_trans(lattice, trans) - real(wp), intent(in) :: lattice(:, :) - real(wp), allocatable, intent(out) :: trans(:, :) - integer, parameter :: rep(3) = 2 - real(wp) :: rec_lat(3, 3) +end subroutine get_xvec_derivs - rec_lat = twopi*transpose(matinv_3x3(lattice)) - call get_lattice_points(rec_lat, rep, .false., trans) +subroutine get_coulomb_matrix(self, mol, cache, amat) + class(eeq_model), intent(in) :: self + type(structure_type), intent(in) :: mol + type(cache_container), intent(inout) :: cache + real(wp), intent(out) :: amat(:, :) + + type(eeq_cache), pointer :: ptr -end subroutine get_rec_trans + call view(cache, ptr) + if (any(mol%periodic)) then + call get_amat_3d(self, mol, ptr%wsc, ptr%alpha, amat) + else + call get_amat_0d(self, mol, amat) + end if +end subroutine get_coulomb_matrix subroutine get_amat_0d(self, mol, amat) - type(mchrg_model_type), intent(in) :: self + class(eeq_model), intent(in) :: self type(structure_type), intent(in) :: mol real(wp), intent(out) :: amat(:, :) @@ -168,15 +213,15 @@ subroutine get_amat_0d(self, mol, amat) !$omp shared(amat, mol, self) & !$omp private(iat, izp, jat, jzp, gam, vec, r2, tmp, amat_local) allocate(amat_local, source=amat) - !$omp do schedule(runtime) + !$omp do schedule(runtime) do iat = 1, mol%nat izp = mol%id(iat) - do jat = 1, iat-1 + do jat = 1, iat - 1 jzp = mol%id(jat) vec = mol%xyz(:, jat) - mol%xyz(:, iat) r2 = vec(1)**2 + vec(2)**2 + vec(3)**2 gam = 1.0_wp / (self%rad(izp)**2 + self%rad(jzp)**2) - tmp = erf(sqrt(r2*gam))/sqrt(r2) + tmp = erf(sqrt(r2 * gam)) / sqrt(r2) amat_local(jat, iat) = amat_local(jat, iat) + tmp amat_local(iat, jat) = amat_local(iat, jat) + tmp end do @@ -190,14 +235,14 @@ subroutine get_amat_0d(self, mol, amat) deallocate(amat_local) !$omp end parallel - amat(mol%nat+1, 1:mol%nat+1) = 1.0_wp - amat(1:mol%nat+1, mol%nat+1) = 1.0_wp - amat(mol%nat+1, mol%nat+1) = 0.0_wp + amat(mol%nat + 1, 1:mol%nat + 1) = 1.0_wp + amat(1:mol%nat + 1, mol%nat + 1) = 1.0_wp + amat(mol%nat + 1, mol%nat + 1) = 0.0_wp end subroutine get_amat_0d subroutine get_amat_3d(self, mol, wsc, alpha, amat) - type(mchrg_model_type), intent(in) :: self + class(eeq_model), intent(in) :: self type(structure_type), intent(in) :: mol type(wignerseitz_cell_type), intent(in) :: wsc real(wp), intent(in) :: alpha @@ -220,15 +265,15 @@ subroutine get_amat_3d(self, mol, wsc, alpha, amat) !$omp shared(amat, mol, self, wsc, dtrans, rtrans, alpha, vol) & !$omp private(iat, izp, jat, jzp, gam, wsw, vec, dtmp, rtmp, amat_local) allocate(amat_local, source=amat) - !$omp do schedule(runtime) + !$omp do schedule(runtime) do iat = 1, mol%nat izp = mol%id(iat) - do jat = 1, iat-1 + do jat = 1, iat - 1 jzp = mol%id(jat) gam = 1.0_wp / sqrt(self%rad(izp)**2 + self%rad(jzp)**2) wsw = 1.0_wp / real(wsc%nimg(jat, iat), wp) do img = 1, wsc%nimg(jat, iat) - vec = mol%xyz(:, iat) - mol%xyz(:, jat) - wsc%trans(:, wsc%tridx(img, jat, iat)) + vec = mol%xyz(:, jat) - mol%xyz(:, iat) + wsc%trans(:, wsc%tridx(img, jat, iat)) call get_amat_dir_3d(vec, gam, alpha, dtrans, dtmp) call get_amat_rec_3d(vec, vol, alpha, rtrans, rtmp) amat_local(jat, iat) = amat_local(jat, iat) + (dtmp + rtmp) * wsw @@ -255,9 +300,9 @@ subroutine get_amat_3d(self, mol, wsc, alpha, amat) deallocate(amat_local) !$omp end parallel - amat(mol%nat+1, 1:mol%nat+1) = 1.0_wp - amat(1:mol%nat+1, mol%nat+1) = 1.0_wp - amat(mol%nat+1, mol%nat+1) = 0.0_wp + amat(mol%nat + 1, 1:mol%nat + 1) = 1.0_wp + amat(1:mol%nat + 1, mol%nat + 1) = 1.0_wp + amat(mol%nat + 1, mol%nat + 1) = 0.0_wp end subroutine get_amat_3d @@ -277,7 +322,7 @@ subroutine get_amat_dir_3d(rij, gam, alp, trans, amat) vec(:) = rij + trans(:, itr) r1 = norm2(vec) if (r1 < eps) cycle - tmp = erf(gam*r1)/r1 - erf(alp*r1)/r1 + tmp = erf(gam * r1) / r1 - erf(alp * r1) / r1 amat = amat + tmp end do @@ -294,20 +339,38 @@ subroutine get_amat_rec_3d(rij, vol, alp, trans, amat) real(wp) :: fac, vec(3), g2, tmp amat = 0.0_wp - fac = 4*pi/vol + fac = 4 * pi / vol do itr = 1, size(trans, 2) vec(:) = trans(:, itr) g2 = dot_product(vec, vec) if (g2 < eps) cycle - tmp = cos(dot_product(rij, vec)) * fac * exp(-0.25_wp*g2/(alp*alp))/g2 + tmp = cos(dot_product(rij, vec)) * fac * exp(-0.25_wp * g2 / (alp * alp)) / g2 amat = amat + tmp end do end subroutine get_amat_rec_3d +subroutine get_coulomb_derivs(self, mol, cache, qvec, dadr, dadL, atrace) + class(eeq_model), intent(in) :: self + type(structure_type), intent(in) :: mol + type(cache_container), intent(inout) :: cache + real(wp), intent(in) :: qvec(:) + real(wp), intent(out) :: dadr(:, :, :), dadL(:, :, :), atrace(:, :) + + type(eeq_cache), pointer :: ptr + + call view(cache, ptr) + + if (any(mol%periodic)) then + call get_damat_3d(self, mol, ptr%wsc, ptr%alpha, qvec, dadr, dadL, atrace) + else + call get_damat_0d(self, mol, qvec, dadr, dadL, atrace) + end if +end subroutine get_coulomb_derivs + subroutine get_damat_0d(self, mol, qvec, dadr, dadL, atrace) - type(mchrg_model_type), intent(in) :: self + class(eeq_model), intent(in) :: self type(structure_type), intent(in) :: mol real(wp), intent(in) :: qvec(:) real(wp), intent(out) :: dadr(:, :, :) @@ -335,21 +398,21 @@ subroutine get_damat_0d(self, mol, qvec, dadr, dadL, atrace) !$omp do schedule(runtime) do iat = 1, mol%nat izp = mol%id(iat) - do jat = 1, iat-1 + do jat = 1, iat - 1 jzp = mol%id(jat) - vec = mol%xyz(:, iat) - mol%xyz(:, jat) + vec = mol%xyz(:, jat) - mol%xyz(:, iat) r2 = vec(1)**2 + vec(2)**2 + vec(3)**2 - gam = 1.0_wp/sqrt(self%rad(izp)**2 + self%rad(jzp)**2) - arg = gam*gam*r2 - dtmp = 2.0_wp*gam*exp(-arg)/(sqrtpi*r2)-erf(sqrt(arg))/(r2*sqrt(r2)) - dG = dtmp*vec + gam = 1.0_wp / sqrt(self%rad(izp)**2 + self%rad(jzp)**2) + arg = gam * gam * r2 + dtmp = 2.0_wp * gam * exp(-arg) / (sqrtpi * r2) - erf(sqrt(arg)) / (r2 * sqrt(r2)) + dG = dtmp * vec dS = spread(dG, 1, 3) * spread(vec, 2, 3) - atrace_local(:, iat) = +dG*qvec(jat) + atrace_local(:, iat) - atrace_local(:, jat) = -dG*qvec(iat) + atrace_local(:, jat) - dadr_local(:, iat, jat) = +dG*qvec(iat) - dadr_local(:, jat, iat) = -dG*qvec(jat) - dadL_local(:, :, jat) = +dS*qvec(iat) + dadL_local(:, :, jat) - dadL_local(:, :, iat) = +dS*qvec(jat) + dadL_local(:, :, iat) + atrace_local(:, iat) = -dG * qvec(jat) + atrace_local(:, iat) + atrace_local(:, jat) = +dG * qvec(iat) + atrace_local(:, jat) + dadr_local(:, iat, jat) = -dG * qvec(iat) + dadr_local(:, jat, iat) = +dG * qvec(jat) + dadL_local(:, :, jat) = +dS * qvec(iat) + dadL_local(:, :, jat) + dadL_local(:, :, iat) = +dS * qvec(jat) + dadL_local(:, :, iat) end do end do !$omp end do @@ -364,7 +427,7 @@ subroutine get_damat_0d(self, mol, qvec, dadr, dadL, atrace) end subroutine get_damat_0d subroutine get_damat_3d(self, mol, wsc, alpha, qvec, dadr, dadL, atrace) - type(mchrg_model_type), intent(in) :: self + class(eeq_model), intent(in) :: self type(structure_type), intent(in) :: mol type(wignerseitz_cell_type), intent(in) :: wsc real(wp), intent(in) :: alpha @@ -393,7 +456,7 @@ subroutine get_damat_3d(self, mol, wsc, alpha, qvec, dadr, dadL, atrace) !$omp parallel default(none) & !$omp shared(mol, self, wsc, alpha, vol, dtrans, rtrans, qvec) & !$omp shared(atrace, dadr, dadL) & - !$omp private(iat, izp, jat, jzp, img, gam, wsw, vec, dG, dS) & + !$omp private(iat, izp, jat, jzp, img, gam, wsw, vec, dG, dS) & !$omp private(dGr, dSr, dGd, dSd, atrace_local, dadr_local, dadL_local) allocate(atrace_local, source=atrace) allocate(dadr_local, source=dadr) @@ -401,25 +464,25 @@ subroutine get_damat_3d(self, mol, wsc, alpha, qvec, dadr, dadL, atrace) !$omp do schedule(runtime) do iat = 1, mol%nat izp = mol%id(iat) - do jat = 1, iat-1 + do jat = 1, iat - 1 jzp = mol%id(jat) dG(:) = 0.0_wp dS(:, :) = 0.0_wp gam = 1.0_wp / sqrt(self%rad(izp)**2 + self%rad(jzp)**2) wsw = 1.0_wp / real(wsc%nimg(jat, iat), wp) do img = 1, wsc%nimg(jat, iat) - vec = mol%xyz(:, iat) - mol%xyz(:, jat) - wsc%trans(:, wsc%tridx(img, jat, iat)) + vec = mol%xyz(:, jat) - mol%xyz(:, iat) + wsc%trans(:, wsc%tridx(img, jat, iat)) call get_damat_dir_3d(vec, gam, alpha, dtrans, dGd, dSd) call get_damat_rec_3d(vec, vol, alpha, rtrans, dGr, dSr) dG = dG + (dGd + dGr) * wsw dS = dS + (dSd + dSr) * wsw end do - atrace_local(:, iat) = +dG*qvec(jat) + atrace_local(:, iat) - atrace_local(:, jat) = -dG*qvec(iat) + atrace_local(:, jat) - dadr_local(:, iat, jat) = +dG*qvec(iat) + dadr_local(:, iat, jat) - dadr_local(:, jat, iat) = -dG*qvec(jat) + dadr_local(:, jat, iat) - dadL_local(:, :, jat) = +dS*qvec(iat) + dadL_local(:, :, jat) - dadL_local(:, :, iat) = +dS*qvec(jat) + dadL_local(:, :, iat) + atrace_local(:, iat) = -dG * qvec(jat) + atrace_local(:, iat) + atrace_local(:, jat) = +dG * qvec(iat) + atrace_local(:, jat) + dadr_local(:, iat, jat) = -dG * qvec(iat) + dadr_local(:, iat, jat) + dadr_local(:, jat, iat) = +dG * qvec(jat) + dadr_local(:, jat, iat) + dadL_local(:, :, jat) = +dS * qvec(iat) + dadL_local(:, :, jat) + dadL_local(:, :, iat) = +dS * qvec(jat) + dadL_local(:, :, iat) end do dS(:, :) = 0.0_wp @@ -431,7 +494,7 @@ subroutine get_damat_3d(self, mol, wsc, alpha, qvec, dadr, dadL, atrace) call get_damat_rec_3d(vec, vol, alpha, rtrans, dGr, dSr) dS = dS + (dSd + dSr) * wsw end do - dadL_local(:, :, iat) = +dS*qvec(iat) + dadL_local(:, :, iat) + dadL_local(:, :, iat) = +dS * qvec(iat) + dadL_local(:, :, iat) end do !$omp end do !$omp critical (get_damat_3d_) @@ -458,16 +521,16 @@ subroutine get_damat_dir_3d(rij, gam, alp, trans, dg, ds) dg(:) = 0.0_wp ds(:, :) = 0.0_wp - gam2 = gam*gam - alp2 = alp*alp + gam2 = gam * gam + alp2 = alp * alp do itr = 1, size(trans, 2) vec(:) = rij + trans(:, itr) r1 = norm2(vec) if (r1 < eps) cycle - r2 = r1*r1 - gtmp = +2*gam*exp(-r2*gam2)/(sqrtpi*r2) - erf(r1*gam)/(r2*r1) - atmp = -2*alp*exp(-r2*alp2)/(sqrtpi*r2) + erf(r1*alp)/(r2*r1) + r2 = r1 * r1 + gtmp = +2 * gam * exp(-r2 * gam2) / (sqrtpi * r2) - erf(r1 * gam) / (r2 * r1) + atmp = -2 * alp * exp(-r2 * alp2) / (sqrtpi * r2) + erf(r1 * alp) / (r2 * r1) dg(:) = dg + (gtmp + atmp) * vec ds(:, :) = ds + (gtmp + atmp) * spread(vec, 1, 3) * spread(vec, 2, 3) end do @@ -485,145 +548,62 @@ subroutine get_damat_rec_3d(rij, vol, alp, trans, dg, ds) integer :: itr real(wp) :: fac, vec(3), g2, gv, etmp, dtmp, alp2 real(wp), parameter :: unity(3, 3) = reshape(& - & [1, 0, 0, 0, 1, 0, 0, 0, 1], shape(unity)) + & [1, 0, 0, 0, 1, 0, 0, 0, 1], [3, 3]) dg(:) = 0.0_wp ds(:, :) = 0.0_wp - fac = 4*pi/vol - alp2 = alp*alp + fac = 4 * pi / vol + alp2 = alp * alp do itr = 1, size(trans, 2) vec(:) = trans(:, itr) g2 = dot_product(vec, vec) if (g2 < eps) cycle gv = dot_product(rij, vec) - etmp = fac * exp(-0.25_wp*g2/alp2)/g2 + etmp = fac * exp(-0.25_wp * g2 / alp2) / g2 dtmp = -sin(gv) * etmp dg(:) = dg + dtmp * vec ds(:, :) = ds + etmp * cos(gv) & - & * ((2.0_wp/g2 + 0.5_wp/alp2) * spread(vec, 1, 3)*spread(vec, 2, 3) - unity) + & * ((2.0_wp / g2 + 0.5_wp / alp2) * spread(vec, 1, 3) * spread(vec, 2, 3) - unity) end do end subroutine get_damat_rec_3d -subroutine solve(self, mol, error, cn, dcndr, dcndL, energy, gradient, sigma, qvec, dqdr, dqdL) - class(mchrg_model_type), intent(in) :: self - type(structure_type), intent(in) :: mol - type(error_type), allocatable, intent(out) :: error - real(wp), intent(in), contiguous :: cn(:) - real(wp), intent(in), contiguous, optional :: dcndr(:, :, :) - real(wp), intent(in), contiguous, optional :: dcndL(:, :, :) - real(wp), intent(out), contiguous, optional :: qvec(:) - real(wp), intent(out), contiguous, optional :: dqdr(:, :, :) - real(wp), intent(out), contiguous, optional :: dqdL(:, :, :) - real(wp), intent(inout), contiguous, optional :: energy(:) - real(wp), intent(inout), contiguous, optional :: gradient(:, :) - real(wp), intent(inout), contiguous, optional :: sigma(:, :) - - integer :: ic, jc, iat, ndim - logical :: grad, cpq, dcn - real(wp) :: alpha - integer(ik) :: info - integer(ik), allocatable :: ipiv(:) - - real(wp), allocatable :: xvec(:), vrhs(:), amat(:, :), ainv(:, :) - real(wp), allocatable :: dxdcn(:), atrace(:, :), dadr(:, :, :), dadL(:, :, :) - type(wignerseitz_cell_type) :: wsc - - ndim = mol%nat + 1 - if (any(mol%periodic)) then - call new_wignerseitz_cell(wsc, mol) - call get_alpha(mol%lattice, alpha) +!> Inspect cache and reallocate it in case of type mismatch +subroutine taint(cache, ptr) + !> Instance of the cache + type(cache_container), target, intent(inout) :: cache + !> Reference to the cache + type(eeq_cache), pointer, intent(out) :: ptr + + if (allocated(cache%raw)) then + call view(cache, ptr) + if (associated(ptr)) return + deallocate(cache%raw) end if - dcn = present(dcndr) .and. present(dcndL) - grad = present(gradient) .and. present(sigma) .and. dcn - cpq = present(dqdr) .and. present(dqdL) .and. dcn - - allocate(amat(ndim, ndim), xvec(ndim)) - allocate(ipiv(ndim)) - if (grad.or.cpq) then - allocate(dxdcn(ndim)) - end if - - call get_vrhs(self, mol, cn, xvec, dxdcn) - if (any(mol%periodic)) then - call get_amat_3d(self, mol, wsc, alpha, amat) - else - call get_amat_0d(self, mol, amat) + if (.not. allocated(cache%raw)) then + block + type(eeq_cache), allocatable :: tmp + allocate(tmp) + call move_alloc(tmp, cache%raw) + end block end if - vrhs = xvec - ainv = amat - - call sytrf(ainv, ipiv, info=info, uplo='l') - if (info /= 0) then - call fatal_error(error, "Bunch-Kaufman factorization failed.") - return - end if - - if (cpq) then - ! Inverted matrix is needed for coupled-perturbed equations - call sytri(ainv, ipiv, info=info, uplo='l') - if (info /= 0) then - call fatal_error(error, "Inversion of factorized matrix failed.") - return - end if - ! Solve the linear system - call symv(ainv, xvec, vrhs, uplo='l') - do ic = 1, ndim - do jc = ic + 1, ndim - ainv(ic, jc) = ainv(jc, ic) - end do - end do - else - ! Solve the linear system - call sytrs(ainv, vrhs, ipiv, info=info, uplo='l') - if (info /= 0) then - call fatal_error(error, "Solution of linear system failed.") - return - end if - end if - - if (present(qvec)) then - qvec(:) = vrhs(:mol%nat) - end if - - if (present(energy)) then - call symv(amat(:, :mol%nat), vrhs(:mol%nat), xvec(:mol%nat), & - & alpha=0.5_wp, beta=-1.0_wp, uplo='l') - energy(:) = energy(:) + vrhs(:mol%nat) * xvec(:mol%nat) - end if - - if (grad.or.cpq) then - allocate(dadr(3, mol%nat, ndim), dadL(3, 3, ndim), atrace(3, mol%nat)) - if (any(mol%periodic)) then - call get_damat_3d(self, mol, wsc, alpha, vrhs, dadr, dadL, atrace) - else - call get_damat_0d(self, mol, vrhs, dadr, dadL, atrace) - end if - xvec(:) = -dxdcn * vrhs - end if - - if (grad) then - call gemv(dadr, vrhs, gradient, beta=1.0_wp) - call gemv(dcndr, xvec(:mol%nat), gradient, beta=1.0_wp) - call gemv(dadL, vrhs, sigma, beta=1.0_wp, alpha=0.5_wp) - call gemv(dcndL, xvec(:mol%nat), sigma, beta=1.0_wp) - end if - - if (cpq) then - do iat = 1, mol%nat - dadr(:, iat, iat) = atrace(:, iat) + dadr(:, iat, iat) - dadr(:, :, iat) = -dcndr(:, :, iat) * dxdcn(iat) + dadr(:, :, iat) - dadL(:, :, iat) = -dcndL(:, :, iat) * dxdcn(iat) + dadL(:, :, iat) - end do - - call gemm(dadr, ainv(:, :mol%nat), dqdr, alpha=-1.0_wp) - call gemm(dadL, ainv(:, :mol%nat), dqdL, alpha=-1.0_wp) - end if - -end subroutine solve - - -end module multicharge_model + call view(cache, ptr) +end subroutine taint + +!> Return reference to cache after resolving its type +subroutine view(cache, ptr) + !> Instance of the cache + type(cache_container), target, intent(inout) :: cache + !> Reference to the cache + type(eeq_cache), pointer, intent(out) :: ptr + nullify(ptr) + select type(target => cache%raw) + type is(eeq_cache) + ptr => target + end select +end subroutine view + +end module multicharge_model_eeq diff --git a/src/multicharge/model/eeqbc.f90 b/src/multicharge/model/eeqbc.f90 new file mode 100644 index 00000000..bd1db2da --- /dev/null +++ b/src/multicharge/model/eeqbc.f90 @@ -0,0 +1,1372 @@ +! This file is part of multicharge. +! SPDX-Identifier: Apache-2.0 +! +! Licensed under the Apache License, Version 2.0 (the "License"); +! you may not use this file except in compliance with the License. +! You may obtain a copy of the License at +! +! http://www.apache.org/licenses/LICENSE-2.0 +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> @file multicharge/model/eeqbc.f90 +!> Provides implementation of the bond capacitor electronegativity equilibration model (EEQ_BC) + +!> Bond capacitor electronegativity equilibration charge model published in +!> +!> Thomas Froitzheim, Marcel Müller, Andreas Hansen, and Stefan Grimme, +!> *J. Chem. Phys.*, **2025**, 162, 214109. +!> DOI: [10.1063/5.0268978](https://dx.doi.org/10.1063/5.0268978) +module multicharge_model_eeqbc + use mctc_env, only: error_type, wp + use mctc_io, only: structure_type + use mctc_io_constants, only: pi + use mctc_ncoord, only: new_ncoord, cn_count + use multicharge_wignerseitz, only: new_wignerseitz_cell, wignerseitz_cell_type + use multicharge_model_type, only: mchrg_model_type, get_dir_trans + use multicharge_blas, only: gemv, gemm + use multicharge_model_cache, only: cache_container, model_cache + implicit none + private + + public :: eeqbc_model, new_eeqbc_model + + !> Cache for the EEQ-BC charge model + type, extends(model_cache) :: eeqbc_cache + !> Local charges + real(wp), allocatable :: qloc(:) + !> Local charge dr derivative + real(wp), allocatable :: dqlocdr(:, :, :) + !> Local charge dL derivative + real(wp), allocatable :: dqlocdL(:, :, :) + !> Full Maxwell capacitance matrix + real(wp), allocatable :: cmat(:, :) + !> Derivative of Maxwell capacitance matrix w.r.t positions + real(wp), allocatable :: dcdr(:, :, :) + !> Derivative of Maxwell capacitance matrix w.r.t lattice vectors + real(wp), allocatable :: dcdL(:, :, :) + !> Store tmp array from xvec calculation for reuse + real(wp), allocatable :: xtmp(:) + end type eeqbc_cache + + type, extends(mchrg_model_type) :: eeqbc_model + !> Bond capacitance + real(wp), allocatable :: cap(:) + !> Average coordination number + real(wp), allocatable :: avg_cn(:) + !> Exponent of error function in bond capacitance + real(wp) :: kbc + !> Exponent of the distance/CN normalization + real(wp) :: norm_exp + !> vdW radii + real(wp), allocatable :: rvdw(:, :) + contains + !> Update and allocate cache + procedure :: update + !> Calculate Coulomb matrix + procedure :: get_coulomb_matrix + !> Calculate derivatives of Coulomb matrix + procedure :: get_coulomb_derivs + !> Calculate right-hand side (electronegativity vector) + procedure :: get_xvec + !> Calculate derivatives of EN vector + procedure :: get_xvec_derivs + !> Calculate constraint matrix (molecular) + procedure :: get_cmat_0d + !> Calculate full constraint matrix (periodic) + procedure :: get_cmat_3d + !> Calculate constraint matrix derivatives (molecular) + procedure :: get_dcmat_0d + !> Calculate constraint matrix derivatives (periodic) + procedure :: get_dcmat_3d + end type eeqbc_model + + real(wp), parameter :: sqrtpi = sqrt(pi) + real(wp), parameter :: sqrt2pi = sqrt(2.0_wp / pi) + real(wp), parameter :: eps = sqrt(epsilon(0.0_wp)) + + !> Default exponent of distance/CN normalization + real(wp), parameter :: default_norm_exp = 1.0_wp + + !> Default exponent of error function in bond capacitance + real(wp), parameter :: default_kbc = 0.65_wp + +contains + +subroutine new_eeqbc_model(self, mol, error, chi, rad, & + & eta, kcnchi, kqchi, kqeta, kcnrad, cap, avg_cn, rvdw, & + & kbc, cutoff, cn_exp, rcov, en, cn_max, norm_exp) + !> Bond capacitor electronegativity equilibration model + type(eeqbc_model), intent(out) :: self + !> Molecular structure data + type(structure_type), intent(in) :: mol + !> Error handling + type(error_type), allocatable, intent(out) :: error + !> Electronegativity + real(wp), intent(in) :: chi(:) + !> Exponent gaussian charge + real(wp), intent(in) :: rad(:) + !> Chemical hardness + real(wp), intent(in) :: eta(:) + !> CN scaling factor for electronegativity + real(wp), intent(in) :: kcnchi(:) + !> Local charge scaling factor for electronegativity + real(wp), intent(in) :: kqchi(:) + !> Local charge scaling factor for chemical hardness + real(wp), intent(in) :: kqeta(:) + !> CN scaling factor for charge width + real(wp), intent(in) :: kcnrad + !> Bond capacitance + real(wp), intent(in) :: cap(:) + !> Average coordination number + real(wp), intent(in) :: avg_cn(:) + !> Van-der-Waals radii + real(wp), intent(in) :: rvdw(:, :) + !> Exponent of error function in bond capacitance + real(wp), intent(in), optional :: kbc + !> Exponent of the distance normalization + real(wp), intent(in), optional :: norm_exp + !> Cutoff radius for coordination number + real(wp), intent(in), optional :: cutoff + !> Steepness of the CN counting function + real(wp), intent(in), optional :: cn_exp + !> Covalent radii for CN + real(wp), intent(in), optional :: rcov(:) + !> Maximum CN cutoff for CN + real(wp), intent(in), optional :: cn_max + !> Pauling electronegativities normalized to fluorine + real(wp), intent(in), optional :: en(:) + + self%chi = chi + self%rad = rad + self%eta = eta + self%kcnchi = kcnchi + self%kqchi = kqchi + self%kqeta = kqeta + self%kcnrad = kcnrad + self%cap = cap + self%avg_cn = avg_cn + self%rvdw = rvdw + + if (present(kbc)) then + self%kbc = kbc + else + self%kbc = default_kbc + end if + + if (present(norm_exp)) then + self%norm_exp = norm_exp + else + self%norm_exp = default_norm_exp + end if + + ! Coordination number + call new_ncoord(self%ncoord, mol, cn_count%erf, error, & + & cutoff=cutoff, kcn=cn_exp, rcov=rcov, cut=cn_max, & + & norm_exp=self%norm_exp) + ! Electronegativity weighted coordination number for local charge + call new_ncoord(self%ncoord_en, mol, cn_count%erf_en, error, & + & cutoff=cutoff, kcn=cn_exp, rcov=rcov, en=en, cut=cn_max, & + & norm_exp=self%norm_exp) + +end subroutine new_eeqbc_model + +subroutine update(self, mol, cache, cn, qloc, dcndr, dcndL, dqlocdr, dqlocdL) + class(eeqbc_model), intent(in) :: self + type(structure_type), intent(in) :: mol + type(cache_container), intent(inout) :: cache + real(wp), intent(in) :: cn(:) + real(wp), intent(in), optional :: qloc(:) + real(wp), intent(in), optional :: dcndr(:, :, :) + real(wp), intent(in), optional :: dcndL(:, :, :) + real(wp), intent(in), optional :: dqlocdr(:, :, :) + real(wp), intent(in), optional :: dqlocdL(:, :, :) + + logical :: grad + + type(eeqbc_cache), pointer :: ptr + + call taint(cache, ptr) + + grad = present(dcndr) .and. present(dcndL) .and. present(dqlocdr) .and. present(dqlocdL) + + ! Refer CN and local charge arrays in cache + ptr%cn = cn + if (present(qloc)) then + ptr%qloc = qloc + else + error stop "qloc required for eeqbc" + end if + + if (grad) then + ptr%dcndr = dcndr + ptr%dcndL = dcndL + ptr%dqlocdr = dqlocdr + ptr%dqlocdL = dqlocdL + end if + + ! Allocate (for get_xvec and xvec_derivs) + if (.not. allocated(ptr%xtmp)) then + allocate(ptr%xtmp(mol%nat + 1)) + end if + + ! Allocate cmat + if (.not. allocated(ptr%cmat)) then + allocate(ptr%cmat(mol%nat + 1, mol%nat + 1)) + end if + + if (any(mol%periodic)) then + ! Create WSC + call new_wignerseitz_cell(ptr%wsc, mol) + + ! Get full cmat sum over all WSC images (for get_xvec and xvec_derivs) + call get_cmat_3d(self, mol, ptr%wsc, ptr%cmat) + if (grad) then + if (.not. allocated(ptr%dcdr)) then + allocate(ptr%dcdr(3, mol%nat, mol%nat + 1)) + end if + if (.not. allocated(ptr%dcdL)) then + allocate(ptr%dcdL(3, 3, mol%nat + 1)) + end if + call get_dcmat_3d(self, mol, ptr%wsc, ptr%dcdr, ptr%dcdL) + end if + else + call get_cmat_0d(self, mol, ptr%cmat) + + ! cmat gradients + if (grad) then + if (.not. allocated(ptr%dcdr)) then + allocate(ptr%dcdr(3, mol%nat, mol%nat + 1)) + end if + if (.not. allocated(ptr%dcdL)) then + allocate(ptr%dcdL(3, 3, mol%nat + 1)) + end if + call get_dcmat_0d(self, mol, ptr%dcdr, ptr%dcdL) + end if + end if + +end subroutine update + +subroutine get_xvec(self, mol, cache, xvec) + class(eeqbc_model), intent(in) :: self + type(structure_type), intent(in) :: mol + type(cache_container), intent(inout) :: cache + real(wp), intent(out) :: xvec(:) + + type(eeqbc_cache), pointer :: ptr + + integer :: iat, izp, img + real(wp) :: ctmp, vec(3), rvdw, capi, wsw + real(wp), allocatable :: dtrans(:, :) + + ! Thread-private array for reduction + real(wp), allocatable :: xvec_local(:) + + call view(cache, ptr) + + xvec(:) = 0.0_wp + !$omp parallel do default(none) schedule(runtime) & + !$omp shared(mol, self, ptr, xvec) & + !$omp private(iat, izp) + do iat = 1, mol%nat + izp = mol%id(iat) + ptr%xtmp(iat) = -self%chi(izp) + self%kcnchi(izp) * ptr%cn(iat) & + & + self%kqchi(izp) * ptr%qloc(iat) + end do + ptr%xtmp(mol%nat + 1) = mol%charge + + call gemv(ptr%cmat, ptr%xtmp, xvec) + + if (any(mol%periodic)) then + call get_dir_trans(mol%lattice, dtrans) + !$omp parallel default(none) & + !$omp shared(mol, self, ptr, xvec, dtrans) private(iat, izp, img, wsw) & + !$omp private(capi, vec, rvdw, ctmp, xvec_local) + allocate(xvec_local, mold=xvec) + xvec_local(:) = 0.0_wp + !$omp do schedule(runtime) + do iat = 1, mol%nat + izp = mol%id(iat) + capi = self%cap(izp) + ! eliminate self-interaction (quasi off-diagonal) + rvdw = self%rvdw(iat, iat) + wsw = 1.0_wp / real(ptr%wsc%nimg(iat, iat), wp) + do img = 1, ptr%wsc%nimg(iat, iat) + vec = ptr%wsc%trans(:, ptr%wsc%tridx(img, iat, iat)) + + call get_cpair_dir(self%kbc, vec, dtrans, rvdw, capi, capi, ctmp) + xvec_local(iat) = xvec_local(iat) - wsw * ctmp * ptr%xtmp(iat) + end do + end do + !$omp end do + !$omp critical (get_xvec_) + xvec(:) = xvec + xvec_local + !$omp end critical (get_xvec_) + deallocate(xvec_local) + !$omp end parallel + end if +end subroutine get_xvec + +subroutine get_xvec_derivs(self, mol, cache, dxdr, dxdL) + class(eeqbc_model), intent(in) :: self + type(structure_type), intent(in) :: mol + type(cache_container), intent(inout) :: cache + real(wp), intent(out), contiguous :: dxdr(:, :, :) + real(wp), intent(out), contiguous :: dxdL(:, :, :) + + type(eeqbc_cache), pointer :: ptr + + integer :: iat, izp, jat, jzp, img + real(wp) :: capi, capj, wsw, vec(3), ctmp, rvdw, dG(3), dS(3, 3) + real(wp), allocatable :: dtmpdr(:, :, :), dtmpdL(:, :, :) + real(wp), allocatable :: dtrans(:, :) + + ! Thread-private arrays for reduction + real(wp), allocatable :: dxdr_local(:, :, :), dxdL_local(:, :, :), dtmpdr_local(:, :, :), dtmpdL_local(:, :, :) + + call view(cache, ptr) + allocate(dtmpdr(3, mol%nat, mol%nat + 1), dtmpdL(3, 3, mol%nat + 1)) + + dxdr(:, :, :) = 0.0_wp + dxdL(:, :, :) = 0.0_wp + dtmpdr(:, :, :) = 0.0_wp + dtmpdL(:, :, :) = 0.0_wp + + !$omp parallel default(none) & + !$omp shared(mol, self, ptr, dtmpdr, dtmpdL) & + !$omp private(iat, izp, dtmpdr_local, dtmpdL_local) + allocate(dtmpdr_local, source=dtmpdr) + allocate(dtmpdL_local, source=dtmpdL) + !$omp do schedule(runtime) + do iat = 1, mol%nat + izp = mol%id(iat) + ! CN and effective charge derivative + dtmpdr_local(:, :, iat) = self%kcnchi(izp) * ptr%dcndr(:, :, iat) + dtmpdr_local(:, :, iat) + dtmpdL_local(:, :, iat) = self%kcnchi(izp) * ptr%dcndL(:, :, iat) + dtmpdL_local(:, :, iat) + dtmpdr_local(:, :, iat) = self%kqchi(izp) * ptr%dqlocdr(:, :, iat) + dtmpdr_local(:, :, iat) + dtmpdL_local(:, :, iat) = self%kqchi(izp) * ptr%dqlocdL(:, :, iat) + dtmpdL_local(:, :, iat) + end do + !$omp end do + !$omp critical (get_xvec_derivs_) + dtmpdr(:, :, :) = dtmpdr + dtmpdr_local + dtmpdL(:, :, :) = dtmpdL + dtmpdL_local + !$omp end critical (get_xvec_derivs_) + deallocate(dtmpdL_local, dtmpdr_local) + !$omp end parallel + + call gemm(dtmpdr, ptr%cmat, dxdr) + call gemm(dtmpdL, ptr%cmat, dxdL) + + if (any(mol%periodic)) then + call get_dir_trans(mol%lattice, dtrans) + !$omp parallel default(none) & + !$omp shared(mol, self, ptr, dxdr, dxdL, dtrans) & + !$omp private(iat, izp, jat, jzp, img, wsw) & + !$omp private(capi, capj, vec, rvdw, ctmp, dG, dS) & + !$omp private(dxdr_local, dxdL_local) + allocate(dxdr_local, mold=dxdr) + allocate(dxdL_local, mold=dxdL) + dxdr_local(:, :, :) = 0.0_wp + dxdL_local(:, :, :) = 0.0_wp + !$omp do schedule(runtime) + do iat = 1, mol%nat + izp = mol%id(iat) + capi = self%cap(izp) + do jat = 1, mol%nat + rvdw = self%rvdw(iat, jat) + jzp = mol%id(jat) + capj = self%cap(jzp) + + ! Diagonal elements + dxdr_local(:, iat, iat) = dxdr_local(:, iat, iat) + ptr%xtmp(jat) * ptr%dcdr(:, iat, jat) + + ! Derivative of capacitance matrix + dxdr_local(:, iat, jat) = dxdr_local(:, iat, jat) & + & + (ptr%xtmp(iat) - ptr%xtmp(jat)) * ptr%dcdr(:, iat, jat) + + wsw = 1.0_wp / real(ptr%wsc%nimg(iat, jat), wp) + do img = 1, ptr%wsc%nimg(iat, jat) + vec = mol%xyz(:, jat) - mol%xyz(:, iat) + ptr%wsc%trans(:, ptr%wsc%tridx(img, jat, iat)) + call get_dcpair_dir(self%kbc, vec, dtrans, rvdw, capi, capj, dG, dS) + dxdL_local(:, :, iat) = dxdL_local(:, :, iat) - wsw * dS * ptr%xtmp(jat) + end do + end do + dxdL_local(:, :, iat) = dxdL_local(:, :, iat) + ptr%xtmp(iat) * ptr%dcdL(:, :, iat) + + ! Capacitance terms for i = j, T != 0 + rvdw = self%rvdw(iat, iat) + wsw = 1.0_wp / real(ptr%wsc%nimg(iat, iat), wp) + do img = 1, ptr%wsc%nimg(iat, iat) + vec = ptr%wsc%trans(:, ptr%wsc%tridx(img, iat, iat)) + + call get_cpair_dir(self%kbc, vec, dtrans, rvdw, capi, capi, ctmp) + ctmp = ctmp * wsw + ! EN derivative + dxdr_local(:, :, iat) = dxdr_local(:, :, iat) - ctmp * self%kcnchi(izp) * ptr%dcndr(:, :, iat) + dxdL_local(:, :, iat) = dxdL_local(:, :, iat) - ctmp * self%kcnchi(izp) * ptr%dcndL(:, :, iat) + dxdr_local(:, :, iat) = dxdr_local(:, :, iat) - ctmp * self%kqchi(izp) * ptr%dqlocdr(:, :, iat) + dxdL_local(:, :, iat) = dxdL_local(:, :, iat) - ctmp * self%kqchi(izp) * ptr%dqlocdL(:, :, iat) + end do + end do + !$omp end do + !$omp critical (get_xvec_derivs_update) + dxdr(:, :, :) = dxdr + dxdr_local + dxdL(:, :, :) = dxdL + dxdL_local + !$omp end critical (get_xvec_derivs_update) + deallocate(dxdL_local, dxdr_local) + !$omp end parallel + else + !$omp parallel default(none) & + !$omp shared(mol, self, ptr, dxdr, dxdL) & + !$omp private(iat, izp, jat, jzp, vec, dxdr_local, dxdL_local) + allocate(dxdr_local, mold=dxdr) + allocate(dxdL_local, mold=dxdL) + dxdr_local(:, :, :) = 0.0_wp + dxdL_local(:, :, :) = 0.0_wp + !$omp do schedule(runtime) + do iat = 1, mol%nat + do jat = 1, iat - 1 + ! Diagonal elements + dxdr_local(:, iat, iat) = dxdr_local(:, iat, iat) + ptr%xtmp(jat) * ptr%dcdr(:, iat, jat) + dxdr_local(:, jat, jat) = dxdr_local(:, jat, jat) + ptr%xtmp(iat) * ptr%dcdr(:, jat, iat) + + ! Derivative of capacitance matrix + dxdr_local(:, iat, jat) = (ptr%xtmp(iat) - ptr%xtmp(jat)) * ptr%dcdr(:, iat, jat) + dxdr_local(:, iat, jat) + dxdr_local(:, jat, iat) = (ptr%xtmp(jat) - ptr%xtmp(iat)) * ptr%dcdr(:, jat, iat) + dxdr_local(:, jat, iat) + + vec = mol%xyz(:, iat) - mol%xyz(:, jat) + dxdL_local(:, :, iat) = dxdL_local(:, :, iat) + ptr%xtmp(jat) * spread(ptr%dcdr(:, iat, jat), 1, 3) * spread(vec, 2, 3) + dxdL_local(:, :, jat) = dxdL_local(:, :, jat) + ptr%xtmp(iat) * spread(ptr%dcdr(:, jat, iat), 1, 3) * spread(-vec, 2, 3) + end do + dxdr_local(:, iat, iat) = dxdr_local(:, iat, iat) + ptr%xtmp(iat) * ptr%dcdr(:, iat, iat) + dxdL_local(:, :, iat) = dxdL_local(:, :, iat) + ptr%xtmp(iat) * ptr%dcdL(:, :, iat) + end do + !$omp end do + !$omp critical (get_xvec_derivs_) + dxdr(:, :, :) = dxdr + dxdr_local + dxdL(:, :, :) = dxdL + dxdL_local + !$omp end critical (get_xvec_derivs_) + deallocate(dxdL_local, dxdr_local) + !$omp end parallel + end if + +end subroutine get_xvec_derivs + +subroutine get_coulomb_matrix(self, mol, cache, amat) + class(eeqbc_model), intent(in) :: self + type(structure_type), intent(in) :: mol + type(cache_container), intent(inout) :: cache + real(wp), intent(out) :: amat(:, :) + + type(eeqbc_cache), pointer :: ptr + call view(cache, ptr) + + if (any(mol%periodic)) then + call get_amat_3d(self, mol, ptr%wsc, ptr%cn, ptr%qloc, ptr%cmat, amat) + else + call get_amat_0d(self, mol, ptr%cn, ptr%qloc, ptr%cmat, amat) + end if +end subroutine get_coulomb_matrix + +subroutine get_amat_0d(self, mol, cn, qloc, cmat, amat) + class(eeqbc_model), intent(in) :: self + type(structure_type), intent(in) :: mol + real(wp), intent(in) :: cn(:) + real(wp), intent(in) :: qloc(:) + real(wp), intent(in) :: cmat(:, :) + real(wp), intent(out) :: amat(:, :) + + integer :: iat, jat, izp, jzp + real(wp) :: vec(3), r2, gam2, tmp, norm_cn, radi, radj + + ! Thread-private array for reduction + real(wp), allocatable :: amat_local(:, :) + + amat(:, :) = 0.0_wp + + !$omp parallel default(none) & + !$omp shared(amat, mol, self, cn, qloc, cmat) & + !$omp private(iat, izp, jat, jzp, gam2, vec, r2, tmp) & + !$omp private(norm_cn, radi, radj, amat_local) + allocate(amat_local, source=amat) + !$omp do schedule(runtime) + do iat = 1, mol%nat + izp = mol%id(iat) + ! Effective charge width of i + norm_cn = 1.0_wp / self%avg_cn(izp)**self%norm_exp + radi = self%rad(izp) * (1.0_wp - self%kcnrad * cn(iat) * norm_cn) + do jat = 1, iat - 1 + jzp = mol%id(jat) + vec = mol%xyz(:, jat) - mol%xyz(:, iat) + r2 = vec(1)**2 + vec(2)**2 + vec(3)**2 + ! Effective charge width of j + norm_cn = cn(jat) / self%avg_cn(jzp)**self%norm_exp + radj = self%rad(jzp) * (1.0_wp - self%kcnrad * norm_cn) + ! Coulomb interaction of Gaussian charges + gam2 = 1.0_wp / (radi**2 + radj**2) + tmp = erf(sqrt(r2 * gam2)) / sqrt(r2) * cmat(jat, iat) + amat_local(jat, iat) = tmp + amat_local(iat, jat) = tmp + end do + ! Effective hardness + tmp = self%eta(izp) + self%kqeta(izp) * qloc(iat) + sqrt2pi / radi + amat_local(iat, iat) = amat_local(iat, iat) + tmp * cmat(iat, iat) + 1.0_wp + end do + !$omp end do + !$omp critical (get_amat_0d_) + amat(:, :) = amat + amat_local + !$omp end critical (get_amat_0d_) + deallocate(amat_local) + !$omp end parallel + + amat(mol%nat + 1, 1:mol%nat + 1) = 1.0_wp + amat(1:mol%nat + 1, mol%nat + 1) = 1.0_wp + amat(mol%nat + 1, mol%nat + 1) = 0.0_wp + +end subroutine get_amat_0d + +subroutine get_amat_3d(self, mol, wsc, cn, qloc, cmat, amat) + class(eeqbc_model), intent(in) :: self + type(structure_type), intent(in) :: mol + type(wignerseitz_cell_type), intent(in) :: wsc + real(wp), intent(in) :: cn(:), qloc(:), cmat(:, :) + real(wp), intent(out) :: amat(:, :) + + integer :: iat, jat, izp, jzp, img + real(wp) :: vec(3), r1, gam, dtmp, ctmp, capi, capj, radi, radj, norm_cn, rvdw, wsw + real(wp), allocatable :: dtrans(:, :) + + ! Thread-private array for reduction + real(wp), allocatable :: amat_local(:, :) + + call get_dir_trans(mol%lattice, dtrans) + + amat(:, :) = 0.0_wp + + !$omp parallel default(none) & + !$omp shared(amat, cmat, mol, cn, qloc, self, wsc, dtrans) & + !$omp private(iat, izp, jat, jzp, gam, vec, dtmp, ctmp, norm_cn) & + !$omp private(radi, radj, capi, capj, rvdw, r1, wsw, amat_local) + allocate(amat_local, source=amat) + !$omp do schedule(runtime) + do iat = 1, mol%nat + izp = mol%id(iat) + ! Effective charge width of i + norm_cn = 1.0_wp / self%avg_cn(izp)**self%norm_exp + radi = self%rad(izp) * (1.0_wp - self%kcnrad * cn(iat) * norm_cn) + capi = self%cap(izp) + do jat = 1, iat - 1 + jzp = mol%id(jat) + ! vdw distance in Angstrom (approximate factor 2) + rvdw = self%rvdw(iat, jat) + ! Effective charge width of j + norm_cn = cn(jat) / self%avg_cn(jzp)**self%norm_exp + radj = self%rad(jzp) * (1.0_wp - self%kcnrad * norm_cn) + capj = self%cap(jzp) + ! Coulomb interaction of Gaussian charges + gam = 1.0_wp / sqrt(radi**2 + radj**2) + wsw = 1.0_wp / real(wsc%nimg(jat, iat), wp) + do img = 1, wsc%nimg(jat, iat) + vec = mol%xyz(:, jat) - mol%xyz(:, iat) + wsc%trans(:, wsc%tridx(img, jat, iat)) + call get_amat_dir_3d(vec, gam, dtrans, self%kbc, rvdw, capi, capj, dtmp) + amat_local(jat, iat) = amat_local(jat, iat) + dtmp * wsw + amat_local(iat, jat) = amat_local(iat, jat) + dtmp * wsw + end do + end do + + ! diagonal Coulomb interaction terms + gam = 1.0_wp / sqrt(2.0_wp * radi**2) + rvdw = self%rvdw(iat, iat) + wsw = 1.0_wp / real(wsc%nimg(iat, iat), wp) + do img = 1, wsc%nimg(iat, iat) + vec = wsc%trans(:, wsc%tridx(img, iat, iat)) + call get_amat_dir_3d(vec, gam, dtrans, self%kbc, rvdw, capi, capi, dtmp) + amat_local(iat, iat) = amat_local(iat, iat) + dtmp * wsw + end do + + ! Effective hardness + dtmp = self%eta(izp) + self%kqeta(izp) * qloc(iat) + sqrt2pi / radi + amat_local(iat, iat) = amat_local(iat, iat) + cmat(iat, iat) * dtmp + 1.0_wp + end do + !$omp end do + !$omp critical (get_amat_3d_) + amat(:, :) = amat + amat_local + !$omp end critical (get_amat_3d_) + deallocate(amat_local) + !$omp end parallel + + amat(mol%nat + 1, 1:mol%nat + 1) = 1.0_wp + amat(1:mol%nat + 1, mol%nat + 1) = 1.0_wp + amat(mol%nat + 1, mol%nat + 1) = 0.0_wp + +end subroutine get_amat_3d + +subroutine get_amat_dir_3d(rij, gam, trans, kbc, rvdw, capi, capj, amat) + real(wp), intent(in) :: rij(3) + real(wp), intent(in) :: gam + real(wp), intent(in) :: kbc + real(wp), intent(in) :: rvdw + real(wp), intent(in) :: capi + real(wp), intent(in) :: capj + real(wp), intent(in) :: trans(:, :) + real(wp), intent(out) :: amat + + integer :: itr + real(wp) :: vec(3), r1, tmp, ctmp + + amat = 0.0_wp + + do itr = 1, size(trans, 2) + vec(:) = rij + trans(:, itr) + r1 = norm2(vec) + if (r1 < eps) cycle + call get_cpair(kbc, ctmp, r1, rvdw, capi, capj) + tmp = -ctmp * erf(gam * r1) / r1 + amat = amat + tmp + end do + +end subroutine get_amat_dir_3d + +subroutine get_coulomb_derivs(self, mol, cache, qvec, dadr, dadL, atrace) + class(eeqbc_model), intent(in) :: self + type(structure_type), intent(in) :: mol + real(wp), intent(in) :: qvec(:) + type(cache_container), intent(inout) :: cache + real(wp), intent(out) :: dadr(:, :, :), dadL(:, :, :), atrace(:, :) + + type(eeqbc_cache), pointer :: ptr + call view(cache, ptr) + + if (any(mol%periodic)) then + call get_damat_3d(self, mol, ptr%wsc, ptr%cn, & + & ptr%qloc, qvec, ptr%dcndr, ptr%dcndL, ptr%dqlocdr, & + & ptr%dqlocdL, ptr%cmat, ptr%dcdr, ptr%dcdL, dadr, dadL, atrace) + + else + call get_damat_0d(self, mol, ptr%cn, & + & ptr%qloc, qvec, ptr%dcndr, ptr%dcndL, ptr%dqlocdr, & + & ptr%dqlocdL, ptr%cmat, ptr%dcdr, ptr%dcdL, dadr, dadL, atrace) + end if +end subroutine get_coulomb_derivs + +subroutine get_damat_0d(self, mol, cn, qloc, qvec, dcndr, dcndL, & + & dqlocdr, dqlocdL, cmat, dcdr, dcdL, dadr, dadL, atrace) + class(eeqbc_model), intent(in) :: self + type(structure_type), intent(in) :: mol + real(wp), intent(in) :: cn(:) + real(wp), intent(in) :: qloc(:) + real(wp), intent(in) :: qvec(:) + real(wp), intent(in) :: dcndr(:, :, :) + real(wp), intent(in) :: dcndL(:, :, :) + real(wp), intent(in) :: dqlocdr(:, :, :) + real(wp), intent(in) :: dqlocdL(:, :, :) + real(wp), intent(in) :: cmat(:, :) + real(wp), intent(in) :: dcdr(:, :, :) + real(wp), intent(in) :: dcdL(:, :, :) + real(wp), intent(out) :: dadr(:, :, :) + real(wp), intent(out) :: dadL(:, :, :) + real(wp), intent(out) :: atrace(:, :) + + integer :: iat, jat, izp, jzp + real(wp) :: vec(3), r2, gam, arg, dtmp, norm_cn + real(wp) :: radi, radj, dradi, dradj, dG(3), dS(3, 3), dgamdL(3, 3) + real(wp), allocatable :: dgamdr(:, :) + + ! Thread-private arrays for reduction + real(wp), allocatable :: atrace_local(:, :) + real(wp), allocatable :: dadr_local(:, :, :), dadL_local(:, :, :) + + allocate(dgamdr(3, mol%nat)) + + atrace(:, :) = 0.0_wp + dadr(:, :, :) = 0.0_wp + dadL(:, :, :) = 0.0_wp + + !$omp parallel default(none) & + !$omp shared(atrace, dadr, dadL, mol, self, cn, qloc, qvec) & + !$omp shared(cmat, dcdr, dcdL, dcndr, dcndL, dqlocdr, dqlocdL) & + !$omp private(iat, izp, jat, jzp, gam, vec, r2, dtmp, norm_cn, arg) & + !$omp private(radi, radj, dradi, dradj, dgamdr, dgamdL, dG, dS) & + !$omp private(atrace_local, dadr_local, dadL_local) + allocate(atrace_local, source=atrace) + allocate(dadr_local, source=dadr) + allocate(dadL_local, source=dadL) + !$omp do schedule(runtime) + do iat = 1, mol%nat + izp = mol%id(iat) + ! Effective charge width of i + norm_cn = 1.0_wp / self%avg_cn(izp)**self%norm_exp + radi = self%rad(izp) * (1.0_wp - self%kcnrad * cn(iat) * norm_cn) + dradi = -self%rad(izp) * self%kcnrad * norm_cn + do jat = 1, iat - 1 + jzp = mol%id(jat) + vec = mol%xyz(:, jat) - mol%xyz(:, iat) + r2 = vec(1)**2 + vec(2)**2 + vec(3)**2 + ! Effective charge width of j + norm_cn = 1.0_wp / self%avg_cn(jzp)**self%norm_exp + radj = self%rad(jzp) * (1.0_wp - self%kcnrad * cn(jat) * norm_cn) + dradj = -self%rad(jzp) * self%kcnrad * norm_cn + + ! Coulomb interaction of Gaussian charges + gam = 1.0_wp / sqrt(radi**2 + radj**2) + dgamdr(:, :) = -(radi * dradi * dcndr(:, :, iat) + radj * dradj * dcndr(:, :, jat)) & + & * gam**3.0_wp + dgamdL(:, :) = -(radi * dradi * dcndL(:, :, iat) + radj * dradj * dcndL(:, :, jat)) & + & * gam**3.0_wp + + ! Explicit derivative + arg = gam * gam * r2 + dtmp = 2.0_wp * gam * exp(-arg) / (sqrtpi * r2) & + & - erf(sqrt(arg)) / (r2 * sqrt(r2)) + dG(:) = dtmp * vec + dS(:, :) = spread(dG, 1, 3) * spread(vec, 2, 3) + atrace_local(:, iat) = -dG * qvec(jat) * cmat(jat, iat) + atrace_local(:, iat) + atrace_local(:, jat) = +dG * qvec(iat) * cmat(iat, jat) + atrace_local(:, jat) + dadr_local(:, iat, jat) = -dG * qvec(iat) * cmat(iat, jat) + dadr_local(:, iat, jat) + dadr_local(:, jat, iat) = +dG * qvec(jat) * cmat(jat, iat) + dadr_local(:, jat, iat) + dadL_local(:, :, iat) = +dS * qvec(jat) * cmat(jat, iat) + dadL_local(:, :, iat) + dadL_local(:, :, jat) = +dS * qvec(iat) * cmat(iat, jat) + dadL_local(:, :, jat) + + ! Effective charge width derivative + dtmp = 2.0_wp * exp(-arg) / (sqrtpi) + atrace_local(:, iat) = -dtmp * qvec(jat) * dgamdr(:, jat) * cmat(jat, iat) + atrace_local(:, iat) + atrace_local(:, jat) = -dtmp * qvec(iat) * dgamdr(:, iat) * cmat(iat, jat) + atrace_local(:, jat) + dadr_local(:, iat, jat) = +dtmp * qvec(iat) * dgamdr(:, iat) * cmat(iat, jat) + dadr_local(:, iat, jat) + dadr_local(:, jat, iat) = +dtmp * qvec(jat) * dgamdr(:, jat) * cmat(jat, iat) + dadr_local(:, jat, iat) + dadL_local(:, :, iat) = +dtmp * qvec(jat) * dgamdL(:, :) * cmat(jat, iat) + dadL_local(:, :, iat) + dadL_local(:, :, jat) = +dtmp * qvec(iat) * dgamdL(:, :) * cmat(iat, jat) + dadL_local(:, :, jat) + + ! Capacitance derivative off-diagonal + dtmp = erf(sqrt(r2) * gam) / (sqrt(r2)) + atrace_local(:, iat) = -dtmp * qvec(jat) * dcdr(:, jat, iat) + atrace_local(:, iat) + atrace_local(:, jat) = -dtmp * qvec(iat) * dcdr(:, iat, jat) + atrace_local(:, jat) + dadr_local(:, iat, jat) = +dtmp * qvec(iat) * dcdr(:, iat, jat) + dadr_local(:, iat, jat) + dadr_local(:, jat, iat) = +dtmp * qvec(jat) * dcdr(:, jat, iat) + dadr_local(:, jat, iat) + dadL_local(:, :, iat) = -dtmp * qvec(jat) * spread(dcdr(:, iat, jat), 2, 3) * spread(vec, 1, 3) & + & + dadL_local(:, :, iat) + dadL_local(:, :, jat) = -dtmp * qvec(iat) * spread(dcdr(:, iat, jat), 2, 3) * spread(vec, 1, 3) & + & + dadL_local(:, :, jat) + + ! Capacitance derivative diagonal + dtmp = (self%eta(izp) + self%kqeta(izp) * qloc(iat) + sqrt2pi / radi) * qvec(iat) + dadr_local(:, jat, iat) = -dtmp * dcdr(:, jat, iat) + dadr_local(:, jat, iat) + + dtmp = (self%eta(jzp) + self%kqeta(jzp) * qloc(jat) + sqrt2pi / radj) * qvec(jat) + dadr_local(:, iat, jat) = -dtmp * dcdr(:, iat, jat) + dadr_local(:, iat, jat) + end do + + ! Hardness derivative + dtmp = self%kqeta(izp) * qvec(iat) * cmat(iat, iat) + dadr_local(:, :, iat) = +dtmp * dqlocdr(:, :, iat) + dadr_local(:, :, iat) + dadL_local(:, :, iat) = +dtmp * dqlocdL(:, :, iat) + dadL_local(:, :, iat) + + ! Effective charge width derivative + dtmp = -sqrt2pi * dradi / (radi**2) * qvec(iat) * cmat(iat, iat) + dadr_local(:, :, iat) = +dtmp * dcndr(:, :, iat) + dadr_local(:, :, iat) + dadL_local(:, :, iat) = +dtmp * dcndL(:, :, iat) + dadL_local(:, :, iat) + + ! Capacitance derivative + dtmp = (self%eta(izp) + self%kqeta(izp) * qloc(iat) + sqrt2pi / radi) * qvec(iat) + dadr_local(:, iat, iat) = +dtmp * dcdr(:, iat, iat) + dadr_local(:, iat, iat) + dadL_local(:, :, iat) = +dtmp * dcdL(:, :, iat) + dadL_local(:, :, iat) + + end do + !$omp end do + !$omp critical (get_damat_0d_) + atrace(:, :) = atrace + atrace_local + dadr(:, :, :) = dadr + dadr_local + dadL(:, :, :) = dadL + dadL_local + !$omp end critical (get_damat_0d_) + deallocate(dadL_local, dadr_local, atrace_local) + !$omp end parallel + +end subroutine get_damat_0d + +subroutine get_damat_3d(self, mol, wsc, cn, qloc, qvec, dcndr, dcndL, dqlocdr, & + & dqlocdL, cmat, dcdr, dcdL, dadr, dadL, atrace) + class(eeqbc_model), intent(in) :: self + type(structure_type), intent(in) :: mol + type(wignerseitz_cell_type), intent(in) :: wsc + real(wp), intent(in) :: cn(:) + real(wp), intent(in) :: qloc(:) + real(wp), intent(in) :: qvec(:) + real(wp), intent(in) :: dcndr(:, :, :) + real(wp), intent(in) :: dcndL(:, :, :) + real(wp), intent(in) :: dqlocdr(:, :, :) + real(wp), intent(in) :: dqlocdL(:, :, :) + real(wp), intent(in) :: cmat(:, :) + real(wp), intent(in) :: dcdr(:, :, :) + real(wp), intent(in) :: dcdL(:, :, :) + real(wp), intent(out) :: dadr(:, :, :) + real(wp), intent(out) :: dadL(:, :, :) + real(wp), intent(out) :: atrace(:, :) + + integer :: iat, jat, izp, jzp, img + real(wp) :: vec(3), r2, gam, arg, dtmp, norm_cn, rvdw, wsw, dgam + real(wp) :: radi, radj, dradi, dradj, dG(3), dS(3, 3) + real(wp) :: dgamdL(3, 3), capi, capj + real(wp), allocatable :: dgamdr(:, :), dtrans(:, :) + + ! Thread-private arrays for reduction + real(wp), allocatable :: atrace_local(:, :) + real(wp), allocatable :: dadr_local(:, :, :), dadL_local(:, :, :) + + call get_dir_trans(mol%lattice, dtrans) + + allocate(dgamdr(3, mol%nat)) + + atrace(:, :) = 0.0_wp + dadr(:, :, :) = 0.0_wp + dadL(:, :, :) = 0.0_wp + + !$omp parallel default(none) & + !$omp shared(self, mol, cn, qloc, qvec, wsc, dadr, dadL, atrace) & + !$omp shared (cmat, dcdr, dcdL, dcndr, dcndL, dqlocdr, dqlocdL, dtrans) & + !$omp private(iat, izp, jat, jzp, img, gam, vec, r2, dtmp, norm_cn, arg, rvdw) & + !$omp private(radi, radj, dradi, dradj, capi, capj, dgamdr, dgamdL, dG, dS, wsw) & + !$omp private(dgam, dadr_local, dadL_local, atrace_local) + allocate(atrace_local, source=atrace) + allocate(dadr_local, source=dadr) + allocate(dadL_local, source=dadL) + !$omp do schedule(runtime) + do iat = 1, mol%nat + izp = mol%id(iat) + ! Effective charge width of i + norm_cn = 1.0_wp / self%avg_cn(izp)**self%norm_exp + radi = self%rad(izp) * (1.0_wp - self%kcnrad * cn(iat) * norm_cn) + dradi = -self%rad(izp) * self%kcnrad * norm_cn + capi = self%cap(izp) + do jat = 1, iat - 1 + jzp = mol%id(jat) + capj = self%cap(jzp) + rvdw = self%rvdw(iat, jat) + + ! Effective charge width of j + norm_cn = 1.0_wp / self%avg_cn(jzp)**self%norm_exp + radj = self%rad(jzp) * (1.0_wp - self%kcnrad * cn(jat) * norm_cn) + dradj = -self%rad(jzp) * self%kcnrad * norm_cn + + ! Coulomb interaction of Gaussian charges + gam = 1.0_wp / sqrt(radi**2 + radj**2) + dgamdr(:, :) = -(radi * dradi * dcndr(:, :, iat) + radj * dradj * dcndr(:, :, jat)) & + & * gam**3.0_wp + dgamdL(:, :) = -(radi * dradi * dcndL(:, :, iat) + radj * dradj * dcndL(:, :, jat)) & + & * gam**3.0_wp + + wsw = 1.0_wp / real(wsc%nimg(jat, iat), wp) + do img = 1, wsc%nimg(jat, iat) + vec = mol%xyz(:, jat) - mol%xyz(:, iat) + wsc%trans(:, wsc%tridx(img, jat, iat)) + + call get_damat_dir(vec, dtrans, capi, capj, rvdw, self%kbc, gam, dG, dS, dgam) + dG = dG * wsw + dS = dS * wsw + dgam = dgam * wsw + + ! Explicit derivative + atrace_local(:, iat) = -dG * qvec(jat) + atrace_local(:, iat) + atrace_local(:, jat) = +dG * qvec(iat) + atrace_local(:, jat) + dadr_local(:, iat, jat) = -dG * qvec(iat) + dadr_local(:, iat, jat) + dadr_local(:, jat, iat) = +dG * qvec(jat) + dadr_local(:, jat, iat) + dadL_local(:, :, jat) = +dS * qvec(iat) + dadL_local(:, :, jat) + dadL_local(:, :, iat) = +dS * qvec(jat) + dadL_local(:, :, iat) + + ! Effective charge width derivative + atrace_local(:, iat) = +dgam * qvec(jat) * dgamdr(:, jat) + atrace_local(:, iat) + atrace_local(:, jat) = +dgam * qvec(iat) * dgamdr(:, iat) + atrace_local(:, jat) + dadr_local(:, iat, jat) = -dgam * qvec(iat) * dgamdr(:, iat) + dadr_local(:, iat, jat) + dadr_local(:, jat, iat) = -dgam * qvec(jat) * dgamdr(:, jat) + dadr_local(:, jat, iat) + dadL_local(:, :, iat) = -dgam * qvec(jat) * dgamdL(:, :) + dadL_local(:, :, iat) + dadL_local(:, :, jat) = -dgam * qvec(iat) * dgamdL(:, :) + dadL_local(:, :, jat) + + call get_damat_dc_dir(vec, dtrans, capi, capj, rvdw, self%kbc, gam, dG, dS) + dG = dG * wsw + dS = dS * wsw + + ! Capacitance derivative off-diagonal + atrace_local(:, iat) = +qvec(jat) * dG(:) + atrace_local(:, iat) + atrace_local(:, jat) = -qvec(iat) * dG(:) + atrace_local(:, jat) + dadr_local(:, jat, iat) = -qvec(jat) * dG(:) + dadr_local(:, jat, iat) + dadr_local(:, iat, jat) = +qvec(iat) * dG(:) + dadr_local(:, iat, jat) + dadL_local(:, :, jat) = -qvec(iat) * dS(:, :) + dadL_local(:, :, jat) + dadL_local(:, :, iat) = -qvec(jat) * dS(:, :) + dadL_local(:, :, iat) + + call get_dcpair_dir(self%kbc, vec, dtrans, rvdw, capi, capj, dG, dS) + dG = dG * wsw + + ! Capacitance derivative diagonal + dtmp = (self%eta(izp) + self%kqeta(izp) * qloc(iat) + sqrt2pi / radi) * qvec(iat) + dadr_local(:, jat, iat) = +dtmp * dG(:) + dadr_local(:, jat, iat) + dtmp = (self%eta(jzp) + self%kqeta(jzp) * qloc(jat) + sqrt2pi / radj) * qvec(jat) + dadr_local(:, iat, jat) = -dtmp * dG(:) + dadr_local(:, iat, jat) + end do + end do + + ! diagonal explicit, charge width, and capacitance derivative terms + gam = 1.0_wp / sqrt(2.0_wp * radi**2) + dtmp = -sqrt2pi * dradi / (radi**2) * qvec(iat) + rvdw = self%rvdw(iat, iat) + wsw = 1.0_wp / real(wsc%nimg(iat, iat), wp) + do img = 1, wsc%nimg(iat, iat) + vec = wsc%trans(:, wsc%tridx(img, iat, iat)) + call get_damat_dir(vec, dtrans, capi, capi, rvdw, self%kbc, gam, dG, dS, dgam) + dgam = dgam * wsw + + ! Explicit derivative + dadL_local(:, :, iat) = +dS * wsw * qvec(iat) + dadL_local(:, :, iat) + + ! Effective charge width derivative + atrace_local(:, iat) = +dtmp * dcndr(:, iat, iat) * dgam + atrace_local(:, iat) + dadr_local(:, iat, iat) = -dtmp * dcndr(:, iat, iat) * dgam + dadr_local(:, iat, iat) + dadL_local(:, :, iat) = -dtmp * dcndL(:, :, iat) * dgam + dadL_local(:, :, iat) + + ! Capacitance derivative + call get_damat_dc_dir(vec, dtrans, capi, capi, rvdw, self%kbc, gam, dG, dS) + dadL_local(:, :, iat) = -qvec(iat) * dS * wsw + dadL_local(:, :, iat) + end do + + ! Hardness derivative + dtmp = self%kqeta(izp) * qvec(iat) * cmat(iat, iat) + dadr_local(:, :, iat) = +dtmp * dqlocdr(:, :, iat) + dadr_local(:, :, iat) + dadL_local(:, :, iat) = +dtmp * dqlocdL(:, :, iat) + dadL_local(:, :, iat) + + ! Effective charge width derivative + dtmp = -sqrt2pi * dradi / (radi**2) * qvec(iat) * cmat(iat, iat) + dadr_local(:, :, iat) = +dtmp * dcndr(:, :, iat) + dadr_local(:, :, iat) + dadL_local(:, :, iat) = +dtmp * dcndL(:, :, iat) + dadL_local(:, :, iat) + + dtmp = (self%eta(izp) + self%kqeta(izp) * qloc(iat) + sqrt2pi / radi) * qvec(iat) + dadr_local(:, iat, iat) = +dtmp * dcdr(:, iat, iat) + dadr_local(:, iat, iat) + dadL_local(:, :, iat) = +dtmp * dcdL(:, :, iat) + dadL_local(:, :, iat) + + end do + !$omp end do + !$omp critical (get_damat_3d_) + atrace(:, :) = atrace + atrace_local + dadr(:, :, :) = dadr + dadr_local + dadL(:, :, :) = dadL + dadL_local + !$omp end critical (get_damat_3d_) + deallocate(dadL_local, dadr_local, atrace_local) + !$omp end parallel + +end subroutine get_damat_3d + +subroutine get_damat_dir(rij, trans, capi, capj, rvdw, kbc, gam, dG, dS, dgam) + real(wp), intent(in) :: rij(3) + real(wp), intent(in) :: trans(:, :) + real(wp), intent(in) :: gam + real(wp), intent(in) :: capi, capj, rvdw, kbc + real(wp), intent(out) :: dG(3) + real(wp), intent(out) :: dS(3, 3) + real(wp), intent(out) :: dgam + + integer :: itr + real(wp) :: vec(3), r1, r2, gtmp, gam2, cmat + + dG(:) = 0.0_wp + dS(:, :) = 0.0_wp + dgam = 0.0_wp + + gam2 = gam * gam + + do itr = 1, size(trans, 2) + vec(:) = rij(:) + trans(:, itr) + r1 = norm2(vec) + if (r1 < eps) cycle + r2 = r1 * r1 + call get_cpair(kbc, cmat, r1, rvdw, capi, capj) + gtmp = 2.0_wp * gam * exp(-r2 * gam2) / (sqrtpi * r2) - erf(r1 * gam) / (r2 * r1) + dG(:) = dG - cmat * gtmp * vec + dS(:, :) = dS - cmat * gtmp * spread(vec, 1, 3) * spread(vec, 2, 3) + dgam = dgam + cmat * 2.0_wp * exp(-gam2 * r2) / sqrtpi + end do + +end subroutine get_damat_dir + +subroutine get_damat_dc_dir(rij, trans, capi, capj, rvdw, kbc, gam, dG, dS) + real(wp), intent(in) :: rij(3) + real(wp), intent(in) :: trans(:, :) + real(wp), intent(in) :: gam + real(wp), intent(in) :: capi, capj, rvdw, kbc + real(wp), intent(out) :: dG(3) + real(wp), intent(out) :: dS(3, 3) + + integer :: itr + real(wp) :: vec(3), r1, gtmp(3), stmp(3, 3), tmp + + dG(:) = 0.0_wp + dS(:, :) = 0.0_wp + + do itr = 1, size(trans, 2) + vec(:) = rij(:) + trans(:, itr) + r1 = norm2(vec) + if (r1 < eps) cycle + call get_dcpair(kbc, vec, rvdw, capi, capj, gtmp, stmp) + tmp = erf(gam * r1) / r1 + dG(:) = dG(:) + tmp * gtmp + dS(:, :) = dS(:, :) + tmp * stmp + end do + +end subroutine get_damat_dc_dir + +subroutine get_cmat_0d(self, mol, cmat) + class(eeqbc_model), intent(in) :: self + type(structure_type), intent(in) :: mol + real(wp), intent(out) :: cmat(:, :) + + integer :: iat, jat, izp, jzp + real(wp) :: vec(3), rvdw, tmp, capi, capj, r1 + + ! Thread-private array for reduction + real(wp), allocatable :: cmat_local(:, :) + + cmat(:, :) = 0.0_wp + + !$omp parallel default(none) & + !$omp shared(cmat, mol, self) & + !$omp private(iat, izp, jat, jzp) & + !$omp private(vec, r1, rvdw, tmp, capi, capj, cmat_local) + allocate(cmat_local, source=cmat) + !$omp do schedule(runtime) + do iat = 1, mol%nat + izp = mol%id(iat) + capi = self%cap(izp) + do jat = 1, iat - 1 + jzp = mol%id(jat) + vec = mol%xyz(:, jat) - mol%xyz(:, iat) + r1 = norm2(vec) + rvdw = self%rvdw(iat, jat) + capj = self%cap(jzp) + + call get_cpair(self%kbc, tmp, r1, rvdw, capi, capj) + + ! Off-diagonal elements + cmat_local(jat, iat) = -tmp + cmat_local(iat, jat) = -tmp + ! Diagonal elements + cmat_local(iat, iat) = cmat_local(iat, iat) + tmp + cmat_local(jat, jat) = cmat_local(jat, jat) + tmp + end do + end do + !$omp end do + !$omp critical (get_cmat_0d_) + cmat(:, :) = cmat + cmat_local + !$omp end critical (get_cmat_0d_) + deallocate(cmat_local) + !$omp end parallel + + cmat(mol%nat + 1, mol%nat + 1) = 1.0_wp + +end subroutine get_cmat_0d + +subroutine get_cmat_3d(self, mol, wsc, cmat) + class(eeqbc_model), intent(in) :: self + type(structure_type), intent(in) :: mol + type(wignerseitz_cell_type), intent(in) :: wsc + real(wp), intent(out) :: cmat(:, :) + + integer :: iat, jat, izp, jzp, img + real(wp) :: vec(3), rvdw, tmp, capi, capj, wsw + real(wp), allocatable :: dtrans(:, :) + + ! Thread-private array for reduction + real(wp), allocatable :: cmat_local(:, :) + + call get_dir_trans(mol%lattice, dtrans) + + cmat(:, :) = 0.0_wp + + !$omp parallel default(none) & + !$omp shared(cmat, mol, self, wsc, dtrans) & + !$omp private(iat, izp, jat, jzp, img) & + !$omp private(vec, rvdw, tmp, capi, capj, wsw, cmat_local) + allocate(cmat_local, source=cmat) + !$omp do schedule(runtime) + do iat = 1, mol%nat + izp = mol%id(iat) + capi = self%cap(izp) + do jat = 1, iat - 1 + jzp = mol%id(jat) + rvdw = self%rvdw(iat, jat) + capj = self%cap(jzp) + wsw = 1.0_wp / real(wsc%nimg(jat, iat), wp) + do img = 1, wsc%nimg(jat, iat) + vec = mol%xyz(:, iat) - mol%xyz(:, jat) - wsc%trans(:, wsc%tridx(img, jat, iat)) + + call get_cpair_dir(self%kbc, vec, dtrans, rvdw, capi, capj, tmp) + + ! Off-diagonal elements + cmat_local(jat, iat) = cmat_local(jat, iat) - tmp * wsw + cmat_local(iat, jat) = cmat_local(iat, jat) - tmp * wsw + ! Diagonal elements + cmat_local(iat, iat) = cmat_local(iat, iat) + tmp * wsw + cmat_local(jat, jat) = cmat_local(jat, jat) + tmp * wsw + end do + end do + + ! diagonal capacitance (interaction with images) + rvdw = self%rvdw(iat, iat) + wsw = 1.0_wp / real(wsc%nimg(iat, iat), wp) + do img = 1, wsc%nimg(iat, iat) + vec = wsc%trans(:, wsc%tridx(img, iat, iat)) + call get_cpair_dir(self%kbc, vec, dtrans, rvdw, capi, capi, tmp) + cmat_local(iat, iat) = cmat_local(iat, iat) + tmp * wsw + end do + end do + !$omp end do + !$omp critical (get_cmat_3d_) + cmat(:, :) = cmat + cmat_local + !$omp end critical (get_cmat_3d_) + deallocate(cmat_local) + !$omp end parallel + ! + cmat(mol%nat + 1, mol%nat + 1) = 1.0_wp + +end subroutine get_cmat_3d + +subroutine get_cpair(kbc, cpair, r1, rvdw, capi, capj) + real(wp), intent(in) :: kbc + real(wp), intent(in) :: r1 + real(wp), intent(in) :: capi + real(wp), intent(in) :: capj + real(wp), intent(in) :: rvdw + real(wp), intent(out) :: cpair + + real(wp) :: arg + + ! Capacitance of bond between atom i and j + arg = -kbc * (r1 - rvdw) / rvdw + cpair = sqrt(capi * capj) * 0.5_wp * (1.0_wp + erf(arg)) +end subroutine get_cpair + +subroutine get_cpair_dir(kbc, rij, trans, rvdw, capi, capj, cpair) + real(wp), intent(in) :: kbc + real(wp), intent(in) :: rij(3) + real(wp), intent(in) :: trans(:, :) + real(wp), intent(in) :: rvdw + real(wp), intent(in) :: capi + real(wp), intent(in) :: capj + real(wp), intent(out) :: cpair + + integer :: itr + real(wp) :: vec(3), r1, tmp + + cpair = 0.0_wp + do itr = 1, size(trans, 2) + vec(:) = rij + trans(:, itr) + r1 = norm2(vec) + if (r1 < eps) cycle + call get_cpair(kbc, tmp, r1, rvdw, capi, capj) + cpair = cpair + tmp + end do +end subroutine get_cpair_dir + +subroutine get_dcpair(kbc, vec, rvdw, capi, capj, dgpair, dspair) + real(wp), intent(in) :: kbc + real(wp), intent(in) :: vec(3) + real(wp), intent(in) :: rvdw + real(wp), intent(in) :: capi + real(wp), intent(in) :: capj + real(wp), intent(out) :: dgpair(3) + real(wp), intent(out) :: dspair(3, 3) + + real(wp) :: r1, arg, dtmp + + dgpair(:) = 0.0_wp + dspair(:, :) = 0.0_wp + + r1 = norm2(vec) + ! Capacitance of bond between atom i and j + arg = -(kbc * (r1 - rvdw) / rvdw)**2 + dtmp = -sqrt(capi * capj) * kbc * exp(arg) / (sqrtpi * rvdw) + dgpair = dtmp * vec / r1 + dspair = spread(dgpair, 1, 3) * spread(vec, 2, 3) +end subroutine get_dcpair + +subroutine get_dcmat_0d(self, mol, dcdr, dcdL) + class(eeqbc_model), intent(in) :: self + type(structure_type), intent(in) :: mol + real(wp), intent(out) :: dcdr(:, :, :) + real(wp), intent(out) :: dcdL(:, :, :) + + integer :: iat, jat, izp, jzp + real(wp) :: vec(3), r2, rvdw, dtmp, arg, dG(3), dS(3, 3), capi, capj + + ! Thread-private arrays for reduction + real(wp), allocatable :: dcdr_local(:, :, :), dcdL_local(:, :, :) + + dcdr(:, :, :) = 0.0_wp + dcdL(:, :, :) = 0.0_wp + + !$omp parallel default(none) & + !$omp shared(dcdr, dcdL, mol, self) & + !$omp private(iat, izp, jat, jzp, r2, vec, rvdw) & + !$omp private(dG, dS, dtmp, arg, capi, capj) & + !$omp private(dcdr_local, dcdL_local) + allocate(dcdr_local, source=dcdr) + allocate(dcdL_local, source=dcdL) + !$omp do schedule(runtime) + do iat = 1, mol%nat + izp = mol%id(iat) + capi = self%cap(izp) + do jat = 1, iat - 1 + jzp = mol%id(jat) + capj = self%cap(jzp) + rvdw = self%rvdw(iat, jat) + vec = mol%xyz(:, jat) - mol%xyz(:, iat) + + call get_dcpair(self%kbc, vec, rvdw, capi, capj, dG, dS) + + ! Off-diagonal elements + dcdr_local(:, iat, jat) = +dG + dcdr_local(:, jat, iat) = -dG + ! Diagonal elements + dcdr_local(:, iat, iat) = -dG + dcdr_local(:, iat, iat) + dcdr_local(:, jat, jat) = +dG + dcdr_local(:, jat, jat) + dcdL_local(:, :, iat) = +dS + dcdL_local(:, :, iat) + dcdL_local(:, :, jat) = +dS + dcdL_local(:, :, jat) + end do + end do + !$omp end do + !$omp critical (get_dcmat_0d_) + dcdr(:, :, :) = dcdr + dcdr_local + dcdL(:, :, :) = dcdL + dcdL_local + !$omp end critical (get_dcmat_0d_) + deallocate(dcdL_local, dcdr_local) + !$omp end parallel + +end subroutine get_dcmat_0d + +subroutine get_dcmat_3d(self, mol, wsc, dcdr, dcdL) + class(eeqbc_model), intent(in) :: self + type(structure_type), intent(in) :: mol + type(wignerseitz_cell_type), intent(in) :: wsc + real(wp), intent(out) :: dcdr(:, :, :) + real(wp), intent(out) :: dcdL(:, :, :) + + integer :: iat, jat, izp, jzp, img + real(wp) :: vec(3), r2, rvdw, dtmp, arg, dG(3), dS(3, 3), capi, capj, wsw + real(wp), allocatable :: dtrans(:, :) + + ! Thread-private arrays for reduction + real(wp), allocatable :: dcdr_local(:, :, :), dcdL_local(:, :, :) + + call get_dir_trans(mol%lattice, dtrans) + + dcdr(:, :, :) = 0.0_wp + dcdL(:, :, :) = 0.0_wp + + !$omp parallel default(none) & + !$omp shared(dcdr, dcdL, mol, self, dtrans, wsc) & + !$omp private(iat, izp, jat, jzp, r2, vec, rvdw) & + !$omp private(dG, dS, dtmp, arg, capi, capj, wsw) & + !$omp private(dcdr_local, dcdL_local) + allocate(dcdr_local, source=dcdr) + allocate(dcdL_local, source=dcdL) + !$omp do schedule(runtime) + do iat = 1, mol%nat + izp = mol%id(iat) + capi = self%cap(izp) + do jat = 1, iat - 1 + jzp = mol%id(jat) + capj = self%cap(jzp) + rvdw = self%rvdw(iat, jat) + wsw = 1.0_wp / real(wsc%nimg(jat, iat), wp) + do img = 1, wsc%nimg(jat, iat) + vec = mol%xyz(:, jat) - mol%xyz(:, iat) + wsc%trans(:, wsc%tridx(img, jat, iat)) + + call get_dcpair_dir(self%kbc, vec, dtrans, rvdw, capi, capj, dG, dS) + + ! Off-diagonal elements + dcdr_local(:, iat, jat) = +dG * wsw + dcdr_local(:, iat, jat) + dcdr_local(:, jat, iat) = -dG * wsw + dcdr_local(:, jat, iat) + ! Diagonal elements + dcdr_local(:, iat, iat) = -dG * wsw + dcdr_local(:, iat, iat) + dcdr_local(:, jat, jat) = +dG * wsw + dcdr_local(:, jat, jat) + dcdL_local(:, :, jat) = +dS * wsw + dcdL_local(:, :, jat) + dcdL_local(:, :, iat) = +dS * wsw + dcdL_local(:, :, iat) + end do + end do + + rvdw = self%rvdw(iat, iat) + wsw = 1.0_wp / real(wsc%nimg(iat, iat), wp) + do img = 1, wsc%nimg(iat, iat) + vec = wsc%trans(:, wsc%tridx(img, iat, iat)) + + call get_dcpair_dir(self%kbc, vec, dtrans, rvdw, capi, capi, dG, dS) + + ! Positive diagonal elements + dcdL_local(:, :, iat) = +dS * wsw + dcdL_local(:, :, iat) + end do + end do + !$omp end do + !$omp critical (get_dcmat_3d_) + dcdr(:, :, :) = dcdr + dcdr_local + dcdL(:, :, :) = dcdL + dcdL_local + !$omp end critical (get_dcmat_3d_) + deallocate(dcdL_local, dcdr_local) + !$omp end parallel + +end subroutine get_dcmat_3d + +subroutine get_dcpair_dir(kbc, rij, trans, rvdw, capi, capj, dgpair, dspair) + real(wp), intent(in) :: rij(3), capi, capj, rvdw, kbc, trans(:, :) + real(wp), intent(out) :: dgpair(3) + real(wp), intent(out) :: dspair(3, 3) + + integer :: itr + real(wp) :: r1, arg, dtmp, dgtmp(3), dstmp(3, 3), vec(3) + + dgpair(:) = 0.0_wp + dspair(:, :) = 0.0_wp + do itr = 1, size(trans, 2) + vec(:) = rij + trans(:, itr) + r1 = norm2(vec) + if (r1 < eps) cycle + call get_dcpair(kbc, vec, rvdw, capi, capj, dgtmp, dstmp) + dgpair(:) = dgpair + dgtmp + dspair(:, :) = dspair + dstmp + end do +end subroutine get_dcpair_dir + +!> Inspect cache and reallocate it in case of type mismatch +subroutine taint(cache, ptr) + !> Instance of the cache + type(cache_container), target, intent(inout) :: cache + !> Reference to the cache + type(eeqbc_cache), pointer, intent(out) :: ptr + + if (allocated(cache%raw)) then + call view(cache, ptr) + if (associated(ptr)) return + deallocate(cache%raw) + end if + + if (.not. allocated(cache%raw)) then + block + type(eeqbc_cache), allocatable :: tmp + allocate(tmp) + call move_alloc(tmp, cache%raw) + end block + end if + + call view(cache, ptr) +end subroutine taint + +!> Return reference to cache after resolving its type +subroutine view(cache, ptr) + !> Instance of the cache + type(cache_container), target, intent(inout) :: cache + !> Reference to the cache + type(eeqbc_cache), pointer, intent(out) :: ptr + nullify(ptr) + select type(target => cache%raw) + type is(eeqbc_cache) + ptr => target + end select +end subroutine view + +end module multicharge_model_eeqbc diff --git a/src/multicharge/model/meson.build b/src/multicharge/model/meson.build new file mode 100644 index 00000000..44128da7 --- /dev/null +++ b/src/multicharge/model/meson.build @@ -0,0 +1,21 @@ +# This file is part of multicharge. +# SPDX-Identifier: Apache-2.0 +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + + +srcs += files( + 'eeq.f90', + 'eeqbc.f90', + 'type.F90', +) diff --git a/src/multicharge/model/type.F90 b/src/multicharge/model/type.F90 new file mode 100644 index 00000000..d2c0c706 --- /dev/null +++ b/src/multicharge/model/type.F90 @@ -0,0 +1,324 @@ +! This file is part of multicharge. +! SPDX-Identifier: Apache-2.0 +! +! Licensed under the Apache License, Version 2.0 (the "License"); +! you may not use this file except in compliance with the License. +! You may obtain a copy of the License at +! +! http://www.apache.org/licenses/LICENSE-2.0 +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> @file multicharge/model/type.f90 +!> Provides a general base class for the charge models + +#ifndef IK +#define IK i4 +#endif + +!> General charge model +module multicharge_model_type + + use mctc_env, only: error_type, fatal_error, wp, ik => IK + use mctc_io, only: structure_type + use mctc_io_constants, only: pi + use mctc_io_math, only: matinv_3x3 + use mctc_cutoff, only: get_lattice_points + use mctc_ncoord, only: ncoord_type + use multicharge_blas, only: gemv, symv, gemm + use multicharge_lapack, only: sytrf, sytrs, sytri + use multicharge_wignerseitz, only: wignerseitz_cell_type, new_wignerseitz_cell + use multicharge_model_cache, only: model_cache, cache_container + implicit none + private + + public :: mchrg_model_type, get_dir_trans, get_rec_trans + + !> Abstract multicharge model type + type, abstract :: mchrg_model_type + !> Electronegativity + real(wp), allocatable :: chi(:) + !> Charge width + real(wp), allocatable :: rad(:) + !> Chemical hardness + real(wp), allocatable :: eta(:) + !> CN scaling factor for electronegativity + real(wp), allocatable :: kcnchi(:) + !> Local charge scaling factor for electronegativity + real(wp), allocatable :: kqchi(:) + !> Local charge scaling factor for chemical hardness + real(wp), allocatable :: kqeta(:) + !> CN scaling factor for charge width + real(wp), allocatable :: kcnrad + !> Coordination number + class(ncoord_type), allocatable :: ncoord + !> Electronegativity weighted CN for local charge + class(ncoord_type), allocatable :: ncoord_en + contains + !> Solve linear equations for the charge model + procedure :: solve + !> Calculate local charges from electronegativity weighted CN + procedure :: local_charge + !> Update cache + procedure(update), deferred :: update + !> Calculate right-hand side (electronegativity) + procedure(get_xvec), deferred :: get_xvec + !> Calculate xvec Gradients + procedure(get_xvec_derivs), deferred :: get_xvec_derivs + !> Calculate Coulomb matrix + procedure(get_coulomb_matrix), deferred :: get_coulomb_matrix + !> Calculate Coulomb matrix derivatives + procedure(get_coulomb_derivs), deferred :: get_coulomb_derivs + end type mchrg_model_type + + abstract interface + subroutine update(self, mol, cache, cn, qloc, dcndr, dcndL, dqlocdr, dqlocdL) + import :: mchrg_model_type, structure_type, cache_container, wp + class(mchrg_model_type), intent(in) :: self + type(structure_type), intent(in) :: mol + type(cache_container), intent(inout) :: cache + real(wp), intent(in) :: cn(:) + real(wp), intent(in), optional :: qloc(:) + real(wp), intent(in), optional :: dcndr(:, :, :) + real(wp), intent(in), optional :: dcndL(:, :, :) + real(wp), intent(in), optional :: dqlocdr(:, :, :) + real(wp), intent(in), optional :: dqlocdL(:, :, :) + end subroutine update + + subroutine get_coulomb_matrix(self, mol, cache, amat) + import :: mchrg_model_type, structure_type, cache_container, wp + class(mchrg_model_type), intent(in) :: self + type(structure_type), intent(in) :: mol + type(cache_container), intent(inout) :: cache + real(wp), intent(out) :: amat(:, :) + end subroutine get_coulomb_matrix + + subroutine get_coulomb_derivs(self, mol, cache, qvec, dadr, dadL, atrace) + import :: mchrg_model_type, structure_type, cache_container, wp + class(mchrg_model_type), intent(in) :: self + type(structure_type), intent(in) :: mol + type(cache_container), intent(inout) :: cache + real(wp), intent(in) :: qvec(:) + real(wp), intent(out) :: dadr(:, :, :), dadL(:, :, :), atrace(:, :) + end subroutine get_coulomb_derivs + + subroutine get_xvec(self, mol, cache, xvec) + import :: mchrg_model_type, cache_container, structure_type, wp + class(mchrg_model_type), intent(in) :: self + type(structure_type), intent(in) :: mol + type(cache_container), intent(inout) :: cache + real(wp), intent(out) :: xvec(:) + end subroutine get_xvec + + subroutine get_xvec_derivs(self, mol, cache, dxdr, dxdL) + import :: mchrg_model_type, structure_type, cache_container, wp + class(mchrg_model_type), intent(in) :: self + type(structure_type), intent(in) :: mol + type(cache_container), intent(inout) :: cache + real(wp), intent(out), contiguous :: dxdr(:, :, :) + real(wp), intent(out), contiguous :: dxdL(:, :, :) + end subroutine get_xvec_derivs + end interface + + real(wp), parameter :: twopi = 2 * pi + +contains + +subroutine get_dir_trans(lattice, trans) + real(wp), intent(in) :: lattice(:, :) + real(wp), allocatable, intent(out) :: trans(:, :) + integer, parameter :: rep(3) = [2, 2, 2] + + call get_lattice_points(lattice, rep, .true., trans) + +end subroutine get_dir_trans + +subroutine get_rec_trans(lattice, trans) + real(wp), intent(in) :: lattice(:, :) + real(wp), allocatable, intent(out) :: trans(:, :) + integer, parameter :: rep(3) = [2, 2, 2] + real(wp) :: rec_lat(3, 3) + + rec_lat = twopi * transpose(matinv_3x3(lattice)) + call get_lattice_points(rec_lat, rep, .false., trans) + +end subroutine get_rec_trans + +subroutine solve(self, mol, error, cn, qloc, dcndr, dcndL, dqlocdr, dqlocdL, & + & energy, gradient, sigma, qvec, dqdr, dqdL) + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: self + !> Molecular structure data + type(structure_type), intent(in) :: mol + !> Error handling + type(error_type), allocatable, intent(out) :: error + !> Coordination number + real(wp), intent(in), contiguous :: cn(:) + !> Local atomic partial charges + real(wp), intent(in), contiguous :: qloc(:) + !> Optional derivative of the coordination number w.r.t. atomic positions + real(wp), intent(in), contiguous, optional :: dcndr(:, :, :) + !> Optional derivative of the coordination number w.r.t. lattice vectors + real(wp), intent(in), contiguous, optional :: dcndL(:, :, :) + !> Optional derivative of the local atomic partial charges w.r.t. atomic positions + real(wp), intent(in), contiguous, optional :: dqlocdr(:, :, :) + !> Optional derivative of the local atomic partial charges w.r.t. lattice vectors + real(wp), intent(in), contiguous, optional :: dqlocdL(:, :, :) + !> Optional atomic partial charges result + real(wp), intent(out), contiguous, optional :: qvec(:) + !> Optional electrostatic energy result + real(wp), intent(inout), contiguous, optional :: energy(:) + !> Optional gradient for electrostatic energy + real(wp), intent(inout), contiguous, optional :: gradient(:, :) + !> Optional stress tensor for electrostatic energy + real(wp), intent(inout), contiguous, optional :: sigma(:, :) + !> Optional derivative of the atomic partial charges w.r.t. atomic positions + real(wp), intent(out), contiguous, optional :: dqdr(:, :, :) + !> Optional derivative of the atomic partial charges w.r.t. lattice vectors + real(wp), intent(out), contiguous, optional :: dqdL(:, :, :) + + integer :: ic, jc, iat, ndim + logical :: grad, cpq, dcn + integer(ik) :: info + integer(ik), allocatable :: ipiv(:) + + ! Variables for solving ES equation + real(wp), allocatable :: xvec(:), vrhs(:), amat(:, :) + real(wp), allocatable :: ainv(:, :), jmat(:, :) + ! Gradients + real(wp), allocatable :: dadr(:, :, :), dadL(:, :, :), atrace(:, :) + real(wp), allocatable :: dxdr(:, :, :), dxdL(:, :, :) + type(cache_container), allocatable :: cache + real(wp), allocatable :: trans(:, :) + + ! Calculate gradient if the respective arrays are present + dcn = present(dcndr) .and. present(dcndL) + grad = present(gradient) .and. present(sigma) .and. dcn + cpq = present(dqdr) .and. present(dqdL) .and. dcn + + ! Update cache + allocate(cache) + call self%update(mol, cache, cn, qloc, dcndr, dcndL, dqlocdr, dqlocdL) + + ! Setup the Coulomb matrix + ndim = mol%nat + 1 + allocate(amat(ndim, ndim)) + call self%get_coulomb_matrix(mol, cache, amat) + + ! Get RHS of ES equation + allocate(xvec(ndim)) + call self%get_xvec(mol, cache, xvec) + + vrhs = xvec + ainv = amat + + ! Factorize the Coulomb matrix + allocate(ipiv(ndim)) + call sytrf(ainv, ipiv, info=info, uplo='l') + if (info /= 0) then + call fatal_error(error, "Bunch-Kaufman factorization failed.") + return + end if + + if (cpq) then + ! Inverted matrix is needed for coupled-perturbed equations + call sytri(ainv, ipiv, info=info, uplo='l') + if (info /= 0) then + call fatal_error(error, "Inversion of factorized matrix failed.") + return + end if + ! Solve the linear system + call symv(ainv, xvec, vrhs, uplo='l') + do ic = 1, ndim + do jc = ic + 1, ndim + ainv(ic, jc) = ainv(jc, ic) + end do + end do + else + ! Solve the linear system + call sytrs(ainv, vrhs, ipiv, info=info, uplo='l') + if (info /= 0) then + call fatal_error(error, "Solution of linear system failed.") + return + end if + + end if + + if (present(qvec)) then + qvec(:) = vrhs(:mol%nat) + end if + + if (present(energy)) then + ! Extract only the Coulomb matrix without the constraints + allocate(jmat(mol%nat, mol%nat)) + jmat = amat(:mol%nat, :mol%nat) + call symv(jmat, vrhs(:mol%nat), xvec(:mol%nat), & + & alpha=0.5_wp, beta=-1.0_wp, uplo='l') + energy(:) = energy(:) + vrhs(:mol%nat) * xvec(:mol%nat) + end if + + ! Allocate and get amat derivatives + if (grad .or. cpq) then + allocate(dadr(3, mol%nat, ndim), dadL(3, 3, ndim), atrace(3, mol%nat)) + allocate(dxdr(3, mol%nat, ndim), dxdL(3, 3, ndim)) + call self%get_xvec_derivs(mol, cache, dxdr, dxdL) + call self%get_coulomb_derivs(mol, cache, vrhs, dadr, dadL, atrace) + do iat = 1, mol%nat + dadr(:, iat, iat) = atrace(:, iat) + dadr(:, iat, iat) + end do + end if + + if (grad) then + gradient = 0.0_wp + call gemv(dadr(:, :, :mol%nat), vrhs(:mol%nat), gradient, beta=1.0_wp, alpha=0.5_wp) + call gemv(dxdr(:, :, :mol%nat), vrhs(:mol%nat), gradient, beta=1.0_wp, alpha=-1.0_wp) + call gemv(dadL, vrhs, sigma, beta=1.0_wp, alpha=0.5_wp) + call gemv(dxdL, vrhs, sigma, beta=1.0_wp, alpha=-1.0_wp) + end if + + if (cpq) then + do iat = 1, mol%nat + dadr(:, :, iat) = -dxdr(:, :, iat) + dadr(:, :, iat) + dadL(:, :, iat) = -dxdL(:, :, iat) + dadL(:, :, iat) + end do + + call gemm(dadr, ainv(:, :mol%nat), dqdr, alpha=-1.0_wp) + call gemm(dadL, ainv(:, :mol%nat), dqdL, alpha=-1.0_wp) + end if +end subroutine solve + +subroutine local_charge(self, mol, trans, qloc, dqlocdr, dqlocdL) + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: self + !> Molecular structure data + type(structure_type), intent(in) :: mol + !> Lattice points + real(wp), intent(in) :: trans(:, :) + !> Local atomic partial charges + real(wp), intent(out) :: qloc(:) + !> Optional derivative of local atomic partial charges w.r.t. atomic positions + real(wp), intent(out), optional :: dqlocdr(3, mol%nat, mol%nat) + !> Optional derivative of local atomic partial charges w.r.t. lattice vectors + real(wp), intent(out), optional :: dqlocdL(3, 3, mol%nat) + + qloc = 0.0_wp + if (present(dqlocdr) .and. present(dqlocdL)) then + dqlocdr = 0.0_wp + dqlocdL = 0.0_wp + end if + ! Get the electronegativity weighted CN for local charge + ! Derivatives depend only in this CN + if (allocated(self%ncoord_en)) then + call self%ncoord_en%get_coordination_number(mol, trans, qloc, dqlocdr, dqlocdL) + end if + + ! Distribute the total charge equally + qloc = qloc + mol%charge / real(mol%nat, wp) + +end subroutine local_charge + +end module multicharge_model_type diff --git a/src/multicharge/output.f90 b/src/multicharge/output.f90 index 852407a7..ecb6ce4b 100644 --- a/src/multicharge/output.f90 +++ b/src/multicharge/output.f90 @@ -43,11 +43,11 @@ subroutine write_ascii_model(unit, mol, model) write(unit, '(a, ":")') "Charge model parameter" write(unit, '(54("-"))') - write(unit, '(a4,5x,*(1x,a10))') "Z", "chi/Eh", "kcn/Eh", "eta/Eh", "rad/AA" + write(unit, '(a4,5x,*(1x,a10))') "Z", "chi/Eh", "kcn_chi/Eh", "eta/Eh", "rad/AA" write(unit, '(54("-"))') do isp = 1, mol%nid write(unit, '(i4, 1x, a4, *(1x,f10.4))') & - & mol%num(isp), mol%sym(isp), model%chi(isp), model%kcn(isp), & + & mol%num(isp), mol%sym(isp), model%chi(isp), model%kcnchi(isp), & & model%eta(isp) + sqrt2pi/model%rad(isp), model%rad(isp) * autoaa end do write(unit, '(54("-"),/)') @@ -81,7 +81,7 @@ subroutine write_ascii_properties(unit, mol, model, cn, qvec) isp = mol%id(iat) write(unit, '(i6,1x,i4,1x,a4,*(1x,f10.4))') & & iat, mol%num(isp), mol%sym(isp), cn(iat), qvec(iat), & - & model%chi(isp) - model%kcn(isp) * sqrt(cn(iat)) + & model%chi(isp) - model%kcnchi(isp) * sqrt(cn(iat)) end do write(unit, '(50("-"))') write(unit, '(a7,22x,f10.4)') & diff --git a/src/multicharge/param.f90 b/src/multicharge/param.f90 index 266b4734..046214a6 100644 --- a/src/multicharge/param.f90 +++ b/src/multicharge/param.f90 @@ -14,16 +14,32 @@ ! limitations under the License. module multicharge_param - use mctc_env, only : error_type, wp - use mctc_io, only : structure_type - use mctc_data, only: get_covalent_rad - use multicharge_model, only : mchrg_model_type, new_mchrg_model - use multicharge_param_eeq2019, only : get_eeq_chi, get_eeq_eta, & - & get_eeq_rad, get_eeq_kcn + use mctc_env, only: error_type, wp + use mctc_io, only: structure_type + use mctc_io_convert, only: autoaa + use mctc_data, only: get_covalent_rad, get_pauling_en, get_vdw_rad + use multicharge_model, only: mchrg_model_type, & + & new_eeq_model, eeq_model, new_eeqbc_model, eeqbc_model + use multicharge_param_eeq2019, only: get_eeq_chi, get_eeq_eta, & + & get_eeq_rad, get_eeq_kcnchi + use multicharge_param_eeqbc2025, only: get_eeqbc_chi, get_eeqbc_eta, & + & get_eeqbc_rad, get_eeqbc_kcnchi, get_eeqbc_kqchi, get_eeqbc_kqeta, & + & get_eeqbc_cap, get_eeqbc_cov_radii, get_eeqbc_avg_cn implicit none private - public :: new_eeq2019_model + public :: new_eeq2019_model, new_eeqbc2025_model, mchrg_model + + !> Possible charge models enumerator + type :: TMchargeModelEnum + !> Classic electronegativity equilibration model + integer :: eeq2019 = 1 + !> Bond-capacitor corrected electronegativity equilibration model + integer :: eeqbc2025 = 2 + end type TMchargeModelEnum + + !> Actual charge model enumerator + type(TMchargeModelEnum), parameter :: mchrg_model = TMchargeModelEnum() contains @@ -31,24 +47,81 @@ subroutine new_eeq2019_model(mol, model, error) !> Molecular structure data type(structure_type), intent(in) :: mol !> Electronegativity equilibration model - type(mchrg_model_type), intent(out) :: model + class(mchrg_model_type), allocatable, intent(out) :: model !> Error handling type(error_type), allocatable, intent(out) :: error - real(wp), parameter :: cutoff = 25.0_wp, cn_exp = 7.5_wp, cn_max = 8.0_wp + real(wp), parameter :: cutoff = 25.0_wp + real(wp), parameter :: cn_exp = 7.5_wp + real(wp), parameter :: cn_max = 8.0_wp - real(wp), allocatable :: chi(:), eta(:), kcn(:), rad(:), rcov(:) + real(wp), allocatable :: chi(:), eta(:), kcnchi(:), rad(:), rcov(:) + type(eeq_model), allocatable :: eeq chi = get_eeq_chi(mol%num) eta = get_eeq_eta(mol%num) - kcn = get_eeq_kcn(mol%num) + kcnchi = get_eeq_kcnchi(mol%num) rad = get_eeq_rad(mol%num) rcov = get_covalent_rad(mol%num) - call new_mchrg_model(model, mol, error=error, chi=chi, & - & rad=rad, eta=eta, kcn=kcn, cutoff=cutoff, & + allocate(eeq) + call new_eeq_model(eeq, mol=mol, error=error, chi=chi, & + & rad=rad, eta=eta, kcnchi=kcnchi, cutoff=cutoff, & & cn_exp=cn_exp, rcov=rcov, cn_max=cn_max) + call move_alloc(eeq, model) end subroutine new_eeq2019_model +subroutine new_eeqbc2025_model(mol, model, error) + !> Molecular structure data + type(structure_type), intent(in) :: mol + !> Electronegativity equilibration model + class(mchrg_model_type), allocatable, intent(out) :: model + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(wp), parameter :: kcnrad = 0.14_wp + real(wp), parameter :: kbc = 0.60_wp + real(wp), parameter :: cutoff = 25.0_wp + real(wp), parameter :: cn_exp = 2.0_wp + real(wp), parameter :: norm_exp = 0.75_wp + + real(wp), allocatable :: chi(:), eta(:), rad(:), kcnchi(:), & + & kqchi(:), kqeta(:), cap(:), rcov(:), avg_cn(:), en(:), & + & rvdw(:, :) + type(eeqbc_model), allocatable :: eeqbc + + chi = get_eeqbc_chi(mol%num) + eta = get_eeqbc_eta(mol%num) + rad = get_eeqbc_rad(mol%num) + kcnchi = get_eeqbc_kcnchi(mol%num) + kqchi = get_eeqbc_kqchi(mol%num) + kqeta = get_eeqbc_kqeta(mol%num) + cap = get_eeqbc_cap(mol%num) + rcov = get_eeqbc_cov_radii(mol%num) + avg_cn = get_eeqbc_avg_cn(mol%num) + ! Electronegativities normalized to Fluorine + ! with actinides (Th-Lr) set to average of 1.30 + en = get_pauling_en(mol%num) + en = merge(en, 1.30_wp, mol%num < 90) + en = merge(0.80_wp, en, mol%num == 87) + en = merge(1.00_wp, en, mol%num == 89) + en = merge(1.10_wp, en, mol%num == 90 .or. mol%num == 91 & + &.or. mol%num == 92 .or. mol%num == 95) + en = merge(1.20_wp, en, mol%num == 93 .or. mol%num == 94 & + &.or. mol%num == 97 .or. mol%num == 103) + en = en / 3.98_wp + rvdw = get_vdw_rad(spread(mol%num(mol%id), 2, mol%nat), & + & spread(mol%num(mol%id), 1, mol%nat)) * autoaa + + allocate(eeqbc) + call new_eeqbc_model(eeqbc, mol=mol, error=error, chi=chi, & + & rad=rad, eta=eta, kcnchi=kcnchi, kqchi=kqchi, kqeta=kqeta, & + & kcnrad=kcnrad, cap=cap, avg_cn=avg_cn, rvdw=rvdw, kbc=kbc, & + & cutoff=cutoff, cn_exp=cn_exp, rcov=rcov, en=en, & + & norm_exp=norm_exp) + call move_alloc(eeqbc, model) + +end subroutine new_eeqbc2025_model + end module multicharge_param diff --git a/src/multicharge/param/CMakeLists.txt b/src/multicharge/param/CMakeLists.txt index 320f656c..95e530bc 100644 --- a/src/multicharge/param/CMakeLists.txt +++ b/src/multicharge/param/CMakeLists.txt @@ -18,6 +18,7 @@ set(dir "${CMAKE_CURRENT_SOURCE_DIR}") list( APPEND srcs "${dir}/eeq2019.f90" + "${dir}/eeqbc2025.f90" ) set(srcs "${srcs}" PARENT_SCOPE) diff --git a/src/multicharge/param/eeq2019.f90 b/src/multicharge/param/eeq2019.f90 index aadd81b5..3b95b9ba 100644 --- a/src/multicharge/param/eeq2019.f90 +++ b/src/multicharge/param/eeq2019.f90 @@ -24,7 +24,7 @@ module multicharge_param_eeq2019 implicit none private - public :: get_eeq_chi, get_eeq_eta, get_eeq_rad, get_eeq_kcn + public :: get_eeq_chi, get_eeq_eta, get_eeq_rad, get_eeq_kcnchi !> Element-specific electronegativity for the electronegativity equilibration charges. @@ -40,10 +40,10 @@ module multicharge_param_eeq2019 end interface get_eeq_eta !> Element-specific CN scaling constant for the electronegativity equilibration charges. - interface get_eeq_kcn - module procedure :: get_eeq_kcn_sym - module procedure :: get_eeq_kcn_num - end interface get_eeq_kcn + interface get_eeq_kcnchi + module procedure :: get_eeq_kcnchi_sym + module procedure :: get_eeq_kcnchi_num + end interface get_eeq_kcnchi !> Element-specific charge widths for the electronegativity equilibration charges. interface get_eeq_rad @@ -105,7 +105,7 @@ module multicharge_param_eeq2019 &-0.00059592_wp,-0.00012585_wp,-0.00140896_wp] !> Element-specific CN scaling constant for the electronegativity equilibration charges. - real(wp), parameter :: eeq_kcn(max_elem) = [& + real(wp), parameter :: eeq_kcnchi(max_elem) = [& & 0.04916110_wp, 0.10937243_wp,-0.12349591_wp,-0.02665108_wp,-0.02631658_wp, & & 0.06005196_wp, 0.09279548_wp, 0.11689703_wp, 0.15704746_wp, 0.07987901_wp, & &-0.10002962_wp,-0.07712863_wp,-0.02170561_wp,-0.04964052_wp, 0.14250599_wp, & @@ -155,7 +155,6 @@ module multicharge_param_eeq2019 contains - !> Get electronegativity for species with a given symbol elemental function get_eeq_chi_sym(symbol) result(chi) @@ -221,35 +220,35 @@ end function get_eeq_eta_num !> Get CN scaling for species with a given symbol -elemental function get_eeq_kcn_sym(symbol) result(kcn) +elemental function get_eeq_kcnchi_sym(symbol) result(kcnchi) !> Element symbol character(len=*), intent(in) :: symbol !> CN scaling - real(wp) :: kcn + real(wp) :: kcnchi - kcn = get_eeq_kcn(to_number(symbol)) + kcnchi = get_eeq_kcnchi(to_number(symbol)) -end function get_eeq_kcn_sym +end function get_eeq_kcnchi_sym !> Get CN scaling for species with a given atomic number -elemental function get_eeq_kcn_num(number) result(kcn) +elemental function get_eeq_kcnchi_num(number) result(kcnchi) !> Atomic number integer, intent(in) :: number !> CN scaling - real(wp) :: kcn + real(wp) :: kcnchi - if (number > 0 .and. number <= size(eeq_kcn, dim=1)) then - kcn = eeq_kcn(number) + if (number > 0 .and. number <= size(eeq_kcnchi, dim=1)) then + kcnchi = eeq_kcnchi(number) else - kcn = -1.0_wp + kcnchi = -1.0_wp end if -end function get_eeq_kcn_num +end function get_eeq_kcnchi_num !> Get charge width for species with a given symbol diff --git a/src/multicharge/param/eeqbc2025.f90 b/src/multicharge/param/eeqbc2025.f90 new file mode 100644 index 00000000..8c6a76f6 --- /dev/null +++ b/src/multicharge/param/eeqbc2025.f90 @@ -0,0 +1,621 @@ +! This file is part of multicharge. +! SPDX-Identifier: Apache-2.0 +! +! Licensed under the Apache License, Version 2.0 (the "License"); +! you may not use this file except in compliance with the License. +! You may obtain a copy of the License at +! +! http://www.apache.org/licenses/LICENSE-2.0 +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Bond capacitor electronegativity equilibration charge model published in +!> +!> Thomas Froitzheim, Marcel Müller, Andreas Hansen, and Stefan Grimme, +!> *J. Chem. Phys.*, **2025**, 162, 214109. +!> DOI: [10.1063/5.0268978](https://dx.doi.org/10.1063/5.0268978) +module multicharge_param_eeqbc2025 + use mctc_env, only: wp + use mctc_io_symbols, only: to_number + implicit none + private + + public :: get_eeqbc_chi, get_eeqbc_eta, get_eeqbc_rad, get_eeqbc_kcnchi, & + & get_eeqbc_kqchi, get_eeqbc_kqeta, get_eeqbc_cap, get_eeqbc_cov_radii, & + & get_eeqbc_avg_cn + + !> Element-specific electronegativity for the EEQ_BC charges. + interface get_eeqbc_chi + module procedure :: get_eeqbc_chi_sym + module procedure :: get_eeqbc_chi_num + end interface get_eeqbc_chi + + !> Element-specific chemical hardnesses for the EEQ_BC charges. + interface get_eeqbc_eta + module procedure :: get_eeqbc_eta_sym + module procedure :: get_eeqbc_eta_num + end interface get_eeqbc_eta + + !> Element-specific charge widths for the EEQ_BC charges. + interface get_eeqbc_rad + module procedure :: get_eeqbc_rad_sym + module procedure :: get_eeqbc_rad_num + end interface get_eeqbc_rad + + !> Element-specific CN scaling of the electronegativity for the EEQ_BC charges. + interface get_eeqbc_kcnchi + module procedure :: get_eeqbc_kcnchi_sym + module procedure :: get_eeqbc_kcnchi_num + end interface get_eeqbc_kcnchi + + !> Element-specific local q scaling of the electronegativity for the EEQ_BC charges. + interface get_eeqbc_kqchi + module procedure :: get_eeqbc_kqchi_sym + module procedure :: get_eeqbc_kqchi_num + end interface get_eeqbc_kqchi + + !> Element-specific local q scaling of the chemical hardness for the EEQ_BC charges. + interface get_eeqbc_kqeta + module procedure :: get_eeqbc_kqeta_sym + module procedure :: get_eeqbc_kqeta_num + end interface get_eeqbc_kqeta + + !> Element-specific bond capacitance for the EEQ_BC charges. + interface get_eeqbc_cap + module procedure :: get_eeqbc_cap_sym + module procedure :: get_eeqbc_cap_num + end interface get_eeqbc_cap + + !> Element-specific covalent radii for the CN for the EEQ_BC charges. + interface get_eeqbc_cov_radii + module procedure :: get_eeqbc_cov_radii_sym + module procedure :: get_eeqbc_cov_radii_num + end interface get_eeqbc_cov_radii + + !> Element-specific average CN for the EEQ_BC charges. + interface get_eeqbc_avg_cn + module procedure :: get_eeqbc_avg_cn_sym + module procedure :: get_eeqbc_avg_cn_num + end interface get_eeqbc_avg_cn + + !> Maximum atomic number allowed in EEQ_BC calculations + integer, parameter :: max_elem = 103 + + !> Element-specific electronegativity for the EEQ_BC charges. + real(wp), parameter :: eeqbc_chi(max_elem) = [& + & 1.7500687479_wp, 0.7992983109_wp, 0.8817302909_wp, 1.2122559922_wp, & !1-4 + & 1.4042606312_wp, 1.7373300176_wp, 1.9224220861_wp, 2.0295674708_wp, & !5-8 + & 2.0914017724_wp, 0.2783743672_wp, 0.7909141712_wp, 0.9333749946_wp, & !9-12 + & 1.1280735350_wp, 1.3504642320_wp, 1.7084529806_wp, 1.9657999323_wp, & !13-16 + & 1.8796814465_wp, 0.8120477849_wp, 0.6229777212_wp, 0.8955669337_wp, & !17-20 + & 0.8887941055_wp, 0.9249293933_wp, 0.8910306356_wp, 0.8730274586_wp, & !21-24 + & 1.0692963783_wp, 1.1430792497_wp, 1.2352658732_wp, 1.2511161359_wp, & !25-28 + & 1.0995052580_wp, 1.0059572004_wp, 1.0390725738_wp, 1.2885924052_wp, & !29-32 + & 1.4638654613_wp, 1.7797597799_wp, 1.6400765990_wp, 0.8859889377_wp, & !33-36 + & 0.5142094052_wp, 0.8785352464_wp, 0.9716967887_wp, 0.8109573582_wp, & !37-40 + & 0.9361297862_wp, 0.9872048394_wp, 1.1290914832_wp, 1.0416755409_wp, & !41-44 + & 1.1579060755_wp, 1.1371382461_wp, 1.1490154759_wp, 1.0811257447_wp, & !45-48 + & 1.0201038561_wp, 1.2317318949_wp, 1.2546053590_wp, 1.6136334955_wp, & !49-52 + & 1.5949826440_wp, 0.8548714270_wp, 0.5116591821_wp, 0.8221154800_wp, & !53-56 + & 0.8992637384_wp, 0.7835477700_wp, 0.6865502434_wp, 0.6063027416_wp, & !57-60 + & 0.5428052646_wp, 0.4960578124_wp, 0.4660603851_wp, 0.4528129826_wp, & !61-64 + & 0.4563156049_wp, 0.4765682521_wp, 0.5135709241_wp, 0.5673236209_wp, & !65-68 + & 0.6378263425_wp, 0.7250790890_wp, 0.8290818603_wp, 0.8697550816_wp, & !69-72 + & 1.0442533196_wp, 1.1429836348_wp, 1.1622493128_wp, 1.2650483683_wp, & !73-76 + & 1.2650500943_wp, 1.3607929134_wp, 1.3186071563_wp, 1.0545750683_wp, & !77-80 + & 0.9074468503_wp, 1.0892548243_wp, 1.1983441731_wp, 1.3955974910_wp, & !81-84 + & 1.6266506350_wp, 0.9802627692_wp, 0.4952498716_wp, 0.7903508991_wp, & !85-88 + & 0.7482689572_wp, 0.8666000614_wp, 0.8153381406_wp, 0.7700731721_wp, & !89-92 + & 0.7308051560_wp, 0.6975340922_wp, 0.6702599807_wp, 0.6489828216_wp, & !93-96 + & 0.6337026148_wp, 0.6244193604_wp, 0.6211330583_wp, 0.6238437086_wp, & !97-100 + & 0.6325513112_wp, 0.6472558662_wp, 0.6679573735_wp] !101-103 + + !> Element-specific chemical hardnesses for the EEQ_BC charges. + real(wp), parameter :: eeqbc_eta(max_elem) = [& + & 0.3572813340_wp, 14.1713349136_wp, -0.0335574715_wp, -2.2617753890_wp, & !1-4 + & -2.9993990603_wp, -2.8456422314_wp, -2.2316836385_wp, -0.9048085573_wp, & !5-8 + & -3.3402942035_wp, 11.6677100883_wp, 0.0461110187_wp, -0.1623149426_wp, & !9-12 + & -0.1976009198_wp, -3.6156182254_wp, -4.8040123811_wp, -5.8989254120_wp, & !13-16 + & -1.7918672558_wp, 3.2077831067_wp, 0.4598658365_wp, -0.3196730368_wp, & !17-20 + & -0.0066012997_wp, -0.0650415781_wp, 0.0116105065_wp, -0.2020240365_wp, & !21-24 + & -0.0451985500_wp, -0.8983846024_wp, -0.5087624261_wp, -0.9360254729_wp, & !25-28 + & -0.3137611925_wp, 0.3714666864_wp, -0.5637510788_wp, -1.5811888792_wp, & !29-32 + & -2.5680164043_wp, -3.3791525742_wp, -0.9039263250_wp, 2.6191171553_wp, & !33-36 + & 0.4517188832_wp, -0.4737572247_wp, -0.3291918172_wp, -0.0641706161_wp, & !37-40 + & -0.4365721167_wp, -0.1388382729_wp, 0.0445179428_wp, -0.3077776724_wp, & !41-44 + & -0.1421769591_wp, -0.3718332953_wp, -0.9003899901_wp, -0.5034953355_wp, & !45-48 + & -0.3154724874_wp, -1.2061278491_wp, -1.0351395610_wp, -2.4727516433_wp, & !49-52 + & -0.5377076044_wp, 2.1647776210_wp, 0.3592585022_wp, -0.6373016543_wp, & !53-56 + & -0.1481956999_wp, -0.4595916155_wp, -0.6048435529_wp, -0.7208619618_wp, & !57-60 + & -0.8076468424_wp, -0.8651981945_wp, -0.8935160183_wp, -0.8926003136_wp, & !61-64 + & -0.8624510805_wp, -0.8030683191_wp, -0.7144520292_wp, -0.5966022109_wp, & !65-68 + & -0.4495188642_wp, -0.2732019891_wp, -0.0676515856_wp, -0.1339322663_wp, & !69-72 + & -0.7103642117_wp, -0.1700796179_wp, -0.1362891699_wp, -1.0705189016_wp, & !73-76 + & -0.8229572159_wp, -1.3207540081_wp, -2.0554362750_wp, -0.2654477885_wp, & !77-80 + & -0.0736143849_wp, -1.1221956034_wp, -0.1821999108_wp, -0.7727065022_wp, & !81-84 + & -0.4699768943_wp, 0.6377347433_wp, 0.4140010159_wp, -0.2353223377_wp, & !85-88 + & -0.1309097826_wp, 0.1881855179_wp, 0.2007222471_wp, 0.1912792246_wp, & !89-92 + & 0.1598564505_wp, 0.1064539248_wp, 0.0310716475_wp, -0.0662903814_wp, & !93-96 + & -0.1856321619_wp, -0.3269536941_wp, -0.4902549779_wp, -0.6755360133_wp, & !97-100 + & -0.8827968003_wp, -1.1120373389_wp, -1.3632576292_wp] !101-103 + + !> Element-specific charge widths for the EEQ_BC charges. + real(wp), parameter :: eeqbc_rad(max_elem) = [& + & 0.4537866920_wp, 0.8971879958_wp, 0.3987756594_wp, 0.2435934990_wp, & !1-4 + & 0.2119711703_wp, 0.2064066867_wp, 0.2398313485_wp, 0.3482853216_wp, & !5-8 + & 0.1479057386_wp, 1.4433940527_wp, 0.6317031456_wp, 0.7152255265_wp, & !9-12 + & 0.6920759433_wp, 0.1952261525_wp, 0.1478738486_wp, 0.1173410276_wp, & !13-16 + & 0.2188836429_wp, 0.7265491450_wp, 1.0062576628_wp, 0.6529550574_wp, & !17-20 + & 1.0787300626_wp, 1.0194369772_wp, 0.7673907688_wp, 0.8234907812_wp, & !21-24 + & 0.7956000862_wp, 0.4194926962_wp, 0.6577871621_wp, 0.4350022430_wp, & !25-28 + & 0.5436327263_wp, 1.2387687941_wp, 0.5125789654_wp, 0.3834386963_wp, & !29-32 + & 0.2781070074_wp, 0.2053677667_wp, 0.3191301456_wp, 3.4957602962_wp, & !33-36 + & 0.8847073217_wp, 0.6739335178_wp, 0.8092111775_wp, 0.8229663676_wp, & !37-40 + & 0.7341667740_wp, 0.8802988629_wp, 1.1234870897_wp, 0.5654595735_wp, & !41-44 + & 0.7749739189_wp, 0.6091511140_wp, 0.4788100227_wp, 0.6104947355_wp, & !45-48 + & 0.6518973596_wp, 0.4348284778_wp, 0.4885595700_wp, 0.2660054523_wp, & !49-52 + & 0.4274914591_wp, 2.3114324559_wp, 0.9734795056_wp, 0.6329900422_wp, & !53-56 + & 1.0109847900_wp, 0.6287499845_wp, 0.5401093486_wp, 0.4679527826_wp, & !57-60 + & 0.4122802864_wp, 0.3730918601_wp, 0.3503875036_wp, 0.3441672169_wp, & !61-64 + & 0.3544310001_wp, 0.3811788531_wp, 0.4244107759_wp, 0.4841267686_wp, & !65-68 + & 0.5603268311_wp, 0.6530109634_wp, 0.7621791656_wp, 1.0577606985_wp, & !69-72 + & 0.6844888492_wp, 0.9102124518_wp, 0.8550543040_wp, 0.4138761210_wp, & !73-76 + & 0.5593056202_wp, 0.3751752813_wp, 0.2949155601_wp, 0.6769971683_wp, & !77-80 + & 0.7124606732_wp, 0.4519163133_wp, 1.0405678353_wp, 0.6688421527_wp, & !81-84 + & 0.4838599292_wp, 0.9792188430_wp, 0.8793273061_wp, 0.8333325045_wp, & !85-88 + & 0.8202868436_wp, 1.7807640816_wp, 1.5641357264_wp, 1.3644976007_wp, & !89-92 + & 1.1818497047_wp, 1.0161920382_wp, 0.8675246014_wp, 0.7358473941_wp, & !93-96 + & 0.6211604164_wp, 0.5234636683_wp, 0.4427571498_wp, 0.3790408609_wp, & !97-100 + & 0.3323148016_wp, 0.3025789719_wp, 0.2898333718_wp] !101-103 + + !> Element-specific CN scaling of the electronegativity for the EEQ_BC charges. + real(wp), parameter :: eeqbc_kcnchi(max_elem) = [& + & 1.3415783494_wp, 2.4226307746_wp, 0.0910702713_wp, -0.2802662922_wp, & !1-4 + & -0.0464303067_wp, 0.3049790613_wp, 0.5014914830_wp, 0.7131712513_wp, & !5-8 + & 1.5978006993_wp, 4.6934800245_wp, -0.2311835622_wp, -0.5722047540_wp, & !9-12 + & -0.1872404228_wp, 0.1355861183_wp, 0.5037598487_wp, 0.8257488249_wp, & !13-16 + & 1.5828922925_wp, 5.6324196990_wp, -1.3574661808_wp, -0.7114730764_wp, & !17-20 + & -0.8412840531_wp, -0.8100781799_wp, -0.7321477749_wp, -0.5690936866_wp, & !21-24 + & -0.7978421025_wp, -0.7081664947_wp, -0.5311094926_wp, -0.5561735098_wp, & !25-28 + & 0.1043470768_wp, -0.2459258932_wp, -0.2244771250_wp, 0.0378446029_wp, & !29-32 + & 0.2939641775_wp, 0.7336233202_wp, 1.1960377617_wp, 1.5974038323_wp, & !33-36 + & -0.5630850954_wp, -1.1059510466_wp, -0.7830773028_wp, -0.9114834757_wp, & !37-40 + & -0.4093603622_wp, -0.2717170095_wp, -0.4691579275_wp, -0.2257381361_wp, & !41-44 + & -0.1375984198_wp, 0.3330053570_wp, 0.0221109296_wp, -0.0920402467_wp, & !45-48 + & -0.3096506887_wp, 0.0088013637_wp, 0.0730363100_wp, 0.4356094483_wp, & !49-52 + & 1.0199146044_wp, 1.0092039203_wp, -0.7528024837_wp, -1.1365506475_wp, & !53-56 + & -0.9661197708_wp, -1.1514088354_wp, -1.1092964223_wp, -1.0718762355_wp, & !57-60 + & -1.0391482749_wp, -1.0111125406_wp, -0.9877690325_wp, -0.9691177507_wp, & !61-64 + & -0.9551586951_wp, -0.9458918658_wp, -0.9413172627_wp, -0.9414348859_wp, & !65-68 + & -0.9462447354_wp, -0.9557468111_wp, -0.9699411130_wp, -0.9467711075_wp, & !69-72 + & -0.5854657957_wp, -0.1956906192_wp, -0.3841246137_wp, -0.2184058724_wp, & !73-76 + & -0.2071244723_wp, 0.1769757167_wp, 0.5363613694_wp, 0.0342662426_wp, & !77-80 + & -0.5074824777_wp, -0.0048092213_wp, -0.0546120433_wp, 0.0560290491_wp, & !81-84 + & 0.8822097689_wp, 0.9546406691_wp, -1.8612818673_wp, -1.2559850201_wp, & !85-88 + & -0.8232940275_wp, -0.7432092987_wp, -0.9259469469_wp, -1.0588247895_wp, & !89-92 + & -1.1418428264_wp, -1.1750010577_wp, -1.1582994833_wp, -1.0917381033_wp, & !93-96 + & -0.9753169176_wp, -0.8090359263_wp, -0.5928951293_wp, -0.3268945267_wp, & !97-100 + & -0.0110341184_wp, 0.3546860955_wp, 0.7702661151_wp] !101-103 + + !> Element-specific local q scaling of the electronegativity for the EEQ_BC charges. + real(wp), parameter :: eeqbc_kqchi(max_elem) = [& + & 0.7122604774_wp, -1.7351284097_wp, 3.0089829052_wp, 2.1166762050_wp, & !1-4 + & 1.5179774898_wp, 1.2180269092_wp, 1.0873609014_wp, 0.8994075937_wp, & !5-8 + & 0.1658248786_wp, -2.5747028940_wp, 3.1762170214_wp, 2.3987338612_wp, & !9-12 + & 2.2469063726_wp, 1.5639940746_wp, 1.2412557993_wp, 1.6283237163_wp, & !13-16 + & 1.5628790844_wp, -0.9249536928_wp, 3.0733040004_wp, 2.7596745507_wp, & !17-20 + & 2.9366708989_wp, 2.7004746183_wp, 2.2295030415_wp, 2.0304690076_wp, & !21-24 + & 1.9683561829_wp, 2.2302711526_wp, 1.8504904266_wp, 2.0575510119_wp, & !25-28 + & 2.2756603413_wp, 2.2094576537_wp, 2.1544064368_wp, 1.9327504630_wp, & !29-32 + & 1.4451438826_wp, 1.4813741556_wp, 2.0308095325_wp, 0.4032186085_wp, & !33-36 + & 3.6036894994_wp, 2.6513413398_wp, 2.6634586616_wp, 2.3940154835_wp, & !37-40 + & 2.3527262731_wp, 2.0735381213_wp, 1.7234564437_wp, 2.2302635382_wp, & !41-44 + & 2.1871313764_wp, 1.8061408427_wp, 1.9051691947_wp, 2.0424482278_wp, & !45-48 + & 2.8036578365_wp, 2.0783981020_wp, 2.0481231960_wp, 1.8544101088_wp, & !49-52 + & 2.1888387015_wp, 0.5779869189_wp, 3.2064625646_wp, 2.7406551784_wp, & !53-56 + & 2.5529621630_wp, 2.5391757608_wp, 2.4348800350_wp, 2.3484586230_wp, & !57-60 + & 2.2799115250_wp, 2.2292387408_wp, 2.1964402705_wp, 2.1815161141_wp, & !61-64 + & 2.1844662716_wp, 2.2052907430_wp, 2.2439895282_wp, 2.3005626274_wp, & !65-68 + & 2.3750100404_wp, 2.4673317674_wp, 2.5775278082_wp, 2.6463737671_wp, & !69-72 + & 2.3987259080_wp, 2.0862161326_wp, 1.8045334538_wp, 2.0382923920_wp, & !73-76 + & 1.6579982531_wp, 1.8353080915_wp, 1.8450710788_wp, 1.5696036105_wp, & !77-80 + & 2.8136219641_wp, 2.3784572290_wp, 1.9914691678_wp, 1.8625351100_wp, & !81-84 + & 2.1579257719_wp, 0.6206683275_wp, 3.5103871382_wp, 2.7327597379_wp, & !85-88 + & 2.7369312006_wp, 2.6004448612_wp, 2.7011486104_wp, 2.7879694953_wp, & !89-92 + & 2.8609075157_wp, 2.9199626718_wp, 2.9651349636_wp, 2.9964243909_wp, & !93-96 + & 3.0138309539_wp, 3.0173546524_wp, 3.0069954867_wp, 2.9827534565_wp, & !97-100 + & 2.9446285619_wp, 2.8926208030_wp, 2.8267301797_wp] !101-103 + + !> Element-specific local q scaling of the chemical hardness for the EEQ_BC charges. + real(wp), parameter :: eeqbc_kqeta(max_elem) = [& + & 1.8222099473_wp, -0.2575679643_wp, 0.4393826724_wp, 1.1102162003_wp, & !1-4 + & 1.2310070946_wp, 0.9818102022_wp, 0.1502230497_wp, 0.4134119032_wp, & !5-8 + & 2.5030512016_wp, -0.4998596384_wp, 2.1023399046_wp, 1.1266337899_wp, & !9-12 + & 1.3785272689_wp, 0.9471745876_wp, 1.6601128471_wp, -0.0156796346_wp, & !13-16 + & 0.6525286877_wp, -2.8148211211_wp, 1.8730352397_wp, 0.4148795713_wp, & !17-20 + & 1.9811917137_wp, 1.3666346630_wp, 0.4773540249_wp, 0.6660383739_wp, & !21-24 + & 0.4949831426_wp, 0.9260098769_wp, 1.4071496248_wp, 0.7430722161_wp, & !25-28 + & 1.4792830405_wp, 1.4211880229_wp, 0.6613271421_wp, 1.3109487181_wp, & !29-32 + & 0.9539967321_wp, 0.0441858334_wp, 0.8506553360_wp, -0.7778128954_wp, & !33-36 + & 2.4456255294_wp, 0.6279760783_wp, 0.8504097502_wp, 0.1275277215_wp, & !37-40 + & 1.0244946467_wp, 0.3991961865_wp, 0.3007399180_wp, 0.8892405348_wp, & !41-44 + & 1.0358999274_wp, 0.5910349581_wp, 1.3306044793_wp, 1.0116510919_wp, & !45-48 + & 1.2017335753_wp, 1.0749481071_wp, 1.5278450966_wp, 0.3830852785_wp, & !49-52 + & 0.8039617911_wp, -1.6689377641_wp, 1.3153512507_wp, 0.6850807472_wp, & !53-56 + & 0.4068053082_wp, 0.2805275842_wp, 0.2612355874_wp, 0.2457254002_wp, & !57-60 + & 0.2339970224_wp, 0.2260504541_wp, 0.2218856952_wp, 0.2215027459_wp, & !61-64 + & 0.2249016061_wp, 0.2320822757_wp, 0.2430447548_wp, 0.2577890434_wp, & !65-68 + & 0.2763151415_wp, 0.2986230491_wp, 0.3247127662_wp, 0.9329386915_wp, & !69-72 + & 1.1124975975_wp, 0.3105056463_wp, 0.2119489274_wp, 0.3490965682_wp, & !73-76 + & 0.9303004996_wp, 0.6578893166_wp, 0.7625190003_wp, 0.6067448860_wp, & !77-80 + & 1.1098111282_wp, 0.9571986961_wp, 1.4674965889_wp, 0.7713149335_wp, & !81-84 + & 0.5513455799_wp, -0.7227615433_wp, 1.2895674764_wp, 0.5960416182_wp, & !85-88 + & 0.1671277145_wp, 0.1575313114_wp, 0.2863965715_wp, 0.4002506248_wp, & !89-92 + & 0.4990934714_wp, 0.5829251111_wp, 0.6517455441_wp, 0.7055547703_wp, & !93-96 + & 0.7443527897_wp, 0.7681396024_wp, 0.7769152082_wp, 0.7706796073_wp, & !97-100 + & 0.7494327996_wp, 0.7131747852_wp, 0.6619055639_wp] !101-103 + + !> Element-specific bond capacitance for the EEQ_BC charges. + real(wp), parameter :: eeqbc_cap(max_elem) = [& + & 3.4358731613_wp, 0.2563012350_wp, 1.7336935111_wp, 1.4252599447_wp, & !1-4 + & 1.9821377790_wp, 7.9575330990_wp, 5.2650283958_wp, 5.3394223720_wp, & !5-8 + & 4.7702507597_wp, 0.5095753028_wp, 5.7961811482_wp, 2.8738819069_wp, & !9-12 + & 1.5730116016_wp, 0.7813507196_wp, 1.0337776163_wp, 1.4123845734_wp, & !13-16 + & 3.0340296817_wp, 0.5326667425_wp, 6.4794438076_wp, 4.1572236543_wp, & !17-20 + & 2.6197028418_wp, 1.9926557922_wp, 1.4258893003_wp, 3.4184301443_wp, & !21-24 + & 3.1337436912_wp, 4.5345735628_wp, 6.3426635435_wp, 4.8622181062_wp, & !25-28 + & 3.9658581319_wp, 2.4205042838_wp, 2.0153453160_wp, 1.3655709456_wp, & !29-32 + & 1.0879161652_wp, 0.8125045161_wp, 3.4331186365_wp, 1.1410555369_wp, & !33-36 + & 5.3302096260_wp, 8.9866820455_wp, 8.0879982654_wp, 1.3505819625_wp, & !37-40 + & 1.9761405818_wp, 4.8306789723_wp, 2.6167089975_wp, 4.9413659163_wp, & !41-44 + & 5.5889636514_wp, 3.7289038580_wp, 2.2978010245_wp, 2.9915912946_wp, & !45-48 + & 3.2084006372_wp, 2.4592286766_wp, 1.0482227697_wp, 1.4124670516_wp, & !49-52 + & 2.0699368746_wp, 2.3426022325_wp, 4.9766316345_wp, 4.7445931148_wp, & !53-56 + & 7.6556126582_wp, 2.2792827162_wp, 2.2265798615_wp, 2.2270872929_wp, & !57-60 + & 2.2808050104_wp, 2.3877330140_wp, 2.5478713036_wp, 2.7612198793_wp, & !61-64 + & 3.0277787411_wp, 3.3475478889_wp, 3.7205273228_wp, 4.1467170428_wp, & !65-68 + & 4.6261170489_wp, 5.1587273410_wp, 5.7445479192_wp, 1.9450532464_wp, & !69-72 + & 1.2082681633_wp, 5.4761913827_wp, 2.8688258387_wp, 3.4269533511_wp, & !73-76 + & 1.2827929585_wp, 4.2446334525_wp, 8.5466705292_wp, 2.7030553995_wp, & !77-80 + & 1.7482905639_wp, 4.5652515937_wp, 2.0750200204_wp, 2.1042278455_wp, & !81-84 + & 2.9249818593_wp, 1.1606670882_wp, 5.1339954989_wp, 5.4015367551_wp, & !85-88 + & 1.5278253705_wp, 0.7201439348_wp, 0.8778110607_wp, 1.0152634518_wp, & !89-92 + & 1.1325011080_wp, 1.2295240293_wp, 1.3063322158_wp, 1.3629256675_wp, & !93-96 + & 1.3993043843_wp, 1.4154683662_wp, 1.4114176133_wp, 1.3871521256_wp, & !97-100 + & 1.3426719030_wp, 1.2779769455_wp, 1.1930672532_wp] !101-103 + + !> Element-specific covalent radii for the CN for the EEQ_BC charges. + real(wp), parameter :: eeqbc_cov_radii(max_elem) = 0.5_wp*[& + & 1.1980006149_wp, 2.2610217725_wp, 2.3787175190_wp, 2.4632164676_wp, & !1-4 + & 2.4613895807_wp, 2.6763007964_wp, 2.7655085211_wp, 2.6466398902_wp, & !5-8 + & 2.0647114131_wp, 2.2964278893_wp, 3.0473595746_wp, 3.3597126173_wp, & !9-12 + & 2.9413551863_wp, 3.3593150082_wp, 3.7124038217_wp, 3.7950496861_wp, & !13-16 + & 3.6218412465_wp, 2.3368507550_wp, 3.2678005729_wp, 2.6934639460_wp, & !17-20 + & 3.0942813806_wp, 3.1994190934_wp, 3.1865351525_wp, 3.0245247746_wp, & !21-24 + & 2.9516405455_wp, 2.7967091405_wp, 2.8624752847_wp, 2.9325871383_wp, & !25-28 + & 2.8750457420_wp, 3.2880254556_wp, 3.4129389757_wp, 3.5547538315_wp, & !29-32 + & 3.8824044195_wp, 4.1349986852_wp, 3.9489265588_wp, 3.6264077864_wp, & !33-36 + & 3.8936921777_wp, 3.5213571939_wp, 3.2417303558_wp, 3.5464510864_wp, & !37-40 + & 3.6460575764_wp, 3.4102131328_wp, 3.4469009914_wp, 3.3043609242_wp, & !41-44 + & 3.3574938698_wp, 3.4236287446_wp, 3.6341385880_wp, 3.8313216784_wp, & !45-48 + & 3.8271624151_wp, 4.1254263093_wp, 3.9895425056_wp, 4.5341418141_wp, & !49-52 + & 4.6758001321_wp, 4.3188262237_wp, 2.8314213049_wp, 4.8914010315_wp, & !53-56 + & 3.6004533315_wp, 2.8758092017_wp, 2.9967129499_wp, 3.1042023757_wp, & !57-60 + & 3.1982774792_wp, 3.2789382603_wp, 3.3461847191_wp, 3.4000168555_wp, & !61-64 + & 3.4404346695_wp, 3.4674381612_wp, 3.4810273305_wp, 3.4812021775_wp, & !65-68 + & 3.4679627021_wp, 3.4413089043_wp, 3.4012407842_wp, 3.5004027339_wp, & !69-72 + & 3.6576246465_wp, 3.2722427492_wp, 3.4847840299_wp, 3.3869572767_wp, & !73-76 + & 3.4600493844_wp, 3.5857257632_wp, 3.5138481825_wp, 4.0752898970_wp, & !77-80 + & 4.2705802544_wp, 4.3281934906_wp, 4.0616856521_wp, 4.3269140322_wp, & !81-84 + & 4.7950102995_wp, 4.0621301306_wp, 4.7045604278_wp, 4.3693314868_wp, & !85-88 + & 3.2349557337_wp, 2.0334056417_wp, 2.5551666814_wp, 3.0015806363_wp, & !89-92 + & 3.3726475065_wp, 3.6683672921_wp, 3.8887399930_wp, 4.0337656091_wp, & !93-96 + & 4.1034441406_wp, 4.0977755873_wp, 4.0167599494_wp, 3.8603972267_wp, & !97-100 + & 3.6286874194_wp, 3.3216305273_wp, 2.9392265506_wp] !101-103 + + !> Element-specific averaged coordination number over the fitset for the EEQ_BC charges. + real(wp), parameter :: eeqbc_avg_cn(max_elem) = [& + & 0.3921100000_wp, 0.0810600000_wp, 0.9910100000_wp, 0.7499500000_wp, & !1-4 + & 1.1543700000_wp, 1.6691400000_wp, 1.4250300000_wp, 0.8718100000_wp, & !5-8 + & 0.6334000000_wp, 0.0876700000_wp, 0.8740600000_wp, 0.8754800000_wp, & !9-12 + & 1.2147200000_wp, 1.1335000000_wp, 1.6890600000_wp, 1.0221600000_wp, & !13-16 + & 0.5386400000_wp, 0.0827800000_wp, 1.4096300000_wp, 1.1954700000_wp, & !17-20 + & 1.5142100000_wp, 1.7892000000_wp, 2.0646100000_wp, 1.6905600000_wp, & !21-24 + & 1.6563700000_wp, 1.5128400000_wp, 1.3179000000_wp, 0.9749800000_wp, & !25-28 + & 0.5334600000_wp, 0.6585000000_wp, 0.9696500000_wp, 1.0083100000_wp, & !29-32 + & 1.0871000000_wp, 0.8222200000_wp, 0.5449300000_wp, 0.1647100000_wp, & !33-36 + & 1.2490800000_wp, 1.2198700000_wp, 1.5657400000_wp, 1.8697600000_wp, & !37-40 + & 1.8947900000_wp, 1.7085000000_wp, 1.5521300000_wp, 1.4903300000_wp, & !41-44 + & 1.3177400000_wp, 0.6991700000_wp, 0.5528200000_wp, 0.6642200000_wp, & !45-48 + & 0.9069800000_wp, 1.0976200000_wp, 1.2183000000_wp, 0.7321900000_wp, & !49-52 + & 0.5498700000_wp, 0.2467100000_wp, 1.5680600000_wp, 1.1677300000_wp, & !53-56 + & 1.6642500000_wp, 1.6032600000_wp, 1.6032600000_wp, 1.6032600000_wp, & !57-60 + & 1.6032600000_wp, 1.6032600000_wp, 1.6032600000_wp, 1.6032600000_wp, & !61-64 + & 1.6032600000_wp, 1.6032600000_wp, 1.6032600000_wp, 1.6032600000_wp, & !65-68 + & 1.6032600000_wp, 1.6032600000_wp, 1.6032600000_wp, 1.8191000000_wp, & !69-72 + & 1.8175100000_wp, 1.6802300000_wp, 1.5224100000_wp, 1.4602600000_wp, & !73-76 + & 1.1110400000_wp, 0.9102600000_wp, 0.5218000000_wp, 1.4895900000_wp, & !77-80 + & 0.8441800000_wp, 0.9426900000_wp, 1.5171900000_wp, 0.7287100000_wp, & !81-84 + & 0.5137000000_wp, 0.2678200000_wp, 1.2122500000_wp, 1.5797100000_wp, & !85-88 + & 1.7549800000_wp, 1.7549800000_wp, 1.7549800000_wp, 1.7549800000_wp, & !89-92 + & 1.7549800000_wp, 1.7549800000_wp, 1.7549800000_wp, 1.7549800000_wp, & !93-96 + & 1.7549800000_wp, 1.7549800000_wp, 1.7549800000_wp, 1.7549800000_wp, & !97-100 + & 1.7549800000_wp, 1.7549800000_wp, 1.7549800000_wp] !101-103 + +contains + +!> Get electronegativity for species with a given symbol +elemental function get_eeqbc_chi_sym(symbol) result(chi) + + !> Element symbol + character(len=*), intent(in) :: symbol + + !> electronegativity + real(wp) :: chi + + chi = get_eeqbc_chi(to_number(symbol)) + +end function get_eeqbc_chi_sym + +!> Get electronegativity for species with a given atomic number +elemental function get_eeqbc_chi_num(number) result(chi) + + !> Atomic number + integer, intent(in) :: number + + !> electronegativity + real(wp) :: chi + + if (number > 0 .and. number <= size(eeqbc_chi, dim=1)) then + chi = eeqbc_chi(number) + else + chi = -1.0_wp + end if + +end function get_eeqbc_chi_num + +!> Get hardness for species with a given symbol +elemental function get_eeqbc_eta_sym(symbol) result(eta) + + !> Element symbol + character(len=*), intent(in) :: symbol + + !> hardness + real(wp) :: eta + + eta = get_eeqbc_eta(to_number(symbol)) + +end function get_eeqbc_eta_sym + +!> Get hardness for species with a given atomic number +elemental function get_eeqbc_eta_num(number) result(eta) + + !> Atomic number + integer, intent(in) :: number + + !> hardness + real(wp) :: eta + + if (number > 0 .and. number <= size(eeqbc_eta, dim=1)) then + eta = eeqbc_eta(number) + else + eta = -1.0_wp + end if + +end function get_eeqbc_eta_num + +!> Get charge width for species with a given symbol +elemental function get_eeqbc_rad_sym(symbol) result(rad) + + !> Element symbol + character(len=*), intent(in) :: symbol + + !> charge width + real(wp) :: rad + + rad = get_eeqbc_rad(to_number(symbol)) + +end function get_eeqbc_rad_sym + +!> Get charge width for species with a given atomic number +elemental function get_eeqbc_rad_num(number) result(rad) + + !> Atomic number + integer, intent(in) :: number + + !> charge width + real(wp) :: rad + + if (number > 0 .and. number <= size(eeqbc_rad, dim=1)) then + rad = eeqbc_rad(number) + else + rad = -1.0_wp + end if + +end function get_eeqbc_rad_num + +!> Get CN scaling of the electronegativity for species with a given symbol +elemental function get_eeqbc_kcnchi_sym(symbol) result(kcnchi) + + !> Element symbol + character(len=*), intent(in) :: symbol + + !> CN scaling of EN + real(wp) :: kcnchi + + kcnchi = get_eeqbc_kcnchi(to_number(symbol)) + +end function get_eeqbc_kcnchi_sym + +!> Get CN scaling of the electronegativity for species with a given atomic number +elemental function get_eeqbc_kcnchi_num(number) result(kcnchi) + + !> Atomic number + integer, intent(in) :: number + + !> CN scaling of EN + real(wp) :: kcnchi + + if (number > 0 .and. number <= size(eeqbc_kcnchi, dim=1)) then + kcnchi = eeqbc_kcnchi(number) + else + kcnchi = -1.0_wp + end if + +end function get_eeqbc_kcnchi_num + +!> Get local q scaling of the electronegativity for species with a given symbol +elemental function get_eeqbc_kqchi_sym(symbol) result(kqchi) + + !> Element symbol + character(len=*), intent(in) :: symbol + + !> local q scaling of EN + real(wp) :: kqchi + + kqchi = get_eeqbc_kqchi(to_number(symbol)) + +end function get_eeqbc_kqchi_sym + +!> Get local q scaling of the electronegativity for species with a given atomic number +elemental function get_eeqbc_kqchi_num(number) result(kqchi) + + !> Atomic number + integer, intent(in) :: number + + !> local q scaling of EN + real(wp) :: kqchi + + if (number > 0 .and. number <= size(eeqbc_kqchi, dim=1)) then + kqchi = eeqbc_kqchi(number) + else + kqchi = -1.0_wp + end if + +end function get_eeqbc_kqchi_num + +!> Get local q scaling of the chemical hardness for species with a given symbol +elemental function get_eeqbc_kqeta_sym(symbol) result(kqeta) + + !> Element symbol + character(len=*), intent(in) :: symbol + + !> local q scaling of hardness + real(wp) :: kqeta + + kqeta = get_eeqbc_kqeta(to_number(symbol)) + +end function get_eeqbc_kqeta_sym + +!> Get local q scaling of the chemical hardness for species with a given atomic number +elemental function get_eeqbc_kqeta_num(number) result(kqeta) + + !> Atomic number + integer, intent(in) :: number + + !> local q scaling of hardness + real(wp) :: kqeta + + if (number > 0 .and. number <= size(eeqbc_kqeta, dim=1)) then + kqeta = eeqbc_kqeta(number) + else + kqeta = -1.0_wp + end if + +end function get_eeqbc_kqeta_num + +!> Get bond capacitance for species with a given symbol +elemental function get_eeqbc_cap_sym(symbol) result(cap) + + !> Element symbol + character(len=*), intent(in) :: symbol + + !> bond capacitance + real(wp) :: cap + + cap = get_eeqbc_cap(to_number(symbol)) + +end function get_eeqbc_cap_sym + +!> Get bond capacitance for species with a given atomic number +elemental function get_eeqbc_cap_num(number) result(cap) + + !> Atomic number + integer, intent(in) :: number + + !> bond capacitance + real(wp) :: cap + + if (number > 0 .and. number <= size(eeqbc_cap, dim=1)) then + cap = eeqbc_cap(number) + else + cap = -1.0_wp + end if + +end function get_eeqbc_cap_num + +!> Get covalent radius for species with a given symbol +elemental function get_eeqbc_cov_radii_sym(symbol) result(rcov) + + !> Element symbol + character(len=*), intent(in) :: symbol + + !> covalent radius + real(wp) :: rcov + + rcov = get_eeqbc_cov_radii(to_number(symbol)) + +end function get_eeqbc_cov_radii_sym + +!> Get covalent radius for species with a given atomic number +elemental function get_eeqbc_cov_radii_num(number) result(rcov) + + !> Atomic number + integer, intent(in) :: number + + !> covalent radius + real(wp) :: rcov + + if (number > 0 .and. number <= size(eeqbc_cov_radii, dim=1)) then + rcov = eeqbc_cov_radii(number) + else + rcov = -1.0_wp + end if + +end function get_eeqbc_cov_radii_num + +!> Get average CN for species with a given symbol +elemental function get_eeqbc_avg_cn_sym(symbol) result(avg_cn) + + !> Element symbol + character(len=*), intent(in) :: symbol + + !> average CN + real(wp) :: avg_cn + + avg_cn = get_eeqbc_avg_cn(to_number(symbol)) + +end function get_eeqbc_avg_cn_sym + +!> Get average CN for species with a given atomic number +elemental function get_eeqbc_avg_cn_num(number) result(avg_cn) + + !> Atomic number + integer, intent(in) :: number + + !> average CN + real(wp) :: avg_cn + + if (number > 0 .and. number <= size(eeqbc_avg_cn, dim=1)) then + avg_cn = eeqbc_avg_cn(number) + else + avg_cn = -1.0_wp + end if + +end function get_eeqbc_avg_cn_num + +end module multicharge_param_eeqbc2025 diff --git a/src/multicharge/param/meson.build b/src/multicharge/param/meson.build index 012bd43f..aa114adb 100644 --- a/src/multicharge/param/meson.build +++ b/src/multicharge/param/meson.build @@ -15,4 +15,5 @@ srcs += files( 'eeq2019.f90', + 'eeqbc2025.f90', ) diff --git a/src/multicharge/wignerseitz.f90 b/src/multicharge/wignerseitz.f90 index 75f162bf..b538ab3e 100644 --- a/src/multicharge/wignerseitz.f90 +++ b/src/multicharge/wignerseitz.f90 @@ -14,31 +14,29 @@ ! limitations under the License. module multicharge_wignerseitz - use mctc_env, only : wp - use mctc_io, only : structure_type - use multicharge_cutoff, only : get_lattice_points + use mctc_env, only: wp + use mctc_io, only: structure_type + use mctc_cutoff, only: get_lattice_points implicit none private public :: wignerseitz_cell_type, new_wignerseitz_cell type :: wignerseitz_cell_type + integer :: nimg_max integer, allocatable :: nimg(:, :) integer, allocatable :: tridx(:, :, :) real(wp), allocatable :: trans(:, :) end type wignerseitz_cell_type - !> Small cutoff threshold to create only closest cells real(wp), parameter :: thr = sqrt(epsilon(0.0_wp)) !> Tolerance to consider equivalent images real(wp), parameter :: tol = 0.01_wp - contains - subroutine new_wignerseitz_cell(self, mol) !> Wigner-Seitz cell instance @@ -57,6 +55,7 @@ subroutine new_wignerseitz_cell(self, mol) allocate(self%nimg(mol%nat, mol%nat), self%tridx(ntr, mol%nat, mol%nat), & & tridx(ntr)) + self%nimg_max = 0 !$omp parallel do default(none) schedule(runtime) collapse(2) & !$omp shared(mol, trans, self) private(iat, jat, vec, nimg, tridx) do iat = 1, mol%nat @@ -65,13 +64,13 @@ subroutine new_wignerseitz_cell(self, mol) call get_pairs(nimg, trans, vec, tridx) self%nimg(jat, iat) = nimg self%tridx(:, jat, iat) = tridx + self%nimg_max = max(nimg, self%nimg_max) end do end do call move_alloc(trans, self%trans) - -end subroutine new_wignerseitz_cell +end subroutine new_wignerseitz_cell subroutine get_pairs(iws, trans, rij, list) integer, intent(out) :: iws @@ -117,5 +116,4 @@ subroutine get_pairs(iws, trans, rij, list) end subroutine get_pairs - end module multicharge_wignerseitz diff --git a/subprojects/.gitignore b/subprojects/.gitignore index 36994b5e..3ac2b290 100644 --- a/subprojects/.gitignore +++ b/subprojects/.gitignore @@ -1,2 +1,5 @@ /*/ json-fortran-8.2.5.wrap +jonquil.wrap +toml-f.wrap +test-drive.wrap diff --git a/test/unit/meson.build b/test/unit/meson.build index 822f4de7..3bc59def 100644 --- a/test/unit/meson.build +++ b/test/unit/meson.build @@ -16,7 +16,7 @@ # Find mstore dependency for testing mstore_dep = dependency( 'mstore', - version: '>=0.1', + version: '>=0.3.0', fallback: ['mstore', 'mstore_dep'], required: not meson.is_subproject(), default_options: [ diff --git a/test/unit/test_model.f90 b/test/unit/test_model.f90 index dc483642..1e109191 100644 --- a/test/unit/test_model.f90 +++ b/test/unit/test_model.f90 @@ -14,12 +14,15 @@ ! limitations under the License. module test_model - use mctc_env, only : wp - use mctc_env_testing, only : new_unittest, unittest_type, error_type, check, test_failed - use mctc_io_structure, only : structure_type, new - use mstore, only : get_structure + use mctc_env, only: wp + use mctc_env_testing, only: new_unittest, unittest_type, error_type, test_failed + use mctc_io_structure, only: structure_type, new + use mstore, only: get_structure use multicharge_model, only: mchrg_model_type - use multicharge_param, only : new_eeq2019_model + use multicharge_model_eeqbc, only: eeqbc_model + use multicharge_param, only: new_eeq2019_model, new_eeqbc2025_model + use multicharge_model_cache, only: cache_container + use multicharge_charge, only: get_charges, get_eeq_charges, get_eeqbc_charges implicit none private @@ -28,10 +31,8 @@ module test_model real(wp), parameter :: thr = 100*epsilon(1.0_wp) real(wp), parameter :: thr2 = sqrt(epsilon(1.0_wp)) - contains - !> Collect all exported unit tests subroutine collect_model(testsuite) @@ -39,32 +40,418 @@ subroutine collect_model(testsuite) type(unittest_type), allocatable, intent(out) :: testsuite(:) testsuite = [ & - & new_unittest("charges-mb01", test_q_mb01), & - & new_unittest("charges-mb02", test_q_mb02), & - & new_unittest("charges-actinides", test_q_actinides), & - & new_unittest("energy-mb03", test_e_mb03), & - & new_unittest("energy-mb04", test_e_mb04), & - & new_unittest("gradient-mb05", test_g_mb05), & - & new_unittest("gradient-mb06", test_g_mb06), & - & new_unittest("sigma-mb07", test_s_mb07), & - & new_unittest("sigma-mb08", test_s_mb08), & - & new_unittest("dqdr-mb09", test_dqdr_mb09), & - & new_unittest("dqdr-mb10", test_dqdr_mb10), & - & new_unittest("dqdL-mb11", test_dqdL_mb11), & - & new_unittest("dqdL-mb12", test_dqdL_mb12), & + & new_unittest("eeq-dadr-mb01", test_eeq_dadr_mb01), & + & new_unittest("eeq-dadL-mb01", test_eeq_dadL_mb01), & + & new_unittest("eeq-dbdr-mb01", test_eeq_dbdr_mb01), & + & new_unittest("eeq-dbdL-mb01", test_eeq_dbdL_mb01), & + & new_unittest("eeq-charges-mb01", test_eeq_q_mb01), & + & new_unittest("eeq-charges-mb02", test_eeq_q_mb02), & + & new_unittest("eeq-charges-actinides", test_eeq_q_actinides), & + & new_unittest("eeq-energy-mb03", test_eeq_e_mb03), & + & new_unittest("eeq-energy-mb04", test_eeq_e_mb04), & + & new_unittest("eeq-gradient-mb05", test_eeq_g_mb05), & + & new_unittest("eeq-gradient-mb06", test_eeq_g_mb06), & + & new_unittest("eeq-sigma-mb07", test_eeq_s_mb07), & + & new_unittest("eeq-sigma-mb08", test_eeq_s_mb08), & + & new_unittest("eeq-dqdr-mb09", test_eeq_dqdr_mb09), & + & new_unittest("eeq-dqdr-mb10", test_eeq_dqdr_mb10), & + & new_unittest("eeq-dqdL-mb11", test_eeq_dqdL_mb11), & + & new_unittest("eeq-dqdL-mb12", test_eeq_dqdL_mb12), & & new_unittest("gradient-h2plus", test_g_h2plus), & + & new_unittest("eeq-dadr-znooh", test_eeq_dadr_znooh), & + & new_unittest("eeq-dbdr-znooh", test_eeq_dbdr_znooh), & & new_unittest("gradient-znooh", test_g_znooh), & - & new_unittest("dqdr-znooh", test_dqdr_znooh) & + & new_unittest("dqdr-znooh", test_dqdr_znooh), & + & new_unittest("eeqbc-dadr-mb01", test_eeqbc_dadr_mb01), & + & new_unittest("eeqbc-dadL-mb01", test_eeqbc_dadL_mb01), & + & new_unittest("eeqbc-dbdr-mb01", test_eeqbc_dbdr_mb01), & + & new_unittest("eeqbc-dbdL-mb01", test_eeqbc_dbdL_mb01), & + & new_unittest("eeqbc-dadr-mb05", test_eeqbc_dadr_mb05), & + & new_unittest("eeqbc-dadL-mb05", test_eeqbc_dadL_mb05), & + & new_unittest("eeqbc-dbdr-mb05", test_eeqbc_dbdr_mb05), & + & new_unittest("eeqbc-charges-mb01", test_eeqbc_q_mb01), & + & new_unittest("eeqbc-charges-mb02", test_eeqbc_q_mb02), & + & new_unittest("eeqbc-charges-actinides", test_eeqbc_q_actinides), & + & new_unittest("eeqbc-energy-mb03", test_eeqbc_e_mb03), & + & new_unittest("eeqbc-energy-mb04", test_eeqbc_e_mb04), & + & new_unittest("eeqbc-gradient-mb05", test_eeqbc_g_mb05), & + & new_unittest("eeqbc-gradient-mb06", test_eeqbc_g_mb06), & + & new_unittest("eeqbc-sigma-mb07", test_eeqbc_s_mb07), & + & new_unittest("eeqbc-sigma-mb08", test_eeqbc_s_mb08), & + & new_unittest("eeqbc-dqdr-mb09", test_eeqbc_dqdr_mb09), & + & new_unittest("eeqbc-dqdr-mb10", test_eeqbc_dqdr_mb10), & + & new_unittest("eeqbc-dqdL-mb11", test_eeqbc_dqdL_mb11), & + & new_unittest("eeqbc-dqdL-mb12", test_eeqbc_dqdL_mb12) & & ] end subroutine collect_model +subroutine test_dadr(error, mol, model) + + !> Molecular structure data + type(structure_type), intent(inout) :: mol + + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: iat, ic, jat, kat + real(wp) :: thr2_local + real(wp), parameter :: trans(3, 1) = 0.0_wp + real(wp), parameter :: step = 1.0e-6_wp + real(wp), allocatable :: cn(:) + real(wp), allocatable :: qloc(:) + real(wp), allocatable :: dcndr(:, :, :), dcndL(:, :, :), dqlocdr(:, :, :), dqlocdL(:, :, :) + real(wp), allocatable :: dadr(:, :, :), dadL(:, :, :), atrace(:, :) + real(wp), allocatable :: qvec(:), numgrad(:, :, :), amatr1(:, :), amatr2(:, :), amatl1(:, :), amatl2(:, :), numtrace(:, :) + type(cache_container), allocatable :: cache + allocate (cache) + + allocate (cn(mol%nat), qloc(mol%nat), amatr1(mol%nat + 1, mol%nat + 1), amatl1(mol%nat + 1, mol%nat + 1), & + & amatr2(mol%nat + 1, mol%nat + 1), amatl2(mol%nat + 1, mol%nat + 1), & + & dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), dqlocdr(3, mol%nat, mol%nat), & + & dqlocdL(3, 3, mol%nat), dadr(3, mol%nat, mol%nat + 1), dadL(3, 3, mol%nat + 1), & + & atrace(3, mol%nat), numtrace(3, mol%nat), numgrad(3, mol%nat, mol%nat + 1), qvec(mol%nat)) + + ! Set tolerance higher if testing eeqbc model + select type (model) + type is (eeqbc_model) + thr2_local = 3.0_wp*thr2 + class default + thr2_local = thr2 + end select + + ! Obtain the vector of charges + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%solve(mol, error, cn, qloc, qvec=qvec) + if (allocated(error)) return + + numgrad = 0.0_wp + + lp: do iat = 1, mol%nat + do ic = 1, 3 + amatr1(:, :) = 0.0_wp + amatr2(:, :) = 0.0_wp + amatl1(:, :) = 0.0_wp + amatl2(:, :) = 0.0_wp + + ! First right-hand side (x+h) + mol%xyz(ic, iat) = mol%xyz(ic, iat) + step + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_coulomb_matrix(mol, cache, amatr1) + + ! Second right-hand side (x+2h) + mol%xyz(ic, iat) = mol%xyz(ic, iat) + step + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_coulomb_matrix(mol, cache, amatr2) + + ! Return to original position before calculating left sides + mol%xyz(ic, iat) = mol%xyz(ic, iat) - 2*step + + ! First left-hand side (x-h) + mol%xyz(ic, iat) = mol%xyz(ic, iat) - step + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_coulomb_matrix(mol, cache, amatl1) + + ! Second left-hand side (x-2h) + mol%xyz(ic, iat) = mol%xyz(ic, iat) - step + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_coulomb_matrix(mol, cache, amatl2) + + ! Return to original position + mol%xyz(ic, iat) = mol%xyz(ic, iat) + 2*step + + do kat = 1, mol%nat + do jat = 1, mol%nat + ! Numerical gradient using 4-step central difference formula + ! f'(x) ≈ [f(x-2h) - 8f(x-h) + 8f(x+h) - f(x+2h)]/(12h) + numgrad(ic, iat, kat) = numgrad(ic, iat, kat) + & + & qvec(jat)*(amatl2(kat, jat) - 8.0_wp*amatl1(kat, jat) + & + & 8.0_wp*amatr1(kat, jat) - amatr2(kat, jat))/(12.0_wp*step) + end do + end do + end do + end do lp + + ! Analytical gradient + call model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) + call model%update(mol, cache, cn, qloc, dcndr, dcndL, dqlocdr, dqlocdL) + call model%get_coulomb_derivs(mol, cache, qvec, dadr, dadL, atrace) + + ! Add trace of the A matrix + do iat = 1, mol%nat + dadr(:, iat, iat) = atrace(:, iat) + dadr(:, iat, iat) + end do + + if (any(abs(dadr(:, :, :) - numgrad(:, :, :)) > thr2_local)) then + call test_failed(error, "Derivative of the A matrix does not match") + print'(a)', "dadr:" + print'(3es21.12)', dadr + print'(a)', "numgrad:" + print'(3es21.12)', numgrad + print'(a)', "diff:" + print'(3es21.12)', dadr - numgrad + end if + +end subroutine test_dadr + +subroutine test_dadL(error, mol, model) + + !> Molecular structure data + type(structure_type), intent(inout) :: mol + + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: ic, jc, iat + real(wp), parameter :: trans(3, 1) = 0.0_wp + real(wp), parameter :: step = 1.0e-6_wp, unity(3, 3) = reshape(& + & [1, 0, 0, 0, 1, 0, 0, 0, 1], [3, 3]) + real(wp), allocatable :: cn(:), dcndr(:, :, :), dcndL(:, :, :) + real(wp), allocatable :: qloc(:), dqlocdr(:, :, :), dqlocdL(:, :, :) + real(wp), allocatable :: dadr(:, :, :), dadL(:, :, :), atrace(:, :) + real(wp), allocatable :: xyz(:, :) + real(wp), allocatable :: qvec(:), numsigma(:, :, :), amatr(:, :), amatl(:, :) + real(wp) :: eps(3, 3) + type(cache_container), allocatable :: cache + allocate (cache) + + allocate (cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + & qloc(mol%nat), dqlocdr(3, mol%nat, mol%nat), dqlocdL(3, 3, mol%nat), & + & amatr(mol%nat + 1, mol%nat + 1), amatl(mol%nat + 1, mol%nat + 1), & + & dadr(3, mol%nat, mol%nat + 1), dadL(3, 3, mol%nat + 1), atrace(3, mol%nat), & + & numsigma(3, 3, mol%nat + 1), qvec(mol%nat), xyz(3, mol%nat)) + + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%solve(mol, error, cn, qloc, qvec=qvec) + if (allocated(error)) return + + numsigma = 0.0_wp + + eps(:, :) = unity + xyz(:, :) = mol%xyz + lp: do ic = 1, 3 + do jc = 1, 3 + amatr(:, :) = 0.0_wp + eps(jc, ic) = eps(jc, ic) + step + mol%xyz(:, :) = matmul(eps, xyz) + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_coulomb_matrix(mol, cache, amatr) + if (allocated(error)) exit lp + + amatl(:, :) = 0.0_wp + eps(jc, ic) = eps(jc, ic) - 2*step + mol%xyz(:, :) = matmul(eps, xyz) + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_coulomb_matrix(mol, cache, amatl) + if (allocated(error)) exit lp + + eps(jc, ic) = eps(jc, ic) + step + mol%xyz(:, :) = xyz + do iat = 1, mol%nat + ! Numerical sigma of the a matrix + numsigma(jc, ic, :) = numsigma(jc, ic, :) + & + & 0.5_wp*qvec(iat)*(amatr(iat, :) - amatl(iat, :))/step + end do + end do + end do lp + if (allocated(error)) return + + call model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) + call model%update(mol, cache, cn, qloc, dcndr, dcndL, dqlocdr, dqlocdL) + + call model%get_coulomb_derivs(mol, cache, qvec, dadr, dadL, atrace) + if (allocated(error)) return + + if (any(abs(dadL(:, :, :) - numsigma(:, :, :)) > thr2)) then + call test_failed(error, "Derivative of the A matrix does not match") + print'(a)', "dadL:" + print'(3es21.12)', dadL + print'(a)', "numsigma:" + print'(3es21.12)', numsigma + print'(a)', "diff:" + print'(3es21.12)', dadL - numsigma + end if + +end subroutine test_dadL + +subroutine test_dbdr(error, mol, model) + + !> Molecular structure data + type(structure_type), intent(inout) :: mol + + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: iat, ic + real(wp), parameter :: trans(3, 1) = 0.0_wp + real(wp), parameter :: step = 1.0e-6_wp + real(wp), allocatable :: cn(:), dcndr(:, :, :), dcndL(:, :, :) + real(wp), allocatable :: qloc(:), dqlocdr(:, :, :), dqlocdL(:, :, :) + real(wp), allocatable :: dbdr(:, :, :), dbdL(:, :, :) + real(wp), allocatable :: numgrad(:, :, :), xvecr(:), xvecl(:) + type(cache_container), allocatable :: cache + allocate (cache) + + allocate (cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + & qloc(mol%nat), dqlocdr(3, mol%nat, mol%nat), dqlocdL(3, 3, mol%nat), & + & xvecr(mol%nat + 1), xvecl(mol%nat + 1), numgrad(3, mol%nat, mol%nat + 1), & + & dbdr(3, mol%nat, mol%nat + 1), dbdL(3, 3, mol%nat + 1)) + + lp: do iat = 1, mol%nat + do ic = 1, 3 + ! Right-hand side + xvecr(:) = 0.0_wp + mol%xyz(ic, iat) = mol%xyz(ic, iat) + step + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_xvec(mol, cache, xvecr) + + ! Left-hand side + xvecl(:) = 0.0_wp + mol%xyz(ic, iat) = mol%xyz(ic, iat) - 2*step + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_xvec(mol, cache, xvecl) + + mol%xyz(ic, iat) = mol%xyz(ic, iat) + step + numgrad(ic, iat, :) = 0.5_wp*(xvecr(:) - xvecl(:))/step + end do + end do lp + + ! Analytical gradient + call model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) + call model%update(mol, cache, cn, qloc, dcndr, dcndL, dqlocdr, dqlocdL) + call model%get_xvec(mol, cache, xvecl) ! need to call this for xtmp in cache (eeqbc) + call model%get_xvec_derivs(mol, cache, dbdr, dbdL) + + if (any(abs(dbdr(:, :, :) - numgrad(:, :, :)) > thr2)) then + call test_failed(error, "Derivative of the b vector does not match") + print'(a)', "dbdr:" + print'(3es21.14)', dbdr + print'(a)', "numgrad:" + print'(3es21.14)', numgrad + print'(a)', "diff:" + print'(3es21.14)', dbdr - numgrad + end if + +end subroutine test_dbdr + +subroutine test_dbdL(error, mol, model) + + !> Molecular structure data + type(structure_type), intent(inout) :: mol + + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: iat, ic, jc + real(wp), parameter :: trans(3, 1) = 0.0_wp + real(wp), parameter :: step = 1.0e-6_wp, unity(3, 3) = reshape(& + & [1, 0, 0, 0, 1, 0, 0, 0, 1], [3, 3]) + real(wp), allocatable :: cn(:), dcndr(:, :, :), dcndL(:, :, :) + real(wp), allocatable :: qloc(:), dqlocdr(:, :, :), dqlocdL(:, :, :) + real(wp), allocatable :: dbdr(:, :, :), dbdL(:, :, :) + real(wp), allocatable :: numsigma(:, :, :), xvecr(:), xvecl(:) + real(wp), allocatable :: xyz(:, :) + real(wp) :: eps(3, 3) + type(cache_container), allocatable :: cache + allocate (cache) + + allocate (cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + & qloc(mol%nat), dqlocdr(3, mol%nat, mol%nat), dqlocdL(3, 3, mol%nat), & + & xvecr(mol%nat + 1), xvecl(mol%nat + 1), numsigma(3, 3, mol%nat + 1), & + & dbdr(3, mol%nat, mol%nat + 1), dbdL(3, 3, mol%nat + 1), xyz(3, mol%nat)) + + numsigma = 0.0_wp + + eps(:, :) = unity + xyz(:, :) = mol%xyz + lp: do ic = 1, 3 + do jc = 1, 3 + ! Right-hand side + xvecr(:) = 0.0_wp + eps(jc, ic) = eps(jc, ic) + step + mol%xyz(:, :) = matmul(eps, xyz) + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_xvec(mol, cache, xvecr) + + ! Left-hand side + xvecl(:) = 0.0_wp + eps(jc, ic) = eps(jc, ic) - 2*step + mol%xyz(:, :) = matmul(eps, xyz) + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_xvec(mol, cache, xvecl) + + eps(jc, ic) = eps(jc, ic) + step + mol%xyz(:, :) = xyz + do iat = 1, mol%nat + numsigma(jc, ic, iat) = 0.5_wp*(xvecr(iat) - xvecl(iat))/step + end do + end do + end do lp -subroutine gen_test(error, mol, qref, eref) + ! Analytical gradient + call model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) + call model%update(mol, cache, cn, qloc, dcndr, dcndL, dqlocdr, dqlocdL) + call model%get_xvec(mol, cache, xvecl) ! need to call this for xtmp in cache (eeqbc) + call model%get_xvec_derivs(mol, cache, dbdr, dbdL) + + if (any(abs(dbdL(:, :, :) - numsigma(:, :, :)) > thr2)) then + call test_failed(error, "Derivative of the b vector does not match") + print'(a)', "dbdL:" + print'(3es21.14)', dbdL + print'(a)', "numsigma:" + print'(3es21.14)', numsigma + print'(a)', "diff:" + print'(3es21.14)', dbdL - numsigma + end if + +end subroutine test_dbdL + +subroutine gen_test(error, mol, model, qref, eref) !> Molecular structure data type(structure_type), intent(in) :: mol + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + !> Reference charges real(wp), intent(in), optional :: qref(:) @@ -74,28 +461,27 @@ subroutine gen_test(error, mol, qref, eref) !> Error handling type(error_type), allocatable, intent(out) :: error - type(mchrg_model_type) :: model real(wp), parameter :: trans(3, 1) = 0.0_wp - real(wp), allocatable :: cn(:) + real(wp), allocatable :: cn(:), qloc(:) real(wp), allocatable :: energy(:) real(wp), allocatable :: qvec(:) - call new_eeq2019_model(mol, model, error) - if (allocated(error)) return - - allocate(cn(mol%nat)) + allocate (cn(mol%nat), qloc(mol%nat)) call model%ncoord%get_coordination_number(mol, trans, cn) + if (allocated(model%ncoord_en)) then + call model%local_charge(mol, trans, qloc) + end if if (present(eref)) then - allocate(energy(mol%nat)) + allocate (energy(mol%nat)) energy(:) = 0.0_wp end if if (present(qref)) then - allocate(qvec(mol%nat)) + allocate (qvec(mol%nat)) end if - call model%solve(mol, error, cn, energy=energy, qvec=qvec) + call model%solve(mol, error, cn, qloc, energy=energy, qvec=qvec) if (allocated(error)) return if (present(qref)) then @@ -103,6 +489,8 @@ subroutine gen_test(error, mol, qref, eref) call test_failed(error, "Partial charges do not match") print'(a)', "Charges:" print'(3es21.14)', qvec + print'(a)', "diff:" + print'(3es21.14)', qvec - qref end if end if if (allocated(error)) return @@ -112,33 +500,35 @@ subroutine gen_test(error, mol, qref, eref) call test_failed(error, "Energies do not match") print'(a)', "Energy:" print'(3es21.14)', energy + print'(a)', "diff:" + print'(3es21.14)', energy - eref end if end if end subroutine gen_test - -subroutine test_numgrad(error, mol) +subroutine test_numgrad(error, mol, model) !> Molecular structure data type(structure_type), intent(inout) :: mol + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + !> Error handling type(error_type), allocatable, intent(out) :: error integer :: iat, ic - type(mchrg_model_type) :: model real(wp), parameter :: trans(3, 1) = 0.0_wp real(wp), parameter :: step = 1.0e-6_wp real(wp), allocatable :: cn(:), dcndr(:, :, :), dcndL(:, :, :) + real(wp), allocatable :: qloc(:), dqlocdr(:, :, :), dqlocdL(:, :, :) real(wp), allocatable :: energy(:), gradient(:, :), sigma(:, :) real(wp), allocatable :: numgrad(:, :) real(wp) :: er, el - call new_eeq2019_model(mol, model, error) - if (allocated(error)) return - - allocate(cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + allocate (cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + & qloc(mol%nat), dqlocdr(3, mol%nat, mol%nat), dqlocdL(3, 3, mol%nat), & & energy(mol%nat), gradient(3, mol%nat), sigma(3, 3), numgrad(3, mol%nat)) energy(:) = 0.0_wp gradient(:, :) = 0.0_wp @@ -149,14 +539,16 @@ subroutine test_numgrad(error, mol) energy(:) = 0.0_wp mol%xyz(ic, iat) = mol%xyz(ic, iat) + step call model%ncoord%get_coordination_number(mol, trans, cn) - call model%solve(mol, error, cn, energy=energy) + call model%local_charge(mol, trans, qloc) + call model%solve(mol, error, cn, qloc, energy=energy) if (allocated(error)) exit lp er = sum(energy) energy(:) = 0.0_wp mol%xyz(ic, iat) = mol%xyz(ic, iat) - 2*step call model%ncoord%get_coordination_number(mol, trans, cn) - call model%solve(mol, error, cn, energy=energy) + call model%local_charge(mol, trans, qloc) + call model%solve(mol, error, cn, qloc, energy=energy) if (allocated(error)) exit lp el = sum(energy) @@ -167,40 +559,52 @@ subroutine test_numgrad(error, mol) if (allocated(error)) return call model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) - energy(:) = 0.0_wp - call model%solve(mol, error, cn, dcndr, dcndL, energy, gradient, sigma) + ! dcndr(:, :, :) = 0.0_wp + ! dcndL(:, :, :) = 0.0_wp + ! dqlocdr(:, :, :) = 0.0_wp + ! dqlocdL(:, :, :) = 0.0_wp + + call model%solve(mol, error, cn, qloc, dcndr, dcndL, & + & dqlocdr, dqlocdL, gradient=gradient, sigma=sigma) if (allocated(error)) return if (any(abs(gradient(:, :) - numgrad(:, :)) > thr2)) then call test_failed(error, "Derivative of energy does not match") + print'(a)', "Energy gradient:" + print'(3es21.14)', gradient + print'(a)', "numgrad:" + print'(3es21.14)', numgrad + print'(a)', "diff:" + print'(3es21.14)', gradient - numgrad end if end subroutine test_numgrad - -subroutine test_numsigma(error, mol) +subroutine test_numsigma(error, mol, model) !> Molecular structure data type(structure_type), intent(inout) :: mol + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + !> Error handling type(error_type), allocatable, intent(out) :: error integer :: ic, jc - type(mchrg_model_type) :: model real(wp), parameter :: trans(3, 1) = 0.0_wp real(wp), parameter :: step = 1.0e-6_wp, unity(3, 3) = reshape(& - & [1, 0, 0, 0, 1, 0, 0, 0, 1], shape(unity)) + & [1, 0, 0, 0, 1, 0, 0, 0, 1], [3, 3]) real(wp), allocatable :: cn(:), dcndr(:, :, :), dcndL(:, :, :) + real(wp), allocatable :: qloc(:), dqlocdr(:, :, :), dqlocdL(:, :, :) real(wp), allocatable :: energy(:), gradient(:, :) - real(wp), allocatable :: lattr(:, :), xyz(:, :) + real(wp), allocatable :: xyz(:, :) real(wp) :: er, el, eps(3, 3), numsigma(3, 3), sigma(3, 3) - call new_eeq2019_model(mol, model, error) - if (allocated(error)) return - - allocate(cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + allocate (cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + & qloc(mol%nat), dqlocdr(3, mol%nat, mol%nat), dqlocdL(3, 3, mol%nat), & & energy(mol%nat), gradient(3, mol%nat), xyz(3, mol%nat)) energy(:) = 0.0_wp gradient(:, :) = 0.0_wp @@ -208,68 +612,74 @@ subroutine test_numsigma(error, mol) eps(:, :) = unity xyz(:, :) = mol%xyz - lattr = trans lp: do ic = 1, 3 do jc = 1, 3 energy(:) = 0.0_wp eps(jc, ic) = eps(jc, ic) + step mol%xyz(:, :) = matmul(eps, xyz) - lattr(:, :) = matmul(eps, trans) - call model%ncoord%get_coordination_number(mol, lattr, cn) - call model%solve(mol, error, cn, energy=energy) + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%solve(mol, error, cn, qloc, energy=energy) if (allocated(error)) exit lp er = sum(energy) energy(:) = 0.0_wp eps(jc, ic) = eps(jc, ic) - 2*step mol%xyz(:, :) = matmul(eps, xyz) - lattr(:, :) = matmul(eps, trans) - call model%ncoord%get_coordination_number(mol, lattr, cn) - call model%solve(mol, error, cn, energy=energy) + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%solve(mol, error, cn, qloc, energy=energy) if (allocated(error)) exit lp el = sum(energy) eps(jc, ic) = eps(jc, ic) + step mol%xyz(:, :) = xyz - lattr(:, :) = trans numsigma(jc, ic) = 0.5_wp*(er - el)/step end do end do lp if (allocated(error)) return call model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) energy(:) = 0.0_wp - call model%solve(mol, error, cn, dcndr, dcndL, energy, gradient, sigma) + call model%solve(mol, error, cn, qloc, dcndr, dcndL, & + & dqlocdr, dqlocdL, energy, gradient, sigma) if (allocated(error)) return if (any(abs(sigma(:, :) - numsigma(:, :)) > thr2)) then call test_failed(error, "Derivative of energy does not match") + print'(a)', "Energy strain:" + print'(3es21.14)', sigma + print'(a)', "numsigma:" + print'(3es21.14)', numsigma + print'(a)', "diff:" + print'(3es21.14)', sigma - numsigma end if end subroutine test_numsigma - -subroutine test_numdqdr(error, mol) +subroutine test_numdqdr(error, mol, model) !> Molecular structure data type(structure_type), intent(inout) :: mol + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + !> Error handling type(error_type), allocatable, intent(out) :: error integer :: iat, ic - type(mchrg_model_type) :: model real(wp), parameter :: trans(3, 1) = 0.0_wp real(wp), parameter :: step = 1.0e-6_wp real(wp), allocatable :: cn(:), dcndr(:, :, :), dcndL(:, :, :) + real(wp), allocatable :: qloc(:), dqlocdr(:, :, :), dqlocdL(:, :, :) real(wp), allocatable :: ql(:), qr(:), dqdr(:, :, :), dqdL(:, :, :) real(wp), allocatable :: numdr(:, :, :) - call new_eeq2019_model(mol, model, error) - if (allocated(error)) return - - allocate(cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + allocate (cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + & qloc(mol%nat), dqlocdr(3, mol%nat, mol%nat), dqlocdL(3, 3, mol%nat), & & ql(mol%nat), qr(mol%nat), dqdr(3, mol%nat, mol%nat), dqdL(3, 3, mol%nat), & & numdr(3, mol%nat, mol%nat)) @@ -277,12 +687,14 @@ subroutine test_numdqdr(error, mol) do ic = 1, 3 mol%xyz(ic, iat) = mol%xyz(ic, iat) + step call model%ncoord%get_coordination_number(mol, trans, cn) - call model%solve(mol, error, cn, qvec=qr) + call model%local_charge(mol, trans, qloc) + call model%solve(mol, error, cn, qloc, qvec=qr) if (allocated(error)) exit lp mol%xyz(ic, iat) = mol%xyz(ic, iat) - 2*step call model%ncoord%get_coordination_number(mol, trans, cn) - call model%solve(mol, error, cn, qvec=ql) + call model%local_charge(mol, trans, qloc) + call model%solve(mol, error, cn, qloc, qvec=ql) if (allocated(error)) exit lp mol%xyz(ic, iat) = mol%xyz(ic, iat) + step @@ -292,39 +704,47 @@ subroutine test_numdqdr(error, mol) if (allocated(error)) return call model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) - call model%solve(mol, error, cn, dcndr, dcndL, dqdr=dqdr, dqdL=dqdL) + call model%solve(mol, error, cn, qloc, dcndr, dcndL, & + & dqlocdr, dqlocdL, dqdr=dqdr, dqdL=dqdL) if (allocated(error)) return if (any(abs(dqdr(:, :, :) - numdr(:, :, :)) > thr2)) then call test_failed(error, "Derivative of charges does not match") + print'(a)', "Charge gradient:" + print'(3es21.14)', dqdr + print'(a)', "numgrad:" + print'(3es21.14)', numdr + print'(a)', "diff:" + print'(3es21.14)', dqdr - numdr end if end subroutine test_numdqdr - -subroutine test_numdqdL(error, mol) +subroutine test_numdqdL(error, mol, model) !> Molecular structure data type(structure_type), intent(inout) :: mol + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + !> Error handling type(error_type), allocatable, intent(out) :: error integer :: ic, jc - type(mchrg_model_type) :: model real(wp), parameter :: trans(3, 1) = 0.0_wp real(wp), parameter :: step = 1.0e-6_wp, unity(3, 3) = reshape(& - & [1, 0, 0, 0, 1, 0, 0, 0, 1], shape(unity)) + & [1, 0, 0, 0, 1, 0, 0, 0, 1], [3, 3]) real(wp), allocatable :: cn(:), dcndr(:, :, :), dcndL(:, :, :) + real(wp), allocatable :: qloc(:), dqlocdr(:, :, :), dqlocdL(:, :, :) real(wp), allocatable :: qr(:), ql(:), dqdr(:, :, :), dqdL(:, :, :) real(wp), allocatable :: lattr(:, :), xyz(:, :), numdL(:, :, :) real(wp) :: eps(3, 3) - call new_eeq2019_model(mol, model, error) - if (allocated(error)) return - - allocate(cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + allocate (cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + & qloc(mol%nat), dqlocdr(3, mol%nat, mol%nat), dqlocdL(3, 3, mol%nat), & & qr(mol%nat), ql(mol%nat), dqdr(3, mol%nat, mol%nat), dqdL(3, 3, mol%nat), & & xyz(3, mol%nat), numdL(3, 3, mol%nat)) @@ -336,15 +756,17 @@ subroutine test_numdqdL(error, mol) eps(jc, ic) = eps(jc, ic) + step mol%xyz(:, :) = matmul(eps, xyz) lattr(:, :) = matmul(eps, trans) - call model%ncoord%get_coordination_number(mol, lattr, cn) - call model%solve(mol, error, cn, qvec=qr) + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%solve(mol, error, cn, qloc, qvec=qr) if (allocated(error)) exit lp eps(jc, ic) = eps(jc, ic) - 2*step mol%xyz(:, :) = matmul(eps, xyz) lattr(:, :) = matmul(eps, trans) - call model%ncoord%get_coordination_number(mol, lattr, cn) - call model%solve(mol, error, cn, qvec=ql) + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%solve(mol, error, cn, qloc, qvec=ql) if (allocated(error)) exit lp eps(jc, ic) = eps(jc, ic) + step @@ -356,74 +778,175 @@ subroutine test_numdqdL(error, mol) if (allocated(error)) return call model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) - call model%solve(mol, error, cn, dcndr, dcndL, dqdr=dqdr, dqdL=dqdL) + call model%solve(mol, error, cn, qloc, dcndr, dcndL, & + & dqlocdr, dqlocdL, dqdr=dqdr, dqdL=dqdL) if (allocated(error)) return if (any(abs(dqdL(:, :, :) - numdL(:, :, :)) > thr2)) then call test_failed(error, "Derivative of charges does not match") + print'(a)', "Charge gradient:" + print'(3es21.14)', dqdL + print'(a)', "numgrad:" + print'(3es21.14)', numdL + print'(a)', "diff:" + print'(3es21.14)', dqdL - numdL end if end subroutine test_numdqdL +subroutine test_eeq_dadr_mb01(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "01") + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_dadr(error, mol, model) + +end subroutine test_eeq_dadr_mb01 + +subroutine test_eeq_dadL_mb01(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "01") + !call get_structure(mol, "ICE10", "gas") + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_dadL(error, mol, model) + +end subroutine test_eeq_dadL_mb01 + +subroutine test_eeq_dbdr_mb01(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "01") + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_dbdr(error, mol, model) + +end subroutine test_eeq_dbdr_mb01 + +subroutine test_eeq_dbdL_mb01(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "01") + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_dbdL(error, mol, model) + +end subroutine test_eeq_dbdL_mb01 -subroutine test_q_mb01(error) +subroutine test_eeq_q_mb01(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model real(wp), parameter :: ref(16) = [& - & 7.73347759615437E-1_wp, 1.07626897257271E-1_wp,-3.66999554268267E-1_wp, & - & 4.92833775451616E-2_wp,-1.83332153007808E-1_wp, 2.33302084420314E-1_wp, & - & 6.61837602813735E-2_wp,-5.43944147972069E-1_wp,-2.70264297953247E-1_wp, & - & 2.66618970100409E-1_wp, 2.62725030332215E-1_wp,-7.15315061940473E-2_wp, & - &-3.73300836681036E-1_wp, 3.84585142200261E-2_wp,-5.05851076468890E-1_wp, & + & 7.73347759615437E-1_wp, 1.07626897257271E-1_wp, -3.66999554268267E-1_wp, & + & 4.92833775451616E-2_wp, -1.83332153007808E-1_wp, 2.33302084420314E-1_wp, & + & 6.61837602813735E-2_wp, -5.43944147972069E-1_wp, -2.70264297953247E-1_wp, & + & 2.66618970100409E-1_wp, 2.62725030332215E-1_wp, -7.15315061940473E-2_wp, & + &-3.73300836681036E-1_wp, 3.84585142200261E-2_wp, -5.05851076468890E-1_wp, & & 5.17677178773158E-1_wp] + real(wp), allocatable :: qvec(:) + call get_structure(mol, "MB16-43", "01") - call gen_test(error, mol, qref=ref) + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call gen_test(error, mol, model, qref=ref) + if (allocated(error)) return -end subroutine test_q_mb01 + ! Check wrapper functions + allocate (qvec(mol%nat), source=0.0_wp) + call get_charges(model, mol, error, qvec) + if (allocated(error)) return + + if (any(abs(qvec - ref) > thr)) then + call test_failed(error, "Partial charges do not match") + print'(a)', "Charges:" + print'(3es21.14)', qvec + print'(a)', "diff:" + print'(3es21.14)', qvec - ref + end if + if (allocated(error)) return + + qvec = 0.0_wp + call get_eeq_charges(mol, error, qvec) + if (allocated(error)) return + + if (any(abs(qvec - ref) > thr)) then + call test_failed(error, "Partial charges do not match") + print'(a)', "Charges:" + print'(3es21.14)', qvec + print'(a)', "diff:" + print'(3es21.14)', qvec - ref + end if + if (allocated(error)) return +end subroutine test_eeq_q_mb01 -subroutine test_q_mb02(error) +subroutine test_eeq_q_mb02(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol - + class(mchrg_model_type), allocatable :: model real(wp), parameter :: ref(16) = [& - & 7.38394752482521E-2_wp,-1.68354859084778E-1_wp,-3.47642846358022E-1_wp, & + & 7.38394752482521E-2_wp, -1.68354859084778E-1_wp, -3.47642846358022E-1_wp, & &-7.05489251302223E-1_wp, 7.73548241620680E-1_wp, 2.30207580650128E-1_wp, & & 1.02748505731185E-1_wp, 9.47818154871089E-2_wp, 2.44259536057649E-2_wp, & - & 2.34984928231320E-1_wp,-3.17839956573785E-1_wp, 6.67112952465234E-1_wp, & + & 2.34984928231320E-1_wp, -3.17839956573785E-1_wp, 6.67112952465234E-1_wp, & &-4.78119957747208E-1_wp, 6.57536208287042E-2_wp, 1.08259091466373E-1_wp, & &-3.58215294268738E-1_wp] call get_structure(mol, "MB16-43", "02") - call gen_test(error, mol, qref=ref) - -end subroutine test_q_mb02 + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call gen_test(error, mol, model, qref=ref) +end subroutine test_eeq_q_mb02 -subroutine test_q_actinides(error) +subroutine test_eeq_q_actinides(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol - + class(mchrg_model_type), allocatable :: model real(wp), parameter :: ref(17) = [& - & 1.86904766283711E-02_wp, 2.89972818160259E-01_wp, 3.59298070941105E-02_wp, & - &-4.61256458126589E-02_wp,-7.02605348653647E-02_wp,-7.42052215689073E-02_wp, & + & 1.86904766283711E-02_wp, 2.89972818160259E-01_wp, 3.59298070941105E-02_wp, & + &-4.61256458126589E-02_wp, -7.02605348653647E-02_wp, -7.42052215689073E-02_wp, & &-8.21938718945845E-02_wp, 1.64953118841151E-01_wp, 2.10381640633390E-01_wp, & - &-6.65485355096282E-02_wp,-2.59873890255450E-01_wp, 1.33839147940414E-01_wp, & - & 7.20768968601809E-02_wp,-3.36652347675997E-03_wp,-1.14546280789657E-01_wp, & - &-8.55922398441004E-02_wp,-1.23131162140762E-01_wp] + &-6.65485355096282E-02_wp, -2.59873890255450E-01_wp, 1.33839147940414E-01_wp, & + & 7.20768968601809E-02_wp, -3.36652347675997E-03_wp, -1.14546280789657E-01_wp, & + &-8.55922398441004E-02_wp, -1.23131162140762E-01_wp] - !> Molecular structure data + !> Molecular structure data mol%nat = 17 mol%nid = 17 mol%id = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, & @@ -431,174 +954,207 @@ subroutine test_q_actinides(error) mol%num = [87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, & & 98, 99, 100, 101, 102, 103] mol%xyz = reshape([ & - & 0.98692316414074_wp, 6.12727238368797_wp,-6.67861597188102_wp, & + & 0.98692316414074_wp, 6.12727238368797_wp, -6.67861597188102_wp, & & 3.63898862390869_wp, 5.12109301182962_wp, 3.01908613326278_wp, & - & 5.14503571563551_wp,-3.97172984617710_wp, 3.82011791828867_wp, & + & 5.14503571563551_wp, -3.97172984617710_wp, 3.82011791828867_wp, & & 6.71986847575494_wp, 1.71382138402812_wp, 3.92749159076307_wp, & - & 4.13783589704826_wp,-2.10695793491818_wp, 0.19753203068899_wp, & - & 8.97685097698326_wp,-3.08813636191844_wp,-4.45568615593938_wp, & - & 12.5486412940776_wp,-1.77128765259458_wp, 0.59261498922861_wp, & - & 7.82051475868325_wp,-3.97159756604558_wp,-0.53637703616916_wp, & - &-0.43444574624893_wp,-1.69696511583960_wp,-1.65898182093050_wp, & - &-4.71270645149099_wp,-0.11534827468942_wp, 2.84863373521297_wp, & - &-2.52061680335614_wp, 1.82937752749537_wp,-2.10366982879172_wp, & - & 0.13551154616576_wp, 7.99805359235043_wp,-1.55508522619903_wp, & - & 3.91594542499717_wp,-1.72975169129597_wp,-5.07944366756113_wp, & + & 4.13783589704826_wp, -2.10695793491818_wp, 0.19753203068899_wp, & + & 8.97685097698326_wp, -3.08813636191844_wp, -4.45568615593938_wp, & + & 12.5486412940776_wp, -1.77128765259458_wp, 0.59261498922861_wp, & + & 7.82051475868325_wp, -3.97159756604558_wp, -0.53637703616916_wp, & + &-0.43444574624893_wp, -1.69696511583960_wp, -1.65898182093050_wp, & + &-4.71270645149099_wp, -0.11534827468942_wp, 2.84863373521297_wp, & + &-2.52061680335614_wp, 1.82937752749537_wp, -2.10366982879172_wp, & + & 0.13551154616576_wp, 7.99805359235043_wp, -1.55508522619903_wp, & + & 3.91594542499717_wp, -1.72975169129597_wp, -5.07944366756113_wp, & &-1.03393930231679_wp, 4.69307230054046_wp, 0.02656940927472_wp, & - & 6.20675384557240_wp, 4.24490721493632_wp,-0.71004195169885_wp, & - & 7.04586341131562_wp, 5.20053667939076_wp,-7.51972863675876_wp, & - & 2.01082807362334_wp, 1.34838807211157_wp,-4.70482633508447_wp],& + & 6.20675384557240_wp, 4.24490721493632_wp, -0.71004195169885_wp, & + & 7.04586341131562_wp, 5.20053667939076_wp, -7.51972863675876_wp, & + & 2.01082807362334_wp, 1.34838807211157_wp, -4.70482633508447_wp],& & [3, 17]) mol%periodic = [.false.] - call gen_test(error, mol, qref=ref) - -end subroutine test_q_actinides + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call gen_test(error, mol, model, qref=ref) +end subroutine test_eeq_q_actinides -subroutine test_e_mb03(error) +subroutine test_eeq_e_mb03(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model real(wp), parameter :: ref(16) = [& - &-2.18698345033562E-1_wp,-1.04793885931268E+0_wp, 4.78963353574572E-2_wp, & + &-2.18698345033562E-1_wp, -1.04793885931268E+0_wp, 4.78963353574572E-2_wp, & & 5.76566377591676E-1_wp, 7.37187470977927E-1_wp, 8.06020047053305E-2_wp, & &-4.19837955782898E-1_wp, 5.49627510550566E-2_wp, 8.01486728591565E-2_wp, & - & 1.00618944521776E-1_wp,-6.61715169034150E-1_wp,-3.60531647289563E-1_wp, & + & 1.00618944521776E-1_wp, -6.61715169034150E-1_wp, -3.60531647289563E-1_wp, & &-4.87729666337974E-1_wp, 2.48257554279938E-1_wp, 6.96027176590956E-1_wp, & & 4.31679925875087E-2_wp] +! &-1.13826350631987E-1_wp,-5.62509056571450E-1_wp, 2.40314584307323E-2_wp, & +! & 2.34612384482528E-1_wp, 3.24513111881020E-1_wp, 4.02366323905675E-2_wp, & +! &-2.17529318207133E-1_wp, 2.75364844977006E-2_wp, 4.02137369467059E-2_wp, & +! & 5.04840322940993E-2_wp,-3.53634572772168E-1_wp,-1.87985748794416E-1_wp, & +! &-2.52739835528964E-1_wp, 1.24520645208966E-1_wp, 2.69468093358888E-1_wp, & +! & 2.15919407508634E-2_wp] call get_structure(mol, "MB16-43", "03") - call gen_test(error, mol, eref=ref) - -end subroutine test_e_mb03 + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call gen_test(error, mol, model, eref=ref) +end subroutine test_eeq_e_mb03 -subroutine test_e_mb04(error) +subroutine test_eeq_e_mb04(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model real(wp), parameter :: ref(16) = [& - & 1.13974214746111E-1_wp,-4.41735365367827E-1_wp, 8.99036489938394E-2_wp, & + & 1.13974214746111E-1_wp, -4.41735365367827E-1_wp, 8.99036489938394E-2_wp, & &-2.97539904703271E-1_wp, 8.05174117097006E-3_wp, 1.31105783760276E-1_wp, & & 1.54594451996644E-1_wp, 1.19929653841255E-1_wp, 1.26056586309101E-1_wp, & - & 1.78439005754586E-1_wp,-1.98703462666082E-1_wp, 4.19630120027785E-1_wp, & - & 7.05569220334930E-2_wp,-4.50925107441869E-1_wp, 1.39289602382354E-1_wp, & + & 1.78439005754586E-1_wp, -1.98703462666082E-1_wp, 4.19630120027785E-1_wp, & + & 7.05569220334930E-2_wp, -4.50925107441869E-1_wp, 1.39289602382354E-1_wp, & &-2.67853086061429E-1_wp] +! & 5.48650497749607E-2_wp,-2.25780913208624E-1_wp, 4.35281631902307E-2_wp, & +! &-1.57205780814366E-1_wp, 4.09837366864403E-3_wp, 6.31282692438352E-2_wp, & +! & 7.48306233723622E-2_wp, 5.87730150647742E-2_wp, 6.10308494414398E-2_wp, & +! & 8.63933930367129E-2_wp,-9.99483536957020E-2_wp, 2.02497843626054E-1_wp, & +! & 3.47529062386466E-2_wp,-2.37058804560779E-1_wp, 6.74225102943070E-2_wp, & +! &-1.36552339896561E-1_wp] call get_structure(mol, "MB16-43", "04") - call gen_test(error, mol, eref=ref) - -end subroutine test_e_mb04 + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call gen_test(error, mol, model, eref=ref) +end subroutine test_eeq_e_mb04 -subroutine test_g_mb05(error) +subroutine test_eeq_g_mb05(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model call get_structure(mol, "MB16-43", "05") - call test_numgrad(error, mol) - -end subroutine test_g_mb05 + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_numgrad(error, mol, model) +end subroutine test_eeq_g_mb05 -subroutine test_g_mb06(error) +subroutine test_eeq_g_mb06(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model call get_structure(mol, "MB16-43", "06") - call test_numgrad(error, mol) - -end subroutine test_g_mb06 + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_numgrad(error, mol, model) +end subroutine test_eeq_g_mb06 -subroutine test_s_mb07(error) +subroutine test_eeq_s_mb07(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model call get_structure(mol, "MB16-43", "07") - call test_numsigma(error, mol) - -end subroutine test_s_mb07 + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_numsigma(error, mol, model) +end subroutine test_eeq_s_mb07 -subroutine test_s_mb08(error) +subroutine test_eeq_s_mb08(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model call get_structure(mol, "MB16-43", "08") - call test_numsigma(error, mol) - -end subroutine test_s_mb08 + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_numsigma(error, mol, model) +end subroutine test_eeq_s_mb08 -subroutine test_dqdr_mb09(error) +subroutine test_eeq_dqdr_mb09(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model call get_structure(mol, "MB16-43", "09") - call test_numdqdr(error, mol) - -end subroutine test_dqdr_mb09 + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_numdqdr(error, mol, model) +end subroutine test_eeq_dqdr_mb09 -subroutine test_dqdr_mb10(error) +subroutine test_eeq_dqdr_mb10(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model call get_structure(mol, "MB16-43", "10") - call test_numdqdr(error, mol) - -end subroutine test_dqdr_mb10 + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_numdqdr(error, mol, model) +end subroutine test_eeq_dqdr_mb10 -subroutine test_dqdL_mb11(error) +subroutine test_eeq_dqdL_mb11(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model call get_structure(mol, "MB16-43", "11") - call test_numdqdL(error, mol) - -end subroutine test_dqdL_mb11 + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_numdqdL(error, mol, model) +end subroutine test_eeq_dqdL_mb11 -subroutine test_dqdL_mb12(error) +subroutine test_eeq_dqdL_mb12(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model call get_structure(mol, "MB16-43", "12") - call test_numdqdL(error, mol) - -end subroutine test_dqdL_mb12 + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_numdqdL(error, mol, model) +end subroutine test_eeq_dqdL_mb12 subroutine test_g_h2plus(error) @@ -606,6 +1162,7 @@ subroutine test_g_h2plus(error) type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model integer, parameter :: nat = 2 real(wp), parameter :: charge = 1.0_wp @@ -616,10 +1173,59 @@ subroutine test_g_h2plus(error) & [3, nat]) call new(mol, num, xyz, charge) - call test_numgrad(error, mol) + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_numgrad(error, mol, model) end subroutine test_g_h2plus +subroutine test_eeq_dadr_znooh(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + integer, parameter :: nat = 4 + real(wp), parameter :: charge = -1.0_wp + integer, parameter :: num(nat) = [30, 8, 8, 1] + real(wp), parameter :: xyz(3, nat) = reshape([ & + & -0.30631629283878_wp, -1.11507514203552_wp, +0.00000000000000_wp, & + & -0.06543072660074_wp, -4.32862093666082_wp, +0.00000000000000_wp, & + & -0.64012239724097_wp, +2.34966763895920_wp, +0.00000000000000_wp, & + & +1.01186941668051_wp, +3.09402843973713_wp, +0.00000000000000_wp],& + & [3, nat]) + + call new(mol, num, xyz, charge) + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_dadr(error, mol, model) + +end subroutine test_eeq_dadr_znooh + +subroutine test_eeq_dbdr_znooh(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + integer, parameter :: nat = 4 + real(wp), parameter :: charge = -1.0_wp + integer, parameter :: num(nat) = [30, 8, 8, 1] + real(wp), parameter :: xyz(3, nat) = reshape([ & + & -0.30631629283878_wp, -1.11507514203552_wp, +0.00000000000000_wp, & + & -0.06543072660074_wp, -4.32862093666082_wp, +0.00000000000000_wp, & + & -0.64012239724097_wp, +2.34966763895920_wp, +0.00000000000000_wp, & + & +1.01186941668051_wp, +3.09402843973713_wp, +0.00000000000000_wp],& + & [3, nat]) + + call new(mol, num, xyz, charge) + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_dbdr(error, mol, model) + +end subroutine test_eeq_dbdr_znooh subroutine test_g_znooh(error) @@ -627,6 +1233,7 @@ subroutine test_g_znooh(error) type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model integer, parameter :: nat = 4 real(wp), parameter :: charge = -1.0_wp @@ -639,17 +1246,19 @@ subroutine test_g_znooh(error) & [3, nat]) call new(mol, num, xyz, charge) - call test_numgrad(error, mol) + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_numgrad(error, mol, model) end subroutine test_g_znooh - subroutine test_dqdr_znooh(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model integer, parameter :: nat = 4 real(wp), parameter :: charge = -1.0_wp @@ -662,9 +1271,401 @@ subroutine test_dqdr_znooh(error) & [3, nat]) call new(mol, num, xyz, charge) - call test_numdqdr(error, mol) + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_numdqdr(error, mol, model) end subroutine test_dqdr_znooh +subroutine test_eeqbc_dadr_mb01(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "01") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_dadr(error, mol, model) + +end subroutine test_eeqbc_dadr_mb01 + +subroutine test_eeqbc_dadL_mb01(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "01") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_dadL(error, mol, model) + +end subroutine test_eeqbc_dadL_mb01 + +subroutine test_eeqbc_dbdr_mb01(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "01") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_dbdr(error, mol, model) + +end subroutine test_eeqbc_dbdr_mb01 + +subroutine test_eeqbc_dbdL_mb01(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "01") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_dbdL(error, mol, model) + +end subroutine test_eeqbc_dbdL_mb01 + +subroutine test_eeqbc_dadr_mb05(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "05") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_dadr(error, mol, model) + +end subroutine test_eeqbc_dadr_mb05 + +subroutine test_eeqbc_dadL_mb05(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "05") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_dadL(error, mol, model) + +end subroutine test_eeqbc_dadL_mb05 + +subroutine test_eeqbc_dbdr_mb05(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "05") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_dbdr(error, mol, model) + +end subroutine test_eeqbc_dbdr_mb05 + +subroutine test_eeqbc_q_mb01(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + real(wp), parameter :: ref(16) = [& + & 4.75783090912440E-1_wp, -4.26540500638442E-2_wp, -3.77871226005535E-1_wp, & + &-9.67376090029522E-2_wp, -1.73364116997142E-1_wp, 1.08660101025683E-1_wp, & + &-1.13628448410420E-1_wp, -3.17939699645693E-1_wp, -2.45655524697400E-1_wp, & + & 1.76106572419156E-1_wp, 1.14510850652006E-1_wp, -1.22241025474265E-1_wp, & + &-1.44595425453640E-2_wp, 2.57782082780412E-1_wp, -1.11777579535162E-1_wp, & + & 4.83486124588080E-1_wp] + + real(wp), allocatable :: qvec(:) + + call get_structure(mol, "MB16-43", "01") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call gen_test(error, mol, model, qref=ref) + + ! Check wrapper functions + allocate (qvec(mol%nat), source=0.0_wp) + call get_charges(model, mol, error, qvec) + if (allocated(error)) return + + if (any(abs(qvec - ref) > thr)) then + call test_failed(error, "Partial charges do not match") + print'(a)', "Charges:" + print'(3es21.14)', qvec + print'(a)', "diff:" + print'(3es21.14)', qvec - ref + end if + if (allocated(error)) return + + qvec = 0.0_wp + call get_eeqbc_charges(mol, error, qvec) + if (allocated(error)) return + + if (any(abs(qvec - ref) > thr)) then + call test_failed(error, "Partial charges do not match") + print'(a)', "Charges:" + print'(3es21.14)', qvec + print'(a)', "diff:" + print'(3es21.14)', qvec - ref + end if + if (allocated(error)) return + +end subroutine test_eeqbc_q_mb01 + +subroutine test_eeqbc_q_mb02(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + real(wp), parameter :: ref(16) = [& + &-7.89571755894845E-2_wp, -1.84724587297173E-1_wp, -1.63060175795952E-2_wp, & + &-2.36115890461711E-1_wp, 5.05729582512203E-1_wp, 1.37556939519704E-1_wp, & + &-2.29048340967271E-2_wp, -4.31722346626804E-2_wp, 2.26466952977883E-1_wp, & + & 1.25047857913714E-1_wp, 6.72899182661252E-3_wp, 3.08986208662492E-1_wp, & + &-3.34344661086462E-1_wp, -3.16758668376149E-2_wp, -5.24170403450005E-2_wp, & + &-3.09898225456160E-1_wp] + + call get_structure(mol, "MB16-43", "02") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call gen_test(error, mol, model, qref=ref) + +end subroutine test_eeqbc_q_mb02 + +subroutine test_eeqbc_q_actinides(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + real(wp), parameter :: ref(17) = [& + & 9.27195802124755E-2_wp, -2.78358027117801E-1_wp, 1.71815557281178E-1_wp, & + & 7.85579953672371E-2_wp, -1.08186262417305E-2_wp, -4.81860290986309E-2_wp, & + & 1.57794666483371E-1_wp, -1.61830258916072E-1_wp, -2.76569765724910E-1_wp, & + & 2.99654899926371E-1_wp, -5.24433579322476E-1_wp, -1.99523360511699E-1_wp, & + &-3.42285450387671E-2_wp, -3.15076271542101E-2_wp, 1.49700940990172E-1_wp, & + & 1.45447393911445E-1_wp, 4.69764784954047E-1_wp] + + ! Molecular structure data + mol%nat = 17 + mol%nid = 17 + mol%id = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, & + & 12, 13, 14, 15, 16, 17] + mol%num = [87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, & + & 98, 99, 100, 101, 102, 103] + mol%xyz = reshape([ & + & 0.98692316414074_wp, 6.12727238368797_wp, -6.67861597188102_wp, & + & 3.63898862390869_wp, 5.12109301182962_wp, 3.01908613326278_wp, & + & 5.14503571563551_wp, -3.97172984617710_wp, 3.82011791828867_wp, & + & 6.71986847575494_wp, 1.71382138402812_wp, 3.92749159076307_wp, & + & 4.13783589704826_wp, -2.10695793491818_wp, 0.19753203068899_wp, & + & 8.97685097698326_wp, -3.08813636191844_wp, -4.45568615593938_wp, & + & 12.5486412940776_wp, -1.77128765259458_wp, 0.59261498922861_wp, & + & 7.82051475868325_wp, -3.97159756604558_wp, -0.53637703616916_wp, & + &-0.43444574624893_wp, -1.69696511583960_wp, -1.65898182093050_wp, & + &-4.71270645149099_wp, -0.11534827468942_wp, 2.84863373521297_wp, & + &-2.52061680335614_wp, 1.82937752749537_wp, -2.10366982879172_wp, & + & 0.13551154616576_wp, 7.99805359235043_wp, -1.55508522619903_wp, & + & 3.91594542499717_wp, -1.72975169129597_wp, -5.07944366756113_wp, & + &-1.03393930231679_wp, 4.69307230054046_wp, 0.02656940927472_wp, & + & 6.20675384557240_wp, 4.24490721493632_wp, -0.71004195169885_wp, & + & 7.04586341131562_wp, 5.20053667939076_wp, -7.51972863675876_wp, & + & 2.01082807362334_wp, 1.34838807211157_wp, -4.70482633508447_wp],& + & [3, 17]) + mol%periodic = [.false.] + + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call gen_test(error, mol, model, qref=ref) + +end subroutine test_eeqbc_q_actinides + +subroutine test_eeqbc_e_mb03(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + real(wp), parameter :: ref(16) = [& + &-6.96992195046228E-2_wp, -1.62155815983893E+0_wp, -1.38060751929644E-3_wp, & + &-9.06342279911342E-1_wp, -1.83281566961757E+0_wp, -1.20333262207652E-1_wp, & + &-6.51187555181622E-1_wp, -3.27410111288548E-3_wp, -8.00565881078213E-3_wp, & + &-2.60385867643294E-2_wp, -9.33285940415006E-1_wp, -1.48859947660327E-1_wp, & + &-7.19456827995756E-1_wp, -9.58311834831915E-2_wp, -1.54672086637309E+0_wp, & + &-1.03483694342593E-5_wp] + + call get_structure(mol, "MB16-43", "03") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call gen_test(error, mol, model, eref=ref) + +end subroutine test_eeqbc_e_mb03 + +subroutine test_eeqbc_e_mb04(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + real(wp), parameter :: ref(16) = [& + &-3.91054587109712E-2_wp, -8.21933095021462E-4_wp, -1.28550631772418E-2_wp, & + &-8.95571658260288E-2_wp, -4.94655224590082E-1_wp, -3.34598696522549E-2_wp, & + &-3.75768676247744E-2_wp, -1.36087478076862E-2_wp, -2.07985587717960E-3_wp, & + &-1.17711924662077E-2_wp, -2.68707428024071E-1_wp, -1.00650791933494E+0_wp, & + &-5.64487253409848E-2_wp, -4.89693252471477E-1_wp, -3.74734977139679E-2_wp, & + &-9.22642011641358E-3_wp] + + call get_structure(mol, "MB16-43", "04") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call gen_test(error, mol, model, eref=ref) + +end subroutine test_eeqbc_e_mb04 + +subroutine test_eeqbc_g_mb05(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "05") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_numgrad(error, mol, model) + +end subroutine test_eeqbc_g_mb05 + +subroutine test_eeqbc_g_mb06(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "06") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_numgrad(error, mol, model) + +end subroutine test_eeqbc_g_mb06 + +subroutine test_eeqbc_s_mb07(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "07") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_numsigma(error, mol, model) + +end subroutine test_eeqbc_s_mb07 + +subroutine test_eeqbc_s_mb08(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "08") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_numsigma(error, mol, model) + +end subroutine test_eeqbc_s_mb08 + +subroutine test_eeqbc_dqdr_mb09(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "09") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_numdqdr(error, mol, model) + +end subroutine test_eeqbc_dqdr_mb09 + +subroutine test_eeqbc_dqdr_mb10(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "10") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_numdqdr(error, mol, model) + +end subroutine test_eeqbc_dqdr_mb10 + +subroutine test_eeqbc_dqdL_mb11(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "11") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_numdqdL(error, mol, model) + +end subroutine test_eeqbc_dqdL_mb11 + +subroutine test_eeqbc_dqdL_mb12(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "MB16-43", "12") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_numdqdL(error, mol, model) + +end subroutine test_eeqbc_dqdL_mb12 end module test_model diff --git a/test/unit/test_pbc.f90 b/test/unit/test_pbc.f90 index 297d9fca..07118ae7 100644 --- a/test/unit/test_pbc.f90 +++ b/test/unit/test_pbc.f90 @@ -14,26 +14,26 @@ ! limitations under the License. module test_pbc - use mctc_env, only : wp - use mctc_env_testing, only : new_unittest, unittest_type, error_type, & + use mctc_env, only: wp + use mctc_env_testing, only: new_unittest, unittest_type, error_type, & & test_failed - use mctc_io_structure, only : structure_type - use mctc_cutoff, only : get_lattice_points - use mstore, only : get_structure - use multicharge_model, only : mchrg_model_type - use multicharge_param, only : new_eeq2019_model + use mctc_io_structure, only: structure_type + use mctc_cutoff, only: get_lattice_points + use mstore, only: get_structure + use multicharge_model, only: mchrg_model_type + use multicharge_model_eeqbc, only: eeqbc_model + use multicharge_param, only: new_eeq2019_model, new_eeqbc2025_model + use multicharge_model_cache, only: cache_container implicit none private public :: collect_pbc - real(wp), parameter :: thr = 1000*epsilon(1.0_wp) + real(wp), parameter :: thr = 1000 * epsilon(1.0_wp) real(wp), parameter :: thr2 = sqrt(epsilon(1.0_wp)) - contains - !> Collect all exported unit tests subroutine collect_pbc(testsuite) @@ -41,22 +41,36 @@ subroutine collect_pbc(testsuite) type(unittest_type), allocatable, intent(out) :: testsuite(:) testsuite = [ & - & new_unittest("charges-cyanamide", test_q_cyanamide), & - & new_unittest("energy-formamide", test_e_formamide), & - & new_unittest("gradient-co2", test_g_co2), & - & new_unittest("sigma-ice", test_s_ice), & - & new_unittest("dqdr-urea", test_dqdr_urea), & - & new_unittest("dqdL-oxacb", test_dqdL_oxacb) & + & new_unittest("eeq-charges-cyanamide", test_eeq_q_cyanamide), & + & new_unittest("eeq-energy-formamide", test_eeq_e_formamide), & + & new_unittest("eeq-dbdr-co2", test_eeq_dbdr_co2), & + & new_unittest("eeq-dbdL-co2", test_eeq_dbdL_co2), & + & new_unittest("eeq-dadr-ice", test_eeq_dadr_ice), & + & new_unittest("eeq-dadL-ice", test_eeq_dadL_ice), & + & new_unittest("eeq-gradient-co2", test_eeq_g_co2), & + & new_unittest("eeq-sigma-ice", test_eeq_s_ice), & + & new_unittest("eeq-dqdr-urea", test_eeq_dqdr_urea), & + & new_unittest("eeq-dqdL-oxacb", test_eeq_dqdL_oxacb), & + & new_unittest("eeqbc-dbdr-co2", test_eeqbc_dbdr_co2), & + & new_unittest("eeqbc-dbdL-co2", test_eeqbc_dbdL_co2), & + & new_unittest("eeqbc-dadr-ice", test_eeqbc_dadr_ice), & + & new_unittest("eeqbc-dadL-ice", test_eeqbc_dadL_ice), & + & new_unittest("eeqbc-gradient-co2", test_eeqbc_g_co2), & + & new_unittest("eeqbc-sigma-ice", test_eeqbc_s_ice), & + & new_unittest("eeqbc-dqdr-urea", test_eeqbc_dqdr_urea), & + & new_unittest("eeqbc-dqdL-oxacb", test_eeqbc_dqdL_oxacb) & & ] end subroutine collect_pbc - -subroutine gen_test(error, mol, qref, eref) +subroutine gen_test(error, mol, model, qref, eref) !> Molecular structure data type(structure_type), intent(in) :: mol + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + !> Reference charges real(wp), intent(in), optional :: qref(:) @@ -66,19 +80,17 @@ subroutine gen_test(error, mol, qref, eref) !> Error handling type(error_type), allocatable, intent(out) :: error - type(mchrg_model_type) :: model real(wp), parameter :: cutoff = 25.0_wp - real(wp), allocatable :: cn(:), trans(:, :) + real(wp), allocatable :: cn(:), qloc(:), trans(:, :) real(wp), allocatable :: energy(:) real(wp), allocatable :: qvec(:) - call new_eeq2019_model(mol, model, error) - if (allocated(error)) return call get_lattice_points(mol%periodic, mol%lattice, cutoff, trans) - allocate(cn(mol%nat)) + allocate(cn(mol%nat), qloc(mol%nat)) call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) if (present(eref)) then allocate(energy(mol%nat)) @@ -88,7 +100,7 @@ subroutine gen_test(error, mol, qref, eref) allocate(qvec(mol%nat)) end if - call model%solve(mol, error, cn, energy=energy, qvec=qvec) + call model%solve(mol, error, cn, qloc, energy=energy, qvec=qvec) if (allocated(error)) return if (present(qref)) then @@ -118,29 +130,30 @@ subroutine gen_test(error, mol, qref, eref) end subroutine gen_test - -subroutine test_numgrad(error, mol) +subroutine test_numgrad(error, mol, model) !> Molecular structure data type(structure_type), intent(inout) :: mol + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + !> Error handling type(error_type), allocatable, intent(out) :: error integer :: iat, ic - type(mchrg_model_type) :: model real(wp), parameter :: cutoff = 25.0_wp real(wp), parameter :: step = 1.0e-6_wp - real(wp), allocatable :: cn(:), dcndr(:, :, :), dcndL(:, :, :), rcov(:), trans(:, :) + real(wp), allocatable :: cn(:), dcndr(:, :, :), dcndL(:, :, :), trans(:, :) + real(wp), allocatable :: qloc(:), dqlocdr(:, :, :), dqlocdL(:, :, :) real(wp), allocatable :: energy(:), gradient(:, :), sigma(:, :) real(wp), allocatable :: numgrad(:, :) real(wp) :: er, el - call new_eeq2019_model(mol, model, error) - if (allocated(error)) return call get_lattice_points(mol%periodic, mol%lattice, cutoff, trans) allocate(cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + & qloc(mol%nat), dqlocdr(3, mol%nat, mol%nat), dqlocdL(3, 3, mol%nat), & & energy(mol%nat), gradient(3, mol%nat), sigma(3, 3), numgrad(3, mol%nat)) energy(:) = 0.0_wp gradient(:, :) = 0.0_wp @@ -149,61 +162,74 @@ subroutine test_numgrad(error, mol) lp: do iat = 1, mol%nat do ic = 1, 3 energy(:) = 0.0_wp + er = 0.0_wp mol%xyz(ic, iat) = mol%xyz(ic, iat) + step call model%ncoord%get_coordination_number(mol, trans, cn) - call model%solve(mol, error, cn, energy=energy) + call model%local_charge(mol, trans, qloc) + call model%solve(mol, error, cn, qloc, energy=energy) if (allocated(error)) exit lp er = sum(energy) energy(:) = 0.0_wp - mol%xyz(ic, iat) = mol%xyz(ic, iat) - 2*step + el = 0.0_wp + mol%xyz(ic, iat) = mol%xyz(ic, iat) - 2 * step call model%ncoord%get_coordination_number(mol, trans, cn) - call model%solve(mol, error, cn, energy=energy) + call model%local_charge(mol, trans, qloc) + call model%solve(mol, error, cn, qloc, energy=energy) if (allocated(error)) exit lp el = sum(energy) mol%xyz(ic, iat) = mol%xyz(ic, iat) + step - numgrad(ic, iat) = 0.5_wp*(er - el)/step + numgrad(ic, iat) = 0.5_wp * (er - el) / step end do end do lp if (allocated(error)) return call model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) energy(:) = 0.0_wp - call model%solve(mol, error, cn, dcndr, dcndL, energy, gradient, sigma) + call model%solve(mol, error, cn, qloc, dcndr, dcndL, & + & dqlocdr, dqlocdL, energy, gradient, sigma) if (allocated(error)) return if (any(abs(gradient(:, :) - numgrad(:, :)) > thr2)) then call test_failed(error, "Derivative of energy does not match") + print'(a)', "gradient:" + print'(3es21.14)', gradient + print'(a)', "numgrad:" + print'(3es21.14)', numgrad + print'(a)', "diff:" + print'(3es21.14)', gradient - numgrad end if end subroutine test_numgrad - -subroutine test_numsigma(error, mol) +subroutine test_numsigma(error, mol, model) !> Molecular structure data type(structure_type), intent(inout) :: mol + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + !> Error handling type(error_type), allocatable, intent(out) :: error integer :: ic, jc - type(mchrg_model_type) :: model real(wp), parameter :: cutoff = 25.0_wp real(wp), parameter :: step = 1.0e-6_wp, unity(3, 3) = reshape(& - & [1, 0, 0, 0, 1, 0, 0, 0, 1], shape(unity)) + & [1, 0, 0, 0, 1, 0, 0, 0, 1], [3, 3]) real(wp), allocatable :: cn(:), dcndr(:, :, :), dcndL(:, :, :), trans(:, :) + real(wp), allocatable :: qloc(:), dqlocdr(:, :, :), dqlocdL(:, :, :) real(wp), allocatable :: energy(:), gradient(:, :) real(wp), allocatable :: lattr(:, :), xyz(:, :) real(wp) :: er, el, eps(3, 3), numsigma(3, 3), sigma(3, 3), lattice(3, 3) - call new_eeq2019_model(mol, model, error) - if (allocated(error)) return call get_lattice_points(mol%periodic, mol%lattice, cutoff, trans) allocate(cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + & qloc(mol%nat), dqlocdr(3, mol%nat, mol%nat), dqlocdL(3, 3, mol%nat), & & energy(mol%nat), gradient(3, mol%nat), xyz(3, mol%nat)) energy(:) = 0.0_wp gradient(:, :) = 0.0_wp @@ -221,17 +247,19 @@ subroutine test_numsigma(error, mol) mol%lattice(:, :) = matmul(eps, lattice) lattr(:, :) = matmul(eps, trans) call model%ncoord%get_coordination_number(mol, lattr, cn) - call model%solve(mol, error, cn, energy=energy) + call model%local_charge(mol, lattr, qloc) + call model%solve(mol, error, cn, qloc, energy=energy) if (allocated(error)) exit lp er = sum(energy) energy(:) = 0.0_wp - eps(jc, ic) = eps(jc, ic) - 2*step + eps(jc, ic) = eps(jc, ic) - 2 * step mol%xyz(:, :) = matmul(eps, xyz) mol%lattice(:, :) = matmul(eps, lattice) lattr(:, :) = matmul(eps, trans) call model%ncoord%get_coordination_number(mol, lattr, cn) - call model%solve(mol, error, cn, energy=energy) + call model%local_charge(mol, lattr, qloc) + call model%solve(mol, error, cn, qloc, energy=energy) if (allocated(error)) exit lp el = sum(energy) @@ -239,101 +267,485 @@ subroutine test_numsigma(error, mol) mol%xyz(:, :) = xyz mol%lattice(:, :) = lattice lattr(:, :) = trans - numsigma(jc, ic) = 0.5_wp*(er - el)/step + numsigma(jc, ic) = 0.5_wp * (er - el) / step end do end do lp if (allocated(error)) return call model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) energy(:) = 0.0_wp - call model%solve(mol, error, cn, dcndr, dcndL, energy, gradient, sigma) + call model%solve(mol, error, cn, qloc, dcndr, dcndL, & + & dqlocdr, dqlocdL, energy, gradient, sigma) if (allocated(error)) return if (any(abs(sigma(:, :) - numsigma(:, :)) > thr2)) then call test_failed(error, "Derivative of energy does not match") + print'(a)', "sigma:" + print'(3es21.14)', sigma + print'(a)', "numgrad:" + print'(3es21.14)', numsigma + print'(a)', "diff:" + print'(3es21.14)', sigma(:, :) - numsigma(:, :) end if end subroutine test_numsigma +subroutine test_dbdr(error, mol, model) + + !> Molecular structure data + type(structure_type), intent(inout) :: mol + + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: iat, ic + real(wp), parameter :: cutoff = 25.0_wp + real(wp), parameter :: step = 1.0e-6_wp + real(wp), allocatable :: cn(:), dcndr(:, :, :), dcndL(:, :, :), trans(:, :) + real(wp), allocatable :: qloc(:), dqlocdr(:, :, :), dqlocdL(:, :, :) + real(wp), allocatable :: dbdr(:, :, :), dbdL(:, :, :) + real(wp), allocatable :: numgrad(:, :, :), xvecr(:), xvecl(:) + type(cache_container), allocatable :: cache + allocate(cache) + + call get_lattice_points(mol%periodic, mol%lattice, cutoff, trans) + + allocate(cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + & qloc(mol%nat), dqlocdr(3, mol%nat, mol%nat), dqlocdL(3, 3, mol%nat), & + & xvecr(mol%nat + 1), xvecl(mol%nat + 1), numgrad(3, mol%nat, mol%nat + 1), & + & dbdr(3, mol%nat, mol%nat + 1), dbdL(3, 3, mol%nat + 1)) + + numgrad = 0.0_wp + + lp: do iat = 1, mol%nat + do ic = 1, 3 + ! Right-hand side + xvecr(:) = 0.0_wp + mol%xyz(ic, iat) = mol%xyz(ic, iat) + step + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_xvec(mol, cache, xvecr) + + ! Left-hand side + xvecl(:) = 0.0_wp + mol%xyz(ic, iat) = mol%xyz(ic, iat) - 2 * step + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_xvec(mol, cache, xvecl) + + mol%xyz(ic, iat) = mol%xyz(ic, iat) + step + numgrad(ic, iat, :) = 0.5_wp * (xvecr(:) - xvecl(:)) / step + end do + end do lp + + ! Analytical gradient + call model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) + call model%update(mol, cache, cn, qloc, dcndr, dcndL, dqlocdr, dqlocdL) + call model%get_xvec(mol, cache, xvecl) ! need to call this for xtmp in cache (eeqbc) + call model%get_xvec_derivs(mol, cache, dbdr, dbdL) + + if (any(abs(dbdr(:, :, :) - numgrad(:, :, :)) > thr2)) then + call test_failed(error, "Derivative of the b vector does not match") + print'(a)', "dbdr:" + print'(3es21.14)', dbdr + print'(a)', "numgrad:" + print'(3es21.14)', numgrad + print'(a)', "diff:" + print'(3es21.14)', dbdr - numgrad + end if + +end subroutine test_dbdr + +subroutine test_dbdL(error, mol, model) + + !> Molecular structure data + type(structure_type), intent(inout) :: mol + + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: iat, ic, jc + real(wp), parameter :: cutoff = 25.0_wp + real(wp), parameter :: step = 1.0e-6_wp, unity(3, 3) = reshape(& + & [1, 0, 0, 0, 1, 0, 0, 0, 1], [3, 3]) + real(wp), allocatable :: cn(:), dcndr(:, :, :), dcndL(:, :, :) + real(wp), allocatable :: qloc(:), dqlocdr(:, :, :), dqlocdL(:, :, :) + real(wp), allocatable :: dbdr(:, :, :), dbdL(:, :, :) + real(wp), allocatable :: numsigma(:, :, :), xvecr(:), xvecl(:) + real(wp), allocatable :: xyz(:, :), lattr(:, :), trans(:, :) + real(wp) :: lattice(3, 3) + real(wp) :: eps(3, 3) + type(cache_container), allocatable :: cache + allocate(cache) + + allocate(cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + & qloc(mol%nat), dqlocdr(3, mol%nat, mol%nat), dqlocdL(3, 3, mol%nat), & + & xvecr(mol%nat + 1), xvecl(mol%nat + 1), numsigma(3, 3, mol%nat + 1), & + & dbdr(3, mol%nat, mol%nat + 1), dbdL(3, 3, mol%nat + 1), xyz(3, mol%nat)) + + call get_lattice_points(mol%periodic, mol%lattice, cutoff, trans) + + numsigma = 0.0_wp + + eps(:, :) = unity + xyz(:, :) = mol%xyz + lattice(:, :) = mol%lattice + lattr = trans + lp: do ic = 1, 3 + do jc = 1, 3 + ! Right-hand side + xvecr(:) = 0.0_wp + eps(jc, ic) = eps(jc, ic) + step + mol%xyz(:, :) = matmul(eps, xyz) + mol%lattice(:, :) = matmul(eps, lattice) + lattr(:, :) = matmul(eps, trans) + call model%ncoord%get_coordination_number(mol, lattr, cn) + call model%local_charge(mol, lattr, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_xvec(mol, cache, xvecr) + + ! Left-hand side + xvecl(:) = 0.0_wp + eps(jc, ic) = eps(jc, ic) - 2 * step + mol%xyz(:, :) = matmul(eps, xyz) + mol%lattice(:, :) = matmul(eps, lattice) + lattr(:, :) = matmul(eps, trans) + call model%ncoord%get_coordination_number(mol, lattr, cn) + call model%local_charge(mol, lattr, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_xvec(mol, cache, xvecl) + + eps(jc, ic) = eps(jc, ic) + step + mol%xyz(:, :) = xyz + mol%lattice(:, :) = lattice + lattr(:, :) = trans + do iat = 1, mol%nat + numsigma(jc, ic, iat) = 0.5_wp * (xvecr(iat) - xvecl(iat)) / step + end do + end do + end do lp + + ! Analytical gradient + call model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) + call model%update(mol, cache, cn, qloc, dcndr, dcndL, dqlocdr, dqlocdL) + call model%get_xvec(mol, cache, xvecl) ! need to call this for xtmp in cache (eeqbc) + call model%get_xvec_derivs(mol, cache, dbdr, dbdL) + + if (any(abs(dbdL(:, :, :) - numsigma(:, :, :)) > thr2)) then + call test_failed(error, "Derivative of the b vector does not match") + print'(a)', "dbdL:" + print'(3es21.14)', dbdL + print'(a)', "numsigma:" + print'(3es21.14)', numsigma + print'(a)', "diff:" + print'(3es21.14)', dbdL - numsigma + end if + +end subroutine test_dbdL + +subroutine test_dadr(error, mol, model) + + !> Molecular structure data + type(structure_type), intent(inout) :: mol + + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: iat, ic, jat, kat + real(wp) :: thr2_local + real(wp), parameter :: cutoff = 25.0_wp + real(wp), parameter :: step = 1.0e-6_wp + real(wp), allocatable :: cn(:) + real(wp), allocatable :: qloc(:) + real(wp), allocatable :: trans(:, :) + real(wp), allocatable :: dcndr(:, :, :), dcndL(:, :, :), dqlocdr(:, :, :), dqlocdL(:, :, :) + real(wp), allocatable :: dadr(:, :, :), dadL(:, :, :), atrace(:, :) + real(wp), allocatable :: qvec(:), numgrad(:, :, :), amatr(:, :), amatl(:, :), numtrace(:, :) + type(cache_container), allocatable :: cache + allocate(cache) + + allocate(cn(mol%nat), qloc(mol%nat), amatr(mol%nat + 1, mol%nat + 1), amatl(mol%nat + 1, mol%nat + 1), & + & dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), dqlocdr(3, mol%nat, mol%nat), & + & dqlocdL(3, 3, mol%nat), dadr(3, mol%nat, mol%nat + 1), dadL(3, 3, mol%nat + 1), & + & atrace(3, mol%nat), numtrace(3, mol%nat), numgrad(3, mol%nat, mol%nat + 1), qvec(mol%nat)) + + ! Set tolerance higher if testing eeqbc model + select type(model) + type is(eeqbc_model) + thr2_local = 3.0_wp * thr2 + class default + thr2_local = thr2 + end select + + call get_lattice_points(mol%periodic, mol%lattice, cutoff, trans) + + ! Obtain the vector of charges + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%solve(mol, error, cn, qloc, qvec=qvec) + if (allocated(error)) return + + numgrad = 0.0_wp + + lp: do iat = 1, mol%nat + do ic = 1, 3 + ! Right-hand side + amatr(:, :) = 0.0_wp + mol%xyz(ic, iat) = mol%xyz(ic, iat) + step + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_coulomb_matrix(mol, cache, amatr) + + ! Left-hand side + amatl(:, :) = 0.0_wp + mol%xyz(ic, iat) = mol%xyz(ic, iat) - 2 * step + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_coulomb_matrix(mol, cache, amatl) + + mol%xyz(ic, iat) = mol%xyz(ic, iat) + step + + do kat = 1, mol%nat + do jat = 1, mol%nat + ! Numerical gradient of the A matrix + numgrad(ic, iat, kat) = 0.5_wp * qvec(jat) * (amatr(kat, jat) - amatl(kat, jat)) / step & + & + numgrad(ic, iat, kat) + end do + end do + end do + end do lp + + ! Analytical gradient + call model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) + call model%update(mol, cache, cn, qloc, dcndr, dcndL, dqlocdr, dqlocdL) + call model%get_coulomb_derivs(mol, cache, qvec, dadr, dadL, atrace) + + ! Add trace of the A matrix + do iat = 1, mol%nat + dadr(:, iat, iat) = atrace(:, iat) + dadr(:, iat, iat) + end do + + ! higher tolerance for numerical gradient + if (any(abs(dadr(:, :, :) - numgrad(:, :, :)) > thr2_local)) then + call test_failed(error, "Derivative of the A matrix does not match") + print'(a)', "dadr:" + print'(3es21.14)', dadr + print'(a)', "numgrad:" + print'(3es21.14)', numgrad + print'(a)', "diff:" + print'(3es21.14)', dadr - numgrad + end if -subroutine test_numdqdr(error, mol) +end subroutine test_dadr + +subroutine test_dadL(error, mol, model) !> Molecular structure data type(structure_type), intent(inout) :: mol + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: ic, jc, iat + real(wp), parameter :: cutoff = 25.0_wp + real(wp), parameter :: step = 1.0e-6_wp, unity(3, 3) = reshape(& + & [1, 0, 0, 0, 1, 0, 0, 0, 1], [3, 3]) + real(wp), allocatable :: cn(:), dcndr(:, :, :), dcndL(:, :, :) + real(wp), allocatable :: qloc(:), dqlocdr(:, :, :), dqlocdL(:, :, :) + real(wp), allocatable :: dadr(:, :, :), dadL(:, :, :), atrace(:, :) + real(wp), allocatable :: xyz(:, :), lattr(:, :), trans(:, :) + real(wp), allocatable :: qvec(:), numsigma(:, :, :), amatr(:, :), amatl(:, :) + real(wp) :: lattice(3, 3) + real(wp) :: eps(3, 3) + type(cache_container), allocatable :: cache + allocate(cache) + + allocate(cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + & qloc(mol%nat), dqlocdr(3, mol%nat, mol%nat), dqlocdL(3, 3, mol%nat), & + & amatr(mol%nat + 1, mol%nat + 1), amatl(mol%nat + 1, mol%nat + 1), & + & dadr(3, mol%nat, mol%nat + 1), dadL(3, 3, mol%nat + 1), atrace(3, mol%nat), & + & numsigma(3, 3, mol%nat + 1), qvec(mol%nat), xyz(3, mol%nat)) + + call get_lattice_points(mol%periodic, mol%lattice, cutoff, trans) + + call model%ncoord%get_coordination_number(mol, trans, cn) + call model%local_charge(mol, trans, qloc) + call model%solve(mol, error, cn, qloc, qvec=qvec) + if (allocated(error)) return + + numsigma = 0.0_wp + + eps(:, :) = unity + xyz(:, :) = mol%xyz + lattice(:, :) = mol%lattice + lattr = trans + lp: do ic = 1, 3 + do jc = 1, 3 + amatr(:, :) = 0.0_wp + eps(jc, ic) = eps(jc, ic) + step + mol%xyz(:, :) = matmul(eps, xyz) + mol%lattice(:, :) = matmul(eps, lattice) + lattr(:, :) = matmul(eps, trans) + call model%ncoord%get_coordination_number(mol, lattr, cn) + call model%local_charge(mol, lattr, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_coulomb_matrix(mol, cache, amatr) + if (allocated(error)) exit lp + + amatl(:, :) = 0.0_wp + eps(jc, ic) = eps(jc, ic) - 2 * step + mol%xyz(:, :) = matmul(eps, xyz) + mol%lattice(:, :) = matmul(eps, lattice) + lattr(:, :) = matmul(eps, trans) + call model%ncoord%get_coordination_number(mol, lattr, cn) + call model%local_charge(mol, lattr, qloc) + call model%update(mol, cache, cn, qloc) + call model%get_coulomb_matrix(mol, cache, amatl) + if (allocated(error)) exit lp + + eps(jc, ic) = eps(jc, ic) + step + mol%xyz(:, :) = xyz + mol%lattice(:, :) = lattice + lattr(:, :) = trans + do iat = 1, mol%nat + ! Numerical sigma of the a matrix + numsigma(jc, ic, :) = 0.5_wp * qvec(iat) * (amatr(iat, :) - amatl(iat, :)) / step + numsigma(jc, ic, :) + end do + end do + end do lp + if (allocated(error)) return + + call model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) + call model%update(mol, cache, cn, qloc, dcndr, dcndL, dqlocdr, dqlocdL) + + call model%get_coulomb_derivs(mol, cache, qvec, dadr, dadL, atrace) + if (allocated(error)) return + + if (any(abs(dadL(:, :, :) - numsigma(:, :, :)) > thr2)) then + call test_failed(error, "Derivative of the A matrix does not match") + print'(a)', "dadL:" + print'(3es21.14)', dadL + print'(a)', "numsigma:" + print'(3es21.14)', numsigma + print'(a)', "diff:" + print'(3es21.14)', dadL - numsigma + end if + +end subroutine test_dadL + +subroutine test_numdqdr(error, mol, model) + + !> Molecular structure data + type(structure_type), intent(inout) :: mol + + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + !> Error handling type(error_type), allocatable, intent(out) :: error integer :: iat, ic - type(mchrg_model_type) :: model real(wp), parameter :: cutoff = 25.0_wp real(wp), parameter :: step = 1.0e-6_wp real(wp), allocatable :: cn(:), dcndr(:, :, :), dcndL(:, :, :), trans(:, :) + real(wp), allocatable :: qloc(:), dqlocdr(:, :, :), dqlocdL(:, :, :) real(wp), allocatable :: ql(:), qr(:), dqdr(:, :, :), dqdL(:, :, :) real(wp), allocatable :: numdr(:, :, :) - call new_eeq2019_model(mol, model, error) - if (allocated(error)) return call get_lattice_points(mol%periodic, mol%lattice, cutoff, trans) allocate(cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + & qloc(mol%nat), dqlocdr(3, mol%nat, mol%nat), dqlocdL(3, 3, mol%nat), & & ql(mol%nat), qr(mol%nat), dqdr(3, mol%nat, mol%nat), dqdL(3, 3, mol%nat), & & numdr(3, mol%nat, mol%nat)) lp: do iat = 1, mol%nat do ic = 1, 3 + qr = 0.0_wp mol%xyz(ic, iat) = mol%xyz(ic, iat) + step call model%ncoord%get_coordination_number(mol, trans, cn) - call model%solve(mol, error, cn, qvec=qr) + call model%local_charge(mol, trans, qloc) + call model%solve(mol, error, cn, qloc, qvec=qr) if (allocated(error)) exit lp - mol%xyz(ic, iat) = mol%xyz(ic, iat) - 2*step + ql = 0.0_wp + mol%xyz(ic, iat) = mol%xyz(ic, iat) - 2 * step call model%ncoord%get_coordination_number(mol, trans, cn) - call model%solve(mol, error, cn, qvec=ql) + call model%local_charge(mol, trans, qloc) + call model%solve(mol, error, cn, qloc, qvec=ql) if (allocated(error)) exit lp mol%xyz(ic, iat) = mol%xyz(ic, iat) + step - numdr(ic, iat, :) = 0.5_wp*(qr - ql)/step + numdr(ic, iat, :) = 0.5_wp * (qr - ql) / step end do end do lp if (allocated(error)) return call model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) - call model%solve(mol, error, cn, dcndr, dcndL, dqdr=dqdr, dqdL=dqdL) + call model%solve(mol, error, cn, qloc, dcndr, dcndL, dqlocdr, dqlocdL, dqdr=dqdr, dqdL=dqdL) if (allocated(error)) return if (any(abs(dqdr(:, :, :) - numdr(:, :, :)) > thr2)) then call test_failed(error, "Derivative of charges does not match") + print'(a)', "dqdr:" + print'(3es21.14)', dqdr + print'(a)', "numdr:" + print'(3es21.14)', numdr + print'(a)', "diff:" + print'(3es21.14)', dqdr - numdr end if end subroutine test_numdqdr - -subroutine test_numdqdL(error, mol) +subroutine test_numdqdL(error, mol, model) !> Molecular structure data type(structure_type), intent(inout) :: mol + !> Electronegativity equilibration model + class(mchrg_model_type), intent(in) :: model + !> Error handling type(error_type), allocatable, intent(out) :: error integer :: ic, jc - type(mchrg_model_type) :: model real(wp), parameter :: cutoff = 25.0_wp real(wp), parameter :: step = 1.0e-6_wp, unity(3, 3) = reshape(& - & [1, 0, 0, 0, 1, 0, 0, 0, 1], shape(unity)) + & [1, 0, 0, 0, 1, 0, 0, 0, 1], [3, 3]) real(wp), allocatable :: cn(:), dcndr(:, :, :), dcndL(:, :, :), trans(:, :) + real(wp), allocatable :: qloc(:), dqlocdr(:, :, :), dqlocdL(:, :, :) real(wp), allocatable :: qr(:), ql(:), dqdr(:, :, :), dqdL(:, :, :) real(wp), allocatable :: lattr(:, :), xyz(:, :), numdL(:, :, :) real(wp) :: eps(3, 3), lattice(3, 3) - call new_eeq2019_model(mol, model, error) - if (allocated(error)) return call get_lattice_points(mol%periodic, mol%lattice, cutoff, trans) allocate(cn(mol%nat), dcndr(3, mol%nat, mol%nat), dcndL(3, 3, mol%nat), & + & qloc(mol%nat), dqlocdr(3, mol%nat, mol%nat), dqlocdL(3, 3, mol%nat), & & qr(mol%nat), ql(mol%nat), dqdr(3, mol%nat, mol%nat), dqdL(3, 3, mol%nat), & & xyz(3, mol%nat), numdL(3, 3, mol%nat)) @@ -343,49 +755,61 @@ subroutine test_numdqdL(error, mol) lattr = trans lp: do ic = 1, 3 do jc = 1, 3 + qr = 0.0_wp + ql = 0.0_wp eps(jc, ic) = eps(jc, ic) + step mol%xyz(:, :) = matmul(eps, xyz) mol%lattice(:, :) = matmul(eps, lattice) lattr(:, :) = matmul(eps, trans) call model%ncoord%get_coordination_number(mol, lattr, cn) - call model%solve(mol, error, cn, qvec=qr) + call model%local_charge(mol, lattr, qloc) + call model%solve(mol, error, cn, qloc, qvec=qr) if (allocated(error)) exit lp - eps(jc, ic) = eps(jc, ic) - 2*step + eps(jc, ic) = eps(jc, ic) - 2 * step mol%xyz(:, :) = matmul(eps, xyz) mol%lattice(:, :) = matmul(eps, lattice) lattr(:, :) = matmul(eps, trans) call model%ncoord%get_coordination_number(mol, lattr, cn) - call model%solve(mol, error, cn, qvec=ql) + call model%local_charge(mol, lattr, qloc) + call model%solve(mol, error, cn, qloc, qvec=ql) if (allocated(error)) exit lp eps(jc, ic) = eps(jc, ic) + step mol%xyz(:, :) = xyz mol%lattice(:, :) = lattice lattr(:, :) = trans - numdL(jc, ic, :) = 0.5_wp*(qr - ql)/step + numdL(jc, ic, :) = 0.5_wp * (qr - ql) / step end do end do lp if (allocated(error)) return call model%ncoord%get_coordination_number(mol, trans, cn, dcndr, dcndL) + call model%local_charge(mol, trans, qloc, dqlocdr, dqlocdL) - call model%solve(mol, error, cn, dcndr, dcndL, dqdr=dqdr, dqdL=dqdL) + call model%solve(mol, error, cn, qloc, dcndr, dcndL, & + & dqlocdr, dqlocdL, dqdr=dqdr, dqdL=dqdL) if (allocated(error)) return if (any(abs(dqdL(:, :, :) - numdL(:, :, :)) > thr2)) then call test_failed(error, "Derivative of charges does not match") + print'(a)', "dqdL:" + print'(3es21.14)', dqdL + print'(a)', "numdL:" + print'(3es21.14)', numdL + print'(a)', "diff:" + print'(3es21.14)', dqdL - numdL end if end subroutine test_numdqdL - -subroutine test_q_cyanamide(error) +subroutine test_eeq_q_cyanamide(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model real(wp), parameter :: ref(40) = [& & 3.47274007973765E-1_wp, 3.47273017259661E-1_wp, 3.47276806231462E-1_wp, & & 3.47267235121650E-1_wp, 3.47288751410308E-1_wp, 3.47296840650318E-1_wp, & @@ -395,91 +819,282 @@ subroutine test_q_cyanamide(error) & 3.45903770121699E-1_wp, 3.58996736955583E-1_wp, 3.58987991603151E-1_wp, & & 3.59000859720791E-1_wp, 3.58990960169615E-1_wp, 3.58990422147650E-1_wp, & & 3.58997842028106E-1_wp, 3.58997124263551E-1_wp, 3.59001728635141E-1_wp, & - &-5.86637659146611E-1_wp,-5.86601835343945E-1_wp,-5.86625078062709E-1_wp, & - &-5.86579999312624E-1_wp,-5.86654394920376E-1_wp,-5.86669360667441E-1_wp, & - &-5.86667481028248E-1_wp,-5.86674873278027E-1_wp,-4.65529092171338E-1_wp, & - &-4.65527713392387E-1_wp,-4.65546450764424E-1_wp,-4.65540905286785E-1_wp, & - &-4.65529860758785E-1_wp,-4.65533757413217E-1_wp,-4.65527683275370E-1_wp, & + &-5.86637659146611E-1_wp, -5.86601835343945E-1_wp, -5.86625078062709E-1_wp, & + &-5.86579999312624E-1_wp, -5.86654394920376E-1_wp, -5.86669360667441E-1_wp, & + &-5.86667481028248E-1_wp, -5.86674873278027E-1_wp, -4.65529092171338E-1_wp, & + &-4.65527713392387E-1_wp, -4.65546450764424E-1_wp, -4.65540905286785E-1_wp, & + &-4.65529860758785E-1_wp, -4.65533757413217E-1_wp, -4.65527683275370E-1_wp, & &-4.65527691475100E-1_wp] call get_structure(mol, "X23", "cyanamide") - call gen_test(error, mol, qref=ref) - -end subroutine test_q_cyanamide + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call gen_test(error, mol, model, qref=ref) +end subroutine test_eeq_q_cyanamide -subroutine test_e_formamide(error) +subroutine test_eeq_e_formamide(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model real(wp), parameter :: ref(24) = [& & 4.01878116759118E-1_wp, 4.01884779867146E-1_wp, 4.01836430415694E-1_wp, & & 4.01859412981015E-1_wp, 4.30132679242368E-1_wp, 4.30105708698129E-1_wp, & & 4.30085668404029E-1_wp, 4.30108945050621E-1_wp, 1.90400193163051E-1_wp, & & 1.90401822781550E-1_wp, 1.90404130981992E-1_wp, 1.90407447306916E-1_wp, & & 3.33868335196572E-1_wp, 3.33848682655264E-1_wp, 3.33875977331594E-1_wp, & - & 3.33893030511429E-1_wp,-8.35635584733599E-1_wp,-8.35614926719694E-1_wp, & - &-8.35542684637248E-1_wp,-8.35589488474056E-1_wp,-6.31079122091240E-1_wp, & - &-6.31059677948463E-1_wp,-6.31085206912995E-1_wp,-6.31081747027041E-1_wp] + & 3.33893030511429E-1_wp, -8.35635584733599E-1_wp, -8.35614926719694E-1_wp, & + &-8.35542684637248E-1_wp, -8.35589488474056E-1_wp, -6.31079122091240E-1_wp, & + &-6.31059677948463E-1_wp, -6.31085206912995E-1_wp, -6.31081747027041E-1_wp] call get_structure(mol, "X23", "formamide") - call gen_test(error, mol, eref=ref) + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call gen_test(error, mol, model, eref=ref) -end subroutine test_e_formamide +end subroutine test_eeq_e_formamide + +subroutine test_eeq_dbdr_co2(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "X23", "CO2") + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_dbdr(error, mol, model) +end subroutine test_eeq_dbdr_co2 -subroutine test_g_co2(error) +subroutine test_eeq_dbdL_co2(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model call get_structure(mol, "X23", "CO2") - call test_numgrad(error, mol) + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_dbdL(error, mol, model) + +end subroutine test_eeq_dbdL_co2 + +subroutine test_eeq_dadr_ice(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error -end subroutine test_g_co2 + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "ICE10", "vi") + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_dadr(error, mol, model) +end subroutine test_eeq_dadr_ice -subroutine test_s_ice(error) +subroutine test_eeq_dadL_ice(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model call get_structure(mol, "ICE10", "vi") - call test_numsigma(error, mol) + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_dadL(error, mol, model) + +end subroutine test_eeq_dadL_ice + +subroutine test_eeq_g_co2(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model -end subroutine test_s_ice + call get_structure(mol, "X23", "CO2") + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_numgrad(error, mol, model) +end subroutine test_eeq_g_co2 -subroutine test_dqdr_urea(error) +subroutine test_eeq_s_ice(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model - call get_structure(mol, "X23", "urea") - call test_numdqdr(error, mol) + call get_structure(mol, "ICE10", "vi") + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_numsigma(error, mol, model) + +end subroutine test_eeq_s_ice + +subroutine test_eeq_dqdr_urea(error) -end subroutine test_dqdr_urea + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "X23", "urea") + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_numdqdr(error, mol, model) +end subroutine test_eeq_dqdr_urea -subroutine test_dqdL_oxacb(error) +subroutine test_eeq_dqdL_oxacb(error) !> Error handling type(error_type), allocatable, intent(out) :: error type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model call get_structure(mol, "X23", "oxacb") - call test_numdqdL(error, mol) + call new_eeq2019_model(mol, model, error) + if (allocated(error)) return + call test_numdqdL(error, mol, model) -end subroutine test_dqdL_oxacb +end subroutine test_eeq_dqdL_oxacb + +subroutine test_eeqbc_dbdr_co2(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "X23", "CO2") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_dbdr(error, mol, model) + +end subroutine test_eeqbc_dbdr_co2 + +subroutine test_eeqbc_dbdL_co2(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "X23", "CO2") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_dbdL(error, mol, model) + +end subroutine test_eeqbc_dbdL_co2 + +subroutine test_eeqbc_dadr_ice(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "ICE10", "vi") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_dadr(error, mol, model) + +end subroutine test_eeqbc_dadr_ice + +subroutine test_eeqbc_dadL_ice(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "ICE10", "vi") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_dadL(error, mol, model) + +end subroutine test_eeqbc_dadL_ice + +subroutine test_eeqbc_g_co2(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "X23", "CO2") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_numgrad(error, mol, model) + +end subroutine test_eeqbc_g_co2 + +subroutine test_eeqbc_s_ice(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "ICE10", "vi") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_numsigma(error, mol, model) + +end subroutine test_eeqbc_s_ice + +subroutine test_eeqbc_dqdr_urea(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "X23", "urea") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_numdqdr(error, mol, model) + +end subroutine test_eeqbc_dqdr_urea + +subroutine test_eeqbc_dqdL_oxacb(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(structure_type) :: mol + class(mchrg_model_type), allocatable :: model + + call get_structure(mol, "X23", "oxacb") + call new_eeqbc2025_model(mol, model, error) + if (allocated(error)) return + call test_numdqdL(error, mol, model) +end subroutine test_eeqbc_dqdL_oxacb end module test_pbc diff --git a/test/unit/test_wignerseitz.f90 b/test/unit/test_wignerseitz.f90 index 94574711..aada53f7 100644 --- a/test/unit/test_wignerseitz.f90 +++ b/test/unit/test_wignerseitz.f90 @@ -14,25 +14,23 @@ ! limitations under the License. module test_wignerseitz - use mctc_env, only : wp - use mctc_env_testing, only : new_unittest, unittest_type, error_type, check, & + use mctc_env, only: wp + use mctc_env_testing, only: new_unittest, unittest_type, error_type, check, & & test_failed - use mctc_io_structure, only : structure_type - use mstore, only : get_structure - use multicharge_cutoff, only : get_lattice_points + use mctc_io_structure, only: structure_type + use mctc_cutoff, only: get_lattice_points + use mstore, only: get_structure use multicharge_wignerseitz implicit none private public :: collect_wignerseitz - real(wp), parameter :: thr = 100*epsilon(1.0_wp) + real(wp), parameter :: thr = 100 * epsilon(1.0_wp) real(wp), parameter :: thr2 = sqrt(epsilon(1.0_wp)) - contains - !> Collect all exported unit tests subroutine collect_wignerseitz(testsuite) @@ -48,7 +46,6 @@ subroutine collect_wignerseitz(testsuite) end subroutine collect_wignerseitz - subroutine test_latticepoints_0d(error) !> Error handling @@ -78,7 +75,6 @@ subroutine test_latticepoints_0d(error) end subroutine test_latticepoints_0d - subroutine test_latticepoints_3d(error) !> Error handling @@ -108,7 +104,6 @@ subroutine test_latticepoints_3d(error) end subroutine test_latticepoints_3d - subroutine test_wsc_0d(error) !> Error handling @@ -129,7 +124,6 @@ subroutine test_wsc_0d(error) end subroutine test_wsc_0d - subroutine test_wsc_3d(error) !> Error handling @@ -150,5 +144,4 @@ subroutine test_wsc_3d(error) end subroutine test_wsc_3d - end module test_wignerseitz