From 6b8a4e9172e0353ac63ff70e12d8a6a5e6610071 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 19 Aug 2024 05:11:55 +0200 Subject: [PATCH 001/374] rmsd module to make permutational invariant rmsd available --- src/ls_rmsd.f90 | 7 +-- src/rmsd_module.f90 | 128 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 132 insertions(+), 3 deletions(-) create mode 100644 src/rmsd_module.f90 diff --git a/src/ls_rmsd.f90 b/src/ls_rmsd.f90 index 54bedcc6..63d04c83 100644 --- a/src/ls_rmsd.f90 +++ b/src/ls_rmsd.f90 @@ -95,7 +95,7 @@ subroutine rmsd(n,coord1,coord2,option,U,x_center,y_center, & real(dp),dimension(3,3) :: Rmatrix real(dp),dimension(4,4) :: S real(dp),dimension(4) :: q - real(dp) :: tmp(3) + real(dp) :: tmp(3),ndble integer :: io ! make copies of the original coordinates @@ -105,11 +105,12 @@ subroutine rmsd(n,coord1,coord2,option,U,x_center,y_center, & ! calculate the barycenters, centroidal coordinates, and the norms x_norm = 0.0_dp y_norm = 0.0_dp + ndbl = 1.0_dp / dble(n) do i = 1,3 xi(:) = x(i,:) yi(:) = y(i,:) - x_center(i) = sum(xi(1:n)) / dble(n) - y_center(i) = sum(yi(1:n)) / dble(n) + x_center(i) = sum(xi(1:n)) * ndble + y_center(i) = sum(yi(1:n)) * ndble xi(:) = xi(:) - x_center(i) yi(:) = yi(:) - y_center(i) x(i,:) = xi(:) diff --git a/src/rmsd_module.f90 b/src/rmsd_module.f90 new file mode 100644 index 00000000..488e33df --- /dev/null +++ b/src/rmsd_module.f90 @@ -0,0 +1,128 @@ + + +module rmsd_module +!***************************************** +!* Module that implements a more +!* modern interface to calculating RMSDs +!***************************************** + use crest_parameters + use ls_rmsd, only: rmsd_classic => rmsd + use strucrd + implicit none + private + + public :: rmsd + + + real(wp),parameter :: bigval = huge(bigval) + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + +function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) +!************************************************************************ +!* function rmsd +!* Calculate the molecular RMSD via a quaternion algorithm +!* +!* Optional arguments are +!* mask - boolean array to select a substructure for RMSD calculation +!* scratch - workspace to create the substructures +!* rotmat - rotation matrix as return argument +!* gradient - Cartesian gradient of the RMSD +!************************************************************************ + implicit none + real(wp) :: rmsdval + type(coord),intent(in) :: ref + type(coord),intent(in) :: mol + !> OPTIONAL arguments + logical,intent(in),optional :: mask(ref%nat) + real(wp),intent(inout),target,optional :: scratch(3,ref%nat,2) + real(wp),intent(out),optional :: rotmat(3,3) + real(wp),intent(out),target,optional :: gradient(3,ref%nat) + !> variables + real(wp) :: x_center(3),y_center(3),Udum(3,3),gdum(3,3) + integer :: nat,getrotmat + real(wp),allocatable :: tmpscratch(:,:,:) + logical :: getgrad + real(wp),pointer :: grdptr !(:,:) + real(wp),pointer :: scratchptr !(:,:,:) + integer :: ic,k + + !> initialize to large value + rmsdval = bigval + !> check structure consistency + if(mol%nat .ne. ref%nat) return + + !> get rotation matrix? + getrotmat = 0 + if(present(rotmat)) getrotmat = 1 + + !> get gradient? + if(present(gradient))then + getgrad = .true. + gradient(:,:) = 0.0_wp + grdptr => gradient + else + getgrad = .false. + grdptr => gdum + endif + +!>--- substructure? + if(present(mask))then + nat = count(mask(:)) + !> scratch workspace to use? + if(present(scratch))then + scratchptr => scratch + else + allocate(tmpscratch(3,nat,2)) + scratchptr => tmpscratch + endif + + !> do the mapping + k=0 + do ic=1,ref%nat + if(mask(ic))then + k=k+1 + scratchptr(1:3,k,1) = mol%xyz(1:3,ic) + scratchptr(1:3,k,2) = ref%xyz(1:3,ic) + endif + enddo + + !> calculate + call rmsd_classic(nat, scratchptr(1:3,1:nat,1), scratchptr(1:3,1:nat,2), & + & getrotmat, Udum, x_center, y_center, rmsdval, & + & getgrad, grdptr) + + !> go backwards through gradient (if necessary) to restore atom order + if(getgrad)then + k=nat + do ic=nat,1,-1 + if(mask(ic))then + grdptr(1:3,ic) = grdptr(1:3,k) + grdptr(1:3,k) = 0.0_wp + k=k-1 + endif + enddo + endif + + deallocate(scratchptr) + if(allocated(tmpscratch)) deallocate(tmpscratch) + + else +!>--- standard calculation + call rmsd_classic(ref%nat,mol%xyz,ref%xyz, & + & getrotmat, Udum, x_center, y_center, rmsdval, & + & getgrad, grdptr) + endif + + !> pass on rotation matrix if asked for + if(getrotmat > 0) rotmat = Udum + +end function rmsd + +!========================================================================================! +!========================================================================================! +end module rmsd_module From 9ccca28546cf15fb4b6c2072b5df0ada424d6a4b Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 25 Aug 2024 02:14:08 +0200 Subject: [PATCH 002/374] typo fix --- src/ls_rmsd.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ls_rmsd.f90 b/src/ls_rmsd.f90 index 63d04c83..25585e10 100644 --- a/src/ls_rmsd.f90 +++ b/src/ls_rmsd.f90 @@ -105,7 +105,7 @@ subroutine rmsd(n,coord1,coord2,option,U,x_center,y_center, & ! calculate the barycenters, centroidal coordinates, and the norms x_norm = 0.0_dp y_norm = 0.0_dp - ndbl = 1.0_dp / dble(n) + ndble = 1.0_dp / dble(n) do i = 1,3 xi(:) = x(i,:) yi(:) = y(i,:) From d038f6e8e7f277bfe08d34df240939dd726ebc7a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 25 Aug 2024 20:45:14 +0200 Subject: [PATCH 003/374] CMake config: let tblite be found from modified fork (if git submodule was not initialized) --- config/modules/Findtblite.cmake | 6 ++++-- config/modules/crest-utils.cmake | 10 ++++++++-- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/config/modules/Findtblite.cmake b/config/modules/Findtblite.cmake index f8fbf600..eb399f83 100644 --- a/config/modules/Findtblite.cmake +++ b/config/modules/Findtblite.cmake @@ -16,7 +16,9 @@ set(_lib "tblite") set(_pkg "TBLITE") -set(_url "https://github.com/tblite/tblite") +#set(_url "https://github.com/tblite/tblite") +set(_url "https://github.com/pprcht/tblite") +set(_branch "xtb_solvation") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") @@ -27,7 +29,7 @@ include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") set(temp_with_tests ${WITH_TESTS}) # Save the current value of WITH_TESTS set(WITH_TESTS FALSE CACHE BOOL "Temporarily disable tests for the tblite subproject" FORCE) set(WITH_API FALSE) -crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}") +crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}" "${_branch}") set(found FALSE) if(TARGET "tblite::tblite") diff --git a/config/modules/crest-utils.cmake b/config/modules/crest-utils.cmake index 375714a2..340d26e4 100644 --- a/config/modules/crest-utils.cmake +++ b/config/modules/crest-utils.cmake @@ -24,10 +24,16 @@ macro( methods url ) + + if(NOT DEFINED ARGV3) + set(branch "HEAD") # Default to HEAD if branch is not provided + else() + set(branch "${ARGV3}") # Use the provided branch + endif() + string(TOLOWER "${package}" _pkg_lc) string(TOUPPER "${package}" _pkg_uc) - # iterate through lookup types in order foreach(method ${methods}) @@ -112,7 +118,7 @@ macro( FetchContent_Declare( "${_pkg_lc}" GIT_REPOSITORY "${url}" - GIT_TAG "HEAD" + GIT_TAG "${branch}" ) FetchContent_MakeAvailable("${_pkg_lc}") From 428340dd2bb92800b32cd7168964708932d69bc8 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 28 Aug 2024 17:50:41 +0200 Subject: [PATCH 004/374] Increase version number --- CMakeLists.txt | 2 +- meson.build | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index a470301f..4a7ef079 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -27,7 +27,7 @@ endif() project( crest LANGUAGES "C" "Fortran" - VERSION 3.0.2 + VERSION 3.1.0 DESCRIPTION "A tool for the exploration of low-energy chemical space" ) diff --git a/meson.build b/meson.build index 22a016de..77be2681 100644 --- a/meson.build +++ b/meson.build @@ -17,7 +17,7 @@ project( 'crest', 'fortran', 'c', - version: '3.0.2', + version: '3.1.0', license: 'LGPL-3.0-or-later', meson_version: '>=0.63', default_options: [ From 0a52a36915e868f4db51d76a24b26f57104fe61a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 29 Aug 2024 16:38:59 +0200 Subject: [PATCH 005/374] Work on permutation invariant RMSD routines --- src/CMakeLists.txt | 1 + src/{rmsd_module.f90 => irmsd_module.f90} | 78 +++++++++++++++++++++-- 2 files changed, 72 insertions(+), 7 deletions(-) rename src/{rmsd_module.f90 => irmsd_module.f90} (61%) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 49c591a2..427a5244 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -57,6 +57,7 @@ list(APPEND srcs "${dir}/internals.f90" "${dir}/internals2.f90" "${dir}/iomod.F90" + "${dir}/irmsd_module.f90" "${dir}/legacy_wrappers.f90" "${dir}/ls_rmsd.f90" "${dir}/marqfit.f90" diff --git a/src/rmsd_module.f90 b/src/irmsd_module.f90 similarity index 61% rename from src/rmsd_module.f90 rename to src/irmsd_module.f90 index 488e33df..4ec788a0 100644 --- a/src/rmsd_module.f90 +++ b/src/irmsd_module.f90 @@ -1,6 +1,6 @@ -module rmsd_module +module irmsd_module !***************************************** !* Module that implements a more !* modern interface to calculating RMSDs @@ -16,12 +16,44 @@ module rmsd_module real(wp),parameter :: bigval = huge(bigval) + + public :: rmsd_cache + type :: rmsd_cache +!**************************************************** +!* cache implementation to avoid repeated allocation +!* and enable shared-memory parallelism +!**************************************************** + real(wp),allocatable :: xyzscratch(:,:,:) + integer,allocatable :: rankscratch(:,:) + integer,allocatable :: orderscratch(:) + logical,allocatable :: assignedscratch(:) + contains + procedure :: allocate => allocate_rmsd_cache + end type rmsd_cache + + !========================================================================================! !========================================================================================! contains !> MODULE PROCEDURES START HERE !========================================================================================! !========================================================================================! + + subroutine allocate_rmsd_cache(self,nat) + implicit none + class(rmsd_cache),intent(inout) :: self + integer,intent(in) :: nat + if(allocated(self%xyzscratch)) deallocate(self%xyzscratch) + if(allocated(self%rankscratch)) deallocate(self%rankscratch) + if(allocated(self%orderscratch)) deallocate(self%orderscratch) + if(allocated(self%assignedscratch)) deallocate(self%assignedscratch) + allocate(self%assignedscratch(nat), source=.false.) + allocate(self%orderscratch(nat), source=0) + allocate(self%rankscratch(nat,2), source=0) + allocate(self%xyzscratch(3,nat,2), source=0.0_wp) + end subroutine allocate_rmsd_cache + + function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) !************************************************************************ !* function rmsd @@ -43,12 +75,13 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) real(wp),intent(out),optional :: rotmat(3,3) real(wp),intent(out),target,optional :: gradient(3,ref%nat) !> variables - real(wp) :: x_center(3),y_center(3),Udum(3,3),gdum(3,3) + real(wp) :: x_center(3),y_center(3),Udum(3,3) + real(wp),target :: gdum(3,3) integer :: nat,getrotmat - real(wp),allocatable :: tmpscratch(:,:,:) + real(wp),allocatable,target :: tmpscratch(:,:,:) logical :: getgrad - real(wp),pointer :: grdptr !(:,:) - real(wp),pointer :: scratchptr !(:,:,:) + real(wp),pointer :: grdptr(:,:) + real(wp),pointer :: scratchptr(:,:,:) integer :: ic,k !> initialize to large value @@ -112,7 +145,7 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) if(allocated(tmpscratch)) deallocate(tmpscratch) else -!>--- standard calculation +!>--- standard calculation (Quarternion algorithm) call rmsd_classic(ref%nat,mol%xyz,ref%xyz, & & getrotmat, Udum, x_center, y_center, rmsdval, & & getgrad, grdptr) @@ -124,5 +157,36 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) end function rmsd !========================================================================================! + +subroutine min_rmsd(ref,mol,rcache,rmsdout) + implicit none + !> IN & OUTPUT + type(coord),intent(in) :: ref + type(coord),intent(inout) :: mol + type(rmsd_cache),intent(inout),optional,target :: rcache + real(wp),intent(out),optional :: rmsdout + + !> LOCAL + type(rmsd_cache),pointer :: cptr + type(rmsd_cache),allocatable,target :: local_rcache + integer :: natmax + + + if(present(rcache))then + cptr => rcache + else + allocate(local_rcache) + natmax = max(ref%nat,mol%nat) + call local_rcache%allocate(natmax) + cptr => local_rcache + endif + + + + +end subroutine min_rmsd + +!========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Date: Thu, 29 Aug 2024 22:45:41 +0200 Subject: [PATCH 006/374] Move sorting-related routines to separate directory --- src/CMakeLists.txt | 13 +- src/meson.build | 12 +- src/minitools.f90 | 23 +-- src/sorting/CMakeLists.txt | 40 +++++ src/{ => sorting}/canonical.f90 | 0 src/{ => sorting}/ccegen.f90 | 0 src/{ => sorting}/cregen.f90 | 0 src/{ => sorting}/ensemblecomp.f90 | 0 src/sorting/hungarian.f90 | 266 +++++++++++++++++++++++++++++ src/{ => sorting}/irmsd_module.f90 | 154 ++++++++--------- src/{ => sorting}/ls_rmsd.f90 | 0 src/sorting/meson.build | 30 ++++ src/{ => sorting}/quicksort.f90 | 0 src/{ => sorting}/rotcompare.f90 | 0 src/{ => sorting}/sortens.f90 | 0 src/{ => sorting}/zdata.f90 | 0 src/{ => sorting}/ztopology.f90 | 0 17 files changed, 429 insertions(+), 109 deletions(-) create mode 100644 src/sorting/CMakeLists.txt rename src/{ => sorting}/canonical.f90 (100%) rename src/{ => sorting}/ccegen.f90 (100%) rename src/{ => sorting}/cregen.f90 (100%) rename src/{ => sorting}/ensemblecomp.f90 (100%) create mode 100644 src/sorting/hungarian.f90 rename src/{ => sorting}/irmsd_module.f90 (58%) rename src/{ => sorting}/ls_rmsd.f90 (100%) create mode 100644 src/sorting/meson.build rename src/{ => sorting}/quicksort.f90 (100%) rename src/{ => sorting}/rotcompare.f90 (100%) rename src/{ => sorting}/sortens.f90 (100%) rename src/{ => sorting}/zdata.f90 (100%) rename src/{ => sorting}/ztopology.f90 (100%) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 427a5244..5d22fce6 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -28,7 +28,7 @@ add_subdirectory("discretize") add_subdirectory("entropy") add_subdirectory("legacy_algos") add_subdirectory("msreact") - +add_subdirectory("sorting") set(dir "${CMAKE_CURRENT_SOURCE_DIR}") @@ -37,17 +37,13 @@ list(APPEND srcs "${dir}/axis_module.f90" "${dir}/biasmerge.f90" "${dir}/bondconstraint.f90" - "${dir}/canonical.f90" - "${dir}/ccegen.f90" "${dir}/choose_settings.f90" "${dir}/classes.f90" "${dir}/cleanup.f90" "${dir}/cn.f90" "${dir}/compress.f90" "${dir}/confparse.f90" - "${dir}/cregen.f90" "${dir}/crest_pars.f90" - "${dir}/ensemblecomp.f90" "${dir}/eval_timer.f90" "${dir}/filemod.f90" "${dir}/flexi.F90" @@ -57,9 +53,7 @@ list(APPEND srcs "${dir}/internals.f90" "${dir}/internals2.f90" "${dir}/iomod.F90" - "${dir}/irmsd_module.f90" "${dir}/legacy_wrappers.f90" - "${dir}/ls_rmsd.f90" "${dir}/marqfit.f90" "${dir}/minitools.f90" "${dir}/miscdata.f90" @@ -68,16 +62,13 @@ list(APPEND srcs "${dir}/printouts.f90" "${dir}/prmat.f90" "${dir}/propcalc.f90" - "${dir}/quicksort.f90" "${dir}/readl.f90" "${dir}/restartlog.f90" - "${dir}/rotcompare.f90" "${dir}/scratch.f90" "${dir}/sdfio.f90" "${dir}/select.f90" "${dir}/signal.c" "${dir}/sigterm.f90" - "${dir}/sortens.f90" "${dir}/strucreader.f90" "${dir}/symmetry2.f90" "${dir}/symmetry_i.c" @@ -85,8 +76,6 @@ list(APPEND srcs "${dir}/trackorigin.f90" "${dir}/utilmod.f90" "${dir}/wallsetup.f90" - "${dir}/zdata.f90" - "${dir}/ztopology.f90" ) list(APPEND prog diff --git a/src/meson.build b/src/meson.build index 1fd7359b..39e69f30 100644 --- a/src/meson.build +++ b/src/meson.build @@ -27,24 +27,20 @@ subdir('discretize') subdir('entropy') subdir('legacy_algos') subdir('msreact') - +subdir('sorting') srcs += files( 'atmasses.f90', 'axis_module.f90', 'biasmerge.f90', 'bondconstraint.f90', - 'canonical.f90', - 'ccegen.f90', 'choose_settings.f90', 'classes.f90', 'cleanup.f90', 'cn.f90', 'compress.f90', 'confparse.f90', - 'cregen.f90', 'crest_pars.f90', - 'ensemblecomp.f90', 'eval_timer.f90', 'filemod.f90', 'flexi.F90', @@ -55,7 +51,6 @@ srcs += files( 'internals2.f90', 'iomod.F90', 'legacy_wrappers.f90', - 'ls_rmsd.f90', 'marqfit.f90', 'minitools.f90', 'miscdata.f90', @@ -64,16 +59,13 @@ srcs += files( 'printouts.f90', 'prmat.f90', 'propcalc.f90', - 'quicksort.f90', 'readl.f90', 'restartlog.f90', - 'rotcompare.f90', 'scratch.f90', 'sdfio.f90', 'select.f90', 'signal.c', 'sigterm.f90', - 'sortens.f90', 'strucreader.f90', 'symmetry2.f90', 'symmetry_i.c', @@ -81,8 +73,6 @@ srcs += files( 'trackorigin.f90', 'utilmod.f90', 'wallsetup.f90', - 'zdata.f90', - 'ztopology.f90', ) prog += files( diff --git a/src/minitools.f90 b/src/minitools.f90 index a6be69f2..980ebeea 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -585,20 +585,23 @@ end function quick_rmsd subroutine quick_rmsd_tool(fname1,fname2,heavy) use crest_parameters use strucrd + use irmsd_module implicit none - character(len=*) :: fname1 - character(len=*) :: fname2 - logical :: heavy - type(coord) :: mol1 + character(len=*),intent(in) :: fname1 + character(len=*),intent(in) :: fname2 + logical,intent(in) :: heavy + type(coord) :: mol,ref real(wp) :: rmsdval - real(wp) :: quick_rmsd - - call mol1%open(fname1) - mol1%xyz = mol1%xyz*bohr !to Angstroem - - rmsdval = quick_rmsd(fname2,mol1%nat,mol1%at,mol1%xyz,heavy) + call ref%open(fname1) + call mol%open(fname2) +! mol1%xyz = mol1%xyz*bohr !to Angstroem +! +! rmsdval = quick_rmsd(fname2,mol1%nat,mol1%at,mol1%xyz,heavy) + rmsdval = rmsd(ref,mol) + + rmsdval = rmsdval * autoaa if (heavy) then write (*,'(1x,a,f16.8)') 'Calculated heavy atom RMSD (Å):',rmsdval else diff --git a/src/sorting/CMakeLists.txt b/src/sorting/CMakeLists.txt new file mode 100644 index 00000000..f90d9f12 --- /dev/null +++ b/src/sorting/CMakeLists.txt @@ -0,0 +1,40 @@ +# This file is part of crest. +# SPDX-Identifier: LGPL-3.0-or-later +# +# crest is free software: you can redistribute it and/or modify it under +# the terms of the GNU Lesser General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# crest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public License +# along with crest. If not, see . + +set(dir "${CMAKE_CURRENT_SOURCE_DIR}") + +list(APPEND srcs + "${dir}/canonical.f90" + "${dir}/ccegen.f90" + "${dir}/cregen.f90" + "${dir}/ensemblecomp.f90" + "${dir}/hungarian.f90" + "${dir}/irmsd_module.f90" + "${dir}/ls_rmsd.f90" + "${dir}/quicksort.f90" + "${dir}/rotcompare.f90" + "${dir}/sortens.f90" + "${dir}/zdata.f90" + "${dir}/ztopology.f90" +) + +set(srcs ${srcs} PARENT_SCOPE) + + + + + + diff --git a/src/canonical.f90 b/src/sorting/canonical.f90 similarity index 100% rename from src/canonical.f90 rename to src/sorting/canonical.f90 diff --git a/src/ccegen.f90 b/src/sorting/ccegen.f90 similarity index 100% rename from src/ccegen.f90 rename to src/sorting/ccegen.f90 diff --git a/src/cregen.f90 b/src/sorting/cregen.f90 similarity index 100% rename from src/cregen.f90 rename to src/sorting/cregen.f90 diff --git a/src/ensemblecomp.f90 b/src/sorting/ensemblecomp.f90 similarity index 100% rename from src/ensemblecomp.f90 rename to src/sorting/ensemblecomp.f90 diff --git a/src/sorting/hungarian.f90 b/src/sorting/hungarian.f90 new file mode 100644 index 00000000..6bec4801 --- /dev/null +++ b/src/sorting/hungarian.f90 @@ -0,0 +1,266 @@ +module hungarian_module +!************************************************************ +!* Implementations of the Hungarian (Kuhn-Munkres) Algorithm +!* in O(n³) time (Edmons & Karp / Tomizawa). +!* +!* Implemented in single precision with a cache to +!* circumvent repeated memory allocation. +!* +!* Also includes some wrappers for standalone use +!************************************************************ + use iso_fortran_env,sp => real32,wp => real64 + implicit none + private + + public :: hungarian + interface hungarian + module procedure hungarian_cached + module procedure hungarian_wrap_int + module procedure hungarian_wrap_sp + module procedure hungarian_wrap_wp + end interface hungarian + + real(sp),parameter,private :: inf = huge(1.0_sp) !> Use huge intrinsic for large numbers + integer,parameter,private :: infi = huge(1) !> Use huge intrinsic for large numbers + + public :: hungarian_cache + type :: hungarian_cache + integer :: J,W + real(sp),allocatable :: Cost(:,:) !> Cost(J,W) + real(sp),allocatable :: answers(:) !> answers(J) + integer,allocatable :: job(:) !> job(W+1) + !> Workspace + real(sp),allocatable :: ys(:) !> ys(J) + real(sp),allocatable :: yt(:) !> yt(W+1) + real(sp),allocatable :: Ct(:,:) !> Ct(W,J) + real(sp),allocatable :: min_to(:) !> min_to(W+1) + integer,allocatable :: prv(:) !> prv(W+1) + logical,allocatable :: in_Z(:) !> in_Z(W+1) + contains + procedure :: allocate => allocate_hungarian_cache + procedure :: deallocate => deallocate_hungarian_cache + end type hungarian_cache + + interface ckmin + module procedure ckmin_int + module procedure ckmin_sp + end interface ckmin + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + subroutine allocate_hungarian_cache(self,J,W) + implicit none + class(hungarian_cache),intent(inout) :: self + integer,intent(in) :: J,W + !> Store dimensions + self%J = J + self%W = W + !> Allocate arrays based on input dimensions + allocate (self%Cost(J,W)) + allocate (self%answers(J)) + allocate (self%job(W+1)) + !> Allocate workspace arrays + allocate (self%ys(J)) + allocate (self%yt(W+1)) + allocate (self%Ct(W,J)) + allocate (self%min_to(W+1)) + allocate (self%prv(W+1)) + allocate (self%in_Z(W+1)) + end subroutine allocate_hungarian_cache + + subroutine deallocate_hungarian_cache(self) + implicit none + class(hungarian_cache),intent(inout) :: self + ! Deallocate arrays if they are allocated + if (allocated(self%Cost)) deallocate (self%Cost) + if (allocated(self%answers)) deallocate (self%answers) + if (allocated(self%job)) deallocate (self%job) + if (allocated(self%ys)) deallocate (self%ys) + if (allocated(self%yt)) deallocate (self%yt) + if (allocated(self%Ct)) deallocate (self%Ct) + if (allocated(self%min_to)) deallocate (self%min_to) + if (allocated(self%prv)) deallocate (self%prv) + if (allocated(self%in_Z)) deallocate (self%in_Z) + end subroutine deallocate_hungarian_cache + +!========================================================================================! + + logical function ckmin_int(a,b) result(yesno) + !> Helper function to compute the minimum and update + integer,intent(inout) :: a + integer,intent(in) :: b + yesno = .false. + if (b < a) then + a = b + yesno = .true. + end if + end function ckmin_int + + logical function ckmin_sp(a,b) result(yesno) + !> Helper function to compute the minimum and update + real(sp),intent(inout) :: a + real(sp),intent(in) :: b + yesno = .false. + if (b < a) then + a = b + yesno = .true. + end if + end function ckmin_sp + + subroutine hungarian_cached(cache,J,W) + !**************************************************************** + !* Hungarian algorithm implementation to solve an assignment + !* problem in O(n³) time. + !* This implementation refers to a cache, which is created + !* to avoid repeated memory allocation. + !* Passing J and W explicitly enables reuse of memory + !* for smaller sub-problems (i.e. cache%J >= J, W accoridingly) + !* + !* Inputs (all within cache, except J and W): + !* C(J, W) - Cost matrix of dimensions J-by-W, + !* where C(jj, ww) is the cost to assign + !* jj-th job to ww-th worker + !* J - Number of jobs + !* W - Number of workers + !* Outputs (all within cache): + !* answers(J) - Vector of length J, where answers(jj) is + !* the minimum cost to assign the first jj + !* jobs to distinct workers + !* job(W+1) - Vector where job(ww) is the job assigned to + !* the ww-th worker (or -1 if no job is assigned) + !**************************************************************** + integer,intent(in) :: J,W + type(hungarian_cache),intent(inout) :: cache + integer :: jj_cur,ww_cur,jj,ww_next,ww + real(sp) :: delta + + !> IMPORTANT: associate to have shorter variable names + associate (C => cache%Cost, & + & answers => cache%answers, & + & job => cache%job, & + & ys => cache%ys, & + & yt => cache%yt, & + & Ct => cache%Ct, & + & min_to => cache%min_to, & + & prv => cache%prv, & + & in_Z => cache%in_Z) + + job = -1 + ys = 0 + yt = 0 + Ct = transpose(C) + + do jj_cur = 1,J !> O(n¹) + ww_cur = W+1 + job(ww_cur) = jj_cur + min_to = inf + prv = -1 + in_Z = .false. + + do while (job(ww_cur) /= -1) !> O(n¹) -> O(n²) + in_Z(ww_cur) = .true. + jj = job(ww_cur) + delta = inf + do ww = 1,W !> O(n²) -> O(n³) + if (.not.in_Z(ww)) then + if (ckmin(min_to(ww),Ct(ww,jj)-ys(jj)-yt(ww))) then + prv(ww) = ww_cur + end if + if (ckmin(delta,min_to(ww))) then + ww_next = ww + end if + end if + end do + + do ww = 1,W+1 + if (in_Z(ww)) then + ys(job(ww)) = ys(job(ww))+delta + yt(ww) = yt(ww)-delta + else + min_to(ww) = min_to(ww)-delta + end if + end do + ww_cur = ww_next + end do + + !> Update assignments along alternating path + do while (ww_cur /= W+1) + job(ww_cur) = job(prv(ww_cur)) + ww_cur = prv(ww_cur) + end do + + answers(jj_cur) = -yt(W+1) + end do + + end associate + end subroutine hungarian_cached + +!========================================================================================! + + subroutine hungarian_wrap_int(C,J,W,answers,job) + !********************************************* + !* Wrapper for integer precision + !********************************************* + implicit none + integer,intent(in) :: C(J,W) + integer,intent(in) :: J,W + integer,intent(out) :: answers(J) + integer,intent(out) :: job(W+1) + type(hungarian_cache) :: cache + + call cache%allocate(J,W) + cache%Cost(1:J,1:W) = real(C(1:J,1:W),sp) + call hungarian_cached(cache,J,W) + + answers(1:J) = nint(cache%answers(1:J)) + job(1:W+1) = cache%job(1:W+1) + call cache%deallocate() + end subroutine hungarian_wrap_int + + subroutine hungarian_wrap_sp(C,J,W,answers,job) + !********************************************* + !* Wrapper for single precision + !********************************************* + implicit none + real(sp),intent(in) :: C(J,W) + integer,intent(in) :: J,W + real(sp),intent(out) :: answers(J) + integer,intent(out) :: job(W+1) + type(hungarian_cache) :: cache + + call cache%allocate(J,W) + cache%Cost(1:J,1:W) = C(1:J,1:W) + call hungarian_cached(cache,J,W) + + answers(1:J) = cache%answers(1:J) + job(1:W+1) = cache%job(1:W+1) + call cache%deallocate() + end subroutine hungarian_wrap_sp + + subroutine hungarian_wrap_wp(C,J,W,answers,job) + !********************************************* + !* Wrapper for double precision + !********************************************* + implicit none + real(wp),intent(in) :: C(J,W) + integer,intent(in) :: J,W + real(wp),intent(out) :: answers(J) + integer,intent(out) :: job(W+1) + type(hungarian_cache) :: cache + + call cache%allocate(J,W) + cache%Cost(1:J,1:W) = real(C(1:J,1:W),sp) + call hungarian_cached(cache,J,W) + + answers(1:J) = real(cache%answers(1:J),wp) + job(1:W+1) = cache%job(1:W+1) + call cache%deallocate() + end subroutine hungarian_wrap_wp + +!========================================================================================! +!========================================================================================! +end module hungarian_module diff --git a/src/irmsd_module.f90 b/src/sorting/irmsd_module.f90 similarity index 58% rename from src/irmsd_module.f90 rename to src/sorting/irmsd_module.f90 index 4ec788a0..c0132f8c 100644 --- a/src/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -1,36 +1,35 @@ - module irmsd_module !***************************************** !* Module that implements a more !* modern interface to calculating RMSDs !***************************************** - use crest_parameters - use ls_rmsd, only: rmsd_classic => rmsd - use strucrd - implicit none - private - - public :: rmsd + use crest_parameters + use ls_rmsd,only:rmsd_classic => rmsd + use strucrd + use hungarian_module + implicit none + private + public :: rmsd - real(wp),parameter :: bigval = huge(bigval) + real(wp),parameter :: bigval = huge(bigval) - - public :: rmsd_cache - type :: rmsd_cache + public :: rmsd_cache + type :: rmsd_cache !**************************************************** !* cache implementation to avoid repeated allocation !* and enable shared-memory parallelism !**************************************************** - real(wp),allocatable :: xyzscratch(:,:,:) - integer,allocatable :: rankscratch(:,:) - integer,allocatable :: orderscratch(:) - logical,allocatable :: assignedscratch(:) - contains - procedure :: allocate => allocate_rmsd_cache - end type rmsd_cache + real(wp),allocatable :: xyzscratch(:,:,:) + integer,allocatable :: rankscratch(:,:) + integer,allocatable :: orderscratch(:) + logical,allocatable :: assignedscratch(:) + type(hungarian_cache),allocatable :: hcache + contains + procedure :: allocate => allocate_rmsd_cache + end type rmsd_cache !========================================================================================! !========================================================================================! @@ -38,23 +37,24 @@ module irmsd_module !========================================================================================! !========================================================================================! - subroutine allocate_rmsd_cache(self,nat) - implicit none - class(rmsd_cache),intent(inout) :: self - integer,intent(in) :: nat - if(allocated(self%xyzscratch)) deallocate(self%xyzscratch) - if(allocated(self%rankscratch)) deallocate(self%rankscratch) - if(allocated(self%orderscratch)) deallocate(self%orderscratch) - if(allocated(self%assignedscratch)) deallocate(self%assignedscratch) - allocate(self%assignedscratch(nat), source=.false.) - allocate(self%orderscratch(nat), source=0) - allocate(self%rankscratch(nat,2), source=0) - allocate(self%xyzscratch(3,nat,2), source=0.0_wp) + implicit none + class(rmsd_cache),intent(inout) :: self + integer,intent(in) :: nat + if (allocated(self%xyzscratch)) deallocate (self%xyzscratch) + if (allocated(self%rankscratch)) deallocate (self%rankscratch) + if (allocated(self%orderscratch)) deallocate (self%orderscratch) + if (allocated(self%assignedscratch)) deallocate (self%assignedscratch) + if (allocated(self%hcache)) deallocate (self%hcache) + allocate (self%assignedscratch(nat),source=.false.) + allocate (self%orderscratch(nat),source=0) + allocate (self%rankscratch(nat,2),source=0) + allocate (self%xyzscratch(3,nat,2),source=0.0_wp) + allocate (self%hcache) + call self%hcache%allocate(nat,nat) end subroutine allocate_rmsd_cache - -function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) + function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) !************************************************************************ !* function rmsd !* Calculate the molecular RMSD via a quaternion algorithm @@ -71,13 +71,13 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) type(coord),intent(in) :: mol !> OPTIONAL arguments logical,intent(in),optional :: mask(ref%nat) - real(wp),intent(inout),target,optional :: scratch(3,ref%nat,2) + real(wp),intent(inout),target,optional :: scratch(3,ref%nat,2) real(wp),intent(out),optional :: rotmat(3,3) real(wp),intent(out),target,optional :: gradient(3,ref%nat) !> variables real(wp) :: x_center(3),y_center(3),Udum(3,3) real(wp),target :: gdum(3,3) - integer :: nat,getrotmat + integer :: nat,getrotmat real(wp),allocatable,target :: tmpscratch(:,:,:) logical :: getgrad real(wp),pointer :: grdptr(:,:) @@ -87,78 +87,78 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) !> initialize to large value rmsdval = bigval !> check structure consistency - if(mol%nat .ne. ref%nat) return + if (mol%nat .ne. ref%nat) return !> get rotation matrix? getrotmat = 0 - if(present(rotmat)) getrotmat = 1 + if (present(rotmat)) getrotmat = 1 !> get gradient? - if(present(gradient))then + if (present(gradient)) then getgrad = .true. gradient(:,:) = 0.0_wp grdptr => gradient else getgrad = .false. grdptr => gdum - endif + end if !>--- substructure? - if(present(mask))then + if (present(mask)) then nat = count(mask(:)) !> scratch workspace to use? - if(present(scratch))then + if (present(scratch)) then scratchptr => scratch else - allocate(tmpscratch(3,nat,2)) + allocate (tmpscratch(3,nat,2)) scratchptr => tmpscratch - endif + end if !> do the mapping - k=0 - do ic=1,ref%nat - if(mask(ic))then - k=k+1 + k = 0 + do ic = 1,ref%nat + if (mask(ic)) then + k = k+1 scratchptr(1:3,k,1) = mol%xyz(1:3,ic) - scratchptr(1:3,k,2) = ref%xyz(1:3,ic) - endif - enddo + scratchptr(1:3,k,2) = ref%xyz(1:3,ic) + end if + end do !> calculate - call rmsd_classic(nat, scratchptr(1:3,1:nat,1), scratchptr(1:3,1:nat,2), & - & getrotmat, Udum, x_center, y_center, rmsdval, & - & getgrad, grdptr) + call rmsd_classic(nat,scratchptr(1:3,1:nat,1),scratchptr(1:3,1:nat,2), & + & getrotmat,Udum,x_center,y_center,rmsdval, & + & getgrad,grdptr) !> go backwards through gradient (if necessary) to restore atom order - if(getgrad)then - k=nat - do ic=nat,1,-1 - if(mask(ic))then + if (getgrad) then + k = nat + do ic = nat,1,-1 + if (mask(ic)) then grdptr(1:3,ic) = grdptr(1:3,k) grdptr(1:3,k) = 0.0_wp - k=k-1 - endif - enddo - endif - - deallocate(scratchptr) - if(allocated(tmpscratch)) deallocate(tmpscratch) + k = k-1 + end if + end do + end if + + deallocate (scratchptr) + if (allocated(tmpscratch)) deallocate (tmpscratch) else !>--- standard calculation (Quarternion algorithm) call rmsd_classic(ref%nat,mol%xyz,ref%xyz, & - & getrotmat, Udum, x_center, y_center, rmsdval, & - & getgrad, grdptr) - endif + & getrotmat,Udum,x_center,y_center,rmsdval, & + & getgrad,grdptr) + end if !> pass on rotation matrix if asked for - if(getrotmat > 0) rotmat = Udum + if (getrotmat > 0) rotmat = Udum -end function rmsd + end function rmsd !========================================================================================! -subroutine min_rmsd(ref,mol,rcache,rmsdout) + subroutine min_rmsd(ref,mol,rcache,rmsdout) implicit none !> IN & OUTPUT type(coord),intent(in) :: ref @@ -170,21 +170,23 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) type(rmsd_cache),pointer :: cptr type(rmsd_cache),allocatable,target :: local_rcache integer :: natmax + real(wp) :: calc_rmsd - - if(present(rcache))then + if (present(rcache)) then cptr => rcache else - allocate(local_rcache) + allocate (local_rcache) natmax = max(ref%nat,mol%nat) call local_rcache%allocate(natmax) cptr => local_rcache - endif + end if + calc_rmsd = rmsd(ref,mol,scratch=cptr%xyzscratch) + if (present(rmsdout)) rmsdout = calc_rmsd + end subroutine min_rmsd - -end subroutine min_rmsd +!========================================================================================! !========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<. + +srcs += files( + 'canonical.f90', + 'ccegen.f90', + 'cregen.f90', + 'ensemblecomp.f90', + 'hungarian.f90', + 'irmsd_module.f90', + 'ls_rmsd.f90', + 'quicksort.f90', + 'rotcompare.f90', + 'sortens.f90', + 'zdata.f90', + 'ztopology.f90', +) diff --git a/src/quicksort.f90 b/src/sorting/quicksort.f90 similarity index 100% rename from src/quicksort.f90 rename to src/sorting/quicksort.f90 diff --git a/src/rotcompare.f90 b/src/sorting/rotcompare.f90 similarity index 100% rename from src/rotcompare.f90 rename to src/sorting/rotcompare.f90 diff --git a/src/sortens.f90 b/src/sorting/sortens.f90 similarity index 100% rename from src/sortens.f90 rename to src/sorting/sortens.f90 diff --git a/src/zdata.f90 b/src/sorting/zdata.f90 similarity index 100% rename from src/zdata.f90 rename to src/sorting/zdata.f90 diff --git a/src/ztopology.f90 b/src/sorting/ztopology.f90 similarity index 100% rename from src/ztopology.f90 rename to src/sorting/ztopology.f90 From a5c98f396dc58a072f6374b651a1d7e3146b5ec0 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 30 Aug 2024 01:12:49 +0200 Subject: [PATCH 007/374] Simple cli for Hungarian algo. Not fixed yet --- src/confparse.f90 | 10 ++++ src/minitools.f90 | 101 +++++++++++++++++++++++++++++++++-- src/sorting/irmsd_module.f90 | 52 +++++++++++++++++- 3 files changed, 157 insertions(+), 6 deletions(-) diff --git a/src/confparse.f90 b/src/confparse.f90 index 1742bc71..c851c557 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -647,6 +647,16 @@ subroutine parseflags(env,arg,nra) call quick_rmsd_tool(ctmp,dtmp,.false.) end if stop + + case ('-hungarian','-hungarianheavy','-hhungarian') + ctmp = trim(arg(i+1)) + dtmp = trim(arg(i+2)) + if ((argument == '-hungarianheavy').or.(argument=='-hhungarian')) then + call quick_hungarian_match(ctmp,dtmp,.true.) + else + call quick_hungarian_match(ctmp,dtmp,.false.) + end if + stop case ('-symmetries') ctmp = trim(arg(i+1)) diff --git a/src/minitools.f90 b/src/minitools.f90 index 980ebeea..b950cf1b 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -592,15 +592,24 @@ subroutine quick_rmsd_tool(fname1,fname2,heavy) logical,intent(in) :: heavy type(coord) :: mol,ref real(wp) :: rmsdval + integer :: i + logical,allocatable :: mask(:) call ref%open(fname1) call mol%open(fname2) -! mol1%xyz = mol1%xyz*bohr !to Angstroem -! -! rmsdval = quick_rmsd(fname2,mol1%nat,mol1%at,mol1%xyz,heavy) + + if(heavy)then + allocate(mask(ref%nat), source=.false.) + do i=1,ref%nat + if(ref%at(i) > 1)then + mask(i) = .true. + endif + enddo + rmsdval = rmsd(ref,mol,mask=mask) + else + rmsdval = rmsd(ref,mol) + endif - rmsdval = rmsd(ref,mol) - rmsdval = rmsdval * autoaa if (heavy) then write (*,'(1x,a,f16.8)') 'Calculated heavy atom RMSD (Å):',rmsdval @@ -652,6 +661,88 @@ function quick_rmsd2(nat,at,xyz,xyz2,heavy) result(rout) return end function quick_rmsd2 +!=========================================================================================! + +subroutine quick_hungarian_match(fname1,fname2,heavy) + use crest_parameters + use strucrd + use hungarian_module + implicit none + character(len=*),intent(in) :: fname1 + character(len=*),intent(in) :: fname2 + logical,intent(in) :: heavy + type(coord) :: mol,ref + real(wp) :: rmsdval + integer :: i,ii,jj,nat + logical,allocatable :: mask(:) + real(wp),allocatable :: C(:,:) + real(wp),allocatable :: answers(:) + integer,allocatable :: mapping(:) + integer,allocatable :: hmap(:),rhmap(:) + real(wp) :: dists(3) + + call ref%open(fname1) + call mol%open(fname2) + + if(heavy)then + allocate(mask(ref%nat), source=.false.) + allocate(hmap(ref%nat), rhmap(ref%nat), source=0) + nat=count((ref%at(:) > 1)) + ii=0 + do i=1,ref%nat + if(ref%at(i) > 1)then + mask(i) = .true. + ii=ii+1 + hmap(i) = ii + rhmap(ii) = i + endif + enddo + else + allocate(mask(ref%nat), source=.true.) + nat=ref%nat + endif + + allocate( C(nat,nat), answers(nat) ) + allocate( mapping(nat+1) ) + do ii=1,nat + if(.not.mask(ii)) cycle + do jj=1,ii + if(.not.mask(jj)) cycle + dists(:)=(ref%xyz(:,ii)-mol%xyz(:,jj) )**2 + if(heavy)then + C(hmap(jj),hmap(ii)) = sqrt(sum(dists)) + C(hmap(ii),hmap(jj)) = C(hmap(jj),hmap(ii)) + else + C(ii,jj) = sqrt(sum(dists)) + C(jj,ii) = C(ii,jj) + endif + enddo + enddo + call hungarian(C,nat,nat,answers,mapping) + + write(*,*) 'Mapping:' + do i=1,nat + if(heavy)then + write(*,'(i6," --> ",i6)') rhmap(i),rhmap(mapping(i)) + else + write(*,'(i6," --> ",i6)') i,mapping(i) + endif + enddo + write(*,*) + + rmsdval = sqrt(answers(nat) / real(nat,wp)) + + rmsdval = abs(rmsdval) * autoaa + if (heavy) then + write (*,'(1x,a,f16.8)') 'Calculated heavy atom RMSD (Å):',rmsdval + else + write (*,'(1x,a,f16.8)') 'Calculated RMSD (Å):',rmsdval + end if + + return +end subroutine quick_hungarian_match + + !=========================================================================================! subroutine resort_ensemble(fname) diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index c0132f8c..7d0d4202 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -141,7 +141,7 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) end do end if - deallocate (scratchptr) + nullify(scratchptr) if (allocated(tmpscratch)) deallocate (tmpscratch) else @@ -188,6 +188,56 @@ end subroutine min_rmsd !========================================================================================! + subroutine atswp(mol,ati,atj) + !******************************** + !* swap atom ati with atj in mol + !******************************** + implicit none + type(coord),intent(inout) :: mol + integer,intent(in) :: ati,atj + real(wp) :: xyztmp(3) + integer :: attmp + xyztmp(1:3) = mol%xyz(1:3,ati) + attmp = mol%at(ati) + mol%xyz(1:3,ati) = mol%xyz(1:3,atj) + mol%at(ati) = mol%at(atj) + mol%xyz(1:3,atj) = xyztmp(1:3) + mol%at(atj) = attmp + end subroutine atswp + +!========================================================================================! + + subroutine compute_hungarian(ref,mol,hcache) + implicit none + !> IN & OUTPUT + type(coord),intent(in) :: ref + type(coord),intent(inout) :: mol + type(hungarian_cache),intent(inout),optional,target :: hcache + + !> LOCAL + type(hungarian_cache),pointer :: hptr + type(hungarian_cache),allocatable,target :: local_hcache + integer :: natmax + + + if (present(hcache)) then + hptr => hcache + else + allocate (local_hcache) + natmax = max(ref%nat,mol%nat) + call local_hcache%allocate(natmax,natmax) + hptr => local_hcache + end if + + !> Compute the cost matrix, which is simply the distance matrix + !> between the two molecules. + !> To avoid computational overhead we can skip the square root. + !> It won't affect the result + + + + end subroutine compute_hungarian + !========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Date: Fri, 30 Aug 2024 18:07:57 +0200 Subject: [PATCH 008/374] rename hungarian_cache --- src/sorting/hungarian.f90 | 30 +++++++++++++++--------------- src/sorting/irmsd_module.f90 | 26 +++++++++++++------------- 2 files changed, 28 insertions(+), 28 deletions(-) diff --git a/src/sorting/hungarian.f90 b/src/sorting/hungarian.f90 index 6bec4801..c216f705 100644 --- a/src/sorting/hungarian.f90 +++ b/src/sorting/hungarian.f90 @@ -23,8 +23,8 @@ module hungarian_module real(sp),parameter,private :: inf = huge(1.0_sp) !> Use huge intrinsic for large numbers integer,parameter,private :: infi = huge(1) !> Use huge intrinsic for large numbers - public :: hungarian_cache - type :: hungarian_cache + public :: assignment_cache + type :: assignment_cache integer :: J,W real(sp),allocatable :: Cost(:,:) !> Cost(J,W) real(sp),allocatable :: answers(:) !> answers(J) @@ -37,9 +37,9 @@ module hungarian_module integer,allocatable :: prv(:) !> prv(W+1) logical,allocatable :: in_Z(:) !> in_Z(W+1) contains - procedure :: allocate => allocate_hungarian_cache - procedure :: deallocate => deallocate_hungarian_cache - end type hungarian_cache + procedure :: allocate => allocate_assignment_cache + procedure :: deallocate => deallocate_assignment_cache + end type assignment_cache interface ckmin module procedure ckmin_int @@ -52,9 +52,9 @@ module hungarian_module !========================================================================================! !========================================================================================! - subroutine allocate_hungarian_cache(self,J,W) + subroutine allocate_assignment_cache(self,J,W) implicit none - class(hungarian_cache),intent(inout) :: self + class(assignment_cache),intent(inout) :: self integer,intent(in) :: J,W !> Store dimensions self%J = J @@ -70,11 +70,11 @@ subroutine allocate_hungarian_cache(self,J,W) allocate (self%min_to(W+1)) allocate (self%prv(W+1)) allocate (self%in_Z(W+1)) - end subroutine allocate_hungarian_cache + end subroutine allocate_assignment_cache - subroutine deallocate_hungarian_cache(self) + subroutine deallocate_assignment_cache(self) implicit none - class(hungarian_cache),intent(inout) :: self + class(assignment_cache),intent(inout) :: self ! Deallocate arrays if they are allocated if (allocated(self%Cost)) deallocate (self%Cost) if (allocated(self%answers)) deallocate (self%answers) @@ -85,7 +85,7 @@ subroutine deallocate_hungarian_cache(self) if (allocated(self%min_to)) deallocate (self%min_to) if (allocated(self%prv)) deallocate (self%prv) if (allocated(self%in_Z)) deallocate (self%in_Z) - end subroutine deallocate_hungarian_cache + end subroutine deallocate_assignment_cache !========================================================================================! @@ -134,7 +134,7 @@ subroutine hungarian_cached(cache,J,W) !* the ww-th worker (or -1 if no job is assigned) !**************************************************************** integer,intent(in) :: J,W - type(hungarian_cache),intent(inout) :: cache + type(assignment_cache),intent(inout) :: cache integer :: jj_cur,ww_cur,jj,ww_next,ww real(sp) :: delta @@ -210,7 +210,7 @@ subroutine hungarian_wrap_int(C,J,W,answers,job) integer,intent(in) :: J,W integer,intent(out) :: answers(J) integer,intent(out) :: job(W+1) - type(hungarian_cache) :: cache + type(assignment_cache) :: cache call cache%allocate(J,W) cache%Cost(1:J,1:W) = real(C(1:J,1:W),sp) @@ -230,7 +230,7 @@ subroutine hungarian_wrap_sp(C,J,W,answers,job) integer,intent(in) :: J,W real(sp),intent(out) :: answers(J) integer,intent(out) :: job(W+1) - type(hungarian_cache) :: cache + type(assignment_cache) :: cache call cache%allocate(J,W) cache%Cost(1:J,1:W) = C(1:J,1:W) @@ -250,7 +250,7 @@ subroutine hungarian_wrap_wp(C,J,W,answers,job) integer,intent(in) :: J,W real(wp),intent(out) :: answers(J) integer,intent(out) :: job(W+1) - type(hungarian_cache) :: cache + type(assignment_cache) :: cache call cache%allocate(J,W) cache%Cost(1:J,1:W) = real(C(1:J,1:W),sp) diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index 7d0d4202..98ab1ac6 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -26,7 +26,7 @@ module irmsd_module integer,allocatable :: orderscratch(:) logical,allocatable :: assignedscratch(:) - type(hungarian_cache),allocatable :: hcache + type(assignment_cache),allocatable :: acache contains procedure :: allocate => allocate_rmsd_cache end type rmsd_cache @@ -45,13 +45,13 @@ subroutine allocate_rmsd_cache(self,nat) if (allocated(self%rankscratch)) deallocate (self%rankscratch) if (allocated(self%orderscratch)) deallocate (self%orderscratch) if (allocated(self%assignedscratch)) deallocate (self%assignedscratch) - if (allocated(self%hcache)) deallocate (self%hcache) + if (allocated(self%acache)) deallocate (self%acache) allocate (self%assignedscratch(nat),source=.false.) allocate (self%orderscratch(nat),source=0) allocate (self%rankscratch(nat,2),source=0) allocate (self%xyzscratch(3,nat,2),source=0.0_wp) - allocate (self%hcache) - call self%hcache%allocate(nat,nat) + allocate (self%acache) + call self%acache%allocate(nat,nat) end subroutine allocate_rmsd_cache function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) @@ -207,26 +207,26 @@ end subroutine atswp !========================================================================================! - subroutine compute_hungarian(ref,mol,hcache) + subroutine compute_hungarian(ref,mol,acache) implicit none !> IN & OUTPUT type(coord),intent(in) :: ref type(coord),intent(inout) :: mol - type(hungarian_cache),intent(inout),optional,target :: hcache + type(assignment_cache),intent(inout),optional,target :: acache !> LOCAL - type(hungarian_cache),pointer :: hptr - type(hungarian_cache),allocatable,target :: local_hcache + type(assignment_cache),pointer :: aptr + type(assignment_cache),allocatable,target :: local_acache integer :: natmax - if (present(hcache)) then - hptr => hcache + if (present(acache)) then + aptr => acache else - allocate (local_hcache) + allocate (local_acache) natmax = max(ref%nat,mol%nat) - call local_hcache%allocate(natmax,natmax) - hptr => local_hcache + call local_acache%allocate(natmax,natmax) + aptr => local_acache end if !> Compute the cost matrix, which is simply the distance matrix From e159c149546e640c0a2383963a212797a3e2e259 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 30 Aug 2024 22:43:43 +0200 Subject: [PATCH 009/374] Add LSAP algo as alternative to Hungarian algo --- src/confparse.f90 | 5 +- src/minitools.f90 | 29 ++-- src/sorting/hungarian.f90 | 349 ++++++++++++++++++++++++++++++++++++-- 3 files changed, 350 insertions(+), 33 deletions(-) diff --git a/src/confparse.f90 b/src/confparse.f90 index c851c557..b9bcb744 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -648,10 +648,11 @@ subroutine parseflags(env,arg,nra) end if stop - case ('-hungarian','-hungarianheavy','-hhungarian') + case ('-hungarian','-hungarianheavy','-hhungarian','-lsap','-hlsap','-lsapheavy') ctmp = trim(arg(i+1)) dtmp = trim(arg(i+2)) - if ((argument == '-hungarianheavy').or.(argument=='-hhungarian')) then + if ((argument == '-hungarianheavy').or.(argument=='-hhungarian').or. & + &(argument == '-lsapheavy').or.(argument=='-hlsap') ) then call quick_hungarian_match(ctmp,dtmp,.true.) else call quick_hungarian_match(ctmp,dtmp,.false.) diff --git a/src/minitools.f90 b/src/minitools.f90 index b950cf1b..f8fbf48a 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -673,12 +673,13 @@ subroutine quick_hungarian_match(fname1,fname2,heavy) logical,intent(in) :: heavy type(coord) :: mol,ref real(wp) :: rmsdval - integer :: i,ii,jj,nat + integer :: i,ii,jj,nat,io logical,allocatable :: mask(:) real(wp),allocatable :: C(:,:) real(wp),allocatable :: answers(:) integer,allocatable :: mapping(:) integer,allocatable :: hmap(:),rhmap(:) + integer,allocatable :: a(:),b(:) real(wp) :: dists(3) call ref%open(fname1) @@ -706,33 +707,35 @@ subroutine quick_hungarian_match(fname1,fname2,heavy) allocate( mapping(nat+1) ) do ii=1,nat if(.not.mask(ii)) cycle - do jj=1,ii + do jj=1,nat if(.not.mask(jj)) cycle - dists(:)=(ref%xyz(:,ii)-mol%xyz(:,jj) )**2 + dists(:)=(ref%xyz(:,ii)-mol%xyz(:,jj))**2 if(heavy)then C(hmap(jj),hmap(ii)) = sqrt(sum(dists)) - C(hmap(ii),hmap(jj)) = C(hmap(jj),hmap(ii)) else - C(ii,jj) = sqrt(sum(dists)) - C(jj,ii) = C(ii,jj) + C(jj,ii) = sqrt(sum(dists)) endif enddo enddo - call hungarian(C,nat,nat,answers,mapping) + allocate(a(nat),b(nat)) + call lsap(C,nat,nat,a,b) - write(*,*) 'Mapping:' + write(*,'(a,3(1x,a))') 'Assignment:',fname2,'-->',fname1 do i=1,nat if(heavy)then - write(*,'(i6," --> ",i6)') rhmap(i),rhmap(mapping(i)) + write(*,'(i6," --> ",i6)') rhmap(a(i)),rhmap(b(i)) else - write(*,'(i6," --> ",i6)') i,mapping(i) + write(*,'(i6," --> ",i6)') a(i),b(i) endif enddo write(*,*) - rmsdval = sqrt(answers(nat) / real(nat,wp)) - - rmsdval = abs(rmsdval) * autoaa + !> reconstruct RMSD from assignment (since our costs are already distances!) + rmsdval = 0.0_wp + do i=1,nat + rmsdval = rmsdval + C(a(i),b(i)) / real(nat,wp) + enddo + rmsdval = sqrt(abs(rmsdval)) * autoaa if (heavy) then write (*,'(1x,a,f16.8)') 'Calculated heavy atom RMSD (Å):',rmsdval else diff --git a/src/sorting/hungarian.f90 b/src/sorting/hungarian.f90 index c216f705..354f011e 100644 --- a/src/sorting/hungarian.f90 +++ b/src/sorting/hungarian.f90 @@ -1,7 +1,13 @@ module hungarian_module !************************************************************ -!* Implementations of the Hungarian (Kuhn-Munkres) Algorithm -!* in O(n³) time (Edmons & Karp / Tomizawa). +!* Implementations of +!* A) The Hungarian (Kuhn-Munkres) Algorithm +!* in O(n³) time (Edmons & Karp / Tomizawa). +!* +!* B) A Rectengular linear assignment problem algorithm +!* (LSAP) accodring to +!* D.F. Crouse, IEEE Trans. Aerosp. Electron. Syst., +!* 2016, 52, 1679-1696, doi: 10.1109/TAES.2016.140952 !* !* Implemented in single precision with a cache to !* circumvent repeated memory allocation. @@ -20,6 +26,14 @@ module hungarian_module module procedure hungarian_wrap_wp end interface hungarian + public :: lsap + interface lsap + module procedure lsap_cached + module procedure lsap_wrap_int + module procedure lsap_wrap_sp + module procedure lsap_wrap_wp + end interface lsap + real(sp),parameter,private :: inf = huge(1.0_sp) !> Use huge intrinsic for large numbers integer,parameter,private :: infi = huge(1) !> Use huge intrinsic for large numbers @@ -27,15 +41,22 @@ module hungarian_module type :: assignment_cache integer :: J,W real(sp),allocatable :: Cost(:,:) !> Cost(J,W) + !> Hungarian algo related real(sp),allocatable :: answers(:) !> answers(J) integer,allocatable :: job(:) !> job(W+1) - !> Workspace - real(sp),allocatable :: ys(:) !> ys(J) - real(sp),allocatable :: yt(:) !> yt(W+1) - real(sp),allocatable :: Ct(:,:) !> Ct(W,J) - real(sp),allocatable :: min_to(:) !> min_to(W+1) + real(sp),allocatable :: ys(:) !> ys(J) + real(sp),allocatable :: yt(:) !> yt(W+1) + real(sp),allocatable :: Ct(:,:) !> Ct(W,J) + real(sp),allocatable :: min_to(:) !> min_to(W+1) integer,allocatable :: prv(:) !> prv(W+1) logical,allocatable :: in_Z(:) !> in_Z(W+1) + !> LSAP related + integer,allocatable :: a(:),b(:) !> a(J), b(J) + real(sp),allocatable :: u(:),v(:) !> u(J), v(W) + real(sp),allocatable :: shortestPathCosts(:) !> ...(W) + integer,allocatable :: path(:),remaining(:) !> path(W), remaining(W) + integer,allocatable :: col4row(:),row4col(:) !> col4row(J), row4col(W) + logical,allocatable :: SR(:),SC(:) !> SR(J), SC(W) contains procedure :: allocate => allocate_assignment_cache procedure :: deallocate => deallocate_assignment_cache @@ -52,24 +73,42 @@ module hungarian_module !========================================================================================! !========================================================================================! - subroutine allocate_assignment_cache(self,J,W) + subroutine allocate_assignment_cache(self,J,W,lsapcache) implicit none class(assignment_cache),intent(inout) :: self integer,intent(in) :: J,W + logical,intent(in),optional :: lsapcache + logical :: yesno + yesno = .false. + if (present(lsapcache)) yesno = lsapcache + !> Store dimensions self%J = J self%W = W - !> Allocate arrays based on input dimensions + if (J > W) then + error stop 'linear assignment problems require rectengular matrices!' + end if allocate (self%Cost(J,W)) - allocate (self%answers(J)) - allocate (self%job(W+1)) - !> Allocate workspace arrays - allocate (self%ys(J)) - allocate (self%yt(W+1)) - allocate (self%Ct(W,J)) - allocate (self%min_to(W+1)) - allocate (self%prv(W+1)) - allocate (self%in_Z(W+1)) + + !> Allocate arrays based on input dimensions & algo type + if (.not.yesno) then + !> Hungarian algo cache: + allocate (self%answers(J)) + allocate (self%job(W+1)) + !> Allocate workspace arrays + allocate (self%ys(J)) + allocate (self%yt(W+1)) + allocate (self%Ct(W,J)) + allocate (self%min_to(W+1)) + allocate (self%prv(W+1)) + allocate (self%in_Z(W+1)) + else + !> LSAP cache + allocate (self%a(J),self%b(J)) + allocate (self%u(J),self%v(W),self%shortestPathCosts(W)) + allocate (self%path(W),self%col4row(J),self%row4col(W)) + allocate (self%SR(J),self%SC(W),self%remaining(W)) + end if end subroutine allocate_assignment_cache subroutine deallocate_assignment_cache(self) @@ -85,6 +124,17 @@ subroutine deallocate_assignment_cache(self) if (allocated(self%min_to)) deallocate (self%min_to) if (allocated(self%prv)) deallocate (self%prv) if (allocated(self%in_Z)) deallocate (self%in_Z) + if (allocated(self%a)) deallocate (self%a) + if (allocated(self%b)) deallocate (self%b) + if (allocated(self%u)) deallocate (self%u) + if (allocated(self%v)) deallocate (self%v) + if (allocated(self%shortestPathCosts)) deallocate (self%shortestPathCosts) + if (allocated(self%path)) deallocate (self%path) + if (allocated(self%col4row)) deallocate (self%col4row) + if (allocated(self%row4col)) deallocate (self%row4col) + if (allocated(self%SR)) deallocate (self%SR) + if (allocated(self%SC)) deallocate (self%SC) + if (allocated(self%remaining)) deallocate (self%remaining) end subroutine deallocate_assignment_cache !========================================================================================! @@ -119,6 +169,8 @@ subroutine hungarian_cached(cache,J,W) !* to avoid repeated memory allocation. !* Passing J and W explicitly enables reuse of memory !* for smaller sub-problems (i.e. cache%J >= J, W accoridingly) + !* Unfortunately, this algorithm has problems with + !* assignments of equal cost. !* !* Inputs (all within cache, except J and W): !* C(J, W) - Cost matrix of dimensions J-by-W, @@ -261,6 +313,267 @@ subroutine hungarian_wrap_wp(C,J,W,answers,job) call cache%deallocate() end subroutine hungarian_wrap_wp +!========================================================================================! +!========================================================================================! + +!**************************************************************** +!* The following implements an alternative algorithm capable +!* to better handle assignments with equivalent costs +!* The algorithm follows +!* D.F. Crouse, IEEE Trans. Aerosp. Electron. Syst., +!* 2016, 52, 1679-1696, doi: 10.1109/TAES.2016.140952 +!* +!* The source code is a free Fortran-adaptation +!* of the C++ lsap algorithm in SciPy +!**************************************************************** + + function augmenting_path(nc,cost,u,v,path,row4col, & + & shortestPathCosts,i,SR,SC, & + & remaining,minValue) result(sink) + implicit none + integer,intent(in) :: nc !> Number of columns (workers) + real(sp),intent(in) :: cost(:,:) !> Cost matrix + real(sp),intent(inout) :: u(:) !> Dual variables for rows (jobs) + real(sp),intent(inout) :: v(:) !> Dual variables for columns (workers) + integer,intent(inout) :: path(:) !> Path array + integer,intent(inout) :: row4col(:) !> Array storing which row is assigned to which column + real(sp),intent(inout) :: shortestPathCosts(:) !> Array for storing shortest path costs + integer,intent(inout) :: i !> Current row being processed + logical,intent(inout) :: SR(:) !> Boolean array for rows + logical,intent(inout) :: SC(:) !> Boolean array for columns + integer,intent(inout) :: remaining(:) !> Array of remaining columns to be processed + real(sp),intent(inout) :: minValue !> Minimum value of the path cost + integer :: sink !> The resulting sink (column) from the augmenting path + integer :: num_remaining,indx,j,it + real(sp) :: lowest,r + + minValue = 0.0_sp + num_remaining = nc + + !> Initialize the remaining array in reverse order + do it = 1,nc + remaining(it) = nc-(it-1) + end do + + !> Initialize SR, SC, and shortestPathCosts + SR = .false. + SC = .false. + shortestPathCosts = inf !> Set to a very large value + + !> Start finding the shortest augmenting path + sink = -1 + do while (sink == -1) + indx = -1 + lowest = inf + SR(i) = .true. + + do it = 1,num_remaining + j = remaining(it) + r = minValue+cost(i,j)-u(i)-v(j) + if (r < shortestPathCosts(j)) then + path(j) = i + shortestPathCosts(j) = r + end if + + !> Choose the smallest cost or a new sink node + if (shortestPathCosts(j) < lowest.or. & + (shortestPathCosts(j) == lowest.and.row4col(j) == -1)) then + lowest = shortestPathCosts(j) + indx = it + end if + end do + + minValue = lowest + if (minValue == inf) then !> Infeasible cost matrix + sink = -1 + return + end if + + j = remaining(indx) + if (row4col(j) == -1) then + sink = j + else + i = row4col(j) + end if + + SC(j) = .true. + num_remaining = num_remaining-1 + remaining(indx) = remaining(num_remaining) + end do + end function augmenting_path + + subroutine swap(x,y) + implicit none + integer,intent(inout) :: x,y + integer :: temp + temp = x + x = y + y = temp + end subroutine swap + + subroutine lsap_cached(lcache,nr,nc,maximize,iostatus) + implicit none + type(assignment_cache),intent(inout) :: lcache + integer,intent(in) :: nr,nc + logical,intent(in) :: maximize + integer :: iostatus + integer :: curRow,curRow_iter,currowtmp,i,j,sink + real(sp) :: minValue + logical :: transposed + integer :: tmpx + !> error codes + integer,parameter :: RECTANGULAR_LSAP_TRANSPOSED = 1 + integer,parameter :: RECTANGULAR_LSAP_INFEASIBLE = 2 + + !> use associates to offload allocation outside the routine + associate (cost => lcache%Cost, & + & a => lcache%a,b => lcache%b, & + & u => lcache%u,v => lcache%v, & + & shortestPathCosts => lcache%shortestPathCosts, & + & path => lcache%path,col4row => lcache%col4row,row4col => lcache%row4col, & + & remaining => lcache%remaining,SR => lcache%SR,SC => lcache%SC) + + !> Handle trivial inputs + if (nr == 1.or.nc == 1) then + iostatus = 0 + return + end if + + !> Determine if we need to transpose the matrix + !> Let the user handle that outside the call + if (nc < nr) then + iostatus = RECTANGULAR_LSAP_TRANSPOSED + return + end if + + !> Negate the cost matrix for maximization + if (maximize) then + cost = -cost + end if + + !> Initialize + u(:) = 0.0_sp + v(:) = 0.0_sp + col4row(:) = -1 + row4col(:) = -1 + path(:) = -1 + + !> Iteratively build the solution + do curRow = 1,nr + curRowtmp = curRow + !> Call augmenting_path routine + sink = augmenting_path(nc,cost,u,v,path,row4col, & + & shortestPathCosts,curRowtmp, & + & SR,SC,remaining,minValue) + if (sink < 0) then + iostatus = RECTANGULAR_LSAP_INFEASIBLE + return + end if + + !> Update dual variables + u(curRow) = u(curRow)+minValue + do i = 1,nr + if (SR(i).and.i /= curRow) then + u(i) = u(i)+minValue-shortestPathCosts(col4row(i)) + end if + end do + + do j = 1,nc + if (SC(j)) then + v(j) = v(j)-minValue+shortestPathCosts(j) + end if + end do + + !> Augment previous solution + j = sink + do + i = path(j) + row4col(j) = i + call swap(col4row(i),j) + if (i == curRow) exit + end do + end do + + !> Finalize the assignment based on transposition + do i = 1,nr + a(i) = i + b(i) = col4row(i) + end do + + iostatus = 0 + end associate + end subroutine lsap_cached + +!========================================================================================! + + subroutine lsap_wrap_int(C,J,W,a,b) + !********************************************* + !* Wrapper for integer precision + !********************************************* + implicit none + integer,intent(in) :: C(J,W) + integer,intent(in) :: J,W + integer,intent(out),allocatable :: a(:) + integer,intent(out),allocatable :: b(:) + type(assignment_cache) :: cache + integer :: io + + call cache%allocate(J,W,.true.) + cache%Cost(1:J,1:W) = real(C(1:J,1:W),sp) + call lsap_cached(cache,J,W,.false.,io) + + allocate(a(J), b(J)) + a(1:J) = cache%a(1:J) + b(1:J) = cache%b(1:J) + call cache%deallocate() + end subroutine lsap_wrap_int + + + subroutine lsap_wrap_sp(C,J,W,a,b) + !********************************************* + !* Wrapper for single precision + !********************************************* + implicit none + real(sp),intent(in) :: C(J,W) + integer,intent(in) :: J,W + integer,intent(out),allocatable :: a(:) + integer,intent(out),allocatable :: b(:) + type(assignment_cache) :: cache + integer :: io + + call cache%allocate(J,W,.true.) + cache%Cost(1:J,1:W) = C(1:J,1:W) + call lsap_cached(cache,J,W,.false.,io) + + allocate(a(J), b(J)) + a(1:J) = cache%a(1:J) + b(1:J) = cache%b(1:J) + call cache%deallocate() + end subroutine lsap_wrap_sp + + + subroutine lsap_wrap_wp(C,J,W,a,b) + !********************************************* + !* Wrapper for double precision + !********************************************* + implicit none + real(wp),intent(in) :: C(J,W) + integer,intent(in) :: J,W + integer,intent(out),allocatable :: a(:) + integer,intent(out),allocatable :: b(:) + type(assignment_cache) :: cache + integer :: io + + call cache%allocate(J,W,.true.) + cache%Cost(1:J,1:W) = real(C(1:J,1:W),sp) + call lsap_cached(cache,J,W,.false.,io) + + allocate(a(J), b(J)) + a(1:J) = cache%a(1:J) + b(1:J) = cache%b(1:J) + call cache%deallocate() + end subroutine lsap_wrap_wp + !========================================================================================! !========================================================================================! end module hungarian_module From 8bfd0eab46059846f8378c1ed67221ed244bb169 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 30 Aug 2024 23:35:28 +0200 Subject: [PATCH 010/374] Reduce memory allocation overhead in axis_0 and axis_4 --- src/axis_module.f90 | 138 ++++++++++++++++++++++++++++++++------------ 1 file changed, 102 insertions(+), 36 deletions(-) diff --git a/src/axis_module.f90 b/src/axis_module.f90 index f6e7379a..ccfd04db 100644 --- a/src/axis_module.f90 +++ b/src/axis_module.f90 @@ -95,15 +95,15 @@ module axis_module !========================================================================================! subroutine axis_0(nat,at,coord,rot,avmom,evec) implicit none - integer :: nat - integer :: at(nat) - real(wp) :: coord(3,nat) - real(wp) :: rot(3),avmom,evec(3,3) + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(in) :: coord(3,nat) + real(wp),intent(out) :: rot(3),avmom,evec(3,3) real(wp) :: a(3,3) real(wp) :: t(6),xyzmom(3),eig(3) !real(wp) :: x(nat),y(nat),z(nat) - real(wp),allocatable :: x(:),y(:),z(:) - real(wp) :: atmass + !real(wp),allocatable :: x(:),y(:),z(:) + real(wp) :: atmass,shift(3) integer :: i,j !************************************************************************ !* const1 = 10**40/(n*a*a) @@ -116,8 +116,9 @@ subroutine axis_0(nat,at,coord,rot,avmom,evec) !> first we move the molecule to the CMA !> this depends on the isotopic masses, and the cartesian geometry. !> - allocate (x(nat),y(nat),z(nat),source=0.0_wp) - call CMA(nat,at,coord,x,y,z) +! allocate (x(nat),y(nat),z(nat),source=0.0_wp) +! call CMA(nat,at,coord,x,y,z) + call CMAshift(nat,at,coord,shift) !************************************************************************ !* matrix for moments of inertia is of form @@ -133,12 +134,18 @@ subroutine axis_0(nat,at,coord,rot,avmom,evec) end do do i = 1,nat atmass = ams(at(i)) - t(1) = t(1) + atmass * (y(i)**2 + z(i)**2) - t(2) = t(2) - atmass * x(i) * y(i) - t(3) = t(3) + atmass * (z(i)**2 + x(i)**2) - t(4) = t(4) - atmass * z(i) * x(i) - t(5) = t(5) - atmass * y(i) * z(i) - t(6) = t(6) + atmass * (x(i)**2 + y(i)**2) +! t(1) = t(1) + atmass * (y(i)**2 + z(i)**2) +! t(2) = t(2) - atmass * x(i) * y(i) +! t(3) = t(3) + atmass * (z(i)**2 + x(i)**2) +! t(4) = t(4) - atmass * z(i) * x(i) +! t(5) = t(5) - atmass * y(i) * z(i) +! t(6) = t(6) + atmass * (x(i)**2 + y(i)**2) + t(1) = t(1) + atmass * ((coord(2,i)-shift(2))**2 + (coord(3,i)-shift(3))**2) + t(2) = t(2) - atmass * (coord(1,i)-shift(1)) * (coord(2,i)-shift(2)) + t(3) = t(3) + atmass * ((coord(3,i)-shift(3))**2 + (coord(1,i)-shift(1))**2) + t(4) = t(4) - atmass * (coord(3,i)-shift(3)) * (coord(1,i)-shift(1)) + t(5) = t(5) - atmass * (coord(2,i)-shift(2)) * (coord(3,i)-shift(3)) + t(6) = t(6) + atmass * ((coord(1,i)-shift(1))**2 + (coord(2,i)-shift(2))**2) a(1,1) = t(1) a(2,1) = t(2) a(1,2) = t(2) @@ -149,7 +156,7 @@ subroutine axis_0(nat,at,coord,rot,avmom,evec) a(2,3) = t(5) a(3,3) = t(6) end do - deallocate (z,y,x) +! deallocate (z,y,x) evec = 0.0_wp eig = 0.0_wp @@ -241,12 +248,14 @@ subroutine axis_2(pr,nat,at,coord,eax) end subroutine axis_2 !========================================================================================! -!> subroutine axis_3 -!> axis routine that orients the molecule along the -!> calculated principle axes and shifts it to CMA. -!> new geometry is written to coordout. -!>--------------------------------------------- + subroutine axis_3(nat,at,coord,coordout,rot) +!**************************************************** +!* subroutine axis_3 +!* axis routine that orients the molecule along the +!* calculated principle axes and shifts it to CMA. +!* new geometry is written to coordout. +!**************************************************** implicit none integer,intent(in) :: nat integer,intent(in) :: at(nat) @@ -293,25 +302,46 @@ subroutine axis_3(nat,at,coord,coordout,rot) end subroutine axis_3 !========================================================================================! -!> subroutine axis_4 -!> axis routine that orients the molecule along the -!> calculated principle axes and shifts it to CMA. -!> new geometry OVERWRITES input. -!>-------------------------------- + subroutine axis_4(nat,at,coord) +!**************************************************** +!* subroutine axis_4 +!* axis routine that orients the molecule along the +!* calculated principle axes and shifts it to CMA. +!* new geometry OVERWRITES input. +!* Optimized for minimal allocation overhead. +!**************************************************** implicit none integer,intent(in) :: nat integer,intent(in) :: at(nat) real(wp),intent(inout) :: coord(3,nat) - real(wp) :: rot(3) - real(wp),allocatable :: coordtmp(:,:) - - allocate (coordtmp(3,nat)) - !> call axis routine - call axis_3(nat,at,coord,coordtmp,rot) - coord = coordtmp - deallocate (coordtmp) + real(wp) :: coordtmp(3),shift(3) + real(wp) :: rot(3),avmom,evec(3,3) + integer :: i,j,k + real(wp) :: xsum + call axis_0(nat,at,coord,rot,avmom,evec) + call CMAshift(nat,at,coord,shift) + do i=1,nat + coord(:,i) = coord(:,i) - shift(:) + enddo + !> do the trafo (chirality is preserved) + xsum = calcxsum(evec) + if (xsum .lt. 0.0_wp) then + do j = 1,3 + evec(j,1) = -evec(j,1) + end do + end if + do i = 1,nat + coordtmp(:) = coord(:,i) + do j = 1,3 + xsum = 0.0_wp + do k = 1,3 + xsum = xsum + coordtmp(k) * evec(k,j) + end do + coord(j,i) = xsum + end do + end do return end subroutine axis_4 @@ -378,10 +408,12 @@ real(wp) function calcxsum(evec) end function calcxsum !========================================================================================! -!> subroutine CMA -!> calculate CMA-shifted coordinates x y z -!>-------------------------------------- + subroutine CMAxyz(nat,at,coord,x,y,z) +!******************************************** +!* subroutine CMA +!* calculate CMA-shifted coordinates x y z +!******************************************** implicit none integer,intent(in) :: nat integer,intent(in) :: at(nat) @@ -411,6 +443,40 @@ subroutine CMAxyz(nat,at,coord,x,y,z) return end subroutine CMAxyz +!========================================================================================! + + subroutine CMAshift(nat,at,coord,shift) +!********************************************************* +!* subroutine CMAshift +!* calculate the shift vector to shift a molecule to CMA +!********************************************************* + implicit none + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(in) :: coord(3,nat) + real(wp),intent(out) :: shift(3) + integer :: i + real(wp) :: sumw,sumwx,sumwy,sumwz,atmass + sumw = 1.d-20 + sumwx = 0.d0 + sumwy = 0.d0 + sumwz = 0.d0 + do i = 1,nat + atmass = ams(at(i)) + sumw = sumw + atmass + sumwx = sumwx + atmass * coord(1,i) + sumwy = sumwy + atmass * coord(2,i) + sumwz = sumwz + atmass * coord(3,i) + end do + sumwx = sumwx / sumw + sumwy = sumwy / sumw + sumwz = sumwz / sumw + shift(1) = sumwx + shift(2) = sumwy + shift(3) = sumwz + return + end subroutine CMAshift + !========================================================================================! !> subroutine CMAtrf !> calculate a shift to the first nat0 atoms' CMA From 06c1d7797c7379c2335d6f2ebfa66c4161227732 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 1 Sep 2024 00:32:34 +0200 Subject: [PATCH 011/374] Sorting routine implementation and cli to test it --- src/confparse.f90 | 8 +- src/minitools.f90 | 43 +++++++- src/sorting/irmsd_module.f90 | 197 ++++++++++++++++++++++++++++------- src/strucreader.f90 | 20 ++++ 4 files changed, 226 insertions(+), 42 deletions(-) diff --git a/src/confparse.f90 b/src/confparse.f90 index b9bcb744..d0989665 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -647,7 +647,13 @@ subroutine parseflags(env,arg,nra) call quick_rmsd_tool(ctmp,dtmp,.false.) end if stop - + + case ('-irmsd') + ctmp = trim(arg(i+1)) + dtmp = trim(arg(i+2)) + call irmsd_tool(ctmp,dtmp) + stop + case ('-hungarian','-hungarianheavy','-hhungarian','-lsap','-hlsap','-lsapheavy') ctmp = trim(arg(i+1)) dtmp = trim(arg(i+2)) diff --git a/src/minitools.f90 b/src/minitools.f90 index f8fbf48a..96b14f60 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -667,13 +667,14 @@ subroutine quick_hungarian_match(fname1,fname2,heavy) use crest_parameters use strucrd use hungarian_module + use axis_module, only: axis implicit none character(len=*),intent(in) :: fname1 character(len=*),intent(in) :: fname2 logical,intent(in) :: heavy type(coord) :: mol,ref real(wp) :: rmsdval - integer :: i,ii,jj,nat,io + integer :: i,ii,jj,nat,io,ich logical,allocatable :: mask(:) real(wp),allocatable :: C(:,:) real(wp),allocatable :: answers(:) @@ -684,7 +685,11 @@ subroutine quick_hungarian_match(fname1,fname2,heavy) call ref%open(fname1) call mol%open(fname2) - + + !> align to rotational axes and shift to center of mass + call axis(ref%nat,ref%at,ref%xyz) + call axis(mol%nat,mol%at,mol%xyz) + if(heavy)then allocate(mask(ref%nat), source=.false.) allocate(hmap(ref%nat), rhmap(ref%nat), source=0) @@ -729,6 +734,11 @@ subroutine quick_hungarian_match(fname1,fname2,heavy) endif enddo write(*,*) + !> write the rotated and shifted coordinates to one file + open(newunit=ich,file='lsap.xyz') + call ref%append(ich) + call mol%append(ich) + close(ich) !> reconstruct RMSD from assignment (since our costs are already distances!) rmsdval = 0.0_wp @@ -745,6 +755,35 @@ subroutine quick_hungarian_match(fname1,fname2,heavy) return end subroutine quick_hungarian_match +!=========================================================================================! + +subroutine irmsd_tool(fname1,fname2) + use crest_parameters + use strucrd + use irmsd_module + implicit none + character(len=*),intent(in) :: fname1 + character(len=*),intent(in) :: fname2 + type(coord) :: mol,ref + real(wp) :: rmsdval + integer :: i,ich + + call ref%open(fname1) + call mol%open(fname2) + + call min_rmsd(ref,mol,rmsdout=rmsdval) + + !> write the rotated and shifted coordinates to one file + open(newunit=ich,file='irmsd.xyz') + call ref%append(ich) + call mol%append(ich) + close(ich) + + rmsdval = rmsdval * autoaa + write (*,'(1x,a,f16.8)') 'Calculated RMSD (Å):',rmsdval + + return +end subroutine irmsd_tool !=========================================================================================! diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index 98ab1ac6..60eb86d6 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -12,6 +12,7 @@ module irmsd_module private public :: rmsd + public :: min_rmsd real(wp),parameter :: bigval = huge(bigval) @@ -22,9 +23,12 @@ module irmsd_module !* and enable shared-memory parallelism !**************************************************** real(wp),allocatable :: xyzscratch(:,:,:) - integer,allocatable :: rankscratch(:,:) - integer,allocatable :: orderscratch(:) - logical,allocatable :: assignedscratch(:) + integer,allocatable :: rank(:,:) + integer,allocatable :: order(:) + integer,allocatable :: current_order(:) + integer,allocatable :: target_order(:) + integer,allocatable :: iwork(:) + logical,allocatable :: assigned(:) type(assignment_cache),allocatable :: acache contains @@ -42,16 +46,22 @@ subroutine allocate_rmsd_cache(self,nat) class(rmsd_cache),intent(inout) :: self integer,intent(in) :: nat if (allocated(self%xyzscratch)) deallocate (self%xyzscratch) - if (allocated(self%rankscratch)) deallocate (self%rankscratch) - if (allocated(self%orderscratch)) deallocate (self%orderscratch) - if (allocated(self%assignedscratch)) deallocate (self%assignedscratch) + if (allocated(self%rank)) deallocate (self%rank) + if (allocated(self%order)) deallocate (self%order) + if (allocated(self%current_order)) deallocate (self%current_order) + if (allocated(self%target_order)) deallocate (self%target_order) + if (allocated(self%iwork)) deallocate (self%iwork) + if (allocated(self%assigned)) deallocate (self%assigned) if (allocated(self%acache)) deallocate (self%acache) - allocate (self%assignedscratch(nat),source=.false.) - allocate (self%orderscratch(nat),source=0) - allocate (self%rankscratch(nat,2),source=0) + allocate (self%assigned(nat),source=.false.) + allocate (self%order(nat),source=0) + allocate (self%current_order(nat),source=0) + allocate (self%target_order(nat),source=0) + allocate (self%iwork(nat),source=0) + allocate (self%rank(nat,2),source=0) allocate (self%xyzscratch(3,nat,2),source=0.0_wp) allocate (self%acache) - call self%acache%allocate(nat,nat) + call self%acache%allocate(nat,nat,.true.) !> assume we are only using the LSAP implementation end subroutine allocate_rmsd_cache function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) @@ -141,7 +151,7 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) end do end if - nullify(scratchptr) + nullify (scratchptr) if (allocated(tmpscratch)) deallocate (tmpscratch) else @@ -169,18 +179,45 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) !> LOCAL type(rmsd_cache),pointer :: cptr type(rmsd_cache),allocatable,target :: local_rcache - integer :: natmax + integer :: nat,ii real(wp) :: calc_rmsd + logical,parameter :: debug = .true. + !> Initialization if (present(rcache)) then cptr => rcache else allocate (local_rcache) - natmax = max(ref%nat,mol%nat) - call local_rcache%allocate(natmax) + if (ref%nat .ne. mol%nat) then + error stop 'Unequal molecule size in min_rmsd()' + end if + nat = max(ref%nat,mol%nat) + call local_rcache%allocate(nat) + call fallbackranks(ref,mol,nat,local_rcache%rank) cptr => local_rcache end if + !> First sorting, to at least restore rank order + if (.not.all(cptr%rank(:,1) .eq. cptr%rank(:,2))) then + call rank_2_order(ref%nat,cptr%rank(:,1),cptr%target_order) + call rank_2_order(mol%nat,cptr%rank(:,2),cptr%current_order) + if (debug) then + write (*,*) 'current order & rank & target order' + do ii = 1,mol%nat + write (*,*) cptr%current_order(ii),cptr%rank(ii,2),cptr%target_order(ii) + end do + end if + call molatomsort(mol,mol%nat,cptr%current_order,cptr%target_order,cptr%iwork) + cptr%rank(:,2) = cptr%rank(:,1) !> since the ranks must be equal now! + if (debug) then + write (*,*) 'sorted order & rank' + do ii = 1,mol%nat + write (*,*) cptr%current_order(ii),cptr%rank(ii,2) + end do + end if + end if + + !> final RMSD calc_rmsd = rmsd(ref,mol,scratch=cptr%xyzscratch) if (present(rmsdout)) rmsdout = calc_rmsd @@ -188,55 +225,137 @@ end subroutine min_rmsd !========================================================================================! - subroutine atswp(mol,ati,atj) - !******************************** - !* swap atom ati with atj in mol - !******************************** - implicit none - type(coord),intent(inout) :: mol - integer,intent(in) :: ati,atj - real(wp) :: xyztmp(3) - integer :: attmp - xyztmp(1:3) = mol%xyz(1:3,ati) - attmp = mol%at(ati) - mol%xyz(1:3,ati) = mol%xyz(1:3,atj) - mol%at(ati) = mol%at(atj) - mol%xyz(1:3,atj) = xyztmp(1:3) - mol%at(atj) = attmp - end subroutine atswp + subroutine fallbackranks(ref,mol,nat,ranks) +!***************************************************************** +!* If we are doing ranks on-the-fly (i.e. without canonical algo) +!* we can fall back to just using the atom types +!***************************************************************** + implicit none + type(coord),intent(in) :: ref,mol + integer,intent(in) :: nat + integer,intent(inout) :: ranks(nat,2) + + integer,allocatable :: typemap(:),rtypemap(:) + integer :: k,ii + allocate (typemap(nat),source=0) + k = 0 + do ii = 1,ref%nat + if (.not.any(typemap(:) .eq. ref%at(ii))) then + k = k+1 + typemap(k) = ref%at(ii) + end if + end do + do ii = 1,mol%nat + if (.not.any(typemap(:) .eq. mol%at(ii))) then + k = k+1 + typemap(k) = mol%at(ii) + end if + end do + k = maxval(typemap(:)) + allocate (rtypemap(k),source=0) + do ii = 1,nat + if (typemap(ii) == 0) cycle + rtypemap(typemap(ii)) = ii + end do + !> assign + do ii = 1,ref%nat + ranks(ii,1) = rtypemap(ref%at(ii)) + end do + do ii = 1,mol%nat + ranks(ii,2) = rtypemap(mol%at(ii)) + end do + deallocate (rtypemap) + deallocate (typemap) + end subroutine fallbackranks !========================================================================================! subroutine compute_hungarian(ref,mol,acache) implicit none !> IN & OUTPUT - type(coord),intent(in) :: ref + type(coord),intent(in) :: ref type(coord),intent(inout) :: mol type(assignment_cache),intent(inout),optional,target :: acache !> LOCAL type(assignment_cache),pointer :: aptr type(assignment_cache),allocatable,target :: local_acache - integer :: natmax - + integer :: nat if (present(acache)) then aptr => acache else allocate (local_acache) - natmax = max(ref%nat,mol%nat) - call local_acache%allocate(natmax,natmax) + if (ref%nat .ne. mol%nat) then + error stop 'Unequal molecule size in compute_hungarian()' + end if + nat = max(ref%nat,mol%nat) + call local_acache%allocate(nat,nat,.true.) aptr => local_acache end if - !> Compute the cost matrix, which is simply the distance matrix + !> Compute the cost matrix, which is simply the distance matrix !> between the two molecules. - !> To avoid computational overhead we can skip the square root. - !> It won't affect the result + !> To avoid computational overhead we can skip the square root. + !> It won't affect the result + end subroutine compute_hungarian +!========================================================================================! - end subroutine compute_hungarian + subroutine rank_2_order(nat,rank,order) + implicit none + integer,intent(in) :: nat + integer,intent(in) :: rank(nat) + integer,intent(out) :: order(nat) + integer :: ii,jj,k,maxrank + order(:) = 0 + maxrank = maxval(rank(:)) + k = 0 + do ii = 1,maxrank + do jj = 1,nat + if (rank(jj) == ii) then + k = k+1 + order(jj) = k + end if + end do + end do + end subroutine rank_2_order + + subroutine molatomsort(mol,n,current_order,target_order,index_map) + implicit none + type(coord),intent(inout) :: mol + integer,intent(in) :: n + integer,intent(inout) :: current_order(n) + integer,intent(in) :: target_order(n) + integer,intent(inout) :: index_map(n) + integer :: i,j,correct_atom,current_position + + !> Step 1: Create a mapping from target_order to current_order positions + do i = 1,n + index_map(current_order(i)) = i + end do + + !> Step 2: Restore the target order + do i = 1,n + correct_atom = target_order(i) + current_position = index_map(correct_atom) + + if (i /= current_position) then + !> Swap atoms i and current_position in molecule + call mol%swap(i,current_position) + + !> Update the index map since the atoms have been swapped + index_map(current_order(i)) = current_position + index_map(current_order(current_position)) = i + + !> Update the current_order array to reflect the swap + j = current_order(i) + current_order(i) = current_order(current_position) + current_order(current_position) = j + end if + end do + end subroutine molatomsort !========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< coord_get_CN !> calculate coordination number procedure :: get_z => coord_get_z !> calculate nuclear charge procedure :: cn_to_bond => coord_cn_to_bond !> generate neighbour matrix from CN + procedure :: swap => atswp !> swap two atoms coordinates and their at() entries end type coord !=========================================================================================! !ensemble class. contains all structures of an ensemble @@ -2370,6 +2371,25 @@ subroutine get_atlist(nat,atlist,line,at) deallocate (substr) end subroutine get_atlist +!=========================================================================================! + + subroutine atswp(self,ati,atj) + !******************************** + !* swap atom ati with atj in mol + !******************************** + implicit none + class(coord),intent(inout) :: self + integer,intent(in) :: ati,atj + real(wp) :: xyztmp(3) + integer :: attmp + xyztmp(1:3) = self%xyz(1:3,ati) + attmp = self%at(ati) + self%xyz(1:3,ati) = self%xyz(1:3,atj) + self%at(ati) = self%at(atj) + self%xyz(1:3,atj) = xyztmp(1:3) + self%at(atj) = attmp + end subroutine atswp + !=========================================================================================! !=========================================================================================! ! end of the module From 8092ad3e6e59216f5021fdae47e4b3dcaa86f964 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 3 Sep 2024 01:00:27 +0200 Subject: [PATCH 012/374] cntd. work on invariant RMSD --- src/minitools.f90 | 2 + src/sorting/canonical.f90 | 76 ++++++++++++++++++++++ src/sorting/irmsd_module.f90 | 123 ++++++++++++++++++++++++++++++++--- 3 files changed, 191 insertions(+), 10 deletions(-) diff --git a/src/minitools.f90 b/src/minitools.f90 index 96b14f60..bd24aef0 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -760,6 +760,7 @@ end subroutine quick_hungarian_match subroutine irmsd_tool(fname1,fname2) use crest_parameters use strucrd + use axis_module use irmsd_module implicit none character(len=*),intent(in) :: fname1 @@ -771,6 +772,7 @@ subroutine irmsd_tool(fname1,fname2) call ref%open(fname1) call mol%open(fname2) + call axis(ref%nat,ref%at,ref%xyz) call min_rmsd(ref,mol,rmsdout=rmsdval) !> write the rotated and shifted coordinates to one file diff --git a/src/sorting/canonical.f90 b/src/sorting/canonical.f90 index 8c88a233..e8ead273 100644 --- a/src/sorting/canonical.f90 +++ b/src/sorting/canonical.f90 @@ -55,7 +55,9 @@ module canonical_mod procedure :: iterate procedure :: rankprint procedure :: stereo => analyze_stereo + procedure :: hasstereo => has_stereo procedure :: compare => compare_canonical_sorter + procedure :: add_h_ranks end type canonical_sorter logical,parameter :: debug = .false. @@ -513,6 +515,42 @@ subroutine analyze_stereo(self,mol) deallocate (neiranks,isstereo) end subroutine analyze_stereo +!===========================================================================================! + + function has_stereo(self,mol) result(yesno) + implicit none + logical :: yesno + class(canonical_sorter),intent(in) :: self + type(coord),intent(in) :: mol + integer :: i,ii,zero,nei,j,jj,maxrank + integer :: k,l,rs + integer,allocatable :: neiranks(:,:) + real(wp) :: coords(3,4) + logical,allocatable :: isstereo(:) + allocate (isstereo(mol%nat),source=.false.) + allocate (neiranks(4,mol%nat),source=0) + maxrank = maxval(self%rank(:)) + do i = 1,self%hatms + ii = self%hmap(i) + zero = count(self%neigh(:,ii) == 0) + nei = self%maxnei-zero +!>--- consider only atoms with 4 unique (in terms of ranks) neighbours as stereocenter + if (nei == 4) then + do j = 1,4 + jj = self%neigh(j,ii) + if (mol%at(jj) == 1) then !> one hydrogen allowed + neiranks(j,ii) = maxrank+1 + else + neiranks(j,ii) = self%rank(jj) + end if + end do + isstereo(ii) = unique_neighbours(4,neiranks(:,ii)) + end if + end do + yesno = any(isstereo(:)) + deallocate (neiranks,isstereo) + end function has_stereo + !========================================================================================! function compare_canonical_sorter(self,other) result(yesno) @@ -569,6 +607,44 @@ function compare_canonical_sorter(self,other) result(yesno) return end function compare_canonical_sorter +!========================================================================================! + + subroutine add_h_ranks(self,mol) +!****************************************************************** +!* Mapps ranks of the heavy atoms back to the full molecule order +!* And continues ranks for H atoms, based on neighbor list +!****************************************************************** + implicit none + class(canonical_sorter),intent(inout) :: self + type(coord),intent(in) :: mol + integer,allocatable :: rankh(:) + integer :: i,ii,zero,nei,j,jj,maxrank + logical :: hneigh +!>--- if there is no H, or this routine was already called, return + if(size(self%rank,1).eq.mol%nat) return +!>--- otherwise, analyze and resize + maxrank=maxval(self%rank(:),1) + allocate(rankh(mol%nat), source=0) + do i = 1,self%hatms + ii = self%hmap(i) + zero = count(self%neigh(:,ii) == 0) + nei = self%maxnei-zero + rankh(ii) = self%rank(i) + hneigh = .false. + do j=1,nei + jj = self%neigh(j,ii) + if (mol%at(jj) == 1) then + if(.not.hneigh)then + hneigh=.true. + maxrank=maxrank+1 + endif + rankh(jj)=maxrank + endif + enddo + enddo + call move_alloc(rankh,self%rank) + end subroutine add_h_ranks + !========================================================================================! !========================================================================================! diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index 60eb86d6..11cdd5eb 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -8,6 +8,7 @@ module irmsd_module use ls_rmsd,only:rmsd_classic => rmsd use strucrd use hungarian_module + use axis_module implicit none private @@ -24,17 +25,24 @@ module irmsd_module !**************************************************** real(wp),allocatable :: xyzscratch(:,:,:) integer,allocatable :: rank(:,:) - integer,allocatable :: order(:) + integer,allocatable :: best_order(:,:) integer,allocatable :: current_order(:) integer,allocatable :: target_order(:) integer,allocatable :: iwork(:) - logical,allocatable :: assigned(:) + logical,allocatable :: assigned(:) !> atom-wise + logical,allocatable :: rassigned(:) !> rank-wise + + integer :: nranks = 0 + integer,allocatable :: ngroup(:) + logical :: stereocheck = .false. type(assignment_cache),allocatable :: acache contains procedure :: allocate => allocate_rmsd_cache end type rmsd_cache + real(wp),parameter :: inf = huge(1.0_wp) + !========================================================================================! !========================================================================================! contains !> MODULE PROCEDURES START HERE @@ -47,18 +55,23 @@ subroutine allocate_rmsd_cache(self,nat) integer,intent(in) :: nat if (allocated(self%xyzscratch)) deallocate (self%xyzscratch) if (allocated(self%rank)) deallocate (self%rank) - if (allocated(self%order)) deallocate (self%order) + if (allocated(self%best_order)) deallocate (self%best_order) if (allocated(self%current_order)) deallocate (self%current_order) if (allocated(self%target_order)) deallocate (self%target_order) if (allocated(self%iwork)) deallocate (self%iwork) if (allocated(self%assigned)) deallocate (self%assigned) + if (allocated(self%rassigned)) deallocate (self%rassigned) + if (allocated(self%ngroup)) deallocate (self%ngroup) if (allocated(self%acache)) deallocate (self%acache) allocate (self%assigned(nat),source=.false.) - allocate (self%order(nat),source=0) + allocate (self%rassigned(nat),source=.false.) + allocate (self%best_order(nat,3),source=0) allocate (self%current_order(nat),source=0) allocate (self%target_order(nat),source=0) allocate (self%iwork(nat),source=0) allocate (self%rank(nat,2),source=0) + self%nranks = 0 + allocate (self%ngroup(nat), source=0) allocate (self%xyzscratch(3,nat,2),source=0.0_wp) allocate (self%acache) call self%acache%allocate(nat,nat,.true.) !> assume we are only using the LSAP implementation @@ -179,11 +192,12 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) !> LOCAL type(rmsd_cache),pointer :: cptr type(rmsd_cache),allocatable,target :: local_rcache - integer :: nat,ii + integer :: nat,ii,rnk real(wp) :: calc_rmsd + real(wp) :: tmprmsd_sym(3) logical,parameter :: debug = .true. - !> Initialization +!>--- Initialization if (present(rcache)) then cptr => rcache else @@ -197,7 +211,13 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) cptr => local_rcache end if - !> First sorting, to at least restore rank order +!>-- Consistency check + cptr%nranks = maxval(cptr%rank(:,1)) + if(cptr%nranks .ne. maxval(cptr%rank(:,2)))then + error stop "Different atom identities in min_rmsd, can't restore an atom order!" + endif + +!>--- First sorting, to at least restore rank order if (.not.all(cptr%rank(:,1) .eq. cptr%rank(:,2))) then call rank_2_order(ref%nat,cptr%rank(:,1),cptr%target_order) call rank_2_order(mol%nat,cptr%rank(:,2),cptr%current_order) @@ -217,12 +237,82 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) end if end if - !> final RMSD +!>--- Count symmetry equivalent groups and assign all unique atoms immediately +! Note, the rank can be zero if we only are looking at heavy atoms + if(all(cptr%ngroup(:) .eq. 0))then + do ii=1,ref%nat + rnk = cptr%rank(ii,1) + if(rnk>0)then + cptr%ngroup(rnk) = cptr%ngroup(rnk) + 1 + endif + enddo + endif + !> assignment reset + cptr%assigned(:) = .false. + cptr%rassigned(:) = .false. + cptr%rassigned(cptr%nranks:) = .true. + do ii=1,ref%nat + rnk = cptr%rank(ii,2) + if(rnk < 1)then + cptr%assigned(ii) = .true. + cycle + endif + if(cptr%ngroup(rnk) .eq. 1)then + cptr%assigned(ii) = .true. + endif + enddo + if(debug)then + write (*,*) 'rank & # members' + do ii = 1,mol%nat + if(cptr%ngroup(ii) > 0)then + write (*,*) ii,cptr%ngroup(ii) + endif + end do + endif + +!>--- Perform the desired symmetry operations, align with rotational axis, run LSAP algo + tmprmsd_sym(:) = inf !> initialize to huge + call axis(mol%nat, mol%at, mol%xyz) + call min_rmsd_iterate_through_groups(ref,mol,1,cptr) + + !> mirror z + if(cptr%stereocheck)then + mol%xyz(3,:) = -mol%xyz(3,:) + call axis(mol%nat, mol%at, mol%xyz) + call min_rmsd_iterate_through_groups(ref,mol,1,cptr) + endif + + +!>--- select the best match among the ones after symmetry operations and use its ordering + + +!>--- final RMSD with fully restored atom order calc_rmsd = rmsd(ref,mol,scratch=cptr%xyzscratch) if (present(rmsdout)) rmsdout = calc_rmsd end subroutine min_rmsd +!========================================================================================! + + subroutine min_rmsd_iterate_through_groups(ref,mol,step,rcache) + implicit none + type(coord),intent(in) :: ref + type(coord),intent(inout) :: mol + integer,intent(in) :: step + type(rmsd_cache),intent(inout) :: rcache + integer :: rr + logical,parameter :: debug=.true. + + if(debug)then + write(*,*) '# ranks:',rcache%nranks + endif + do rr=1,rcache%nranks + if(rcache%rassigned(rr)) cycle + + enddo + + end subroutine min_rmsd_iterate_through_groups + !========================================================================================! subroutine fallbackranks(ref,mol,nat,ranks) @@ -270,17 +360,23 @@ end subroutine fallbackranks !========================================================================================! - subroutine compute_hungarian(ref,mol,acache) + subroutine compute_hungarian(ref,mol,ranks,targetrank,acache) +!************************************************************** +!* Run the linear assignment algorithm on the desired subset +!* of atoms (via rank and targetrank) +!************************************************************** implicit none !> IN & OUTPUT type(coord),intent(in) :: ref type(coord),intent(inout) :: mol + integer,intent(in) :: ranks(:) + integer,intent(in) :: targetrank type(assignment_cache),intent(inout),optional,target :: acache !> LOCAL type(assignment_cache),pointer :: aptr type(assignment_cache),allocatable,target :: local_acache - integer :: nat + integer :: nat,i,ii,jj if (present(acache)) then aptr => acache @@ -301,6 +397,11 @@ subroutine compute_hungarian(ref,mol,acache) end subroutine compute_hungarian + +!========================================================================================! + + + !========================================================================================! subroutine rank_2_order(nat,rank,order) @@ -322,6 +423,8 @@ subroutine rank_2_order(nat,rank,order) end do end subroutine rank_2_order +!========================================================================================! + subroutine molatomsort(mol,n,current_order,target_order,index_map) implicit none type(coord),intent(inout) :: mol From a4c6e58e9f20a6a4e16db163ae6a2fe3ceb622d3 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 8 Sep 2024 01:25:52 +0200 Subject: [PATCH 013/374] Flatten Cost matrix in LSAP algos, run it for each group of atom ranks --- src/sorting/hungarian.f90 | 56 ++++++++------ src/sorting/irmsd_module.f90 | 139 +++++++++++++++++++++++------------ 2 files changed, 124 insertions(+), 71 deletions(-) diff --git a/src/sorting/hungarian.f90 b/src/sorting/hungarian.f90 index 354f011e..e9289a90 100644 --- a/src/sorting/hungarian.f90 +++ b/src/sorting/hungarian.f90 @@ -40,7 +40,7 @@ module hungarian_module public :: assignment_cache type :: assignment_cache integer :: J,W - real(sp),allocatable :: Cost(:,:) !> Cost(J,W) + real(sp),allocatable :: Cost(:) !> Cost(J*W), 1D for more efficient memory access !> Hungarian algo related real(sp),allocatable :: answers(:) !> answers(J) integer,allocatable :: job(:) !> job(W+1) @@ -75,8 +75,9 @@ module hungarian_module subroutine allocate_assignment_cache(self,J,W,lsapcache) implicit none + integer,intent(in) :: J + integer,intent(in) :: W class(assignment_cache),intent(inout) :: self - integer,intent(in) :: J,W logical,intent(in),optional :: lsapcache logical :: yesno yesno = .false. @@ -88,7 +89,7 @@ subroutine allocate_assignment_cache(self,J,W,lsapcache) if (J > W) then error stop 'linear assignment problems require rectengular matrices!' end if - allocate (self%Cost(J,W)) + allocate (self%Cost(J*W)) !> Allocate arrays based on input dimensions & algo type if (.not.yesno) then @@ -185,7 +186,8 @@ subroutine hungarian_cached(cache,J,W) !* job(W+1) - Vector where job(ww) is the job assigned to !* the ww-th worker (or -1 if no job is assigned) !**************************************************************** - integer,intent(in) :: J,W + integer,intent(in) :: J + integer,intent(in) :: W type(assignment_cache),intent(inout) :: cache integer :: jj_cur,ww_cur,jj,ww_next,ww real(sp) :: delta @@ -204,7 +206,7 @@ subroutine hungarian_cached(cache,J,W) job = -1 ys = 0 yt = 0 - Ct = transpose(C) + !Ct = transpose(reshape(C,[J,W])) do jj_cur = 1,J !> O(n¹) ww_cur = W+1 @@ -219,7 +221,8 @@ subroutine hungarian_cached(cache,J,W) delta = inf do ww = 1,W !> O(n²) -> O(n³) if (.not.in_Z(ww)) then - if (ckmin(min_to(ww),Ct(ww,jj)-ys(jj)-yt(ww))) then + !if (ckmin(min_to(ww),Ct(ww,jj)-ys(jj)-yt(ww))) then + if (ckmin(min_to(ww),C(jj+(ww-1)*J)-ys(jj)-yt(ww))) then prv(ww) = ww_cur end if if (ckmin(delta,min_to(ww))) then @@ -258,14 +261,15 @@ subroutine hungarian_wrap_int(C,J,W,answers,job) !* Wrapper for integer precision !********************************************* implicit none + integer,intent(in) :: J + integer,intent(in) :: W integer,intent(in) :: C(J,W) - integer,intent(in) :: J,W integer,intent(out) :: answers(J) integer,intent(out) :: job(W+1) type(assignment_cache) :: cache call cache%allocate(J,W) - cache%Cost(1:J,1:W) = real(C(1:J,1:W),sp) + cache%Cost(1:J*W) = reshape(real(C(1:J,1:W),sp),[J*W]) call hungarian_cached(cache,J,W) answers(1:J) = nint(cache%answers(1:J)) @@ -278,14 +282,15 @@ subroutine hungarian_wrap_sp(C,J,W,answers,job) !* Wrapper for single precision !********************************************* implicit none + integer,intent(in) :: J + integer,intent(in) :: W real(sp),intent(in) :: C(J,W) - integer,intent(in) :: J,W real(sp),intent(out) :: answers(J) integer,intent(out) :: job(W+1) type(assignment_cache) :: cache call cache%allocate(J,W) - cache%Cost(1:J,1:W) = C(1:J,1:W) + cache%Cost(1:J*W) = reshape(C(1:J,1:W),[J*W]) call hungarian_cached(cache,J,W) answers(1:J) = cache%answers(1:J) @@ -298,14 +303,15 @@ subroutine hungarian_wrap_wp(C,J,W,answers,job) !* Wrapper for double precision !********************************************* implicit none + integer,intent(in) :: J + integer,intent(in) :: W real(wp),intent(in) :: C(J,W) - integer,intent(in) :: J,W real(wp),intent(out) :: answers(J) integer,intent(out) :: job(W+1) type(assignment_cache) :: cache call cache%allocate(J,W) - cache%Cost(1:J,1:W) = real(C(1:J,1:W),sp) + cache%Cost(1:J*W) = reshape(real(C(1:J,1:W),sp),[J*W]) call hungarian_cached(cache,J,W) answers(1:J) = real(cache%answers(1:J),wp) @@ -327,12 +333,13 @@ end subroutine hungarian_wrap_wp !* of the C++ lsap algorithm in SciPy !**************************************************************** - function augmenting_path(nc,cost,u,v,path,row4col, & + function augmenting_path(nr,nc,cost,u,v,path,row4col, & & shortestPathCosts,i,SR,SC, & & remaining,minValue) result(sink) implicit none + integer,intent(in) :: nr !> Number of columns (jobs) integer,intent(in) :: nc !> Number of columns (workers) - real(sp),intent(in) :: cost(:,:) !> Cost matrix + real(sp),intent(in) :: cost(:) !> Cost matrix (1D, nr*nc length) real(sp),intent(inout) :: u(:) !> Dual variables for rows (jobs) real(sp),intent(inout) :: v(:) !> Dual variables for columns (workers) integer,intent(inout) :: path(:) !> Path array @@ -369,7 +376,7 @@ function augmenting_path(nc,cost,u,v,path,row4col, & do it = 1,num_remaining j = remaining(it) - r = minValue+cost(i,j)-u(i)-v(j) + r = minValue+cost(i+((j-1)*nr))-u(i)-v(j) if (r < shortestPathCosts(j)) then path(j) = i shortestPathCosts(j) = r @@ -435,6 +442,8 @@ subroutine lsap_cached(lcache,nr,nc,maximize,iostatus) !> Handle trivial inputs if (nr == 1.or.nc == 1) then + a(1) = 1 + b(1) = 1 iostatus = 0 return end if @@ -462,7 +471,7 @@ subroutine lsap_cached(lcache,nr,nc,maximize,iostatus) do curRow = 1,nr curRowtmp = curRow !> Call augmenting_path routine - sink = augmenting_path(nc,cost,u,v,path,row4col, & + sink = augmenting_path(nr,nc,cost,u,v,path,row4col, & & shortestPathCosts,curRowtmp, & & SR,SC,remaining,minValue) if (sink < 0) then @@ -511,15 +520,16 @@ subroutine lsap_wrap_int(C,J,W,a,b) !* Wrapper for integer precision !********************************************* implicit none + integer,intent(in) :: J + integer,intent(in) :: W integer,intent(in) :: C(J,W) - integer,intent(in) :: J,W integer,intent(out),allocatable :: a(:) integer,intent(out),allocatable :: b(:) type(assignment_cache) :: cache integer :: io call cache%allocate(J,W,.true.) - cache%Cost(1:J,1:W) = real(C(1:J,1:W),sp) + cache%Cost(1:J*W) = reshape(real(C(1:J,1:W),sp), [J*W]) call lsap_cached(cache,J,W,.false.,io) allocate(a(J), b(J)) @@ -534,15 +544,16 @@ subroutine lsap_wrap_sp(C,J,W,a,b) !* Wrapper for single precision !********************************************* implicit none + integer,intent(in) :: J + integer,intent(in) :: W real(sp),intent(in) :: C(J,W) - integer,intent(in) :: J,W integer,intent(out),allocatable :: a(:) integer,intent(out),allocatable :: b(:) type(assignment_cache) :: cache integer :: io call cache%allocate(J,W,.true.) - cache%Cost(1:J,1:W) = C(1:J,1:W) + cache%Cost(1:J*W) = reshape(C(1:J,1:W), [J*W]) call lsap_cached(cache,J,W,.false.,io) allocate(a(J), b(J)) @@ -557,15 +568,16 @@ subroutine lsap_wrap_wp(C,J,W,a,b) !* Wrapper for double precision !********************************************* implicit none + integer,intent(in) :: J + integer,intent(in) :: W real(wp),intent(in) :: C(J,W) - integer,intent(in) :: J,W integer,intent(out),allocatable :: a(:) integer,intent(out),allocatable :: b(:) type(assignment_cache) :: cache integer :: io call cache%allocate(J,W,.true.) - cache%Cost(1:J,1:W) = real(C(1:J,1:W),sp) + cache%Cost(1:J*W) = reshape(real(C(1:J,1:W),sp), [J*W]) call lsap_cached(cache,J,W,.false.,io) allocate(a(J), b(J)) diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index 11cdd5eb..0f00628d 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -29,6 +29,7 @@ module irmsd_module integer,allocatable :: current_order(:) integer,allocatable :: target_order(:) integer,allocatable :: iwork(:) + integer,allocatable :: iwork2(:,:) logical,allocatable :: assigned(:) !> atom-wise logical,allocatable :: rassigned(:) !> rank-wise @@ -59,6 +60,7 @@ subroutine allocate_rmsd_cache(self,nat) if (allocated(self%current_order)) deallocate (self%current_order) if (allocated(self%target_order)) deallocate (self%target_order) if (allocated(self%iwork)) deallocate (self%iwork) + if (allocated(self%iwork2)) deallocate (self%iwork2) if (allocated(self%assigned)) deallocate (self%assigned) if (allocated(self%rassigned)) deallocate (self%rassigned) if (allocated(self%ngroup)) deallocate (self%ngroup) @@ -69,9 +71,10 @@ subroutine allocate_rmsd_cache(self,nat) allocate (self%current_order(nat),source=0) allocate (self%target_order(nat),source=0) allocate (self%iwork(nat),source=0) + allocate (self%iwork2(nat,2),source=0) allocate (self%rank(nat,2),source=0) self%nranks = 0 - allocate (self%ngroup(nat), source=0) + allocate (self%ngroup(nat),source=0) allocate (self%xyzscratch(3,nat,2),source=0.0_wp) allocate (self%acache) call self%acache%allocate(nat,nat,.true.) !> assume we are only using the LSAP implementation @@ -213,9 +216,9 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) !>-- Consistency check cptr%nranks = maxval(cptr%rank(:,1)) - if(cptr%nranks .ne. maxval(cptr%rank(:,2)))then + if (cptr%nranks .ne. maxval(cptr%rank(:,2))) then error stop "Different atom identities in min_rmsd, can't restore an atom order!" - endif + end if !>--- First sorting, to at least restore rank order if (.not.all(cptr%rank(:,1) .eq. cptr%rank(:,2))) then @@ -237,55 +240,53 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) end if end if -!>--- Count symmetry equivalent groups and assign all unique atoms immediately +!>--- Count symmetry equivalent groups and assign all unique atoms immediately ! Note, the rank can be zero if we only are looking at heavy atoms - if(all(cptr%ngroup(:) .eq. 0))then - do ii=1,ref%nat - rnk = cptr%rank(ii,1) - if(rnk>0)then - cptr%ngroup(rnk) = cptr%ngroup(rnk) + 1 - endif - enddo - endif + if (all(cptr%ngroup(:) .eq. 0)) then + do ii = 1,ref%nat + rnk = cptr%rank(ii,1) + if (rnk > 0) then + cptr%ngroup(rnk) = cptr%ngroup(rnk)+1 + end if + end do + end if !> assignment reset cptr%assigned(:) = .false. cptr%rassigned(:) = .false. - cptr%rassigned(cptr%nranks:) = .true. - do ii=1,ref%nat + cptr%rassigned(cptr%nranks+1:) = .true. !> skip unneeded allocation space + do ii = 1,ref%nat rnk = cptr%rank(ii,2) - if(rnk < 1)then + if (rnk < 1) then cptr%assigned(ii) = .true. cycle - endif - if(cptr%ngroup(rnk) .eq. 1)then + end if + if (cptr%ngroup(rnk) .eq. 1) then cptr%assigned(ii) = .true. - endif - enddo - if(debug)then - write (*,*) 'rank & # members' + end if + end do + if (debug) then + write (*,*) 'rank & # members' do ii = 1,mol%nat - if(cptr%ngroup(ii) > 0)then + if (cptr%ngroup(ii) > 0) then write (*,*) ii,cptr%ngroup(ii) - endif + end if end do - endif + end if !>--- Perform the desired symmetry operations, align with rotational axis, run LSAP algo tmprmsd_sym(:) = inf !> initialize to huge - call axis(mol%nat, mol%at, mol%xyz) + call axis(mol%nat,mol%at,mol%xyz) call min_rmsd_iterate_through_groups(ref,mol,1,cptr) !> mirror z - if(cptr%stereocheck)then + if (cptr%stereocheck) then mol%xyz(3,:) = -mol%xyz(3,:) - call axis(mol%nat, mol%at, mol%xyz) + call axis(mol%nat,mol%at,mol%xyz) call min_rmsd_iterate_through_groups(ref,mol,1,cptr) - endif - + end if !>--- select the best match among the ones after symmetry operations and use its ordering - !>--- final RMSD with fully restored atom order calc_rmsd = rmsd(ref,mol,scratch=cptr%xyzscratch) @@ -295,21 +296,24 @@ end subroutine min_rmsd !========================================================================================! subroutine min_rmsd_iterate_through_groups(ref,mol,step,rcache) - implicit none - type(coord),intent(in) :: ref - type(coord),intent(inout) :: mol - integer,intent(in) :: step - type(rmsd_cache),intent(inout) :: rcache - integer :: rr - logical,parameter :: debug=.true. + implicit none + type(coord),intent(in) :: ref + type(coord),intent(inout) :: mol + integer,intent(in) :: step + type(rmsd_cache),intent(inout),target :: rcache + integer :: rr + type(assignment_cache),pointer :: aptr + logical,parameter :: debug = .true. - if(debug)then - write(*,*) '# ranks:',rcache%nranks - endif - do rr=1,rcache%nranks - if(rcache%rassigned(rr)) cycle - - enddo + if (debug) then + write (*,*) '# ranks:',rcache%nranks + end if + aptr => rcache%acache + do rr = 1,rcache%nranks + if (rcache%rassigned(rr)) cycle + call compute_hungarian(ref,mol,rcache%rank,rcache%ngroup,rr, & + & rcache%iwork2,aptr) + end do end subroutine min_rmsd_iterate_through_groups @@ -360,7 +364,7 @@ end subroutine fallbackranks !========================================================================================! - subroutine compute_hungarian(ref,mol,ranks,targetrank,acache) + subroutine compute_hungarian(ref,mol,ranks,ngroups,targetrank,iwork2,acache) !************************************************************** !* Run the linear assignment algorithm on the desired subset !* of atoms (via rank and targetrank) @@ -369,14 +373,19 @@ subroutine compute_hungarian(ref,mol,ranks,targetrank,acache) !> IN & OUTPUT type(coord),intent(in) :: ref type(coord),intent(inout) :: mol - integer,intent(in) :: ranks(:) + integer,intent(in) :: ranks(:,:) + integer,intent(in) :: ngroups(:) integer,intent(in) :: targetrank + integer,intent(inout) :: iwork2(:,:) type(assignment_cache),intent(inout),optional,target :: acache !> LOCAL type(assignment_cache),pointer :: aptr type(assignment_cache),allocatable,target :: local_acache - integer :: nat,i,ii,jj + integer :: nat,i,j,ii,jj,rnknat,iostatus + real(sp) :: dists(3) + + logical,parameter :: debug = .true. if (present(acache)) then aptr => acache @@ -394,14 +403,46 @@ subroutine compute_hungarian(ref,mol,ranks,targetrank,acache) !> between the two molecules. !> To avoid computational overhead we can skip the square root. !> It won't affect the result + !> Also, since aptr%Cost is a flattened matrix, we only fill + !> the first rnknat**2 entries + rnknat = ngroups(targetrank) + ii = 0 + do i = 1,ref%nat + if (ranks(i,1) .ne. targetrank) cycle + ii = ii+1 + iwork2(ii,1) = i !> mapping using the first column of iwork2 + jj = 0 + do j = 1,mol%nat + if (ranks(j,2) .ne. targetrank) cycle + jj = jj+1 + dists(:)=(ref%xyz(:,i)-mol%xyz(:,j))**2 !> use i and j + aptr%Cost(jj+(ii-1)*rnknat) = sum(dists) + end do + end do - end subroutine compute_hungarian + if (debug) then + write (*,*) 'target rank',targetrank,'# atoms',rnknat + end if -!========================================================================================! + call lsap(aptr,rnknat,rnknat,.false.,iostatus) + !> paasing back the determined order as second column of iwork2 + if(iostatus==0)then + if(debug)then + do i=1,rnknat + write (*,*) iwork2(aptr%a(i),1),'-->',iwork2(aptr%b(i),1) + enddo + endif + else + !> in the unlikely case we have a failure of the LSAP + !> we do just a 1:1 mapping, just so that the algo doesn't crash + iwork2(1:rnknat,2) = iwork2(1:rnknat,1) + endif + end subroutine compute_hungarian + !========================================================================================! subroutine rank_2_order(nat,rank,order) From 5cc3eb437e48243142c303eb5624d2b3241b24ec Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 8 Sep 2024 05:55:58 +0200 Subject: [PATCH 014/374] Nearly complete initial implementation of iRMSD --- src/minitools.f90 | 7 ++- src/sorting/irmsd_module.f90 | 105 +++++++++++++++++++++++++++-------- 2 files changed, 89 insertions(+), 23 deletions(-) diff --git a/src/minitools.f90 b/src/minitools.f90 index bd24aef0..e9c269ae 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -768,12 +768,17 @@ subroutine irmsd_tool(fname1,fname2) type(coord) :: mol,ref real(wp) :: rmsdval integer :: i,ich + type(rmsd_cache) :: rcache call ref%open(fname1) call mol%open(fname2) call axis(ref%nat,ref%at,ref%xyz) - call min_rmsd(ref,mol,rmsdout=rmsdval) + + call rcache%allocate(ref%nat) + call fallbackranks(ref,mol,ref%nat,rcache%rank) + + call min_rmsd(ref,mol,rcache=rcache,rmsdout=rmsdval) !> write the rotated and shifted coordinates to one file open(newunit=ich,file='irmsd.xyz') diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index 0f00628d..ffdb4ab8 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -15,6 +15,8 @@ module irmsd_module public :: rmsd public :: min_rmsd + public :: fallbackranks + real(wp),parameter :: bigval = huge(bigval) public :: rmsd_cache @@ -28,6 +30,7 @@ module irmsd_module integer,allocatable :: best_order(:,:) integer,allocatable :: current_order(:) integer,allocatable :: target_order(:) + integer,allocatable :: target_order_bkup(:,:) integer,allocatable :: iwork(:) integer,allocatable :: iwork2(:,:) logical,allocatable :: assigned(:) !> atom-wise @@ -59,6 +62,7 @@ subroutine allocate_rmsd_cache(self,nat) if (allocated(self%best_order)) deallocate (self%best_order) if (allocated(self%current_order)) deallocate (self%current_order) if (allocated(self%target_order)) deallocate (self%target_order) + if (allocated(self%target_order_bkup)) deallocate (self%target_order_bkup) if (allocated(self%iwork)) deallocate (self%iwork) if (allocated(self%iwork2)) deallocate (self%iwork2) if (allocated(self%assigned)) deallocate (self%assigned) @@ -70,6 +74,7 @@ subroutine allocate_rmsd_cache(self,nat) allocate (self%best_order(nat,3),source=0) allocate (self%current_order(nat),source=0) allocate (self%target_order(nat),source=0) + allocate (self%target_order_bkup(nat,2),source=0) allocate (self%iwork(nat),source=0) allocate (self%iwork2(nat,2),source=0) allocate (self%rank(nat,2),source=0) @@ -195,9 +200,9 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) !> LOCAL type(rmsd_cache),pointer :: cptr type(rmsd_cache),allocatable,target :: local_rcache - integer :: nat,ii,rnk + integer :: nat,ii,rnk,dumpunit real(wp) :: calc_rmsd - real(wp) :: tmprmsd_sym(3) + real(wp) :: tmprmsd_sym(3),dum logical,parameter :: debug = .true. !>--- Initialization @@ -220,7 +225,7 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) error stop "Different atom identities in min_rmsd, can't restore an atom order!" end if -!>--- First sorting, to at least restore rank order +!>--- First sorting, to at least restore rank order (only if that's not the case!) if (.not.all(cptr%rank(:,1) .eq. cptr%rank(:,2))) then call rank_2_order(ref%nat,cptr%rank(:,1),cptr%target_order) call rank_2_order(mol%nat,cptr%rank(:,2),cptr%current_order) @@ -255,6 +260,8 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) cptr%rassigned(:) = .false. cptr%rassigned(cptr%nranks+1:) = .true. !> skip unneeded allocation space do ii = 1,ref%nat + cptr%iwork(ii) = ii !> also init iwork + cptr%current_order(ii) = ii !> also init current_order rnk = cptr%rank(ii,2) if (rnk < 1) then cptr%assigned(ii) = .true. @@ -274,18 +281,48 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) end if !>--- Perform the desired symmetry operations, align with rotational axis, run LSAP algo + if (debug) then + open (newunit=dumpunit,file='debugirmsd.xyz') + call ref%append(dumpunit) + end if tmprmsd_sym(:) = inf !> initialize to huge call axis(mol%nat,mol%at,mol%xyz) - call min_rmsd_iterate_through_groups(ref,mol,1,cptr) + call min_rmsd_iterate_through_groups(ref,mol,1,cptr,dum) + tmprmsd_sym(1) = dum + cptr%target_order_bkup(:,1) = cptr%iwork(:) + if (debug) then + write (*,*) 'Total LSAP cost:',dum + call mol%append(dumpunit) + end if !> mirror z if (cptr%stereocheck) then mol%xyz(3,:) = -mol%xyz(3,:) call axis(mol%nat,mol%at,mol%xyz) - call min_rmsd_iterate_through_groups(ref,mol,1,cptr) + call min_rmsd_iterate_through_groups(ref,mol,1,cptr,dum) + tmprmsd_sym(2) = dum + cptr%target_order_bkup(:,2) = cptr%iwork(:) + if (debug) then + write (*,*) 'Total LSAP cost (mirrored):',dum + call mol%append(dumpunit) + end if + end if + + if (debug) then + close (dumpunit) end if !>--- select the best match among the ones after symmetry operations and use its ordering + ii = minloc(tmprmsd_sym(:),1) + write (*,*) ii + cptr%target_order(:) = cptr%target_order_bkup(:,ii) + if (debug) then + write (*,*) 'Determined remapping' + do ii = 1,mol%nat + write (*,*) cptr%current_order(ii),'-->',cptr%target_order(ii) + end do + end if + !call molatomsort(mol,mol%nat,cptr%current_order,cptr%target_order,cptr%iwork) !>--- final RMSD with fully restored atom order calc_rmsd = rmsd(ref,mol,scratch=cptr%xyzscratch) @@ -295,24 +332,40 @@ end subroutine min_rmsd !========================================================================================! - subroutine min_rmsd_iterate_through_groups(ref,mol,step,rcache) + subroutine min_rmsd_iterate_through_groups(ref,mol,step,rcache,val) implicit none type(coord),intent(in) :: ref type(coord),intent(inout) :: mol integer,intent(in) :: step type(rmsd_cache),intent(inout),target :: rcache - integer :: rr + real(wp),intent(out) :: val + integer :: rr,ii,jj + real(wp) :: val0 type(assignment_cache),pointer :: aptr logical,parameter :: debug = .true. + !> reset val + val = 0.0_wp + if (debug) then write (*,*) '# ranks:',rcache%nranks end if aptr => rcache%acache do rr = 1,rcache%nranks if (rcache%rassigned(rr)) cycle - call compute_hungarian(ref,mol,rcache%rank,rcache%ngroup,rr, & - & rcache%iwork2,aptr) + + !> LSAP wrapper that computes the relevant Cost matrix for the atoms of rank rr + call compute_linear_sum_assignment( & + & ref,mol,rcache%rank,rcache%ngroup,rr, & + & rcache%iwork2,aptr,val0) + + do ii = 1,rcache%ngroup(rr) + rcache%iwork(rcache%iwork2(ii,1)) = rcache%iwork2(ii,2) + end do + + !> add up the total LSAP cost (of considered ranks) + !> we need this if we have to decide on a mapping in case of false enantiomers + val = val+val0 end do end subroutine min_rmsd_iterate_through_groups @@ -364,7 +417,8 @@ end subroutine fallbackranks !========================================================================================! - subroutine compute_hungarian(ref,mol,ranks,ngroups,targetrank,iwork2,acache) + subroutine compute_linear_sum_assignment(ref,mol,ranks, & + & ngroups,targetrank,iwork2,acache,val0) !************************************************************** !* Run the linear assignment algorithm on the desired subset !* of atoms (via rank and targetrank) @@ -378,6 +432,7 @@ subroutine compute_hungarian(ref,mol,ranks,ngroups,targetrank,iwork2,acache) integer,intent(in) :: targetrank integer,intent(inout) :: iwork2(:,:) type(assignment_cache),intent(inout),optional,target :: acache + real(wp),intent(out) :: val0 !> LOCAL type(assignment_cache),pointer :: aptr @@ -387,12 +442,14 @@ subroutine compute_hungarian(ref,mol,ranks,ngroups,targetrank,iwork2,acache) logical,parameter :: debug = .true. + val0 = 0.0_wp + if (present(acache)) then aptr => acache else allocate (local_acache) if (ref%nat .ne. mol%nat) then - error stop 'Unequal molecule size in compute_hungarian()' + error stop 'Unequal molecule size in compute_linear_sum_assignment()' end if nat = max(ref%nat,mol%nat) call local_acache%allocate(nat,nat,.true.) @@ -415,12 +472,11 @@ subroutine compute_hungarian(ref,mol,ranks,ngroups,targetrank,iwork2,acache) do j = 1,mol%nat if (ranks(j,2) .ne. targetrank) cycle jj = jj+1 - dists(:)=(ref%xyz(:,i)-mol%xyz(:,j))**2 !> use i and j + dists(:) = (ref%xyz(:,i)-mol%xyz(:,j))**2 !> use i and j aptr%Cost(jj+(ii-1)*rnknat) = sum(dists) end do end do - if (debug) then write (*,*) 'target rank',targetrank,'# atoms',rnknat end if @@ -428,20 +484,25 @@ subroutine compute_hungarian(ref,mol,ranks,ngroups,targetrank,iwork2,acache) call lsap(aptr,rnknat,rnknat,.false.,iostatus) !> paasing back the determined order as second column of iwork2 - if(iostatus==0)then - if(debug)then - do i=1,rnknat + if (iostatus == 0) then + if (debug) then + do i = 1,rnknat write (*,*) iwork2(aptr%a(i),1),'-->',iwork2(aptr%b(i),1) - enddo - endif + end do + end if + do i = 1,rnknat + jj = aptr%a(i) + ii = aptr%b(i) + val0 = val0+aptr%Cost(jj+(ii-1)*rnknat) + iwork2(i,2) = iwork2(aptr%b(i),1) + end do else !> in the unlikely case we have a failure of the LSAP !> we do just a 1:1 mapping, just so that the algo doesn't crash - iwork2(1:rnknat,2) = iwork2(1:rnknat,1) - endif - + iwork2(1:rnknat,2) = iwork2(1:rnknat,1) + end if - end subroutine compute_hungarian + end subroutine compute_linear_sum_assignment !========================================================================================! From 53d6aa9a8dfba567706a19389a5dd6b41388fcf9 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 9 Sep 2024 03:31:51 +0200 Subject: [PATCH 015/374] almost working standalone tool --- src/minitools.f90 | 33 +++++- src/sorting/canonical.f90 | 56 +++++---- src/sorting/irmsd_module.f90 | 220 ++++++++++++++++++++++++++++++++--- 3 files changed, 270 insertions(+), 39 deletions(-) diff --git a/src/minitools.f90 b/src/minitools.f90 index e9c269ae..7a785abb 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -762,6 +762,7 @@ subroutine irmsd_tool(fname1,fname2) use strucrd use axis_module use irmsd_module + use canonical_mod implicit none character(len=*),intent(in) :: fname1 character(len=*),intent(in) :: fname2 @@ -769,14 +770,44 @@ subroutine irmsd_tool(fname1,fname2) real(wp) :: rmsdval integer :: i,ich type(rmsd_cache) :: rcache + type(canonical_sorter) :: canmol + type(canonical_sorter) :: canref + logical,parameter :: debug=.true. + !> read the geometries call ref%open(fname1) call mol%open(fname2) + !> move ref to CMA and align rotational axes call axis(ref%nat,ref%at,ref%xyz) + !> allocate memory call rcache%allocate(ref%nat) - call fallbackranks(ref,mol,ref%nat,rcache%rank) + + !> canonical atom ranks + call canref%init(ref,invtype='apsp+') + call canref%add_h_ranks(ref) + rcache%stereocheck = .not.(canref%hasstereo(ref)) + call canref%shrink() + + call canmol%init(mol,invtype='apsp+') + call canmol%add_h_ranks(mol) + call canmol%shrink() + + !> check if we can work with the determined ranks + if(checkranks(ref%nat,canref%rank,canmol%rank))then + rcache%rank(:,1) = canref%rank(:) + rcache%rank(:,2) = canmol%rank(:) + if(debug)then + write(*,*) 'iRMSD ranks:' + do i=1,ref%nat + write(*,*) rcache%rank(i,1),rcache%rank(i,2) + enddo + endif + else + !> if not, fall back to atom types + call fallbackranks(ref,mol,ref%nat,rcache%rank) + endif call min_rmsd(ref,mol,rcache=rcache,rmsdout=rmsdval) diff --git a/src/sorting/canonical.f90 b/src/sorting/canonical.f90 index e8ead273..8b2ba0ac 100644 --- a/src/sorting/canonical.f90 +++ b/src/sorting/canonical.f90 @@ -2,7 +2,7 @@ module canonical_mod !************************************************************************* !* Implementation of different algorithms for determining atom identities -!* +!* !* A) Implementation of the CANGEN algorithm by Weininger et al. !* D.Weininger et al., J. Chem. Inf. Comput. Sci., 1989, 29, 97-101. !* doi.org/10.1021/ci00062a008 @@ -228,9 +228,9 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) case default !> CANGEN - if(.not.present(wbo))then + if (.not.present(wbo)) then error stop 'CANGEN implementation requires wbo matrix as argument' - endif + end if do i = 1,k ii = self%hmap(i) ati = mol%at(ii) @@ -241,7 +241,7 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) if (Amat(j,ii) .ne. 0) then if (mol%at(j) .eq. 1) then counth = counth+1 !> count H neighbours - countbo2 = countbo2-wbo(j,ii) !> but NOT in total bond order + countbo2 = countbo2-wbo(j,ii) !> but NOT in total bond order end if countb = countb+1 !> count all neighbours !countbo2 = countbo2+wbo(j,ii) !> sum the total bond order @@ -477,7 +477,7 @@ subroutine analyze_stereo(self,mol) zero = count(self%neigh(:,ii) == 0) nei = self%maxnei-zero !>--- consider only atoms with 4 unique (in terms of CANGEN ranks) neighbours as stereocenter - if (nei == 4) then + if (nei == 4) then do j = 1,4 jj = self%neigh(j,ii) if (mol%at(jj) == 1) then !> one hydrogen allowed @@ -535,7 +535,7 @@ function has_stereo(self,mol) result(yesno) zero = count(self%neigh(:,ii) == 0) nei = self%maxnei-zero !>--- consider only atoms with 4 unique (in terms of ranks) neighbours as stereocenter - if (nei == 4) then + if (nei == 4) then do j = 1,4 jj = self%neigh(j,ii) if (mol%at(jj) == 1) then !> one hydrogen allowed @@ -617,32 +617,40 @@ subroutine add_h_ranks(self,mol) implicit none class(canonical_sorter),intent(inout) :: self type(coord),intent(in) :: mol - integer,allocatable :: rankh(:) - integer :: i,ii,zero,nei,j,jj,maxrank + integer,allocatable :: rankh(:) + integer,allocatable :: rankmap(:) + integer :: i,ii,zero,nei,j,jj,maxrank,rr logical :: hneigh !>--- if there is no H, or this routine was already called, return - if(size(self%rank,1).eq.mol%nat) return + if (size(self%rank,1) .eq. mol%nat) return !>--- otherwise, analyze and resize - maxrank=maxval(self%rank(:),1) - allocate(rankh(mol%nat), source=0) + maxrank = maxval(self%rank(:),1) + allocate (rankmap(maxrank),source=0) + allocate (rankh(mol%nat),source=0) do i = 1,self%hatms ii = self%hmap(i) zero = count(self%neigh(:,ii) == 0) nei = self%maxnei-zero - rankh(ii) = self%rank(i) - hneigh = .false. - do j=1,nei - jj = self%neigh(j,ii) - if (mol%at(jj) == 1) then - if(.not.hneigh)then - hneigh=.true. - maxrank=maxrank+1 - endif - rankh(jj)=maxrank - endif - enddo - enddo + rr = self%rank(i) + rankh(ii) = rr + + do j = 1,nei + jj = self%neigh(j,ii) + if (mol%at(jj) == 1) then + +!>--- rankmap will map the new ranks of H atoms attached to +!> the already ranked heavy atoms. This way equivalent H's will get the same rank +!> I.e. if two methyl groups have same ranks, their H's must also have the same ranks + if (rankmap(rr) == 0) then + maxrank = maxrank+1 + rankmap(rr) = maxrank + end if + rankh(jj) = rankmap(rr) + end if + end do + end do call move_alloc(rankh,self%rank) + deallocate (rankmap) end subroutine add_h_ranks !========================================================================================! diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index ffdb4ab8..519113fd 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -15,10 +15,22 @@ module irmsd_module public :: rmsd public :: min_rmsd - public :: fallbackranks + public :: checkranks,fallbackranks real(wp),parameter :: bigval = huge(bigval) + type :: rmsd_core_cache +!************************************* +!* Memory cache for rmsd_core routine +!************************************* + real(wp),allocatable :: x(:,:) + real(wp),allocatable :: y(:,:) + real(wp),allocatable :: xi(:) + real(wp),allocatable :: yi(:) + contains + procedure :: allocate => allocate_rmsd_core_cache + end type rmsd_core_cache + public :: rmsd_cache type :: rmsd_cache !**************************************************** @@ -30,7 +42,7 @@ module irmsd_module integer,allocatable :: best_order(:,:) integer,allocatable :: current_order(:) integer,allocatable :: target_order(:) - integer,allocatable :: target_order_bkup(:,:) + integer,allocatable :: order_bkup(:,:) integer,allocatable :: iwork(:) integer,allocatable :: iwork2(:,:) logical,allocatable :: assigned(:) !> atom-wise @@ -40,12 +52,17 @@ module irmsd_module integer,allocatable :: ngroup(:) logical :: stereocheck = .false. + type(rmsd_core_cache),allocatable :: ccache type(assignment_cache),allocatable :: acache contains procedure :: allocate => allocate_rmsd_cache end type rmsd_cache real(wp),parameter :: inf = huge(1.0_wp) + real(wp),parameter :: imat(3,3) = reshape([1.0_wp,0.0_wp,0.0_wp, & + & 0.0_wp,1.0_wp,0.0_wp, & + & 0.0_wp,0.0_wp,1.0_wp], & + & [3,3]) !========================================================================================! !========================================================================================! @@ -53,6 +70,20 @@ module irmsd_module !========================================================================================! !========================================================================================! + subroutine allocate_rmsd_core_cache(self,nat) + implicit none + class(rmsd_core_cache),intent(inout) :: self + integer,intent(in) :: nat + if (allocated(self%x)) deallocate (self%x) + if (allocated(self%y)) deallocate (self%y) + if (allocated(self%xi)) deallocate (self%xi) + if (allocated(self%yi)) deallocate (self%yi) + allocate (self%xi(nat),source=0.0_wp) + allocate (self%yi(nat),source=0.0_wp) + allocate (self%x(3,nat),source=0.0_wp) + allocate (self%y(3,nat),source=0.0_wp) + end subroutine allocate_rmsd_core_cache + subroutine allocate_rmsd_cache(self,nat) implicit none class(rmsd_cache),intent(inout) :: self @@ -62,26 +93,29 @@ subroutine allocate_rmsd_cache(self,nat) if (allocated(self%best_order)) deallocate (self%best_order) if (allocated(self%current_order)) deallocate (self%current_order) if (allocated(self%target_order)) deallocate (self%target_order) - if (allocated(self%target_order_bkup)) deallocate (self%target_order_bkup) + if (allocated(self%order_bkup)) deallocate (self%order_bkup) if (allocated(self%iwork)) deallocate (self%iwork) if (allocated(self%iwork2)) deallocate (self%iwork2) if (allocated(self%assigned)) deallocate (self%assigned) if (allocated(self%rassigned)) deallocate (self%rassigned) if (allocated(self%ngroup)) deallocate (self%ngroup) + if (allocated(self%ccache)) deallocate (self%ccache) if (allocated(self%acache)) deallocate (self%acache) allocate (self%assigned(nat),source=.false.) allocate (self%rassigned(nat),source=.false.) allocate (self%best_order(nat,3),source=0) allocate (self%current_order(nat),source=0) allocate (self%target_order(nat),source=0) - allocate (self%target_order_bkup(nat,2),source=0) + allocate (self%order_bkup(nat,2),source=0) allocate (self%iwork(nat),source=0) allocate (self%iwork2(nat,2),source=0) allocate (self%rank(nat,2),source=0) self%nranks = 0 allocate (self%ngroup(nat),source=0) allocate (self%xyzscratch(3,nat,2),source=0.0_wp) + allocate (self%ccache) allocate (self%acache) + call self%ccache%allocate(nat) call self%acache%allocate(nat,nat,.true.) !> assume we are only using the LSAP implementation end subroutine allocate_rmsd_cache @@ -187,9 +221,127 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) end function rmsd +!========================================================================================! + + subroutine rmsd_core(nat,xyz1,xyz2,calc_u,U,error,calc_g,grad,ccache) +!********************************************************** +!* Rewrite or RMSD code with modified memory management +!* Adapted from ls_rmsd, and using some of its subroutines +!* The goal is to offload memory allocation to outside +!* the routine in case it is repeadetly called +!********************************************************** + use ls_rmsd,only:dstmev,rotation_matrix + implicit none + integer,intent(in) :: nat + real(wp),intent(in) :: xyz1(3,nat) + real(wp),intent(in) :: xyz2(3,nat) + logical,intent(in) :: calc_u + real(wp),dimension(3,3),intent(out) :: U + real(wp),intent(out) :: error + logical,intent(in) :: calc_g + real(wp),intent(inout) :: grad(:,:) + type(rmsd_core_cache),intent(inout) :: ccache + + !> LOCAL + integer :: i,j + real(wp) :: x_center(3) + real(wp) :: y_center(3) + real(wp) :: x_norm,y_norm,lambda + real(wp) :: Rmatrix(3,3) + real(wp) :: S(4,4) + real(wp) :: q(4) + real(wp) :: tmp(3),rnat + integer :: io + + !> associate + associate (x => ccache%x,y => ccache%y,xi => ccache%xi,yi => ccache%yi) + + !> make copies of the original coordinates + x(:,:) = xyz1(:,:) + y(:,:) = xyz2(:,:) + + !> calculate the barycenters, centroidal coordinates, and the norms + x_norm = 0.0_wp + y_norm = 0.0_wp + rnat = 1.0_wp/real(nat,wp) + do i = 1,3 + xi(:) = x(i,:) + yi(:) = y(i,:) + x_center(i) = sum(xi(1:nat))*rnat + y_center(i) = sum(yi(1:nat))*rnat + xi(:) = xi(:)-x_center(i) + yi(:) = yi(:)-y_center(i) + x(i,:) = xi(:) + y(i,:) = yi(:) + x_norm = x_norm+dot_product(xi,xi) + y_norm = y_norm+dot_product(yi,yi) + end do + + !> calculate the R matrix + do i = 1,3 + do j = 1,3 + Rmatrix(i,j) = dot_product(x(i,:),y(j,:)) + end do + end do + + !> S matrix + S(1,1) = Rmatrix(1,1)+Rmatrix(2,2)+Rmatrix(3,3) + S(2,1) = Rmatrix(2,3)-Rmatrix(3,2) + S(3,1) = Rmatrix(3,1)-Rmatrix(1,3) + S(4,1) = Rmatrix(1,2)-Rmatrix(2,1) + + S(1,2) = S(2,1) + S(2,2) = Rmatrix(1,1)-Rmatrix(2,2)-Rmatrix(3,3) + S(3,2) = Rmatrix(1,2)+Rmatrix(2,1) + S(4,2) = Rmatrix(1,3)+Rmatrix(3,1) + + S(1,3) = S(3,1) + S(2,3) = S(3,2) + S(3,3) = -Rmatrix(1,1)+Rmatrix(2,2)-Rmatrix(3,3) + S(4,3) = Rmatrix(2,3)+Rmatrix(3,2) + + S(1,4) = S(4,1) + S(2,4) = S(4,2) + S(3,4) = S(4,3) + S(4,4) = -Rmatrix(1,1)-Rmatrix(2,2)+Rmatrix(3,3) + + !> Calculate eigenvalues and eigenvectors, and + !> take the maximum eigenvalue lambda and the corresponding eigenvector q. + call dstmev(S,lambda,q,io) + if (io /= 0) then + error = -1.0_wp + return + end if + + if (calc_u) then + !> reset + U(:,:) = Imat(:,:) + !> convert quaternion q to rotation matrix U + call rotation_matrix(q,U) + end if + + !> RMS Deviation + error = sqrt(max(0.0_wp, ((x_norm+y_norm)-2.0_wp*lambda))*rnat) + + if (calc_g) then + !> Gradient of the error of xyz1 w.r.t xyz2 + do i = 1,nat + do j = 1,3 + tmp(:) = matmul(transpose(U(:,:)),y(:,i)) + grad(j,i) = ((x(j,i)-tmp(j))/error)*rnat + end do + end do + end if + + end associate + end subroutine rmsd_core + !========================================================================================! subroutine min_rmsd(ref,mol,rcache,rmsdout) +!********************************************************************* +!* Main routine to determine minium RMSD considering atom permutation +!********************************************************************* implicit none !> IN & OUTPUT type(coord),intent(in) :: ref @@ -261,7 +413,7 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) cptr%rassigned(cptr%nranks+1:) = .true. !> skip unneeded allocation space do ii = 1,ref%nat cptr%iwork(ii) = ii !> also init iwork - cptr%current_order(ii) = ii !> also init current_order + cptr%target_order(ii) = ii !> also init target_order rnk = cptr%rank(ii,2) if (rnk < 1) then cptr%assigned(ii) = .true. @@ -289,7 +441,7 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) call axis(mol%nat,mol%at,mol%xyz) call min_rmsd_iterate_through_groups(ref,mol,1,cptr,dum) tmprmsd_sym(1) = dum - cptr%target_order_bkup(:,1) = cptr%iwork(:) + cptr%order_bkup(:,1) = cptr%iwork(:) if (debug) then write (*,*) 'Total LSAP cost:',dum call mol%append(dumpunit) @@ -301,28 +453,31 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) call axis(mol%nat,mol%at,mol%xyz) call min_rmsd_iterate_through_groups(ref,mol,1,cptr,dum) tmprmsd_sym(2) = dum - cptr%target_order_bkup(:,2) = cptr%iwork(:) + cptr%order_bkup(:,2) = cptr%iwork(:) if (debug) then write (*,*) 'Total LSAP cost (mirrored):',dum call mol%append(dumpunit) end if - end if - - if (debug) then - close (dumpunit) + mol%xyz(3,:) = -mol%xyz(3,:) !> restore z end if !>--- select the best match among the ones after symmetry operations and use its ordering ii = minloc(tmprmsd_sym(:),1) - write (*,*) ii - cptr%target_order(:) = cptr%target_order_bkup(:,ii) + if(ii == 2)then + mol%xyz(3,:) = -mol%xyz(3,:) + endif + cptr%current_order(:) = cptr%order_bkup(:,ii) if (debug) then write (*,*) 'Determined remapping' do ii = 1,mol%nat write (*,*) cptr%current_order(ii),'-->',cptr%target_order(ii) end do end if - !call molatomsort(mol,mol%nat,cptr%current_order,cptr%target_order,cptr%iwork) + call molatomsort(mol,mol%nat,cptr%current_order,cptr%target_order,cptr%iwork) + if (debug) then + call mol%append(dumpunit) + close (dumpunit) + end if !>--- final RMSD with fully restored atom order calc_rmsd = rmsd(ref,mol,scratch=cptr%xyzscratch) @@ -525,6 +680,43 @@ subroutine rank_2_order(nat,rank,order) end do end subroutine rank_2_order +!========================================================================================! + + function checkranks(nat,ranks1,ranks2) result(yesno) +!*********************************************************************** +!* Check two rank arrays to see if we have the same amount of +!* atoms in the same ranks (a condition to bein able to work with them) +!*********************************************************************** + implicit none + logical :: yesno + integer,intent(in) :: nat + integer,intent(in) :: ranks1(nat) + integer,intent(in) :: ranks2(nat) + integer :: ii,jj,maxrank1,maxrank2 + integer :: count1,count2 + yesno=.false. + + maxrank1 = maxval(ranks1) + maxrank2 = maxval(ranks2) + !> different maxranks, so we can't have the same and return + if(maxrank1 .ne. maxrank2) return + + do ii=1,maxrank1 + count1 = 0 + count2 = 0 + do jj=1,nat + if(ranks1(jj) .eq. ii) count1 = count1 + 1 + if(ranks2(jj) .eq. ii) count2 = count2 + 1 + enddo + !> not the same amount of atoms in rank ii, return from function + if(count1 .ne. count2) return + enddo + + !> if we reach this point we can assume the given ranks are o.k. + yesno = .true. + end function checkranks + + !========================================================================================! subroutine molatomsort(mol,n,current_order,target_order,index_map) From 97b1004bd30913a5ac03faa317022d4d83a5aae4 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 9 Sep 2024 23:38:58 +0200 Subject: [PATCH 016/374] iRMSD working --- src/minitools.f90 | 168 ++++++++++++------------ src/sorting/canonical.f90 | 20 ++- src/sorting/hungarian.f90 | 4 +- src/sorting/irmsd_module.f90 | 247 ++++++++++++++++++++++++++++------- 4 files changed, 305 insertions(+), 134 deletions(-) diff --git a/src/minitools.f90 b/src/minitools.f90 index 7a785abb..2cf1e253 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -25,7 +25,7 @@ subroutine splitfile(fname,up,low) !******************************************************** use crest_parameters use iomod - use strucrd,only: rdensemble,coord + use strucrd,only:rdensemble,coord implicit none character(len=*) :: fname integer :: up,low @@ -48,9 +48,6 @@ subroutine splitfile(fname,up,low) call getcwd(thispath) !current dir= thispath - !call rdensembleparam(fname,nat,nall) - !allocate (xyz(3,nat,nall),at(nat)) - !call rdensemble(fname,nat,nall,at,xyz) call rdensemble(fname,nall,structures) r = makedir("SPLIT") !create new directory @@ -75,7 +72,6 @@ subroutine splitfile(fname,up,low) write (tmppath2,'(a,i0)') "STRUC",i r = makedir(trim(tmppath2)) call chdir(tmppath2) - !call wrxyz("struc.xyz",nat,at,xyz(:,:,i)) call structures(i)%write("struc.xyz") call chdir(tmppath1) end do @@ -414,7 +410,6 @@ subroutine testtopo(fname,env,tmode) case ('methyl') do i = 1,zmol%nat l1 = zmol%methyl(i) - !write(*,*) l1 if (l1) write (*,'(a,i0,a)') 'Atom ',i,' is methyl (or similar)' end do @@ -597,20 +592,20 @@ subroutine quick_rmsd_tool(fname1,fname2,heavy) call ref%open(fname1) call mol%open(fname2) - - if(heavy)then - allocate(mask(ref%nat), source=.false.) - do i=1,ref%nat - if(ref%at(i) > 1)then + + if (heavy) then + allocate (mask(ref%nat),source=.false.) + do i = 1,ref%nat + if (ref%at(i) > 1) then mask(i) = .true. - endif - enddo + end if + end do rmsdval = rmsd(ref,mol,mask=mask) else rmsdval = rmsd(ref,mol) - endif + end if - rmsdval = rmsdval * autoaa + rmsdval = rmsdval*autoaa if (heavy) then write (*,'(1x,a,f16.8)') 'Calculated heavy atom RMSD (Å):',rmsdval else @@ -667,7 +662,7 @@ subroutine quick_hungarian_match(fname1,fname2,heavy) use crest_parameters use strucrd use hungarian_module - use axis_module, only: axis + use axis_module,only:axis implicit none character(len=*),intent(in) :: fname1 character(len=*),intent(in) :: fname2 @@ -678,7 +673,7 @@ subroutine quick_hungarian_match(fname1,fname2,heavy) logical,allocatable :: mask(:) real(wp),allocatable :: C(:,:) real(wp),allocatable :: answers(:) - integer,allocatable :: mapping(:) + integer,allocatable :: mapping(:) integer,allocatable :: hmap(:),rhmap(:) integer,allocatable :: a(:),b(:) real(wp) :: dists(3) @@ -690,62 +685,62 @@ subroutine quick_hungarian_match(fname1,fname2,heavy) call axis(ref%nat,ref%at,ref%xyz) call axis(mol%nat,mol%at,mol%xyz) - if(heavy)then - allocate(mask(ref%nat), source=.false.) - allocate(hmap(ref%nat), rhmap(ref%nat), source=0) - nat=count((ref%at(:) > 1)) - ii=0 - do i=1,ref%nat - if(ref%at(i) > 1)then + if (heavy) then + allocate (mask(ref%nat),source=.false.) + allocate (hmap(ref%nat),rhmap(ref%nat),source=0) + nat = count((ref%at(:) > 1)) + ii = 0 + do i = 1,ref%nat + if (ref%at(i) > 1) then mask(i) = .true. - ii=ii+1 + ii = ii+1 hmap(i) = ii rhmap(ii) = i - endif - enddo + end if + end do else - allocate(mask(ref%nat), source=.true.) - nat=ref%nat - endif - - allocate( C(nat,nat), answers(nat) ) - allocate( mapping(nat+1) ) - do ii=1,nat - if(.not.mask(ii)) cycle - do jj=1,nat - if(.not.mask(jj)) cycle - dists(:)=(ref%xyz(:,ii)-mol%xyz(:,jj))**2 - if(heavy)then + allocate (mask(ref%nat),source=.true.) + nat = ref%nat + end if + + allocate (C(nat,nat),answers(nat)) + allocate (mapping(nat+1)) + do ii = 1,nat + if (.not.mask(ii)) cycle + do jj = 1,nat + if (.not.mask(jj)) cycle + dists(:) = (ref%xyz(:,ii)-mol%xyz(:,jj))**2 + if (heavy) then C(hmap(jj),hmap(ii)) = sqrt(sum(dists)) else C(jj,ii) = sqrt(sum(dists)) - endif - enddo - enddo - allocate(a(nat),b(nat)) + end if + end do + end do + allocate (a(nat),b(nat)) call lsap(C,nat,nat,a,b) - write(*,'(a,3(1x,a))') 'Assignment:',fname2,'-->',fname1 - do i=1,nat - if(heavy)then - write(*,'(i6," --> ",i6)') rhmap(a(i)),rhmap(b(i)) - else - write(*,'(i6," --> ",i6)') a(i),b(i) - endif - enddo - write(*,*) + write (*,'(a,3(1x,a))') 'Assignment:',fname2,'-->',fname1 + do i = 1,nat + if (heavy) then + write (*,'(i6," --> ",i6)') rhmap(a(i)),rhmap(b(i)) + else + write (*,'(i6," --> ",i6)') a(i),b(i) + end if + end do + write (*,*) !> write the rotated and shifted coordinates to one file - open(newunit=ich,file='lsap.xyz') + open (newunit=ich,file='lsap.xyz') call ref%append(ich) call mol%append(ich) - close(ich) + close (ich) !> reconstruct RMSD from assignment (since our costs are already distances!) rmsdval = 0.0_wp - do i=1,nat - rmsdval = rmsdval + C(a(i),b(i)) / real(nat,wp) - enddo - rmsdval = sqrt(abs(rmsdval)) * autoaa + do i = 1,nat + rmsdval = rmsdval+C(a(i),b(i))/real(nat,wp) + end do + rmsdval = sqrt(abs(rmsdval))*autoaa if (heavy) then write (*,'(1x,a,f16.8)') 'Calculated heavy atom RMSD (Å):',rmsdval else @@ -772,7 +767,12 @@ subroutine irmsd_tool(fname1,fname2) type(rmsd_cache) :: rcache type(canonical_sorter) :: canmol type(canonical_sorter) :: canref - logical,parameter :: debug=.true. + logical,parameter :: debug = .false. + + write (stdout,*) 'iRMSD algorithm' + write (stdout,*) 'reference: ',fname1 + write (stdout,*) 'processed: ',fname2 + write (stdout,*) !> read the geometries call ref%open(fname1) @@ -782,42 +782,50 @@ subroutine irmsd_tool(fname1,fname2) call axis(ref%nat,ref%at,ref%xyz) !> allocate memory - call rcache%allocate(ref%nat) + call rcache%allocate(ref%nat) !> canonical atom ranks call canref%init(ref,invtype='apsp+') call canref%add_h_ranks(ref) - rcache%stereocheck = .not.(canref%hasstereo(ref)) + rcache%stereocheck = .not. (canref%hasstereo(ref)) call canref%shrink() + write(*,*) 'false enantiomers possible?: ',rcache%stereocheck call canmol%init(mol,invtype='apsp+') call canmol%add_h_ranks(mol) call canmol%shrink() - - !> check if we can work with the determined ranks - if(checkranks(ref%nat,canref%rank,canmol%rank))then - rcache%rank(:,1) = canref%rank(:) - rcache%rank(:,2) = canmol%rank(:) - if(debug)then - write(*,*) 'iRMSD ranks:' - do i=1,ref%nat - write(*,*) rcache%rank(i,1),rcache%rank(i,2) - enddo - endif + + !> check if we can work with the determined ranks + if (checkranks(ref%nat,canref%rank,canmol%rank)) then + write(stdout,*) 'using canonical atom identities as rank backend' + rcache%rank(:,1) = canref%rank(:) + rcache%rank(:,2) = canmol%rank(:) + if (debug) then + write (*,*) 'iRMSD ranks:' + write (*,*) 'atom',' rank('//fname1//')',' rank('//fname2//')' + do i = 1,ref%nat + write (*,*) i,rcache%rank(i,1),rcache%rank(i,2) + end do + write (*,*) + end if else - !> if not, fall back to atom types - call fallbackranks(ref,mol,ref%nat,rcache%rank) - endif + !> if not, fall back to atom types + write(stdout,*) 'using atom types as rank backend' + call fallbackranks(ref,mol,ref%nat,rcache%rank) + end if - call min_rmsd(ref,mol,rcache=rcache,rmsdout=rmsdval) + call min_rmsd(ref,mol,rcache=rcache,rmsdout=rmsdval,align=.true.) - !> write the rotated and shifted coordinates to one file - open(newunit=ich,file='irmsd.xyz') + !> write the rotated and shifted coordinates to one file + open (newunit=ich,file='irmsd.xyz') call ref%append(ich) call mol%append(ich) - close(ich) + close (ich) + write (stdout,*) + write (stdout,*) 'aligned structures written to irmsd.xyz' + write (stdout,*) - rmsdval = rmsdval * autoaa + rmsdval = rmsdval*autoaa write (*,'(1x,a,f16.8)') 'Calculated RMSD (Å):',rmsdval return diff --git a/src/sorting/canonical.f90 b/src/sorting/canonical.f90 index 8b2ba0ac..7c1decef 100644 --- a/src/sorting/canonical.f90 +++ b/src/sorting/canonical.f90 @@ -619,7 +619,7 @@ subroutine add_h_ranks(self,mol) type(coord),intent(in) :: mol integer,allocatable :: rankh(:) integer,allocatable :: rankmap(:) - integer :: i,ii,zero,nei,j,jj,maxrank,rr + integer :: i,ii,zero,nei,j,jj,maxrank,rr,maxrank2 logical :: hneigh !>--- if there is no H, or this routine was already called, return if (size(self%rank,1) .eq. mol%nat) return @@ -642,13 +642,27 @@ subroutine add_h_ranks(self,mol) !> the already ranked heavy atoms. This way equivalent H's will get the same rank !> I.e. if two methyl groups have same ranks, their H's must also have the same ranks if (rankmap(rr) == 0) then - maxrank = maxrank+1 - rankmap(rr) = maxrank + !maxrank = maxrank+1 + rankmap(rr) = maxrank + rr end if rankh(jj) = rankmap(rr) end if end do end do +!>--- clean up "gaps" in rank assignment + maxrank=maxval(rankh,1) + maxrank2 = maxrank + do i=1,maxrank + if(i > maxrank2) exit + ii = count(rankh(:) == i) + if(ii == 0) maxrank2 = maxrank2 - 1 + do while (ii == 0) + do jj=1,mol%nat + if(rankh(jj) > i) rankh(jj) = rankh(jj) - 1 + enddo + ii = count(rankh(:) == i) + enddo + enddo call move_alloc(rankh,self%rank) deallocate (rankmap) end subroutine add_h_ranks diff --git a/src/sorting/hungarian.f90 b/src/sorting/hungarian.f90 index e9289a90..5eecb615 100644 --- a/src/sorting/hungarian.f90 +++ b/src/sorting/hungarian.f90 @@ -424,7 +424,7 @@ subroutine lsap_cached(lcache,nr,nc,maximize,iostatus) integer,intent(in) :: nr,nc logical,intent(in) :: maximize integer :: iostatus - integer :: curRow,curRow_iter,currowtmp,i,j,sink + integer :: curRow,curRow_iter,currowtmp,i,j,jj,sink real(sp) :: minValue logical :: transposed integer :: tmpx @@ -495,7 +495,7 @@ subroutine lsap_cached(lcache,nr,nc,maximize,iostatus) !> Augment previous solution j = sink - do + do jj=1,nc i = path(j) row4col(j) = i call swap(col4row(i),j) diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index 519113fd..88caae7f 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -5,7 +5,6 @@ module irmsd_module !* modern interface to calculating RMSDs !***************************************** use crest_parameters - use ls_rmsd,only:rmsd_classic => rmsd use strucrd use hungarian_module use axis_module @@ -64,6 +63,21 @@ module irmsd_module & 0.0_wp,0.0_wp,1.0_wp], & & [3,3]) + real(wp),parameter :: Rx180(3,3) = reshape([1.0_wp,0.0_wp,0.0_wp, & + & 0.0_wp,-1.0_wp,0.0_wp, & + & 0.0_wp,0.0_wp,-1.0_wp], & + & [3,3]) + + real(wp),parameter :: Ry180(3,3) = reshape([-1.0_wp,0.0_wp,0.0_wp, & + & 0.0_wp,1.0_wp,0.0_wp, & + & 0.0_wp,0.0_wp,-1.0_wp], & + & [3,3]) + + real(wp),parameter :: Rz180(3,3) = reshape([-1.0_wp,0.0_wp,0.0_wp, & + & 0.0_wp,-1.0_wp,0.0_wp, & + & 0.0_wp,0.0_wp,1.0_wp], & + & [3,3]) + !========================================================================================! !========================================================================================! contains !> MODULE PROCEDURES START HERE @@ -106,7 +120,7 @@ subroutine allocate_rmsd_cache(self,nat) allocate (self%best_order(nat,3),source=0) allocate (self%current_order(nat),source=0) allocate (self%target_order(nat),source=0) - allocate (self%order_bkup(nat,2),source=0) + allocate (self%order_bkup(nat,8),source=0) allocate (self%iwork(nat),source=0) allocate (self%iwork2(nat,2),source=0) allocate (self%rank(nat,2),source=0) @@ -119,7 +133,11 @@ subroutine allocate_rmsd_cache(self,nat) call self%acache%allocate(nat,nat,.true.) !> assume we are only using the LSAP implementation end subroutine allocate_rmsd_cache - function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) +!========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< variables + type(rmsd_core_cache),allocatable,target :: ccachetmp + type(rmsd_core_cache),pointer :: ccptr real(wp) :: x_center(3),y_center(3),Udum(3,3) real(wp),target :: gdum(3,3) integer :: nat,getrotmat + logical :: calc_u real(wp),allocatable,target :: tmpscratch(:,:,:) logical :: getgrad real(wp),pointer :: grdptr(:,:) @@ -156,7 +178,11 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) !> get rotation matrix? getrotmat = 0 - if (present(rotmat)) getrotmat = 1 + calc_u = .false. + if (present(rotmat)) then + getrotmat = 1 + calc_u = .true. + end if !> get gradient? if (present(gradient)) then @@ -168,6 +194,15 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) grdptr => gdum end if + !> use present cache? + if (present(ccache)) then + ccptr => ccache + else + allocate (ccachetmp) + call ccachetmp%allocate(ref%nat) + ccptr => ccachetmp + end if + !>--- substructure? if (present(mask)) then nat = count(mask(:)) @@ -190,9 +225,8 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) end do !> calculate - call rmsd_classic(nat,scratchptr(1:3,1:nat,1),scratchptr(1:3,1:nat,2), & - & getrotmat,Udum,x_center,y_center,rmsdval, & - & getgrad,grdptr) + call rmsd_core(nat,scratchptr(1:3,1:nat,1),scratchptr(1:3,1:nat,2), & + & calc_u,Udum,rmsdval,getgrad,grdptr,ccptr) !> go backwards through gradient (if necessary) to restore atom order if (getgrad) then @@ -211,13 +245,12 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient) result(rmsdval) else !>--- standard calculation (Quarternion algorithm) - call rmsd_classic(ref%nat,mol%xyz,ref%xyz, & - & getrotmat,Udum,x_center,y_center,rmsdval, & - & getgrad,grdptr) + call rmsd_core(ref%nat,mol%xyz,ref%xyz, & + & calc_u,Udum,rmsdval,getgrad,grdptr,ccptr) end if !> pass on rotation matrix if asked for - if (getrotmat > 0) rotmat = Udum + if (calc_u) rotmat = Udum end function rmsd @@ -338,9 +371,16 @@ end subroutine rmsd_core !========================================================================================! - subroutine min_rmsd(ref,mol,rcache,rmsdout) + subroutine min_rmsd(ref,mol,rcache,rmsdout,align) !********************************************************************* !* Main routine to determine minium RMSD considering atom permutation +!* Input +!* ref - the reference structure +!* mol - the structure to be matched to ref +!* Optinal arguments +!* rcache - memory cache +!* rmsdout - the calculated RMSD scalar +!* align - quarternion-align mol in the last stage !********************************************************************* implicit none !> IN & OUTPUT @@ -348,14 +388,16 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) type(coord),intent(inout) :: mol type(rmsd_cache),intent(inout),optional,target :: rcache real(wp),intent(out),optional :: rmsdout + logical,intent(in),optional :: align !> LOCAL type(rmsd_cache),pointer :: cptr type(rmsd_cache),allocatable,target :: local_rcache integer :: nat,ii,rnk,dumpunit real(wp) :: calc_rmsd - real(wp) :: tmprmsd_sym(3),dum - logical,parameter :: debug = .true. + real(wp) :: tmprmsd_sym(8),dum + real(wp) :: rotmat(3,3) + logical,parameter :: debug = .false. !>--- Initialization if (present(rcache)) then @@ -421,6 +463,7 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) end if if (cptr%ngroup(rnk) .eq. 1) then cptr%assigned(ii) = .true. + cptr%rassigned(rnk) = .true. end if end do if (debug) then @@ -433,29 +476,33 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) end if !>--- Perform the desired symmetry operations, align with rotational axis, run LSAP algo +!> Since the rotational axis alignment can be a bit arbitrary w.r.t 180° rotations +!> we need to check these as well. if (debug) then open (newunit=dumpunit,file='debugirmsd.xyz') call ref%append(dumpunit) end if - tmprmsd_sym(:) = inf !> initialize to huge + !> initialize to huge + tmprmsd_sym(:) = inf + !> initial alignment of mol call axis(mol%nat,mol%at,mol%xyz) - call min_rmsd_iterate_through_groups(ref,mol,1,cptr,dum) - tmprmsd_sym(1) = dum - cptr%order_bkup(:,1) = cptr%iwork(:) + + !> Running the checks + call min_rmsd_rotcheck(ref,mol,cptr,tmprmsd_sym,1) if (debug) then - write (*,*) 'Total LSAP cost:',dum + write (*,*) 'Total LSAP cost:',minval(tmprmsd_sym(1:4)) call mol%append(dumpunit) end if - !> mirror z + !> mirror z and re-run the same checks if (cptr%stereocheck) then - mol%xyz(3,:) = -mol%xyz(3,:) - call axis(mol%nat,mol%at,mol%xyz) - call min_rmsd_iterate_through_groups(ref,mol,1,cptr,dum) - tmprmsd_sym(2) = dum - cptr%order_bkup(:,2) = cptr%iwork(:) + mol%xyz(3,:) = -mol%xyz(3,:) !> mirror z + call axis(mol%nat,mol%at,mol%xyz) !> align + + !> Running the checks + call min_rmsd_rotcheck(ref,mol,cptr,tmprmsd_sym,2) if (debug) then - write (*,*) 'Total LSAP cost (mirrored):',dum + write (*,*) 'Total LSAP cost (inverted):',minval(tmprmsd_sym(5:8)) call mol%append(dumpunit) end if mol%xyz(3,:) = -mol%xyz(3,:) !> restore z @@ -463,16 +510,36 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) !>--- select the best match among the ones after symmetry operations and use its ordering ii = minloc(tmprmsd_sym(:),1) - if(ii == 2)then + if (debug) then + write (*,*) 'final alignment:',ii,"/ 8" + end if + if (ii > 4) then mol%xyz(3,:) = -mol%xyz(3,:) - endif + if (debug) write (*,*) 'inverting' + end if + select case (ii) !> 180° rotations + case (1,5) + continue + case (2,6) + mol%xyz = matmul(Rx180,mol%xyz) + if (debug) write (*,*) '180°x' + case (3,7) + mol%xyz = matmul(Rx180,mol%xyz) + mol%xyz = matmul(Ry180,mol%xyz) + if (debug) write (*,*) '180°x, 180°y' + case (4,8) + mol%xyz = matmul(Ry180,mol%xyz) + if (debug) write (*,*) '180°y' + end select cptr%current_order(:) = cptr%order_bkup(:,ii) + if (debug) then write (*,*) 'Determined remapping' do ii = 1,mol%nat write (*,*) cptr%current_order(ii),'-->',cptr%target_order(ii) end do end if + call molatomsort(mol,mol%nat,cptr%current_order,cptr%target_order,cptr%iwork) if (debug) then call mol%append(dumpunit) @@ -480,24 +547,30 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout) end if !>--- final RMSD with fully restored atom order - calc_rmsd = rmsd(ref,mol,scratch=cptr%xyzscratch) + if (present(align)) then + calc_rmsd = rmsd(ref,mol,scratch=cptr%xyzscratch,ccache=cptr%ccache,rotmat=rotmat) + if (align) then + mol%xyz = matmul(rotmat,mol%xyz) + end if + else + calc_rmsd = rmsd(ref,mol,scratch=cptr%xyzscratch,ccache=cptr%ccache) + end if if (present(rmsdout)) rmsdout = calc_rmsd end subroutine min_rmsd !========================================================================================! - subroutine min_rmsd_iterate_through_groups(ref,mol,step,rcache,val) + subroutine min_rmsd_iterate_through_groups(ref,mol,rcache,val) implicit none type(coord),intent(in) :: ref type(coord),intent(inout) :: mol - integer,intent(in) :: step type(rmsd_cache),intent(inout),target :: rcache real(wp),intent(out) :: val integer :: rr,ii,jj real(wp) :: val0 type(assignment_cache),pointer :: aptr - logical,parameter :: debug = .true. + logical,parameter :: debug = .false. !> reset val val = 0.0_wp @@ -525,6 +598,83 @@ subroutine min_rmsd_iterate_through_groups(ref,mol,step,rcache,val) end subroutine min_rmsd_iterate_through_groups +!========================================================================================! + + subroutine min_rmsd_rotcheck(ref,mol,cptr,values,step) + implicit none + type(coord),intent(in) :: ref + type(coord),intent(inout) :: mol + type(rmsd_cache),intent(inout),target :: cptr + real(wp),intent(inout) :: values(:) + integer,intent(in) :: step + integer :: rr,ii,jj,debugunit2 + real(wp) :: vals(4),dum + logical,parameter :: debug = .false. + + !> reset val + vals(:) = 0.0_wp + + if (debug) then + open (newunit=debugunit2,file='rotdebug.xyz') + call ref%append(debugunit2) + end if + call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) + vals(1) = dum + if (debug) call mol%append(debugunit2) + cptr%order_bkup(:,1+4*(step-1)) = cptr%iwork(:) + + mol%xyz = matmul(Rx180,mol%xyz) + call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) + vals(2) = dum + if (debug) call mol%append(debugunit2) + cptr%order_bkup(:,2+4*(step-1)) = cptr%iwork(:) + + mol%xyz = matmul(Ry180,mol%xyz) + call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) + vals(3) = dum + if (debug) call mol%append(debugunit2) + cptr%order_bkup(:,3+4*(step-1)) = cptr%iwork(:) + + mol%xyz = matmul(Rx180,mol%xyz) + call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) + vals(4) = dum + if (debug) call mol%append(debugunit2) + cptr%order_bkup(:,4+4*(step-1)) = cptr%iwork(:) + + mol%xyz = matmul(Ry180,mol%xyz) !> restore + + if (debug) then + close (debugunit2) + write (*,*) 'vals:',vals(:) + end if + + do ii = 1,4 + values(ii+4*(step-1)) = vals(ii) + end do + end subroutine min_rmsd_rotcheck + +!=========================================================================================! + + subroutine min_rmsd_quadalign(ref,mol,rotate) + implicit none + type(coord),intent(in) :: ref + type(coord),intent(inout) :: mol + logical,intent(out) :: rotate(3) + integer :: rr,ii,jj,acount + real(wp) :: val0 + integer :: tmp1,tmp2 + type(assignment_cache),pointer :: aptr + logical,parameter :: debug = .false. + + rotate(:) = .false. + + do jj = 1,3 + tmp1 = count(ref%xyz(jj,:) > 0.0_wp) + tmp2 = count(mol%xyz(jj,:) > 0.0_wp) + if (tmp1 .ne. tmp2) rotate(jj) = .true. + end do + end subroutine min_rmsd_quadalign + !========================================================================================! subroutine fallbackranks(ref,mol,nat,ranks) @@ -595,7 +745,7 @@ subroutine compute_linear_sum_assignment(ref,mol,ranks, & integer :: nat,i,j,ii,jj,rnknat,iostatus real(sp) :: dists(3) - logical,parameter :: debug = .true. + logical,parameter :: debug = .false. val0 = 0.0_wp @@ -681,7 +831,7 @@ subroutine rank_2_order(nat,rank,order) end subroutine rank_2_order !========================================================================================! - + function checkranks(nat,ranks1,ranks2) result(yesno) !*********************************************************************** !* Check two rank arrays to see if we have the same amount of @@ -694,29 +844,28 @@ function checkranks(nat,ranks1,ranks2) result(yesno) integer,intent(in) :: ranks2(nat) integer :: ii,jj,maxrank1,maxrank2 integer :: count1,count2 - yesno=.false. + yesno = .false. maxrank1 = maxval(ranks1) maxrank2 = maxval(ranks2) !> different maxranks, so we can't have the same and return - if(maxrank1 .ne. maxrank2) return - - do ii=1,maxrank1 - count1 = 0 - count2 = 0 - do jj=1,nat - if(ranks1(jj) .eq. ii) count1 = count1 + 1 - if(ranks2(jj) .eq. ii) count2 = count2 + 1 - enddo - !> not the same amount of atoms in rank ii, return from function - if(count1 .ne. count2) return - enddo - + if (maxrank1 .ne. maxrank2) return + + do ii = 1,maxrank1 + count1 = 0 + count2 = 0 + do jj = 1,nat + if (ranks1(jj) .eq. ii) count1 = count1+1 + if (ranks2(jj) .eq. ii) count2 = count2+1 + end do + !> not the same amount of atoms in rank ii, return from function + if (count1 .ne. count2) return + end do + !> if we reach this point we can assume the given ranks are o.k. yesno = .true. end function checkranks - !========================================================================================! subroutine molatomsort(mol,n,current_order,target_order,index_map) From 162ee2820822ceacd1bcafa77f2513253fc9c46a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 10 Sep 2024 01:43:56 +0200 Subject: [PATCH 017/374] Catch bad indexing for failing assignments --- src/minitools.f90 | 2 +- src/sorting/hungarian.f90 | 4 ++-- src/sorting/irmsd_module.f90 | 1 + 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/minitools.f90 b/src/minitools.f90 index 2cf1e253..32dd170e 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -826,7 +826,7 @@ subroutine irmsd_tool(fname1,fname2) write (stdout,*) rmsdval = rmsdval*autoaa - write (*,'(1x,a,f16.8)') 'Calculated RMSD (Å):',rmsdval + write (*,'(1x,a,f16.8)') 'Calculated iRMSD (Å):',rmsdval return end subroutine irmsd_tool diff --git a/src/sorting/hungarian.f90 b/src/sorting/hungarian.f90 index 5eecb615..5fb5778d 100644 --- a/src/sorting/hungarian.f90 +++ b/src/sorting/hungarian.f90 @@ -495,7 +495,7 @@ subroutine lsap_cached(lcache,nr,nc,maximize,iostatus) !> Augment previous solution j = sink - do jj=1,nc + do jj=1,nc+1 !> avoid infinite loop i = path(j) row4col(j) = i call swap(col4row(i),j) @@ -503,7 +503,7 @@ subroutine lsap_cached(lcache,nr,nc,maximize,iostatus) end do end do - !> Finalize the assignment based on transposition + !> Finalize the assignment do i = 1,nr a(i) = i b(i) = col4row(i) diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index 88caae7f..589abd31 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -798,6 +798,7 @@ subroutine compute_linear_sum_assignment(ref,mol,ranks, & do i = 1,rnknat jj = aptr%a(i) ii = aptr%b(i) + if(ii == -1 .or. jj == -1) cycle !> cycle bad assignments val0 = val0+aptr%Cost(jj+(ii-1)*rnknat) iwork2(i,2) = iwork2(aptr%b(i),1) end do From f24f8b820a41ec5851cec7b662ffc87ba75d579a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 11 Sep 2024 01:14:52 +0200 Subject: [PATCH 018/374] format quicksort routines --- src/sorting/quicksort.f90 | 101 ++++++++------------------------------ 1 file changed, 21 insertions(+), 80 deletions(-) diff --git a/src/sorting/quicksort.f90 b/src/sorting/quicksort.f90 index 69f18de4..9468eba6 100644 --- a/src/sorting/quicksort.f90 +++ b/src/sorting/quicksort.f90 @@ -76,73 +76,16 @@ recursive subroutine quicksort(n,arr) deallocate (R,L) end subroutine quicksort -!=============================================================! -! classical quicksort algorithm, sort HIGH-to-LOW -!=============================================================! -recursive subroutine revquicksort(n,arr) - implicit none - integer :: n,arr(n),i,j,k,m - integer :: pivot - integer,allocatable :: R(:),L(:) - integer :: rr,ll,rc,lc,pp - - if (n .le. 1) return - - pivot = arr(1) - pp = 0 - do i = 1,n - if (arr(i) .eq. pivot) pp = pp+1 - end do - - ll = 0 - do i = 1,n - if (arr(i) .ge. pivot) then - ll = ll+1 - end if - end do - ll = ll-pp - rr = n-ll-pp - allocate (L(ll),R(rr)) - - lc = 0 - rc = 0 - do j = 1,n - if (arr(j) .gt. pivot) then - lc = lc+1 - L(lc) = arr(j) - else if (arr(j) .lt. pivot) then - rc = rc+1 - R(rc) = arr(j) - end if - end do - - call revquicksort(ll,L) - call revquicksort(rr,R) - - do i = 1,ll - arr(i) = L(i) - end do - do k = 1,pp - m = k+ll - arr(m) = pivot - end do - do j = 1,rr - m = j+ll+pp - arr(m) = R(j) - end do - - deallocate (R,L) -end subroutine revquicksort - !=============================================================! ! other variant of quicksort algos !=============================================================! recursive subroutine qsort(a,first,last,ind) + use iso_fortran_env,only:wp => real64 implicit none - real*8 a(*),x,t - integer ind(*) - integer first,last - integer i,j,ii + real(wp) :: a(:) + real(wp) :: x,t + integer :: ind(:) + integer :: first,last,i,j,ii x = a((first+last)/2) i = first @@ -165,10 +108,11 @@ recursive subroutine qsort(a,first,last,ind) end subroutine qsort recursive subroutine qqsort(a,first,last) + use iso_fortran_env,only:wp => real64 implicit none - real*8 a(*),x,t - integer first,last - integer i,j + real(wp) :: a(:) + real(wp) :: x,t + integer :: first,last,i,j x = a((first+last)/2) i = first @@ -190,12 +134,12 @@ recursive subroutine qqsort(a,first,last) end subroutine qqsort recursive subroutine maskqsort(a,first,last,mask) + use iso_fortran_env,only:wp => real64 implicit none - real*8 a(*),t - integer x - integer mask(*) - integer first,last - integer i,j,ii + real(wp) :: a(:) + real(wp) :: t + integer :: x,first,last,i,j,ii + integer :: mask(:) x = mask((first+last)/2) i = first @@ -218,13 +162,12 @@ recursive subroutine maskqsort(a,first,last,mask) end subroutine maskqsort recursive subroutine matqsort(adim,nall,a,adum,first,last,mask) + use iso_fortran_env,only:wp => real64 implicit none - integer :: adim,nall - real*8 a(adim,nall),adum(adim) - integer x - integer mask(nall) - integer first,last - integer i,j,ii + integer :: adim,nall + real(wp) :: a(adim,nall),adum(adim) + integer :: x,first,last,i,j,ii + integer :: mask(nall) x = mask((first+last)/2) i = first @@ -251,10 +194,8 @@ recursive subroutine stringqsort(sdim,strs,first,last,mask) integer :: sdim character(len=*) :: strs(sdim) character(len=len(strs(1))) :: str - integer x - integer mask(sdim) - integer first,last - integer i,j,ii + integer :: x,first,last,i,j,ii + integer :: mask(sdim) x = mask((first+last)/2) i = first j = last From f41562a8a57c2e806d4bf0b9e3b1965232fe0507 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 11 Sep 2024 02:22:26 +0200 Subject: [PATCH 019/374] Add ensemble_quicksort and interface --- src/sorting/quicksort.f90 | 137 +++++++++++++++++++++++++++++++++++++- 1 file changed, 136 insertions(+), 1 deletion(-) diff --git a/src/sorting/quicksort.f90 b/src/sorting/quicksort.f90 index 9468eba6..cb31e5d9 100644 --- a/src/sorting/quicksort.f90 +++ b/src/sorting/quicksort.f90 @@ -1,7 +1,7 @@ !================================================================================! ! This file is part of crest. ! -! Copyright (C) 2020 Philipp Pracht +! Copyright (C) 2020-2024 Philipp Pracht ! ! crest is free software: you can redistribute it and/or modify it under ! the terms of the GNU Lesser General Public License as published by @@ -17,6 +17,77 @@ ! along with crest. If not, see . !================================================================================! +module quicksort_interface +!******************************************************** +!* module to load an interface to the quicksort routines +!* mandatory to handle optional input arguments +!******************************************************** + implicit none + interface + recursive subroutine quicksort(n,arr) + implicit none + integer :: n,arr(n) + end subroutine quicksort + + recursive subroutine qsort(a,first,last,ind) + use iso_fortran_env,only:wp => real64 + implicit none + real(wp) :: a(:) + integer :: ind(:) + integer :: first,last + end subroutine qsort + + recursive subroutine qqsort(a,first,last) + use iso_fortran_env,only:wp => real64 + implicit none + real(wp) :: a(:) + integer :: first,last + end subroutine qqsort + + recursive subroutine maskqsort(a,first,last,mask) + use iso_fortran_env,only:wp => real64 + implicit none + real(wp) :: a(:) + integer :: first,last + integer :: mask(:) + end subroutine maskqsort + + recursive subroutine matqsort(adim,nall,a,adum,first,last,mask) + use iso_fortran_env,only:wp => real64 + implicit none + integer :: adim,nall + real(wp) :: a(adim,nall),adum(adim) + integer :: first,last + integer :: mask(nall) + end subroutine matqsort + + recursive subroutine stringqsort(sdim,strs,first,last,mask) + implicit none + integer :: sdim + character(len=*) :: strs(sdim) + integer :: first,last + integer :: mask(sdim) + end subroutine stringqsort + + subroutine maskinvert(nall,mask) + implicit none + integer :: nall + integer :: mask(nall) + end subroutine maskinvert + + recursive subroutine ensemble_qsort(nall,structures,first,last,mask) + use crest_parameters + use strucrd,only:coord + implicit none + integer,intent(in) :: nall + type(coord),intent(inout) :: structures(nall) + integer,intent(in) :: first,last + integer,intent(inout),optional :: mask(nall) + end subroutine ensemble_qsort + + end interface +end module quicksort_interface + !=============================================================! ! classical quicksort algorithm, sort LOW-to-HIGH !=============================================================! @@ -230,3 +301,67 @@ subroutine maskinvert(nall,mask) deallocate (imask) return end subroutine maskinvert + +!========================================================================================! + +recursive subroutine ensemble_qsort(nall,structures,first,last,mask) + use crest_parameters + use strucrd,only:coord + implicit none + integer,intent(in) :: nall + type(coord),intent(inout) :: structures(nall) + integer,intent(in) :: first,last + integer,intent(inout),optional :: mask(nall) + + !> LOCAL + type(coord),allocatable :: tmpmol + integer :: i,j,mm,ii + real(wp) :: ee + + if (present(mask)) then +!>--- sort according to a given mask (reference order) + mm = mask((first+last)/2) + i = first + j = last + do + do while (mask(i) < mm) + i = i+1 + end do + do while (mm < mask(j)) + j = j-1 + end do + if (i >= j) exit + ii = mask(i); mask(i) = mask(j); mask(j) = ii + allocate (tmpmol) + tmpmol = structures(i); structures(i) = structures(j); structures(j) = tmpmol + deallocate (tmpmol) + i = i+1 + j = j-1 + end do + if (first < i-1) call ensemble_qsort(nall,structures,first,i-1,mask) + if (j+1 < last) call ensemble_qsort(nall,structures,j+1,last,mask) + + else +!>--- standard, sort according to energy of structures + ee = structures((first+last)/2)%energy + i = first + j = last + do + do while (structures(i)%energy < ee) + i = i+1 + end do + do while (ee < structures(j)%energy) + j = j-1 + end do + if (i >= j) exit + allocate (tmpmol) + tmpmol = structures(i); structures(i) = structures(j); structures(j) = tmpmol + deallocate (tmpmol) + i = i+1 + j = j-1 + end do + if (first < i-1) call ensemble_qsort(nall,structures,first,i-1) + if (j+1 < last) call ensemble_qsort(nall,structures,j+1,last) + end if +end subroutine ensemble_qsort + From d55fdbbff744f95b39a2fe7caa01564067ab4994 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 15 Sep 2024 03:34:36 +0200 Subject: [PATCH 020/374] Test implementation for minimizing RMSD --- src/algos/CMakeLists.txt | 1 + src/algos/meson.build | 1 + src/algos/sorting.f90 | 58 +++++++++++++ src/classes.f90 | 1 + src/confparse.f90 | 176 +++++++++++++++++++------------------ src/crest_main.f90 | 4 + src/sorting/cregen.f90 | 178 +++++++++++++++++++++++++++++++++++++- src/sorting/hungarian.f90 | 3 +- 8 files changed, 335 insertions(+), 87 deletions(-) create mode 100644 src/algos/sorting.f90 diff --git a/src/algos/CMakeLists.txt b/src/algos/CMakeLists.txt index 3df8c266..40277f7f 100644 --- a/src/algos/CMakeLists.txt +++ b/src/algos/CMakeLists.txt @@ -28,6 +28,7 @@ list(APPEND srcs "${dir}/search_1.f90" "${dir}/search_mecp.f90" "${dir}/setuptest.f90" + "${dir}/sorting.f90" "${dir}/protonate.f90" "${dir}/hessian_tools.f90" "${dir}/ConfSolv.F90" diff --git a/src/algos/meson.build b/src/algos/meson.build index 43977333..cebe5f85 100644 --- a/src/algos/meson.build +++ b/src/algos/meson.build @@ -26,6 +26,7 @@ srcs += files( 'search_1.f90', 'search_mecp.f90', 'setuptest.f90', + 'sorting.f90', 'protonate.f90', 'hessian_tools.f90', 'ConfSolv.F90', diff --git a/src/algos/sorting.f90 b/src/algos/sorting.f90 new file mode 100644 index 00000000..275ad032 --- /dev/null +++ b/src/algos/sorting.f90 @@ -0,0 +1,58 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2024 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +!========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>! +!> Implementation for standalone sorting +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>! +!========================================================================================! +!> Input/Output: +!> env - crest's systemdata object +!> tim - timer object +!>----------------------------------------------- +subroutine crest_sort(env,tim) + use crest_parameters + use crest_data + use crest_calculator + use strucrd + use cregen_interface + implicit none + type(systemdata),intent(inout) :: env + type(timer),intent(inout) :: tim + type(coord) :: mol,molnew + integer :: i,j,k,l,io,ich + logical :: pr,wr +!========================================================================================! + integer :: nall + type(coord),allocatable :: structures(:) + +!========================================================================================! + call tim%start(11,'Sorting') +!========================================================================================! + + call rdensemble(env%ensemblename,nall,structures) + write(stdout,'(a,i0,a)') 'Read ensemble with ',nall,' structures' + + call cregen_irmsd_all(nall,structures,2) + + +!========================================================================================! + call tim%stop(11) + return +end subroutine crest_sort diff --git a/src/classes.f90 b/src/classes.f90 index 1f7ce783..5a26e223 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -74,6 +74,7 @@ module crest_data integer,parameter,public :: crest_protonate = 16 integer,parameter,public :: crest_deprotonate = 17 integer,parameter,public :: crest_tautomerize = 18 + integer,parameter,public :: crest_sorting = 19 !>> runtypes with IDs between use non-legacy routines <--- check if help is requested or citations shall be diplayed do i = 1,nra if (any((/character(6)::'-h','-H','--h','--H','--help'/) == trim(arg(i)))) then - if(nra > i)then - ctmp=trim(arg(i+1)) - if(ctmp(1:1).ne.'-')then + if (nra > i) then + ctmp = trim(arg(i+1)) + if (ctmp(1:1) .ne. '-') then call confscript_morehelp(ctmp) - endif - endif + end if + end if call confscript_help() end if if (any((/character(10)::'-cite','--cite','--citation'/) == trim(arg(i)))) then @@ -262,7 +262,6 @@ subroutine parseflags(env,arg,nra) error stop end if - !>--- options for constrained conformer sampling env%fixfile = 'none selected' @@ -421,7 +420,6 @@ subroutine parseflags(env,arg,nra) env%inputcoords = env%ensemblename !> just for a printout exit - case ('-pka','-pKa') !> pKa calculation script env%crestver = crest_pka env%runver = 33 @@ -527,7 +525,7 @@ subroutine parseflags(env,arg,nra) case ('-solvtool','-qcg') !> Set solute file if present - if(i == 2) env%solu_file = trim(arg(i-1)) + if (i == 2) env%solu_file = trim(arg(i-1)) !> Set solvent file if prensent !> If it is another argument, it doesent matter as solvent file is checke in solvtool if (nra >= i+1) env%solv_file = trim(arg(i+1)) @@ -553,7 +551,7 @@ subroutine parseflags(env,arg,nra) env%autozsort = .false. exit - case ('-msreact') + case ('-msreact') env%crestver = crest_msreac env%preopt = .false. env%presp = .true. @@ -641,7 +639,7 @@ subroutine parseflags(env,arg,nra) case ('-rmsd','-rmsdheavy','-hrmsd') ctmp = trim(arg(i+1)) dtmp = trim(arg(i+2)) - if ((argument == '-rmsdheavy').or.(argument=='-hrmsd')) then + if ((argument == '-rmsdheavy').or.(argument == '-hrmsd')) then call quick_rmsd_tool(ctmp,dtmp,.true.) else call quick_rmsd_tool(ctmp,dtmp,.false.) @@ -657,8 +655,8 @@ subroutine parseflags(env,arg,nra) case ('-hungarian','-hungarianheavy','-hhungarian','-lsap','-hlsap','-lsapheavy') ctmp = trim(arg(i+1)) dtmp = trim(arg(i+2)) - if ((argument == '-hungarianheavy').or.(argument=='-hhungarian').or. & - &(argument == '-lsapheavy').or.(argument=='-hlsap') ) then + if ((argument == '-hungarianheavy').or.(argument == '-hhungarian').or. & + &(argument == '-lsapheavy').or.(argument == '-hlsap')) then call quick_hungarian_match(ctmp,dtmp,.true.) else call quick_hungarian_match(ctmp,dtmp,.false.) @@ -730,7 +728,7 @@ subroutine parseflags(env,arg,nra) env%preopt = .false. env%crestver = crest_optimize env%legacy = .false. - if(argument.eq.'-ohess') env%crest_ohess=.true. + if (argument .eq. '-ohess') env%crest_ohess = .true. exit case ('-hess','-numhess') !> Numerical hessian @@ -750,6 +748,16 @@ subroutine parseflags(env,arg,nra) env%legacy = .false. exit + case ('-sort') + env%preopt = .false. + env%crestver = crest_sorting + ctmp = trim(arg(i+1)) + inquire (file=ctmp,exist=ex) + if (ex)then + env%inputcoords = ctmp + env%ensemblename = ctmp + endif + case ('-SANDBOX') !>--- IMPLEMENT HERE WHATEVER YOU LIKE, FOR TESTING !>----- @@ -1054,35 +1062,35 @@ subroutine parseflags(env,arg,nra) !========================================================================================! if (env%crestver == crest_msreac) then select case (argument) !> msreact - case('-msnoiso') !> filter out non fragmentated structures in msreact - env%msnoiso=.true. - case('-msiso') !> filter out fragmentated structures in msreact - env%msiso=.true. - case('-msnbonds') ! give number of bonds up to which bias potential is added between atoms default 3 - call readl(arg(i + 1),xx,j) + case ('-msnoiso') !> filter out non fragmentated structures in msreact + env%msnoiso = .true. + case ('-msiso') !> filter out fragmentated structures in msreact + env%msiso = .true. + case ('-msnbonds') ! give number of bonds up to which bias potential is added between atoms default 3 + call readl(arg(i+1),xx,j) env%msnbonds = xx(1) - case('-msnshifts') ! give number of times atoms are randomly shifted before optimization - call readl(arg(i + 1),xx,j) + case ('-msnshifts') ! give number of times atoms are randomly shifted before optimization + call readl(arg(i+1),xx,j) env%msnshifts = xx(1) - case('-msnshifts2') ! give number of times atoms are randomly shifted before applying the constrained optimization default 0 - call readl(arg(i + 1),xx,j) + case ('-msnshifts2') ! give number of times atoms are randomly shifted before applying the constrained optimization default 0 + call readl(arg(i+1),xx,j) env%msnshifts2 = xx(1) - case('-msnfrag') ! give number of structures that should be generated - call readl(arg(i + 1),xx,j) + case ('-msnfrag') ! give number of structures that should be generated + call readl(arg(i+1),xx,j) env%msnfrag = xx(1) - case('-msmolbar') !> filter out structures with same molbar code in msreact - env%msmolbar=.true. - case('-msinchi') !> filter out structures with same inchi code in msreact - env%msinchi=.true. - case('-msnoattrh') !> add attractive potential for H-atoms - env%msattrh=.false. - case('-mslargeprint') !> additional printouts and keep MSDIR - env%mslargeprint=.true. - case('-msinput') ! give number of times atoms are randomly shifted before applying the constrained optimization default 0 - ctmp = trim(arg(i+1)) - if (ctmp(1:1) .ne. '-') then - env%msinput = trim(ctmp) - end if + case ('-msmolbar') !> filter out structures with same molbar code in msreact + env%msmolbar = .true. + case ('-msinchi') !> filter out structures with same inchi code in msreact + env%msinchi = .true. + case ('-msnoattrh') !> add attractive potential for H-atoms + env%msattrh = .false. + case ('-mslargeprint') !> additional printouts and keep MSDIR + env%mslargeprint = .true. + case ('-msinput') ! give number of times atoms are randomly shifted before applying the constrained optimization default 0 + ctmp = trim(arg(i+1)) + if (ctmp(1:1) .ne. '-') then + env%msinput = trim(ctmp) + end if end select !> msreact end if !========================================================================================! @@ -1102,7 +1110,7 @@ subroutine parseflags(env,arg,nra) env%performCross = .true. !> do the genetic crossing env%autozsort = .true. case ('-keepdir','-keeptmp') !> Do not delete temporary directories at the end - env%keepModef = .true. + env%keepModef = .true. case ('-opt','-optlev') !> settings for optimization level of GFN-xTB env%optlev = optlevnum(arg(i+1)) write (*,'(2x,a,1x,a)') trim(arg(i)),optlevflag(env%optlev) @@ -1121,7 +1129,7 @@ subroutine parseflags(env,arg,nra) write (*,'(2x,a,'' : Use of GFN1-xTB requested.'')') env%gfnver case ('-gfn2') env%gfnver = '--gfn2' - write (*,'(2x,a,'' : Use of GFN2-xTB requested.'')') env%gfnver + write (*,'(2x,a,'' : Use of GFN2-xTB requested.'')') env%gfnver case ('-gfn0') env%gfnver = '--gfn0' write (*,'(2x,a,'' : Use of GFN0-xTB requested.'')') env%gfnver @@ -1133,7 +1141,7 @@ subroutine parseflags(env,arg,nra) ctype = 5 !> bond constraint activated if (any((/crest_imtd,crest_imtd2/) == env%crestver)) then bondconst = .true. - endif + end if env%cts%cbonds_md = .true. env%checkiso = .true. case ('stereoisomers') @@ -1183,14 +1191,14 @@ subroutine parseflags(env,arg,nra) write (*,'(2x,a,a)') argument,' : energy reweighting' end if - case('-refine','-rsp','-ropt') !> add one refinement step (via cmd only one is possible) + case ('-refine','-rsp','-ropt') !> add one refinement step (via cmd only one is possible) env%legacy = .false. !> new calculators only! - if(nra >= i+1)then + if (nra >= i+1) then env%gfnver2 = trim(arg(i+1)) write (*,'(2x,a,1x,a,a)') argument,trim(env%gfnver2), & & ' : adding refinement step (singlepoint on optimized structures)' - endif - + end if + case ('-charges') !> read charges from file for GFN-FF calcs. ctmp = trim(arg(i+1)) if ((len_trim(ctmp) < 1).or.(ctmp(1:1) == '-')) then @@ -1219,8 +1227,8 @@ subroutine parseflags(env,arg,nra) if (io .eq. 0) env%cts%dscal = rdum end if case ('-mtd_kscal','-mtdkscal') - call readl(arg(i+1),xx,j) - env%mtd_kscal = xx(1) + call readl(arg(i+1),xx,j) + env%mtd_kscal = xx(1) case ('-norestart') env%allowrestart = .false. case ('-readbias') @@ -1446,10 +1454,10 @@ subroutine parseflags(env,arg,nra) env%potpad = xx(1) case ('-watoms','-wat') ctmp = arg(i+1) - if(ctmp(1:1) .ne. '-')then - env%potatlist = trim(ctmp) - write(*,*) env%potatlist - endif + if (ctmp(1:1) .ne. '-') then + env%potatlist = trim(ctmp) + write (*,*) env%potatlist + end if case ('-wall') env%wallsetup = .true. write (*,'(2x,a,1x,a)') '--wall:','requesting setup of wall potential' @@ -1609,8 +1617,8 @@ subroutine parseflags(env,arg,nra) env%protb%threshsort = .true. ctmp = trim(arg(i+1)) if (ctmp(1:1) .ne. '-') then - read(ctmp,*,iostat=io) idum - if(io.eq.0) env%protb%amount = idum + read (ctmp,*,iostat=io) idum + if (io .eq. 0) env%protb%amount = idum end if case ('-swel') !> switch out H+ to something else in protonation script if (env%properties .eq. -3) then @@ -1622,8 +1630,8 @@ subroutine parseflags(env,arg,nra) env%protb%threshsort = .true. ctmp = trim(arg(i+1)) if (ctmp(1:1) .ne. '-') then - read(ctmp,*,iostat=io) idum - if(io.eq.0) env%protb%amount = idum + read (ctmp,*,iostat=io) idum + if (io .eq. 0) env%protb%amount = idum end if case ('-tautomerize') !> tautomerization tool env%properties = p_tautomerize @@ -1821,7 +1829,7 @@ subroutine parseflags(env,arg,nra) env%final_gfn2_opt = .false. case ('-directed') !> specify the directed list env%qcg_flag = .true. - ctmp = trim(arg(i + 1)) + ctmp = trim(arg(i+1)) if (ctmp(1:1) .ne. '-') then env%directed_file = trim(ctmp) write (*,'(2x,a,1x,a)') trim(argument)//' :',trim(ctmp) @@ -2077,7 +2085,7 @@ subroutine parseflags(env,arg,nra) end if !>--- automatic wall potential for the LEGACY version - if (env%NCI.or.env%wallsetup .and. env%legacy) then + if (env%NCI.or.env%wallsetup.and.env%legacy) then call wallpot(env) if (env%wallsetup) then write (*,'(2x,a)') 'Automatically generated ellipsoide potential:' @@ -2149,21 +2157,21 @@ subroutine parseflags(env,arg,nra) env%lmover = env%gfnver end if end if - if (env%ensemble_opt == '--gfn2' .or. env%gfnver == '--gfn2') & + if (env%ensemble_opt == '--gfn2'.or.env%gfnver == '--gfn2') & & env%final_gfn2_opt = .false. !Prevent additional opt. if (env%useqmdff) then env%autozsort = .false. end if - if (.not.env%preopt .and. env%crestver.ne.crest_trialopt) then + if (.not.env%preopt.and.env%crestver .ne. crest_trialopt) then if (allocated(env%ref%topo)) deallocate (env%ref%topo) end if !>-- turn off niceprint if we are not writing to terminal - if(env%niceprint)then + if (env%niceprint) then env%niceprint = myisatty(output_unit) - endif + end if !>-- driver for optimization along trajectory, additional settings if (.not.any((/crest_mfmdgc,crest_imtd,crest_imtd2,crest_compr/) == env%crestver) & @@ -2191,17 +2199,17 @@ subroutine parseflags(env,arg,nra) if (env%sdfformat) then env%autozsort = .false. end if - + !>--- 2023/08/19 moved zsort to a standalone property tool - if(env%autozsort)then + if (env%autozsort) then env%properties = p_zsort - endif + end if !>--- for legacy runtypes, check if xtb is present - if(env%legacy)then + if (env%legacy) then call checkprog_silent(env%ProgName,.true.,iostat=io) - if(io /= 0 ) error stop - endif + if (io /= 0) error stop + end if !========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>! @@ -2212,25 +2220,25 @@ subroutine parseflags(env,arg,nra) write (stdout,'(/,a)',advance='no') '> Setting up backup calculator ...' flush (stdout) call env2calc_setup(env) - write(stdout,*) 'done.' + write (stdout,*) 'done.' call env%calc%info(stdout) end if !>--- pass on opt-level to new calculator - if(.not.env%legacy)then - env%calc%optlev = nint(env%optlev) - endif + if (.not.env%legacy) then + env%calc%optlev = nint(env%optlev) + end if !>--- ONIOM setup from toml file - if (allocated(env%ONIOM_toml))then - allocate(env%calc%ONIOM) - call ONIOM_read_toml(env%ONIOM_toml,env%nat,env%ref%at,env%ref%xyz,env%calc%ONIOM) + if (allocated(env%ONIOM_toml)) then + allocate (env%calc%ONIOM) + call ONIOM_read_toml(env%ONIOM_toml,env%nat,env%ref%at,env%ref%xyz,env%calc%ONIOM) call env%calc%ONIOMexpand() - endif + end if !>--- important printouts - if( .not.env%legacy)then + if (.not.env%legacy) then call print_frozen(env) - endif + end if return end subroutine parseflags @@ -2288,7 +2296,7 @@ subroutine parseRC2(env,bondconst) else env%cts%used = .false. return - end if + end if !>--- read the data call read_constrainbuffer(env%constraints,env%cts) @@ -2303,9 +2311,9 @@ subroutine parseRC2(env,bondconst) end if end do end if - if(.not.env%legacy)then + if (.not.env%legacy) then call parse_xtbinputfile(env,env%constraints) - endif + end if !>--- some settings create = .false. @@ -2455,7 +2463,7 @@ subroutine inputcoords(env,arg) else inputfile = 'coord' end if - if(.not.allocated(env%inputcoords)) env%inputcoords = inputfile + if (.not.allocated(env%inputcoords)) env%inputcoords = inputfile !>-- if the input was a SDF file, special handling env%sdfformat = .false. @@ -2469,16 +2477,16 @@ subroutine inputcoords(env,arg) if (.not.allocated(env%inputcoords)) env%inputcoords = 'coord' call mol%open('coord') !>-- shift to CMA and/or align according to rot.const. We have to be careful about this. - if (any((/ crest_sp, crest_optimize, crest_numhessian, crest_trialopt /) == env%crestver))then + if (any((/crest_sp,crest_optimize,crest_numhessian,crest_trialopt/) == env%crestver)) then !> some runtypes should only do a CMA translation, but no rotation call CMAtrf(mol%nat,mol%nat,mol%at,mol%xyz) - else if (env%crestver == crest_solv)then + else if (env%crestver == crest_solv) then !> runtypes like qcg must not modify input coordinates! continue else !> all other can align with rot. axis call axis(mol%nat,mol%at,mol%xyz) - endif + end if !>-- overwrite coord call mol%write('coord') diff --git a/src/crest_main.f90 b/src/crest_main.f90 index c8d9fc41..91b77494 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -299,6 +299,10 @@ program CREST case(crest_tautomerize) call tautomerize(env,tim) + case(crest_sorting) !> interface to standalone ensemble sorting + call crest_sort(env,tim) + + case (crest_test) call crest_playground(env,tim) diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 31b86ca9..3e6b5202 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -49,6 +49,16 @@ subroutine newcregen(env,quickset,infile) integer,intent(in),optional :: quickset character(len=*),intent(in),optional :: infile end subroutine newcregen + + subroutine cregen_irmsd_all(nall,structures,printlvl) + use strucrd + implicit none + !> INPUT + integer,intent(in) :: nall + type(coord),intent(inout),target :: structures(nall) + integer,intent(in),optional :: printlvl + end subroutine cregen_irmsd_all + end interface end module cregen_interface @@ -163,7 +173,7 @@ subroutine newcregen(env,quickset,infile) call rdensemble(fname,nat,nallref,at,xyz,comments) !call rdensemble(fname,nallref,structures) !allocate(references, source=structures) - + !>--- track ensemble for restart call trackensemble(fname,nat,nallref,at,xyz,comments) @@ -464,7 +474,7 @@ subroutine cregen_director(env,simpleset,checkbroken,sortE,sortRMSD,sortRMSD2, & logical,intent(out) :: anal logical,intent(out) :: topocheck logical,intent(out) :: checkez - logical,intent(out) :: saveelow + logical,intent(out) :: saveelow checkbroken = .true. !> fragmentized structures are sorted out sortE = .true. !> sort based on energy @@ -1507,6 +1517,170 @@ end subroutine cregen_CRE !=========================================================================================! +subroutine cregen_irmsd_all(nall,structures,printlvl) +!******************************************** +!* Proof-of-concept routine to run all +!* pairs of RMSD for an array of structures +!******************************************** + use crest_parameters + use crest_data + use strucrd + use axis_module + use canonical_mod + use irmsd_module + use utilities,only:lin + implicit none + !> INPUT + integer,intent(in) :: nall + type(coord),intent(inout),target :: structures(nall) + integer,intent(in),optional :: printlvl + + !> LOCAL + integer :: i,j,ii,jj,T,nallpairs,cc,nat + integer :: prlvl,iunit + type(rmsd_cache),allocatable :: rcaches(:) + !type(rmsd_cache) :: rcaches + type(coord),allocatable,target :: workmols(:) + type(canonical_sorter),allocatable :: sorters(:) + real(wp),allocatable :: rmsds(:) + type(coord),pointer :: ref,mol + type(coord) :: molloc + real(wp) :: rmsdval,runtime + logical :: stereocheck + type(timer) :: profiler + + logical,parameter :: debug = .true. + real(wp),allocatable :: debugrmsds(:) + + !> for implementing OpenMP parallelism + T = 1 + + !> print level + if (present(printlvl)) then + prlvl = printlvl + else + prlvl = 0 + end if + + !> set up timer + call profiler%init(3) + + !> prepare workspace + nallpairs = (nall*(nall+1))/2 + allocate (rmsds(nallpairs),source=0.0_wp) + if (debug) then + allocate (debugrmsds(nallpairs),source=0.0_wp) + end if + + allocate (rcaches(T)) + ref => structures(1) + nat = ref%nat + allocate (workmols(T)) + do i = 1,T + mol => workmols(i) + allocate (mol%at(ref%nat)) + allocate (mol%xyz(3,ref%nat)) + nullify (mol) + call rcaches(i)%allocate(ref%nat) + end do + + !> set up ranks for each structure + call profiler%start(1) + allocate (sorters(nall)) + if (prlvl > 0) then + write (stdout,'(a)',advance='no') 'CREGEN> Setting up canonical atom ranks ... ' + flush (stdout) + end if + do ii = 1,nall + mol => structures(ii) + call axis(mol%nat,mol%at,mol%xyz) + call sorters(ii)%init(mol,invtype='apsp+') + call sorters(ii)%add_h_ranks(mol) + if (ii == 1) then + stereocheck = .not. (sorters(ii)%hasstereo(ref)) + end if + call sorters(ii)%shrink() + end do + call profiler%stop(1) + if (prlvl > 0) then + call profiler%write_timing(stdout,1,'done.',.true.) + runtime = (profiler%get(1)/real(nall,wp))*1000.0_wp + write (stdout,'(a,f0.3,a)') 'CREGEN> Corresponding to approximately ',runtime, & + & ' ms per processed structure' + end if + + !> And finally, run the RMSD checks + call profiler%start(2) + if (prlvl > 0) then + write (stdout,*) + write (stdout,'(a)',advance='no') 'CREGEN> Running all pair RMSDs ... ' + flush (stdout) + end if + cc = 1 + do ii = 1,nall + rcaches(cc)%stereocheck = stereocheck + rcaches(cc)%rank(1:nat,1) = sorters(ii)%rank(1:nat) + do jj = ii+1,nall + workmols(cc)%nat = structures(jj)%nat + workmols(cc)%at(:) = structures(jj)%at(:) + workmols(cc)%xyz(:,:) = structures(jj)%xyz(:,:) + !molloc = structures(jj) + rcaches(cc)%rank(:,2) = sorters(jj)%rank(:) + call min_rmsd(structures(ii),workmols(cc), & + & rcache=rcaches(cc),rmsdout=rmsdval) + rmsds(lin(ii,jj)) = rmsdval + end do + end do + call profiler%stop(2) + if (prlvl > 0) then + call profiler%write_timing(stdout,2,'done.',.true.) + !write (stdout,'(a)',advance='yes') 'done.' + runtime = (profiler%get(2)/real(nallpairs,wp))*1000.0_wp + write (stdout,'(a,f0.3,a)') 'CREGEN> Corresponding to approximately ',runtime, & + & ' ms per processed RMSD' + + end if + + if (debug) then + !> RMSD without permutation + do ii = 1,nall + do jj = ii+1,nall + rmsdval = rmsd(structures(ii),structures(jj)) + debugrmsds(lin(ii,jj)) = rmsdval + end do + end do + end if + + if (prlvl > 1) then + write (stdout,'(a)') 'CREGEN> Writing cregen_rmsds.csv with RMSDs in Angström' + open (newunit=iunit,file='cregen_rmsds.csv') + if (debug) then + write (iunit,'(a,3(",",a))') 'A','B','rmsd','rmsdref' + do ii = 1,nall + do jj = ii+1,nall + write (iunit,'(i0,",",i0,2(",",f0.7))') & + & min(ii,jj),max(ii,jj),rmsds(lin(ii,jj))*autoaa,debugrmsds(lin(ii,jj))*autoaa + end do + end do + else + write (iunit,'(a,",",a,",",a)') 'A','B','rmsd' + do ii = 1,nall + do jj = ii+1,nall + write (iunit,'(i0,",",i0,",",f0.7)') min(ii,jj),max(ii,jj),rmsds(lin(ii,jj))*autoaa + end do + end do + end if + close (iunit) + end if + + deallocate (sorters) + deallocate (workmols) + deallocate (rcaches) + deallocate (rmsds) +end subroutine cregen_irmsd_all + +!=========================================================================================! + subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) !**************************************************************** !* subroutine cregen_EQUAL diff --git a/src/sorting/hungarian.f90 b/src/sorting/hungarian.f90 index 5fb5778d..dd9b1d5c 100644 --- a/src/sorting/hungarian.f90 +++ b/src/sorting/hungarian.f90 @@ -404,8 +404,9 @@ function augmenting_path(nr,nc,cost,u,v,path,row4col, & end if SC(j) = .true. - num_remaining = num_remaining-1 + remaining(indx) = remaining(num_remaining) + num_remaining = num_remaining-1 end do end function augmenting_path From 45b5d100210190d74da61ec2d46c748931caa850 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 19 Sep 2024 16:29:58 +0200 Subject: [PATCH 021/374] Modified adding H ranks to canonical sorter --- src/algos/playground.f90 | 2 +- src/minitools.f90 | 18 +++++--- src/sorting/canonical.f90 | 88 ++++++++++++++++++++------------------- src/sorting/cregen.f90 | 4 +- 4 files changed, 62 insertions(+), 50 deletions(-) diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index bffbf199..de0714f4 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -81,7 +81,7 @@ subroutine crest_playground(env,tim) write(stdout,*) write(stdout,*) 'CANGEN algorithm' - call can%init(mol,calc%calcs(1)%wbo,'apsp+') + call can%init(mol,calc%calcs(1)%wbo,'apsp+',heavy=.false.) call can%stereo(mol) call can%rankprint(mol) diff --git a/src/minitools.f90 b/src/minitools.f90 index 32dd170e..e008fc8a 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -762,7 +762,7 @@ subroutine irmsd_tool(fname1,fname2) character(len=*),intent(in) :: fname1 character(len=*),intent(in) :: fname2 type(coord) :: mol,ref - real(wp) :: rmsdval + real(wp) :: rmsdval,tmpd(3),tmpdist integer :: i,ich type(rmsd_cache) :: rcache type(canonical_sorter) :: canmol @@ -785,14 +785,14 @@ subroutine irmsd_tool(fname1,fname2) call rcache%allocate(ref%nat) !> canonical atom ranks - call canref%init(ref,invtype='apsp+') - call canref%add_h_ranks(ref) + call canref%init(ref,invtype='apsp+',heavy=.false.) + !call canref%add_h_ranks(ref) rcache%stereocheck = .not. (canref%hasstereo(ref)) call canref%shrink() write(*,*) 'false enantiomers possible?: ',rcache%stereocheck - call canmol%init(mol,invtype='apsp+') - call canmol%add_h_ranks(mol) + call canmol%init(mol,invtype='apsp+',heavy=.false.) + !call canmol%add_h_ranks(mol) call canmol%shrink() !> check if we can work with the determined ranks @@ -825,6 +825,14 @@ subroutine irmsd_tool(fname1,fname2) write (stdout,*) 'aligned structures written to irmsd.xyz' write (stdout,*) + do i=1,mol%nat + tmpd(:) = (mol%xyz(:,i) - ref%xyz(:,i))**2 + tmpdist = sqrt(sum(tmpd(:)))*autoaa + if(tmpdist > 0.01_wp)then + write(*,*) i,mol%at(i),tmpdist + endif + enddo + rmsdval = rmsdval*autoaa write (*,'(1x,a,f16.8)') 'Calculated iRMSD (Å):',rmsdval diff --git a/src/sorting/canonical.f90 b/src/sorting/canonical.f90 index 7c1decef..96e9f380 100644 --- a/src/sorting/canonical.f90 +++ b/src/sorting/canonical.f90 @@ -109,7 +109,7 @@ end subroutine shrink_canonical_sorter !========================================================================================! - subroutine init_canonical_sorter(self,mol,wbo,invtype) + subroutine init_canonical_sorter(self,mol,wbo,invtype,heavy) !***************************************************************** !* Initializes the canonical_sorter and runs the CANGEN algorithm !***************************************************************** @@ -118,6 +118,7 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) type(coord),intent(in) :: mol real(wp),intent(in),optional :: wbo(mol%nat,mol%nat) character(len=*),intent(in),optional :: invtype + logical,intent(in),optional :: heavy integer :: nodes integer,allocatable :: Amat(:,:) !> adjacency matrix for FULL molecule integer :: counth,countb,countbo @@ -126,7 +127,7 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) integer :: i,j,k,l,ii,ati,atj,maxnei integer,allocatable :: ichrgs(:),frag(:) character(len=:),allocatable :: myinvtype - logical :: use_icharges + logical :: use_icharges,include_H,anyH !>--- optional argument handling if (present(invtype)) then @@ -134,6 +135,12 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) else myinvtype = 'cangen' end if + if (present(heavy)) then + include_H = .not.heavy + else + include_H = .false. + end if + anyH = any(mol%at(:).eq.1) !>--- all atoms of the full mol. graph are nodes nodes = mol%nat @@ -141,7 +148,7 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) !>--- map to heavy atom-only representation k = 0 do i = 1,mol%nat - if (mol%at(i) .ne. 1) k = k+1 + if (mol%at(i) .ne. 1.or.include_h) k = k+1 end do self%nat = nodes self%hatms = k @@ -178,7 +185,7 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) k = 0 do i = 1,nodes l = 0 - if (mol%at(i) .ne. 1) then + if (mol%at(i) .ne. 1.or.include_h) then k = k+1 self%nmap(i) = k self%hmap(k) = i @@ -192,8 +199,11 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) end if end do end do + !> H's excluded from hadjac, always do i = 1,k + if (mol%at(self%hmap(i)) .eq. 1) cycle do j = 1,i-1 + if (mol%at(self%hmap(j)) .eq. 1) cycle self%hadjac(j,i) = Amat(self%hmap(j),self%hmap(i)) self%hadjac(i,j) = self%hadjac(j,i) end do @@ -278,6 +288,14 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) call debugprint(self,mol) end if call self%iterate(mol) !> iterate recursively until ranking doesn't change + +!>--- finally, if required, add H atoms + if (include_H .and. anyH) then + !> sinc H's will have been added with rank 1, shift all ranks + self%rank(:) = self%rank(:)-1 + call self%add_h_ranks(mol) + end if + end subroutine init_canonical_sorter !========================================================================================! @@ -621,49 +639,35 @@ subroutine add_h_ranks(self,mol) integer,allocatable :: rankmap(:) integer :: i,ii,zero,nei,j,jj,maxrank,rr,maxrank2 logical :: hneigh -!>--- if there is no H, or this routine was already called, return - if (size(self%rank,1) .eq. mol%nat) return +!>--- self%rank must already have the correct dimension! + if (size(self%rank,1) .ne. mol%nat) then + stop 'wrong dimension for adding H to canonical ranks!' + end if + !>--- otherwise, analyze and resize maxrank = maxval(self%rank(:),1) + +!>--- cycle through atoms, assign ranks depending on neighbour list allocate (rankmap(maxrank),source=0) - allocate (rankh(mol%nat),source=0) + rr = 0 do i = 1,self%hatms - ii = self%hmap(i) - zero = count(self%neigh(:,ii) == 0) - nei = self%maxnei-zero - rr = self%rank(i) - rankh(ii) = rr - - do j = 1,nei - jj = self%neigh(j,ii) - if (mol%at(jj) == 1) then - -!>--- rankmap will map the new ranks of H atoms attached to -!> the already ranked heavy atoms. This way equivalent H's will get the same rank -!> I.e. if two methyl groups have same ranks, their H's must also have the same ranks - if (rankmap(rr) == 0) then - !maxrank = maxrank+1 - rankmap(rr) = maxrank + rr - end if - rankh(jj) = rankmap(rr) - end if - end do + if (mol%at(i) .ne. 1) cycle + ii = self%neigh(1,i) + jj = self%rank(ii) + rankmap(jj) = 1 + end do + do i = 1,maxrank + if (rankmap(i) .eq. 1) then + rr = rr+1 + rankmap(i) = maxrank+rr + end if + end do + do i = 1,self%hatms + if (mol%at(i) .ne. 1) cycle + ii = self%neigh(1,i) + jj = self%rank(ii) + self%rank(i) = rankmap(jj) end do -!>--- clean up "gaps" in rank assignment - maxrank=maxval(rankh,1) - maxrank2 = maxrank - do i=1,maxrank - if(i > maxrank2) exit - ii = count(rankh(:) == i) - if(ii == 0) maxrank2 = maxrank2 - 1 - do while (ii == 0) - do jj=1,mol%nat - if(rankh(jj) > i) rankh(jj) = rankh(jj) - 1 - enddo - ii = count(rankh(:) == i) - enddo - enddo - call move_alloc(rankh,self%rank) deallocate (rankmap) end subroutine add_h_ranks diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 3e6b5202..226a2df7 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -1594,8 +1594,8 @@ subroutine cregen_irmsd_all(nall,structures,printlvl) do ii = 1,nall mol => structures(ii) call axis(mol%nat,mol%at,mol%xyz) - call sorters(ii)%init(mol,invtype='apsp+') - call sorters(ii)%add_h_ranks(mol) + call sorters(ii)%init(mol,invtype='apsp+',heavy=.false.) + !call sorters(ii)%add_h_ranks(mol) if (ii == 1) then stereocheck = .not. (sorters(ii)%hasstereo(ref)) end if From ca38408834f007d7ead8e6c23d315477ee3af300 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 26 Sep 2024 17:23:33 +0200 Subject: [PATCH 022/374] Some maintenance, fix unit tests --- src/optimize/optimize_maths.f90 | 4 +- src/sorting/canonical.f90 | 38 +------ src/sorting/cregen.f90 | 19 +++- src/sorting/quicksort.f90 | 38 +++---- src/utilmod.f90 | 188 +++++++++++++++++++++++++++----- 5 files changed, 198 insertions(+), 89 deletions(-) diff --git a/src/optimize/optimize_maths.f90 b/src/optimize/optimize_maths.f90 index b46a223c..1e714d98 100644 --- a/src/optimize/optimize_maths.f90 +++ b/src/optimize/optimize_maths.f90 @@ -113,8 +113,8 @@ recursive subroutine detrotra_qsort(a,first,last,ind) i = i+1 j = j-1 end do - if (first < i-1) call qsort(a,first,i-1,ind) - if (j+1 < last) call qsort(a,j+1,last,ind) + if (first < i-1) call detrotra_qsort(a,first,i-1,ind) + if (j+1 < last) call detrotra_qsort(a,j+1,last,ind) end subroutine detrotra_qsort end subroutine detrotra8 diff --git a/src/sorting/canonical.f90 b/src/sorting/canonical.f90 index 96e9f380..5ad4b260 100644 --- a/src/sorting/canonical.f90 +++ b/src/sorting/canonical.f90 @@ -21,6 +21,7 @@ module canonical_mod use strucrd use adjacency use geo + use utilities, only: nth_prime implicit none private @@ -672,43 +673,6 @@ subroutine add_h_ranks(self,mol) end subroutine add_h_ranks !========================================================================================! -!========================================================================================! - - function nth_prime(x) result(prime) - implicit none - integer,intent(in) :: x - integer :: prime - integer :: c,num,i - logical :: is_prime - integer,parameter :: prime_numbers(100) = (/2,3,5,7,11,13,17,19,23,29, & - & 31,37,41,43,47,53,59,61,67,71,73,79,83,89,97,101,103,107,109, & - & 113,127,131,137,139,149,151,157,163,167,173,179,181,191,193,197, & - & 199,211,223,227,229,233,239,241,251,257,263,269,271,277,281,283, & - & 293,307,311,313,317,331,337,347,349,353,359,367,373,379,383,389, & - & 397,401,409,419,421,431,433,439,443,449,457,461,463,467,479,487, & - & 491,499,503,509,521,523,541/) - if (x <= 100) then - prime = prime_numbers(x) - return - end if - c = 0 - num = 1 - do while (c < x) - num = num+1 - is_prime = .true. - do i = 2,int(sqrt(real(num))) - if (mod(num,i) == 0) then - is_prime = .false. - exit - end if - end do - if (is_prime) then - c = c+1 - end if - end do - prime = num - end function nth_prime - !========================================================================================! subroutine debugprint(can,mol) diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 226a2df7..71b37e4f 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -646,6 +646,7 @@ subroutine discardbroken(ch,env,topocheck,nat,nall,at,xyz,comments,newnall) use crest_data use strucrd use miscdata,only:rcov + use quicksort_interface implicit none !> INPUT type(systemdata) :: env ! MAIN STORAGE OS SYSTEM DATA @@ -741,7 +742,8 @@ subroutine discardbroken(ch,env,topocheck,nat,nall,at,xyz,comments,newnall) order = orderref call xyzqsort(nat,nall,xyz,c0,order,1,nall) order = orderref - call stringqsort(nall,comments,1,nall,order) + !call stringqsort(nall,comments,1,nall,order) + call stringqsort(nall,len(comments(1)),comments,1,nall,order) llan = nall-newnall write (ch,'('' number of removed clashes :'',i6)') llan @@ -774,6 +776,7 @@ subroutine cregen_topocheck(ch,env,checkez,nat,nall,at,xyz,comments,newnall) use miscdata,only:rcov use utilities use crest_cn_module + use quicksort_interface implicit none type(systemdata) :: env ! MAIN STORAGE OS SYSTEM DATA integer,intent(in) :: ch ! printout channel @@ -891,7 +894,8 @@ subroutine cregen_topocheck(ch,env,checkez,nat,nall,at,xyz,comments,newnall) order = orderref call xyzqsort(nat,nall,xyz,c1,order,1,nall) order = orderref - call stringqsort(nall,comments,1,nall,order) + !call stringqsort(nall,comments,1,nall,order) + call stringqsort(nall,len(comments(1)),comments,1,nall,order) llan = nall-newnall write (ch,'('' number of topology mismatches :'',i6)') llan @@ -1060,6 +1064,7 @@ subroutine cregen_esort(ch,nat,nall,xyz,comments,nallout,ewin) !************************************************************** use crest_parameters use strucrd + use quicksort_interface implicit none integer,intent(in) :: ch integer,intent(in) :: nat @@ -1098,7 +1103,8 @@ subroutine cregen_esort(ch,nat,nall,xyz,comments,nallout,ewin) deallocate (c0) order = orderref - call stringqsort(nall,comments,1,nall,order) + !call stringqsort(nall,comments,1,nall,order) + call stringqsort(nall,len(comments(1)),comments,1,nall,order) !>-- determine cut-off of energies if (ewin < 9999.9_wp) then @@ -1153,6 +1159,7 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) use ls_rmsd use axis_module use utilities + use quicksort_interface implicit none type(systemdata) :: env integer,intent(in) :: ch @@ -1423,7 +1430,7 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) order = orderref call maskqsort(er,1,nall,order) order = orderref - call stringqsort(nall,comments,1,nall,order) + call stringqsort(nall,len(comments(1)),comments,1,nall,order) order = orderref call matqsort(3,nall,rot,rotdum,1,nall,order) end if @@ -2115,6 +2122,7 @@ subroutine cregen_repairorder(nat,nall,xyz,comments,group) use crest_data use strucrd use utilities + use quicksort_interface implicit none integer,intent(in) :: nat integer,intent(in) :: nall @@ -2168,7 +2176,8 @@ subroutine cregen_repairorder(nat,nall,xyz,comments,group) call xyzqsort(nat,nall,xyz,cdum,order,1,nall) deallocate (cdum) order = orderref - call stringqsort(nall,comments,1,nall,order) + !call stringqsort(nall,comments,1,nall,order) + call stringqsort(nall,len(comments(1)),comments,1,nall,order) if (ttag) then edum = grepenergy(comments(1)) write (btmp,*) edum,'!t1' diff --git a/src/sorting/quicksort.f90 b/src/sorting/quicksort.f90 index cb31e5d9..16b0742c 100644 --- a/src/sorting/quicksort.f90 +++ b/src/sorting/quicksort.f90 @@ -32,24 +32,24 @@ end subroutine quicksort recursive subroutine qsort(a,first,last,ind) use iso_fortran_env,only:wp => real64 implicit none - real(wp) :: a(:) - integer :: ind(:) + real(wp) :: a(*) + integer :: ind(*) integer :: first,last end subroutine qsort recursive subroutine qqsort(a,first,last) use iso_fortran_env,only:wp => real64 implicit none - real(wp) :: a(:) + real(wp) :: a(*) integer :: first,last end subroutine qqsort recursive subroutine maskqsort(a,first,last,mask) use iso_fortran_env,only:wp => real64 implicit none - real(wp) :: a(:) + real(wp) :: a(*) integer :: first,last - integer :: mask(:) + integer :: mask(*) end subroutine maskqsort recursive subroutine matqsort(adim,nall,a,adum,first,last,mask) @@ -61,10 +61,10 @@ recursive subroutine matqsort(adim,nall,a,adum,first,last,mask) integer :: mask(nall) end subroutine matqsort - recursive subroutine stringqsort(sdim,strs,first,last,mask) + recursive subroutine stringqsort(sdim,slen,strs,first,last,mask) implicit none - integer :: sdim - character(len=*) :: strs(sdim) + integer,intent(in) :: sdim,slen + character(len=slen) :: strs(sdim) integer :: first,last integer :: mask(sdim) end subroutine stringqsort @@ -153,9 +153,9 @@ end subroutine quicksort recursive subroutine qsort(a,first,last,ind) use iso_fortran_env,only:wp => real64 implicit none - real(wp) :: a(:) + real(wp) :: a(*) real(wp) :: x,t - integer :: ind(:) + integer :: ind(*) integer :: first,last,i,j,ii x = a((first+last)/2) @@ -181,7 +181,7 @@ end subroutine qsort recursive subroutine qqsort(a,first,last) use iso_fortran_env,only:wp => real64 implicit none - real(wp) :: a(:) + real(wp) :: a(*) real(wp) :: x,t integer :: first,last,i,j @@ -207,10 +207,10 @@ end subroutine qqsort recursive subroutine maskqsort(a,first,last,mask) use iso_fortran_env,only:wp => real64 implicit none - real(wp) :: a(:) + real(wp) :: a(*) real(wp) :: t integer :: x,first,last,i,j,ii - integer :: mask(:) + integer :: mask(*) x = mask((first+last)/2) i = first @@ -260,11 +260,11 @@ recursive subroutine matqsort(adim,nall,a,adum,first,last,mask) if (j+1 < last) call matqsort(adim,nall,a,adum,j+1,last,mask) end subroutine matqsort -recursive subroutine stringqsort(sdim,strs,first,last,mask) +recursive subroutine stringqsort(sdim,slen,strs,first,last,mask) implicit none - integer :: sdim - character(len=*) :: strs(sdim) - character(len=len(strs(1))) :: str + integer,intent(in) :: sdim,slen + character(len=slen) :: strs(sdim) + character(len=slen) :: str integer :: x,first,last,i,j,ii integer :: mask(sdim) x = mask((first+last)/2) @@ -283,8 +283,8 @@ recursive subroutine stringqsort(sdim,strs,first,last,mask) i = i+1 j = j-1 end do - if (first < i-1) call stringqsort(sdim,strs,first,i-1,mask) - if (j+1 < last) call stringqsort(sdim,strs,j+1,last,mask) + if (first < i-1) call stringqsort(sdim,slen,strs,first,i-1,mask) + if (j+1 < last) call stringqsort(sdim,slen,strs,j+1,last,mask) end subroutine stringqsort subroutine maskinvert(nall,mask) diff --git a/src/utilmod.f90 b/src/utilmod.f90 index 5ba52271..a33251b1 100644 --- a/src/utilmod.f90 +++ b/src/utilmod.f90 @@ -49,6 +49,7 @@ module utilities public :: distcma public :: binomial public :: factorial + public :: nth_prime !========================================================================================! !========================================================================================! @@ -544,64 +545,199 @@ end subroutine dumpenergies !========================================================================================! - function binomial(n, k) result(res) + function binomial(n,k) result(res) !************************************************** -!* Function to calculate the binomial coefficient +!* Function to calculate the binomial coefficient !* !* ⎛ n ⎞ !* ⎝ k ⎠ = n! / (k! * (n - k)!) !* !************************************************** implicit none - integer, intent(in) :: n, k + integer,intent(in) :: n,k real(wp) :: reswp integer :: res - reswp = factorial(n) / (factorial(k) * factorial(n - k)) + reswp = factorial(n)/(factorial(k)*factorial(n-k)) res = nint(reswp) end function binomial - function factorial(x) result(fact) !*************************************************** -!* Function to calculate the factorial of a number -!* factorial(x) = x! = x * (x-1) * (x-2) * ... * 1 +!* Function to calculate the factorial of a number +!* factorial(x) = x! = x * (x-1) * (x-2) * ... * 1 !*************************************************** implicit none - integer, intent(in) :: x + integer,intent(in) :: x integer :: i real(wp) :: fact fact = 1.0_wp - do i = 2, x - fact = fact * real(i,wp) + do i = 2,x + fact = fact*real(i,wp) end do end function factorial - - recursive subroutine get_combinations(n, k, ntot, c, combinations, tmp, depth) + recursive subroutine get_combinations(n,k,ntot,c,combinations,tmp,depth) implicit none - integer, intent(in) :: n, k, ntot, depth !> depth should start out as 0 + integer,intent(in) :: n,k,ntot,depth !> depth should start out as 0 integer,intent(inout) :: c,tmp(k) - integer, intent(inout) :: combinations(k,ntot) + integer,intent(inout) :: combinations(k,ntot) integer :: i if (depth >= k) then - c=c+1 + c = c+1 combinations(:,c) = tmp(:) return - else if(depth==0)then - do i=1,n - tmp(depth+1) = i - call get_combinations(n, k, ntot, c, combinations, tmp, depth+1) - enddo - else - do i=1,tmp(depth) - if(i==tmp(depth)) cycle - tmp(depth+1) = i - call get_combinations(n, k, ntot, c, combinations, tmp, depth+1) - enddo + else if (depth == 0) then + do i = 1,n + tmp(depth+1) = i + call get_combinations(n,k,ntot,c,combinations,tmp,depth+1) + end do + else + do i = 1,tmp(depth) + if (i == tmp(depth)) cycle + tmp(depth+1) = i + call get_combinations(n,k,ntot,c,combinations,tmp,depth+1) + end do end if end subroutine get_combinations +!========================================================================================! + function nth_prime(n) result(prime) +!******************************************** +!* get the n-th prime number. +!* The first thousand are saved as a +!* parameter to reduce computational effort. +!******************************************** + implicit none + integer,intent(in) :: n + integer :: prime + integer :: c,num,i + logical :: is_prime +!&< + integer,parameter :: maxprimepar = 1000 + integer, parameter :: prime_numbers(maxprimepar) = (/ & + & 2, 3, 5, 7, 11, 13, 17, 19, 23, 29, & + & 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, & + & 73, 79, 83, 89, 97, 101, 103, 107, 109, 113, & + & 127, 131, 137, 139, 149, 151, 157, 163, 167, 173, & + & 179, 181, 191, 193, 197, 199, 211, 223, 227, 229, & + & 233, 239, 241, 251, 257, 263, 269, 271, 277, 281, & + & 283, 293, 307, 311, 313, 317, 331, 337, 347, 349, & + & 353, 359, 367, 373, 379, 383, 389, 397, 401, 409, & + & 419, 421, 431, 433, 439, 443, 449, 457, 461, 463, & + & 467, 479, 487, 491, 499, 503, 509, 521, 523, 541, & + & 547, 557, 563, 569, 571, 577, 587, 593, 599, 601, & + & 607, 613, 617, 619, 631, 641, 643, 647, 653, 659, & + & 661, 673, 677, 683, 691, 701, 709, 719, 727, 733, & + & 739, 743, 751, 757, 761, 769, 773, 787, 797, 809, & + & 811, 821, 823, 827, 829, 839, 853, 857, 859, 863, & + & 877, 881, 883, 887, 907, 911, 919, 929, 937, 941, & + & 947, 953, 967, 971, 977, 983, 991, 997, 1009, 1013, & + & 1019, 1021, 1031, 1033, 1039, 1049, 1051, 1061, 1063, 1069, & + & 1087, 1091, 1093, 1097, 1103, 1109, 1117, 1123, 1129, 1151, & + & 1153, 1163, 1171, 1181, 1187, 1193, 1201, 1213, 1217, 1223, & + & 1229, 1231, 1237, 1249, 1259, 1277, 1279, 1283, 1289, 1291, & + & 1297, 1301, 1303, 1307, 1319, 1321, 1327, 1361, 1367, 1373, & + & 1381, 1399, 1409, 1423, 1427, 1429, 1433, 1439, 1447, 1451, & + & 1453, 1459, 1471, 1481, 1483, 1487, 1489, 1493, 1499, 1511, & + & 1523, 1531, 1543, 1549, 1553, 1559, 1567, 1571, 1579, 1583, & + & 1597, 1601, 1607, 1609, 1613, 1619, 1621, 1627, 1637, 1657, & + & 1663, 1667, 1669, 1693, 1697, 1699, 1709, 1721, 1723, 1733, & + & 1741, 1747, 1753, 1759, 1777, 1783, 1787, 1789, 1801, 1811, & + & 1823, 1831, 1847, 1861, 1867, 1871, 1873, 1877, 1879, 1889, & + & 1901, 1907, 1913, 1931, 1933, 1949, 1951, 1973, 1979, 1987, & + & 1993, 1997, 1999, 2003, 2011, 2017, 2027, 2029, 2039, 2053, & + & 2063, 2069, 2081, 2083, 2087, 2089, 2099, 2111, 2113, 2129, & + & 2131, 2137, 2141, 2143, 2153, 2161, 2179, 2203, 2207, 2213, & + & 2221, 2237, 2239, 2243, 2251, 2267, 2269, 2273, 2281, 2287, & + & 2293, 2297, 2309, 2311, 2333, 2339, 2341, 2347, 2351, 2357, & + & 2371, 2377, 2381, 2383, 2389, 2393, 2399, 2411, 2417, 2423, & + & 2437, 2441, 2447, 2459, 2467, 2473, 2477, 2503, 2521, 2531, & + & 2539, 2543, 2549, 2551, 2557, 2579, 2591, 2593, 2609, 2617, & + & 2621, 2633, 2647, 2657, 2659, 2663, 2671, 2677, 2683, 2687, & + & 2689, 2693, 2699, 2707, 2711, 2713, 2719, 2729, 2731, 2741, & + & 2749, 2753, 2767, 2777, 2789, 2791, 2797, 2801, 2803, 2819, & + & 2833, 2837, 2843, 2851, 2857, 2861, 2879, 2887, 2897, 2903, & + & 2909, 2917, 2927, 2939, 2953, 2957, 2963, 2969, 2971, 2999, & + & 3001, 3011, 3019, 3023, 3037, 3041, 3049, 3061, 3067, 3079, & + & 3083, 3089, 3109, 3119, 3121, 3137, 3163, 3167, 3169, 3181, & + & 3187, 3191, 3203, 3209, 3217, 3221, 3229, 3251, 3253, 3257, & + & 3259, 3271, 3299, 3301, 3307, 3313, 3319, 3323, 3329, 3331, & + & 3343, 3347, 3359, 3361, 3371, 3373, 3389, 3391, 3407, 3413, & + & 3433, 3449, 3457, 3461, 3463, 3467, 3469, 3491, 3499, 3511, & + & 3517, 3527, 3529, 3533, 3539, 3541, 3547, 3557, 3559, 3571, & + & 3581, 3583, 3593, 3607, 3613, 3617, 3623, 3631, 3637, 3643, & + & 3659, 3671, 3673, 3677, 3691, 3697, 3701, 3709, 3719, 3727, & + & 3733, 3739, 3761, 3767, 3769, 3779, 3793, 3797, 3803, 3821, & + & 3823, 3833, 3847, 3851, 3853, 3863, 3877, 3881, 3889, 3907, & + & 3911, 3917, 3919, 3923, 3929, 3931, 3943, 3947, 3967, 3989, & + & 4001, 4003, 4007, 4013, 4019, 4021, 4027, 4049, 4051, 4057, & + & 4073, 4079, 4091, 4093, 4099, 4111, 4127, 4129, 4133, 4139, & + & 4153, 4157, 4159, 4177, 4201, 4211, 4217, 4219, 4229, 4231, & + & 4241, 4243, 4253, 4259, 4261, 4271, 4273, 4283, 4289, 4297, & + & 4327, 4337, 4339, 4349, 4357, 4363, 4373, 4391, 4397, 4409, & + & 4421, 4423, 4441, 4447, 4451, 4457, 4463, 4481, 4483, 4493, & + & 4507, 4513, 4517, 4519, 4523, 4547, 4549, 4561, 4567, 4583, & + & 4591, 4597, 4603, 4621, 4637, 4639, 4643, 4649, 4651, 4657, & + & 4663, 4673, 4679, 4691, 4703, 4721, 4723, 4729, 4733, 4751, & + & 4759, 4783, 4787, 4789, 4793, 4799, 4801, 4813, 4817, 4831, & + & 4861, 4871, 4877, 4889, 4903, 4909, 4919, 4931, 4933, 4937, & + & 4943, 4951, 4957, 4967, 4969, 4973, 4987, 4993, 4999, 5003, & + & 5009, 5011, 5021, 5023, 5039, 5051, 5059, 5077, 5081, 5087, & + & 5099, 5101, 5107, 5113, 5119, 5147, 5153, 5167, 5171, 5179, & + & 5189, 5197, 5209, 5227, 5231, 5233, 5237, 5261, 5273, 5279, & + & 5281, 5297, 5303, 5309, 5323, 5333, 5347, 5351, 5381, 5387, & + & 5393, 5399, 5407, 5413, 5417, 5419, 5431, 5437, 5441, 5443, & + & 5449, 5471, 5477, 5479, 5483, 5501, 5503, 5507, 5519, 5521, & + & 5527, 5531, 5557, 5563, 5569, 5573, 5581, 5591, 5623, 5639, & + & 5641, 5647, 5651, 5653, 5657, 5659, 5669, 5683, 5689, 5693, & + & 5701, 5711, 5717, 5737, 5741, 5743, 5749, 5779, 5783, 5791, & + & 5801, 5807, 5813, 5821, 5827, 5839, 5843, 5849, 5851, 5857, & + & 5861, 5867, 5869, 5879, 5881, 5897, 5903, 5923, 5927, 5939, & + & 5953, 5981, 5987, 6007, 6011, 6029, 6037, 6043, 6047, 6053, & + & 6067, 6073, 6079, 6089, 6091, 6101, 6113, 6121, 6131, 6133, & + & 6143, 6151, 6163, 6173, 6197, 6199, 6203, 6211, 6217, 6221, & + & 6229, 6247, 6257, 6263, 6269, 6271, 6277, 6287, 6299, 6301, & + & 6311, 6317, 6323, 6329, 6337, 6343, 6353, 6359, 6361, 6367, & + & 6373, 6379, 6389, 6397, 6421, 6427, 6449, 6451, 6469, 6473, & + & 6481, 6491, 6521, 6529, 6547, 6551, 6553, 6563, 6569, 6571, & + & 6577, 6581, 6599, 6607, 6619, 6637, 6653, 6659, 6661, 6673, & + & 6679, 6689, 6691, 6701, 6703, 6709, 6719, 6733, 6737, 6761, & + & 6763, 6779, 6781, 6791, 6793, 6803, 6823, 6827, 6829, 6833, & + & 6841, 6857, 6863, 6869, 6871, 6883, 6899, 6907, 6911, 6917, & + & 6947, 6949, 6959, 6961, 6967, 6971, 6977, 6983, 6991, 6997, & + & 7001, 7013, 7019, 7027, 7039, 7043, 7057, 7069, 7079, 7103, & + & 7109, 7121, 7127, 7129, 7151, 7159, 7177, 7187, 7193, 7207, & + & 7211, 7213, 7219, 7229, 7237, 7243, 7247, 7253, 7283, 7297, & + & 7307, 7309, 7321, 7331, 7333, 7349, 7351, 7369, 7393, 7411, & + & 7417, 7433, 7451, 7457, 7459, 7477, 7481, 7487, 7489, 7499, & + & 7507, 7517, 7523, 7529, 7537, 7541, 7547, 7549, 7559, 7561, & + & 7573, 7577, 7583, 7589, 7591, 7603, 7607, 7621, 7639, 7643, & + & 7649, 7669, 7673, 7681, 7687, 7691, 7699, 7703, 7717, 7723, & + & 7727, 7741, 7753, 7757, 7759, 7789, 7793, 7817, 7823, 7829, & + & 7841, 7853, 7867, 7873, 7877, 7879, 7883, 7901, 7907, 7919 /) +!&> + if (n <= maxprimepar) then + prime = prime_numbers(n) + return + end if + c = maxprimepar + num = prime_numbers(maxprimepar) + do while (c < n) + num = num+1 + is_prime = .true. + do i = 2,int(sqrt(real(num))) + if (mod(num,i) == 0) then + is_prime = .false. + exit + end if + end do + if (is_prime) then + c = c+1 + end if + end do + prime = num + end function nth_prime !========================================================================================! !========================================================================================! From e002ecd61874d0e28543e6fb027e6bf80d9d3640 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 28 Sep 2024 03:53:37 +0200 Subject: [PATCH 023/374] More iRMSD based sorting functionalities --- src/algos/sorting.f90 | 22 ++++- src/classes.f90 | 1 + src/confparse.f90 | 4 + src/sorting/cregen.f90 | 194 ++++++++++++++++++++++++++++++++++++++++- 4 files changed, 216 insertions(+), 5 deletions(-) diff --git a/src/algos/sorting.f90 b/src/algos/sorting.f90 index 275ad032..63953035 100644 --- a/src/algos/sorting.f90 +++ b/src/algos/sorting.f90 @@ -41,16 +41,32 @@ subroutine crest_sort(env,tim) !========================================================================================! integer :: nall type(coord),allocatable :: structures(:) - + integer,allocatable :: groups(:) !========================================================================================! call tim%start(11,'Sorting') !========================================================================================! call rdensemble(env%ensemblename,nall,structures) - write(stdout,'(a,i0,a)') 'Read ensemble with ',nall,' structures' + allocate(groups(nall), source=0) + write(stdout,'(a,i0,a)') '> Read ensemble with ',nall,' structures' + write(stdout,*) + + select case(env%sortmode) + + case('isort') +!>--- Assigning structures to conformers based on RTHR + call underline('Assigning conformers based on iRMSD and RTHR') + call cregen_irmsd_sort(env,nall,structures,groups,allcanon=.true.,printlvl=2) - call cregen_irmsd_all(nall,structures,2) + case('all','allpair') +!>--- all unique pairs of the ensemble (only suitable for small ensembles) + call underline('Running all unique pair RMSDs incl. atom permutation') + call cregen_irmsd_all(nall,structures,2) + case default +!>--- all unique pairs of the ensemble (only suitable for small ensembles) + call cregen_irmsd_all(nall,structures,2) + end select !========================================================================================! call tim%stop(11) diff --git a/src/classes.f90 b/src/classes.f90 index 5a26e223..f3bb8961 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -384,6 +384,7 @@ module crest_data character(len=:),allocatable :: wbofile character(len=:),allocatable :: atlist character(len=:),allocatable :: chargesfilename + character(len=:),allocatable :: sortmode !>--- METADYN data real(wp) :: hmass diff --git a/src/confparse.f90 b/src/confparse.f90 index a3239e54..88be2765 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -757,6 +757,10 @@ subroutine parseflags(env,arg,nra) env%inputcoords = ctmp env%ensemblename = ctmp endif + if(nra >= i+3)then + ctmp = trim(arg(i+2)) + if(ctmp(1:1).ne.'-') env%sortmode=trim(ctmp) + endif case ('-SANDBOX') !>--- IMPLEMENT HERE WHATEVER YOU LIKE, FOR TESTING diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 71b37e4f..c0953171 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -59,6 +59,19 @@ subroutine cregen_irmsd_all(nall,structures,printlvl) integer,intent(in),optional :: printlvl end subroutine cregen_irmsd_all + subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) + use crest_data + use strucrd + implicit none + !> INPUT + type(systemdata),intent(inout) :: env + integer,intent(in) :: nall + type(coord),intent(inout),target :: structures(nall) + integer,intent(inout) :: groups(nall) + logical,intent(in),optional :: allcanon + integer,intent(in),optional :: printlvl + end subroutine cregen_irmsd_sort + end interface end module cregen_interface @@ -1104,7 +1117,7 @@ subroutine cregen_esort(ch,nat,nall,xyz,comments,nallout,ewin) order = orderref !call stringqsort(nall,comments,1,nall,order) - call stringqsort(nall,len(comments(1)),comments,1,nall,order) + call stringqsort(nall,len(comments(1)),comments,1,nall,order) !>-- determine cut-off of energies if (ewin < 9999.9_wp) then @@ -1688,6 +1701,181 @@ end subroutine cregen_irmsd_all !=========================================================================================! +subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) +!******************************************************* +!* Proof-of-concept routine to analyze an +!* ensemble only via the iRMSD procedure. +!* Conformers are identified by the rthr threshold only +!******************************************************* + use crest_parameters + use crest_data + use iomod, only: to_str + use strucrd + use axis_module + use canonical_mod + use irmsd_module + use utilities,only:lin + use omp_lib + implicit none + !> INPUT + type(systemdata),intent(inout) :: env + integer,intent(in) :: nall + type(coord),intent(inout),target :: structures(nall) + integer,intent(inout) :: groups(nall) + logical,intent(in),optional :: allcanon + integer,intent(in),optional :: printlvl + + !> LOCAL + integer :: i,j,ii,jj,T,Tn,nallpairs,cc,nat + integer :: gcount + integer :: prlvl,iunit + type(rmsd_cache),allocatable :: rcaches(:) + type(coord),allocatable,target :: workmols(:) + type(canonical_sorter),allocatable :: sorters(:) + real(wp),allocatable :: rmsds(:) + type(coord),pointer :: ref,mol + type(coord) :: molloc + real(wp) :: rmsdval,runtime,RTHR + logical :: stereocheck,individual_IDs + type(timer) :: profiler + + logical,parameter :: debug = .true. + +!>--- handle optional arguments + if (present(allcanon)) then + individual_IDs = allcanon + else + individual_IDs = .false. + end if + if (present(printlvl)) then + prlvl = printlvl + else + prlvl = 1 + end if + +!>--- set up parallelization + call new_ompautoset(env,'max',nall,T,Tn) + +!>--- set up parameters (note we are working with BOHR internally) + RTHR = env%rthr*aatoau + +!>--- print some sorting data + if (prlvl > 0)then + write(stdout,'(a)') 'CREGEN> Info for iRMSD sorting:' + write(stdout,'(2x,a,i9)') 'number of structures :',nall + write(stdout,'(2x,a,f9.5,a)') 'RTHR (RMSD threshold) :',RTHR*autoaa,' Å' + write(stdout,'(2x,a,i9)') 'OpenMP threads :',T + write(stdout,'(2x,a,a9)') 'Individual atom IDs? :',to_str(individual_IDs) + write(stdout,*) + endif + +!>--- Set up atom identities (either for all, or just the first structure) + if(individual_IDs)then + allocate (sorters(nall)) + else + allocate (sorters(1)) + endif + if (prlvl > 0) then + write (stdout,'(a)',advance='no') 'CREGEN> Setting up canonical atom ranks ... ' + flush (stdout) + end if + ref => structures(1) + do ii = 1,nall + mol => structures(ii) + call axis(mol%nat,mol%at,mol%xyz) + if(individual_IDs .or. ii == 1)then + call sorters(ii)%init(mol,invtype='apsp+',heavy=.false.) + endif + if (ii == 1) then + stereocheck = .not. (sorters(ii)%hasstereo(ref)) + end if + if(individual_IDs .or. ii == 1)then + call sorters(ii)%shrink() + endif + end do + if (prlvl > 0) then + write (stdout,'(a)') 'done.' + write (stdout,*) + end if + +!>--- allocate work cache + if (prlvl > 0) then + write (stdout,'(a)',advance='no') 'CREGEN> Allocating iRMSD work cache ... ' + flush (stdout) + end if + allocate (rcaches(T)) + ref => structures(1) + nat = ref%nat + allocate (workmols(T)) + do i = 1,T + mol => workmols(i) + allocate (mol%at(ref%nat)) + allocate (mol%xyz(3,ref%nat)) + nullify (mol) + call rcaches(i)%allocate(ref%nat) + rcaches(i)%stereocheck = stereocheck + end do + if (prlvl > 0) then + write (stdout,'(a)') 'done.' + write (stdout,*) + end if + +!>--- run the checks + if (prlvl > 0) then + write (stdout,'(a)',advance='no') 'CREGEN> Running all pair RMSDs ... ' + flush (stdout) + end if + + gcount = maxval(groups(:)) + do ii = 1,nall +!>--- find next unassigned conformer and assign a new group + if(groups(ii) .ne. 0) cycle + gcount = gcount + 1 + groups(ii) = gcount + +!>--- Then, cross-check all other unassigned conformers + !$omp parallel & + !$omp shared(nall, nat, groups, individual_IDs, sorters, rcaches) & + !$omp shared(workmols, structures, ii) & + !$omp private(jj,rmsdval,cc) + !$omp do schedule(static) + do jj = ii+1,nall + cc = omp_get_thread_num() + 1 + if(groups(jj) .ne. 0) cycle + if(individual_IDs)then + rcaches(cc)%rank(1:nat,1) = sorters(ii)%rank(1:nat) + rcaches(cc)%rank(1:nat,2) = sorters(jj)%rank(1:nat) + else + rcaches(cc)%rank(1:nat,1) = sorters(1)%rank(1:nat) + rcaches(cc)%rank(1:nat,2) = sorters(1)%rank(1:nat) + endif + workmols(cc)%nat = structures(jj)%nat + workmols(cc)%at(:) = structures(jj)%at(:) + workmols(cc)%xyz(:,:) = structures(jj)%xyz(:,:) + call min_rmsd(structures(ii),workmols(cc), & + & rcache=rcaches(cc),rmsdout=rmsdval) + if(rmsdval < RTHR) groups(jj) = gcount + end do + !$omp end do + !$omp end parallel + end do + if (prlvl > 0) then + write (stdout,'(a)') 'done.' + write (stdout,*) + end if + + if(debug)then + write(*,*) 'assigned groups, and count' + do ii=1,maxval(groups(:)) + write(*,*) ii,count(groups(:)==ii) + enddo + endif + + +end subroutine cregen_irmsd_sort + +!=========================================================================================! + subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) !**************************************************************** !* subroutine cregen_EQUAL @@ -2497,11 +2685,13 @@ end subroutine cregen_bonusfiles subroutine cregen_setthreads(ch,env,pr) use crest_parameters use crest_data + use omp_lib implicit none type(systemdata) :: env integer :: ch logical :: pr - integer :: TID,OMP_GET_NUM_THREADS,OMP_GET_THREAD_NUM,nproc,T,Tn + !integer :: TID,OMP_GET_NUM_THREADS,OMP_GET_THREAD_NUM, + integer :: TID,nproc,T,Tn !>---- setting the threads for OMP parallel usage if (env%autothreads) then call new_ompautoset(env,'max',0,T,Tn) From 36990a9fb5db3784f3e99090094d338b1bc15022 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 4 Oct 2024 10:48:56 +0200 Subject: [PATCH 024/374] Sorting procedure including invariant RMSD --- src/algos/sorting.f90 | 21 ++++++++-- src/confparse.f90 | 2 +- src/sorting/cregen.f90 | 88 ++++++++++++++++++++++++------------------ 3 files changed, 69 insertions(+), 42 deletions(-) diff --git a/src/algos/sorting.f90 b/src/algos/sorting.f90 index 63953035..918505a6 100644 --- a/src/algos/sorting.f90 +++ b/src/algos/sorting.f90 @@ -42,22 +42,35 @@ subroutine crest_sort(env,tim) integer :: nall type(coord),allocatable :: structures(:) integer,allocatable :: groups(:) + + !========================================================================================! - call tim%start(11,'Sorting') -!========================================================================================! + + write(stdout,'(a,a,a)',advance='no') '> Read ensemble ',trim(env%ensemblename),' ... ' + flush(stdout) call rdensemble(env%ensemblename,nall,structures) allocate(groups(nall), source=0) - write(stdout,'(a,i0,a)') '> Read ensemble with ',nall,' structures' + write(stdout,'(i0,a)') nall,' structures!' write(stdout,*) +!========================================================================================! + call tim%start(11,'Sorting') + select case(env%sortmode) case('isort') -!>--- Assigning structures to conformers based on RTHR +!>--- Assigning structures to conformers based on RTHR,with canonical atom IDs call underline('Assigning conformers based on iRMSD and RTHR') call cregen_irmsd_sort(env,nall,structures,groups,allcanon=.true.,printlvl=2) + + case('isort_noid') +!>--- Assigning structures to conformers based on RTHR, WITHOUT canonical atom IDs + call underline('Assigning conformers based on iRMSD and RTHR') + call cregen_irmsd_sort(env,nall,structures,groups,allcanon=.false.,printlvl=2) + + case('all','allpair') !>--- all unique pairs of the ensemble (only suitable for small ensembles) call underline('Running all unique pair RMSDs incl. atom permutation') diff --git a/src/confparse.f90 b/src/confparse.f90 index 88be2765..7f151baa 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -757,7 +757,7 @@ subroutine parseflags(env,arg,nra) env%inputcoords = ctmp env%ensemblename = ctmp endif - if(nra >= i+3)then + if(nra >= i+2)then ctmp = trim(arg(i+2)) if(ctmp(1:1).ne.'-') env%sortmode=trim(ctmp) endif diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index c0953171..c15fefe6 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -1709,7 +1709,7 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) !******************************************************* use crest_parameters use crest_data - use iomod, only: to_str + use iomod,only:to_str use strucrd use axis_module use canonical_mod @@ -1756,45 +1756,59 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) !>--- set up parallelization call new_ompautoset(env,'max',nall,T,Tn) +!>--- set up timer + call profiler%init(3) + !>--- set up parameters (note we are working with BOHR internally) - RTHR = env%rthr*aatoau + RTHR = env%rthr*aatoau !>--- print some sorting data - if (prlvl > 0)then - write(stdout,'(a)') 'CREGEN> Info for iRMSD sorting:' - write(stdout,'(2x,a,i9)') 'number of structures :',nall - write(stdout,'(2x,a,f9.5,a)') 'RTHR (RMSD threshold) :',RTHR*autoaa,' Å' - write(stdout,'(2x,a,i9)') 'OpenMP threads :',T - write(stdout,'(2x,a,a9)') 'Individual atom IDs? :',to_str(individual_IDs) - write(stdout,*) - endif + if (prlvl > 0) then + write (stdout,'(a)') 'CREGEN> Info for iRMSD sorting:' + write (stdout,'(2x,a,i9)') 'number of structures :',nall + write (stdout,'(2x,a,f9.5,a)') 'RTHR (RMSD threshold) :',RTHR*autoaa,' Å' + write (stdout,'(2x,a,i9)') 'OpenMP threads :',T + write (stdout,'(2x,a,a9)') 'Individual atom IDs? :',to_str(individual_IDs) + write (stdout,*) + end if !>--- Set up atom identities (either for all, or just the first structure) - if(individual_IDs)then + if (individual_IDs) then allocate (sorters(nall)) else allocate (sorters(1)) - endif + end if if (prlvl > 0) then write (stdout,'(a)',advance='no') 'CREGEN> Setting up canonical atom ranks ... ' flush (stdout) + call profiler%start(1) end if ref => structures(1) + !$omp parallel & + !$omp shared(sorters, structures, stereocheck) & + !$omp private(mol,ii) + !$omp do schedule(dynamic) do ii = 1,nall mol => structures(ii) call axis(mol%nat,mol%at,mol%xyz) - if(individual_IDs .or. ii == 1)then - call sorters(ii)%init(mol,invtype='apsp+',heavy=.false.) - endif + if (individual_IDs.or.ii == 1) then + call sorters(ii)%init(mol,invtype='apsp+',heavy=.false.) + end if if (ii == 1) then stereocheck = .not. (sorters(ii)%hasstereo(ref)) end if - if(individual_IDs .or. ii == 1)then - call sorters(ii)%shrink() - endif + if (individual_IDs.or.ii == 1) then + call sorters(ii)%shrink() + end if end do + !$omp end do + !$omp end parallel if (prlvl > 0) then - write (stdout,'(a)') 'done.' + call profiler%stop(1) + call profiler%write_timing(stdout,1,'done.',.true.) + runtime = (profiler%get(1)/real(nall,wp))*1000.0_wp + write (stdout,'(1x,a,f0.3,a)') '* Corresponding to approximately ',runtime, & + & ' ms per processed RMSD' write (stdout,*) end if @@ -1824,13 +1838,13 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) if (prlvl > 0) then write (stdout,'(a)',advance='no') 'CREGEN> Running all pair RMSDs ... ' flush (stdout) + call profiler%start(2) end if - gcount = maxval(groups(:)) do ii = 1,nall !>--- find next unassigned conformer and assign a new group - if(groups(ii) .ne. 0) cycle - gcount = gcount + 1 + if (groups(ii) .ne. 0) cycle + gcount = gcount+1 groups(ii) = gcount !>--- Then, cross-check all other unassigned conformers @@ -1838,39 +1852,39 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) !$omp shared(nall, nat, groups, individual_IDs, sorters, rcaches) & !$omp shared(workmols, structures, ii) & !$omp private(jj,rmsdval,cc) - !$omp do schedule(static) + !$omp do schedule(dynamic) do jj = ii+1,nall - cc = omp_get_thread_num() + 1 - if(groups(jj) .ne. 0) cycle - if(individual_IDs)then + cc = omp_get_thread_num()+1 + if (groups(jj) .ne. 0) cycle + if (individual_IDs) then rcaches(cc)%rank(1:nat,1) = sorters(ii)%rank(1:nat) rcaches(cc)%rank(1:nat,2) = sorters(jj)%rank(1:nat) else rcaches(cc)%rank(1:nat,1) = sorters(1)%rank(1:nat) rcaches(cc)%rank(1:nat,2) = sorters(1)%rank(1:nat) - endif + end if workmols(cc)%nat = structures(jj)%nat workmols(cc)%at(:) = structures(jj)%at(:) workmols(cc)%xyz(:,:) = structures(jj)%xyz(:,:) call min_rmsd(structures(ii),workmols(cc), & & rcache=rcaches(cc),rmsdout=rmsdval) - if(rmsdval < RTHR) groups(jj) = gcount + if (rmsdval < RTHR) groups(jj) = gcount end do !$omp end do !$omp end parallel end do if (prlvl > 0) then - write (stdout,'(a)') 'done.' - write (stdout,*) + call profiler%stop(2) + call profiler%write_timing(stdout,2,'done.',.true.) + write (stdout,*) end if - if(debug)then - write(*,*) 'assigned groups, and count' - do ii=1,maxval(groups(:)) - write(*,*) ii,count(groups(:)==ii) - enddo - endif - + if (debug) then + write (*,*) 'assigned groups, and count' + do ii = 1,maxval(groups(:)) + write (*,*) ii,count(groups(:) == ii) + end do + end if end subroutine cregen_irmsd_sort From 2b441756800cd5bde8da7f2837ecdfc9ed625008 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 30 Nov 2024 16:56:51 +0100 Subject: [PATCH 025/374] Start implementing stuff --- src/basinhopping/class.f90 | 104 ++++++++++++++++++++++++++++++++++ src/basinhopping/mc.f90 | 98 ++++++++++++++++++++++++++++++++ src/basinhopping/takestep.f90 | 73 ++++++++++++++++++++++++ 3 files changed, 275 insertions(+) create mode 100644 src/basinhopping/class.f90 create mode 100644 src/basinhopping/mc.f90 create mode 100644 src/basinhopping/takestep.f90 diff --git a/src/basinhopping/class.f90 b/src/basinhopping/class.f90 new file mode 100644 index 00000000..0d5496b1 --- /dev/null +++ b/src/basinhopping/class.f90 @@ -0,0 +1,104 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2024 Philipp Pracht, David Wales +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module bh_class_module + use crest_parameters + use strucrd,only:coord + implicit none + +!=========================================================================================! + + public :: bh_class + type :: bh_class +!************************************************************************ +!* data object that contains the data for a *SINGLE* basin-hopping chain +!************************************************************************ + +!>--- counters + integer :: iteration = 0 !> current iteration + integer :: saved = 0 !> number of saved quenches + +!>--- paramters + integer :: maxsteps = 100 !> maximum steps to take + real(wp) :: temp = 300.0_wp !> MC acceptance temperature + real(wp) :: scalefac = 1.0_wp !> temperature increase factor + integer :: steptype = 0 !> step type selection + real(wp) :: stepsize(3) = & !> step sizes e.g. for lengths, angles, dihedrals + & (/0.2_wp,0.2_wp,0.2_wp/) + integer :: maxsave = 100 !> maximum number of quenches saved + +!>--- results/properties + real(wp) :: emin = 0.0_wp !> current ref energy of markov chain + integer :: whichmin = 0 !> mapping to which structure emin refers + real(wp) :: emax = 0.0_wp !> highest energy structure among saved quenches + integer :: whichmax = 0 !> mapping of highest energy structure + type(coord),allocatable :: structures(:) !> list of structures from successfull quenches + +!>--- Type procedures + contains + procedure :: init => bh_class_allocate + procedure :: deallocate => bh_class_deallocate + end type bh_class + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + subroutine bh_class_allocate(self,temp,maxsteps,maxsave) + implicit none + class(bh_class) :: self + real(wp),intent(in),optional :: temp + integer,intent(in),optional :: maxsteps + integer,intent(in),optional :: maxsave + + call self%deallocate() + if (present(temp)) then + self%temp = temp + end if + if (present(maxsteps)) then + self%maxsteps = maxsteps + end if + if (present(maxsave)) then + self%maxsave = maxsave + end if + + self%iteration = 0 + self%saved = 0 + allocate (self%structures(self%maxsave)) + end subroutine bh_class_allocate + +!=========================================================================================! + + subroutine bh_class_deallocate(self) + implicit none + class(bh_class) :: self + if (allocated(self%structures)) deallocate (self%structures) + end subroutine bh_class_deallocate + +!=========================================================================================! + + + + +!=========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<. +!================================================================================! + +module bh_mc_module + use crest_parameters + use strucrd,only:coord + use crest_calculator + use bh_class_module + use bh_step_module + implicit none + private + + logical,parameter :: debug = .true. +! logical,parameter :: debug = .false. + + public :: mc + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + subroutine mc(calc,mol,bh) + implicit none + !> IN/OUTPUT + type(calcdata),intent(inout) :: calc !> potential settings + type(coord),intent(inout) :: mol !> molecular system + type(bh_class),intent(inout) :: bh !> BH settings + !> LOCAL + type(coord) :: tmpmol !> copy to take steps + integer :: iter + + do iter = 1,bh%maxsteps + +!>--- Take the step + call takestep(mol,bh,tmpmol) + +!>--- Quench it + + +!>--- Accept/reject + + +!>--- Update structures + + end do + + end subroutine mc + +!=========================================================================================! + + function mcaccept(mol,bh) result(accept) +!************************************** +!* The regular MC acceptance condition +!************************************** + implicit none + logical :: accept + type(coord),intent(in) :: mol + type(bh_calss),intent(in) :: bh + real(wp) :: eold,enew,temp + real(wp) :: random,fact + accept = .false. + eold = bh%emin + enew = mol%energy + temp = bh%temp*kB !> Kelvin to a.u. + + + if (enew .lt. eold) then + accept = .true. + else + call random_number(random) + fact = exp(-(enew-eold)/temp) + if (fact .gt. random) accept = .true. + end if + + end function mcaccept + +!=========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<. +!================================================================================! + +module bh_step_module + use crest_parameters + use strucrd,only:coord + use bh_class_module + implicit none + private + + logical,parameter :: debug = .true. +! logical,parameter :: debug = .false. + + public :: takestep + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + subroutine takestep(mol,bh,newmol) + implicit none + !> IN/OUTPUT + type(coord),intent(in) :: mol !> molecular system + type(bh_class),intent(inout) :: bh !> BH settings + type(coord),intent(out) :: newmol + !> LOCAL + + select case(bh%steptype) + case default !> Cartesian + newmol = mol + call takestep_cart(newmol, bh%stepsize(1)) + end select + + end subroutine takestep + +!=========================================================================================! + + subroutine takestep_cart(newmol,stepsize) + implicit none + type(coord),intent(inout) :: newmol + real(wp),intent(in) :: stepsize + real(wp) :: r(3) + integer :: i + + do i = 1,newmol%nat + call random_number(r) + r(:) = (r(:)-0.5_wp)*2.0_wp + newmol%xyz(:,i) = newmol%xyz(:,i)+r(:)*stepsize + end do + end subroutine takestep_cart + +!=========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Date: Sat, 30 Nov 2024 17:23:40 +0100 Subject: [PATCH 026/374] procedure work --- src/basinhopping/mc.f90 | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/src/basinhopping/mc.f90 b/src/basinhopping/mc.f90 index cd535458..8e899108 100644 --- a/src/basinhopping/mc.f90 +++ b/src/basinhopping/mc.f90 @@ -21,6 +21,7 @@ module bh_mc_module use crest_parameters use strucrd,only:coord use crest_calculator + use optimize_module use bh_class_module use bh_step_module implicit none @@ -45,15 +46,24 @@ subroutine mc(calc,mol,bh) type(bh_class),intent(inout) :: bh !> BH settings !> LOCAL type(coord) :: tmpmol !> copy to take steps - integer :: iter + type(coord) :: optmol !> quenched structure + integer :: iter,iostatus + real(wp) :: etot + real(wp),allocatable :: grd + + + allocate(grd(3,mol%nat), source=0.0_wp) - do iter = 1,bh%maxsteps + do iter = 1,bh%maxsteps + bh%iteration = iter + !>--- Take the step call takestep(mol,bh,tmpmol) !>--- Quench it - + call optimize_geometry(tmpmol,optmol,calc,etot,grd, & + & .false.,.false.,iostatus) !>--- Accept/reject @@ -62,6 +72,7 @@ subroutine mc(calc,mol,bh) end do + deallocate(grd) end subroutine mc !=========================================================================================! @@ -81,7 +92,6 @@ function mcaccept(mol,bh) result(accept) enew = mol%energy temp = bh%temp*kB !> Kelvin to a.u. - if (enew .lt. eold) then accept = .true. else From 493eed27ad2b33c896113e8f381c7123821374a6 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 1 Dec 2024 14:35:34 +0100 Subject: [PATCH 027/374] work on basin hopping --- src/basinhopping/CMakeLists.txt | 33 ++++++++++++++++++++++++++++++++ src/basinhopping/class.f90 | 34 ++++++++++++++++++++++++++++++--- src/basinhopping/mc.f90 | 32 +++++++++++++++++++++++++++++-- src/basinhopping/meson.build | 21 ++++++++++++++++++++ src/basinhopping/takestep.f90 | 13 +++++++++---- 5 files changed, 124 insertions(+), 9 deletions(-) create mode 100644 src/basinhopping/CMakeLists.txt create mode 100644 src/basinhopping/meson.build diff --git a/src/basinhopping/CMakeLists.txt b/src/basinhopping/CMakeLists.txt new file mode 100644 index 00000000..d0392fc4 --- /dev/null +++ b/src/basinhopping/CMakeLists.txt @@ -0,0 +1,33 @@ +# This file is part of crest. +# SPDX-Identifier: LGPL-3.0-or-later +# +# crest is free software: you can redistribute it and/or modify it under +# the terms of the GNU Lesser General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# crest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public License +# along with crest. If not, see . + +set(dir "${CMAKE_CURRENT_SOURCE_DIR}") + +list(APPEND srcs + "${dir}/class.f90" + "${dir}/mc.f90" + "${dir}/takestep.f90" +) + +set(srcs ${srcs} PARENT_SCOPE) + + + + + + + + diff --git a/src/basinhopping/class.f90 b/src/basinhopping/class.f90 index 0d5496b1..137b6e21 100644 --- a/src/basinhopping/class.f90 +++ b/src/basinhopping/class.f90 @@ -48,12 +48,13 @@ module bh_class_module integer :: whichmin = 0 !> mapping to which structure emin refers real(wp) :: emax = 0.0_wp !> highest energy structure among saved quenches integer :: whichmax = 0 !> mapping of highest energy structure - type(coord),allocatable :: structures(:) !> list of structures from successfull quenches + type(coord),allocatable :: structures(:) !> list of structures from succesfull quenches !>--- Type procedures contains procedure :: init => bh_class_allocate procedure :: deallocate => bh_class_deallocate + procedure :: add => bh_class_add end type bh_class !========================================================================================! @@ -95,8 +96,35 @@ end subroutine bh_class_deallocate !=========================================================================================! - - + subroutine bh_class_add(self,mol) + implicit none + class(bh_class) :: self + type(coord) :: mol + integer :: i,j + real(wp) :: mintmp,maxtmp + if(self%saved < self%maxsave)then + self%saved = self%saved + 1 + self%structures( self%saved ) = mol + else + i = self%%whichmax + self%structures( i ) = mol + endif + + mintmp = huge(mintmp) + maxtmp = -huge(maxtmp) + do i = 1,self%saved + if(structures(i)%energy < mintmp)then + mintmp = structures(i)%energy + self%whichmin = i + endif + if(structures(i)%energy > maxtmp)then + maxtmp = structures(i)%energy + self%whichmax = i + endif + enddo + self%emin = mintmp + self%emax = maxtmp + end subroutine bh_class_add !=========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Take the step - call takestep(mol,bh,tmpmol) + call takestep(mol,calc,bh,tmpmol) !>--- Quench it call optimize_geometry(tmpmol,optmol,calc,etot,grd, & & .false.,.false.,iostatus) !>--- Accept/reject + if(iostatus == 0)then !> successfull optimization + + if(debug)then + write(*,*) 'Final quench energy',etot + endif + accept = mcaccept(optmol,bh) + if( accept )then + + + !> check duplicates here + + else + if(debug) write(*,*) 'Quench does not fullfill MC criterion' + cycle + endif + else + if(debug) write(*,*) "Quench failed" + cycle + endif !>--- Update structures + mol = optmol + end do +!>--- Stats + + deallocate(grd) end subroutine mc diff --git a/src/basinhopping/meson.build b/src/basinhopping/meson.build new file mode 100644 index 00000000..30615d50 --- /dev/null +++ b/src/basinhopping/meson.build @@ -0,0 +1,21 @@ +# This file is part of crest. +# SPDX-Identifier: LGPL-3.0-or-later +# +# crest is free software: you can redistribute it and/or modify it under +# the terms of the GNU Lesser General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# crest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public License +# along with crest. If not, see . + +srcs += files( + 'class.f90', + 'mc.f90', + 'takestep.f90', +) diff --git a/src/basinhopping/takestep.f90 b/src/basinhopping/takestep.f90 index b064b9e9..6e360408 100644 --- a/src/basinhopping/takestep.f90 +++ b/src/basinhopping/takestep.f90 @@ -20,6 +20,7 @@ module bh_step_module use crest_parameters use strucrd,only:coord + use crest_calculator use bh_class_module implicit none private @@ -35,10 +36,11 @@ module bh_step_module !========================================================================================! !========================================================================================! - subroutine takestep(mol,bh,newmol) + subroutine takestep(mol,calc,bh,newmol) implicit none !> IN/OUTPUT type(coord),intent(in) :: mol !> molecular system + type(calcdata),intent(inout) :: calc type(bh_class),intent(inout) :: bh !> BH settings type(coord),intent(out) :: newmol !> LOCAL @@ -46,21 +48,24 @@ subroutine takestep(mol,bh,newmol) select case(bh%steptype) case default !> Cartesian newmol = mol - call takestep_cart(newmol, bh%stepsize(1)) + call takestep_cart(newmol, bh%stepsize(1), calc) end select end subroutine takestep !=========================================================================================! - subroutine takestep_cart(newmol,stepsize) + subroutine takestep_cart(newmol,stepsize,calc) implicit none type(coord),intent(inout) :: newmol real(wp),intent(in) :: stepsize + type(calcdata),intent(inout) :: calc real(wp) :: r(3) integer :: i - do i = 1,newmol%nat + if(allocated(calc%freezelist))then + if(any(calc%freezelist(:).eq.i)) cycle + endif call random_number(r) r(:) = (r(:)-0.5_wp)*2.0_wp newmol%xyz(:,i) = newmol%xyz(:,i)+r(:)*stepsize From 3302d2db7b570ff330f483dd0d58e84498f8e712 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 1 Dec 2024 21:19:54 +0100 Subject: [PATCH 028/374] First test implementation --- src/CMakeLists.txt | 1 + src/basinhopping/CMakeLists.txt | 2 + src/basinhopping/algo.f90 | 95 +++++++++++++++++++++++++++++++ src/basinhopping/basinhopping.f90 | 48 ++++++++++++++++ src/basinhopping/class.f90 | 10 ++-- src/basinhopping/mc.f90 | 37 +++++++----- src/basinhopping/meson.build | 2 + src/basinhopping/takestep.f90 | 4 +- src/classes.f90 | 2 + src/confparse.f90 | 4 ++ src/crest_main.f90 | 4 +- 11 files changed, 186 insertions(+), 23 deletions(-) create mode 100644 src/basinhopping/algo.f90 create mode 100644 src/basinhopping/basinhopping.f90 diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 5d22fce6..5d6a20d6 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -29,6 +29,7 @@ add_subdirectory("entropy") add_subdirectory("legacy_algos") add_subdirectory("msreact") add_subdirectory("sorting") +add_subdirectory("basinhopping") set(dir "${CMAKE_CURRENT_SOURCE_DIR}") diff --git a/src/basinhopping/CMakeLists.txt b/src/basinhopping/CMakeLists.txt index d0392fc4..6a29ef85 100644 --- a/src/basinhopping/CMakeLists.txt +++ b/src/basinhopping/CMakeLists.txt @@ -17,6 +17,8 @@ set(dir "${CMAKE_CURRENT_SOURCE_DIR}") list(APPEND srcs + "${dir}/algo.f90" + "${dir}/basinhopping.f90" "${dir}/class.f90" "${dir}/mc.f90" "${dir}/takestep.f90" diff --git a/src/basinhopping/algo.f90 b/src/basinhopping/algo.f90 new file mode 100644 index 00000000..6c04476e --- /dev/null +++ b/src/basinhopping/algo.f90 @@ -0,0 +1,95 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2022 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +subroutine crest_basinhopping(env,tim) + use crest_parameters + use crest_data + use crest_calculator + use strucrd + use bh_module + implicit none + type(systemdata),intent(inout) :: env + type(timer),intent(inout) :: tim + type(coord) :: mol,molnew + integer :: i,j,k,l,io,ich,T,Tn + logical :: pr,wr +!========================================================================================! + type(calcdata) :: calc + type(bh_class) :: bh + + real(wp) :: energy,gnorm + real(wp),allocatable :: grad(:,:) + + character(len=80) :: atmp + character(len=*),parameter :: trjf='crest_quenched.xyz' +!========================================================================================! + write(stdout,*) + !call system('figlet dynamics') + write(stdout,*) " ____ _ _ _ _ " + write(stdout,*) "| __ ) __ _ ___(_)_ __ | | | | ___ _ __ _ __ (_)_ __ __ _ " + write(stdout,*) "| _ \ / _` / __| | '_ \| |_| |/ _ \| '_ \| '_ \| | '_ \ / _` |" + write(stdout,*) "| |_) | (_| \__ \ | | | | _ | (_) | |_) | |_) | | | | | (_| |" + write(stdout,*) "|____/ \__,_|___/_|_| |_|_| |_|\___/| .__/| .__/|_|_| |_|\__, |" + write(stdout,*) " |_| |_| |___/ " + write(stdout,*) "" + call new_ompautoset(env,'max',0,T,Tn) + call ompprint_intern() + + calc = env%calc + call env%ref%to(mol) + write (stdout,*) + write (stdout,*) 'Input structure:' + call mol%append(stdout) + write (stdout,*) +!========================================================================================! + pr = .true. +!>--- print calculation info + call calc%info( stdout ) + +!>--- singlepoint of input structure + allocate(grad(3,mol%nat), source=0.0_wp) + call engrad(mol,calc,energy,grad,io) + mol%energy = energy !> we need this to start the Markov-chain + +!>--- actual basin hopping + call bh%init(300.0_wp,50,20) + bh%stepsize(1) = 1.0_wp + + call tim%start(14,'Basin-Hopping (BH)') + + call mc(calc,mol,bh) + + + open(newunit=ich,file=trjf) + do i=1,bh%saved + call bh%structures(i)%append(ich) + enddo + close(ich) + + if (io == 0) then + write (stdout,*) 'BH run completed successfully' + write (stdout,*) 'Successfull quenches written to ',trjf + else + write (stdout,*) 'WARNING: BH run terminated ABNORMALLY' + env%iostatus_meta = status_failed + end if +!========================================================================================! + call tim%stop(14) + return +end subroutine crest_basinhopping diff --git a/src/basinhopping/basinhopping.f90 b/src/basinhopping/basinhopping.f90 new file mode 100644 index 00000000..066ffba1 --- /dev/null +++ b/src/basinhopping/basinhopping.f90 @@ -0,0 +1,48 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2024 Philipp Pracht, David Wales +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module bh_module + use crest_parameters + use strucrd,only:coord + use crest_calculator + use optimize_module + use bh_class_module + use bh_step_module + use bh_mc_module + implicit none + private + + logical,parameter :: debug = .true. +! logical,parameter :: debug = .false. + +!>-- RE-EXPORTS + public :: mc + public :: bh_class + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + +!=========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< maxtmp)then - maxtmp = structures(i)%energy + if(self%structures(i)%energy > maxtmp)then + maxtmp = self%structures(i)%energy self%whichmax = i endif enddo diff --git a/src/basinhopping/mc.f90 b/src/basinhopping/mc.f90 index 778d00f8..28dfef64 100644 --- a/src/basinhopping/mc.f90 +++ b/src/basinhopping/mc.f90 @@ -50,22 +50,25 @@ subroutine mc(calc,mol,bh) type(coord) :: optmol !> quenched structure integer :: iter,iostatus real(wp) :: etot - real(wp),allocatable :: grd + real(wp),allocatable :: grd(:,:) logical :: accept - - - + +!>--- Add input energy to Markov chain + bh%emin = mol%energy allocate(grd(3,mol%nat), source=0.0_wp) - do iter = 1,bh%maxsteps + +!=======================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Take the step +!>--- Take the step (mol --> tmpmol) call takestep(mol,calc,bh,tmpmol) -!>--- Quench it +!>--- Quench it (tmpmol --> optmol) call optimize_geometry(tmpmol,optmol,calc,etot,grd, & & .false.,.false.,iostatus) @@ -73,29 +76,32 @@ subroutine mc(calc,mol,bh) if(iostatus == 0)then !> successfull optimization if(debug)then - write(*,*) 'Final quench energy',etot + write(*,*) 'Quench energy',etot + write(*,*) 'Markov chain energy',bh%emin endif accept = mcaccept(optmol,bh) if( accept )then - + if(debug) write(*,*) "accepted quench" !> check duplicates here else - if(debug) write(*,*) 'Quench does not fullfill MC criterion' - cycle + if(debug) write(*,*) 'Quench does not fulfill MC criterion' + cycle MonteCarlo endif else if(debug) write(*,*) "Quench failed" - cycle + cycle MonteCarlo endif !>--- Update structures mol = optmol + call bh%add(mol) - - end do + end do MonteCarlo +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Stats @@ -112,7 +118,7 @@ function mcaccept(mol,bh) result(accept) implicit none logical :: accept type(coord),intent(in) :: mol - type(bh_calss),intent(in) :: bh + type(bh_class),intent(in) :: bh real(wp) :: eold,enew,temp real(wp) :: random,fact accept = .false. @@ -130,6 +136,7 @@ function mcaccept(mol,bh) result(accept) end function mcaccept + !=========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<. srcs += files( + 'algo.90', + 'basinhopping.f90', 'class.f90', 'mc.f90', 'takestep.f90', diff --git a/src/basinhopping/takestep.f90 b/src/basinhopping/takestep.f90 index 6e360408..676c4e28 100644 --- a/src/basinhopping/takestep.f90 +++ b/src/basinhopping/takestep.f90 @@ -63,8 +63,8 @@ subroutine takestep_cart(newmol,stepsize,calc) real(wp) :: r(3) integer :: i do i = 1,newmol%nat - if(allocated(calc%freezelist))then - if(any(calc%freezelist(:).eq.i)) cycle + if(calc%nfreeze > 0)then + if(calc%freezelist(i)) cycle endif call random_number(r) r(:) = (r(:)-0.5_wp)*2.0_wp diff --git a/src/classes.f90 b/src/classes.f90 index 28d243b3..c59c47dc 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -86,6 +86,8 @@ module crest_data integer,parameter,public :: crest_rigcon = 271 integer,parameter,public :: crest_trialopt = 272 integer,parameter,public :: crest_ensemblesp = 273 + integer,parameter,public :: crest_bh = 274 + integer,parameter,public :: crest_bhpt = 275 !>> <--- IMPLEMENT HERE WHATEVER YOU LIKE, FOR TESTING diff --git a/src/crest_main.f90 b/src/crest_main.f90 index d424ff87..01db20ec 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -303,7 +303,9 @@ program CREST case(crest_sorting) !> interface to standalone ensemble sorting call crest_sort(env,tim) - + + case(crest_bh) !> Standard basin-hopping + call crest_basinhopping(env,tim) case (crest_test) call crest_playground(env,tim) From 254b1bd2209d7bbb6853624e0ddec10db4e4c295 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 6 Dec 2024 16:19:11 +0100 Subject: [PATCH 029/374] Setting changes for BH --- src/basinhopping/algo.f90 | 2 +- src/basinhopping/class.f90 | 6 ++++++ src/basinhopping/mc.f90 | 5 +++-- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/src/basinhopping/algo.f90 b/src/basinhopping/algo.f90 index 6c04476e..6d398f55 100644 --- a/src/basinhopping/algo.f90 +++ b/src/basinhopping/algo.f90 @@ -69,7 +69,7 @@ subroutine crest_basinhopping(env,tim) !>--- actual basin hopping call bh%init(300.0_wp,50,20) - bh%stepsize(1) = 1.0_wp + bh%stepsize(1) = 0.75_wp call tim%start(14,'Basin-Hopping (BH)') diff --git a/src/basinhopping/class.f90 b/src/basinhopping/class.f90 index 22c4cc2d..75391d70 100644 --- a/src/basinhopping/class.f90 +++ b/src/basinhopping/class.f90 @@ -50,6 +50,10 @@ module bh_class_module integer :: whichmax = 0 !> mapping of highest energy structure type(coord),allocatable :: structures(:) !> list of structures from succesfull quenches +!>--- temporary storage + integer,allocatable :: amat(:,:) !> adjacency matrix + real(wp),allocatable :: zmat(:,:) !> internal coordinates (to cache the memory) + !>--- Type procedures contains procedure :: init => bh_class_allocate @@ -92,6 +96,8 @@ subroutine bh_class_deallocate(self) implicit none class(bh_class) :: self if (allocated(self%structures)) deallocate (self%structures) + if ( allocated(self%amat)) deallocate(self%amat) + if (allocated(self%zmat)) deallocate(self%zmat) end subroutine bh_class_deallocate !=========================================================================================! diff --git a/src/basinhopping/mc.f90 b/src/basinhopping/mc.f90 index 28dfef64..50faecf1 100644 --- a/src/basinhopping/mc.f90 +++ b/src/basinhopping/mc.f90 @@ -22,6 +22,7 @@ module bh_mc_module use strucrd,only:coord use crest_calculator use optimize_module + use axis_module use bh_class_module use bh_step_module use omp_lib @@ -76,12 +77,12 @@ subroutine mc(calc,mol,bh) if(iostatus == 0)then !> successfull optimization if(debug)then - write(*,*) 'Quench energy',etot - write(*,*) 'Markov chain energy',bh%emin + write(*,*) 'Quench energy',etot,' Markov chain energy',bh%emin endif accept = mcaccept(optmol,bh) if( accept )then + call axis(optmol%nat,optmol%at,optmol%xyz) if(debug) write(*,*) "accepted quench" !> check duplicates here From f50a3cb3cd4dc4c0814456bb391f311a9ab80c52 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 13 Dec 2024 16:58:39 +0100 Subject: [PATCH 030/374] Work on BHGO, make nice printouts etc. --- src/algos/protonate.f90 | 12 +- src/algos/search_conformers.f90 | 2 +- src/basinhopping/algo.f90 | 45 ++++--- src/basinhopping/basinhopping.f90 | 1 - src/basinhopping/class.f90 | 47 +++++-- src/basinhopping/mc.f90 | 216 +++++++++++++++++++++++++----- src/basinhopping/takestep.f90 | 32 ++++- src/optimize/optimize_module.f90 | 27 +++- src/sorting/canonical.f90 | 20 +-- 9 files changed, 306 insertions(+), 96 deletions(-) diff --git a/src/algos/protonate.f90 b/src/algos/protonate.f90 index a058bddf..0edd80bf 100644 --- a/src/algos/protonate.f90 +++ b/src/algos/protonate.f90 @@ -211,7 +211,7 @@ subroutine crest_new_protonate(env,tim) !>--- Run optimizations call tim%start(15,'Ensemble optimization (FF)') - call print_opt_data(tmpcalc_ff,stdout) + call print_opt_data(tmpcalc_ff,stdout,natoms=natp) write (stdout,'(a,i0,a)') '> ',npnew,' structures to optimize ...' call crest_oloop(env,natp,npnew,atp,xyzp(:,:,1:npnew),ep(1:npnew),.false.,tmpcalc_ff) call tim%stop(15) @@ -301,7 +301,7 @@ subroutine crest_new_protonate(env,tim) call tmpcalc%info(stdout) tmpcalc%optnewinit = .true. call tim%start(20,'Ensemble optimization') - call print_opt_data(env%calc,stdout) + call print_opt_data(env%calc,stdout,natoms=natp) write (stdout,'(a,i0,a)') '> ',npnew,' structures to optimize ...' call crest_oloop(env,natp,npnew,atp,xyzp(:,:,1:npnew),ep,.false.,tmpcalc) call tim%stop(20) @@ -695,7 +695,7 @@ subroutine crest_new_deprotonate(env,tim) !>--- Run optimizations call tim%start(15,'Ensemble optimization (FF)') - call print_opt_data(tmpcalc_ff,stdout) + call print_opt_data(tmpcalc_ff,stdout,natoms=natp) write (stdout,'(a,i0,a)') '> ',npnew,' structures to optimize ...' call crest_oloop(env,natp,npnew,atp,xyzp(:,:,1:npnew),ep(1:npnew),.false.,tmpcalc_ff) call tim%stop(15) @@ -784,7 +784,7 @@ subroutine crest_new_deprotonate(env,tim) call tmpcalc%info(stdout) tmpcalc%optnewinit = .true. call tim%start(20,'Ensemble optimization') - call print_opt_data(env%calc,stdout) + call print_opt_data(env%calc,stdout,natoms=natp) write (stdout,'(a,i0,a)') '> ',npnew,' structures to optimize ...' call crest_oloop(env,natp,npnew,atp,xyzp(:,:,1:npnew),ep(1:npnew),.false.,tmpcalc) call tim%stop(20) @@ -1178,7 +1178,7 @@ subroutine crest_new_tautomerize(env,tim) !>--- Run optimizations call tim%start(15,'Ensemble optimization (FF)') - call print_opt_data(tmpcalc_ff,stdout) + call print_opt_data(tmpcalc_ff,stdout,natoms=natp) write (stdout,'(a,i0,a)') '> ',npnew,' structures to optimize ...' call crest_oloop(env,natp,npnew,atp,xyzp(:,:,1:npnew),ep(1:npnew),.false.,tmpcalc_ff) call tim%stop(15) @@ -1271,7 +1271,7 @@ subroutine crest_new_tautomerize(env,tim) call tmpcalc%info(stdout) tmpcalc%optnewinit = .true. call tim%start(20,'Ensemble optimization') - call print_opt_data(env%calc,stdout) + call print_opt_data(env%calc,stdout,natoms=natp) write (stdout,'(a,i0,a)') '> ',npnew,' structures to optimize ...' call crest_oloop(env,natp,npnew,atp,xyzp(:,:,1:npnew),ep,.false.,tmpcalc) call tim%stop(20) diff --git a/src/algos/search_conformers.f90 b/src/algos/search_conformers.f90 index a3c32ba2..9d5dea5e 100644 --- a/src/algos/search_conformers.f90 +++ b/src/algos/search_conformers.f90 @@ -480,7 +480,7 @@ subroutine set_multilevel_options(env,i,pr) env%calc%optlev = 0 end select - call print_opt_data(env%calc, stdout) + call print_opt_data(env%calc, stdout, natoms=env%ref%nat) end subroutine set_multilevel_options end subroutine crest_multilevel_oloop diff --git a/src/basinhopping/algo.f90 b/src/basinhopping/algo.f90 index 6d398f55..30e9e18b 100644 --- a/src/basinhopping/algo.f90 +++ b/src/basinhopping/algo.f90 @@ -1,7 +1,7 @@ !================================================================================! ! This file is part of crest. ! -! Copyright (C) 2022 Philipp Pracht +! Copyright (C) 2024 Philipp Pracht, David Wales ! ! crest is free software: you can redistribute it and/or modify it under ! the terms of the GNU Lesser General Public License as published by @@ -22,6 +22,7 @@ subroutine crest_basinhopping(env,tim) use crest_data use crest_calculator use strucrd + use optimize_module use bh_module implicit none type(systemdata),intent(inout) :: env @@ -37,33 +38,35 @@ subroutine crest_basinhopping(env,tim) real(wp),allocatable :: grad(:,:) character(len=80) :: atmp - character(len=*),parameter :: trjf='crest_quenched.xyz' + character(len=*),parameter :: trjf = 'crest_quenched.xyz' !========================================================================================! - write(stdout,*) + write (stdout,*) !call system('figlet dynamics') - write(stdout,*) " ____ _ _ _ _ " - write(stdout,*) "| __ ) __ _ ___(_)_ __ | | | | ___ _ __ _ __ (_)_ __ __ _ " - write(stdout,*) "| _ \ / _` / __| | '_ \| |_| |/ _ \| '_ \| '_ \| | '_ \ / _` |" - write(stdout,*) "| |_) | (_| \__ \ | | | | _ | (_) | |_) | |_) | | | | | (_| |" - write(stdout,*) "|____/ \__,_|___/_|_| |_|_| |_|\___/| .__/| .__/|_|_| |_|\__, |" - write(stdout,*) " |_| |_| |___/ " - write(stdout,*) "" + write (stdout,*) " ____ _ _ _ _ " + write (stdout,*) "| __ ) __ _ ___(_)_ __ | | | | ___ _ __ _ __ (_)_ __ __ _ " + write (stdout,*) "| _ \ / _` / __| | '_ \| |_| |/ _ \| '_ \| '_ \| | '_ \ / _` |" + write (stdout,*) "| |_) | (_| \__ \ | | | | _ | (_) | |_) | |_) | | | | | (_| |" + write (stdout,*) "|____/ \__,_|___/_|_| |_|_| |_|\___/| .__/| .__/|_|_| |_|\__, |" + write (stdout,*) " |_| |_| |___/ " + write (stdout,*) "" call new_ompautoset(env,'max',0,T,Tn) call ompprint_intern() - calc = env%calc + calc = env%calc call env%ref%to(mol) write (stdout,*) write (stdout,*) 'Input structure:' call mol%append(stdout) write (stdout,*) !========================================================================================! - pr = .true. !>--- print calculation info - call calc%info( stdout ) + call calc%info(stdout) + write (stdout,'(a)') '> Geometry optimization settings:' + call print_opt_data(calc,stdout,natoms=mol%nat,tag=' : ') + write (stdout,*) !>--- singlepoint of input structure - allocate(grad(3,mol%nat), source=0.0_wp) + allocate (grad(3,mol%nat),source=0.0_wp) call engrad(mol,calc,energy,grad,io) mol%energy = energy !> we need this to start the Markov-chain @@ -73,16 +76,16 @@ subroutine crest_basinhopping(env,tim) call tim%start(14,'Basin-Hopping (BH)') - call mc(calc,mol,bh) - + call mc(calc,mol,bh,verbosity=2) - open(newunit=ich,file=trjf) - do i=1,bh%saved - call bh%structures(i)%append(ich) - enddo - close(ich) + open (newunit=ich,file=trjf) + do i = 1,bh%saved + call bh%structures(i)%append(ich) + end do + close (ich) if (io == 0) then + write (stdout,*) write (stdout,*) 'BH run completed successfully' write (stdout,*) 'Successfull quenches written to ',trjf else diff --git a/src/basinhopping/basinhopping.f90 b/src/basinhopping/basinhopping.f90 index 066ffba1..ddbc62e3 100644 --- a/src/basinhopping/basinhopping.f90 +++ b/src/basinhopping/basinhopping.f90 @@ -41,7 +41,6 @@ module bh_module !========================================================================================! !========================================================================================! - !=========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Run/Thread ID !>--- counters integer :: iteration = 0 !> current iteration @@ -38,10 +41,13 @@ module bh_class_module integer :: maxsteps = 100 !> maximum steps to take real(wp) :: temp = 300.0_wp !> MC acceptance temperature real(wp) :: scalefac = 1.0_wp !> temperature increase factor + real(wp) :: rthr = 0.125_wp !> RMSD threshold (\AA) + real(wp) :: ethr = 0.05_wp !> minima/conformer energy distinction (kcal/mol) integer :: steptype = 0 !> step type selection real(wp) :: stepsize(3) = & !> step sizes e.g. for lengths, angles, dihedrals & (/0.2_wp,0.2_wp,0.2_wp/) integer :: maxsave = 100 !> maximum number of quenches saved + real(wp),allocatable :: etarget !> target energy to be hit (useful in benchmarks) !>--- results/properties real(wp) :: emin = 0.0_wp !> current ref energy of markov chain @@ -53,6 +59,9 @@ module bh_class_module !>--- temporary storage integer,allocatable :: amat(:,:) !> adjacency matrix real(wp),allocatable :: zmat(:,:) !> internal coordinates (to cache the memory) + type(rmsd_cache) :: rcache !> similarity check cache (iRMSD) + logical :: stereocheck !> check for false-rotamers? + type(canonical_sorter),allocatable :: sorters(:) !> canonical atom ID storage !>--- Type procedures contains @@ -84,10 +93,12 @@ subroutine bh_class_allocate(self,temp,maxsteps,maxsave) if (present(maxsave)) then self%maxsave = maxsave end if + self%maxsave = min(self%maxsave,self%maxsteps) self%iteration = 0 self%saved = 0 allocate (self%structures(self%maxsave)) + allocate (self%sorters(self%maxsave)) end subroutine bh_class_allocate !=========================================================================================! @@ -96,8 +107,9 @@ subroutine bh_class_deallocate(self) implicit none class(bh_class) :: self if (allocated(self%structures)) deallocate (self%structures) - if ( allocated(self%amat)) deallocate(self%amat) - if (allocated(self%zmat)) deallocate(self%zmat) + if (allocated(self%amat)) deallocate (self%amat) + if (allocated(self%zmat)) deallocate (self%zmat) + if (allocated(self%sorters)) deallocate (self%sorters) end subroutine bh_class_deallocate !=========================================================================================! @@ -108,26 +120,37 @@ subroutine bh_class_add(self,mol) type(coord) :: mol integer :: i,j real(wp) :: mintmp,maxtmp - if(self%saved < self%maxsave)then - self%saved = self%saved + 1 - self%structures( self%saved ) = mol + if (self%saved < self%maxsave) then + self%saved = self%saved+1 + i = self%saved + self%structures(i) = mol + !$omp critical + call self%sorters(i)%init(mol,invtype='apsp+',heavy=.false.) + if (i == 1) then + self%stereocheck = .not. (self%sorters(i)%hasstereo(mol)) + end if + !$omp end critical else i = self%whichmax - self%structures( i ) = mol - endif + self%structures(i) = mol + !$omp critical + call self%sorters(i)%deallocate() + call self%sorters(i)%init(mol,invtype='apsp+',heavy=.false.) + !$omp end critical + end if mintmp = huge(mintmp) maxtmp = -huge(maxtmp) do i = 1,self%saved - if(self%structures(i)%energy < mintmp)then + if (self%structures(i)%energy < mintmp) then mintmp = self%structures(i)%energy self%whichmin = i - endif - if(self%structures(i)%energy > maxtmp)then + end if + if (self%structures(i)%energy > maxtmp) then maxtmp = self%structures(i)%energy self%whichmax = i - endif - enddo + end if + end do self%emin = mintmp self%emax = maxtmp end subroutine bh_class_add diff --git a/src/basinhopping/mc.f90 b/src/basinhopping/mc.f90 index 50faecf1..db95e0f9 100644 --- a/src/basinhopping/mc.f90 +++ b/src/basinhopping/mc.f90 @@ -23,14 +23,17 @@ module bh_mc_module use crest_calculator use optimize_module use axis_module + use irmsd_module + use canonical_mod + use bh_class_module use bh_step_module - use omp_lib implicit none private logical,parameter :: debug = .true. ! logical,parameter :: debug = .false. +! character(len=*),parameter :: tag = 'BH> ' public :: mc @@ -40,32 +43,59 @@ module bh_mc_module !========================================================================================! !========================================================================================! - subroutine mc(calc,mol,bh) + subroutine mc(calc,mol,bh,verbosity) +!******************************************************************** +!* A thread-safe single basin-hopping MC run +!* Parameters and quenched structures are saved within the bh object +!******************************************************************** implicit none !> IN/OUTPUT type(calcdata),intent(inout) :: calc !> potential settings type(coord),intent(inout) :: mol !> molecular system type(bh_class),intent(inout) :: bh !> BH settings + integer,intent(in),optional :: verbosity !> printout parameter !> LOCAL type(coord) :: tmpmol !> copy to take steps type(coord) :: optmol !> quenched structure - integer :: iter,iostatus - real(wp) :: etot + integer :: iter,iostatus,accepted,discarded,broke + real(wp) :: etot,ratio real(wp),allocatable :: grd(:,:) - logical :: accept + logical :: accept,dupe,broken + integer :: printlvl + character(len=10) :: tag - -!>--- Add input energy to Markov chain - bh%emin = mol%energy + write(tag,'("BH[",i0,"]>")') bh%id + if (present(verbosity)) then + printlvl = verbosity + else + printlvl = 0 + end if - allocate(grd(3,mol%nat), source=0.0_wp) +!>--- Add input energy to Markov chain + bh%emin = mol%energy + call bh%add(mol) +!>--- print information about the run? + if (printlvl > 0) then + !$omp critical + call mcheader(bh) + !$omp end critical + end if + + !$omp critical + allocate (grd(3,mol%nat),source=0.0_wp) + !$omp end critical !=======================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Take the step (mol --> tmpmol) call takestep(mol,calc,bh,tmpmol) @@ -74,42 +104,133 @@ subroutine mc(calc,mol,bh) & .false.,.false.,iostatus) !>--- Accept/reject - if(iostatus == 0)then !> successfull optimization + if (iostatus == 0) then !> successfull optimization + + if (printlvl > 1) then + write (stdout,'(a,1x,a,es17.8,a,es17.8,a)') trim(tag),'Quench energy',etot, & + & ' Eh, Markov chain energy',bh%emin,' Eh' + end if + + accept = mcaccept(optmol,bh) + if (accept) then + accepted = accepted+1 - if(debug)then - write(*,*) 'Quench energy',etot,' Markov chain energy',bh%emin - endif + call axis(optmol%nat,optmol%at,optmol%xyz) - accept = mcaccept(optmol,bh) - if( accept )then - call axis(optmol%nat,optmol%at,optmol%xyz) + if (printlvl > 1)then + write (stdout,'(a)',advance='no') repeat(' ',len_trim(tag)+1)//"accepted quench" + endif - if(debug) write(*,*) "accepted quench" - !> check duplicates here + !> check duplicates here + call mcduplicate(mol,bh,dupe,broken) + if( broken )then + broke = broke + 1 + if (printlvl > 1) write (stdout,'(a)',advance='no') & + & ', but REJECTED due to topology mismatch!' + else if( dupe )then + discarded = discarded + 1 + if (printlvl > 1) write (stdout,'(a)',advance='no') & + & ', but NOT SAVED due to duplicate detection!' + endif + if(printlvl > 1) write(stdout,*) + else + if (printlvl > 1) write (stdout,'(a,a)') repeat(' ',len_trim(tag)+1), & + & 'Quench rejected, does not fulfill MC criterion' + cycle MonteCarlo + end if else - if(debug) write(*,*) 'Quench does not fulfill MC criterion' + if (printlvl > 1) write (stdout,'(a,1x,a)') trim(tag),"Quench failed" cycle MonteCarlo - endif - else - if(debug) write(*,*) "Quench failed" - cycle MonteCarlo - endif + end if !>--- Update structures - mol = optmol - call bh%add(mol) + if(.not.broken)then + !> continue Markov chain + mol = optmol + + if(.not.dupe)then + !> Save new unique structures + call bh%add(mol) + endif + endif end do MonteCarlo !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Stats + if (printlvl > 0) then + !$omp critical + call mcstats(bh,accepted,discarded,broke) + !$omp end critical + end if - - deallocate(grd) + deallocate (grd) end subroutine mc +!=========================================================================================! + + subroutine mcheader(bh) + implicit none + type(bh_class),intent(in) :: bh + + write (stdout,'(a)') '+'//repeat('-',63)//'+' + write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(a,3x)',advance='no') 'Starting Basin-Hopping Global Optimization' + write (stdout,'(a,i3,a)',advance='no') '[Thread/ID ',bh%id,']' + write (stdout,'(2x,"|")') + + write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(a,f20.10,a)',advance='no') 'Initial energy:',bh%emin,' Eh' + write (stdout,'(24x,"|")') + + write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(a,es9.3,3x)',advance='no') 'T/K: ',bh%temp + write (stdout,'(a,i5,3x)',advance='no') 'steps: ',bh%maxsteps + write (stdout,'(a,i5,3x)',advance='no') 'max save: ',bh%maxsave + write (stdout,'(12x,"|")') + + write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(a,a,2x)',advance='no') 'step type: ',steptypestr(bh%steptype) + write (stdout,'(a,3f9.5)',advance='no') 'step size:',bh%stepsize(1:3) + write (stdout,'(3x,"|")') + + write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(a,f9.5,a)',advance='no') 'Thresholds ΔRMSD:',bh%rthr,' Å, ' + write (stdout,'(a,es10.4,a)',advance='no') 'ΔE: ',bh%ethr,' kcal/mol' + write (stdout,'(6x,"|")') + write (stdout,'(a)') '+'//repeat('-',63)//'+' + end subroutine mcheader + + subroutine mcstats(bh,accepted,discarded,broke) + implicit none + type(bh_class),intent(in) :: bh + integer,intent(in) :: accepted,discarded,broke + real(wp) :: ratio + + write (stdout,'(a)') '+'//repeat('~',63)//'+' + write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(a,21x)',advance='no') 'Basin-Hopping Statistics' + write (stdout,'(a,i3,a)',advance='no') '[Thread/ID ',bh%id,']' + write (stdout,'(2x,"|")') + + write (stdout,'(a,1x)',advance='no') '|' + ratio = real(accepted,wp)/real(bh%maxsteps,wp) + write (stdout,'(a,f6.2,a)',advance='no') 'MC acceptance ratio ',ratio*100.0_wp,' %, ' + ratio = real(discarded,wp)/real(accepted,wp) + write (stdout,'(a,f6.2,a)',advance='no') 'similarity rejection ',ratio*100.0_wp,' %' + write (stdout,'(2x,"|")') + + write (stdout,'(a,1x)',advance='no') '|' + ratio = real(broke,wp)/real(accepted,wp) + write (stdout,'(a,f6.2,a)',advance='no') 'topology rejection ',ratio*100.0_wp,' %, ' + ratio = real(accepted-discarded-broke,wp)/real(bh%maxsteps,wp) + write (stdout,'(a,f6.2,a)',advance='no') 'TOTAL ACCEPT ratio ',ratio*100.0_wp,' %' + write (stdout,'(2x,"|")') + write (stdout,'(a)') '+'//repeat('~',63)//'+' + end subroutine mcstats + !=========================================================================================! function mcaccept(mol,bh) result(accept) @@ -137,6 +258,39 @@ function mcaccept(mol,bh) result(accept) end function mcaccept +!=========================================================================================! + + subroutine mcduplicate(mol,bh,dupe,broken) +!***************************************************** +!* Check if a new structure (mol) is already in the +!* list of saved structures (bh%structures) +!***************************************************** + implicit none + type(coord),intent(in) :: mol + type(bh_class),intent(inout) :: bh + real(wp) :: rthr,ethr + logical,intent(out) :: dupe,broken + !> LOCAL + integer :: i,j,k,l + type(canonical_sorter) :: newsort + + dupe = .false. + broken = .false. + ethr = bh%ethr + rthr = bh%rthr + + !$omp critical + call newsort%init(mol,invtype='apsp+',heavy=.false.) + !$omp end critical + + do i = 1,bh%saved + !> TODO + end do + + !$omp critical + call newsort%deallocate() + !$omp end critical + end subroutine mcduplicate !=========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Cartesian + str = 'Cartesian' + case (1) !> natural internals + str = 'internal ' + case (2) !> dihedral only + str = 'dihedral ' + case (3) !> intermolecular (CMA,tilt) only + str = 'intermol ' + end select + end function steptypestr + +!=========================================================================================! + subroutine takestep(mol,calc,bh,newmol) implicit none !> IN/OUTPUT type(coord),intent(in) :: mol !> molecular system - type(calcdata),intent(inout) :: calc + type(calcdata),intent(inout) :: calc type(bh_class),intent(inout) :: bh !> BH settings type(coord),intent(out) :: newmol !> LOCAL - select case(bh%steptype) + select case (bh%steptype) case default !> Cartesian newmol = mol - call takestep_cart(newmol, bh%stepsize(1), calc) + call takestep_cart(newmol,bh%stepsize(1),calc) end select end subroutine takestep @@ -63,9 +81,9 @@ subroutine takestep_cart(newmol,stepsize,calc) real(wp) :: r(3) integer :: i do i = 1,newmol%nat - if(calc%nfreeze > 0)then - if(calc%freezelist(i)) cycle - endif + if (calc%nfreeze > 0) then + if (calc%freezelist(i)) cycle + end if call random_number(r) r(:) = (r(:)-0.5_wp)*2.0_wp newmol%xyz(:,i) = newmol%xyz(:,i)+r(:)*stepsize diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index 42fbe67f..65322f5e 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -98,14 +98,27 @@ end subroutine optimize_geometry !========================================================================================! - subroutine print_opt_data(calc,ich) + subroutine print_opt_data(calc,ich,natoms,tag) implicit none type(calcdata) :: calc integer,intent(in) :: ich - integer :: tight + integer,intent(in),optional :: natoms + character(len=*),intent(in),optional :: tag + integer :: tight,nat real(wp) :: ethr,gthr + character(len=:),allocatable :: ttag + if(present(tag))then + ttag=tag + else + ttag=' ' + endif + if(present(natoms))then + nat=natoms + else + nat=0 + endif - write (ich,'(1x,a)',advance='no') 'Optimization engine: ' + write (ich,'(a,a)',advance='no') ttag,'Optimization engine: ' select case (calc%opt_engine) case ( 0) write (ich,'(a)') 'ANCOPT' @@ -119,7 +132,7 @@ subroutine print_opt_data(calc,ich) write(ich,'(a)') 'Unknown' end select if (calc%opt_engine >= 0) then - write (ich,'(1x,a)',advance='no') 'Hessian update type: ' + write (ich,'(a,a)',advance='no') ttag,'Hessian update type: ' select case (calc%iupdat) case (0) write (ich,'(a)') 'BFGS' @@ -135,11 +148,11 @@ subroutine print_opt_data(calc,ich) end if tight = calc%optlev - call get_optthr(0,tight,calc,ethr,gthr) - write (ich,'(1x,a,e10.3,a,e10.3,a)') 'E/G convergence criteria: ',& + call get_optthr(nat,tight,calc,ethr,gthr) + write (ich,'(a,a,e10.3,a,e10.3,a)') ttag,'E/G convergence criteria: ',& & ethr,' Eh,',gthr,' Eh/a0' - write (ich,'(1x,a,i0)') 'maximum optimization steps: ',calc%maxcycle + write (ich,'(a,a,i0)') ttag,'maximum optimization steps: ',calc%maxcycle end subroutine print_opt_data diff --git a/src/sorting/canonical.f90 b/src/sorting/canonical.f90 index 5ad4b260..3931c5b4 100644 --- a/src/sorting/canonical.f90 +++ b/src/sorting/canonical.f90 @@ -153,13 +153,13 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype,heavy) end do self%nat = nodes self%hatms = k - allocate (self%nmap(nodes)) - allocate (self%hmap(k)) - allocate (self%invariants(k),source=0_int64) - allocate (self%invariants0(k),source=0) - allocate (self%prime(k),source=2) - allocate (self%rank(k),source=1) - allocate (self%hadjac(k,k),source=0) + if (.not.allocated(self%nmap)) allocate (self%nmap(nodes)) + if (.not.allocated(self%hmap)) allocate (self%hmap(k)) + if (.not.allocated(self%invariants)) allocate (self%invariants(k),source=0_int64) + if (.not.allocated(self%invariants0)) allocate (self%invariants0(k),source=0) + if (.not.allocated(self%prime)) allocate (self%prime(k),source=2) + if (.not.allocated(self%rank)) allocate (self%rank(k),source=1) + if (.not.allocated(self%hadjac)) allocate (self%hadjac(k,k),source=0) !>--- determine number of subgraphs via CN call mol%cn_to_bond(cn,Bmat,'cov') @@ -180,7 +180,7 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype,heavy) end do if (debug) write (stdout,*) 'maximum number of neighbours',maxnei self%maxnei = maxnei - allocate (self%neigh(maxnei,mol%nat),source=0) + if (.not.allocated(self%neigh)) allocate (self%neigh(maxnei,mol%nat),source=0) !>--- fill rest of self k = 0 @@ -277,8 +277,8 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype,heavy) call debugprint(self,mol) end if !>--- start assignment - allocate (self%newrank(k),source=0) !> workspace - allocate (self%newinv(k),source=0_int64) !>workspace + if (.not.allocated(self%newrank)) allocate (self%newrank(k),source=0) !> workspace + if (.not.allocated(self%newinv)) allocate (self%newinv(k),source=0_int64) !>workspace call self%update_ranks() self%rank(:) = self%newrank(:) if (debug) then From 5114c966e80fcc202dd104e210c3f6cccce9e06e Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 20 Dec 2024 11:14:22 +0100 Subject: [PATCH 031/374] Printouts & cleanup for simple BH --- src/basinhopping/algo.f90 | 4 +- src/basinhopping/class.f90 | 9 ++-- src/basinhopping/mc.f90 | 90 ++++++++++++++++++++++++++------------ 3 files changed, 69 insertions(+), 34 deletions(-) diff --git a/src/basinhopping/algo.f90 b/src/basinhopping/algo.f90 index 30e9e18b..6d772265 100644 --- a/src/basinhopping/algo.f90 +++ b/src/basinhopping/algo.f90 @@ -71,8 +71,8 @@ subroutine crest_basinhopping(env,tim) mol%energy = energy !> we need this to start the Markov-chain !>--- actual basin hopping - call bh%init(300.0_wp,50,20) - bh%stepsize(1) = 0.75_wp + call bh%init(300.0_wp,200,20) + bh%stepsize(1) = 1.0_wp call tim%start(14,'Basin-Hopping (BH)') diff --git a/src/basinhopping/class.f90 b/src/basinhopping/class.f90 index 24108c9c..626b37bb 100644 --- a/src/basinhopping/class.f90 +++ b/src/basinhopping/class.f90 @@ -57,10 +57,10 @@ module bh_class_module type(coord),allocatable :: structures(:) !> list of structures from succesfull quenches !>--- temporary storage - integer,allocatable :: amat(:,:) !> adjacency matrix - real(wp),allocatable :: zmat(:,:) !> internal coordinates (to cache the memory) - type(rmsd_cache) :: rcache !> similarity check cache (iRMSD) - logical :: stereocheck !> check for false-rotamers? + integer,allocatable :: amat(:,:) !> adjacency matrix + real(wp),allocatable :: zmat(:,:) !> internal coordinates (to cache the memory) + type(rmsd_cache),allocatable :: rcache !> similarity check cache (iRMSD) + logical :: stereocheck !> check for false-rotamers? type(canonical_sorter),allocatable :: sorters(:) !> canonical atom ID storage !>--- Type procedures @@ -110,6 +110,7 @@ subroutine bh_class_deallocate(self) if (allocated(self%amat)) deallocate (self%amat) if (allocated(self%zmat)) deallocate (self%zmat) if (allocated(self%sorters)) deallocate (self%sorters) + if (allocated(self%rcache)) deallocate(self%rcache) end subroutine bh_class_deallocate !=========================================================================================! diff --git a/src/basinhopping/mc.f90 b/src/basinhopping/mc.f90 index db95e0f9..8af5cf41 100644 --- a/src/basinhopping/mc.f90 +++ b/src/basinhopping/mc.f90 @@ -25,15 +25,14 @@ module bh_mc_module use axis_module use irmsd_module use canonical_mod - + use quicksort_interface, only: ensemble_qsort use bh_class_module use bh_step_module implicit none private - logical,parameter :: debug = .true. -! logical,parameter :: debug = .false. -! character(len=*),parameter :: tag = 'BH> ' +! logical,parameter :: debug = .true. + logical,parameter :: debug = .false. public :: mc @@ -64,7 +63,7 @@ subroutine mc(calc,mol,bh,verbosity) integer :: printlvl character(len=10) :: tag - write(tag,'("BH[",i0,"]>")') bh%id + write (tag,'("BH[",i0,"]>")') bh%id if (present(verbosity)) then printlvl = verbosity @@ -107,8 +106,8 @@ subroutine mc(calc,mol,bh,verbosity) if (iostatus == 0) then !> successfull optimization if (printlvl > 1) then - write (stdout,'(a,1x,a,es17.8,a,es17.8,a)') trim(tag),'Quench energy',etot, & - & ' Eh, Markov chain energy',bh%emin,' Eh' + write (stdout,'(a,1x,a,es17.8,a,es17.8,a)') trim(tag),'Quench E=',etot, & + & ' Eh, Markov E=',bh%emin,' Eh' end if accept = mcaccept(optmol,bh) @@ -117,23 +116,23 @@ subroutine mc(calc,mol,bh,verbosity) call axis(optmol%nat,optmol%at,optmol%xyz) - if (printlvl > 1)then - write (stdout,'(a)',advance='no') repeat(' ',len_trim(tag)+1)//"accepted quench" - endif + if (printlvl > 1) then + write (stdout,'(a)',advance='no') repeat(' ',len_trim(tag)+1)//"accepted quench" + end if !> check duplicates here - call mcduplicate(mol,bh,dupe,broken) - if( broken )then - broke = broke + 1 - if (printlvl > 1) write (stdout,'(a)',advance='no') & + call mcduplicate(mol,bh,dupe,broken) + if (broken) then + broke = broke+1 + if (printlvl > 1) write (stdout,'(a)',advance='no') & & ', but REJECTED due to topology mismatch!' - else if( dupe )then - discarded = discarded + 1 - if (printlvl > 1) write (stdout,'(a)',advance='no') & + else if (dupe) then + discarded = discarded+1 + if (printlvl > 1) write (stdout,'(a)',advance='no') & & ', but NOT SAVED due to duplicate detection!' - endif + end if - if(printlvl > 1) write(stdout,*) + if (printlvl > 1) write (stdout,*) else if (printlvl > 1) write (stdout,'(a,a)') repeat(' ',len_trim(tag)+1), & & 'Quench rejected, does not fulfill MC criterion' @@ -145,20 +144,23 @@ subroutine mc(calc,mol,bh,verbosity) end if !>--- Update structures - if(.not.broken)then + if (.not.broken) then !> continue Markov chain mol = optmol - if(.not.dupe)then - !> Save new unique structures + if (.not.dupe) then + !> Save new unique structures call bh%add(mol) - endif - endif + end if + end if end do MonteCarlo !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Post-processing +! call ensemble_qsort(nall,structures,first,last) + !>--- Stats if (printlvl > 0) then !$omp critical @@ -271,25 +273,57 @@ subroutine mcduplicate(mol,bh,dupe,broken) real(wp) :: rthr,ethr logical,intent(out) :: dupe,broken !> LOCAL - integer :: i,j,k,l + integer :: i,j,k,l,nat type(canonical_sorter) :: newsort + real(wp) :: rmsdval,deltaE dupe = .false. broken = .false. ethr = bh%ethr rthr = bh%rthr + nat = mol%nat + + if (debug) write (*,*) + + if (.not.allocated(bh%rcache)) then + if (debug) write (*,*) "allocating RCACHE" + !$omp critical + allocate (bh%rcache) + call bh%rcache%allocate(nat) + !$omp end critical + end if !$omp critical call newsort%init(mol,invtype='apsp+',heavy=.false.) !$omp end critical - do i = 1,bh%saved + COMPARE: do i = 1,bh%saved + !> TODO - end do + deltaE = (mol%energy-bh%structures(i)%energy)*autokcal + + bh%rcache%rank(1:nat,1) = newsort%rank(1:nat) + bh%rcache%rank(1:nat,2) = bh%sorters(i)%rank(1:nat) + + call min_rmsd(mol,bh%structures(i), & + & rcache=bh%rcache,rmsdout=rmsdval) + + if (debug) write (*,'(a,es15.4,a,es15.4,a)') 'RMSD=',rmsdval*autoaa, & + & ' Å, delta E=',deltaE,' kcal/mol' + + if (abs(deltaE) .lt. ethr.and.rmsdval*autoaa .lt. rthr) then + dupe = .true. + if (deltaE < 0.0_wp) then + !> if the energy is lower, we replace the molecule (better conformation) + bh%structures(i) = mol + end if + exit COMPARE + end if + end do COMPARE !$omp critical call newsort%deallocate() - !$omp end critical + !$omp end critical end subroutine mcduplicate !=========================================================================================! From 849e445fb203a2763bf7f0128c13666599fc9fa7 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 16 Jan 2025 13:01:29 +0100 Subject: [PATCH 032/374] basin hopping class structure and printouts --- src/basinhopping/class.f90 | 6 +++++- src/basinhopping/mc.f90 | 15 +++++++++++---- 2 files changed, 16 insertions(+), 5 deletions(-) diff --git a/src/basinhopping/class.f90 b/src/basinhopping/class.f90 index 626b37bb..5e55a5b7 100644 --- a/src/basinhopping/class.f90 +++ b/src/basinhopping/class.f90 @@ -60,8 +60,10 @@ module bh_class_module integer,allocatable :: amat(:,:) !> adjacency matrix real(wp),allocatable :: zmat(:,:) !> internal coordinates (to cache the memory) type(rmsd_cache),allocatable :: rcache !> similarity check cache (iRMSD) - logical :: stereocheck !> check for false-rotamers? + logical :: stereocheck = .false. !> check for false-rotamers? type(canonical_sorter),allocatable :: sorters(:) !> canonical atom ID storage + logical :: topocheck = .true. !> check for correct connectivity + type(canonical_sorter),allocatable :: refsort !> use same reference connectivity for all !>--- Type procedures contains @@ -111,6 +113,7 @@ subroutine bh_class_deallocate(self) if (allocated(self%zmat)) deallocate (self%zmat) if (allocated(self%sorters)) deallocate (self%sorters) if (allocated(self%rcache)) deallocate(self%rcache) + if (allocated(self%refsort)) deallocate(self%refsort) end subroutine bh_class_deallocate !=========================================================================================! @@ -137,6 +140,7 @@ subroutine bh_class_add(self,mol) !$omp critical call self%sorters(i)%deallocate() call self%sorters(i)%init(mol,invtype='apsp+',heavy=.false.) + call self%sorters(i)%shrink() !$omp end critical end if diff --git a/src/basinhopping/mc.f90 b/src/basinhopping/mc.f90 index 8af5cf41..53f3d9cc 100644 --- a/src/basinhopping/mc.f90 +++ b/src/basinhopping/mc.f90 @@ -60,7 +60,7 @@ subroutine mc(calc,mol,bh,verbosity) real(wp) :: etot,ratio real(wp),allocatable :: grd(:,:) logical :: accept,dupe,broken - integer :: printlvl + integer :: printlvl,first,last character(len=10) :: tag write (tag,'("BH[",i0,"]>")') bh%id @@ -159,7 +159,9 @@ subroutine mc(calc,mol,bh,verbosity) !=======================================================================================! !>--- Post-processing -! call ensemble_qsort(nall,structures,first,last) + first=1 + last=bh%saved + call ensemble_qsort(bh%maxsave,bh%structures,first,last) !>--- Stats if (printlvl > 0) then @@ -276,12 +278,14 @@ subroutine mcduplicate(mol,bh,dupe,broken) integer :: i,j,k,l,nat type(canonical_sorter) :: newsort real(wp) :: rmsdval,deltaE + logical :: topocheck dupe = .false. broken = .false. ethr = bh%ethr rthr = bh%rthr nat = mol%nat + topocheck = .true. if (debug) write (*,*) @@ -295,6 +299,7 @@ subroutine mcduplicate(mol,bh,dupe,broken) !$omp critical call newsort%init(mol,invtype='apsp+',heavy=.false.) + !call newsort%stereo(mol) !$omp end critical COMPARE: do i = 1,bh%saved @@ -302,8 +307,10 @@ subroutine mcduplicate(mol,bh,dupe,broken) !> TODO deltaE = (mol%energy-bh%structures(i)%energy)*autokcal - bh%rcache%rank(1:nat,1) = newsort%rank(1:nat) - bh%rcache%rank(1:nat,2) = bh%sorters(i)%rank(1:nat) + if(topocheck)then + bh%rcache%rank(1:nat,1) = newsort%rank(1:nat) + bh%rcache%rank(1:nat,2) = bh%sorters(i)%rank(1:nat) + endif call min_rmsd(mol,bh%structures(i), & & rcache=bh%rcache,rmsdout=rmsdval) From 7ff01fd889ad075efafe05f3734a9da2b656e49a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 17 Jan 2025 15:03:50 +0100 Subject: [PATCH 033/374] Prepare toml parser for basin-hopping data block --- src/parsing/confparse2.f90 | 43 ++++++----- src/parsing/parse_calcdata.f90 | 126 ++++++++++++++++++++++++++++++++- src/parsing/parse_maindata.f90 | 2 + 3 files changed, 152 insertions(+), 19 deletions(-) diff --git a/src/parsing/confparse2.f90 b/src/parsing/confparse2.f90 index 9eb8a4e7..1a0d7c70 100644 --- a/src/parsing/confparse2.f90 +++ b/src/parsing/confparse2.f90 @@ -42,6 +42,7 @@ subroutine parseinputfile(env,fname) use crest_data use crest_calculator,only:calcdata use dynamics_module,only:mddata + use bh_module,only:bh_class !> modules used for parsing the root_object use parse_keyvalue,only:keyvalue @@ -50,7 +51,7 @@ subroutine parseinputfile(env,fname) use parse_maindata use parse_inputfile,only:parse_input use parse_calcdata,only:parse_calculation_data, & - & parse_dynamics_data + & parse_dynamics_data,parse_basinhopping_data !> Declarations implicit none type(systemdata),intent(inout) :: env @@ -60,6 +61,7 @@ subroutine parseinputfile(env,fname) type(datablock) :: blk type(calcdata) :: newcalc type(mddata) :: mddat + type(bh_class) :: bh logical :: ex,l1,l2 integer :: i,j,k,l integer :: readstatus @@ -78,7 +80,7 @@ subroutine parseinputfile(env,fname) call dict%print2() !>--- sanity check for input files - readstatus = 0 !> has to remain 0, or something went wrong + readstatus = 0 !> has to remain 0, or something went wrong !>--- parse all root-level key-value pairs do i = 1,dict%nkv @@ -112,11 +114,17 @@ subroutine parseinputfile(env,fname) call env_mddat_specialcases(env) end if +!>--- check for any basinhopping/MC setup + call parse_basinhopping_data(env,bh,dict,l1,readstatus) + if (l1) then + ! env%bh_ref = bh + end if + !>--- terminate if there were any unrecognized keywords - if(readstatus /= 0)then - write(stdout, '(i0,a)') readstatus,' error(s) while reading input file' + if (readstatus /= 0) then + write (stdout,'(i0,a)') readstatus,' error(s) while reading input file' call creststop(status_config) - endif + end if !>--- check for lwONIOM setup (will be read at end of confparse) do i = 1,dict%nblk @@ -193,8 +201,7 @@ subroutine env_calcdat_specialcases(env) integer :: refine_lvl !> if this return is triggered, the program will fall back to GFN2 at some point - if(env%calc%ncalculations .lt. 1) return - + if (env%calc%ncalculations .lt. 1) return !> special case for GFN-FF calculations if (any(env%calc%calcs(:)%id == jobtype%gfnff)) then @@ -209,9 +216,9 @@ subroutine env_calcdat_specialcases(env) do i = 1,env%calc%ncalculations refine_lvl = env%calc%calcs(i)%refine_lvl if (refine_lvl <= 0) cycle - if(allocated(env%refine_queue))then + if (allocated(env%refine_queue)) then if (any(env%refine_queue(:) == refine_lvl)) cycle - endif + end if call env%addrefine(refine_lvl) end do end if @@ -235,15 +242,15 @@ subroutine env_mddat_specialcases(env) integer :: nac,ii,iac !>--- Check for MD-active only levels - if(allocated(env%mddat%active_potentials))then + if (allocated(env%mddat%active_potentials)) then nac = size(env%mddat%active_potentials) - do ii=1,nac - !>--- deactivate by default (the MD routine will set them to active automatically) - iac = env%mddat%active_potentials(ii) - if(iac <= env%calc%ncalculations)then - env%calc%calcs(iac)%active = .false. - endif - enddo - endif + do ii = 1,nac + !>--- deactivate by default (the MD routine will set them to active automatically) + iac = env%mddat%active_potentials(ii) + if (iac <= env%calc%ncalculations) then + env%calc%calcs(iac)%active = .false. + end if + end do + end if end subroutine env_mddat_specialcases diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 3597568a..d09be3af 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -28,6 +28,7 @@ module parse_calcdata use crest_data use crest_calculator,only:calcdata,calculation_settings,jobtype,constraint,scantype use dynamics_module + use bh_module use gradreader_module,only:gradtype,conv2gradfmt use tblite_api,only:xtblvl use strucrd,only:get_atlist,coord @@ -62,6 +63,7 @@ module parse_calcdata public :: parse_calculation_data public :: parse_dynamics_data + public :: parse_basinhopping_data character(len=*),parameter,private :: fmturk = '("unrecognized KEYWORD in ",a," : ",a)' character(len=*),parameter,private :: fmtura = '("unrecognized ARGUMENT : ",a)' @@ -801,7 +803,7 @@ subroutine parse_constraint_auto(env,calc,constr,kv,success,rd) dum4 = kv%value_fa(6) call constr%bondrangeconstraint(atm1,atm2,dum1,dum2,beta=dum3,T=dum4) case default - write(stdout,'(a)') '**ERROR** wrong number of arguments in bondrange constraint' + write (stdout,'(a)') '**ERROR** wrong number of arguments in bondrange constraint' call creststop(status_config) end select success = .true. @@ -1132,6 +1134,128 @@ subroutine parse_metadyn_auto(mtd,kv,success,rd) end subroutine parse_metadyn_auto +!========================================================================================! + + subroutine parse_basinhopping_data(env,bh,dict,included,istat) +!********************************************* +!* The following routines are used to +!* read information into the "mddata" object +!********************************************* + implicit none + type(systemdata) :: env + type(bh_class) :: bh + type(root_object) :: dict + type(datablock) :: blk + type(calculation_settings) :: newjob + type(constraint) :: newcstr + integer :: i,j,k,l + logical,intent(out) :: included + integer,intent(inout) :: istat + + included = .false. + + do i = 1,dict%nblk + call blk%deallocate() + blk = dict%blk_list(i) + if (blk%header == 'basinhopping') then + included = .true. + call parse_bh_class(env,blk,bh,istat) + end if + end do + return + end subroutine parse_basinhopping_data + subroutine parse_bh_class(env,blk,bh,istat) + implicit none + type(systemdata),intent(inout) :: env + type(datablock),intent(in) :: blk + type(bh_class),intent(inout) :: bh + integer,intent(inout) :: istat + integer :: i,j,nat + logical :: rd + if (blk%header .ne. 'basinhopping') return + + do i = 1,blk%nkv + call parse_bh_auto(env,bh,blk%kv_list(i),rd) + if (.not.rd) then + istat = istat+1 + write (stdout,fmturk) '['//blk%header//']-block',blk%kv_list(i)%key + end if + end do + return + end subroutine parse_bh_class + subroutine parse_bh_auto(env,bh,kv,rd) + implicit none + type(systemdata),intent(inout) :: env + type(bh_class) :: bh + type(keyvalue) :: kv + logical,intent(out) :: rd + logical,allocatable :: atlist(:) + integer :: nat,j + logical :: ex + rd = .true. + + select case (kv%key) +! case ('active','active_levels') +! mddat%active_potentials = kv%value_ia +! +! case ('includermsd','atlist+') +! call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) +! if (.not.allocated(env%includeRMSD)) allocate (env%includeRMSD(nat),source=1) +! do j = 1,nat +! if (atlist(j)) env%includeRMSD(j) = 1 +! end do +! +! case ('excludermsd','atlist-') +! call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) +! if (.not.allocated(env%includeRMSD)) allocate (env%includeRMSD(nat),source=1) +! do j = 1,nat +! if (atlist(j)) env%includeRMSD(j) = 0 +! end do +! +! case ('length','length_ps') +! mddat%length_ps = kv%value_f +! case ('dump') +! mddat%dumpstep = kv%value_f +! case ('hmass') +! mddat%md_hmass = kv%value_f +! case ('tstep') +! mddat%tstep = kv%value_f +! case ('t','temp','temperature') +! mddat%tsoll = kv%value_f +! mddat%thermostat = .true. +! +! case ('shake') +! select case (kv%id) +! case (valuetypes%int) +! if (kv%value_i <= 0) then +! mddat%shake = .false. +! else +! mddat%shake = .true. +! mddat%shk%shake_mode = min(kv%value_i,2) +! end if +! case (valuetypes%bool) +! mddat%shake = kv%value_b +! if (kv%value_b) mddat%shk%shake_mode = 1 +! end select +! case ('printstep') +! mddat%printstep = kv%value_i +! case ('blocklength','blockl') +! mddat%blockl = kv%value_i +! +! case ('restart') +! inquire (file=trim(kv%value_c),exist=ex) +! if (ex) then +! mddat%restart = .true. +! mddat%restartfile = trim(kv%value_c) +! end if + + case default + rd = .false. + return + end select + + end subroutine parse_bh_auto + !========================================================================================! !========================================================================================! end module parse_calcdata diff --git a/src/parsing/parse_maindata.f90 b/src/parsing/parse_maindata.f90 index 33fa9734..e4afe2aa 100644 --- a/src/parsing/parse_maindata.f90 +++ b/src/parsing/parse_maindata.f90 @@ -185,6 +185,8 @@ subroutine parse_main_c(env,key,val,rd) env%autozsort = .false. env%performCross = .false. env%rotamermds = .false. + case ('bh','gmin') + env%crestver = crest_bh case ('entropy','imtd-smtd') env%crestver = crest_imtd !> the entropy mode acts as subtype of the crest_imtd algo env%properties = abs(p_CREentropy) From 47701c2758aa2f336485915923d46933747c790a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 19 Jan 2025 16:35:59 +0100 Subject: [PATCH 034/374] Implement BH toml keywords and RNG seeding --- src/basinhopping/algo.f90 | 10 +++- src/basinhopping/class.f90 | 17 +++++- src/basinhopping/mc.f90 | 66 +++++++++++++++++---- src/basinhopping/takestep.f90 | 4 +- src/classes.f90 | 2 + src/parsing/confparse2.f90 | 2 +- src/parsing/parse_calcdata.f90 | 103 +++++++++++++++------------------ 7 files changed, 128 insertions(+), 76 deletions(-) diff --git a/src/basinhopping/algo.f90 b/src/basinhopping/algo.f90 index 6d772265..7edbd76e 100644 --- a/src/basinhopping/algo.f90 +++ b/src/basinhopping/algo.f90 @@ -71,13 +71,19 @@ subroutine crest_basinhopping(env,tim) mol%energy = energy !> we need this to start the Markov-chain !>--- actual basin hopping - call bh%init(300.0_wp,200,20) - bh%stepsize(1) = 1.0_wp + if(allocated(env%bh_ref))then + bh = env%bh_ref + call bh%init() + else + call bh%init(300.0_wp,200,20) + bh%stepsize(1) = 1.0_wp + endif call tim%start(14,'Basin-Hopping (BH)') call mc(calc,mol,bh,verbosity=2) +!>--- dump saved minima open (newunit=ich,file=trjf) do i = 1,bh%saved call bh%structures(i)%append(ich) diff --git a/src/basinhopping/class.f90 b/src/basinhopping/class.f90 index 5e55a5b7..d0f0ae14 100644 --- a/src/basinhopping/class.f90 +++ b/src/basinhopping/class.f90 @@ -31,7 +31,8 @@ module bh_class_module !************************************************************************ !* data object that contains the data for a *SINGLE* basin-hopping chain !************************************************************************ - integer :: id = 0 !> Run/Thread ID + integer :: id = 0 !> Run/Thread ID + integer,allocatable :: seed !> RNG seed, only used when allocated !>--- counters integer :: iteration = 0 !> current iteration @@ -84,6 +85,7 @@ subroutine bh_class_allocate(self,temp,maxsteps,maxsave) real(wp),intent(in),optional :: temp integer,intent(in),optional :: maxsteps integer,intent(in),optional :: maxsave + real(wp) :: rand call self%deallocate() if (present(temp)) then @@ -101,6 +103,15 @@ subroutine bh_class_allocate(self,temp,maxsteps,maxsave) self%saved = 0 allocate (self%structures(self%maxsave)) allocate (self%sorters(self%maxsave)) + +!>--- generate a random seed, if the object doesn't have one already + if (.not.allocated(self%seed)) then + !> Generate a real in [0,1) + call random_number(rand) + !> Scale and shift to produce an integer in [1,10mil] + allocate (self%seed) + self%seed = int(rand*100000000.0)+1 + end if end subroutine bh_class_allocate !=========================================================================================! @@ -112,8 +123,8 @@ subroutine bh_class_deallocate(self) if (allocated(self%amat)) deallocate (self%amat) if (allocated(self%zmat)) deallocate (self%zmat) if (allocated(self%sorters)) deallocate (self%sorters) - if (allocated(self%rcache)) deallocate(self%rcache) - if (allocated(self%refsort)) deallocate(self%refsort) + if (allocated(self%rcache)) deallocate (self%rcache) + if (allocated(self%refsort)) deallocate (self%refsort) end subroutine bh_class_deallocate !=========================================================================================! diff --git a/src/basinhopping/mc.f90 b/src/basinhopping/mc.f90 index 53f3d9cc..5b7f20ef 100644 --- a/src/basinhopping/mc.f90 +++ b/src/basinhopping/mc.f90 @@ -25,7 +25,7 @@ module bh_mc_module use axis_module use irmsd_module use canonical_mod - use quicksort_interface, only: ensemble_qsort + use quicksort_interface,only:ensemble_qsort use bh_class_module use bh_step_module implicit none @@ -82,6 +82,15 @@ subroutine mc(calc,mol,bh,verbosity) !$omp end critical end if +!>--- seed the RNG? + if (allocated(bh%seed)) then + if (printlvl > 1) then + write (stdout,'(a,1x,a,i0)') trim(tag), & + & 'Seeding current RNG instance with: ',bh%seed + end if + call RNG_seed(bh%seed) + end if + !$omp critical allocate (grd(3,mol%nat),source=0.0_wp) !$omp end critical @@ -132,14 +141,14 @@ subroutine mc(calc,mol,bh,verbosity) & ', but NOT SAVED due to duplicate detection!' end if - if (printlvl > 1) write (stdout,*) + if (printlvl > 1) write (stdout,'(/)') else - if (printlvl > 1) write (stdout,'(a,a)') repeat(' ',len_trim(tag)+1), & + if (printlvl > 1) write (stdout,'(a,a,/)') repeat(' ',len_trim(tag)+1), & & 'Quench rejected, does not fulfill MC criterion' cycle MonteCarlo end if else - if (printlvl > 1) write (stdout,'(a,1x,a)') trim(tag),"Quench failed" + if (printlvl > 1) write (stdout,'(a,1x,a,/)') trim(tag),"Quench failed" cycle MonteCarlo end if @@ -159,9 +168,9 @@ subroutine mc(calc,mol,bh,verbosity) !=======================================================================================! !>--- Post-processing - first=1 - last=bh%saved - call ensemble_qsort(bh%maxsave,bh%structures,first,last) + first = 1 + last = bh%saved + call ensemble_qsort(bh%maxsave,bh%structures,first,last) !>--- Stats if (printlvl > 0) then @@ -178,6 +187,8 @@ end subroutine mc subroutine mcheader(bh) implicit none type(bh_class),intent(in) :: bh + character(len=80) :: atmp + integer :: n write (stdout,'(a)') '+'//repeat('-',63)//'+' write (stdout,'(a,1x)',advance='no') '|' @@ -195,6 +206,16 @@ subroutine mcheader(bh) write (stdout,'(a,i5,3x)',advance='no') 'max save: ',bh%maxsave write (stdout,'(12x,"|")') + if (allocated(bh%seed)) then + write (stdout,'(a,1x)',advance='no') '|' + write (atmp,'(a,i0)') 'Random number generation (reference) seed: ',bh%seed + write (stdout,'(a,1x)',advance='no') trim(atmp) + n = 61-len_trim(atmp) + write (stdout,'(a)',advance='no') repeat(' ',n) + write (stdout,'("|")') + end if + + write (stdout,'(a,1x)',advance='no') '|' write (stdout,'(a,a,2x)',advance='no') 'step type: ',steptypestr(bh%steptype) write (stdout,'(a,3f9.5)',advance='no') 'step size:',bh%stepsize(1:3) @@ -204,6 +225,7 @@ subroutine mcheader(bh) write (stdout,'(a,f9.5,a)',advance='no') 'Thresholds ΔRMSD:',bh%rthr,' Å, ' write (stdout,'(a,es10.4,a)',advance='no') 'ΔE: ',bh%ethr,' kcal/mol' write (stdout,'(6x,"|")') + write (stdout,'(a)') '+'//repeat('-',63)//'+' end subroutine mcheader @@ -235,6 +257,26 @@ subroutine mcstats(bh,accepted,discarded,broke) write (stdout,'(a)') '+'//repeat('~',63)//'+' end subroutine mcstats +!=========================================================================================! + + subroutine RNG_seed(iseed) +!************************************* +!* seed the RNG to get a reproducible +!* sequence of random numbers +!************************************* + integer,intent(in) :: iseed + integer :: n + integer,allocatable :: seedArray(:) + !> 1) Query how many integers are needed to set the seed (compiler dependent!) + call random_seed(size=n) + !> 2) Allocate and assign a known pattern + allocate (seedArray(n)) + seedArray(:) = iseed + !> 3) Set the seed explicitly + call random_seed(put=seedArray) + deallocate (seedArray) + end subroutine RNG_seed + !=========================================================================================! function mcaccept(mol,bh) result(accept) @@ -299,25 +341,25 @@ subroutine mcduplicate(mol,bh,dupe,broken) !$omp critical call newsort%init(mol,invtype='apsp+',heavy=.false.) - !call newsort%stereo(mol) !$omp end critical COMPARE: do i = 1,bh%saved - !> TODO + !> Energy difference deltaE = (mol%energy-bh%structures(i)%energy)*autokcal - if(topocheck)then + !> Geometry difference (permutation-invariant RMSD) + if (topocheck) then bh%rcache%rank(1:nat,1) = newsort%rank(1:nat) bh%rcache%rank(1:nat,2) = bh%sorters(i)%rank(1:nat) - endif - + end if call min_rmsd(mol,bh%structures(i), & & rcache=bh%rcache,rmsdout=rmsdval) if (debug) write (*,'(a,es15.4,a,es15.4,a)') 'RMSD=',rmsdval*autoaa, & & ' Å, delta E=',deltaE,' kcal/mol' + !> Check if (abs(deltaE) .lt. ethr.and.rmsdval*autoaa .lt. rthr) then dupe = .true. if (deltaE < 0.0_wp) then diff --git a/src/basinhopping/takestep.f90 b/src/basinhopping/takestep.f90 index 50257c62..16671f5f 100644 --- a/src/basinhopping/takestep.f90 +++ b/src/basinhopping/takestep.f90 @@ -64,9 +64,11 @@ subroutine takestep(mol,calc,bh,newmol) !> LOCAL select case (bh%steptype) - case default !> Cartesian + case(0) !> Cartesian newmol = mol call takestep_cart(newmol,bh%stepsize(1),calc) + case default + error stop 'Steptype not implemented yet' end select end subroutine takestep diff --git a/src/classes.f90 b/src/classes.f90 index c59c47dc..43ac3ffb 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -25,6 +25,7 @@ module crest_data use iso_fortran_env,wp => real64,dp => int64 use crest_calculator,only:calcdata use dynamics_module,only:mddata + use bh_module,only:bh_class use strucrd,only:coord use crest_type_timer,only:timer use lwoniom_module, only: lwoniom_input @@ -502,6 +503,7 @@ module crest_data !>--- Calculation settings for newer implementations (version >= 3.0) type(calcdata) :: calc type(mddata) :: mddat + type(bh_class),allocatable :: bh_ref !>--- rigidconf data integer :: rigidconf_algo = 0 integer :: rigidconf_toposource = 0 diff --git a/src/parsing/confparse2.f90 b/src/parsing/confparse2.f90 index 1a0d7c70..5bb313da 100644 --- a/src/parsing/confparse2.f90 +++ b/src/parsing/confparse2.f90 @@ -117,7 +117,7 @@ subroutine parseinputfile(env,fname) !>--- check for any basinhopping/MC setup call parse_basinhopping_data(env,bh,dict,l1,readstatus) if (l1) then - ! env%bh_ref = bh + env%bh_ref = bh end if !>--- terminate if there were any unrecognized keywords diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index d09be3af..437a21e0 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -1137,10 +1137,10 @@ end subroutine parse_metadyn_auto !========================================================================================! subroutine parse_basinhopping_data(env,bh,dict,included,istat) -!********************************************* +!********************************************** !* The following routines are used to -!* read information into the "mddata" object -!********************************************* +!* read information into the "bh_class" object +!********************************************** implicit none type(systemdata) :: env type(bh_class) :: bh @@ -1190,64 +1190,53 @@ subroutine parse_bh_auto(env,bh,kv,rd) type(keyvalue) :: kv logical,intent(out) :: rd logical,allocatable :: atlist(:) - integer :: nat,j + integer :: n,j logical :: ex rd = .true. select case (kv%key) -! case ('active','active_levels') -! mddat%active_potentials = kv%value_ia -! -! case ('includermsd','atlist+') -! call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) -! if (.not.allocated(env%includeRMSD)) allocate (env%includeRMSD(nat),source=1) -! do j = 1,nat -! if (atlist(j)) env%includeRMSD(j) = 1 -! end do -! -! case ('excludermsd','atlist-') -! call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) -! if (.not.allocated(env%includeRMSD)) allocate (env%includeRMSD(nat),source=1) -! do j = 1,nat -! if (atlist(j)) env%includeRMSD(j) = 0 -! end do -! -! case ('length','length_ps') -! mddat%length_ps = kv%value_f -! case ('dump') -! mddat%dumpstep = kv%value_f -! case ('hmass') -! mddat%md_hmass = kv%value_f -! case ('tstep') -! mddat%tstep = kv%value_f -! case ('t','temp','temperature') -! mddat%tsoll = kv%value_f -! mddat%thermostat = .true. -! -! case ('shake') -! select case (kv%id) -! case (valuetypes%int) -! if (kv%value_i <= 0) then -! mddat%shake = .false. -! else -! mddat%shake = .true. -! mddat%shk%shake_mode = min(kv%value_i,2) -! end if -! case (valuetypes%bool) -! mddat%shake = kv%value_b -! if (kv%value_b) mddat%shk%shake_mode = 1 -! end select -! case ('printstep') -! mddat%printstep = kv%value_i -! case ('blocklength','blockl') -! mddat%blockl = kv%value_i -! -! case ('restart') -! inquire (file=trim(kv%value_c),exist=ex) -! if (ex) then -! mddat%restart = .true. -! mddat%restartfile = trim(kv%value_c) -! end if + case ('maxsave') + bh%maxsave = kv%value_i + + case ('seed') + if(.not.allocated(bh%seed)) allocate(bh%seed) + bh%seed = kv%value_i + + case ('step','stepsize') + select case (kv%id) + case (valuetypes%int) + bh%stepsize(1) = real(kv%value_i) + case (valuetypes%float) + bh%stepsize(1) = kv%value_f + case (valuetypes%float_array) + n = min(size(kv%value_fa,1),3) + bh%stepsize(1:n) = kv%value_fa(1:n) + case default + !>--- keyword was recognized, but invalid argument supplied + write (stdout,fmtura) kv%rawvalue + call creststop(status_config) + end select + + case ('steps','maxsteps') + bh%maxsteps = kv%value_i + + case ('steptype') + select case(kv%value_c) + case('cartesian') + bh%steptype=0 + case('internal') + bh%steptype=1 + case('dihedral') + bh%steptype=2 + case('intermol') + bh%steptype=3 + case default + write (stdout,fmtura) trim(kv%value_c) + call creststop(status_config) + end select + + case ('temp','T') + bh%temp = kv%value_f case default rd = .false. From bc5c3f7ad3fe33e1569df9452bfdb6f3d8e6bb9e Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 23 Jan 2025 15:19:57 +0100 Subject: [PATCH 035/374] Prepare iterative BH algo (termination will happen via some condition) --- src/basinhopping/algo.f90 | 24 ++++++++++++++++++------ src/basinhopping/class.f90 | 19 ++++++++++++++++++- src/basinhopping/mc.f90 | 8 ++++---- src/parsing/parse_calcdata.f90 | 5 ++++- src/printouts.f90 | 12 ++++++------ 5 files changed, 50 insertions(+), 18 deletions(-) diff --git a/src/basinhopping/algo.f90 b/src/basinhopping/algo.f90 index 7edbd76e..36c2e61c 100644 --- a/src/basinhopping/algo.f90 +++ b/src/basinhopping/algo.f90 @@ -28,7 +28,7 @@ subroutine crest_basinhopping(env,tim) type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim type(coord) :: mol,molnew - integer :: i,j,k,l,io,ich,T,Tn + integer :: i,j,k,l,io,ich,T,Tn,mciter logical :: pr,wr !========================================================================================! type(calcdata) :: calc @@ -36,12 +36,13 @@ subroutine crest_basinhopping(env,tim) real(wp) :: energy,gnorm real(wp),allocatable :: grad(:,:) + integer :: nall + type(coord),allocatable :: structuredump(:) character(len=80) :: atmp character(len=*),parameter :: trjf = 'crest_quenched.xyz' !========================================================================================! write (stdout,*) - !call system('figlet dynamics') write (stdout,*) " ____ _ _ _ _ " write (stdout,*) "| __ ) __ _ ___(_)_ __ | | | | ___ _ __ _ __ (_)_ __ __ _ " write (stdout,*) "| _ \ / _` / __| | '_ \| |_| |/ _ \| '_ \| '_ \| | '_ \ / _` |" @@ -81,13 +82,22 @@ subroutine crest_basinhopping(env,tim) call tim%start(14,'Basin-Hopping (BH)') - call mc(calc,mol,bh,verbosity=2) + do mciter=1,bh%maxiter + if(bh%maxiter > 1) call printiter2(mciter) + call bh%newiter() + call mc(calc,mol,bh,verbosity=2) + if(mciter == 1)then + nall = bh%saved + allocate(structuredump(nall)) + structuredump(1:nall) = bh%structures(1:nall) + else + + endif + enddo !>--- dump saved minima open (newunit=ich,file=trjf) - do i = 1,bh%saved - call bh%structures(i)%append(ich) - end do + call wrensemble(ich,nall,structuredump) close (ich) if (io == 0) then @@ -100,5 +110,7 @@ subroutine crest_basinhopping(env,tim) end if !========================================================================================! call tim%stop(14) + + if(allocated(structuredump)) deallocate(structuredump) return end subroutine crest_basinhopping diff --git a/src/basinhopping/class.f90 b/src/basinhopping/class.f90 index d0f0ae14..c5ce60f4 100644 --- a/src/basinhopping/class.f90 +++ b/src/basinhopping/class.f90 @@ -39,6 +39,7 @@ module bh_class_module integer :: saved = 0 !> number of saved quenches !>--- paramters + integer :: maxiter = 1 !> maximum repetitions of the whole BH run integer :: maxsteps = 100 !> maximum steps to take real(wp) :: temp = 300.0_wp !> MC acceptance temperature real(wp) :: scalefac = 1.0_wp !> temperature increase factor @@ -71,6 +72,7 @@ module bh_class_module procedure :: init => bh_class_allocate procedure :: deallocate => bh_class_deallocate procedure :: add => bh_class_add + procedure :: newiter => bh_class_newiter end type bh_class !========================================================================================! @@ -110,7 +112,7 @@ subroutine bh_class_allocate(self,temp,maxsteps,maxsave) call random_number(rand) !> Scale and shift to produce an integer in [1,10mil] allocate (self%seed) - self%seed = int(rand*100000000.0)+1 + self%seed = (int(rand*100000000.0)+1) end if end subroutine bh_class_allocate @@ -127,6 +129,21 @@ subroutine bh_class_deallocate(self) if (allocated(self%refsort)) deallocate (self%refsort) end subroutine bh_class_deallocate +!========================================================================================! + + subroutine bh_class_newiter(self) + implicit none + class(bh_class) :: self + integer :: i + self%iteration = self%iteration + 1 + !$omp critical + do i = 1,self%saved + call self%sorters(i)%deallocate() + enddo + !$omp end critical + self%saved=0 + end subroutine bh_class_newiter + !=========================================================================================! subroutine bh_class_add(self,mol) diff --git a/src/basinhopping/mc.f90 b/src/basinhopping/mc.f90 index 5b7f20ef..94c9c464 100644 --- a/src/basinhopping/mc.f90 +++ b/src/basinhopping/mc.f90 @@ -60,7 +60,7 @@ subroutine mc(calc,mol,bh,verbosity) real(wp) :: etot,ratio real(wp),allocatable :: grd(:,:) logical :: accept,dupe,broken - integer :: printlvl,first,last + integer :: printlvl,first,last,dynamicseed character(len=10) :: tag write (tag,'("BH[",i0,"]>")') bh%id @@ -84,9 +84,10 @@ subroutine mc(calc,mol,bh,verbosity) !>--- seed the RNG? if (allocated(bh%seed)) then + dynamicseed = bh%seed+(bh%iteration-1)+bh%id*1000 if (printlvl > 1) then - write (stdout,'(a,1x,a,i0)') trim(tag), & - & 'Seeding current RNG instance with: ',bh%seed + write (stdout,'(a,1x,2(a,i0),a)') trim(tag), & + & 'Seeding current RNG instance with: ',bh%seed,' (',dynamicseed,')' end if call RNG_seed(bh%seed) end if @@ -100,7 +101,6 @@ subroutine mc(calc,mol,bh,verbosity) discarded = 0 broke = 0 MonteCarlo: do iter = 1,bh%maxsteps - bh%iteration = iter broken = .false. dupe = .false. diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 437a21e0..f5bcdd53 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -1195,6 +1195,9 @@ subroutine parse_bh_auto(env,bh,kv,rd) rd = .true. select case (kv%key) + case ('maxiter') !> these are NOT the BH steps! + bh%maxiter = max(1,kv%value_i) + case ('maxsave') bh%maxsave = kv%value_i @@ -1217,7 +1220,7 @@ subroutine parse_bh_auto(env,bh,kv,rd) call creststop(status_config) end select - case ('steps','maxsteps') + case ('steps','maxsteps') !> these are the BH steps bh%maxsteps = kv%value_i case ('steptype') diff --git a/src/printouts.f90 b/src/printouts.f90 index 6cc8e4c9..bdd0af8f 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -651,17 +651,17 @@ end subroutine mtdwarning subroutine printiter implicit none write (*,*) - write (*,'(90("*"))') - write (*,'("**",25x,"N E W I T E R A T I O N C Y C L E",25x,"**")') - write (*,'(90("*"))') + write (*,'(80("*"))') + write (*,'("**",20x,"N E W I T E R A T I O N C Y C L E",20x,"**")') + write (*,'(80("*"))') end subroutine printiter subroutine printiter2(i) implicit none integer :: i write (*,*) - write (*,'(90("*"))') - write (*,'("**",26x,"I T E R A T I O N C Y C L E ",i3,23x,"**")') i - write (*,'(90("*"))') + write (*,'(80("*"))') + write (*,'("**",21x,"I T E R A T I O N C Y C L E ",i3,18x,"**")') i + write (*,'(80("*"))') end subroutine printiter2 !========================================================================================! From a20aa7188b272752f5dde613e32d418e1972f0bb Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 23 Jan 2025 15:45:35 +0100 Subject: [PATCH 036/374] Colorify for nicer BH stdout --- src/basinhopping/mc.f90 | 8 +++-- src/iomod.F90 | 71 ++++++++++++++++++++++++++++++++++++++--- 2 files changed, 72 insertions(+), 7 deletions(-) diff --git a/src/basinhopping/mc.f90 b/src/basinhopping/mc.f90 index 94c9c464..be017502 100644 --- a/src/basinhopping/mc.f90 +++ b/src/basinhopping/mc.f90 @@ -19,6 +19,7 @@ module bh_mc_module use crest_parameters + use iomod use strucrd,only:coord use crest_calculator use optimize_module @@ -126,7 +127,8 @@ subroutine mc(calc,mol,bh,verbosity) call axis(optmol%nat,optmol%at,optmol%xyz) if (printlvl > 1) then - write (stdout,'(a)',advance='no') repeat(' ',len_trim(tag)+1)//"accepted quench" + write (stdout,'(a)',advance='no') repeat(' ',len_trim(tag)+1)// & + & "Quench "//colorify('ACCEPTED','green') end if !> check duplicates here @@ -138,13 +140,13 @@ subroutine mc(calc,mol,bh,verbosity) else if (dupe) then discarded = discarded+1 if (printlvl > 1) write (stdout,'(a)',advance='no') & - & ', but NOT SAVED due to duplicate detection!' + & ', but '//colorify('NOT SAVED','gold')//' due to duplicate detection!' end if if (printlvl > 1) write (stdout,'(/)') else if (printlvl > 1) write (stdout,'(a,a,/)') repeat(' ',len_trim(tag)+1), & - & 'Quench rejected, does not fulfill MC criterion' + & 'Quench '//colorify('REJECTED','red')//', does not fulfill MC criterion' cycle MonteCarlo end if else diff --git a/src/iomod.F90 b/src/iomod.F90 index ffa325aa..4f083971 100644 --- a/src/iomod.F90 +++ b/src/iomod.F90 @@ -55,6 +55,13 @@ integer(kind=c_int) function c_symlink(c_from,c_to) bind(c,name="symlink") end function end interface + interface + integer(c_int) function c_isatty(fd) bind(c,name="isatty") + use iso_c_binding + integer(c_int),value :: fd + end function c_isatty + end interface + interface wrshort module procedure wrshort_real module procedure wrshort_int @@ -759,19 +766,75 @@ end function directory_exist !=========================================================================================! !=========================================================================================! -!> a wrapper for the intrinsic isatty function. -!> ifort only seems to work if isatty is declard as external -!> while gfortran does not want that... function myisatty(channel) result(term) +!************************************************************ +!* a wrapper for the intrinsic isatty function. +!* ifort only seems to work if isatty is declard as external +!* while gfortran does not want that... +!************************************************************ implicit none integer,intent(in) :: channel logical :: term #ifdef __INTEL_COMPILER logical,external :: isatty #endif - term = isatty(channel) + term = isatty(channel) end function myisatty + logical function is_terminal() +!***************************************************************************** +!* Helper function to check if stdout (fd=1) is a TTY +!* This version runs via the iso_c interface rather than the isatty function +!* Also, it doesn't need an output channel +!***************************************************************************** + use iso_c_binding + implicit none + is_terminal = (c_isatty(1_c_int) /= 0) + end function is_terminal + +!=========================================================================================! +!=========================================================================================! +!=========================================================================================! + + function colorify(text,color) result(colored_text) +!****************************************************************************** +!* colorify(text, color) returns a string that wraps `text` in +!* ANSI color codes if stdout is a TTY, or returns `text` as-is otherwise. +!****************************************************************************** + implicit none + !> INPUT + character(len=*),intent(in) :: text + character(len=*),intent(in) :: color + !> We will build the returned string with a deferred-length character + character(len=:),allocatable :: colored_text + !> Escape sequence for ANSI codes + character(len=*),parameter :: ESC = char(27)//"[" + !> Decide if we want color (only if stdout is a terminal) + if (is_terminal()) then + select case (trim(adjustl(color))) + case ("red") + colored_text = ESC//"31m"//trim(text)//ESC//"0m" + case ("green") + colored_text = ESC//"32m"//trim(text)//ESC//"0m" + case ("blue") + colored_text = ESC//"34m"//trim(text)//ESC//"0m" + case ("yellow") + colored_text = ESC//"33m"//trim(text)//ESC//"0m" + case ("gold") + !> 256-color code for a “gold-ish” color + colored_text = ESC//"38;5;214m"//trim(text)//ESC//"0m" + case default + !> If color not recognized (or empty), return text unmodified + colored_text = text + end select + + else + ! Not a terminal => no color codes + colored_text = text + end if + + end function colorify + !=========================================================================================! !=========================================================================================! !=========================================================================================! From ceb74f50e0b6006a27fe2bdc74bcbf87769a3378 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 23 Jan 2025 17:35:07 +0100 Subject: [PATCH 037/374] Add storing function in between BH iterations --- src/basinhopping/algo.f90 | 27 +++--- src/basinhopping/mc.f90 | 2 +- src/sorting/CMakeLists.txt | 1 + src/sorting/cregen.f90 | 3 + src/sorting/meson.build | 1 + src/sorting/unionize.f90 | 178 +++++++++++++++++++++++++++++++++++++ 6 files changed, 197 insertions(+), 15 deletions(-) create mode 100644 src/sorting/unionize.f90 diff --git a/src/basinhopping/algo.f90 b/src/basinhopping/algo.f90 index 36c2e61c..89fb44f9 100644 --- a/src/basinhopping/algo.f90 +++ b/src/basinhopping/algo.f90 @@ -22,6 +22,7 @@ subroutine crest_basinhopping(env,tim) use crest_data use crest_calculator use strucrd + use cregen_interface,only:unionizeEnsembles use optimize_module use bh_module implicit none @@ -37,7 +38,7 @@ subroutine crest_basinhopping(env,tim) real(wp) :: energy,gnorm real(wp),allocatable :: grad(:,:) integer :: nall - type(coord),allocatable :: structuredump(:) + type(coord),allocatable :: structuredump(:) character(len=80) :: atmp character(len=*),parameter :: trjf = 'crest_quenched.xyz' @@ -72,28 +73,26 @@ subroutine crest_basinhopping(env,tim) mol%energy = energy !> we need this to start the Markov-chain !>--- actual basin hopping - if(allocated(env%bh_ref))then + if (allocated(env%bh_ref)) then bh = env%bh_ref call bh%init() else call bh%init(300.0_wp,200,20) bh%stepsize(1) = 1.0_wp - endif + end if call tim%start(14,'Basin-Hopping (BH)') - - do mciter=1,bh%maxiter - if(bh%maxiter > 1) call printiter2(mciter) + nall = 0 + do mciter = 1,bh%maxiter + if (bh%maxiter > 1) call printiter2(mciter) call bh%newiter() call mc(calc,mol,bh,verbosity=2) - if(mciter == 1)then - nall = bh%saved - allocate(structuredump(nall)) - structuredump(1:nall) = bh%structures(1:nall) - else - endif - enddo + write (stdout,'(a)') 'New structures will be appended to memory ...' + call unionizeEnsembles(nall,structuredump,bh%saved,bh%structures, & + & ethr=bh%ethr,rthr=bh%rthr) + write (stdout,'(a,i0,a)') 'Currently ',nall,' structures saved!' + end do !>--- dump saved minima open (newunit=ich,file=trjf) @@ -111,6 +110,6 @@ subroutine crest_basinhopping(env,tim) !========================================================================================! call tim%stop(14) - if(allocated(structuredump)) deallocate(structuredump) + if (allocated(structuredump)) deallocate (structuredump) return end subroutine crest_basinhopping diff --git a/src/basinhopping/mc.f90 b/src/basinhopping/mc.f90 index be017502..eb4b9c55 100644 --- a/src/basinhopping/mc.f90 +++ b/src/basinhopping/mc.f90 @@ -140,7 +140,7 @@ subroutine mc(calc,mol,bh,verbosity) else if (dupe) then discarded = discarded+1 if (printlvl > 1) write (stdout,'(a)',advance='no') & - & ', but '//colorify('NOT SAVED','gold')//' due to duplicate detection!' + & ', but '//colorify('NOT SAVED','yellow')//' due to duplicate detection!' end if if (printlvl > 1) write (stdout,'(/)') diff --git a/src/sorting/CMakeLists.txt b/src/sorting/CMakeLists.txt index f90d9f12..c4f3ac04 100644 --- a/src/sorting/CMakeLists.txt +++ b/src/sorting/CMakeLists.txt @@ -27,6 +27,7 @@ list(APPEND srcs "${dir}/quicksort.f90" "${dir}/rotcompare.f90" "${dir}/sortens.f90" + "${dir}/unionize.f90" "${dir}/zdata.f90" "${dir}/ztopology.f90" ) diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index c15fefe6..47d8230e 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -37,6 +37,7 @@ module cregen_interface !* module to load an interface to the newcregen routine !* mandatory to handle the optional input arguments !******************************************************* + use unionize_module implicit none interface subroutine newcregen(env,quickset,infile) @@ -73,6 +74,8 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) end subroutine cregen_irmsd_sort end interface +!>--- Additional Related RE-EXPORTS + public :: unionizeEnsembles end module cregen_interface subroutine newcregen(env,quickset,infile) diff --git a/src/sorting/meson.build b/src/sorting/meson.build index de88bddc..bda805ab 100644 --- a/src/sorting/meson.build +++ b/src/sorting/meson.build @@ -25,6 +25,7 @@ srcs += files( 'quicksort.f90', 'rotcompare.f90', 'sortens.f90', + 'unionize.f90', 'zdata.f90', 'ztopology.f90', ) diff --git a/src/sorting/unionize.f90 b/src/sorting/unionize.f90 new file mode 100644 index 00000000..453fdada --- /dev/null +++ b/src/sorting/unionize.f90 @@ -0,0 +1,178 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2025 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module unionize_module + use crest_parameters + use strucrd,only:coord + use axis_module + use irmsd_module + use canonical_mod + use quicksort_interface,only:ensemble_qsort + implicit none + private + +! logical,parameter :: debug = .true. + logical,parameter :: debug = .false. + + public :: unionizeEnsembles + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + subroutine unionizeEnsembles(nin,inputs,nmerge,newmols,rthr,ethr) +!*************************************************************************** +!* Merge two ensembles into a new one +!* We asume "inputs" is our reference into which "newmols" shall be merged. +!* "inputs" must be an allocatable list of structures and is OVERWRITTEN +!* by the new list. +!* Setting rthr and ethr to zero (or omitting the arguments) +!* will lead to every structure being identified as unique and +!* append it to the output ensemble. +!*************************************************************************** + implicit none + integer,intent(inout) :: nin + type(coord),allocatable,intent(inout) :: inputs(:) + integer,intent(in) :: nmerge + type(coord),intent(in),target :: newmols(nmerge) + real(wp),intent(in),optional :: rthr,ethr + !> LOCAL + integer :: nout + type(coord),allocatable :: structures(:) + logical :: dupe,broken + integer :: i,j,k,l,nat,ntaken,first,last + type(canonical_sorter) :: newsort,refsort + real(wp) :: rthr_ref,ethr_ref + real(wp) :: rmsdval,deltaE + type(coord),pointer :: mol + logical :: topocheck + type(rmsd_cache),allocatable :: rcache !> similarity check cache (iRMSD) + integer,allocatable :: similarto(:) + + nout = 0 + dupe = .false. + broken = .false. + topocheck = .true. + nat = newmols(1)%nat + if (present(ethr)) then + ethr_ref = ethr + else + ethr_ref = 0.0_wp + end if + if (present(rthr)) then + rthr_ref = rthr + else + rthr_ref = 0.0_wp + end if +!>--- allocate mapping + allocate (similarto(nmerge),source=0) + +!>--- we can skip the soring is "inputs" is empty + if (nin .ne. 0) then +!>--- Prepare comparison data storage + if (debug) write (*,*) + if (.not.allocated(rcache)) then + if (debug) write (*,*) "allocating RCACHE" + !$omp critical + allocate (rcache) + call rcache%allocate(nat) + !$omp end critical + end if + !$omp critical + call refsort%init(inputs(1),invtype='apsp+',heavy=.false.) + call newsort%init(newmols(1),invtype='apsp+',heavy=.false.) + !$omp end critical + +!>--- double loop to count duplicates + COMPAREOUTER: do i = 1,nin + COMPAREINNER: do j = 1,nmerge + if (similarto(j) .ne. 0) cycle COMPAREINNER + mol => newmols(j) + !> Energy difference + deltaE = (mol%energy-inputs(i)%energy)*autokcal + !> we can skip some comparisons if the energy difference is too large + if (abs(deltaE) .gt. ethr) cycle COMPAREINNER + + !> Geometry difference (permutation-invariant RMSD) + if (topocheck) then + rcache%rank(1:nat,1) = newsort%rank(1:nat) + rcache%rank(1:nat,2) = refsort%rank(1:nat) + end if + call min_rmsd(mol,inputs(i), & + & rcache=rcache,rmsdout=rmsdval) + + if (debug) write (*,'(a,es15.4,a,es15.4,a)') 'RMSD=',rmsdval*autoaa, & + & ' Å, delta E=',deltaE,' kcal/mol' + + !> Check + if (abs(deltaE) .lt. ethr_ref.and.rmsdval*autoaa .lt. rthr_ref) then + dupe = .true. + similarto(j) = i + if (deltaE < 0.0_wp) then + !> if the energy is lower, we replace the molecule (better conformation) + inputs(i) = mol + end if + exit COMPAREINNER + end if + end do COMPAREINNER + end do COMPAREOUTER + nullify (mol) + !$omp critical + call newsort%deallocate() + call refsort%deallocate() + !$omp end critical + end if + + ntaken = count(similarto(:) .eq. 0) + nout = nin+ntaken + +!>--- after having checked the molecules, allocate new (output) space + allocate (structures(nout)) + k = 0 + if (nin .ne. 0) then + do i = 1,nin + k = k+1 + structures(k) = inputs(i) + end do + end if + do i = 1,nmerge + if (similarto(i) .eq. 0) then + k = k+1 + structures(k) = newmols(i) + end if + end do + +!>--- for good measure, sort by energy again + first = 1 + last = nout + call ensemble_qsort(nout,structures,first,last) + +!>-- overwrite "inputs" + nin = nout + if(allocated(inputs)) deallocate(inputs) + call move_alloc(structures,inputs) + + end subroutine unionizeEnsembles + +!=========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Date: Thu, 23 Jan 2025 19:04:32 +0100 Subject: [PATCH 038/374] Append colorify printout in BH --- src/basinhopping/mc.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/basinhopping/mc.f90 b/src/basinhopping/mc.f90 index eb4b9c55..4865b223 100644 --- a/src/basinhopping/mc.f90 +++ b/src/basinhopping/mc.f90 @@ -150,7 +150,7 @@ subroutine mc(calc,mol,bh,verbosity) cycle MonteCarlo end if else - if (printlvl > 1) write (stdout,'(a,1x,a,/)') trim(tag),"Quench failed" + if (printlvl > 1) write (stdout,'(a,1x,a,/)') trim(tag),"Quench "//colorify("FAILED","red") cycle MonteCarlo end if From 4edf296ea4490e489e25e14f689cf80e4198ebb2 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 25 Feb 2025 14:26:15 +0100 Subject: [PATCH 039/374] shake module atom freezing fix --- src/dynamics/shake_module.f90 | 161 ++++++++++++++++++++-------------- 1 file changed, 97 insertions(+), 64 deletions(-) diff --git a/src/dynamics/shake_module.f90 b/src/dynamics/shake_module.f90 index 0de18e57..ab8bda72 100644 --- a/src/dynamics/shake_module.f90 +++ b/src/dynamics/shake_module.f90 @@ -91,7 +91,6 @@ module shake_module public :: init_shake public :: do_shake - !========================================================================================! !========================================================================================! contains !> MODULE PROCEDURES START HERE @@ -101,7 +100,7 @@ module shake_module subroutine init_shake(nat,at,xyz,shk,pr) !******************************************** !* subroutine init_shake -!* initialize SHAKE algorithm by documenting +!* initialize SHAKE algorithm by documenting !* which pairs of atoms to constrain !******************************************** implicit none @@ -125,29 +124,29 @@ subroutine init_shake(nat,at,xyz,shk,pr) integer,allocatable :: cons2(:,:) !>--- if shake was already set up, return - if(shk%initialized) return + if (shk%initialized) return !>--- reset counter nconsu = 0 n2 = 0 checkfreeze = associated(shk%freezeptr) !> gfortran workaround - if(checkfreeze)then !> gfortran check + if (checkfreeze) then !> gfortran check nfrz = size(shk%freezeptr,1) else - nfrz = 0 - endif + nfrz = 0 + end if !>--- count user-defined bonds - if ((shk%nusr > 0) .and. allocated(shk%conslistu)) then + if ((shk%nusr > 0).and.allocated(shk%conslistu)) then do i = 1,shk%nusr - nconsu = nconsu + 1 + nconsu = nconsu+1 end do end if !>--- constrain all X-H only if (shk%shake_mode == 1) then - ij = nat * (nat + 1) / 2 + ij = nat*(nat+1)/2 allocate (cons2(2,ij),source=0) do i = 1,nat if (at(i) .eq. 1) then @@ -156,11 +155,11 @@ subroutine init_shake(nat,at,xyz,shk,pr) if (j .ne. i) then !> check if BOTH are frozen - if(checkfreeze.and.j<=nfrz.and.i<=nfrz)then - if( shk%freezeptr(i) .and. shk%freezeptr(j) ) cycle - endif - - rij = (xyz(1,i) - xyz(1,j))**2 + (xyz(2,i) - xyz(2,j))**2 + (xyz(3,i) - xyz(3,j))**2 + if (checkfreeze.and.j <= nfrz.and.i <= nfrz) then + if (shk%freezeptr(i).and.shk%freezeptr(j)) cycle + end if + + rij = (xyz(1,i)-xyz(1,j))**2+(xyz(2,i)-xyz(2,j))**2+(xyz(3,i)-xyz(3,j))**2 if (rij .lt. minrij) then minrij = rij jmin = j @@ -169,14 +168,14 @@ subroutine init_shake(nat,at,xyz,shk,pr) end do if (at(jmin) .eq. 1) then if (jmin .gt. i) then - nconsu = nconsu + 1 - n2 = n2 + 1 + nconsu = nconsu+1 + n2 = n2+1 cons2(1,n2) = i cons2(2,n2) = jmin end if else - nconsu = nconsu + 1 - n2 = n2 + 1 + nconsu = nconsu+1 + n2 = n2+1 cons2(1,n2) = i cons2(2,n2) = jmin end if @@ -187,7 +186,7 @@ subroutine init_shake(nat,at,xyz,shk,pr) !>--- SHAKE all bonds if (shk%shake_mode == 2) then if (allocated(shk%wbo)) then - ij = nat * (nat + 1) / 2 + ij = nat*(nat+1)/2 allocate (cons2(2,ij),source=0) allocate (list(ij),source=0) do i = 1,nat @@ -195,34 +194,34 @@ subroutine init_shake(nat,at,xyz,shk,pr) if (i .eq. j) cycle !>--- if both are frozen, no SHAKE! - if(checkfreeze.and.j<=nfrz.and.i<=nfrz)then - if( shk%freezeptr(i) .and. shk%freezeptr(j) ) cycle - endif + if (checkfreeze.and.j <= nfrz.and.i <= nfrz) then + if (shk%freezeptr(i).and.shk%freezeptr(j)) cycle + end if - rij = (xyz(1,i) - xyz(1,j))**2 + (xyz(2,i) - xyz(2,j))**2 + (xyz(3,i) - xyz(3,j))**2 - rco = (atomicRad(at(j)) + atomicRad(at(i))) * autoaa + rij = (xyz(1,i)-xyz(1,j))**2+(xyz(2,i)-xyz(2,j))**2+(xyz(3,i)-xyz(3,j))**2 + rco = (atomicRad(at(j))+atomicRad(at(i)))*autoaa ij = shake_lin(i,j) !>--- to consider? - rcut = (0.52917726_wp * sqrt(rij) .lt. 1.2_wp * rco) .and. (list(ij) .eq. 0) + rcut = (0.52917726_wp*sqrt(rij) .lt. 1.2_wp*rco).and.(list(ij) .eq. 0) !>--- metal bond? - metalbond = metal(at(i)) .eq. 1 .or. metal(at(j)) .eq. 1 + metalbond = metal(at(i)) .eq. 1.or.metal(at(j)) .eq. 1 !>--- WBO threshold. if WBO > thr, the bond is constrained wthr = 0.5_wp !>--- modify wthr, e.g. K...O in phosphates have WBO around 0.15 if (metalbond) wthr = 0.1_wp !>--- check relevant - if (rcut .and. shk%wbo(i,j) .gt. wthr) then + if (rcut.and.shk%wbo(i,j) .gt. wthr) then !>--- do not constrain M bonds except Li/Be - metalbond = metal(at(i)) .eq. 1 .or. metal(at(j)) .eq. 1 - if (at(i) .eq. 3 .or. at(i) .eq. 4 .or. at(j) .eq. 3 .or. at(j) .eq. 4) & + metalbond = metal(at(i)) .eq. 1.or.metal(at(j)) .eq. 1 + if (at(i) .eq. 3.or.at(i) .eq. 4.or.at(j) .eq. 3.or.at(j) .eq. 4) & & metalbond = .false. if (metalbond) then - if ((i .lt. j) .and. pr) & + if ((i .lt. j).and.pr) & & write (*,*) 'init_shake: metal bond ',i,j,'not constrained' else list(ij) = 1 - nconsu = nconsu + 1 - n2 = n2 + 1 + nconsu = nconsu+1 + n2 = n2+1 cons2(1,n2) = i cons2(2,n2) = j end if @@ -250,7 +249,7 @@ subroutine init_shake(nat,at,xyz,shk,pr) if (shk%nusr > 0) then shk%conslist(1:2,1:shk%nusr) = shk%conslistu(1:2,1:shk%nusr) - j = shk%nusr + 1 + j = shk%nusr+1 else j = 1 end if @@ -260,8 +259,8 @@ subroutine init_shake(nat,at,xyz,shk,pr) do i = 1,shk%ncons iat = shk%conslist(1,i) jat = shk%conslist(2,i) - drij(1:3) = xyz(1:3,iat) - xyz(1:3,jat) - shk%distcons(i) = drij(1)**2 + drij(2)**2 + drij(3)**2 + drij(1:3) = xyz(1:3,iat)-xyz(1:3,jat) + shk%distcons(i) = drij(1)**2+drij(2)**2+drij(3)**2 end do if (allocated(cons2)) deallocate (cons2) @@ -291,22 +290,31 @@ subroutine do_shake(nat,xyzo,xyz,velo,acc,mass,tstep,shk,pr,iostat) real(wp) :: r,dev,dist,denom real(wp) :: gcons,rmi,rmj real(wp) :: tau1,tau2 - integer :: jmaxdev + integer :: jmaxdev,nfrz + logical :: checkfreeze conv = .false. !> assume not converged io = 1 !> and therefore unsuccessfull icyc = 0 - if(.not.allocated(shk%xyzt)) allocate(shk%xyzt(3,nat)) + if (.not.allocated(shk%xyzt)) allocate (shk%xyzt(3,nat)) shk%xyzt = xyz - tau1 = 1.0_wp / tstep - tau2 = tau1 * tau1 + checkfreeze = associated(shk%freezeptr) + !> gfortran workaround + if (checkfreeze) then !> gfortran check + nfrz = size(shk%freezeptr,1) + else + nfrz = 0 + end if + + tau1 = 1.0_wp/tstep + tau2 = tau1*tau1 do i = 1,shk%ncons iat = shk%conslist(1,i) jat = shk%conslist(2,i) - shk%dro(1:3,i) = xyzo(1:3,iat) - xyzo(1:3,jat) + shk%dro(1:3,i) = xyzo(1:3,iat)-xyzo(1:3,jat) end do !>--- iterative SHAKE loop @@ -316,10 +324,10 @@ subroutine do_shake(nat,xyzo,xyz,velo,acc,mass,tstep,shk,pr,iostat) do i = 1,shk%ncons iat = shk%conslist(1,i) jat = shk%conslist(2,i) - shk%dr(1:3,i) = shk%xyzt(1:3,iat) - shk%xyzt(1:3,jat) - shk%dr(4,i) = shk%dr(1,i)**2 + shk%dr(2,i)**2 + shk%dr(3,i)**2 + shk%dr(1:3,i) = shk%xyzt(1:3,iat)-shk%xyzt(1:3,jat) + shk%dr(4,i) = shk%dr(1,i)**2+shk%dr(2,i)**2+shk%dr(3,i)**2 dist = shk%distcons(i) - dev = abs(shk%dr(4,i) - dist) / dist + dev = abs(shk%dr(4,i)-dist)/dist if (dev .gt. maxdev) then maxdev = dev jmaxdev = i @@ -328,38 +336,63 @@ subroutine do_shake(nat,xyzo,xyz,velo,acc,mass,tstep,shk,pr,iostat) if (maxdev .lt. shk%tolshake) conv = .true. - if (.not. conv) then - do i = 1,shk%ncons - iat = shk%conslist(1,i) - jat = shk%conslist(2,i) - dist = shk%distcons(i) - rmi = 1.0_wp / mass(iat) - rmj = 1.0_wp / mass(jat) - denom = 2.0_wp * (rmi + rmj) * (shk%dr(1,i) * shk%dro(1,i) + & - & shk%dr(2,i) * shk%dro(2,i) + & - & shk%dr(3,i) * shk%dro(3,i)) - gcons = (dist - shk%dr(4,i)) / denom - shk%xyzt(1:3,iat) = shk%xyzt(1:3,iat) + rmi * gcons * shk%dro(1:3,i) - shk%xyzt(1:3,jat) = shk%xyzt(1:3,jat) - rmj * gcons * shk%dro(1:3,i) - end do + if (.not.conv) then + if (.not.checkfreeze.or.nfrz > 0) then !> Non-frozen case + + do i = 1,shk%ncons + iat = shk%conslist(1,i) + jat = shk%conslist(2,i) + dist = shk%distcons(i) + rmi = 1.0_wp/mass(iat) + rmj = 1.0_wp/mass(jat) + denom = 2.0_wp*(rmi+rmj)*(shk%dr(1,i)*shk%dro(1,i)+ & + & shk%dr(2,i)*shk%dro(2,i)+ & + & shk%dr(3,i)*shk%dro(3,i)) + gcons = (dist-shk%dr(4,i))/denom + shk%xyzt(1:3,iat) = shk%xyzt(1:3,iat)+rmi*gcons*shk%dro(1:3,i) + shk%xyzt(1:3,jat) = shk%xyzt(1:3,jat)-rmj*gcons*shk%dro(1:3,i) + end do + + else !> Frozen case + + do i = 1,shk%ncons + iat = shk%conslist(1,i) + jat = shk%conslist(2,i) + dist = shk%distcons(i) + rmi = 1.0_wp/mass(iat) + rmj = 1.0_wp/mass(jat) + denom = 2.0_wp*(rmi+rmj)*(shk%dr(1,i)*shk%dro(1,i)+ & + & shk%dr(2,i)*shk%dro(2,i)+ & + & shk%dr(3,i)*shk%dro(3,i)) + gcons = (dist-shk%dr(4,i))/denom + !> update only non-frozen + if (.not.shk%freezeptr(iat)) then + shk%xyzt(1:3,iat) = shk%xyzt(1:3,iat)+rmi*gcons*shk%dro(1:3,i) + end if + if (.not.shk%freezeptr(jat)) then + shk%xyzt(1:3,jat) = shk%xyzt(1:3,jat)-rmj*gcons*shk%dro(1:3,i) + end if + end do + end if + end if - icyc = icyc + 1 - if (.not. conv .and. icyc .le. shk%maxcyc) cycle + icyc = icyc+1 + if (.not.conv.and.icyc .le. shk%maxcyc) cycle exit end do if (conv) then - velo = velo + (shk%xyzt - xyz) * tau1 - acc = acc + (shk%xyzt - xyz) * tau2 + velo = velo+(shk%xyzt-xyz)*tau1 + acc = acc+(shk%xyzt-xyz)*tau2 xyz = shk%xyzt io = 0 !> successful termination else if (pr) then write (*,*) 'SHAKE did not converge! maxdev=',maxdev end if - if(present(iostat))then + if (present(iostat)) then iostat = io - endif + end if return end subroutine do_shake @@ -372,7 +405,7 @@ integer function shake_lin(i1,i2) integer :: i1,i2,idum1,idum2 idum1 = max(i1,i2) idum2 = min(i1,i2) - shake_lin = idum2 + idum1 * (idum1 - 1) / 2 + shake_lin = idum2+idum1*(idum1-1)/2 return end function shake_lin From c7cd20274659d82e49a4169ab614266e0d11889e Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 7 Mar 2025 16:52:19 +0100 Subject: [PATCH 040/374] Modify iRMSD code for degenerate rotational axes --- src/axis_module.f90 | 40 ++++++- src/confparse.f90 | 8 ++ src/minitools.f90 | 87 ++++++++++++++-- src/sorting/irmsd_module.f90 | 197 ++++++++++++++++++++++++----------- 4 files changed, 264 insertions(+), 68 deletions(-) diff --git a/src/axis_module.f90 b/src/axis_module.f90 index ccfd04db..e03952dd 100644 --- a/src/axis_module.f90 +++ b/src/axis_module.f90 @@ -75,6 +75,8 @@ module axis_module end interface cma public :: CMAtrf + public :: uniqueax + !========================================================================================! !========================================================================================! contains !> MODULE PROCEDURES START HERE @@ -303,7 +305,7 @@ end subroutine axis_3 !========================================================================================! - subroutine axis_4(nat,at,coord) + subroutine axis_4(nat,at,coord,rotconst) !**************************************************** !* subroutine axis_4 !* axis routine that orients the molecule along the @@ -315,6 +317,7 @@ subroutine axis_4(nat,at,coord) integer,intent(in) :: nat integer,intent(in) :: at(nat) real(wp),intent(inout) :: coord(3,nat) + real(wp),intent(out),optional :: rotconst(3) real(wp) :: coordtmp(3),shift(3) real(wp) :: rot(3),avmom,evec(3,3) integer :: i,j,k @@ -342,6 +345,10 @@ subroutine axis_4(nat,at,coord) coord(j,i) = xsum end do end do + if(present(rotconst))then + rotconst(:) = rot(:) + endif + return end subroutine axis_4 @@ -407,6 +414,37 @@ real(wp) function calcxsum(evec) return end function calcxsum +!========================================================================================! + + subroutine uniqueax(rot,unique,thr) +!************************************************** +!* check if a given rotational constant is unique +!************************************************** + implicit none + real(wp),intent(in) :: rot(3) + logical,intent(out) :: unique(3) + real(wp),intent(in),optional :: thr + real(wp) :: thrtmp + real(wp) :: diff(3) + + unique(:) = .false. + + if(present(thr))then + thrtmp = thr + else + thrtmp = 0.01_wp + endif + + diff(1) = abs(rot(2)/rot(1) - 1.0_wp) + diff(2) = abs(rot(3)/rot(1) - 1.0_wp) + diff(3) = abs(rot(3)/rot(2) - 1.0_wp) + + if(diff(1) .gt. thrtmp .and. diff(2) .gt. thrtmp) unique(1) = .true. + if(diff(1) .gt. thrtmp .and. diff(3) .gt. thrtmp) unique(2) = .true. + if(diff(2) .gt. thrtmp .and. diff(3) .gt. thrtmp) unique(3) = .true. + + end subroutine uniqueax + !========================================================================================! subroutine CMAxyz(nat,at,coord,x,y,z) diff --git a/src/confparse.f90 b/src/confparse.f90 index a43a6a57..504c367f 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -584,6 +584,14 @@ subroutine parseflags(env,arg,nra) end if stop + case ('-rotalign') + ctmp = trim(arg(i+1)) + inquire (file=ctmp,exist=ex) + if (ex) then + call rotalign_tool(ctmp) + end if + stop + case ('-printboltz') if (nra >= i+2) then ctmp = trim(arg(i+1)) diff --git a/src/minitools.f90 b/src/minitools.f90 index e008fc8a..108ae46b 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -92,7 +92,7 @@ subroutine printaniso(fname,bmin,bmax,bshift) use axis_module implicit none character(len=*) :: fname - type(ensemble) :: ens + type(coord),allocatable :: structures(:) integer :: nat integer :: nall @@ -102,6 +102,7 @@ subroutine printaniso(fname,bmin,bmax,bshift) real(wp),allocatable :: rot(:,:) real(wp) :: rotaniso !function real(wp),allocatable :: anis(:) + real(wp) :: evec(3,3),evecavg(3,3) real(wp) :: bthrerf real(wp) :: bmin,bmax,bshift @@ -109,23 +110,34 @@ subroutine printaniso(fname,bmin,bmax,bshift) real(wp) :: dum integer :: i - call ens%open(fname) - nat = ens%nat - nall = ens%nall + call rdensemble(fname,nall,structures) + nat = structures(1)%nat allocate (c1(3,nat),at(nat)) allocate (rot(3,nall)) allocate (anis(nall)) - at = ens%at + at(:) = structures(1)%at(:) + evecavg(:,:) = 0.0_wp + do i = 1,nall + c1(1:3,:) = structures(i)%xyz(1:3,:)*autoaa + call axis(nat,at,c1,rot(1:3,i),dum,evec) + evecavg(:,:) = evecavg(:,:) + evec(:,:) + enddo + evecavg(:,:) = evecavg(:,:) / real(nall) do i = 1,nall - c1(1:3,:) = ens%xyz(1:3,:,i) - call axis(nat,at,c1,rot(1:3,i),dum) + c1(1:3,:) = structures(i)%xyz(1:3,:)*autoaa + call axis(nat,at,c1,rot(1:3,i),dum,evec) anis(i) = rotaniso(i,nall,rot) thr = bthrerf(bmin,anis(i),bmax,bshift) write (*,'(3f10.2,2x,f8.4,2x,f8.4)') rot(1:3,i),anis(i),thr + !write (*,'(3f20.10)') evec(:,1) + !write (*,'(3f20.10)') abs(dot_product(evec(:,1),evecavg(:,1))),abs(dot_product(evec(:,2),evecavg(:,2))),abs(dot_product(evec(:,3),evecavg(:,3))) + !write (*,'(3f20.10)') evec(:,2) + !write (*,'(3f20.10)') evec(:,3) end do + deallocate (anis,rot,at,c1) @@ -135,6 +147,67 @@ end subroutine printaniso !=========================================================================================! +subroutine rotalign_tool(fname) +!**************************************************** +!* print the anisotropy of the rotational constants +!* for all structures in a given ensemble file +!**************************************************** + use crest_parameters + use strucrd + use axis_module + implicit none + character(len=*) :: fname + type(coord),allocatable :: structures(:) + + integer :: nat + integer :: nall + real(wp),allocatable :: c1(:,:),c2(:,:) + integer,allocatable :: at(:) + + real(wp),allocatable :: rot(:,:) + real(wp) :: rotaniso !function + real(wp),allocatable :: anis(:) + real(wp) :: evec(3,3),evecavg(3,3) + + real(wp) :: bthrerf + real(wp) :: bmin,bmax,bshift + real(wp) :: thr + real(wp) :: dum + integer :: i + + real(wp), parameter :: Ry90(3,3) = reshape([ & + & 0.0_wp, 0.0_wp, -1.0_wp, & + & 0.0_wp, 1.0_wp, 0.0_wp, & + & 1.0_wp, 0.0_wp, 0.0_wp & + & ], [3,3]) + + + call rdensemble(fname,nall,structures) + nat = structures(1)%nat + + allocate (c1(3,nat),c2(3,nat),at(nat)) + allocate (rot(3,nall)) + + at(:) = structures(1)%at(:) + write (*,'(3a10)') 'A/MHz','B/MHz','C/MHz' + do i = 1,nall + c1(1:3,:) = structures(i)%xyz(1:3,:)*autoaa + call axis(nat,at,c1,rot(1:3,i)) + c2 = c1 + structures(i)%xyz = c2*aatoau + write (*,'(3f10.2)') rot(1:3,i) + end do + + deallocate (rot,at,c2,c1) + + call wrensemble('rotalign.xyz',nall,structures) + + stop + return +end subroutine rotalign_tool + +!=========================================================================================! + subroutine prbweight(fname,Targ) !***************************************************** !* read in a file with 1 to 2 columns diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index 589abd31..8cc25bd7 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -58,26 +58,47 @@ module irmsd_module end type rmsd_cache real(wp),parameter :: inf = huge(1.0_wp) - real(wp),parameter :: imat(3,3) = reshape([1.0_wp,0.0_wp,0.0_wp, & - & 0.0_wp,1.0_wp,0.0_wp, & + real(wp),parameter :: imat(3,3) = reshape([1.0_wp,0.0_wp,0.0_wp, & + & 0.0_wp,1.0_wp,0.0_wp, & & 0.0_wp,0.0_wp,1.0_wp], & & [3,3]) - real(wp),parameter :: Rx180(3,3) = reshape([1.0_wp,0.0_wp,0.0_wp, & - & 0.0_wp,-1.0_wp,0.0_wp, & + real(wp),parameter :: Rx180(3,3) = reshape([1.0_wp,0.0_wp,0.0_wp, & + & 0.0_wp,-1.0_wp,0.0_wp, & & 0.0_wp,0.0_wp,-1.0_wp], & & [3,3]) - real(wp),parameter :: Ry180(3,3) = reshape([-1.0_wp,0.0_wp,0.0_wp, & + real(wp),parameter :: Ry180(3,3) = reshape([-1.0_wp,0.0_wp,0.0_wp, & & 0.0_wp,1.0_wp,0.0_wp, & & 0.0_wp,0.0_wp,-1.0_wp], & & [3,3]) real(wp),parameter :: Rz180(3,3) = reshape([-1.0_wp,0.0_wp,0.0_wp, & - & 0.0_wp,-1.0_wp,0.0_wp, & + & 0.0_wp,-1.0_wp,0.0_wp, & & 0.0_wp,0.0_wp,1.0_wp], & & [3,3]) + real(wp), parameter :: Rx90(3,3) = reshape([ & + & 1.0_wp, 0.0_wp, 0.0_wp, & + & 0.0_wp, 0.0_wp, 1.0_wp, & + & 0.0_wp, -1.0_wp, 0.0_wp & + & ], [3,3]) + real(wp),parameter :: Rx90T(3,3) = transpose(Rx90) + + real(wp), parameter :: Ry90(3,3) = reshape([ & + & 0.0_wp, 0.0_wp, -1.0_wp, & + & 0.0_wp, 1.0_wp, 0.0_wp, & + & 1.0_wp, 0.0_wp, 0.0_wp & + & ], [3,3]) + real(wp),parameter :: Ry90T(3,3) = transpose(Ry90) + + real(wp), parameter :: Rz90(3,3) = reshape([ & + & 0.0_wp, 1.0_wp, 0.0_wp, & + & -1.0_wp, 0.0_wp, 0.0_wp, & + & 0.0_wp, 0.0_wp, 1.0_wp & + & ], [3,3]) + real(wp),parameter :: Rz90T(3,3) = transpose(Rz90) + !========================================================================================! !========================================================================================! contains !> MODULE PROCEDURES START HERE @@ -120,7 +141,7 @@ subroutine allocate_rmsd_cache(self,nat) allocate (self%best_order(nat,3),source=0) allocate (self%current_order(nat),source=0) allocate (self%target_order(nat),source=0) - allocate (self%order_bkup(nat,8),source=0) + allocate (self%order_bkup(nat,32),source=0) allocate (self%iwork(nat),source=0) allocate (self%iwork2(nat,2),source=0) allocate (self%rank(nat,2),source=0) @@ -393,10 +414,10 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout,align) !> LOCAL type(rmsd_cache),pointer :: cptr type(rmsd_cache),allocatable,target :: local_rcache - integer :: nat,ii,rnk,dumpunit + integer :: nat,ii,rnk,dumpunit,scenario real(wp) :: calc_rmsd - real(wp) :: tmprmsd_sym(8),dum - real(wp) :: rotmat(3,3) + real(wp) :: tmprmsd_sym(32),dum + real(wp) :: rotmat(3,3),rotconst(3) logical,parameter :: debug = .false. !>--- Initialization @@ -485,12 +506,13 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout,align) !> initialize to huge tmprmsd_sym(:) = inf !> initial alignment of mol - call axis(mol%nat,mol%at,mol%xyz) + call axis(mol%nat,mol%at,mol%xyz,rotconst) + call min_rmsd_rotcheck_unique(mol,rotconst,scenario) - !> Running the checks - call min_rmsd_rotcheck(ref,mol,cptr,tmprmsd_sym,1) + !> Running the checks and check of uniqueness of rotational axes + call min_rmsd_rotcheck_permute(ref,mol,cptr,tmprmsd_sym,1,scenario) if (debug) then - write (*,*) 'Total LSAP cost:',minval(tmprmsd_sym(1:4)) + write (*,*) 'Total LSAP cost:',minval(tmprmsd_sym(1:16)) call mol%append(dumpunit) end if @@ -500,34 +522,44 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout,align) call axis(mol%nat,mol%at,mol%xyz) !> align !> Running the checks - call min_rmsd_rotcheck(ref,mol,cptr,tmprmsd_sym,2) + call min_rmsd_rotcheck_permute(ref,mol,cptr,tmprmsd_sym,2,scenario) if (debug) then - write (*,*) 'Total LSAP cost (inverted):',minval(tmprmsd_sym(5:8)) + write (*,*) 'Total LSAP cost (inverted):',minval(tmprmsd_sym(17:32)) call mol%append(dumpunit) end if mol%xyz(3,:) = -mol%xyz(3,:) !> restore z end if !>--- select the best match among the ones after symmetry operations and use its ordering - ii = minloc(tmprmsd_sym(:),1) + ii = minloc(tmprmsd_sym(1:32),1) if (debug) then - write (*,*) 'final alignment:',ii,"/ 8" + write (*,*) 'final alignment:',ii,"/ 32" end if - if (ii > 4) then + if (ii > 16) then mol%xyz(3,:) = -mol%xyz(3,:) if (debug) write (*,*) 'inverting' end if + if ((ii > 4 .and. ii < 9) .or. (ii > 20 .and. ii < 25))then + if(scenario == 1) mol%xyz = matmul(Rx90,mol%xyz) + if(scenario == 2) mol%xyz = matmul(Rz90,mol%xyz) + if(scenario == 3) mol%xyz = matmul(Rz90,mol%xyz) + if(debug) write (*,*) '90° tilt' + else if ((ii > 8 .and. ii < 13) .or. (ii > 24 .and. ii < 29))then + mol%xyz = matmul(Ry90,mol%xyz) + else if ((ii > 12 .and. ii < 17) .or. (ii > 28))then + mol%xyz = matmul(Rx90,mol%xyz) + endif select case (ii) !> 180° rotations - case (1,5) + case (1,5,9,13,17,21,25,29) continue - case (2,6) + case (2,6,10,14,18,22,26,30) mol%xyz = matmul(Rx180,mol%xyz) if (debug) write (*,*) '180°x' - case (3,7) + case (3,7,11,15,19,23,27,31) mol%xyz = matmul(Rx180,mol%xyz) mol%xyz = matmul(Ry180,mol%xyz) if (debug) write (*,*) '180°x, 180°y' - case (4,8) + case (4,8,12,16,20,24,28,32) mol%xyz = matmul(Ry180,mol%xyz) if (debug) write (*,*) '180°y' end select @@ -600,80 +632,125 @@ end subroutine min_rmsd_iterate_through_groups !========================================================================================! - subroutine min_rmsd_rotcheck(ref,mol,cptr,values,step) + subroutine min_rmsd_rotcheck_unique(mol,rot,scenario,thr) +!******************************************************* +!* Based on the rotational constants, determine what we +!* need to do with the molecule in the following +!******************************************************* + implicit none + type(coord),intent(inout) :: mol + real(wp),intent(in) :: rot(3) + integer,intent(out) :: scenario + real(wp),intent(in),optional :: thr + logical :: unique(3) + integer :: nunique + + scenario = 0 + call uniqueax(rot,unique,thr) + + nunique = count(unique,1) + select case(nunique) + case ( 3 ) !> 3 unique principal axes + scenario = 0 + case ( 1 ) !> one unique principal axis + if(unique(1)) scenario = 1 !> A unique (long axis) + if(unique(3)) scenario = 2 !> C unique (short axis) + case ( 0 ) !> rotationally ambiguous system + scenario = 3 + end select + end subroutine min_rmsd_rotcheck_unique + +!=======================================================================================! + + subroutine min_rmsd_rotcheck_permute(ref,mol,cptr,values,step,scenario) implicit none type(coord),intent(in) :: ref type(coord),intent(inout) :: mol type(rmsd_cache),intent(inout),target :: cptr real(wp),intent(inout) :: values(:) - integer,intent(in) :: step + integer,intent(in) :: step,scenario integer :: rr,ii,jj,debugunit2 - real(wp) :: vals(4),dum + real(wp) :: vals(16),dum logical,parameter :: debug = .false. !> reset val - vals(:) = 0.0_wp + vals(:) = inf if (debug) then open (newunit=debugunit2,file='rotdebug.xyz') call ref%append(debugunit2) end if + + ALIGNLOOP : do ii=1,4 call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) - vals(1) = dum + vals(1+4*(ii-1)) = dum if (debug) call mol%append(debugunit2) - cptr%order_bkup(:,1+4*(step-1)) = cptr%iwork(:) + cptr%order_bkup(:,1+4*(ii-1)+16*(step-1)) = cptr%iwork(:) mol%xyz = matmul(Rx180,mol%xyz) call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) - vals(2) = dum + vals(2+4*(ii-1)) = dum if (debug) call mol%append(debugunit2) - cptr%order_bkup(:,2+4*(step-1)) = cptr%iwork(:) + cptr%order_bkup(:,2+4*(ii-1)+16*(step-1)) = cptr%iwork(:) mol%xyz = matmul(Ry180,mol%xyz) call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) - vals(3) = dum + vals(3+4*(ii-1)) = dum if (debug) call mol%append(debugunit2) - cptr%order_bkup(:,3+4*(step-1)) = cptr%iwork(:) + cptr%order_bkup(:,3+4*(ii-1)+16*(step-1)) = cptr%iwork(:) mol%xyz = matmul(Rx180,mol%xyz) call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) - vals(4) = dum + vals(4+4*(ii-1)) = dum if (debug) call mol%append(debugunit2) - cptr%order_bkup(:,4+4*(step-1)) = cptr%iwork(:) + cptr%order_bkup(:,4+4*(ii-1)+16*(step-1)) = cptr%iwork(:) mol%xyz = matmul(Ry180,mol%xyz) !> restore + !exit ALIGNLOOP + select case(scenario) + case( 0 ) !> 3 Unique moments of inertia + exit ALIGNLOOP + case( 1 ) !> only one unique moment of inertia (A) + if( ii == 2 )then + mol%xyz = matmul(Rx90T,mol%xyz) + exit ALIGNLOOP + endif + mol%xyz = matmul(Rx90,mol%xyz) + case (2) !> only one unique moment of inertia (C) + if( ii == 2 )then + mol%xyz = matmul(Rz90T,mol%xyz) + exit ALIGNLOOP + endif + mol%xyz = matmul(Rz90,mol%xyz) + case (3) + if( ii == 1)then + mol%xyz = matmul(Rz90,mol%xyz) + else if(ii == 2)then + mol%xyz = matmul(Rz90T,mol%xyz) + mol%xyz = matmul(Ry90,mol%xyz) + else if(ii == 3)then + mol%xyz = matmul(Ry90T,mol%xyz) + mol%xyz = matmul(Rx90,mol%xyz) + else + mol%xyz = matmul(Rx90T,mol%xyz) + exit ALIGNLOOP + endif + end select + + + enddo ALIGNLOOP + + if (debug) then close (debugunit2) write (*,*) 'vals:',vals(:) end if - do ii = 1,4 - values(ii+4*(step-1)) = vals(ii) - end do - end subroutine min_rmsd_rotcheck - -!=========================================================================================! - - subroutine min_rmsd_quadalign(ref,mol,rotate) - implicit none - type(coord),intent(in) :: ref - type(coord),intent(inout) :: mol - logical,intent(out) :: rotate(3) - integer :: rr,ii,jj,acount - real(wp) :: val0 - integer :: tmp1,tmp2 - type(assignment_cache),pointer :: aptr - logical,parameter :: debug = .false. - - rotate(:) = .false. - - do jj = 1,3 - tmp1 = count(ref%xyz(jj,:) > 0.0_wp) - tmp2 = count(mol%xyz(jj,:) > 0.0_wp) - if (tmp1 .ne. tmp2) rotate(jj) = .true. + do ii = 1,16 + values(ii+16*(step-1)) = vals(ii) end do - end subroutine min_rmsd_quadalign + end subroutine min_rmsd_rotcheck_permute !========================================================================================! From 3972555bb3802a3ace4d280d394b1054f6bb2a88 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 27 Mar 2025 10:46:02 +0100 Subject: [PATCH 041/374] somne keyword additions --- src/algos/sorting.f90 | 8 ++++++++ src/confparse.f90 | 8 ++++++-- src/minitools.f90 | 5 ++++- 3 files changed, 18 insertions(+), 3 deletions(-) diff --git a/src/algos/sorting.f90 b/src/algos/sorting.f90 index 918505a6..af5b2c97 100644 --- a/src/algos/sorting.f90 +++ b/src/algos/sorting.f90 @@ -32,6 +32,7 @@ subroutine crest_sort(env,tim) use crest_calculator use strucrd use cregen_interface + use iomod, only: catdel implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim @@ -76,6 +77,12 @@ subroutine crest_sort(env,tim) call underline('Running all unique pair RMSDs incl. atom permutation') call cregen_irmsd_all(nall,structures,2) + case('cregen') +!>--- the original CREGEN procedure (fallback, needs nicer implementations) + if(allocated(structures))deallocate(structures) + call newcregen(env,infile=env%ensemblename) + call catdel('cregen.out.tmp') + case default !>--- all unique pairs of the ensemble (only suitable for small ensembles) call cregen_irmsd_all(nall,structures,2) @@ -83,5 +90,6 @@ subroutine crest_sort(env,tim) !========================================================================================! call tim%stop(11) + if(allocated(structures)) deallocate(structures) return end subroutine crest_sort diff --git a/src/confparse.f90 b/src/confparse.f90 index 504c367f..a49c5fce 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -654,10 +654,14 @@ subroutine parseflags(env,arg,nra) end if stop - case ('-irmsd') + case ('-irmsd','-irmsd_noinv') ctmp = trim(arg(i+1)) dtmp = trim(arg(i+2)) - call irmsd_tool(ctmp,dtmp) + if(index(argument,'_noinv').ne.0)then + call irmsd_tool(ctmp,dtmp,.false.) + else + call irmsd_tool(ctmp,dtmp,.true.) + endif stop case ('-hungarian','-hungarianheavy','-hhungarian','-lsap','-hlsap','-lsapheavy') diff --git a/src/minitools.f90 b/src/minitools.f90 index 108ae46b..9641943f 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -825,7 +825,7 @@ end subroutine quick_hungarian_match !=========================================================================================! -subroutine irmsd_tool(fname1,fname2) +subroutine irmsd_tool(fname1,fname2,mirror) use crest_parameters use strucrd use axis_module @@ -834,6 +834,7 @@ subroutine irmsd_tool(fname1,fname2) implicit none character(len=*),intent(in) :: fname1 character(len=*),intent(in) :: fname2 + logical,intent(in) :: mirror type(coord) :: mol,ref real(wp) :: rmsdval,tmpd(3),tmpdist integer :: i,ich @@ -863,6 +864,8 @@ subroutine irmsd_tool(fname1,fname2) rcache%stereocheck = .not. (canref%hasstereo(ref)) call canref%shrink() write(*,*) 'false enantiomers possible?: ',rcache%stereocheck + write(*,*) 'allow inversion?: ',mirror + if(.not.mirror) rcache%stereocheck = .false. call canmol%init(mol,invtype='apsp+',heavy=.false.) !call canmol%add_h_ranks(mol) From d812653dab96038d25076626d6d34ebbd864b42c Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 30 Mar 2025 16:31:50 +0200 Subject: [PATCH 042/374] Fix atom freezing within SHAKE --- src/dynamics/shake_module.f90 | 24 ++++++++++++++++++------ 1 file changed, 18 insertions(+), 6 deletions(-) diff --git a/src/dynamics/shake_module.f90 b/src/dynamics/shake_module.f90 index ab8bda72..435a01a4 100644 --- a/src/dynamics/shake_module.f90 +++ b/src/dynamics/shake_module.f90 @@ -214,10 +214,10 @@ subroutine init_shake(nat,at,xyz,shk,pr) !>--- do not constrain M bonds except Li/Be metalbond = metal(at(i)) .eq. 1.or.metal(at(j)) .eq. 1 if (at(i) .eq. 3.or.at(i) .eq. 4.or.at(j) .eq. 3.or.at(j) .eq. 4) & - & metalbond = .false. + & metalbond = .false. if (metalbond) then if ((i .lt. j).and.pr) & - & write (*,*) 'init_shake: metal bond ',i,j,'not constrained' + & write (*,*) 'init_shake: metal bond ',i,j,'not constrained' else list(ij) = 1 nconsu = nconsu+1 @@ -382,10 +382,22 @@ subroutine do_shake(nat,xyzo,xyz,velo,acc,mass,tstep,shk,pr,iostat) end do if (conv) then - velo = velo+(shk%xyzt-xyz)*tau1 - acc = acc+(shk%xyzt-xyz)*tau2 - xyz = shk%xyzt - io = 0 !> successful termination + + if (nfrz .eq. 0) then + velo = velo+(shk%xyzt-xyz)*tau1 + acc = acc+(shk%xyzt-xyz)*tau2 + xyz = shk%xyzt + io = 0 !> successful termination + else + do i = 1,nat + if (.not.shk%freezeptr(i)) then + velo(:,i) = velo(:,i)+(shk%xyzt(:,i)-xyz(:,i))*tau1 + acc(:,i) = acc(:,i)+(shk%xyzt(:,i)-xyz(:,i))*tau2 + xyz(:,i) = shk%xyzt(:,i) + end if + end do + end if + io = 0 else if (pr) then write (*,*) 'SHAKE did not converge! maxdev=',maxdev end if From 5466dd0f28d9d2df1ad3ca1e83946f9629f39963 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 30 Mar 2025 17:46:08 +0200 Subject: [PATCH 043/374] New banner --- src/printouts.f90 | 47 +++++++++++++++++++++++++++++++---------------- 1 file changed, 31 insertions(+), 16 deletions(-) diff --git a/src/printouts.f90 b/src/printouts.f90 index 981a65d6..fecb8f31 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -80,29 +80,44 @@ subroutine box3(version,date,commit,author) character(len=*) :: date character(len=*) :: commit character(len=*) :: author - character(len=200) :: logo(10) + character(len=200) :: logo(13) character(len=200) :: info(2) integer,parameter :: pad_left = 7 integer :: i,lcount write (*,*) - write (logo(1),'(''╔════════════════════════════════════════════╗'')') - write (logo(2),'(''║ ___ ___ ___ ___ _____ ║'')') - write (logo(3),'(''║ / __| _ \ __/ __|_ _| ║'')') - write (logo(4),'(''║ | (__| / _|\__ \ | | ║'')') - write (logo(5),'(''║ \___|_|_\___|___/ |_| ║'')') - write (logo(6),'(''║ ║'')') - write (logo(7),'(''║ Conformer-Rotamer Ensemble Sampling Tool ║'')') - write (logo(8),'(''║ based on the xTB methods ║'')') - write (logo(9),'(''║ ║'')') - write (logo(10),'("╚════════════════════════════════════════════╝")') - do i = 1,10 - write (*,'(a,a)') repeat(" ",pad_left),trim(logo(i)) + !write (logo(1),'(''╔════════════════════════════════════════════╗'')') + !write (logo(2),'(''║ ___ ___ ___ ___ _____ ║'')') + !write (logo(3),'(''║ / __| _ \ __/ __|_ _| ║'')') + !write (logo(4),'(''║ | (__| / _|\__ \ | | ║'')') + !write (logo(5),'(''║ \___|_|_\___|___/ |_| ║'')') + !write (logo(6),'(''║ ║'')') + !write (logo(7),'(''║ Conformer-Rotamer Ensemble Sampling Tool ║'')') + !write (logo(8),'(''║ based on the xTB methods ║'')') + !write (logo(9),'(''║ ║'')') + !write (logo(10),'("╚════════════════════════════════════════════╝")') + + write (logo(1), '(''╔════════════════════════════════════════════════╗'')') + write (logo(2), '(''║ ║'')') + write (logo(3), '(''║ ██████╗██████╗ ███████╗███████╗████████╗ ║'')') + write (logo(4), '(''║ ██╔════╝██╔══██╗██╔════╝██╔════╝╚══██╔══╝ ║'')') + write (logo(5), '(''║ ██║ ██████╔╝█████╗ ███████╗ ██║ ║'')') + write (logo(6), '(''║ ██║ ██╔══██╗██╔══╝ ╚════██║ ██║ ║'')') + write (logo(7), '(''║ ╚██████╗██║ ██║███████╗███████║ ██║ ║'')') + write (logo(8), '(''║ ╚═════╝╚═╝ ╚═╝╚══════╝╚══════╝ ╚═╝ ║'')') + write (logo(9), '(''║ ║'')') + write (logo(10),'(''║ Conformer-Rotamer Ensemble Sampling Tool ║'')') + write (logo(11),'(''║ based on the xTB methods ║'')') + write (logo(12),'(''║ ║'')') + write (logo(13),'(''╚════════════════════════════════════════════════╝'')') + + do i = 1,13 + write (*,'(a,a)') repeat(" ",pad_left),trim(logo(i)) end do - write (*,'(a,''Version '',a,'', '',a)') repeat(" ",pad_left),trim(version),trim(date) + write (*,'(a,'' Version '',a,'', '',a)') repeat(" ",pad_left),trim(version),trim(date) if(author(1:2).eq."'@")then - write (*,'(a,"commit (",a,") compiled by ",a)') repeat(" ",pad_left),commit,"'usr"//author(2:) + write (*,'(a," commit (",a,") compiled by ",a)') repeat(" ",pad_left),commit,"'usr"//author(2:) else - write (*,'(a,"commit (",a,") compiled by ",a)') repeat(" ",pad_left),commit,author + write (*,'(a," commit (",a,") compiled by ",a)') repeat(" ",pad_left),commit,author endif end subroutine box3 From 4eee8024a8318303bea00561f0e622822b3646de Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 2 Apr 2025 17:40:14 +0200 Subject: [PATCH 044/374] Fix IO handling for generic scripts/subprocesses in parallel routines --- src/algos/parallel.f90 | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/src/algos/parallel.f90 b/src/algos/parallel.f90 index 0fb289c2..27fa9f01 100644 --- a/src/algos/parallel.f90 +++ b/src/algos/parallel.f90 @@ -127,13 +127,15 @@ subroutine crest_sploop(env,nat,nall,at,xyz,eread) do i = 1,T do j = 1,env%calc%ncalculations calculations(i)%calcs(j) = env%calc%calcs(j) - !>--- directories + !>--- directories and io preparation ex = directory_exist(env%calc%calcs(j)%calcspace) if (.not.ex) then io = makedir(trim(env%calc%calcs(j)%calcspace)) end if write (atmp,'(a,"_",i0)') sep,i calculations(i)%calcs(j)%calcspace = env%calc%calcs(j)%calcspace//trim(atmp) + if(allocated(calculations(i)%calcs(j)%calcfile)) deallocate(calculations(i)%calcs(j)%calcfile) + if(allocated(calculations(i)%calcs(j)%systemcall)) deallocate(calculations(i)%calcs(j)%systemcall) call calculations(i)%calcs(j)%printid(i,j) end do calculations(i)%pr_energies = .false. @@ -307,7 +309,7 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) do i = 1,T do j = 1,mycalc%ncalculations calculations(i)%calcs(j) = mycalc%calcs(j) - !>--- directories + !>--- directories and io preparation ex = directory_exist(mycalc%calcs(j)%calcspace) if (.not.ex) then io = makedir(trim(mycalc%calcs(j)%calcspace)) @@ -317,6 +319,8 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) endif write (atmp,'(a,"_",i0)') sep,i calculations(i)%calcs(j)%calcspace = mycalc%calcs(j)%calcspace//trim(atmp) + if(allocated(calculations(i)%calcs(j)%calcfile)) deallocate(calculations(i)%calcs(j)%calcfile) + if(allocated(calculations(i)%calcs(j)%systemcall)) deallocate(calculations(i)%calcs(j)%systemcall) call calculations(i)%calcs(j)%printid(i,j) end do calculations(i)%pr_energies = .false. @@ -564,13 +568,15 @@ subroutine crest_search_multimd(env,mol,mddats,nsim) moltmps(i)%xyz = mol%xyz do j = 1,env%calc%ncalculations calculations(i)%calcs(j) = env%calc%calcs(j) - !>--- directories + !>--- directories and io preparation ex = directory_exist(env%calc%calcs(j)%calcspace) if (.not.ex) then io = makedir(trim(env%calc%calcs(j)%calcspace)) end if write (atmp,'(a,"_",i0)') sep,i calculations(i)%calcs(j)%calcspace = env%calc%calcs(j)%calcspace//trim(atmp) + if(allocated(calculations(i)%calcs(j)%calcfile)) deallocate(calculations(i)%calcs(j)%calcfile) + if(allocated(calculations(i)%calcs(j)%systemcall)) deallocate(calculations(i)%calcs(j)%systemcall) call calculations(i)%calcs(j)%printid(i,j) end do calculations(i)%pr_energies = .false. @@ -866,13 +872,15 @@ subroutine crest_search_multimd2(env,mols,mddats,nsim) do i = 1,T do j = 1,env%calc%ncalculations calculations(i)%calcs(j) = env%calc%calcs(j) - !>--- directories + !>--- directories and io preparation ex = directory_exist(env%calc%calcs(j)%calcspace) if (.not.ex) then io = makedir(trim(env%calc%calcs(j)%calcspace)) end if write (atmp,'(a,"_",i0)') sep,i calculations(i)%calcs(j)%calcspace = env%calc%calcs(j)%calcspace//trim(atmp) + if(allocated(calculations(i)%calcs(j)%calcfile)) deallocate(calculations(i)%calcs(j)%calcfile) + if(allocated(calculations(i)%calcs(j)%systemcall)) deallocate(calculations(i)%calcs(j)%systemcall) call calculations(i)%calcs(j)%printid(i,j) end do calculations(i)%pr_energies = .false. From b558241243adbf2b2e4c9cb97774466b952610a7 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 3 Apr 2025 15:09:14 +0200 Subject: [PATCH 045/374] simple boilerplate implementation of L-BFGS --- src/optimize/CMakeLists.txt | 1 + src/optimize/lbfgs.f90 | 282 +++++++++++++ src/optimize/optimize_module.f90 | 1 + src/optimize/optimize_type.f90 | 684 ++++++++++++++++--------------- 4 files changed, 636 insertions(+), 332 deletions(-) create mode 100644 src/optimize/lbfgs.f90 diff --git a/src/optimize/CMakeLists.txt b/src/optimize/CMakeLists.txt index 1fd034a2..a3209fc9 100644 --- a/src/optimize/CMakeLists.txt +++ b/src/optimize/CMakeLists.txt @@ -20,6 +20,7 @@ list(APPEND srcs "${dir}/ancopt.f90" "${dir}/gd.f90" "${dir}/rfo.f90" + "${dir}/lbfgs.f90" "${dir}/hessupdate.f90" "${dir}/modelhessian.f90" "${dir}/optimize_maths.f90" diff --git a/src/optimize/lbfgs.f90 b/src/optimize/lbfgs.f90 new file mode 100644 index 00000000..3a9b4924 --- /dev/null +++ b/src/optimize/lbfgs.f90 @@ -0,0 +1,282 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2025 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module lbfgs_module + use,intrinsic :: iso_fortran_env,only:wp => real64 + use crest_calculator + use strucrd + use optimize_type !> This module provides the 'optimizer' type. + implicit none + private + + public :: lbfgs_optimize + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + function lbfgs_direction(nvar,g,k,OPT,gamma) result(d) + !******************************************************************************* + !* Two-loop recursion routine to compute the search direction. + !* + !* This function uses the stored correction pairs (S and Y) and + !* corresponding scaling factors (rho) to approximate the product + !* H*g, where H is the inverse Hessian approximation. + !* + !* The algorithm proceeds in two loops: + !* 1. The first (backward) loop computes the coefficients "alpha" and + !* subtracts corrections from the gradient. + !* 2. The second (forward) loop applies the corrections in the reverse order. + !* Finally, the result is negated to obtain the descent direction. + !* Note, this routine is NOT called for the very first iteration (k == 0) + !* + !* @param nvar Dimension of the variable space. + !* @param k Number of stored correction pairs (k ≤ m). + !* @param g Current gradient vector. + !* @param OPT optimizer type that stores the following variables + !* => S Matrix containing the s-vectors (x_{k+1} - x_k), + !* of size(nvar, m). + !* => Y Matrix containing the y-vectors (g_{k+1} - g_k), + !* of size(nvar, m). + !* => rho Array of stored values 1/(y^T*s) for each correction. + !* => alpha coefficients (get computed in this function) + !* => q temporary workspace + !* @param gamma Scaling factor for the initial Hessian approximation. + !* + !* @return d Computed search direction (negative approximate inverse + !* Hessian times g). + !******************************************************************************** + !> INPUT + integer,intent(in) :: nvar,k + type(optimizer),intent(inout) :: OPT + real(wp),intent(in) :: g(nvar) + real(wp),intent(in) :: gamma + !> OUTPUT + real(wp) :: d(nvar) + !> LOCAL + integer :: i + + associate (S => OPT%S,Y => OPT%Y,alpha => OPT%alpha,rho => OPT%rho,q => OPT%q) + + !> Initialize q with the current gradient. + q = g + + !--------------------------------------------------------- + !> First loop (backward pass): for i = k downto 1, + !> compute the coefficient alpha(i) and update q. + !--------------------------------------------------------- + do i = k,1,-1 + alpha(i) = rho(i)*dot_product(S(1:nvar,i),q) + q = q-alpha(i)*Y(1:nvar,i) + end do + + !--------------------------------------------------------- + !> Apply the initial Hessian approximation. + !> We use a scaled identity matrix H0 = gamma * I. + !--------------------------------------------------------- + d = gamma*q + + !--------------------------------------------------------- + !> Second loop (forward pass): for i = 1 to k, + !> compute the correction and update d. + !--------------------------------------------------------- + do i = 1,k + d = d+S(1:nvar,i)*(alpha(i)-rho(i)*dot_product(Y(1:nvar,i),d)) + end do + + !> The final search direction is the negative of d. + d = -d + + end associate + end function lbfgs_direction + + subroutine obj_func(x,f,g) + !************************************************************************ + !* Dummy objective function (quadratic). + !* + !* This subroutine computes the value and gradient of the objective + !* function defined as f(x) = 1/2 * x^T * x. Its gradient is simply x. + !* Replace this with your actual function evaluations. + !* + !* @param x Input variable vector. + !* @param f Output function value. + !* @param g Output gradient vector. + !*********************************************************************** + real(wp),intent(in) :: x(:) + real(wp),intent(out) :: f + real(wp),intent(out) :: g(size(x)) + f = 0.5_wp*dot_product(x,x) + g = x + end subroutine obj_func + + subroutine lbfgs_optimize(mol,calc,etot,grd,nvar,x,max_iter,m,tol,pr,io) + !************************************************************************** + !* L-BFGS Optimization Routine + !* + !* Performs optimization using the Limited-memory BFGS (L-BFGS) algorithm. + !* The routine updates the coordinate vector x to approach a local minimum of the + !* objective function. It integrates with an optimizer type (OPT) to manage the + !* correction pairs (s and y) and related internal data using associate constructs. + !* + !* The main steps include: + !* 1. Evaluating the objective function and gradient at the current x. + !* 2. Computing the search direction via the two-loop recursion (lbfgs_direction). + !* 3. Updating x using a fixed step (with the option to incorporate a line search). + !* 4. Updating the correction pairs: s = x_new - x and y = g_new - g, while managing + !* the history using a shifting strategy when full. + !* + !* @param nvar Integer. Dimension of the variable space. + !* @param x Real(wp) array. Input coordinate vector; updated with optimized values. + !* @param max_iter Integer. Maximum number of iterations allowed. + !* @param m Integer. Maximum number of stored corrections (history length). + !* @param tol Real(wp). Convergence tolerance (stopping criteria based on f). + !* @param io Integer. Output status variable (0 indicates success). + !************************************************************************** + implicit none + !> INPUT + type(coord),intent(inout) :: mol + type(calcdata),intent(in) :: calc + real(wp),intent(inout) :: etot + real(wp),intent(inout) :: grd(3,mol%nat) + integer,intent(in) :: nvar + real(wp),intent(inout) :: x(nvar) + integer,intent(in) :: max_iter,m + real(wp),intent(in) :: tol + logical,intent(in) :: pr + !> OUTPUT + integer,intent(out) :: io + !> LOCAL + type(optimizer) :: OPT + integer :: iter,k + real(wp) :: gnorm,deltaE + real(wp),allocatable :: g(:),d(:),g_new(:),x_new(:) + real(wp) :: f,f_new,gamma,step + + !> Prepare settings + io = 0 + + + !> Allocate the vectors for position, gradient, and search direction. + allocate (g(nvar),d(nvar),g_new(nvar),x_new(nvar)) + !> Allocate matrices to store up to m correction pairs (columns correspond to each stored pair). + call OPT%allocatelbfgs(nvar,m) + associate (S => OPT%S,Y => OPT%Y,rho => OPT%rho,alpha => OPT%alpha) + S = 0.0_wp + Y = 0.0_wp + rho = 0.0_wp + k = 0 ! Initially, no correction pairs are stored. + + !> Evaluate the objective function and its gradient at the starting point. + call obj_func(x,f,g) + + iter = 0 + if (pr) call print_optiter(iter) + gnorm = norm2(grd) + if (pr) then + write (*,'(" * total energy :",f14.7,1x,"Eh")',advance='no') etot + write (*,'(5x,"change ΔE",e18.7,1x,"Eh")') 0.0_wp + write (*,'(3x,"gradient norm :",f14.7,1x,"Eh/a0")') gnorm + end if + + do while (f > tol.and.iter < max_iter) + iter = iter+1 + if (pr) call print_optiter(iter) + + if (iter == 1) then + !> First iteration: use the steepest descent direction. + d = -g + else + !--------------------------------------------------------- + !> Determine the scaling factor gamma for the initial Hessian. + ! Here we use the most recent correction pair. + !--------------------------------------------------------- + if (k > 0) then + gamma = dot_product(S(1:nvar,k),Y(1:nvar,k))/ & + dot_product(Y(1:nvar,k),Y(1:nvar,k)) + else + gamma = 1.0_wp + end if + + !> Compute the search direction using the two-loop recursion. + d = lbfgs_direction(nvar,g,k,OPT,gamma) + end if + + !--------------------------------------------------------- + !> A fixed step size could be used here for simplicity. + ! In a full implementation, a line search could be used. + !--------------------------------------------------------- + step = 1.0_wp + + !> Update the position: x_new = x + step * d. + x_new = x+step*d + + !====================================================================! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Evaluate the objective and gradient at the new position. + call obj_func(x_new,f_new,g_new) + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Compute the correction pair: + ! s = x_new - x and y = g_new - g. + !--------------------------------------------------------- + if (k < m) then + !> If there is still room in the history, simply add the new pair. + k = k+1 + S(1:nvar,k) = x_new-x + Y(1:nvar,k) = g_new-g + else + !> When the history is full, shift the stored corrections and + !> insert the new pair at the end. + S(1:nvar,1:m-1) = S(1:nvar,2:m) + Y(1:nvar,1:m-1) = Y(1:nvar,2:m) + S(1:nvar,m) = x_new-x + Y(1:nvar,m) = g_new-g + end if + + !> Update the scaling factor for the new correction pair. + rho(k) = 1.0_wp/dot_product(Y(1:nvar,k),S(1:nvar,k)) + + !> Update the current position, gradient, and function value. + x = x_new + g = g_new + f = f_new + + !> Optional: print iteration information. + if (pr) then + write (*,'(" * total energy :",f14.7,1x,"Eh")',advance='no') etot + write (*,'(5x,"change ΔE",e18.7,1x,"Eh")') deltaE + write (*,'(3x,"gradient norm :",f14.7,1x,"Eh/a0")',advance='no') gnorm + end if + end do + + !> stop associating + end associate + + !> Deallocate all temporary arrays. + deallocate (g,d,g_new,x_new) + end subroutine lbfgs_optimize + +end module lbfgs_module + diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index 65322f5e..eaafb2f4 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -31,6 +31,7 @@ module optimize_module use ancopt_module use gradientdescent_module use rfo_module + use lbfgs_module use optimize_utils implicit none private diff --git a/src/optimize/optimize_type.f90 b/src/optimize/optimize_type.f90 index 1ced8342..6a659773 100644 --- a/src/optimize/optimize_type.f90 +++ b/src/optimize/optimize_type.f90 @@ -21,34 +21,46 @@ ! under the Open-source software LGPL-3.0 Licencse. !================================================================================! module optimize_type - use iso_fortran_env, only: wp=>real64 - use optimize_maths, only: detrotra8 - implicit none - - public :: optimizer - public :: convergence_log - private - - type optimizer - integer :: n !< number of atoms - integer :: n3 !< dimension of hessian - integer :: nvar !< actual dimension - real(wp) :: hlow - real(wp) :: hmax - real(wp),allocatable :: hess(:) - real(wp),allocatable :: B(:,:) - real(wp),allocatable :: eigv(:) - real(wp),allocatable :: coord(:) - real(wp),allocatable :: xyz(:,:) - contains - procedure :: allocate => allocate_anc - procedure :: allocate2 => allocate_opt - procedure :: deallocate => deallocate_anc - procedure :: write => write_anc - procedure :: new => generate_anc_blowup - procedure :: get_cartesian - end type optimizer - + use iso_fortran_env,only:wp => real64 + use optimize_maths,only:detrotra8 + implicit none + + public :: optimizer + public :: convergence_log + private + + type optimizer + !****************************************************** + !* Storage type for optimizations + !* + !* Depending on the chosen optimization algorithm + !* different variables in this will be used/allocated + !****************************************************** + integer :: n !< number of atoms + integer :: n3 !< dimension of hessian + integer :: nvar !< actual dimension + real(wp) :: hlow + real(wp) :: hmax + real(wp),allocatable :: hess(:) + real(wp),allocatable :: B(:,:) + real(wp),allocatable :: eigv(:) + real(wp),allocatable :: coord(:) + real(wp),allocatable :: xyz(:,:) + !> L-BFGS block + integer :: m !> history size + real(wp),allocatable :: S(:,:),Y(:,:) + real(wp),allocatable :: rho(:) + real(wp),allocatable :: alpha(:) + real(wp),allocatable :: q(:) + contains + procedure :: allocate => allocate_anc + procedure :: allocate2 => allocate_opt + procedure :: allocatelbfgs => allocate_lbfgs + procedure :: deallocate => deallocate_anc + procedure :: write => write_anc + procedure :: new => generate_anc_blowup + procedure :: get_cartesian + end type optimizer type :: convergence_log integer :: nlog @@ -62,7 +74,6 @@ module optimize_type interface convergence_log module procedure new_convergence_log end interface convergence_log - !========================================================================================! !========================================================================================! @@ -70,362 +81,372 @@ module optimize_type !========================================================================================! !========================================================================================! -subroutine allocate_anc(self,n,nvar,hlow,hmax) - implicit none - class(optimizer),intent(inout) :: self - integer, intent(in) :: n - integer, intent(in) :: nvar - integer :: n3 - real(wp),intent(in),optional :: hlow - real(wp),intent(in),optional :: hmax - n3 = 3*n - call self%deallocate - self%n = n - self%n3 = 3*n - self%nvar = nvar - if (present(hlow)) self%hlow = hlow - if (present(hmax)) self%hmax = hmax - allocate( self%hess(nvar*(nvar+1)/2), source = 0.0_wp ) - allocate( self%B(n3,n3), source = 0.0_wp ) - allocate( self%eigv(n3), source = 0.0_wp ) - allocate( self%coord(nvar), source = 0.0_wp ) - allocate( self%xyz(3,n), source = 0.0_wp ) -end subroutine allocate_anc - - -subroutine allocate_opt(self,n)!,nvar) - implicit none - class(optimizer),intent(inout) :: self - integer, intent(in) :: n - !integer, intent(in) :: nvar - integer :: nvar - integer :: n3 - !real(wp),intent(in),optional :: hlow - !real(wp),intent(in),optional :: hmax - n3 = 3*n - call self%deallocate - self%n = n - self%n3 = 3*n - nvar = 3*n - self%nvar = nvar - allocate( self%hess(nvar*(nvar+1)/2), source = 0.0_wp ) - !allocate( self%B(n3,n3), source = 0.0_wp ) - allocate( self%eigv(n3), source = 0.0_wp ) - !allocate( self%coord(nvar), source = 0.0_wp ) - !allocate( self%xyz(3,n), source = 0.0_wp ) -end subroutine allocate_opt - - + subroutine allocate_anc(self,n,nvar,hlow,hmax) + implicit none + class(optimizer),intent(inout) :: self + integer,intent(in) :: n + integer,intent(in) :: nvar + integer :: n3 + real(wp),intent(in),optional :: hlow + real(wp),intent(in),optional :: hmax + n3 = 3*n + call self%deallocate + self%n = n + self%n3 = 3*n + self%nvar = nvar + if (present(hlow)) self%hlow = hlow + if (present(hmax)) self%hmax = hmax + allocate (self%hess(nvar*(nvar+1)/2),source=0.0_wp) + allocate (self%B(n3,n3),source=0.0_wp) + allocate (self%eigv(n3),source=0.0_wp) + allocate (self%coord(nvar),source=0.0_wp) + allocate (self%xyz(3,n),source=0.0_wp) + end subroutine allocate_anc + + subroutine allocate_opt(self,n) + implicit none + class(optimizer),intent(inout) :: self + integer,intent(in) :: n + integer :: nvar + integer :: n3 + n3 = 3*n + call self%deallocate + self%n = n + self%n3 = 3*n + nvar = 3*n + self%nvar = nvar + allocate (self%hess(nvar*(nvar+1)/2),source=0.0_wp) + allocate (self%eigv(n3),source=0.0_wp) + end subroutine allocate_opt + + subroutine allocate_lbfgs(self,nvar,mem) + implicit none + class(optimizer),intent(inout) :: self + integer,intent(in) :: nvar,mem + call self%deallocate + self%m = mem + self%nvar = nvar + allocate(self%S(nvar,mem)) + allocate(self%Y(nvar,mem)) + allocate(self%rho(mem)) + allocate(self%alpha(mem)) + allocate(self%q(nvar)) + end subroutine allocate_lbfgs !========================================================================================! -subroutine deallocate_anc(self) - implicit none - class(optimizer),intent(inout) :: self - self%n = 0 - self%n3 = 0 - self%nvar = 0 - if (allocated(self%hess )) deallocate( self%hess ) - if (allocated(self%B )) deallocate( self%B ) - if (allocated(self%eigv )) deallocate( self%eigv ) - if (allocated(self%coord)) deallocate( self%coord ) - if (allocated(self%xyz )) deallocate( self%xyz ) -end subroutine deallocate_anc + subroutine deallocate_anc(self) + implicit none + class(optimizer),intent(inout) :: self + self%n = 0 + self%n3 = 0 + self%nvar = 0 + if (allocated(self%hess)) deallocate (self%hess) + if (allocated(self%B)) deallocate (self%B) + if (allocated(self%eigv)) deallocate (self%eigv) + if (allocated(self%coord)) deallocate (self%coord) + if (allocated(self%xyz)) deallocate (self%xyz) + if (allocated(self%S)) deallocate (self%S) + if (allocated(self%Y)) deallocate (self%Y) + if (allocated(self%rho)) deallocate (self%rho) + if (allocated(self%alpha)) deallocate (self%alpha) + if (allocated(self%q)) deallocate(self%q) + end subroutine deallocate_anc !========================================================================================! !> @brief print information about current approximate normal coordinates to unit -subroutine write_anc(self,iunit,comment) - implicit none - class(optimizer), intent(in) :: self !< approximate normal coordinates - integer, intent(in) :: iunit !< file handle - character(len=*),intent(in) :: comment !< name of the variable - character(len=*),parameter :: dfmt = '(1x,a,1x,"=",1x,g0)' - - write(iunit,'(72(">"))') - write(iunit,'(1x,"*",1x,a)') "Writing 'optimizer' class" - write(iunit,'( "->",1x,a)') comment - write(iunit,'(72("-"))') - write(iunit,'(1x,"*",1x,a)') "status of the fields" - write(iunit,dfmt) "integer :: n ",self%n - write(iunit,dfmt) "integer :: n3 ",self%n3 - write(iunit,dfmt) "integer :: nvar ",self%nvar - write(iunit,dfmt) "real :: hlow ",self%hlow - write(iunit,dfmt) "real :: hmax ",self%hmax - write(iunit,'(72("-"))') - write(iunit,'(1x,"*",1x,a)') "allocation status" - write(iunit,dfmt) "allocated? hess(:) ",allocated(self%hess) - write(iunit,dfmt) "allocated? B(:) ",allocated(self%B) - write(iunit,dfmt) "allocated? eigv(:) ",allocated(self%eigv) - write(iunit,dfmt) "allocated? coord(:) ",allocated(self%coord) - write(iunit,dfmt) "allocated? xyz(:,:) ",allocated(self%xyz) - write(iunit,'(72("-"))') - write(iunit,'(1x,"*",1x,a)') "size of memory allocation" - if (allocated(self%hess)) then - write(iunit,dfmt) "size(1) :: hess(*) ",size(self%hess,1) - endif - if (allocated(self%B)) then - write(iunit,dfmt) "size(1) :: B(*,:) ",size(self%B,1) - write(iunit,dfmt) "size(2) :: B(:,*) ",size(self%B,2) - endif - if (allocated(self%eigv)) then - write(iunit,dfmt) "size(1) :: eigv(*) ",size(self%eigv,1) - endif - if (allocated(self%coord)) then - write(iunit,dfmt) "size(1) :: coord(*) ",size(self%coord,1) - endif - if (allocated(self%xyz)) then - write(iunit,dfmt) "size(1) :: xyz(*,:) ",size(self%xyz,1) - write(iunit,dfmt) "size(2) :: xyz(:,*) ",size(self%xyz,2) - endif - write(iunit,'(72("<"))') -end subroutine write_anc + subroutine write_anc(self,iunit,comment) + implicit none + class(optimizer),intent(in) :: self !< approximate normal coordinates + integer,intent(in) :: iunit !< file handle + character(len=*),intent(in) :: comment !< name of the variable + character(len=*),parameter :: dfmt = '(1x,a,1x,"=",1x,g0)' + + write (iunit,'(72(">"))') + write (iunit,'(1x,"*",1x,a)') "Writing 'optimizer' class" + write (iunit,'( "->",1x,a)') comment + write (iunit,'(72("-"))') + write (iunit,'(1x,"*",1x,a)') "status of the fields" + write (iunit,dfmt) "integer :: n ",self%n + write (iunit,dfmt) "integer :: n3 ",self%n3 + write (iunit,dfmt) "integer :: nvar ",self%nvar + write (iunit,dfmt) "real :: hlow ",self%hlow + write (iunit,dfmt) "real :: hmax ",self%hmax + write (iunit,'(72("-"))') + write (iunit,'(1x,"*",1x,a)') "allocation status" + write (iunit,dfmt) "allocated? hess(:) ",allocated(self%hess) + write (iunit,dfmt) "allocated? B(:) ",allocated(self%B) + write (iunit,dfmt) "allocated? eigv(:) ",allocated(self%eigv) + write (iunit,dfmt) "allocated? coord(:) ",allocated(self%coord) + write (iunit,dfmt) "allocated? xyz(:,:) ",allocated(self%xyz) + write (iunit,'(72("-"))') + write (iunit,'(1x,"*",1x,a)') "size of memory allocation" + if (allocated(self%hess)) then + write (iunit,dfmt) "size(1) :: hess(*) ",size(self%hess,1) + end if + if (allocated(self%B)) then + write (iunit,dfmt) "size(1) :: B(*,:) ",size(self%B,1) + write (iunit,dfmt) "size(2) :: B(:,*) ",size(self%B,2) + end if + if (allocated(self%eigv)) then + write (iunit,dfmt) "size(1) :: eigv(*) ",size(self%eigv,1) + end if + if (allocated(self%coord)) then + write (iunit,dfmt) "size(1) :: coord(*) ",size(self%coord,1) + end if + if (allocated(self%xyz)) then + write (iunit,dfmt) "size(1) :: xyz(*,:) ",size(self%xyz,1) + write (iunit,dfmt) "size(2) :: xyz(:,*) ",size(self%xyz,2) + end if + write (iunit,'(72("<"))') + end subroutine write_anc !========================================================================================! -subroutine generate_anc_blowup(self,xyz,hess,pr,linear,fail) - implicit none - class(optimizer),intent(inout) :: self - real(wp), intent(in) :: xyz(3,self%n) - real(wp), intent(inout) :: hess(self%n3,self%n3) - logical, intent(in) :: pr - logical, intent(in) :: linear - logical, intent(out) :: fail + subroutine generate_anc_blowup(self,xyz,hess,pr,linear,fail) + implicit none + class(optimizer),intent(inout) :: self + real(wp),intent(in) :: xyz(3,self%n) + real(wp),intent(inout) :: hess(self%n3,self%n3) + logical,intent(in) :: pr + logical,intent(in) :: linear + logical,intent(out) :: fail - real(wp),parameter :: thr1 = 1.0e-10_wp - real(wp),parameter :: thr2 = 1.0e-11_wp - integer, parameter :: maxtry = 4 - integer :: i,itry - integer :: nvar - integer :: info - integer :: lwork - integer :: liwork - integer, allocatable :: iwork(:) - real(wp) :: elow,damp,thr - real(wp),allocatable :: aux(:) + real(wp),parameter :: thr1 = 1.0e-10_wp + real(wp),parameter :: thr2 = 1.0e-11_wp + integer,parameter :: maxtry = 4 + integer :: i,itry + integer :: nvar + integer :: info + integer :: lwork + integer :: liwork + integer,allocatable :: iwork(:) + real(wp) :: elow,damp,thr + real(wp),allocatable :: aux(:) - !> LAPACK - external :: dsyevd + !> LAPACK + external :: dsyevd - fail = .false. - self%xyz = xyz + fail = .false. + self%xyz = xyz - thr = thr2 - lwork = 1 + 6*self%n3 + 2*self%n3**2 - liwork = 8 * self%n3 + thr = thr2 + lwork = 1+6*self%n3+2*self%n3**2 + liwork = 8*self%n3 - allocate(iwork(liwork), source = 0 ) - allocate(aux(lwork), source = 0.0_wp ) + allocate (iwork(liwork),source=0) + allocate (aux(lwork),source=0.0_wp) - call dsyevd('V','U',self%n3,hess,self%n3,self%eigv, & - & aux,lwork,iwork,liwork,info) + call dsyevd('V','U',self%n3,hess,self%n3,self%eigv, & + & aux,lwork,iwork,liwork,info) - deallocate(aux,iwork) + deallocate (aux,iwork) - call detrotra8(linear,self%n,self%xyz,hess,self%eigv) + call detrotra8(linear,self%n,self%xyz,hess,self%eigv) - elow = minval(self%eigv,mask=(abs(self%eigv) > thr1)) + elow = minval(self%eigv,mask=(abs(self%eigv) > thr1)) - damp = max(self%hlow - elow,0.0_wp) - where(abs(self%eigv) > thr2) self%eigv = self%eigv + damp + damp = max(self%hlow-elow,0.0_wp) + where (abs(self%eigv) > thr2) self%eigv = self%eigv+damp ! do i = 1, self%n3 ! if (abs(self%eigv(i)) > thr2 ) self%eigv(i) = self%eigv(i) + damp ! enddo - if(pr)then - write(*,*) 'Shifting diagonal of input Hessian by ', damp - write(*,*) 'Lowest eigenvalues of input Hessian' - write(*,'(6F12.6)')(self%eigv(i),i=1,min(18,self%n3)) - write(*,*) 'Highest eigenvalues' - write(*,'(6F12.6)')(self%eigv(i),i=self%n3-5,self%n3) - write(*,*) - endif - - fail = .true. - get_anc: do itry = 1, maxtry + if (pr) then + write (*,*) 'Shifting diagonal of input Hessian by ',damp + write (*,*) 'Lowest eigenvalues of input Hessian' + write (*,'(6F12.6)') (self%eigv(i),i=1,min(18,self%n3)) + write (*,*) 'Highest eigenvalues' + write (*,'(6F12.6)') (self%eigv(i),i=self%n3-5,self%n3) + write (*,*) + end if + + fail = .true. + get_anc: do itry = 1,maxtry self%B = 0.0_wp self%hess = 0.0_wp nvar = 0 ! take largest (positive) first - do i = self%n3, 1, -1 - if (abs(self%eigv(i)) > thr .and. nvar < self%nvar) then - nvar = nvar+1 - self%B(:,nvar) = hess(:,i) - self%hess(nvar+nvar*(nvar-1)/2) = & - min(max(self%eigv(i),self%hlow),self%hmax) - endif - enddo - - if (nvar.ne.self%nvar) then - thr = thr * 0.1_wp - cycle get_anc - endif + do i = self%n3,1,-1 + if (abs(self%eigv(i)) > thr.and.nvar < self%nvar) then + nvar = nvar+1 + self%B(:,nvar) = hess(:,i) + self%hess(nvar+nvar*(nvar-1)/2) = & + min(max(self%eigv(i),self%hlow),self%hmax) + end if + end do + + if (nvar .ne. self%nvar) then + thr = thr*0.1_wp + cycle get_anc + end if fail = .false. exit get_anc - enddo get_anc + end do get_anc - if (fail) then - if(pr) write(*,*) 'nvar, self%nvar',nvar,self%nvar + if (fail) then + if (pr) write (*,*) 'nvar, self%nvar',nvar,self%nvar return - end if + end if - call sort(self%n3,self%nvar,self%hess,self%B) + call sort(self%n3,self%nvar,self%hess,self%B) - self%coord = 0.0_wp - return -end subroutine generate_anc_blowup + self%coord = 0.0_wp + return + end subroutine generate_anc_blowup !========================================================================================! -subroutine generate_anc_packed(self,xyz,hess,pr,fail) - implicit none - class(optimizer),intent(inout) :: self - real(wp), intent(in) :: xyz(3,self%n) - real(wp), intent(inout) :: hess(self%n3*(self%n3+1)/2) - logical, intent(in) :: pr - logical, intent(out) :: fail - - real(wp),parameter :: thr1 = 1.0e-10_wp - real(wp),parameter :: thr2 = 1.0e-11_wp - integer, parameter :: maxtry = 4 - integer :: i,itry - integer :: nvar - integer :: info - integer :: lwork - integer :: liwork - integer, allocatable :: iwork(:) - real(wp) :: elow,damp,thr - real(wp),allocatable :: aux(:) - real(wp),allocatable :: u(:,:) - - !> LAPACK - external :: dspevd - - self%xyz = xyz - - thr = thr2 - lwork = 1 + 6*self%n3 + 2*self%n3**2 - liwork = 8 * self%n3 - - allocate(iwork(liwork), source = 0 ) - allocate(aux(lwork), source = 0.0_wp ) - allocate(u(self%n3,self%n3), source = 0.0_wp ) - - call dspevd('V','U',self%n3,hess,self%eigv,u,self%n3, & - & aux,lwork,iwork,liwork,info) - - !elow = 1.0e+99_wp - elow = minval(self%eigv,mask=(abs(self%eigv) > thr1)) - !do i = 1, self%n3 - ! if (abs(self%eigv(i)) > thr1 ) elow = min(elow,self%eigv(i)) - !enddo - - damp = max(self%hlow - elow,0.0_wp) - where(abs(self%eigv) > thr2) self%eigv = self%eigv + damp + subroutine generate_anc_packed(self,xyz,hess,pr,fail) + implicit none + class(optimizer),intent(inout) :: self + real(wp),intent(in) :: xyz(3,self%n) + real(wp),intent(inout) :: hess(self%n3*(self%n3+1)/2) + logical,intent(in) :: pr + logical,intent(out) :: fail + + real(wp),parameter :: thr1 = 1.0e-10_wp + real(wp),parameter :: thr2 = 1.0e-11_wp + integer,parameter :: maxtry = 4 + integer :: i,itry + integer :: nvar + integer :: info + integer :: lwork + integer :: liwork + integer,allocatable :: iwork(:) + real(wp) :: elow,damp,thr + real(wp),allocatable :: aux(:) + real(wp),allocatable :: u(:,:) + + !> LAPACK + external :: dspevd + + self%xyz = xyz + + thr = thr2 + lwork = 1+6*self%n3+2*self%n3**2 + liwork = 8*self%n3 + + allocate (iwork(liwork),source=0) + allocate (aux(lwork),source=0.0_wp) + allocate (u(self%n3,self%n3),source=0.0_wp) + + call dspevd('V','U',self%n3,hess,self%eigv,u,self%n3, & + & aux,lwork,iwork,liwork,info) + + !elow = 1.0e+99_wp + elow = minval(self%eigv,mask=(abs(self%eigv) > thr1)) + !do i = 1, self%n3 + ! if (abs(self%eigv(i)) > thr1 ) elow = min(elow,self%eigv(i)) + !enddo + + damp = max(self%hlow-elow,0.0_wp) + where (abs(self%eigv) > thr2) self%eigv = self%eigv+damp ! do i = 1, self%n3 ! if (abs(self%eigv(i)) > thr2 ) self%eigv(i) = self%eigv(i) + damp ! enddo - if(pr)then - write(*,*) 'Shifting diagonal of input Hessian by ', damp - write(*,*) 'Lowest eigenvalues of input Hessian' - write(*,'(6F12.6)')(self%eigv(i),i=1,min(18,self%n3)) - write(*,*) 'Highest eigenvalues' - write(*,'(6F12.6)')(self%eigv(i),i=self%n3-5,self%n3) - write(*,*) - endif - - fail = .true. - get_anc: do itry = 1, maxtry + if (pr) then + write (*,*) 'Shifting diagonal of input Hessian by ',damp + write (*,*) 'Lowest eigenvalues of input Hessian' + write (*,'(6F12.6)') (self%eigv(i),i=1,min(18,self%n3)) + write (*,*) 'Highest eigenvalues' + write (*,'(6F12.6)') (self%eigv(i),i=self%n3-5,self%n3) + write (*,*) + end if + + fail = .true. + get_anc: do itry = 1,maxtry self%B = 0.0_wp self%hess = 0.0_wp nvar = 0 ! take largest (positive) first - do i = self%n3, 1, -1 - if (abs(self%eigv(i)) > thr .and. nvar < self%nvar) then - nvar = nvar+1 - self%B(:,nvar) = u(:,i) - self%hess(nvar+nvar*(nvar-1)/2) = & - min(max(self%eigv(i),self%hlow),self%hmax) - endif - enddo - - if (nvar.ne.self%nvar) then - thr = thr * 0.1_wp - cycle get_anc - endif + do i = self%n3,1,-1 + if (abs(self%eigv(i)) > thr.and.nvar < self%nvar) then + nvar = nvar+1 + self%B(:,nvar) = u(:,i) + self%hess(nvar+nvar*(nvar-1)/2) = & + min(max(self%eigv(i),self%hlow),self%hmax) + end if + end do + + if (nvar .ne. self%nvar) then + thr = thr*0.1_wp + cycle get_anc + end if fail = .false. exit get_anc - enddo get_anc + end do get_anc - if (fail) then - if(pr) write(*,*) 'nvar, selv%nvar',nvar,self%nvar + if (fail) then + if (pr) write (*,*) 'nvar, selv%nvar',nvar,self%nvar return - end if + end if - call sort(self%n3,self%nvar,self%hess,self%B) + call sort(self%n3,self%nvar,self%hess,self%B) - self%coord = 0.0_wp - return -end subroutine generate_anc_packed + self%coord = 0.0_wp + return + end subroutine generate_anc_packed !========================================================================================! -pure subroutine sort(nat3,nvar,hess,b) - implicit none - integer :: ii,k,j,m,i - integer, intent(in) :: nat3,nvar - real(wp),intent(inout) :: hess(nvar*(nvar+1)/2) - real(wp),intent(inout) :: b(nat3,nat3) - real(wp) :: pp,sc1 - real(wp),allocatable :: edum(:) - allocate( edum(nvar), source = 0.0_wp ) - - do k=1,nvar - edum(k)=hess(k+k*(k-1)/2) - enddo + pure subroutine sort(nat3,nvar,hess,b) + implicit none + integer :: ii,k,j,m,i + integer,intent(in) :: nat3,nvar + real(wp),intent(inout) :: hess(nvar*(nvar+1)/2) + real(wp),intent(inout) :: b(nat3,nat3) + real(wp) :: pp,sc1 + real(wp),allocatable :: edum(:) + allocate (edum(nvar),source=0.0_wp) + + do k = 1,nvar + edum(k) = hess(k+k*(k-1)/2) + end do ! sort - do ii = 2, nvar - i = ii - 1 + do ii = 2,nvar + i = ii-1 k = i - pp= edum(i) - do j = ii, nvar - if (edum(j) .gt. pp) cycle - k = j - pp= edum(j) - enddo + pp = edum(i) + do j = ii,nvar + if (edum(j) .gt. pp) cycle + k = j + pp = edum(j) + end do if (k .eq. i) cycle edum(k) = edum(i) edum(i) = pp - do m=1,nat3 - sc1=b(m,i) - b(m,i)=b(m,k) - b(m,k)=sc1 - enddo - enddo - - do k=1,nvar - hess(k+k*(k-1)/2)=edum(k) - enddo - return -end subroutine sort + do m = 1,nat3 + sc1 = b(m,i) + b(m,i) = b(m,k) + b(m,k) = sc1 + end do + end do + + do k = 1,nvar + hess(k+k*(k-1)/2) = edum(k) + end do + return + end subroutine sort !========================================================================================! -subroutine get_cartesian(self,xyz) - implicit none - class(optimizer),intent(in) :: self - integer :: m,i,j,k - real(wp),intent(out) :: xyz (3,self%n) - real(wp) :: dum + subroutine get_cartesian(self,xyz) + implicit none + class(optimizer),intent(in) :: self + integer :: m,i,j,k + real(wp),intent(out) :: xyz(3,self%n) + real(wp) :: dum external :: dgemv !> generate cartesian displacement vector - xyz = self%xyz - call dgemv('n',self%n3,self%nvar,1.0_wp,self%B,self%n3,self%coord,1,1.0_wp,xyz,1) - return -end subroutine get_cartesian + xyz = self%xyz + call dgemv('n',self%n3,self%nvar,1.0_wp,self%B,self%n3,self%coord,1,1.0_wp,xyz,1) + return + end subroutine get_cartesian !========================================================================================! @@ -445,17 +466,17 @@ pure function get_averaged_energy(self) result(val) ! only apply it if sufficient number of points i.e. a "tail" can exist ! with the censo blockl = 8 default, this can first be effective in the second - if (self%nlog .lt. 3 * nav) then + if (self%nlog .lt. 3*nav) then val = self%elog(self%nlog) else - low = max(1,self%nlog - nav + 1) + low = max(1,self%nlog-nav+1) j = 0 eav = 0 do i = self%nlog,low,-1 - j = j + 1 - eav = eav + self%elog(i) + j = j+1 + eav = eav+self%elog(i) end do - val = eav / float(j) + val = eav/float(j) end if end function get_averaged_energy @@ -468,20 +489,20 @@ pure function get_averaged_gradient(self) result(deriv) ! only apply it if sufficient number of points i.e. a "tail" can exist ! with the censo blockl = 8 default, this can first be effective in the second - if (self%nlog .lt. 3 * nav) then + if (self%nlog .lt. 3*nav) then deriv = self%glog(self%nlog) else - low = max(1,self%nlog - nav + 1) + low = max(1,self%nlog-nav+1) j = 0 gav = 0 do i = self%nlog,low,-1 - j = j + 1 - gav = gav + self%glog(i) + j = j+1 + gav = gav+self%glog(i) end do ! adjust the gradient norm to xtb "conventions" because e.g. a noisy ! DCOSMO-RS gradient for large cases can never (even on average) ! become lower than the "-opt normal" thresholds - deriv = gav / float(j) / 2.d0 + deriv = gav/float(j)/2.d0 end if end function get_averaged_gradient @@ -493,7 +514,7 @@ pure subroutine set_eg_log(self,e,g) integer :: k,k2 k = size(self%elog) if (self%nlog >= k) then - k2 = k + 1 + k2 = k+1 allocate (dum(k2)) dum(1:k) = self%elog(1:k) call move_alloc(dum,self%elog) @@ -501,12 +522,11 @@ pure subroutine set_eg_log(self,e,g) dum(1:k) = self%glog(1:k) call move_alloc(dum,self%glog) end if - self%nlog = self%nlog + 1 + self%nlog = self%nlog+1 self%elog(self%nlog) = e self%glog(self%nlog) = g end subroutine set_eg_log - !========================================================================================! !========================================================================================! end module optimize_type From a88395a60d3ae12cfe9bdf27a2554ff742043bd6 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 4 Apr 2025 10:06:15 +0200 Subject: [PATCH 046/374] Rename crestopt.log to crestopt.log.xyz and crest_dynamics.trj crest_dynamics.trj.xyz to conform with file endings --- src/algos/dynamics.f90 | 2 +- src/algos/optimization.f90 | 2 +- src/algos/parallel.f90 | 12 ++++++------ src/algos/scan.f90 | 2 +- src/algos/search_1.f90 | 4 ++-- src/algos/search_conformers.f90 | 6 +++--- src/algos/search_entropy.f90 | 8 ++++---- src/algos/search_mecp.f90 | 4 ++-- src/algos/search_newnci.f90 | 4 ++-- src/algos/setuptest.f90 | 8 ++++---- src/optimize/ancopt.f90 | 4 ++-- src/optimize/gd.f90 | 4 ++-- src/optimize/optutils.f90 | 2 +- src/optimize/rfo.f90 | 4 ++-- 14 files changed, 33 insertions(+), 33 deletions(-) diff --git a/src/algos/dynamics.f90 b/src/algos/dynamics.f90 index ff351e92..f315e5bc 100644 --- a/src/algos/dynamics.f90 +++ b/src/algos/dynamics.f90 @@ -39,7 +39,7 @@ subroutine crest_moleculardynamics(env,tim) real(wp),allocatable :: grad(:,:) character(len=80) :: atmp - character(len=*),parameter :: trjf='crest_dynamics.trj' + character(len=*),parameter :: trjf='crest_dynamics.trj.xyz' !========================================================================================! write(stdout,*) !call system('figlet dynamics') diff --git a/src/algos/optimization.f90 b/src/algos/optimization.f90 index 775c0414..161804fd 100644 --- a/src/algos/optimization.f90 +++ b/src/algos/optimization.f90 @@ -69,7 +69,7 @@ subroutine crest_optimization(env,tim) !>-- geometry optimization pr = .true. !> stdout printout - wr = .true. !> write crestopt.log + wr = .true. !> write crestopt.log.xyz !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<--- printout directions and timer initialization pr = .false. !> stdout printout - wr = .false. !> write crestopt.log + wr = .false. !> write crestopt.log.xyz call profiler%init(1) call profiler%start(1) @@ -330,7 +330,7 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) !>--- printout directions and timer initialization pr = .false. !> stdout printout - wr = .false. !> write crestopt.log + wr = .false. !> write crestopt.log.xyz if (dump) then open (newunit=ich,file=ensemblefile) open (newunit=ich2,file=ensembleelog) @@ -542,7 +542,7 @@ subroutine crest_search_multimd(env,mol,mddats,nsim) !===========================================================! !>--- decide wether to skip this call if (trackrestart(env)) then - call restart_write_dummy('crest_dynamics.trj') + call restart_write_dummy('crest_dynamics.trj.xyz') return end if @@ -643,7 +643,7 @@ subroutine collect(n,mddats) integer :: i,io,ich,ich2 character(len=:),allocatable :: atmp character(len=256) :: btmp - open (newunit=ich,file='crest_dynamics.trj') + open (newunit=ich,file='crest_dynamics.trj.xyz') do i = 1,n atmp = mddats(i)%trajectoryfile inquire (file=atmp,exist=ex) @@ -850,7 +850,7 @@ subroutine crest_search_multimd2(env,mols,mddats,nsim) !===========================================================! !>--- decide wether to skip this call if (trackrestart(env)) then - call restart_write_dummy('crest_dynamics.trj') + call restart_write_dummy('crest_dynamics.trj.xyz') return end if @@ -944,7 +944,7 @@ subroutine collect(n,mddats) integer :: i,io,ich,ich2 character(len=:),allocatable :: atmp character(len=256) :: btmp - open (newunit=ich,file='crest_dynamics.trj') + open (newunit=ich,file='crest_dynamics.trj.xyz') do i = 1,n atmp = mddats(i)%trajectoryfile inquire (file=atmp,exist=ex) diff --git a/src/algos/scan.f90 b/src/algos/scan.f90 index 0a40d94d..abf20a48 100644 --- a/src/algos/scan.f90 +++ b/src/algos/scan.f90 @@ -287,7 +287,7 @@ recursive subroutine runscan(mol,calc,calcclean,current) allocate (grad(3,mol%nat),source=0.0_wp) !>-- geometry optimization pr = .false. !> stdout printout - wr = .true. !> write crestopt.log + wr = .true. !> write crestopt.log.xyz molbackup = mol do j=1,calc%scans(current)%steps !write(*,*) current, calc%scans(current)%steps, j diff --git a/src/algos/search_1.f90 b/src/algos/search_1.f90 index 8b4d9ae9..14613288 100644 --- a/src/algos/search_1.f90 +++ b/src/algos/search_1.f90 @@ -82,8 +82,8 @@ subroutine crest_search_1(env,tim) call tim%start(2,'Molecular dynamics (MD)') call crest_search_multimd(env,mol,mddats,nsim) call tim%stop(2) -!>--- a file called crest_dynamics.trj should have been written - ensnam = 'crest_dynamics.trj' +!>--- a file called crest_dynamics.trj.xyz should have been written + ensnam = 'crest_dynamics.trj.xyz' !==========================================================! !>--- Reoptimization of trajectories diff --git a/src/algos/search_conformers.f90 b/src/algos/search_conformers.f90 index d86d9416..07ce7519 100644 --- a/src/algos/search_conformers.f90 +++ b/src/algos/search_conformers.f90 @@ -124,8 +124,8 @@ subroutine crest_search_imtdgc(env,tim) call tim%start(2,'Metadynamics (MTD)') call crest_search_multimd(env,mol,mddats,nsim) call tim%stop(2) -!>--- a file called crest_dynamics.trj should have been written - ensnam = 'crest_dynamics.trj' +!>--- a file called crest_dynamics.trj.xyz should have been written + ensnam = 'crest_dynamics.trj.xyz' !>--- deallocate for next iteration if(allocated(mddats))deallocate(mddats) @@ -193,7 +193,7 @@ subroutine crest_search_imtdgc(env,tim) !>--- Reoptimization of trajectories call checkname_xyz(crefile,atmp,btmp) write(stdout,'('' Appending file '',a,'' with new structures'')')trim(atmp) - ensnam = 'crest_dynamics.trj' + ensnam = 'crest_dynamics.trj.xyz' call appendto(ensnam,trim(atmp)) call tim%start(3,'Geometry optimization') call crest_multilevel_wrap(env,trim(atmp),-1) diff --git a/src/algos/search_entropy.f90 b/src/algos/search_entropy.f90 index 9c1b8c77..c273cdca 100644 --- a/src/algos/search_entropy.f90 +++ b/src/algos/search_entropy.f90 @@ -130,8 +130,8 @@ subroutine crest_search_entropy(env,tim) call tim%start(2,'Metadynamics (MTD)') call crest_search_multimd(env,mol,mddats,nsim) call tim%stop(2) -!>--- a file called crest_dynamics.trj should have been written - ensnam = 'crest_dynamics.trj' +!>--- a file called crest_dynamics.trj.xyz should have been written + ensnam = 'crest_dynamics.trj.xyz' !>--- deallocate for next iteration if (allocated(mddats)) deallocate (mddats) @@ -373,10 +373,10 @@ subroutine crest_smtd_mds(env,ensnam) !===================================================================! !>--- and finally, run the sMTDs on the different starting structures call crest_search_multimd2(env,mols,mddats,nsim) -!>--- output will be collected in crest_dynamics.trj +!>--- output will be collected in crest_dynamics.trj.xyz !>--- but the entropy routines look for the crest_rotamers_ files call checkname_xyz(crefile,atmp,btmp) - call rename('crest_dynamics.trj',atmp) + call rename('crest_dynamics.trj.xyz',atmp) !===================================================================! !>--- by default, clean up the directory if (.not.env%keepModef) call cleanMTD diff --git a/src/algos/search_mecp.f90 b/src/algos/search_mecp.f90 index b480fbfe..c0f8ae45 100644 --- a/src/algos/search_mecp.f90 +++ b/src/algos/search_mecp.f90 @@ -72,8 +72,8 @@ subroutine crest_search_mecp(env,tim) call tim%start(2,'Molecular dynamics (MD)') call crest_search_multimd(env,mol,mddats,nsim) call tim%stop(2) - !>--- a file called crest_dynamics.trj should have been written - ensnam = 'crest_dynamics.trj' + !>--- a file called crest_dynamics.trj.xyz should have been written + ensnam = 'crest_dynamics.trj.xyz' !==========================================================! !>--- Reoptimization of trajectories diff --git a/src/algos/search_newnci.f90 b/src/algos/search_newnci.f90 index 2472b28c..f5323e1e 100644 --- a/src/algos/search_newnci.f90 +++ b/src/algos/search_newnci.f90 @@ -121,8 +121,8 @@ subroutine crest_search_newnci(env,tim) call tim%start(2,'Metadynamics (MTD)') call crest_search_multimd(env,mol,mddats,nsim) call tim%stop(2) -!>--- a file called crest_dynamics.trj should have been written - ensnam = 'crest_dynamics.trj' +!>--- a file called crest_dynamics.trj.xyz should have been written + ensnam = 'crest_dynamics.trj.xyz' !>--- deallocate for next iteration if (allocated(mddats)) deallocate (mddats) diff --git a/src/algos/setuptest.f90 b/src/algos/setuptest.f90 index c118957d..c9038590 100644 --- a/src/algos/setuptest.f90 +++ b/src/algos/setuptest.f90 @@ -304,9 +304,9 @@ subroutine trialOPT_calculator(env) !>--- perform geometry optimization pr = .false. !> stdout printout - wr = .true. !> write crestopt.log + wr = .true. !> write crestopt.log.xyz if(wr)then - call remove('crestopt.log') + call remove('crestopt.log.xyz') endif call optimize_geometry(mol,molopt,tmpcalc,energy,grd,pr,wr,io) @@ -348,7 +348,7 @@ subroutine trialOPT_warning(env,mol,success) if (.not.success) then write (stdout,*) write (stdout,*) ' Initial geometry optimization failed!' - write (stdout,*) ' Please check your input and, if present, crestopt.log.' + write (stdout,*) ' Please check your input and, if present, crestopt.log.xyz.' call creststop(status_failed) end if write (stdout,*) 'Geometry successfully optimized.' @@ -392,7 +392,7 @@ subroutine trialOPT_warning(env,mol,success) if (env%legacy) then write (stdout,'(1x,a)') 'You can check the optimization trajectory in the "xtbopt.log" file.' else - write (stdout,'(1x,a)') 'You can check the optimization trajectory in the "crestopt.log" file.' + write (stdout,'(1x,a)') 'You can check the optimization trajectory in the "crestopt.log.xyz" file.' end if write (stdout,'(1x,a)') 'Try either of these options:' write (stdout,'(/,4x,a)') 'A) Pre-optimize your input seperately and use the optimized' diff --git a/src/optimize/ancopt.f90 b/src/optimize/ancopt.f90 index 287f46b5..032acb1d 100644 --- a/src/optimize/ancopt.f90 +++ b/src/optimize/ancopt.f90 @@ -61,7 +61,7 @@ subroutine ancopt(mol,calc,etot,grd,pr,wr,iostatus) !> on output final energy !> grd - Cartesian gradient !> pr - printout bool -!> wr - logfile (crestopt.log) bool +!> wr - logfile (crestopt.log.xyz) bool !> iostatus - return status of the routine !> (success=0, error<0, not converged>0) !!*********************************************************************** @@ -171,7 +171,7 @@ subroutine ancopt(mol,calc,etot,grd,pr,wr,iostatus) !>--- initialize .log file, if desired ilog = 942 if (wr) then - open (newunit=ilog,file='crestopt.log') + open (newunit=ilog,file='crestopt.log.xyz') end if !>--- The ANCOPT iteration loop. "iter" is updated in relax() subroutine diff --git a/src/optimize/gd.f90 b/src/optimize/gd.f90 index 00c57bfe..7de349f5 100644 --- a/src/optimize/gd.f90 +++ b/src/optimize/gd.f90 @@ -57,7 +57,7 @@ subroutine gradientdescent(mol,calc,etot,grd,pr,wr,iostatus) !> on output final energy !> grd - Cartesian gradient !> pr - printout bool -!> wr - logfile (crestopt.log) bool +!> wr - logfile (crestopt.log.xyz) bool !> iostatus - return status of the routine !> (success=0, error<0, not converged>0) !!*********************************************************************** @@ -164,7 +164,7 @@ subroutine gradientdescent(mol,calc,etot,grd,pr,wr,iostatus) !>--- initialize .log file, if desired ilog = 942 if (wr) then - open (newunit=ilog,file='crestopt.log') + open (newunit=ilog,file='crestopt.log.xyz') end if !>--- The gradient descent iteration loop. "iter" diff --git a/src/optimize/optutils.f90 b/src/optimize/optutils.f90 index ee943152..b31005ae 100644 --- a/src/optimize/optutils.f90 +++ b/src/optimize/optutils.f90 @@ -410,7 +410,7 @@ subroutine print_optsummary(calc,tight,nvar,maxcycle,maxmicro, & write (*,chrfmt) "Hessian update ","schlegel" end select end if - write (*,chrfmt) "write crestopt.log",bool2string(wr) + write (*,chrfmt) "write crestopt.log.xyz",bool2string(wr) if (linear) then write (*,chrfmt) "linear (good luck)",bool2string(linear) else diff --git a/src/optimize/rfo.f90 b/src/optimize/rfo.f90 index fc97b5c6..394329af 100644 --- a/src/optimize/rfo.f90 +++ b/src/optimize/rfo.f90 @@ -60,7 +60,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !> on output final energy !> grd - Cartesian gradient !> pr - printout bool -!> wr - logfile (crestopt.log) bool +!> wr - logfile (crestopt.log.xyz) bool !> iostatus - return status of the routine !> (success=0, error<0, not converged>0) !!*********************************************************************** @@ -208,7 +208,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !>--- initialize .log file, if desired ilog = 942 if (wr) then - open (newunit=ilog,file='crestopt.log') + open (newunit=ilog,file='crestopt.log.xyz') end if !>--- The ANCOPT iteration loop. "iter" is updated in relax() subroutine From c772fb9ca6c9ed9d846cb99c93b30a6f9a8b98e3 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 9 Apr 2025 16:31:27 +0200 Subject: [PATCH 047/374] working l-bfgs with some defaults --- src/calculator/calc_type.f90 | 1 + src/optimize/CMakeLists.txt | 1 + src/optimize/coordtrafo.f90 | 232 +++++++++++++++++++++++++++++++ src/optimize/lbfgs.f90 | 165 +++++++++++++--------- src/optimize/optimize_module.f90 | 6 +- src/optimize/rfo.f90 | 41 +++--- 6 files changed, 355 insertions(+), 91 deletions(-) create mode 100644 src/optimize/coordtrafo.f90 diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index c1c18adf..44b1d68b 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -249,6 +249,7 @@ module calc_type logical :: tsopt = .false. integer :: iupdat = 0 !> 0=BFGS, 1=Powell, 2=SR1, 3=Bofill, 4=Schlegel integer :: opt_engine = 0 !> default: ANCOPT + integer :: lbfgs_histsize = 20 !> L-BFGS history size !>--- GFN0* data, needed for special MECP application type(gfn0_data),allocatable :: g0calc diff --git a/src/optimize/CMakeLists.txt b/src/optimize/CMakeLists.txt index a3209fc9..3b953469 100644 --- a/src/optimize/CMakeLists.txt +++ b/src/optimize/CMakeLists.txt @@ -23,6 +23,7 @@ list(APPEND srcs "${dir}/lbfgs.f90" "${dir}/hessupdate.f90" "${dir}/modelhessian.f90" + "${dir}/coordtrafo.f90" "${dir}/optimize_maths.f90" "${dir}/optimize_module.f90" "${dir}/optimize_type.f90" diff --git a/src/optimize/coordtrafo.f90 b/src/optimize/coordtrafo.f90 new file mode 100644 index 00000000..7c778dc6 --- /dev/null +++ b/src/optimize/coordtrafo.f90 @@ -0,0 +1,232 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2025 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module coordinate_transform_module +!*********************************************************************** +!* Module: coordinate_transform_module +!* +!* This module provides transformation routines for converting between +!* different coordinate representations. In particular, it includes routines +!* to transform 3D Cartesian coordinates (stored in a 'coord' type from the +!* strucrd module) into a 1D vector representation and vice versa. It also +!* provides routines to transform gradients between a 3D representation (as a +!* 2D array with dimensions 3 x nat) and a 1D vector. These routines are useful +!* in optimization contexts where a flattened variable representation is required. +!*********************************************************************** + use crest_parameters + use strucrd + implicit none + private + + public :: compute_nvar,transform_mol,transform_grd + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + function compute_nvar(mol) result(nvar) + !*********************************************************************** + !* Function compute_nvar + !* Computes the number of variables for a system with nat atoms. + !* nvar is defined as 3 * nat. + !*********************************************************************** + implicit none + type(coord),intent(in) :: mol + integer :: nvar + + nvar = 3*mol%nat + end function compute_nvar + +!========================================================================================! + + subroutine transform_mol(transformation_type,mol,nvar,vec) + !*********************************************************************** + !* Subroutine transform_mol + !* Wrapper routine for coordinate transformations on a molecule. + !* Supported transformation types: + !* "cart2v" - Transforms mol%xyz (3D Cartesian coordinates) into a 1D vector. + !* "v2cart" - Transforms a 1D vector into mol%xyz. + !* + !* @param transformation_type Character string specifying the transformation. + !* @param mol Type(coord) variable containing Cartesian coordinates. + !* @param vec 1D real(wp) vector (input for "v2cart", output for "cart2v"). + !* @param nvar Integer, number of variables (nvar = 3*mol%nat). + !*********************************************************************** + implicit none + character(len=*),intent(in) :: transformation_type + type(coord),intent(inout) :: mol + real(wp),intent(inout) :: vec(nvar) + integer,intent(in) :: nvar + + select case (trim(transformation_type)) + case ("cart2v") + call cartesian_to_vector(mol,vec,nvar) + case ("v2cart") + call vector_to_cartesian(vec,nvar,mol) + case default + write(*,*)"Error: Transformation type not recognized in transform_mol." + stop + end select + end subroutine transform_mol + +!========================================================================================! + + subroutine transform_grd(transformation_type,mol,grd,nvar,vec) + !*********************************************************************** + !* Subroutine transform_grd + !* Wrapper routine for gradient transformations. + !* Supported transformation types: + !* "grd2v" - Transforms a 3D gradient array grd(3, nat) into a 1D vector. + !* "v2grd" - Transforms a 1D gradient vector into a 3D array grd(3, nat). + !* + !* @param transformation_type Character string specifying the transformation. + !* @param grd 3D gradient array (3 x nat); input for "grd2v" + !* and output for "v2grd". + !* @param vec 1D real(wp) vector (output for "grd2v", input for "v2grd"). + !* @param nvar Integer, number of variables (nvar = 3*nat). + !*********************************************************************** + implicit none + character(len=*),intent(in) :: transformation_type + type(coord),intent(inout) :: mol + real(wp),intent(inout) :: grd(3,mol%nat) + real(wp),intent(inout) :: vec(nvar) + integer,intent(inout) :: nvar + integer :: nat + + nat = mol%nat + select case (trim(transformation_type)) + case ("cart2v") + call gradient_to_vector(grd,nat,vec,nvar) + case ("v2cart") + call vector_to_gradient(vec,nvar,grd,nat) + case default + write(*,*)"Error: Transformation type not recognized in transform_grd." + stop + end select + end subroutine transform_grd + +!========================================================================================! + + subroutine cartesian_to_vector(mol,x,nvar) + !*********************************************************************** + ! Subroutine cartesian_to_vector + ! Transforms 3D Cartesian coordinates from mol%xyz into a 1D vector x. + ! The number of variables is computed as nvar = 3 * mol%nat. + !*********************************************************************** + implicit none + type(coord),intent(in) :: mol + real(wp),intent(out) :: x(nvar) + integer,intent(in) :: nvar + integer :: i,j,idx + + x = reshape(mol%xyz, [nvar]) + !idx = 0 + !do j = 1,mol%nat + ! do i = 1,3 + ! idx = idx+1 + ! x(idx) = mol%xyz(i,j) + ! end do + !end do + end subroutine cartesian_to_vector + + subroutine vector_to_cartesian(x,nvar,mol) + !*********************************************************************** + ! Subroutine vector_to_cartesian + ! Transforms a 1D vector x into 3D Cartesian coordinates stored in mol%xyz. + ! It computes the number of atoms as nat = nvar / 3 and allocates mol%xyz. + !*********************************************************************** + implicit none + integer,intent(in) :: nvar + real(wp),intent(in) :: x(nvar) + type(coord),intent(inout) :: mol + integer :: nat,i,j,idx + + if (mod(nvar,3) /= 0) then + write(*,*)"Error: nvar must be a multiple of 3." + stop + end if + + mol%xyz = reshape(x,[3,mol%nat]) +! nat = mol%nat +! idx = 0 +! do j = 1,nat +! do i = 1,3 +! idx = idx+1 +! mol%xyz(i,j) = x(idx) +! end do +! end do + end subroutine vector_to_cartesian + +!========================================================================================! + + subroutine gradient_to_vector(grd,nat,g,nvar) + !*********************************************************************** + !* Subroutine gradient_to_vector + !* Transforms a 3D gradient array grd(3, nat) into a 1D vector g. + !* The number of variables is computed as nvar = 3 * nat. + !*********************************************************************** + implicit none + integer,intent(in) :: nat,nvar + real(wp),intent(in) :: grd(3,nat) + real(wp),intent(out) :: g(nvar) + integer :: i,j,idx + + g = reshape(grd, [nvar]) + !idx = 0 + !do j = 1,nat + ! do i = 1,3 + ! idx = idx+1 + ! g(idx) = grd(i,j) + ! end do + !end do + end subroutine gradient_to_vector + + subroutine vector_to_gradient(g,nvar,grd,nat) + !*********************************************************************** + !* Subroutine vector_to_gradient + !* Transforms a 1D gradient vector g into a 3D gradient array grd(3, nat). + !* It computes the number of atoms as nat = nvar / 3 and allocates grd. + !*********************************************************************** + implicit none + integer,intent(in) :: nvar,nat + real(wp),intent(in) :: g(nvar) + real(wp),intent(out) :: grd(3,nat) + integer :: i,j,idx + + if (mod(nvar,3) /= 0) then + write(*,*)"Error: nvar must be a multiple of 3." + stop + end if + + grd = reshape(g, [3,nat]) + !idx = 0 + !do j = 1,nat + ! do i = 1,3 + ! idx = idx+1 + ! grd(i,j) = g(idx) + ! end do + !end do + end subroutine vector_to_gradient + +!========================================================================================! +!========================================================================================! +end module coordinate_transform_module + diff --git a/src/optimize/lbfgs.f90 b/src/optimize/lbfgs.f90 index 3a9b4924..2fea6756 100644 --- a/src/optimize/lbfgs.f90 +++ b/src/optimize/lbfgs.f90 @@ -17,11 +17,15 @@ ! along with crest. If not, see . !================================================================================! +!> This module implemnts a simple L-BFGS with different coordinate choices + module lbfgs_module use,intrinsic :: iso_fortran_env,only:wp => real64 use crest_calculator use strucrd use optimize_type !> This module provides the 'optimizer' type. + use optimize_utils + use coordinate_transform_module implicit none private @@ -33,7 +37,7 @@ module lbfgs_module !========================================================================================! !========================================================================================! - function lbfgs_direction(nvar,g,k,OPT,gamma) result(d) + function lbfgs_direction(nvar,g,k,OPT,gamm) result(d) !******************************************************************************* !* Two-loop recursion routine to compute the search direction. !* @@ -59,7 +63,7 @@ function lbfgs_direction(nvar,g,k,OPT,gamma) result(d) !* => rho Array of stored values 1/(y^T*s) for each correction. !* => alpha coefficients (get computed in this function) !* => q temporary workspace - !* @param gamma Scaling factor for the initial Hessian approximation. + !* @param gamm Scaling factor for the initial Hessian approximation. !* !* @return d Computed search direction (negative approximate inverse !* Hessian times g). @@ -68,7 +72,7 @@ function lbfgs_direction(nvar,g,k,OPT,gamma) result(d) integer,intent(in) :: nvar,k type(optimizer),intent(inout) :: OPT real(wp),intent(in) :: g(nvar) - real(wp),intent(in) :: gamma + real(wp),intent(in) :: gamm !> OUTPUT real(wp) :: d(nvar) !> LOCAL @@ -76,6 +80,9 @@ function lbfgs_direction(nvar,g,k,OPT,gamma) result(d) associate (S => OPT%S,Y => OPT%Y,alpha => OPT%alpha,rho => OPT%rho,q => OPT%q) + !write(*,*) k + !write(*,*) S(:,k) + !write(*,*) Y(:,k) !> Initialize q with the current gradient. q = g @@ -90,9 +97,9 @@ function lbfgs_direction(nvar,g,k,OPT,gamma) result(d) !--------------------------------------------------------- !> Apply the initial Hessian approximation. - !> We use a scaled identity matrix H0 = gamma * I. + !> We use a scaled identity matrix H0 = gamm * I. !--------------------------------------------------------- - d = gamma*q + d = gamm*q !--------------------------------------------------------- !> Second loop (forward pass): for i = 1 to k, @@ -108,26 +115,9 @@ function lbfgs_direction(nvar,g,k,OPT,gamma) result(d) end associate end function lbfgs_direction - subroutine obj_func(x,f,g) - !************************************************************************ - !* Dummy objective function (quadratic). - !* - !* This subroutine computes the value and gradient of the objective - !* function defined as f(x) = 1/2 * x^T * x. Its gradient is simply x. - !* Replace this with your actual function evaluations. - !* - !* @param x Input variable vector. - !* @param f Output function value. - !* @param g Output gradient vector. - !*********************************************************************** - real(wp),intent(in) :: x(:) - real(wp),intent(out) :: f - real(wp),intent(out) :: g(size(x)) - f = 0.5_wp*dot_product(x,x) - g = x - end subroutine obj_func - - subroutine lbfgs_optimize(mol,calc,etot,grd,nvar,x,max_iter,m,tol,pr,io) +!========================================================================================! + + subroutine lbfgs_optimize(mol,calc,etot,grd,pr,io) !************************************************************************** !* L-BFGS Optimization Routine !* @@ -143,11 +133,6 @@ subroutine lbfgs_optimize(mol,calc,etot,grd,nvar,x,max_iter,m,tol,pr,io) !* 4. Updating the correction pairs: s = x_new - x and y = g_new - g, while managing !* the history using a shifting strategy when full. !* - !* @param nvar Integer. Dimension of the variable space. - !* @param x Real(wp) array. Input coordinate vector; updated with optimized values. - !* @param max_iter Integer. Maximum number of iterations allowed. - !* @param m Integer. Maximum number of stored corrections (history length). - !* @param tol Real(wp). Convergence tolerance (stopping criteria based on f). !* @param io Integer. Output status variable (0 indicates success). !************************************************************************** implicit none @@ -156,86 +141,122 @@ subroutine lbfgs_optimize(mol,calc,etot,grd,nvar,x,max_iter,m,tol,pr,io) type(calcdata),intent(in) :: calc real(wp),intent(inout) :: etot real(wp),intent(inout) :: grd(3,mol%nat) - integer,intent(in) :: nvar - real(wp),intent(inout) :: x(nvar) - integer,intent(in) :: max_iter,m - real(wp),intent(in) :: tol logical,intent(in) :: pr !> OUTPUT integer,intent(out) :: io !> LOCAL type(optimizer) :: OPT - integer :: iter,k - real(wp) :: gnorm,deltaE - real(wp),allocatable :: g(:),d(:),g_new(:),x_new(:) - real(wp) :: f,f_new,gamma,step + integer :: iter,k,nvar,m + integer :: tight,max_iter + real(wp) :: gnorm,deltaE,energy + real(wp) :: ethr,gthr,maxerise + logical :: econverged,gconverged,converged,Erise + real(wp),allocatable :: x(:),g(:),d(:),g_new(:),x_new(:),gtmp(:,:) + real(wp) :: f,f_new,gamm,step + integer :: ilog !> Prepare settings io = 0 - - + nvar = compute_nvar(mol) + m = calc%lbfgs_histsize + gnorm = norm2(grd) + deltaE = huge(deltaE) + tight = calc%optlev + call get_optthr(mol%nat,tight,calc,ethr,gthr) + max_iter = calc%maxcycle !> automatic setting in get_optthr or by user + maxerise = calc%maxerise + econverged = .false. + gconverged = .false. + converged = .false. + + open (newunit=ilog,file='crestopt.log.xyz') + call mol%appendlog(ilog,etot) + + !$omp critical !> Allocate the vectors for position, gradient, and search direction. - allocate (g(nvar),d(nvar),g_new(nvar),x_new(nvar)) + allocate (x(nvar),g(nvar),d(nvar),g_new(nvar),x_new(nvar),gtmp(3,mol%nat)) !> Allocate matrices to store up to m correction pairs (columns correspond to each stored pair). call OPT%allocatelbfgs(nvar,m) + !$omp end critical + associate (S => OPT%S,Y => OPT%Y,rho => OPT%rho,alpha => OPT%alpha) S = 0.0_wp Y = 0.0_wp rho = 0.0_wp k = 0 ! Initially, no correction pairs are stored. - !> Evaluate the objective function and its gradient at the starting point. - call obj_func(x,f,g) + !> First trafo + call transform_mol('cart2v',mol,nvar,x) + call transform_grd('cart2v',mol,grd,nvar,g) iter = 0 - if (pr) call print_optiter(iter) - gnorm = norm2(grd) if (pr) then + call print_optiter(iter) write (*,'(" * total energy :",f14.7,1x,"Eh")',advance='no') etot write (*,'(5x,"change ΔE",e18.7,1x,"Eh")') 0.0_wp write (*,'(3x,"gradient norm :",f14.7,1x,"Eh/a0")') gnorm end if - do while (f > tol.and.iter < max_iter) + LBFGS_iter: do while (.not.converged.and.iter < max_iter) iter = iter+1 - if (pr) call print_optiter(iter) + if (pr) call print_optiter(iter) if (iter == 1) then !> First iteration: use the steepest descent direction. d = -g else !--------------------------------------------------------- - !> Determine the scaling factor gamma for the initial Hessian. + !> Determine the scaling factor gamm for the initial Hessian. ! Here we use the most recent correction pair. !--------------------------------------------------------- if (k > 0) then - gamma = dot_product(S(1:nvar,k),Y(1:nvar,k))/ & - dot_product(Y(1:nvar,k),Y(1:nvar,k)) + gamm = dot_product(S(1:nvar,k),Y(1:nvar,k))/ & + dot_product(Y(1:nvar,k),Y(1:nvar,k)) else - gamma = 1.0_wp + gamm = 1.0_wp end if !> Compute the search direction using the two-loop recursion. - d = lbfgs_direction(nvar,g,k,OPT,gamma) + d = lbfgs_direction(nvar,g,k,OPT,gamm) end if !--------------------------------------------------------- !> A fixed step size could be used here for simplicity. ! In a full implementation, a line search could be used. + ! If the energy rises, we reduce the stepsize iteratively !--------------------------------------------------------- - step = 1.0_wp - - !> Update the position: x_new = x + step * d. - x_new = x+step*d - - !====================================================================! - !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Evaluate the objective and gradient at the new position. - call obj_func(x_new,f_new,g_new) - !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Update the position: x_new = x + step * d. + x_new = x+step*d + + !====================================================================! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Evaluate the objective and gradient at the new position. + call transform_mol('v2cart',mol,nvar,x_new) + grd = 0.0_wp + call engrad(mol,calc,energy,gtmp,io) + call mol%appendlog(ilog,energy) + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< maxerise) + if (Erise) then + step = step*0.25_wp + if (pr) then + write (*,'(" * energy rise detected, decreasing stepsize")') + end if + end if + end do + econverged = abs(deltaE) .lt. ethr + gconverged = gnorm .lt. gthr !--------------------------------------------------------- !> Compute the correction pair: @@ -261,22 +282,30 @@ subroutine lbfgs_optimize(mol,calc,etot,grd,nvar,x,max_iter,m,tol,pr,io) !> Update the current position, gradient, and function value. x = x_new g = g_new - f = f_new + etot = energy !> Optional: print iteration information. if (pr) then write (*,'(" * total energy :",f14.7,1x,"Eh")',advance='no') etot write (*,'(5x,"change ΔE",e18.7,1x,"Eh")') deltaE write (*,'(3x,"gradient norm :",f14.7,1x,"Eh/a0")',advance='no') gnorm + call print_convd(econverged,gconverged) end if - end do + converged = econverged.and.gconverged + end do LBFGS_iter !> stop associating end associate + !> Final trafo + call transform_mol('v2cart',mol,nvar,x_new) + call transform_grd('v2cart',mol,grd,nvar,g_new) + !> Deallocate all temporary arrays. - deallocate (g,d,g_new,x_new) + deallocate (x_new,g_new,d,g,x) end subroutine lbfgs_optimize +!========================================================================================! +!========================================================================================! end module lbfgs_module diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index eaafb2f4..fa1ed380 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -82,8 +82,10 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) call ancopt(molnew,calc,etot,grd,pr,wr,iostatus) case ( 1) !> l-bfgs goes here - write(stdout,'(a)') 'L-BFGS currently not implemented' - stop + !write(stdout,'(a)') 'L-BFGS currently not implemented' + !stop + call lbfgs_optimize(molnew,calc,etot,grd,pr,iostatus) + case ( 2) !> rfo goes here call rfopt(molnew,calc,etot,grd,pr,wr,iostatus) diff --git a/src/optimize/rfo.f90 b/src/optimize/rfo.f90 index 394329af..769b0658 100644 --- a/src/optimize/rfo.f90 +++ b/src/optimize/rfo.f90 @@ -23,7 +23,7 @@ !> This module implements a standard RFO algorithm (in Cart. coords) module rfo_module - use iso_fortran_env, only: wp=>real64, sp=>real32 + use iso_fortran_env,only:wp => real64,sp => real32 use crest_calculator use axis_module use strucrd @@ -121,7 +121,6 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) real(wp),external :: ddot real(sp),external :: sdot - iostatus = 0 fail = .false. converged = .false. @@ -133,7 +132,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) iupdat = calc%iupdat hlow = calc%hlow_opt !> 0.01 in ancopt, 0.002 too small hmax = calc%hmax_opt - maxdispl = calc%maxdispl_opt + maxdispl = calc%maxdispl_opt gnorm = 0.0_wp depred = 0.0_wp echng = 0.0_wp @@ -181,23 +180,23 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) npvar = OPT%nvar*(nvar1)/2 !> packed size of Hessian (note the abuse of nvar1!) npvar1 = nvar1*(nvar1+1)/2 !> packed size of augmented Hessian allocate (Uaug(nvar1,1),eaug(nvar1),Aaug(npvar1)) - allocate ( gold(OPT%nvar),displ(OPT%nvar),grd1(OPT%nvar),source=0.0_wp) + allocate (gold(OPT%nvar),displ(OPT%nvar),grd1(OPT%nvar),source=0.0_wp) !$omp end critical !>------------------------------------------------------------------------ !>--- put the Hessian guess into the type !>------------------------------------------------------------------------ - k = 0 - do i = 1,nat3 - do j = 1,i - k = k+1 - if( i /= j )then - OPT%hess(k) = 0.0_wp - else - OPT%hess(k) = calc%hguess - endif - end do - end do + k = 0 + do i = 1,nat3 + do j = 1,i + k = k+1 + if (i /= j) then + OPT%hess(k) = 0.0_wp + else + OPT%hess(k) = calc%hguess + end if + end do + end do !>--- backup coordinates, and starting energy molopt%nat = mol%nat @@ -302,13 +301,13 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) alp = 1.0d-1 if (gnorm .lt. 0.002) then ! 0.002 alp = 1.5d-1 ! 1.5 - endif + end if if (gnorm .lt. 0.0006) then alp = 2.0d-1 ! 2 - endif + end if if (gnorm .lt. 0.0003) then alp = 3.0d-1 ! 3 - endif + end if !>------------------------------------------------------------------------ !> Update the Hessian @@ -460,9 +459,9 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !> deallocate data !$omp critical - if (allocated(gold)) deallocate(gold) - if (allocated(displ)) deallocate(displ) - if (allocated(grd1)) deallocate(grd1) + if (allocated(gold)) deallocate (gold) + if (allocated(displ)) deallocate (displ) + if (allocated(grd1)) deallocate (grd1) if (allocated(Uaug)) deallocate (Uaug) if (allocated(eaug)) deallocate (eaug) if (allocated(Aaug)) deallocate (Aaug) From 0d8f4dc6e38a2dcf92156ff697cdb960545a7d57 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 14 Apr 2025 13:49:33 +0200 Subject: [PATCH 048/374] Move iRMSD tool and RMSD tool to sorting.f90 runtypes --- src/algos/sorting.f90 | 174 ++++++++++++++++++++++++++++++++++------ src/classes.f90 | 1 + src/confparse.f90 | 67 ++++++++++------ src/legacy_wrappers.f90 | 3 +- src/minitools.f90 | 92 --------------------- src/sorting/cregen.f90 | 40 ++++++--- 6 files changed, 227 insertions(+), 150 deletions(-) diff --git a/src/algos/sorting.f90 b/src/algos/sorting.f90 index af5b2c97..38474e3d 100644 --- a/src/algos/sorting.f90 +++ b/src/algos/sorting.f90 @@ -30,66 +30,190 @@ subroutine crest_sort(env,tim) use crest_parameters use crest_data use crest_calculator - use strucrd + use strucrd use cregen_interface - use iomod, only: catdel + use iomod,only:catdel implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim type(coord) :: mol,molnew - integer :: i,j,k,l,io,ich + integer :: i,j,k,l,io,ich logical :: pr,wr !========================================================================================! integer :: nall type(coord),allocatable :: structures(:) - integer,allocatable :: groups(:) + integer,allocatable :: groups(:) +!========================================================================================! + select case (env%sortmode) + case default + write (stdout,'(a,a,a)',advance='no') '> Read ensemble ',trim(env%ensemblename),' ... ' + flush (stdout) + call rdensemble(env%ensemblename,nall,structures) + allocate (groups(nall),source=0) + write (stdout,'(i0,a)') nall,' structures!' + case ('irmsd','rmsd','hrmsd') + write (stdout,'(a,a)',advance='no') '> Reading files ',trim(env%ensemblename) + flush (stdout) + write (stdout,'(a,a)') ' and ',trim(env%ensemblename2) + end select + write (stdout,*) !========================================================================================! + call tim%start(11,'Sorting') + select case (env%sortmode) - write(stdout,'(a,a,a)',advance='no') '> Read ensemble ',trim(env%ensemblename),' ... ' - flush(stdout) - call rdensemble(env%ensemblename,nall,structures) - allocate(groups(nall), source=0) - write(stdout,'(i0,a)') nall,' structures!' - write(stdout,*) + case ('rmsd') + call quick_rmsd_tool(trim(env%ensemblename),trim(env%ensemblename2),.false.) + stop -!========================================================================================! - call tim%start(11,'Sorting') + case ('hrmsd') + call quick_rmsd_tool(trim(env%ensemblename),trim(env%ensemblename2),.true.) + stop - select case(env%sortmode) + case ('irmsd') + call irmsd_tool(env%ensemblename,env%ensemblename2,env%iinversion) + stop - case('isort') + case ('isort') !>--- Assigning structures to conformers based on RTHR,with canonical atom IDs call underline('Assigning conformers based on iRMSD and RTHR') - call cregen_irmsd_sort(env,nall,structures,groups,allcanon=.true.,printlvl=2) + call cregen_irmsd_sort(env,nall,structures,groups,allcanon=.true.,printlvl=2) - - case('isort_noid') + case ('isort_noid') !>--- Assigning structures to conformers based on RTHR, WITHOUT canonical atom IDs call underline('Assigning conformers based on iRMSD and RTHR') - call cregen_irmsd_sort(env,nall,structures,groups,allcanon=.false.,printlvl=2) - + call cregen_irmsd_sort(env,nall,structures,groups,allcanon=.false.,printlvl=2) - case('all','allpair') + case ('all','allpair') !>--- all unique pairs of the ensemble (only suitable for small ensembles) call underline('Running all unique pair RMSDs incl. atom permutation') - call cregen_irmsd_all(nall,structures,2) + call cregen_irmsd_all(nall,structures,printlvl=2,iinversion=env%iinversion) - case('cregen') + case ('cregen') !>--- the original CREGEN procedure (fallback, needs nicer implementations) - if(allocated(structures))deallocate(structures) + if (allocated(structures)) deallocate (structures) call newcregen(env,infile=env%ensemblename) call catdel('cregen.out.tmp') case default !>--- all unique pairs of the ensemble (only suitable for small ensembles) - call cregen_irmsd_all(nall,structures,2) + call cregen_irmsd_all(nall,structures,printlvl=2,iinversion=env%iinversion) end select !========================================================================================! call tim%stop(11) - if(allocated(structures)) deallocate(structures) + if (allocated(structures)) deallocate (structures) return end subroutine crest_sort + +!=========================================================================================! + +subroutine irmsd_tool(fname1,fname2,iinversion) +!******************************************************* +!* irmsd_tool +!* Standalone implementation to compare two structures +!* with the iRMSD method. +!* This implementation should be called only on its own, +!* for ensemble-based processing see the CREGEN file +!******************************************************* + use crest_parameters + use strucrd + use axis_module + use irmsd_module + use canonical_mod + implicit none + character(len=*),intent(in) :: fname1 + character(len=*),intent(in) :: fname2 + integer,intent(in) :: iinversion + type(coord) :: mol,ref + real(wp) :: rmsdval,tmpd(3),tmpdist + integer :: i,ich + type(rmsd_cache) :: rcache + type(canonical_sorter) :: canmol + type(canonical_sorter) :: canref + logical :: mirror + logical,parameter :: debug = .false. + + write (stdout,*) 'iRMSD algorithm' + write (stdout,*) 'reference: ',trim(fname1) + write (stdout,*) 'processed: ',trim(fname2) + write (stdout,*) + + !> read the geometries + call ref%open(trim(fname1)) + call mol%open(trim(fname2)) + + !> move ref to CMA and align rotational axes + call axis(ref%nat,ref%at,ref%xyz) + + !> allocate memory + call rcache%allocate(ref%nat) + + !> canonical atom ranks + call canref%init(ref,invtype='apsp+',heavy=.false.) + !call canref%add_h_ranks(ref) + rcache%stereocheck = .not. (canref%hasstereo(ref)) + call canref%shrink() + write (stdout,*) 'false enantiomers possible?: ',rcache%stereocheck + select case (iinversion) + case (0) + mirror = .true. + case (1) + mirror = .true. + rcache%stereocheck = .true. + case (2) + mirror = .false. + rcache%stereocheck = .false. + end select + write (stdout,*) 'allow inversion?: ',mirror + + call canmol%init(mol,invtype='apsp+',heavy=.false.) + !call canmol%add_h_ranks(mol) + call canmol%shrink() + + !> check if we can work with the determined ranks + if (checkranks(ref%nat,canref%rank,canmol%rank)) then + write (stdout,*) 'using canonical atom identities as rank backend' + rcache%rank(:,1) = canref%rank(:) + rcache%rank(:,2) = canmol%rank(:) + if (debug) then + write (*,*) 'iRMSD ranks:' + write (*,*) 'atom',' rank('//fname1//')',' rank('//fname2//')' + do i = 1,ref%nat + write (*,*) i,rcache%rank(i,1),rcache%rank(i,2) + end do + write (*,*) + end if + else + !> if not, fall back to atom types + write (stdout,*) 'using atom types as rank backend' + call fallbackranks(ref,mol,ref%nat,rcache%rank) + end if + + call min_rmsd(ref,mol,rcache=rcache,rmsdout=rmsdval,align=.true.) + + !> write the rotated and shifted coordinates to one file + open (newunit=ich,file='irmsd.xyz') + call ref%append(ich) + call mol%append(ich) + close (ich) + write (stdout,*) + write (stdout,*) 'aligned structures written to irmsd.xyz' + write (stdout,*) + + do i = 1,mol%nat + tmpd(:) = (mol%xyz(:,i)-ref%xyz(:,i))**2 + tmpdist = sqrt(sum(tmpd(:)))*autoaa + if (tmpdist > 0.01_wp) then + write (*,*) i,mol%at(i),tmpdist + end if + end do + + rmsdval = rmsdval*autoaa + write (*,'(1x,a,f16.8)') 'Calculated iRMSD (Å):',rmsdval + + return +end subroutine irmsd_tool + diff --git a/src/classes.f90 b/src/classes.f90 index 43ac3ffb..bc80931c 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -347,6 +347,7 @@ module crest_data real(wp) :: pthrsum real(wp) :: tboltz logical :: cgf(6) !> collection of CREGEN options + integer :: iinversion = 0 !> 0=auto,1=on, 2=off real(wp) :: mdtemps(10) !> different temperatures for the QMDFF-MDs in V1 real(wp) :: mdtime !> MD length (V1&2) diff --git a/src/confparse.f90 b/src/confparse.f90 index a49c5fce..6b233587 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -645,24 +645,43 @@ subroutine parseflags(env,arg,nra) end if case ('-rmsd','-rmsdheavy','-hrmsd') - ctmp = trim(arg(i+1)) - dtmp = trim(arg(i+2)) if ((argument == '-rmsdheavy').or.(argument == '-hrmsd')) then - call quick_rmsd_tool(ctmp,dtmp,.true.) + env%sortmode = 'hrmsd' else - call quick_rmsd_tool(ctmp,dtmp,.false.) + env%sortmode = 'rmsd' + end if + ctmp = trim(arg(i+1)) + dtmp = trim(arg(i+2)) + env%preopt = .false. + env%crestver = crest_sorting + inquire (file=ctmp,exist=ex) + if (ex) then + env%inputcoords = ctmp + env%ensemblename = ctmp + end if + inquire (file=dtmp,exist=ex) + if (ex) then + env%ensemblename2 = dtmp end if - stop case ('-irmsd','-irmsd_noinv') ctmp = trim(arg(i+1)) dtmp = trim(arg(i+2)) - if(index(argument,'_noinv').ne.0)then - call irmsd_tool(ctmp,dtmp,.false.) - else - call irmsd_tool(ctmp,dtmp,.true.) - endif - stop + env%preopt = .false. + env%crestver = crest_sorting + env%sortmode = 'irmsd' + inquire (file=ctmp,exist=ex) + if (ex) then + env%inputcoords = ctmp + env%ensemblename = ctmp + end if + inquire (file=dtmp,exist=ex) + if (ex) then + env%ensemblename2 = dtmp + end if + if (index(argument,'_noinv') .ne. 0) then + env%iinversion = 2 + end if case ('-hungarian','-hungarianheavy','-hhungarian','-lsap','-hlsap','-lsapheavy') ctmp = trim(arg(i+1)) @@ -765,15 +784,15 @@ subroutine parseflags(env,arg,nra) env%crestver = crest_sorting ctmp = trim(arg(i+1)) inquire (file=ctmp,exist=ex) - if (ex)then + if (ex) then env%inputcoords = ctmp env%ensemblename = ctmp - endif - if(nra >= i+2)then - ctmp = trim(arg(i+2)) - if(ctmp(1:1).ne.'-') env%sortmode=trim(ctmp) - endif - + end if + if (nra >= i+2) then + ctmp = trim(arg(i+2)) + if (ctmp(1:1) .ne. '-') env%sortmode = trim(ctmp) + end if + case ('-bh','-GMIN') env%crestver = crest_bh exit @@ -2230,11 +2249,11 @@ subroutine parseflags(env,arg,nra) env%ProgName = ctmp !>--- for legacy runtypes, check if xtb is present - if(env%legacy.or.env%QCG)then + if (env%legacy.or.env%QCG) then call checkprog_silent(env%ProgName,.true.,iostat=io) - if(io /= 0 ) error stop - write(stdout,'(/,a,a)') 'Selected path to xtb binary: ',trim(env%Progname) - endif + if (io /= 0) error stop + write (stdout,'(/,a,a)') 'Selected path to xtb binary: ',trim(env%Progname) + end if !========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>! @@ -2246,7 +2265,9 @@ subroutine parseflags(env,arg,nra) flush (stdout) call env2calc_setup(env) write (stdout,*) 'done.' - call env%calc%info(stdout) + if (env%crestver .ne. crest_sorting) then + call env%calc%info(stdout) + end if end if !>--- pass on opt-level to new calculator if (.not.env%legacy) then diff --git a/src/legacy_wrappers.f90 b/src/legacy_wrappers.f90 index cc4d7e3f..064b3663 100644 --- a/src/legacy_wrappers.f90 +++ b/src/legacy_wrappers.f90 @@ -344,7 +344,8 @@ subroutine trialOPT(env) if (env%crestver == crest_trialopt) then !>-- if we reach this point in the standalone trialopt the geometry is ok! write (stdout,*) - stop 'Geometry ok!' + write (stdout,*) 'Geometry ok!' + stop end if end subroutine trialOPT diff --git a/src/minitools.f90 b/src/minitools.f90 index 9641943f..7a46d786 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -825,98 +825,6 @@ end subroutine quick_hungarian_match !=========================================================================================! -subroutine irmsd_tool(fname1,fname2,mirror) - use crest_parameters - use strucrd - use axis_module - use irmsd_module - use canonical_mod - implicit none - character(len=*),intent(in) :: fname1 - character(len=*),intent(in) :: fname2 - logical,intent(in) :: mirror - type(coord) :: mol,ref - real(wp) :: rmsdval,tmpd(3),tmpdist - integer :: i,ich - type(rmsd_cache) :: rcache - type(canonical_sorter) :: canmol - type(canonical_sorter) :: canref - logical,parameter :: debug = .false. - - write (stdout,*) 'iRMSD algorithm' - write (stdout,*) 'reference: ',fname1 - write (stdout,*) 'processed: ',fname2 - write (stdout,*) - - !> read the geometries - call ref%open(fname1) - call mol%open(fname2) - - !> move ref to CMA and align rotational axes - call axis(ref%nat,ref%at,ref%xyz) - - !> allocate memory - call rcache%allocate(ref%nat) - - !> canonical atom ranks - call canref%init(ref,invtype='apsp+',heavy=.false.) - !call canref%add_h_ranks(ref) - rcache%stereocheck = .not. (canref%hasstereo(ref)) - call canref%shrink() - write(*,*) 'false enantiomers possible?: ',rcache%stereocheck - write(*,*) 'allow inversion?: ',mirror - if(.not.mirror) rcache%stereocheck = .false. - - call canmol%init(mol,invtype='apsp+',heavy=.false.) - !call canmol%add_h_ranks(mol) - call canmol%shrink() - - !> check if we can work with the determined ranks - if (checkranks(ref%nat,canref%rank,canmol%rank)) then - write(stdout,*) 'using canonical atom identities as rank backend' - rcache%rank(:,1) = canref%rank(:) - rcache%rank(:,2) = canmol%rank(:) - if (debug) then - write (*,*) 'iRMSD ranks:' - write (*,*) 'atom',' rank('//fname1//')',' rank('//fname2//')' - do i = 1,ref%nat - write (*,*) i,rcache%rank(i,1),rcache%rank(i,2) - end do - write (*,*) - end if - else - !> if not, fall back to atom types - write(stdout,*) 'using atom types as rank backend' - call fallbackranks(ref,mol,ref%nat,rcache%rank) - end if - - call min_rmsd(ref,mol,rcache=rcache,rmsdout=rmsdval,align=.true.) - - !> write the rotated and shifted coordinates to one file - open (newunit=ich,file='irmsd.xyz') - call ref%append(ich) - call mol%append(ich) - close (ich) - write (stdout,*) - write (stdout,*) 'aligned structures written to irmsd.xyz' - write (stdout,*) - - do i=1,mol%nat - tmpd(:) = (mol%xyz(:,i) - ref%xyz(:,i))**2 - tmpdist = sqrt(sum(tmpd(:)))*autoaa - if(tmpdist > 0.01_wp)then - write(*,*) i,mol%at(i),tmpdist - endif - enddo - - rmsdval = rmsdval*autoaa - write (*,'(1x,a,f16.8)') 'Calculated iRMSD (Å):',rmsdval - - return -end subroutine irmsd_tool - -!=========================================================================================! - subroutine resort_ensemble(fname) !************************************************ !* resort all structures of a given ensemblefile diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 47d8230e..86e97568 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -37,7 +37,7 @@ module cregen_interface !* module to load an interface to the newcregen routine !* mandatory to handle the optional input arguments !******************************************************* - use unionize_module + use unionize_module implicit none interface subroutine newcregen(env,quickset,infile) @@ -51,13 +51,14 @@ subroutine newcregen(env,quickset,infile) character(len=*),intent(in),optional :: infile end subroutine newcregen - subroutine cregen_irmsd_all(nall,structures,printlvl) + subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) use strucrd implicit none !> INPUT integer,intent(in) :: nall type(coord),intent(inout),target :: structures(nall) integer,intent(in),optional :: printlvl + integer,intent(in),optional :: iinversion end subroutine cregen_irmsd_all subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) @@ -75,7 +76,7 @@ end subroutine cregen_irmsd_sort end interface !>--- Additional Related RE-EXPORTS - public :: unionizeEnsembles + public :: unionizeEnsembles end module cregen_interface subroutine newcregen(env,quickset,infile) @@ -1540,7 +1541,7 @@ end subroutine cregen_CRE !=========================================================================================! -subroutine cregen_irmsd_all(nall,structures,printlvl) +subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) !******************************************** !* Proof-of-concept routine to run all !* pairs of RMSD for an array of structures @@ -1557,12 +1558,11 @@ subroutine cregen_irmsd_all(nall,structures,printlvl) integer,intent(in) :: nall type(coord),intent(inout),target :: structures(nall) integer,intent(in),optional :: printlvl - + integer,intent(in),optional :: iinversion !> LOCAL integer :: i,j,ii,jj,T,nallpairs,cc,nat integer :: prlvl,iunit type(rmsd_cache),allocatable :: rcaches(:) - !type(rmsd_cache) :: rcaches type(coord),allocatable,target :: workmols(:) type(canonical_sorter),allocatable :: sorters(:) real(wp),allocatable :: rmsds(:) @@ -1632,6 +1632,18 @@ subroutine cregen_irmsd_all(nall,structures,printlvl) & ' ms per processed structure' end if + !> allow user to set inversion check (false rotamers) + if (present(iinversion)) then + select case (iinversion) + case (0) + continue + case (1) + stereocheck = .true. + case (2) + stereocheck = .false. + end select + end if + !> And finally, run the RMSD checks call profiler%start(2) if (prlvl > 0) then @@ -1807,7 +1819,7 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) !$omp end do !$omp end parallel if (prlvl > 0) then - call profiler%stop(1) + call profiler%stop(1) call profiler%write_timing(stdout,1,'done.',.true.) runtime = (profiler%get(1)/real(nall,wp))*1000.0_wp write (stdout,'(1x,a,f0.3,a)') '* Corresponding to approximately ',runtime, & @@ -1815,6 +1827,16 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) write (stdout,*) end if + !>--- allow user to set inversion check (false rotamers) + select case (env%iinversion) + case (0) + continue + case (1) + stereocheck = .true. + case (2) + stereocheck = .false. + end select + !>--- allocate work cache if (prlvl > 0) then write (stdout,'(a)',advance='no') 'CREGEN> Allocating iRMSD work cache ... ' @@ -1877,8 +1899,8 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) !$omp end parallel end do if (prlvl > 0) then - call profiler%stop(2) - call profiler%write_timing(stdout,2,'done.',.true.) + call profiler%stop(2) + call profiler%write_timing(stdout,2,'done.',.true.) write (stdout,*) end if From 5ebb99da052f8a6881c7da4585145152878a7f98 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 14 Apr 2025 14:27:12 +0200 Subject: [PATCH 049/374] Introduce --inversion flag --- src/algos/sorting.f90 | 2 +- src/confparse.f90 | 13 +++++++++++++ src/sorting/cregen.f90 | 17 ++++++++++++++++- 3 files changed, 30 insertions(+), 2 deletions(-) diff --git a/src/algos/sorting.f90 b/src/algos/sorting.f90 index 38474e3d..9e05cbd1 100644 --- a/src/algos/sorting.f90 +++ b/src/algos/sorting.f90 @@ -73,7 +73,7 @@ subroutine crest_sort(env,tim) stop case ('irmsd') - call irmsd_tool(env%ensemblename,env%ensemblename2,env%iinversion) + call irmsd_tool(trim(env%ensemblename),trim(env%ensemblename2),env%iinversion) stop case ('isort') diff --git a/src/confparse.f90 b/src/confparse.f90 index 6b233587..a26f44fd 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -1647,6 +1647,19 @@ subroutine parseflags(env,arg,nra) env%checkiso = .true. case ('-noezcheck','-nocheckez') env%checkiso = .false. + case ('-inversion') + ctmp = lowercase(trim(arg(i+1))) + select case (ctmp) + case ('auto') + env%iinversion = 0 + case ('on') + env%iinversion = 1 + case ('off') + env%iinversion = 2 + case default + write (stdout,'(a,a,a,a)') 'invalid argument for ',argument,': ',trim(ctmp) + stop + end select !========================================================================================! !-------- PROPERTY CALCULATION related flags !========================================================================================! diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 86e97568..175453e5 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -1572,7 +1572,7 @@ subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) logical :: stereocheck type(timer) :: profiler - logical,parameter :: debug = .true. + logical,parameter :: debug = .false. real(wp),allocatable :: debugrmsds(:) !> for implementing OpenMP parallelism @@ -1642,6 +1642,9 @@ subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) case (2) stereocheck = .false. end select + if (prlvl > 1) then + write (stdout,'(a,l2)') 'CREGEN> Check for false rotamers (geometry inversion)? -->',stereocheck + end if end if !> And finally, run the RMSD checks @@ -1784,6 +1787,15 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) write (stdout,'(2x,a,f9.5,a)') 'RTHR (RMSD threshold) :',RTHR*autoaa,' Å' write (stdout,'(2x,a,i9)') 'OpenMP threads :',T write (stdout,'(2x,a,a9)') 'Individual atom IDs? :',to_str(individual_IDs) + write (stdout,'(2x,a)',advance='no') 'False rotamer check? :' + select case(env%iinversion) + case (0) + write(stdout,'(a9)') 'auto' + case (1) + write(stdout,'(a9)') 'on' + case (2) + write(stdout,'(a9)') 'off' + end select write (stdout,*) end if @@ -1836,6 +1848,9 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) case (2) stereocheck = .false. end select + if (prlvl > 1) then + write (stdout,'(a,l2)') 'CREGEN> Check for false rotamers (geometry inversion)? -->',stereocheck + end if !>--- allocate work cache if (prlvl > 0) then From eba298f9cd1f1a0603a2772c430bd3b9e7161ffa Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 14 Apr 2025 14:37:30 +0200 Subject: [PATCH 050/374] Renamie 'scenario' to 'uniquenesscase' in iRMSD source, for clarity --- src/sorting/irmsd_module.f90 | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index 8cc25bd7..41d05bf5 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -414,7 +414,7 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout,align) !> LOCAL type(rmsd_cache),pointer :: cptr type(rmsd_cache),allocatable,target :: local_rcache - integer :: nat,ii,rnk,dumpunit,scenario + integer :: nat,ii,rnk,dumpunit,uniquenesscase real(wp) :: calc_rmsd real(wp) :: tmprmsd_sym(32),dum real(wp) :: rotmat(3,3),rotconst(3) @@ -507,22 +507,22 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout,align) tmprmsd_sym(:) = inf !> initial alignment of mol call axis(mol%nat,mol%at,mol%xyz,rotconst) - call min_rmsd_rotcheck_unique(mol,rotconst,scenario) + call min_rmsd_rotcheck_unique(mol,rotconst,uniquenesscase) !> Running the checks and check of uniqueness of rotational axes - call min_rmsd_rotcheck_permute(ref,mol,cptr,tmprmsd_sym,1,scenario) + call min_rmsd_rotcheck_permute(ref,mol,cptr,tmprmsd_sym,1,uniquenesscase) if (debug) then write (*,*) 'Total LSAP cost:',minval(tmprmsd_sym(1:16)) call mol%append(dumpunit) end if - !> mirror z and re-run the same checks + !> mirror z and re-run the same checks (i.e. the false rotamer inversion) if (cptr%stereocheck) then mol%xyz(3,:) = -mol%xyz(3,:) !> mirror z call axis(mol%nat,mol%at,mol%xyz) !> align !> Running the checks - call min_rmsd_rotcheck_permute(ref,mol,cptr,tmprmsd_sym,2,scenario) + call min_rmsd_rotcheck_permute(ref,mol,cptr,tmprmsd_sym,2,uniquenesscase) if (debug) then write (*,*) 'Total LSAP cost (inverted):',minval(tmprmsd_sym(17:32)) call mol%append(dumpunit) @@ -540,9 +540,9 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout,align) if (debug) write (*,*) 'inverting' end if if ((ii > 4 .and. ii < 9) .or. (ii > 20 .and. ii < 25))then - if(scenario == 1) mol%xyz = matmul(Rx90,mol%xyz) - if(scenario == 2) mol%xyz = matmul(Rz90,mol%xyz) - if(scenario == 3) mol%xyz = matmul(Rz90,mol%xyz) + if(uniquenesscase == 1) mol%xyz = matmul(Rx90,mol%xyz) + if(uniquenesscase == 2) mol%xyz = matmul(Rz90,mol%xyz) + if(uniquenesscase == 3) mol%xyz = matmul(Rz90,mol%xyz) if(debug) write (*,*) '90° tilt' else if ((ii > 8 .and. ii < 13) .or. (ii > 24 .and. ii < 29))then mol%xyz = matmul(Ry90,mol%xyz) @@ -632,7 +632,7 @@ end subroutine min_rmsd_iterate_through_groups !========================================================================================! - subroutine min_rmsd_rotcheck_unique(mol,rot,scenario,thr) + subroutine min_rmsd_rotcheck_unique(mol,rot,uniquenesscase,thr) !******************************************************* !* Based on the rotational constants, determine what we !* need to do with the molecule in the following @@ -640,35 +640,35 @@ subroutine min_rmsd_rotcheck_unique(mol,rot,scenario,thr) implicit none type(coord),intent(inout) :: mol real(wp),intent(in) :: rot(3) - integer,intent(out) :: scenario + integer,intent(out) :: uniquenesscase real(wp),intent(in),optional :: thr logical :: unique(3) integer :: nunique - scenario = 0 + uniquenesscase = 0 call uniqueax(rot,unique,thr) nunique = count(unique,1) select case(nunique) case ( 3 ) !> 3 unique principal axes - scenario = 0 + uniquenesscase = 0 case ( 1 ) !> one unique principal axis - if(unique(1)) scenario = 1 !> A unique (long axis) - if(unique(3)) scenario = 2 !> C unique (short axis) + if(unique(1)) uniquenesscase = 1 !> A unique (long axis) + if(unique(3)) uniquenesscase = 2 !> C unique (short axis) case ( 0 ) !> rotationally ambiguous system - scenario = 3 + uniquenesscase = 3 end select end subroutine min_rmsd_rotcheck_unique !=======================================================================================! - subroutine min_rmsd_rotcheck_permute(ref,mol,cptr,values,step,scenario) + subroutine min_rmsd_rotcheck_permute(ref,mol,cptr,values,step,uniquenesscase) implicit none type(coord),intent(in) :: ref type(coord),intent(inout) :: mol type(rmsd_cache),intent(inout),target :: cptr real(wp),intent(inout) :: values(:) - integer,intent(in) :: step,scenario + integer,intent(in) :: step,uniquenesscase integer :: rr,ii,jj,debugunit2 real(wp) :: vals(16),dum logical,parameter :: debug = .false. @@ -708,7 +708,7 @@ subroutine min_rmsd_rotcheck_permute(ref,mol,cptr,values,step,scenario) mol%xyz = matmul(Ry180,mol%xyz) !> restore !exit ALIGNLOOP - select case(scenario) + select case(uniquenesscase) case( 0 ) !> 3 Unique moments of inertia exit ALIGNLOOP case( 1 ) !> only one unique moment of inertia (A) From 4569ee4b2c1b614ee170452ffe2e893dc0971a54 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 28 May 2025 13:55:51 +0200 Subject: [PATCH 051/374] recognize gxTB for --refine --- src/calculator/calc_type.f90 | 4 ++++ src/calculator/turbom_sc.f90 | 5 +++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index c1c18adf..77de8a97 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -1199,6 +1199,10 @@ subroutine create_calclevel_shortcut(self,levelstring) self%id = jobtype%turbomole self%rdgrad = .false. self%binary = 'gp3' + case ('gxtb') + self%id = jobtype%turbomole + self%rdgrad = .false. + self%binary = 'gxtb' case ('orca') self%id = jobtype%orca diff --git a/src/calculator/turbom_sc.f90 b/src/calculator/turbom_sc.f90 index 39383c94..0282950d 100644 --- a/src/calculator/turbom_sc.f90 +++ b/src/calculator/turbom_sc.f90 @@ -32,11 +32,12 @@ module turbom_sc implicit none !>--- private module variables and parameters private - integer,parameter :: nf = 6 + integer,parameter :: nf = 7 character(len=*),parameter :: oldfiles(nf) = [& & 'energy ','ceh.charges ', & & 'output ','.data ', & - & 'NOT_CONVERGED','gp3restart ' ] + & 'NOT_CONVERGED','gp3restart ', & + & 'gxtbrestart '] character(len=*),parameter :: ridft = 'ridft' !> Turbomoles 'ridft' character(len=*),parameter :: xyzn = 'coord' !> input coords must be in coord character(len=*),parameter :: ef = 'energy' !> energy will be read from file energy From 0aeb97858953b7f15f214e43de12a69dc876fe91 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 26 Jun 2025 12:23:28 +0200 Subject: [PATCH 052/374] Fix missin comma in qcg, see issue #423 --- src/qcg/solvtool_misc.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/qcg/solvtool_misc.f90 b/src/qcg/solvtool_misc.f90 index 1c6b6724..3ff1ca92 100644 --- a/src/qcg/solvtool_misc.f90 +++ b/src/qcg/solvtool_misc.f90 @@ -232,7 +232,7 @@ subroutine xtb_dock(env, fnameA, fnameB, solu, clus) call new_ompautoset(env,'auto',1,T,Tn) !--- Jobcall docking - write (jobcall, '(a,1x,''dock'',1x,a,1x,a,1x,a,1x,f4.2,1x,''--nfrag1'',1x,i0,1x,a,1x& + write (jobcall, '(a,1x,''dock'',1x,a,1x,a,1x,a,1x,f4.2,1x,''--nfrag1'',1x,i0,1x,a,1x, & & ''--input xcontrol > xtb_dock.out'',a)') & & trim(env%ProgName), trim(fnameA), trim(fnameB), trim(env%gfnver),& & env%optlev, solu%nat, trim(env%docking_qcg_flag), trim(pipe) From f74b25cae75f300225a77255cb162abf9232fb0f Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 23 Jul 2025 19:16:26 +0200 Subject: [PATCH 053/374] g-xTB numgrad implementation --- src/calculator/calc_type.f90 | 25 ++++- src/calculator/calculator.F90 | 65 ++++++++++++ src/calculator/printouts.F90 | 3 +- src/confparse.f90 | 176 ++++++++++++++++----------------- src/legacy_wrappers.f90 | 6 +- src/parsing/parse_calcdata.f90 | 13 ++- src/printouts.f90 | 59 ++++++----- 7 files changed, 228 insertions(+), 119 deletions(-) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 77de8a97..be1b93e5 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -97,6 +97,8 @@ module calc_type character(len=:),allocatable :: shortflag !> shorter job description !>--- gradient format specifications + logical :: numgrad = .false. !> run numerical gradient (expensive!) + real(wp) :: gradstep = 0.0005_wp !> displacement for numerical gradient logical :: rdgrad = .true. integer :: gradtype = 0 integer :: gradfmt = 0 @@ -1091,6 +1093,9 @@ subroutine calculation_settings_info(self,iunit) character(len=*),parameter :: fmt3 = '(" :",2x,a20," : ",a)' character(len=*),parameter :: fmt4 = '(" :",1x,a)' character(len=20) :: atmp + logical :: gxtbwarn + + gxtbwarn=.false. if (allocated(self%description)) then write (iunit,'(" :",1x,a)') trim(self%description) @@ -1111,7 +1116,12 @@ subroutine calculation_settings_info(self,iunit) end if if (any((/jobtype%orca,jobtype%xtbsys,jobtype%turbomole, & & jobtype%generic,jobtype%terachem/) == self%id)) then - write (iunit,'(" :",3x,a,a)') 'selected binary : ',trim(self%binary) + if(index(self%binary,'gxtb').ne.0)then + write(iunit,fmt4) 'g-xTB (development version)' + gxtbwarn = .true. + else + write (iunit,'(" :",3x,a,a)') 'selected binary : ',trim(self%binary) + endif end if if (self%refine_lvl > 0) then write (atmp,*) 'refinement stage' @@ -1169,6 +1179,11 @@ subroutine calculation_settings_info(self,iunit) endif end if + if(gxtbwarn)then + write(iunit,fmt4) 'WARNING: This currently the development version of g-xTB.' + write(iunit,fmt4) 'WARNING: Gradients are NUMERICAL (i.e., expensive and noisy!)' + endif + end subroutine calculation_settings_info !=========================================================================================! @@ -1199,10 +1214,14 @@ subroutine create_calclevel_shortcut(self,levelstring) self%id = jobtype%turbomole self%rdgrad = .false. self%binary = 'gp3' - case ('gxtb') + case ('gxtb','gxtb_dev') self%id = jobtype%turbomole self%rdgrad = .false. - self%binary = 'gxtb' + self%binary = 'gxtb' + self%rdwbo = .false. + if(index(levelstring,'_dev').ne.0)then + self%numgrad = .true. + endif case ('orca') self%id = jobtype%orca diff --git a/src/calculator/calculator.F90 b/src/calculator/calculator.F90 index 9cd47931..85e02162 100644 --- a/src/calculator/calculator.F90 +++ b/src/calculator/calculator.F90 @@ -179,6 +179,9 @@ subroutine engrad_mol(mol,calc,energy,gradient,iostatus) !==========================================! call potential_core(molptr,calc,i,iostatus) !==========================================! + !> and numerical gradient, if selected + !==========================================! + call numgrad_core(molptr,calc,i,iostatus) !==========================================! if (iostatus /= 0) then @@ -382,6 +385,68 @@ subroutine potential_core(molptr,calc,id,iostatus) end subroutine potential_core + subroutine numgrad_core(molptr,calc,id,iostatus) +!******************************************************* +!* subroutine numgrad +!* routine to perform a numerical gradient calculation +!******************************************************* + implicit none + type(coord),intent(in) :: molptr + type(calcdata),intent(inout) :: calc + integer,intent(in) :: id + integer,intent(out) :: iostatus + + integer :: i,j,k,l,ich,och,io,pnat + type(coord),allocatable :: moltmp + real(wp) :: energy,el,er, step,step2 + real(wp),allocatable :: ngrd(:,:) + !real(wp),parameter :: step = 0.0005_wp + !real(wp),parameter :: step2 = 0.5_wp/step + + if (id > calc%ncalculations) return + if (.not.calc%calcs(id)%numgrad) return + + pnat = molptr%nat + step = calc%calcs(id)%gradstep + step2 = 0.5_wp/step + + !> back up energy + energy = calc%etmp(id) + + !> allocate temprorary gradient space + !$omp critical + allocate(ngrd(3,pnat), source=0.0_wp) + allocate(moltmp, source=molptr) + !$omp end critical + + do i = 1,molptr%nat + do j = 1,3 + moltmp%xyz(j,i) = moltmp%xyz(j,i)+step + call potential_core(moltmp,calc,id,iostatus) + er = calc%etmp(id) + + moltmp%xyz(j,i) = moltmp%xyz(j,i)-2*step + call potential_core(moltmp,calc,id,iostatus) + el = calc%etmp(id) + + moltmp%xyz(j,i) = moltmp%xyz(j,i)+step + ngrd(j,i) = step2*(er-el) + end do + end do + + !> transfer tmp gradient to the calc object + calc%grdtmp(:,1:pnat,id) = ngrd(:,1:pnat) + !$omp critical + deallocate(moltmp) + deallocate(ngrd) + !$omp end critical + + !> restore the energy + calc%etmp(id) = energy + + return + end subroutine numgrad_core + !========================================================================================! !========================================================================================! !========================================================================================! diff --git a/src/calculator/printouts.F90 b/src/calculator/printouts.F90 index b2658be6..e426c39a 100644 --- a/src/calculator/printouts.F90 +++ b/src/calculator/printouts.F90 @@ -131,7 +131,8 @@ subroutine calculation_summary(calc,mol,energy,grad,molnew,iounit,print) end if !>--- gradients - if (all(calc%calcs(:)%rdgrad.eqv..false.)) then + if (all(calc%calcs(:)%rdgrad.eqv..false.) .and. & + & all(calc%calcs(:)%numgrad.eqv..false.) ) then write (iunit,*) write (iunit,'(a)') '> No gradients calculated' else if (present(grad)) then diff --git a/src/confparse.f90 b/src/confparse.f90 index ddb05e29..93180ec1 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -94,12 +94,12 @@ subroutine parseflags(env,arg,nra) !>--- check if help is requested or citations shall be diplayed do i = 1,nra if (any((/character(6)::'-h','-H','--h','--H','--help'/) == trim(arg(i)))) then - if(nra > i)then - ctmp=trim(arg(i+1)) - if(ctmp(1:1).ne.'-')then + if (nra > i) then + ctmp = trim(arg(i+1)) + if (ctmp(1:1) .ne. '-') then call confscript_morehelp(ctmp) - endif - endif + end if + end if call confscript_help() end if if (any((/character(10)::'-cite','--cite','--citation'/) == trim(arg(i)))) then @@ -262,7 +262,6 @@ subroutine parseflags(env,arg,nra) error stop end if - !>--- options for constrained conformer sampling env%fixfile = 'none selected' @@ -423,7 +422,6 @@ subroutine parseflags(env,arg,nra) env%inputcoords = env%ensemblename !> just for a printout exit - case ('-pka','-pKa') !> pKa calculation script env%crestver = crest_pka env%runver = 33 @@ -529,7 +527,7 @@ subroutine parseflags(env,arg,nra) case ('-solvtool','-qcg') !> Set solute file if present - if(i == 2) env%solu_file = trim(arg(i-1)) + if (i == 2) env%solu_file = trim(arg(i-1)) !> Set solvent file if prensent !> If it is another argument, it doesent matter as solvent file is checke in solvtool if (nra >= i+1) env%solv_file = trim(arg(i+1)) @@ -555,7 +553,7 @@ subroutine parseflags(env,arg,nra) env%autozsort = .false. exit - case ('-msreact') + case ('-msreact') env%crestver = crest_msreac env%preopt = .false. env%presp = .true. @@ -643,7 +641,7 @@ subroutine parseflags(env,arg,nra) case ('-rmsd','-rmsdheavy','-hrmsd') ctmp = trim(arg(i+1)) dtmp = trim(arg(i+2)) - if ((argument == '-rmsdheavy').or.(argument=='-hrmsd')) then + if ((argument == '-rmsdheavy').or.(argument == '-hrmsd')) then call quick_rmsd_tool(ctmp,dtmp,.true.) else call quick_rmsd_tool(ctmp,dtmp,.false.) @@ -715,7 +713,7 @@ subroutine parseflags(env,arg,nra) env%preopt = .false. env%crestver = crest_optimize env%legacy = .false. - if(argument.eq.'-ohess') env%crest_ohess=.true. + if (argument .eq. '-ohess') env%crest_ohess = .true. exit case ('-hess','-numhess') !> Numerical hessian @@ -1039,40 +1037,40 @@ subroutine parseflags(env,arg,nra) !========================================================================================! if (env%crestver == crest_msreac) then select case (argument) !> msreact - case('-msei') - env%msei=.true. - case('-mscid') - env%mscid=.true. - env%msei=.false. - case('-msnoiso') !> filter out non fragmentated structures in msreact - env%msnoiso=.true. - case('-msiso') !> filter out fragmentated structures in msreact - env%msiso=.true. - case('-msnbonds') ! give number of bonds up to which bias potential is added between atoms default 3 - call readl(arg(i + 1),xx,j) + case ('-msei') + env%msei = .true. + case ('-mscid') + env%mscid = .true. + env%msei = .false. + case ('-msnoiso') !> filter out non fragmentated structures in msreact + env%msnoiso = .true. + case ('-msiso') !> filter out fragmentated structures in msreact + env%msiso = .true. + case ('-msnbonds') ! give number of bonds up to which bias potential is added between atoms default 3 + call readl(arg(i+1),xx,j) env%msnbonds = xx(1) - case('-msnshifts') ! give number of times atoms are randomly shifted before optimization - call readl(arg(i + 1),xx,j) + case ('-msnshifts') ! give number of times atoms are randomly shifted before optimization + call readl(arg(i+1),xx,j) env%msnshifts = xx(1) - case('-msnshifts2') ! give number of times atoms are randomly shifted before applying the constrained optimization default 0 - call readl(arg(i + 1),xx,j) + case ('-msnshifts2') ! give number of times atoms are randomly shifted before applying the constrained optimization default 0 + call readl(arg(i+1),xx,j) env%msnshifts2 = xx(1) - case('-msnfrag') ! give number of structures that should be generated - call readl(arg(i + 1),xx,j) + case ('-msnfrag') ! give number of structures that should be generated + call readl(arg(i+1),xx,j) env%msnfrag = xx(1) - case('-msmolbar') !> filter out structures with same molbar code in msreact - env%msmolbar=.true. - case('-msinchi') !> filter out structures with same inchi code in msreact - env%msinchi=.true. - case('-msnoattrh') !> add attractive potential for H-atoms - env%msattrh=.false. - case('-mslargeprint') !> additional printouts and keep MSDIR - env%mslargeprint=.true. - case('-msinput') ! give number of times atoms are randomly shifted before applying the constrained optimization default 0 - ctmp = trim(arg(i+1)) - if (ctmp(1:1) .ne. '-') then - env%msinput = trim(ctmp) - end if + case ('-msmolbar') !> filter out structures with same molbar code in msreact + env%msmolbar = .true. + case ('-msinchi') !> filter out structures with same inchi code in msreact + env%msinchi = .true. + case ('-msnoattrh') !> add attractive potential for H-atoms + env%msattrh = .false. + case ('-mslargeprint') !> additional printouts and keep MSDIR + env%mslargeprint = .true. + case ('-msinput') ! give number of times atoms are randomly shifted before applying the constrained optimization default 0 + ctmp = trim(arg(i+1)) + if (ctmp(1:1) .ne. '-') then + env%msinput = trim(ctmp) + end if end select !> msreact end if !========================================================================================! @@ -1092,7 +1090,7 @@ subroutine parseflags(env,arg,nra) env%performCross = .true. !> do the genetic crossing env%autozsort = .true. case ('-keepdir','-keeptmp') !> Do not delete temporary directories at the end - env%keepModef = .true. + env%keepModef = .true. case ('-opt','-optlev') !> settings for optimization level of GFN-xTB env%optlev = optlevnum(arg(i+1)) write (*,'(2x,a,1x,a)') trim(arg(i)),optlevflag(env%optlev) @@ -1111,7 +1109,7 @@ subroutine parseflags(env,arg,nra) write (*,'(2x,a,'' : Use of GFN1-xTB requested.'')') env%gfnver case ('-gfn2') env%gfnver = '--gfn2' - write (*,'(2x,a,'' : Use of GFN2-xTB requested.'')') env%gfnver + write (*,'(2x,a,'' : Use of GFN2-xTB requested.'')') env%gfnver case ('-gfn0') env%gfnver = '--gfn0' write (*,'(2x,a,'' : Use of GFN0-xTB requested.'')') env%gfnver @@ -1123,7 +1121,7 @@ subroutine parseflags(env,arg,nra) ctype = 5 !> bond constraint activated if (any((/crest_imtd,crest_imtd2/) == env%crestver)) then bondconst = .true. - endif + end if env%cts%cbonds_md = .true. env%checkiso = .true. case ('stereoisomers') @@ -1131,6 +1129,8 @@ subroutine parseflags(env,arg,nra) case default env%gfnver = '--gfn2' end select !> GFN + case ('-gxtb_dev') + env%gfnver = 'gxtb_dev' case ('-gfn2@gfn0','-gfn2@gfn1','-gfn2@gff','-gfn2@ff','-gfn2@gfnff') if (.not.env%legacy) then !TODO write (*,'("> ",a,1x,a)') argument,'option not yet available with new calculator' @@ -1173,14 +1173,14 @@ subroutine parseflags(env,arg,nra) write (*,'(2x,a,a)') argument,' : energy reweighting' end if - case('-refine','-rsp','-ropt') !> add one refinement step (via cmd only one is possible) + case ('-refine','-rsp','-ropt') !> add one refinement step (via cmd only one is possible) env%legacy = .false. !> new calculators only! - if(nra >= i+1)then + if (nra >= i+1) then env%gfnver2 = trim(arg(i+1)) write (*,'(2x,a,1x,a,a)') argument,trim(env%gfnver2), & & ' : adding refinement step (singlepoint on optimized structures)' - endif - + end if + case ('-charges') !> read charges from file for GFN-FF calcs. ctmp = trim(arg(i+1)) if ((len_trim(ctmp) < 1).or.(ctmp(1:1) == '-')) then @@ -1209,8 +1209,8 @@ subroutine parseflags(env,arg,nra) if (io .eq. 0) env%cts%dscal = rdum end if case ('-mtd_kscal','-mtdkscal') - call readl(arg(i+1),xx,j) - env%mtd_kscal = xx(1) + call readl(arg(i+1),xx,j) + env%mtd_kscal = xx(1) case ('-norestart') env%allowrestart = .false. case ('-readbias') @@ -1436,10 +1436,10 @@ subroutine parseflags(env,arg,nra) env%potpad = xx(1) case ('-watoms','-wat') ctmp = arg(i+1) - if(ctmp(1:1) .ne. '-')then - env%potatlist = trim(ctmp) - write(*,*) env%potatlist - endif + if (ctmp(1:1) .ne. '-') then + env%potatlist = trim(ctmp) + write (*,*) env%potatlist + end if case ('-wall') env%wallsetup = .true. write (*,'(2x,a,1x,a)') '--wall:','requesting setup of wall potential' @@ -1599,8 +1599,8 @@ subroutine parseflags(env,arg,nra) env%protb%threshsort = .true. ctmp = trim(arg(i+1)) if (ctmp(1:1) .ne. '-') then - read(ctmp,*,iostat=io) idum - if(io.eq.0) env%protb%amount = idum + read (ctmp,*,iostat=io) idum + if (io .eq. 0) env%protb%amount = idum end if case ('-swel') !> switch out H+ to something else in protonation script if (env%properties .eq. -3) then @@ -1612,8 +1612,8 @@ subroutine parseflags(env,arg,nra) env%protb%threshsort = .true. ctmp = trim(arg(i+1)) if (ctmp(1:1) .ne. '-') then - read(ctmp,*,iostat=io) idum - if(io.eq.0) env%protb%amount = idum + read (ctmp,*,iostat=io) idum + if (io .eq. 0) env%protb%amount = idum end if case ('-tautomerize') !> tautomerization tool env%properties = p_tautomerize @@ -1811,7 +1811,7 @@ subroutine parseflags(env,arg,nra) env%final_gfn2_opt = .false. case ('-directed') !> specify the directed list env%qcg_flag = .true. - ctmp = trim(arg(i + 1)) + ctmp = trim(arg(i+1)) if (ctmp(1:1) .ne. '-') then env%directed_file = trim(ctmp) write (*,'(2x,a,1x,a)') trim(argument)//' :',trim(ctmp) @@ -2067,7 +2067,7 @@ subroutine parseflags(env,arg,nra) end if !>--- automatic wall potential for the LEGACY version - if (env%NCI.or.env%wallsetup .and. env%legacy) then + if (env%NCI.or.env%wallsetup.and.env%legacy) then call wallpot(env) if (env%wallsetup) then write (*,'(2x,a)') 'Automatically generated ellipsoide potential:' @@ -2139,21 +2139,21 @@ subroutine parseflags(env,arg,nra) env%lmover = env%gfnver end if end if - if (env%ensemble_opt == '--gfn2' .or. env%gfnver == '--gfn2') & + if (env%ensemble_opt == '--gfn2'.or.env%gfnver == '--gfn2') & & env%final_gfn2_opt = .false. !Prevent additional opt. if (env%useqmdff) then env%autozsort = .false. end if - if (.not.env%preopt .and. env%crestver.ne.crest_trialopt) then + if (.not.env%preopt.and.env%crestver .ne. crest_trialopt) then if (allocated(env%ref%topo)) deallocate (env%ref%topo) end if !>-- turn off niceprint if we are not writing to terminal - if(env%niceprint)then + if (env%niceprint) then env%niceprint = myisatty(output_unit) - endif + end if !>-- driver for optimization along trajectory, additional settings if (.not.any((/crest_mfmdgc,crest_imtd,crest_imtd2,crest_compr/) == env%crestver) & @@ -2181,22 +2181,22 @@ subroutine parseflags(env,arg,nra) if (env%sdfformat) then env%autozsort = .false. end if - + !>--- 2023/08/19 moved zsort to a standalone property tool - if(env%autozsort)then + if (env%autozsort) then env%properties = p_zsort - endif + end if !>--- convert ProgName to absolute path (to make legacy routines more stable) ctmp = absolute_filepath(trim(env%ProgName)) env%ProgName = ctmp !>--- for legacy runtypes, check if xtb is present - if(env%legacy.or.env%QCG)then + if (env%legacy.or.env%QCG) then call checkprog_silent(env%ProgName,.true.,iostat=io) - if(io /= 0 ) error stop - write(stdout,'(/,a,a)') 'Selected path to xtb binary: ',trim(env%Progname) - endif + if (io /= 0) error stop + write (stdout,'(/,a,a)') 'Selected path to xtb binary: ',trim(env%Progname) + end if !========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>! @@ -2207,25 +2207,25 @@ subroutine parseflags(env,arg,nra) write (stdout,'(/,a)',advance='no') '> Setting up backup calculator ...' flush (stdout) call env2calc_setup(env) - write(stdout,*) 'done.' + write (stdout,*) 'done.' call env%calc%info(stdout) end if !>--- pass on opt-level to new calculator - if(.not.env%legacy)then - env%calc%optlev = nint(env%optlev) - endif + if (.not.env%legacy) then + env%calc%optlev = nint(env%optlev) + end if !>--- ONIOM setup from toml file - if (allocated(env%ONIOM_toml))then - allocate(env%calc%ONIOM) - call ONIOM_read_toml(env%ONIOM_toml,env%nat,env%ref%at,env%ref%xyz,env%calc%ONIOM) + if (allocated(env%ONIOM_toml)) then + allocate (env%calc%ONIOM) + call ONIOM_read_toml(env%ONIOM_toml,env%nat,env%ref%at,env%ref%xyz,env%calc%ONIOM) call env%calc%ONIOMexpand() - endif + end if !>--- important printouts - if( .not.env%legacy)then + if (.not.env%legacy) then call print_frozen(env) - endif + end if return end subroutine parseflags @@ -2283,7 +2283,7 @@ subroutine parseRC2(env,bondconst) else env%cts%used = .false. return - end if + end if !>--- read the data call read_constrainbuffer(env%constraints,env%cts) @@ -2298,9 +2298,9 @@ subroutine parseRC2(env,bondconst) end if end do end if - if(.not.env%legacy)then + if (.not.env%legacy) then call parse_xtbinputfile(env,env%constraints) - endif + end if !>--- some settings create = .false. @@ -2450,7 +2450,7 @@ subroutine inputcoords(env,arg) else inputfile = 'coord' end if - if(.not.allocated(env%inputcoords)) env%inputcoords = inputfile + if (.not.allocated(env%inputcoords)) env%inputcoords = inputfile !>-- if the input was a SDF file, special handling env%sdfformat = .false. @@ -2464,16 +2464,16 @@ subroutine inputcoords(env,arg) if (.not.allocated(env%inputcoords)) env%inputcoords = 'coord' call mol%open('coord') !>-- shift to CMA and/or align according to rot.const. We have to be careful about this. - if (any((/ crest_sp, crest_optimize, crest_numhessian, crest_trialopt /) == env%crestver))then + if (any((/crest_sp,crest_optimize,crest_numhessian,crest_trialopt/) == env%crestver)) then !> some runtypes should only do a CMA translation, but no rotation call CMAtrf(mol%nat,mol%nat,mol%at,mol%xyz) - else if (env%crestver == crest_solv)then + else if (env%crestver == crest_solv) then !> runtypes like qcg must not modify input coordinates! continue else !> all other can align with rot. axis call axis(mol%nat,mol%at,mol%xyz) - endif + end if !>-- overwrite coord call mol%write('coord') diff --git a/src/legacy_wrappers.f90 b/src/legacy_wrappers.f90 index cc4d7e3f..e32cd2cd 100644 --- a/src/legacy_wrappers.f90 +++ b/src/legacy_wrappers.f90 @@ -52,7 +52,8 @@ subroutine env2calc(env,calc,molin) cal%rdwbo = .false. cal%rddip = .false. !> except for SP runtype (from command line!) - if (env%crestver == crest_sp) then + if (env%crestver == crest_sp.and. & + & cal%id .ne. jobtype%turbomole) then cal%rdwbo = .true. cal%rddip = .true. cal%rdqat = .true. @@ -406,13 +407,12 @@ subroutine tautomerize(env,tim) end if end subroutine tautomerize - !========================================================================================! subroutine catchdiatomic(env) !**************************************** !* subroutine catchdiatomic -!* if we only have one or two atoms just +!* if we only have one or two atoms just !* write the "optimized" structure !**************************************** use crest_data diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index a317e5d4..9b23259f 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -239,8 +239,12 @@ subroutine parse_setting_auto(env,job,kv,rd) job%id = jobtype%gfn0occ case ('gfnff','gff','gfn-ff') job%id = jobtype%gfnff - case ('pvol','libpvol', 'pv') + case ('pvol','libpvol','pv') job%id = jobtype%libpvol + case ('gxtb_dev') + job%id = jobtype%turbomole + job%rdgrad = .false. + job%binary = 'gxtb' case ('none') job%id = jobtype%unknown case ('lj','lennard-jones') @@ -290,6 +294,11 @@ subroutine parse_setting_auto(env,job,kv,rd) case ('gradmt') job%gradfmt = conv2gradfmt(kv%value_c) + case ('numgrad') + job%numgrad = kv%value_b + case ('gradstep') + job%gradstep = kv%value_f + case ('efile') job%efile = kv%value_c @@ -822,7 +831,7 @@ subroutine parse_constraint_auto(env,calc,constr,kv,success,rd) dum4 = kv%value_fa(6) call constr%bondrangeconstraint(atm1,atm2,dum1,dum2,beta=dum3,T=dum4) case default - write(stdout,'(a)') '**ERROR** wrong number of arguments in bondrange constraint' + write (stdout,'(a)') '**ERROR** wrong number of arguments in bondrange constraint' call creststop(status_config) end select success = .true. diff --git a/src/printouts.f90 b/src/printouts.f90 index 00592cc7..fecb8f31 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -80,29 +80,44 @@ subroutine box3(version,date,commit,author) character(len=*) :: date character(len=*) :: commit character(len=*) :: author - character(len=200) :: logo(10) + character(len=200) :: logo(13) character(len=200) :: info(2) integer,parameter :: pad_left = 7 integer :: i,lcount write (*,*) - write (logo(1),'(''╔════════════════════════════════════════════╗'')') - write (logo(2),'(''║ ___ ___ ___ ___ _____ ║'')') - write (logo(3),'(''║ / __| _ \ __/ __|_ _| ║'')') - write (logo(4),'(''║ | (__| / _|\__ \ | | ║'')') - write (logo(5),'(''║ \___|_|_\___|___/ |_| ║'')') - write (logo(6),'(''║ ║'')') - write (logo(7),'(''║ Conformer-Rotamer Ensemble Sampling Tool ║'')') - write (logo(8),'(''║ based on the xTB methods ║'')') - write (logo(9),'(''║ ║'')') - write (logo(10),'("╚════════════════════════════════════════════╝")') - do i = 1,10 - write (*,'(a,a)') repeat(" ",pad_left),trim(logo(i)) + !write (logo(1),'(''╔════════════════════════════════════════════╗'')') + !write (logo(2),'(''║ ___ ___ ___ ___ _____ ║'')') + !write (logo(3),'(''║ / __| _ \ __/ __|_ _| ║'')') + !write (logo(4),'(''║ | (__| / _|\__ \ | | ║'')') + !write (logo(5),'(''║ \___|_|_\___|___/ |_| ║'')') + !write (logo(6),'(''║ ║'')') + !write (logo(7),'(''║ Conformer-Rotamer Ensemble Sampling Tool ║'')') + !write (logo(8),'(''║ based on the xTB methods ║'')') + !write (logo(9),'(''║ ║'')') + !write (logo(10),'("╚════════════════════════════════════════════╝")') + + write (logo(1), '(''╔════════════════════════════════════════════════╗'')') + write (logo(2), '(''║ ║'')') + write (logo(3), '(''║ ██████╗██████╗ ███████╗███████╗████████╗ ║'')') + write (logo(4), '(''║ ██╔════╝██╔══██╗██╔════╝██╔════╝╚══██╔══╝ ║'')') + write (logo(5), '(''║ ██║ ██████╔╝█████╗ ███████╗ ██║ ║'')') + write (logo(6), '(''║ ██║ ██╔══██╗██╔══╝ ╚════██║ ██║ ║'')') + write (logo(7), '(''║ ╚██████╗██║ ██║███████╗███████║ ██║ ║'')') + write (logo(8), '(''║ ╚═════╝╚═╝ ╚═╝╚══════╝╚══════╝ ╚═╝ ║'')') + write (logo(9), '(''║ ║'')') + write (logo(10),'(''║ Conformer-Rotamer Ensemble Sampling Tool ║'')') + write (logo(11),'(''║ based on the xTB methods ║'')') + write (logo(12),'(''║ ║'')') + write (logo(13),'(''╚════════════════════════════════════════════════╝'')') + + do i = 1,13 + write (*,'(a,a)') repeat(" ",pad_left),trim(logo(i)) end do - write (*,'(a,''Version '',a,'', '',a)') repeat(" ",pad_left),trim(version),trim(date) + write (*,'(a,'' Version '',a,'', '',a)') repeat(" ",pad_left),trim(version),trim(date) if(author(1:2).eq."'@")then - write (*,'(a,"commit (",a,") compiled by ",a)') repeat(" ",pad_left),commit,"'usr"//author(2:) + write (*,'(a," commit (",a,") compiled by ",a)') repeat(" ",pad_left),commit,"'usr"//author(2:) else - write (*,'(a,"commit (",a,") compiled by ",a)') repeat(" ",pad_left),commit,author + write (*,'(a," commit (",a,") compiled by ",a)') repeat(" ",pad_left),commit,author endif end subroutine box3 @@ -651,17 +666,17 @@ end subroutine mtdwarning subroutine printiter implicit none write (*,*) - write (*,'(90("*"))') - write (*,'("**",25x,"N E W I T E R A T I O N C Y C L E",25x,"**")') - write (*,'(90("*"))') + write (*,'(80("*"))') + write (*,'("**",20x,"N E W I T E R A T I O N C Y C L E",20x,"**")') + write (*,'(80("*"))') end subroutine printiter subroutine printiter2(i) implicit none integer :: i write (*,*) - write (*,'(90("*"))') - write (*,'("**",26x,"I T E R A T I O N C Y C L E ",i3,23x,"**")') i - write (*,'(90("*"))') + write (*,'(80("*"))') + write (*,'("**",21x,"I T E R A T I O N C Y C L E ",i3,18x,"**")') i + write (*,'(80("*"))') end subroutine printiter2 !========================================================================================! From db0b5e63aa26610425a426794b83933524a36c12 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 23 Jul 2025 22:32:38 +0200 Subject: [PATCH 054/374] Use gxtb's internal numerical gradient to avoid reinitialization overhead --- src/calculator/calc_type.f90 | 5 +- src/calculator/gradreader.f90 | 13 ++- src/confparse.f90 | 4 + src/parsing/parse_calcdata.f90 | 3 +- src/printouts.f90 | 192 ++++++++++++++++++--------------- 5 files changed, 122 insertions(+), 95 deletions(-) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index be1b93e5..3b61bc49 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -1180,7 +1180,7 @@ subroutine calculation_settings_info(self,iunit) end if if(gxtbwarn)then - write(iunit,fmt4) 'WARNING: This currently the development version of g-xTB.' + write(iunit,fmt4) 'WARNING: This currently is the development version of g-xTB.' write(iunit,fmt4) 'WARNING: Gradients are NUMERICAL (i.e., expensive and noisy!)' endif @@ -1220,7 +1220,8 @@ subroutine create_calclevel_shortcut(self,levelstring) self%binary = 'gxtb' self%rdwbo = .false. if(index(levelstring,'_dev').ne.0)then - self%numgrad = .true. + self%other = '-grad' + self%rdgrad=.true. endif case ('orca') self%id = jobtype%orca diff --git a/src/calculator/gradreader.f90 b/src/calculator/gradreader.f90 index aa90514d..424c7a04 100644 --- a/src/calculator/gradreader.f90 +++ b/src/calculator/gradreader.f90 @@ -176,7 +176,7 @@ subroutine rd_grad_tm(iunit,nat,energy,grad,iostatus) integer,intent(out) :: iostatus integer :: c,io,n,i,j character(len=128) :: atmp - character(len=20) :: btmp(8) + character(len=20) :: btmp(10) real(wp) :: dum logical :: readblock @@ -184,7 +184,7 @@ subroutine rd_grad_tm(iunit,nat,energy,grad,iostatus) energy = 0.0_wp grad(:,:) = 0.0_wp - c = 0 + c = 1 readblock = .false. do read (iunit,'(a)',iostat=io) atmp @@ -192,11 +192,14 @@ subroutine rd_grad_tm(iunit,nat,energy,grad,iostatus) atmp = adjustl(atmp) if (atmp(1:4) == '$end') readblock = .false. if( readblock ) then + if(index(atmp,'cycle').ne.0)then - read(atmp,*) btmp(1:2),j,btmp(3:6),energy,btmp(7:8),dum + read(atmp,*) btmp(1:8) + read(btmp(7),*) energy elseif(c < nat)then !> skip coords c = c + 1 else !> read grad + !backspace(iunit) call rd_grad_n3(iunit,nat,grad,iostatus) exit endif @@ -270,7 +273,7 @@ subroutine rd_grad_3n(iunit,nat,grad,iostatus) grad(:,:) = 0.0_wp c = 0 - do i = 1,n + do i = 1,nat do j = 1,3 read (iunit,*,iostat=io) dum if (io < 0) then @@ -301,7 +304,7 @@ subroutine rd_grad_n3(iunit,nat,grad,iostatus) grad(:,:) = 0.0_wp c = 0 - do i = 1,n + do i = 1,nat read (iunit,*,iostat=io) dum(1:3) if (io < 0) then iostatus = 3 diff --git a/src/confparse.f90 b/src/confparse.f90 index 93180ec1..f06d639d 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -1129,8 +1129,12 @@ subroutine parseflags(env,arg,nra) case default env%gfnver = '--gfn2' end select !> GFN + + case ('-gxtb') + call gxtb_dev_warning() case ('-gxtb_dev') env%gfnver = 'gxtb_dev' + case ('-gfn2@gfn0','-gfn2@gfn1','-gfn2@gff','-gfn2@ff','-gfn2@gfnff') if (.not.env%legacy) then !TODO write (*,'("> ",a,1x,a)') argument,'option not yet available with new calculator' diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 9b23259f..00768671 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -243,8 +243,9 @@ subroutine parse_setting_auto(env,job,kv,rd) job%id = jobtype%libpvol case ('gxtb_dev') job%id = jobtype%turbomole - job%rdgrad = .false. + job%rdgrad = .true. job%binary = 'gxtb' + job%other ='-grad' case ('none') job%id = jobtype%unknown case ('lj','lennard-jones') diff --git a/src/printouts.f90 b/src/printouts.f90 index fecb8f31..f34ceada 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -95,30 +95,30 @@ subroutine box3(version,date,commit,author) !write (logo(8),'(''║ based on the xTB methods ║'')') !write (logo(9),'(''║ ║'')') !write (logo(10),'("╚════════════════════════════════════════════╝")') - - write (logo(1), '(''╔════════════════════════════════════════════════╗'')') - write (logo(2), '(''║ ║'')') - write (logo(3), '(''║ ██████╗██████╗ ███████╗███████╗████████╗ ║'')') - write (logo(4), '(''║ ██╔════╝██╔══██╗██╔════╝██╔════╝╚══██╔══╝ ║'')') - write (logo(5), '(''║ ██║ ██████╔╝█████╗ ███████╗ ██║ ║'')') - write (logo(6), '(''║ ██║ ██╔══██╗██╔══╝ ╚════██║ ██║ ║'')') - write (logo(7), '(''║ ╚██████╗██║ ██║███████╗███████║ ██║ ║'')') - write (logo(8), '(''║ ╚═════╝╚═╝ ╚═╝╚══════╝╚══════╝ ╚═╝ ║'')') - write (logo(9), '(''║ ║'')') - write (logo(10),'(''║ Conformer-Rotamer Ensemble Sampling Tool ║'')') - write (logo(11),'(''║ based on the xTB methods ║'')') - write (logo(12),'(''║ ║'')') - write (logo(13),'(''╚════════════════════════════════════════════════╝'')') + + write (logo(1),'(''╔════════════════════════════════════════════════╗'')') + write (logo(2),'(''║ ║'')') + write (logo(3),'(''║ ██████╗██████╗ ███████╗███████╗████████╗ ║'')') + write (logo(4),'(''║ ██╔════╝██╔══██╗██╔════╝██╔════╝╚══██╔══╝ ║'')') + write (logo(5),'(''║ ██║ ██████╔╝█████╗ ███████╗ ██║ ║'')') + write (logo(6),'(''║ ██║ ██╔══██╗██╔══╝ ╚════██║ ██║ ║'')') + write (logo(7),'(''║ ╚██████╗██║ ██║███████╗███████║ ██║ ║'')') + write (logo(8),'(''║ ╚═════╝╚═╝ ╚═╝╚══════╝╚══════╝ ╚═╝ ║'')') + write (logo(9),'(''║ ║'')') + write (logo(10),'(''║ Conformer-Rotamer Ensemble Sampling Tool ║'')') + write (logo(11),'(''║ based on the xTB methods ║'')') + write (logo(12),'(''║ ║'')') + write (logo(13),'(''╚════════════════════════════════════════════════╝'')') do i = 1,13 - write (*,'(a,a)') repeat(" ",pad_left),trim(logo(i)) + write (*,'(a,a)') repeat(" ",pad_left),trim(logo(i)) end do write (*,'(a,'' Version '',a,'', '',a)') repeat(" ",pad_left),trim(version),trim(date) - if(author(1:2).eq."'@")then - write (*,'(a," commit (",a,") compiled by ",a)') repeat(" ",pad_left),commit,"'usr"//author(2:) + if (author(1:2) .eq. "'@") then + write (*,'(a," commit (",a,") compiled by ",a)') repeat(" ",pad_left),commit,"'usr"//author(2:) else - write (*,'(a," commit (",a,") compiled by ",a)') repeat(" ",pad_left),commit,author - endif + write (*,'(a," commit (",a,") compiled by ",a)') repeat(" ",pad_left),commit,author + end if end subroutine box3 subroutine disclaimer @@ -160,7 +160,7 @@ subroutine confscript_morehelp(flag) character(len=*),intent(in) :: flag write (*,'(80("-"))') - write(*,*) + write (*,*) select case (flag) case default write (*,'(/,1x,''General, technical, and calculation options:'')') @@ -322,22 +322,22 @@ subroutine confscript_morehelp(flag) write (*,'(5x,''-freqscal : defines frequency scale factor. Only for outprint'')') write (*,'(5x,''-freqlvl [method] : define a method for frequency computation. All gfn versions are supported'')') write (*,*) - - case('msreact') + + case ('msreact') write (*,'(1x,'' mass spectral fragment generator (msreact)'')') write (*,'(1x,''General usage :'')') write (*,'(5x,'' -msreact [options]'')') write (*,'(1x,''options:'')') - write(*,'(5x,''-msnoattrh : deactivate attractive potential between hydrogen and LMO centers)'')') - write(*,'(5x,''-msnshifts [int] : perform n optimizations with randomly shifted atom postions (default 0) '')') - write(*,'(5x,''-msnshifts2 [int] : perform n optimizations with randomly shifted atom postions and repulsive potential applied to bonds (default 0) '')') - write(*,'(5x ''-msnbonds [int] : maximum number of bonds between atoms pairs for applying repulsive potential (default 3)'')') - write(*,'(5x,''-msmolbar : sort out topological duplicates by molbar codes (requires sourced "molbar")'')') - write(*,'(5x,''-msinchi : sort out topological duplicates by inchi codes (requires sourced "obabel")'')') - write(*,'(5x ''-msnfrag [int] : number of fragments that are printed by msreact (random selection)'')') - write(*,'(5x,''-msiso : print only non-dissociated structures (isomers)'')') - write(*,'(5x,''-msnoiso : print only dissociated structures'')') - write(*,'(5x,''-mslargeprint : do not remove temporary files and MSDIR do not remove temporary files and MSDIR with constrained optimizations'')') + write (*,'(5x,''-msnoattrh : deactivate attractive potential between hydrogen and LMO centers)'')') + write (*,'(5x,''-msnshifts [int] : perform n optimizations with randomly shifted atom postions (default 0) '')') + write (*,'(5x,''-msnshifts2 [int] : perform n optimizations with randomly shifted atom postions and repulsive potential applied to bonds (default 0) '')') + write (*,'(5x ''-msnbonds [int] : maximum number of bonds between atoms pairs for applying repulsive potential (default 3)'')') + write (*,'(5x,''-msmolbar : sort out topological duplicates by molbar codes (requires sourced "molbar")'')') + write (*,'(5x,''-msinchi : sort out topological duplicates by inchi codes (requires sourced "obabel")'')') + write (*,'(5x ''-msnfrag [int] : number of fragments that are printed by msreact (random selection)'')') + write (*,'(5x,''-msiso : print only non-dissociated structures (isomers)'')') + write (*,'(5x,''-msnoiso : print only dissociated structures'')') + write (*,'(5x,''-mslargeprint : do not remove temporary files and MSDIR do not remove temporary files and MSDIR with constrained optimizations'')') write (*,'(5x,''-chrg : set the molecules´ charge'')') write (*,'(5x,''-ewin : set energy window in for sorting out fragments kcal/mol,'')') write (*,'(5x,'' [default: 200.0 kcal/mol] '')') @@ -349,7 +349,7 @@ subroutine confscript_morehelp(flag) write (*,'(5x,'' fc_rep : force constant for repulsive potential between atom pairs (default 0.5) '')') write (*,'(5x,'' fc_attr : force constant for attractive potential between hydrogen and LMO centers (default -0.5) '')') write (*,'(5x,'' etemp : electronic temperature in xTB optimizations'')') - + case ('other') write (*,'(1x,''Other tools for standalone use:'')') write (*,'(5x,''-zsort : use only the zsort subroutine'')') @@ -421,8 +421,8 @@ subroutine crestcite write (*,'( 5x,'' JCTC, 2022, 18 (5), 3174-3189.'')') write (*,'(/5x,''• P.Pracht, C.Bannwarth, JCTC, 2022, 18 (10), 6370-6385.'')') write (*,'(/3x,''• P.Pracht, S.Grimme, C.Bannwarth, F.Bohle, S.Ehlert,'')') - write (*,'( 3x,'' G.Feldmann, J.Gorges, M.Müller, T.Neudecker, C.Plett,'')') - write (*,'( 3x,'' S.Spicher, P.Steinbach, P.Wesołowski, F.Zeller,'')') + write (*,'( 3x,'' G.Feldmann, J.Gorges, M.Müller, T.Neudecker, C.Plett,'')') + write (*,'( 3x,'' S.Spicher, P.Steinbach, P.Wesołowski, F.Zeller,'')') write (*,'( 3x,'' J. Chem. Phys., 2024, 160, 114110.'')') write (*,'(/,/)') @@ -560,23 +560,23 @@ end subroutine qcg_head !========================================================================================! subroutine msreact_head() - implicit none - write (*,*) - write (*,'(2x,''========================================'')') - write (*,'(2x,''| |'')') - write (*,'(2x,''| MSREACT |'')') - write (*,'(2x,''| automated MS fragment generator |'')') - write (*,'(2x,''| |'')') - write (*,'(2x,''| University of Bonn, MCTC |'')') - write (*,'(2x,''========================================'')') - write (*,'(2x,'' S. Grimme, P. Pracht, J. Gorges.'')') - write (*,*) - write (*,'(3x,''Cite work conducted with this code as'')') - write (*,'(/,3x,''Philipp Pracht, Stefan Grimme, Christoph Bannwarth, Fabian Bohle, Sebastian Ehlert, Gereon Feldmann,'')') - write (*,'(3x,''Johannes Gorges, Marcel Müller, Tim Neudecker, Christoph Plett, Sebastian Spicher, Pit Steinbach,'')') - write (*,'(3x,''Patryk A. Wesolowski, and Felix Zeller J. Chem. Phys., 2024, submitted.'')') - write (*,*) - end subroutine msreact_head + implicit none + write (*,*) + write (*,'(2x,''========================================'')') + write (*,'(2x,''| |'')') + write (*,'(2x,''| MSREACT |'')') + write (*,'(2x,''| automated MS fragment generator |'')') + write (*,'(2x,''| |'')') + write (*,'(2x,''| University of Bonn, MCTC |'')') + write (*,'(2x,''========================================'')') + write (*,'(2x,'' S. Grimme, P. Pracht, J. Gorges.'')') + write (*,*) + write (*,'(3x,''Cite work conducted with this code as'')') + write (*,'(/,3x,''Philipp Pracht, Stefan Grimme, Christoph Bannwarth, Fabian Bohle, Sebastian Ehlert, Gereon Feldmann,'')') + write (*,'(3x,''Johannes Gorges, Marcel Müller, Tim Neudecker, Christoph Plett, Sebastian Spicher, Pit Steinbach,'')') + write (*,'(3x,''Patryk A. Wesolowski, and Felix Zeller J. Chem. Phys., 2024, submitted.'')') + write (*,*) +end subroutine msreact_head !========================================================================================! @@ -738,12 +738,12 @@ subroutine print_crest_metadata() write (*,'(2x,a,1x,a)') 'CREST version :',version write (*,'(2x,a,1x,a)') 'timestamp :',date write (*,'(2x,a,1x,a)') 'commit :',commit - if(author(1:2).eq."'@")then - l = len_trim(author) - write (*,'(2x,a,1x,a)') 'compiled by :',"'usr"//author(2:l) + if (author(1:2) .eq. "'@") then + l = len_trim(author) + write (*,'(2x,a,1x,a)') 'compiled by :',"'usr"//author(2:l) else - write (*,'(2x,a,1x,a)') 'compiled by :',author - endif + write (*,'(2x,a,1x,a)') 'compiled by :',author + end if write (*,'(2x,a,1x,a)') 'Fortran compiler :',fcompiler write (*,'(2x,a,1x,a)') 'C compiler :',ccompiler write (*,'(2x,a,1x,a)') 'build system :',bsystem @@ -1229,46 +1229,64 @@ end subroutine print_frozen !========================================================================================! subroutine progbar(percent,bar) - use crest_parameters - implicit none - real(wp),intent(in) :: percent - character(len=52),intent(inout) :: bar - integer :: i - integer :: done,notdone - - bar='[' + use crest_parameters + implicit none + real(wp),intent(in) :: percent + character(len=52),intent(inout) :: bar + integer :: i + integer :: done,notdone - done=nint(percent/2) - notdone=50-done + bar = '[' - do i=1,done - bar=trim(bar)//'#' - enddo + done = nint(percent/2) + notdone = 50-done + do i = 1,done + bar = trim(bar)//'#' + end do - do i=1,notdone - bar=trim(bar)//'-' - enddo + do i = 1,notdone + bar = trim(bar)//'-' + end do - bar=trim(bar)//']' + bar = trim(bar)//']' end subroutine progbar subroutine printprogbar(percent) - use crest_parameters - implicit none - real(wp),intent(in) :: percent - character(len=52) :: bar + use crest_parameters + implicit none + real(wp),intent(in) :: percent + character(len=52) :: bar - if(percent>0.0_wp)then - call progbar(percent,bar) - else - call progbar(0.0_wp,bar) - endif - write(0,FMT="(A1,A52,2x,F6.2,A)",ADVANCE="NO") achar(13), & - & bar, percent, '% finished.' - - flush(0) + if (percent > 0.0_wp) then + call progbar(percent,bar) + else + call progbar(0.0_wp,bar) + end if + write (0,FMT="(A1,A52,2x,F6.2,A)",ADVANCE="NO") achar(13), & + & bar,percent,'% finished.' + + flush (0) end subroutine printprogbar !========================================================================================! !========================================================================================! + +subroutine gxtb_dev_warning + use crest_parameters + use crest_data, only: status_ioerr + write (stdout,*) + write (stdout,'(a)') "!!! WARNING !!!" + write (stdout,'(a)') "You have selected g-xTB for your calculations, but currently only the" + write (stdout,'(a)') "preliminary binary version is available." + write (stdout,'(a)') "This version does NOT HAVE ANALYTICAL GRADIENTS available and uses" + write (stdout,'(a)') "NUMERICAL gradients which are SLOW and NOISY." + write (stdout,*) + write (stdout,'(a)') 'The cmd argument "--gxtb" will be disabled until an implementation' + write(stdout,'(a)') 'with analytical gradients is available' + write(stdout,*) + write (stdout,'(a)') 'Please use "--gxtb_dev" in the mean time.' + write (stdout,'(a)') "Make sure you have the dev version gxtb installed (https://github.com/grimme-lab/g-xtb)" + write(stdout,*) + call creststop(status_ioerr) +end subroutine gxtb_dev_warning From 5cca2134f1242c6997c5d1466a601127470f5579 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 31 Jul 2025 17:01:57 +0200 Subject: [PATCH 055/374] Unify call to parallel and serial basinhopping --- src/basinhopping/algo.f90 | 191 ++++++++++++++++++++++++++++++--- src/basinhopping/class.f90 | 5 + src/basinhopping/mc.f90 | 20 ++++ src/crest_main.f90 | 38 +++---- src/parsing/parse_calcdata.f90 | 3 + src/strucreader.f90 | 8 ++ 6 files changed, 229 insertions(+), 36 deletions(-) diff --git a/src/basinhopping/algo.f90 b/src/basinhopping/algo.f90 index 89fb44f9..96edf67b 100644 --- a/src/basinhopping/algo.f90 +++ b/src/basinhopping/algo.f90 @@ -17,6 +17,37 @@ ! along with crest. If not, see . !================================================================================! +module bh_algo_interface + implicit none + interface + subroutine single_basinhopping_core(env,mol,calc,structuredump) + use crest_data + use crest_calculator + use strucrd + implicit none + type(systemdata),intent(inout) :: env + type(coord),intent(inout) :: mol + type(coord),allocatable,intent(inout) :: structuredump(:) + type(calcdata),intent(inout) :: calc + end subroutine single_basinhopping_core + subroutine parallel_basinhopping_core(env,mol,calc,structuredump) + use crest_data + use crest_calculator + use strucrd + implicit none + !> INPUT/OUTPUT + type(systemdata),intent(inout) :: env + type(coord),intent(inout) :: mol + type(coord),allocatable,intent(inout) :: structuredump(:) + type(calcdata),intent(in) :: calc + end subroutine parallel_basinhopping_core + end interface +end module bh_algo_interface + +!================================================================================! +!================================================================================! +!================================================================================! + subroutine crest_basinhopping(env,tim) use crest_parameters use crest_data @@ -25,6 +56,7 @@ subroutine crest_basinhopping(env,tim) use cregen_interface,only:unionizeEnsembles use optimize_module use bh_module + use bh_algo_interface implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim @@ -33,13 +65,12 @@ subroutine crest_basinhopping(env,tim) logical :: pr,wr !========================================================================================! type(calcdata) :: calc - type(bh_class) :: bh real(wp) :: energy,gnorm real(wp),allocatable :: grad(:,:) integer :: nall type(coord),allocatable :: structuredump(:) - + logical :: parallel character(len=80) :: atmp character(len=*),parameter :: trjf = 'crest_quenched.xyz' !========================================================================================! @@ -72,6 +103,62 @@ subroutine crest_basinhopping(env,tim) call engrad(mol,calc,energy,grad,io) mol%energy = energy !> we need this to start the Markov-chain +!==========================================================================================! + parallel = .false. + if (allocated(env%bh_ref)) then + parallel = env%bh_ref%parallel + end if + +!=========================================================================================! + call tim%start(14,'Basin-Hopping (BH)') + + if (parallel) then + call parallel_basinhopping_core(env,mol,calc,structuredump) + else + call single_basinhopping_core(env,mol,calc,structuredump) + end if +!>--- dump saved minima + nall = size(structuredump,1) + open (newunit=ich,file=trjf) + call wrensemble(ich,nall,structuredump) + close (ich) + + if (io == 0) then + write (stdout,*) + write (stdout,*) 'BH run completed successfully' + write (stdout,*) 'Successfull quenches written to ',trjf + else + write (stdout,*) 'WARNING: BH run terminated ABNORMALLY' + env%iostatus_meta = status_failed + end if + + call tim%stop(14) + + if (allocated(structuredump)) deallocate (structuredump) + return +end subroutine crest_basinhopping + +subroutine single_basinhopping_core(env,mol,calc,structuredump) + use crest_parameters + use crest_data + use crest_calculator + use strucrd + use cregen_interface,only:unionizeEnsembles + use optimize_module + use bh_module + implicit none + type(systemdata),intent(inout) :: env + type(coord),intent(inout) :: mol + type(coord),allocatable,intent(inout) :: structuredump(:) + type(calcdata),intent(inout) :: calc +!========================================================================================! + integer :: i,j,k,l,io,ich,T,Tn,mciter + logical :: pr,wr + type(bh_class) :: bh + integer :: nall +!========================================================================================! + call new_ompautoset(env,'max',0,T,Tn) +!========================================================================================! !>--- actual basin hopping if (allocated(env%bh_ref)) then bh = env%bh_ref @@ -81,7 +168,6 @@ subroutine crest_basinhopping(env,tim) bh%stepsize(1) = 1.0_wp end if - call tim%start(14,'Basin-Hopping (BH)') nall = 0 do mciter = 1,bh%maxiter if (bh%maxiter > 1) call printiter2(mciter) @@ -93,23 +179,94 @@ subroutine crest_basinhopping(env,tim) & ethr=bh%ethr,rthr=bh%rthr) write (stdout,'(a,i0,a)') 'Currently ',nall,' structures saved!' end do + return +end subroutine single_basinhopping_core -!>--- dump saved minima - open (newunit=ich,file=trjf) - call wrensemble(ich,nall,structuredump) - close (ich) +subroutine parallel_basinhopping_core(env,mol,calc,structuredump) +!************************************************************************** +!* subroutine parallel_basinhopping_core +!* Perform multiple independent BH runs from a single given starting point +!* Ensembles are unified at the end and returned via structuedump +!************************************************************************** + use crest_parameters + use crest_data + use crest_calculator + use strucrd + use cregen_interface,only:unionizeEnsembles + use optimize_module + use bh_module + implicit none + !> INPUT/OUTPUT + type(systemdata),intent(inout) :: env + type(coord),intent(inout) :: mol + type(coord),allocatable,intent(inout) :: structuredump(:) + type(calcdata),intent(in) :: calc +!========================================================================================! + !> LOCAL + integer :: i,j,k,l,io,ich,T,Tn,mciter + logical :: pr,wr + type(calcdata),allocatable :: calcp(:) + type(bh_class),allocatable :: bhp(:) + type(coord),allocatable :: mols(:) + real(wp) :: energy + integer :: nall + type(mollist),allocatable :: dumplist(:) - if (io == 0) then - write (stdout,*) - write (stdout,*) 'BH run completed successfully' - write (stdout,*) 'Successfull quenches written to ',trjf + call new_ompautoset(env,'auto',0,T,Tn) + !======================================================================================! + !> THIS IS THE PARALLEL IMPORTANT BIT + !======================================================================================! +!>--- allocate temporary spaces for parallel usage + allocate (mols(T),source=mol) + allocate (bhp(T)) + allocate (calcp(T),source=calc) + allocate (dumplist(T)) + if (allocated(env%bh_ref)) then + do K = 1,T + bhp(K) = env%bh_ref + call bhp(K)%init() + end do else - write (stdout,*) 'WARNING: BH run terminated ABNORMALLY' - env%iostatus_meta = status_failed + do K = 1,T + call bhp(K)%init(300.0_wp,200,20) + bhp(K)%stepsize(1) = 1.0_wp + end do end if -!========================================================================================! - call tim%stop(14) + do K = 1,T + bhp(K)%id = K-1 + end do - if (allocated(structuredump)) deallocate (structuredump) + !$omp parallel do default(shared) private(K, mciter) schedule(dynamic) + do K = 1,T + do mciter = 1,bhp(K)%maxiter + !$omp critical + if (bhp(K)%maxiter > 1) call printiter2(mciter) + !$omp end critical + call bhp(K)%newiter() + call mc(calcp(K),mols(K),bhp(K),verbosity=2) + + write (stdout,'(a)') 'New structures will be appended to memory ...' + call unionizeEnsembles(dumplist(K)%nall,dumplist(K)%structure, & + & bhp(K)%saved,bhp(K)%structures, & + & ethr=bhp(K)%ethr,rthr=bhp(K)%rthr) + write (stdout,'(a,i0,a,i0,a)') 'Currently ',dumplist(K)%nall, & + & ' structures saved (BH[',bhp(K)%id,'])!' + end do + end do + !$omp end parallel do + + write (stdout,*) + write (stdout,'(a)') 'Parallel BH runs done!' + write (stdout,'(a)') 'Collecting structures in one ensemble ...' + nall = 0 + do K = 1,T + call unionizeEnsembles(nall,structuredump, & + & dumplist(K)%nall,dumplist(K)%structure, & + & ethr=bhp(K)%ethr,rthr=bhp(K)%rthr) + end do + write (stdout,'(a,i0,a)') 'Total of ',nall,' structures remain.' +!=======================================================================================! +!> PARALLEL BIT END +!=======================================================================================! return -end subroutine crest_basinhopping +end subroutine parallel_basinhopping_core diff --git a/src/basinhopping/class.f90 b/src/basinhopping/class.f90 index c5ce60f4..58deff5e 100644 --- a/src/basinhopping/class.f90 +++ b/src/basinhopping/class.f90 @@ -33,6 +33,10 @@ module bh_class_module !************************************************************************ integer :: id = 0 !> Run/Thread ID integer,allocatable :: seed !> RNG seed, only used when allocated +!>--- settings + logical :: parallel = .false. !> runtype definition + integer :: quenchmode = 0 !> selection of how to quench structures + integer :: duplicatemode = 0 !> selection of how to prune duplicates !>--- counters integer :: iteration = 0 !> current iteration @@ -51,6 +55,7 @@ module bh_class_module integer :: maxsave = 100 !> maximum number of quenches saved real(wp),allocatable :: etarget !> target energy to be hit (useful in benchmarks) + !>--- results/properties real(wp) :: emin = 0.0_wp !> current ref energy of markov chain integer :: whichmin = 0 !> mapping to which structure emin refers diff --git a/src/basinhopping/mc.f90 b/src/basinhopping/mc.f90 index 4865b223..7ce36642 100644 --- a/src/basinhopping/mc.f90 +++ b/src/basinhopping/mc.f90 @@ -116,8 +116,10 @@ subroutine mc(calc,mol,bh,verbosity) if (iostatus == 0) then !> successfull optimization if (printlvl > 1) then + !$omp critical write (stdout,'(a,1x,a,es17.8,a,es17.8,a)') trim(tag),'Quench E=',etot, & & ' Eh, Markov E=',bh%emin,' Eh' + !$omp end critical end if accept = mcaccept(optmol,bh) @@ -377,6 +379,24 @@ subroutine mcduplicate(mol,bh,dupe,broken) !$omp end critical end subroutine mcduplicate + !========================================================================================! + + subroutine mcquench(calc,bh,tmpmol,optmol,iostat) + implicit none + !> Input + type(calcdata),intent(inout) :: calc !> potential settings + type(bh_class),intent(inout) :: bh !> BH settings + type(coord),intent(in) :: tmpmol !> molecular system + !> Output + type(coord),intent(out) :: optmol !> molecular system output + integer,intent(out) :: iostat + + iostat = 1 + + + end subroutine mcquench + + !=========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< real64 use crest_parameters !> Datatypes and constants use crest_data !> module for the main data storage (imports systemdata and timer) - use crest_restartlog - USE, INTRINSIC :: IEEE_EXCEPTIONS + use crest_restartlog + USE,INTRINSIC :: IEEE_EXCEPTIONS implicit none type(systemdata) :: env !> MAIN STORAGE OF SYSTEM DATA type(timer) :: tim !> timer object @@ -39,7 +39,7 @@ program CREST logical :: ex,ex1,ex2 intrinsic :: iargc,getarg - LOGICAL :: overflow, division_by_zero, invalid_operation + LOGICAL :: overflow,division_by_zero,invalid_operation call initsignal() !SIGTERM catcher @@ -113,8 +113,8 @@ program CREST end if if (env%newcregen) then block - use cregen_interface - call newcregen(env,0) + use cregen_interface + call newcregen(env,0) end block else call cregen2(env) @@ -129,7 +129,7 @@ program CREST call tim%stop(1) call propquit(tim) !>--- zsort routine - case(p_zsort) + case (p_zsort) call zsort write (*,*) write (*,*) 'The z-matrix of the input coord file has been sorted.' @@ -140,7 +140,7 @@ program CREST !>--- only ensemble comparison case (p_compare) - call compare_ensembles(env) + call compare_ensembles(env) call propquit(tim) ! !>--- protonation tool ! case (p_protonate) @@ -241,7 +241,7 @@ program CREST case (crest_imtd,crest_imtd2) !> MTD-GC algo call confscript2i(env,tim) - case (crest_mdopt, crest_mdopt2) + case (crest_mdopt,crest_mdopt2) call mdopt(env,tim) !> MDOPT case (crest_screen) @@ -290,21 +290,21 @@ program CREST call trialOPT(env) case (crest_ensemblesp) !> singlepoints along ensemble - call crest_ensemble_singlepoints(env,tim) + call crest_ensemble_singlepoints(env,tim) - case(crest_protonate) + case (crest_protonate) call protonate(env,tim) - - case(crest_deprotonate) + + case (crest_deprotonate) call deprotonate(env,tim) - case(crest_tautomerize) - call tautomerize(env,tim) + case (crest_tautomerize) + call tautomerize(env,tim) - case(crest_sorting) !> interface to standalone ensemble sorting + case (crest_sorting) !> interface to standalone ensemble sorting call crest_sort(env,tim) - - case(crest_bh) !> Standard basin-hopping + + case (crest_bh) !> Standard basin-hopping call crest_basinhopping(env,tim) case (crest_test) @@ -360,8 +360,8 @@ program CREST !=========================================================================================! !> shout down hosted subprocesses block - use ConfSolv_module - call cs_shutdown(io) + use ConfSolv_module + call cs_shutdown(io) end block !=========================================================================================! diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 32a1e170..b02b21c5 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -1272,6 +1272,9 @@ subroutine parse_bh_auto(env,bh,kv,rd) case ('temp','T') bh%temp = kv%value_f + case ('parallel') + bh%parallel = kv%value_b + case default rd = .false. return diff --git a/src/strucreader.f90 b/src/strucreader.f90 index 88174c4f..d347bd11 100644 --- a/src/strucreader.f90 +++ b/src/strucreader.f90 @@ -135,6 +135,7 @@ module strucrd public :: pdbdata public :: coord public :: ensemble + public :: mollist public :: coordline public :: get_atlist @@ -243,6 +244,13 @@ module strucrd procedure :: write => write_ensemble !write to file end type ensemble + +!==========================================================================================! + type :: mollist + integer :: nall = 0 + type(coord),allocatable :: structure(:) + end type mollist + !=========================================================================================! !=========================================================================================! contains !> MODULE PROCEDURES START HERE From 4e7a0f0009f1d5c54cc609b17329f60510ff35e2 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 19 Aug 2025 10:37:49 +0200 Subject: [PATCH 056/374] start work on standalone rmsd pot --- src/calculator/CMakeLists.txt | 1 + src/calculator/rmsdpot.f90 | 75 +++++++++++++++++++++++++++++++++++ 2 files changed, 76 insertions(+) create mode 100644 src/calculator/rmsdpot.f90 diff --git a/src/calculator/CMakeLists.txt b/src/calculator/CMakeLists.txt index 13e1cd2e..da7bf4a3 100644 --- a/src/calculator/CMakeLists.txt +++ b/src/calculator/CMakeLists.txt @@ -28,6 +28,7 @@ list(APPEND srcs "${dir}/oniom_hessian.F90" "${dir}/nonadiabatic.f90" "${dir}/tblite_api.F90" + "${dir}/rmsdpot.f90" "${dir}/api_helpers.F90" "${dir}/api_engrad.f90" "${dir}/gradreader.f90" diff --git a/src/calculator/rmsdpot.f90 b/src/calculator/rmsdpot.f90 new file mode 100644 index 00000000..e6996ef9 --- /dev/null +++ b/src/calculator/rmsdpot.f90 @@ -0,0 +1,75 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2025 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module rmsdpot + use strucrd + use iso_fortran_env,only:wp => real64 + + implicit none + private + + type :: rmsdbias + integer :: nbias = 0 + real(wp),allocatable :: alpha(:) + real(wp),allocatable :: kpush(:) + integer,allocatable :: mult(:) + type(coord),pointer :: ptr_structures(:) + end type rmsdbias + + public :: rmsdbias + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + subroutine rmsd_push_engrad(mol,rbias,energy,grad) +!************************************************************************* +!* Compute a repulsive energy and corresponding forces for +!* the similarity match between the currnt mol and a list of references +!************************************************************************* + implicit none + type(coord),intent(in) :: mol + type(rmsdbias) :: rbias + + real(wp),intent(inout) :: energy + real(wp),intent(inout) :: grad(3,mol%nat) + integer :: i,j,k,l + + real(wp) :: tmpe,ktot,rmssq + real(wp),allocatable :: tmpgrad(:,:) + + energy = 0.0_wp + grad = 0.0_wp + + do i=1,rbias%nbias + rmssq = 0.0_wp ** 2 + ktot = real(rbias%mult(i))*rbias%kpush(i)*real(mol%nat) + tmpe = ktot*exp(-rbias%alpha(i)*rmssq ) + + + enddo + + return + end subroutine rmsd_push_engrad + +!========================================================================================! +!========================================================================================! +end module rmsdpot From 0b9b1077b86e31391106d8ac203badf143f6aebf Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 28 Aug 2025 22:12:41 +0200 Subject: [PATCH 057/374] Update tblite submodule to 0.5.0 --- subprojects/tblite | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subprojects/tblite b/subprojects/tblite index 660d1678..6f6cd7d2 160000 --- a/subprojects/tblite +++ b/subprojects/tblite @@ -1 +1 @@ -Subproject commit 660d1678d6f36999d7ffda6e710d5ff00ff2f8ff +Subproject commit 6f6cd7d20d97b22ef00d420904343c7bb8e2afdf From f23ba0e9123c0fa883c0e0a4fa3b4f04cf8edcfc Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 29 Aug 2025 01:52:17 +0200 Subject: [PATCH 058/374] position-independent input file selection in cli --- src/confparse.f90 | 29 +++++++++------- src/parsing/parse_inputfile.F90 | 61 ++++++++++++++++++++++++++++++++- src/parsing/parse_maindata.f90 | 2 +- 3 files changed, 78 insertions(+), 14 deletions(-) diff --git a/src/confparse.f90 b/src/confparse.f90 index f06d639d..5e8910b3 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -330,18 +330,23 @@ subroutine parseflags(env,arg,nra) env%properties2 = p_none !> backup for env%properties env%iterativeV2 = .true. !> iterative crest V2 version env%preopt = .true. -!>--- check for input file - do i = 1,nra - argument = trim(arg(i)) - if (argument == '--input'.or.argument == '-i') then - call parseinputfile(env,trim(arg(i+1))) - exit - end if - if (i == 1.and.index(argument,'.toml') .ne. 0) then - call parseinputfile(env,trim(arg(1))) - exit - end if - end do +!>--- check for (TOML) input file +! do i = 1,nra +! argument = trim(arg(i)) +! if (argument == '--input'.or.argument == '-i') then +! call parseinputfile(env,trim(arg(i+1))) +! exit +! end if +! if (i == 1.and.index(argument,'.toml') .ne. 0) then +! call parseinputfile(env,trim(arg(1))) +! exit +! end if +! end do + call find_input_file(arg,nra,idum) + if(idum.ne.0)then + call parseinputfile(env,trim(arg(idum))) + endif + !>--- first arg loop do i = 1,nra argument = trim(arg(i)) diff --git a/src/parsing/parse_inputfile.F90 b/src/parsing/parse_inputfile.F90 index 4497c873..7f7bb201 100644 --- a/src/parsing/parse_inputfile.F90 +++ b/src/parsing/parse_inputfile.F90 @@ -27,9 +27,13 @@ module parse_inputfile public :: parse_test public :: parse_input + public :: find_input_file external creststop + integer,parameter :: nf = 2 + character(len=*),parameter :: ftypes(nf) = [& + & '.toml','.TOML'] !========================================================================================! !========================================================================================! contains !> MODULE PROCEDURES START HERE @@ -76,7 +80,7 @@ subroutine parse_input(fname,dict) case default write (stdout,'(a,a)') 'Unknown file format of input file ',trim(fname) call creststop(status_input) - case ('.toml') + case ('.toml','.TOML') #ifdef WITH_TOMLF !>--- parse .toml file via the toml-f library (the DEFAULT setting) call parse_tomlf(fname,dict) @@ -88,5 +92,60 @@ subroutine parse_input(fname,dict) end subroutine parse_input +!========================================================================================! + + subroutine find_input_file(args,nra,pos) + !******************************************* + !* A routine to look up an input file from + !* the list of command line arguments + !******************************************* + implicit none + integer,intent(in) :: nra + character(len=*) :: args(nra) + integer,intent(out) :: pos + + character(len=:),allocatable :: argument + logical,allocatable :: isinputfile(:) + logical,allocatable :: inputprio(:) + integer :: i,j,k,l + logical :: ex + + pos = 0 + allocate (isinputfile(nra),source=.false.) + allocate (inputprio(nra),source=.false.) + + do i = 1,nra + argument = args(i) + inquire (file=argument,exist=ex) + if (ex) then + do j = 1,nf + if (index(argument,ftypes(j)) .ne. 0) then + isinputfile(i) = .true. + if (i > 1) then + if (args(i-1) == '--input'.or.args(i-1) == '-i') then + inputprio(i) = .true. + end if + end if + end if + end do + end if + end do + + !> if there are multiple inputs given, we select the last one, + !> except if it was provided with --input/-i + !> (same logic applies for multiple --input/-i) + if (any(inputprio(:))) then + do i = 1,nra + if (inputprio(i)) pos = i + end do + elseif (any(isinputfile(:))) then + do i = 1,nra + if (isinputfile(i)) pos = i + end do + else + pos = 0 + end if + + end subroutine find_input_file !========================================================================================! end module parse_inputfile diff --git a/src/parsing/parse_maindata.f90 b/src/parsing/parse_maindata.f90 index 33fa9734..4574b160 100644 --- a/src/parsing/parse_maindata.f90 +++ b/src/parsing/parse_maindata.f90 @@ -228,7 +228,7 @@ subroutine parse_main_c(env,key,val,rd) case ('ensemble_input','ensemble','input_ensemble') env%ensemblename = val env%inputcoords = val - case ('input','structure') + case ('input','structure','coord','coords') env%inputcoords = val call mol%open(val) call env%ref%load(mol) From e82c1cb64c081a633a05c463fa090a7539b45955 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 5 Sep 2025 12:16:49 +0200 Subject: [PATCH 059/374] modify constraint input flag --- src/confparse.f90 | 15 ++------------- 1 file changed, 2 insertions(+), 13 deletions(-) diff --git a/src/confparse.f90 b/src/confparse.f90 index 5e8910b3..64a9c6f1 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -331,17 +331,6 @@ subroutine parseflags(env,arg,nra) env%iterativeV2 = .true. !> iterative crest V2 version env%preopt = .true. !>--- check for (TOML) input file -! do i = 1,nra -! argument = trim(arg(i)) -! if (argument == '--input'.or.argument == '-i') then -! call parseinputfile(env,trim(arg(i+1))) -! exit -! end if -! if (i == 1.and.index(argument,'.toml') .ne. 0) then -! call parseinputfile(env,trim(arg(1))) -! exit -! end if -! end do call find_input_file(arg,nra,idum) if(idum.ne.0)then call parseinputfile(env,trim(arg(idum))) @@ -1367,11 +1356,11 @@ subroutine parseflags(env,arg,nra) env%cts%cbonds_md = .true. env%cts%cbonds_global = .false. end if - case ('-cfile','-cinp') !> specify the constrain file + case ('-cfile','-cinp','-C','-c') !> specify the constrain file ctmp = trim(arg(i+1)) if (ctmp(1:1) .ne. '-') then env%constraints = trim(ctmp) - write (*,'(2x,a,1x,a)') '--cinp :',trim(ctmp) + write (*,'(2x,a,1x,a)') argument//' :',trim(ctmp) end if case ('-fc','-forceconstant') ctmp = trim(arg(i+1)) From 3f3798c3e6a51a77cc44b0d0dfa11f37b85d8522 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 5 Sep 2025 12:52:19 +0200 Subject: [PATCH 060/374] let the internal writecoord routine print the energy in xyz format --- src/strucreader.f90 | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/src/strucreader.f90 b/src/strucreader.f90 index 24c7e583..01acc3b8 100644 --- a/src/strucreader.f90 +++ b/src/strucreader.f90 @@ -1506,10 +1506,10 @@ subroutine coord_get_z(self,z) end subroutine coord_get_z !==================================================================! - - subroutine coord_cn_to_bond(self,cn,bond,cn_type,cn_thr) - implicit none - class(coord) :: self + + subroutine coord_cn_to_bond(self,cn,bond,cn_type,cn_thr) + implicit none + class(coord) :: self real(wp),intent(out),allocatable :: cn(:) real(wp),intent(out),allocatable,optional :: bond(:,:) real(wp),intent(in),optional :: cn_thr @@ -1519,8 +1519,7 @@ subroutine coord_cn_to_bond(self,cn,bond,cn_type,cn_thr) allocate (cn(self%nat),source=0.0_wp) call calculate_CN(self%nat,self%at,self%xyz,cn, & & cntype=cn_type,cnthr=cn_thr,bond=bond) - end subroutine coord_cn_to_bond - + end subroutine coord_cn_to_bond !=========================================================================================! !=========================================================================================! @@ -1935,12 +1934,14 @@ subroutine writecoord(self,fname) implicit none class(coord) :: self character(len=*),intent(in) :: fname + character(len=80) :: comment if (.not.allocated(self%xyz)) then write (*,*) 'Cannot write ',trim(fname),'. not allocated' end if if (index(fname,'.xyz') .ne. 0) then + write (comment,'(a,G0.12)') ' energy= ',self%energy self%xyz = self%xyz*bohr !to Angström - call wrxyz(fname,self%nat,self%at,self%xyz) + call wrxyz(fname,self%nat,self%at,self%xyz,comment) self%xyz = self%xyz/bohr !back else call wrc0(fname,self%nat,self%at,self%xyz) @@ -2230,14 +2231,14 @@ function grepenergy(line) integer :: i,io,k atmp = trim(line) energy = 0.0_wp - if(index(atmp,'energy=').ne.0)then - k=index(atmp,'energy=') - atmp=atmp(k+7:) + if (index(atmp,'energy=') .ne. 0) then + k = index(atmp,'energy=') + atmp = atmp(k+7:) read (atmp,*,iostat=io) energy - if(io.ne.0) energy=0.0_wp - else if(index(atmp,'energy:').ne.0)then - k=index(atmp,'energy:') - atmp=atmp(k+7:) + if (io .ne. 0) energy = 0.0_wp + else if (index(atmp,'energy:') .ne. 0) then + k = index(atmp,'energy:') + atmp = atmp(k+7:) read (atmp,*,iostat=io) energy if (io .ne. 0) energy = 0.0_wp else From 77ba3d314d5c6aa2cf68cd332b9bdcd83f7a5ed7 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 18 Sep 2025 12:34:20 +0200 Subject: [PATCH 061/374] grad/nograd option for cli sp routine --- src/classes.f90 | 1 + src/confparse.f90 | 5 +++++ src/legacy_wrappers.f90 | 16 +++++++++++----- 3 files changed, 17 insertions(+), 5 deletions(-) diff --git a/src/classes.f90 b/src/classes.f90 index 53050cb2..f24dbd9d 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -553,6 +553,7 @@ module crest_data logical :: fullcre = .false. !> calculate exact rotamer degeneracies logical :: gbsa !> use gbsa logical :: gcmultiopt !> 2 level optimization for GC in V2 + logical :: gradsp = .true. !> turn on/off gradient calculation in singlepoint logical :: heavyrmsd = .false. !> use only heavy atoms for RMSD in CREGEN? logical :: inplaceMode = .true. !> in-place mode: optimization dirs are created "on-the-fly" logical :: iterativeV2 !> iterative version of V2 (= V3) diff --git a/src/confparse.f90 b/src/confparse.f90 index 64a9c6f1..203eec7e 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -1255,6 +1255,11 @@ subroutine parseflags(env,arg,nra) close (ich) write (*,'(2x,a,1x,a)') trim(arg(i)),trim(arg(i+1)) + case ('-grad') + env%gradsp = .true. + case ('-nograd') + env%gradsp = .false. + case ('-len','-mdlen','-mdtime') !> set md length in ps atmp = arg(i+1) call to_lower(atmp) diff --git a/src/legacy_wrappers.f90 b/src/legacy_wrappers.f90 index e32cd2cd..cad970f3 100644 --- a/src/legacy_wrappers.f90 +++ b/src/legacy_wrappers.f90 @@ -52,11 +52,17 @@ subroutine env2calc(env,calc,molin) cal%rdwbo = .false. cal%rddip = .false. !> except for SP runtype (from command line!) - if (env%crestver == crest_sp.and. & - & cal%id .ne. jobtype%turbomole) then - cal%rdwbo = .true. - cal%rddip = .true. - cal%rdqat = .true. + if (env%crestver == crest_sp) then + cal%rdgrad = env%gradsp + if (cal%id .ne. jobtype%turbomole) then + cal%rdwbo = .true. + cal%rddip = .true. + cal%rdqat = .true. + else + if (.not.env%gradsp) then + cal%other = '' + end if + end if end if !> implicit solvation From a7b66dcb0b3f886906c96077cda242759d2e038f Mon Sep 17 00:00:00 2001 From: Phelan Shao Date: Thu, 9 Oct 2025 11:48:10 +0800 Subject: [PATCH 062/374] Guard CREGEN against empty conformer groups --- src/cregen.f90 | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/cregen.f90 b/src/cregen.f90 index 31b86ca9..23d60221 100644 --- a/src/cregen.f90 +++ b/src/cregen.f90 @@ -87,6 +87,7 @@ subroutine newcregen(env,quickset,infile) !>--- sorting arguments integer,allocatable :: gref(:),group(:) integer :: ng + integer :: i integer,allocatable :: degen(:,:) !>--- float data @@ -241,6 +242,19 @@ subroutine newcregen(env,quickset,infile) ng = group(0) allocate (degen(3,ng)) call cregen_groupinfo(nall,ng,group,degen) + else + ng = nall + if (ng > 0) then + allocate (degen(3,ng)) + do i = 1, ng + degen(1,i) = 1 + degen(2,i) = i + degen(3,i) = i + end do + else + allocate (degen(3,1)) + degen = 0 + end if end if if (sortRMSD2) then allocate (group(0:nall)) @@ -2194,6 +2208,7 @@ subroutine cregen_conffile(env,cname,nat,nall,at,xyz,comments,ng,degen) open (newunit=ich,file=trim(cname)) do i = 1,ng k = degen(2,i) + if (k <= 0 .or. k > nall) cycle if (i .eq. 1.or.env%printscoords) then !write a scoord.* for each conformer? scoord.1 is always written call getname1(i,newcomment) c0(:,:) = xyz(:,:,k)/bohr From 31507b8f88b1d288cc366d5b0d0688899b925979 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 22 Oct 2025 14:44:12 +0200 Subject: [PATCH 063/374] activate preoptimization when selecting sampling modes via the toml input --- src/parsing/parse_maindata.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parsing/parse_maindata.f90 b/src/parsing/parse_maindata.f90 index 4574b160..a192a973 100644 --- a/src/parsing/parse_maindata.f90 +++ b/src/parsing/parse_maindata.f90 @@ -168,7 +168,7 @@ subroutine parse_main_c(env,key,val,rd) env%preopt = .false. env%crestver = crest_scanning case ('search_1') - env%preopt = .false. + env%preopt = .true. env%crestver = crest_s1 env%runver = crest_s1 case ('mecp','mecp_search') @@ -176,7 +176,7 @@ subroutine parse_main_c(env,key,val,rd) env%crestver = crest_mecp env%runver = crest_mecp case ('imtd-gc') - env%preopt = .false. + env%preopt = .true. env%crestver = crest_imtd env%runver = 1 case ('nci-mtd','nci') @@ -203,7 +203,7 @@ subroutine parse_main_c(env,key,val,rd) env%crestver = crest_numhessian env%runver = crest_numhessian case ('rigidconf') - env%preopt = .false. + env%preopt = .true. env%crestver = crest_rigcon env%runver = crest_rigcon From ced672c876a0dd5ba3f1469593825f789f33be13 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 4 Nov 2025 20:27:44 +0100 Subject: [PATCH 064/374] Update versioning --- CMakeLists.txt | 2 +- meson.build | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index f47b56ac..9566f7e2 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -27,7 +27,7 @@ endif() project( crest LANGUAGES "C" "Fortran" - VERSION 3.1.0 + VERSION 3.0.3 DESCRIPTION "A tool for the exploration of low-energy chemical space" ) diff --git a/meson.build b/meson.build index 77be2681..bb04ea32 100644 --- a/meson.build +++ b/meson.build @@ -17,7 +17,7 @@ project( 'crest', 'fortran', 'c', - version: '3.1.0', + version: '3.0.3', license: 'LGPL-3.0-or-later', meson_version: '>=0.63', default_options: [ From 7b5f5918b6dac5d5e1bae3d1a17dff10cde2eecd Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 4 Nov 2025 21:16:51 +0100 Subject: [PATCH 065/374] Add routine and printout for maximum RAM usage --- src/CMakeLists.txt | 1 + src/eval_timer.f90 | 5 ++++- src/iomod.F90 | 7 +++++++ src/mempeak.c | 48 ++++++++++++++++++++++++++++++++++++++++++++++ src/meson.build | 1 + 5 files changed, 61 insertions(+), 1 deletion(-) create mode 100644 src/mempeak.c diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 5d6a20d6..2b5d882a 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -58,6 +58,7 @@ list(APPEND srcs "${dir}/marqfit.f90" "${dir}/minitools.f90" "${dir}/miscdata.f90" + "${dir}/mempeak.c" "${dir}/ncigeo.f90" "${dir}/ompmklset.F90" "${dir}/printouts.f90" diff --git a/src/eval_timer.f90 b/src/eval_timer.f90 index 4d4b570e..80d0f883 100644 --- a/src/eval_timer.f90 +++ b/src/eval_timer.f90 @@ -25,15 +25,18 @@ subroutine eval_timer(tim) use crest_data use crest_calculator,only: engrad_total use crest_restartlog + use iomod, only: get_peak_rss_kb implicit none type(timer) :: tim - real(wp) :: time_total,time_avg + real(wp) :: time_total,time_avg,mem character(len=40) :: atmp write (stdout,*) call smallhead('Wall Time Summary') call tim%write(stdout,'CREST runtime',verbose=.true.) time_total = tim%get() call tim%clear + mem = real(get_peak_rss_kb(),wp) + write(stdout,'(" * Peak RSS: ",f8.2, " MiB")') mem/1024.0_wp if(engrad_total > 0)then write(atmp,'(f30.3)') time_total/real(engrad_total,wp) write(stdout,'(" * Total number of energy+grad calls: ",i0)') & !,a,1x,a,a)') & diff --git a/src/iomod.F90 b/src/iomod.F90 index 6d8a68b2..1a03bb4d 100644 --- a/src/iomod.F90 +++ b/src/iomod.F90 @@ -62,6 +62,13 @@ integer(c_int) function c_isatty(fd) bind(c,name="isatty") end function c_isatty end interface + interface + function get_peak_rss_kb() bind(C, name="get_peak_rss_kb") result(kb) + import :: c_long_long + integer(c_long_long) :: kb + end function + end interface + interface wrshort module procedure wrshort_real module procedure wrshort_int diff --git a/src/mempeak.c b/src/mempeak.c new file mode 100644 index 00000000..b3d98555 --- /dev/null +++ b/src/mempeak.c @@ -0,0 +1,48 @@ +/* +! This file is part of crest. +! +! Copyright (C) 2025 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . + +*/ +#ifdef _WIN32 +#define WIN32_LEAN_AND_MEAN +#include +#include +__declspec(dllexport) long long get_peak_rss_kb(void) { + PROCESS_MEMORY_COUNTERS pmc; + if (GetProcessMemoryInfo(GetCurrentProcess(), &pmc, sizeof(pmc))) { + // bytes -> kilobytes + return (long long)(pmc.PeakWorkingSetSize / 1024); + } + return -1; +} +#else +#include +#include +long long get_peak_rss_kb(void) { + struct rusage ru; + if (getrusage(RUSAGE_SELF, &ru) == 0) { +// On Linux: ru_maxrss is in kilobytes +// On macOS/BSD: ru_maxrss is in bytes — convert to KB +#ifdef __APPLE__ + return (long long)(ru.ru_maxrss / 1024); +#else + return (long long)ru.ru_maxrss; +#endif + } + return -1; +} +#endif diff --git a/src/meson.build b/src/meson.build index 39e69f30..c55eb919 100644 --- a/src/meson.build +++ b/src/meson.build @@ -54,6 +54,7 @@ srcs += files( 'marqfit.f90', 'minitools.f90', 'miscdata.f90', + 'mempeak.c', 'ncigeo.f90', 'ompmklset.F90', 'printouts.f90', From 36799f1873b24a99c7b986a420bacb5322f80e51 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 4 Nov 2025 21:48:22 +0100 Subject: [PATCH 066/374] Add printout to --splitfile, tidy up minitools.f90 --- src/minitools.f90 | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/src/minitools.f90 b/src/minitools.f90 index 7a46d786..81c37d2f 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -77,6 +77,12 @@ subroutine splitfile(fname,up,low) end do call chdir(thispath) + write (stdout,*) + write (stdout,'(a,i0,a,i0,a)') '> Created subdirectories SPLIT/STRUC{',low,'-',nc,'}/' + write (stdout,'(a)') '> All directories contain a "struc.xyz" with molecular coordinates' + write (stdout,'(a)') '> The order of SPLIT/STRUC*/ is the same as in '//trim(fname) + write (stdout,*) + write (stdout,'(a)') 'exit.' return end subroutine splitfile @@ -102,7 +108,7 @@ subroutine printaniso(fname,bmin,bmax,bshift) real(wp),allocatable :: rot(:,:) real(wp) :: rotaniso !function real(wp),allocatable :: anis(:) - real(wp) :: evec(3,3),evecavg(3,3) + real(wp) :: evec(3,3),evecavg(3,3) real(wp) :: bthrerf real(wp) :: bmin,bmax,bshift @@ -122,9 +128,9 @@ subroutine printaniso(fname,bmin,bmax,bshift) do i = 1,nall c1(1:3,:) = structures(i)%xyz(1:3,:)*autoaa call axis(nat,at,c1,rot(1:3,i),dum,evec) - evecavg(:,:) = evecavg(:,:) + evec(:,:) - enddo - evecavg(:,:) = evecavg(:,:) / real(nall) + evecavg(:,:) = evecavg(:,:)+evec(:,:) + end do + evecavg(:,:) = evecavg(:,:)/real(nall) do i = 1,nall c1(1:3,:) = structures(i)%xyz(1:3,:)*autoaa @@ -132,12 +138,7 @@ subroutine printaniso(fname,bmin,bmax,bshift) anis(i) = rotaniso(i,nall,rot) thr = bthrerf(bmin,anis(i),bmax,bshift) write (*,'(3f10.2,2x,f8.4,2x,f8.4)') rot(1:3,i),anis(i),thr - !write (*,'(3f20.10)') evec(:,1) - !write (*,'(3f20.10)') abs(dot_product(evec(:,1),evecavg(:,1))),abs(dot_product(evec(:,2),evecavg(:,2))),abs(dot_product(evec(:,3),evecavg(:,3))) - !write (*,'(3f20.10)') evec(:,2) - !write (*,'(3f20.10)') evec(:,3) end do - deallocate (anis,rot,at,c1) @@ -167,7 +168,7 @@ subroutine rotalign_tool(fname) real(wp),allocatable :: rot(:,:) real(wp) :: rotaniso !function real(wp),allocatable :: anis(:) - real(wp) :: evec(3,3),evecavg(3,3) + real(wp) :: evec(3,3),evecavg(3,3) real(wp) :: bthrerf real(wp) :: bmin,bmax,bshift @@ -175,12 +176,11 @@ subroutine rotalign_tool(fname) real(wp) :: dum integer :: i - real(wp), parameter :: Ry90(3,3) = reshape([ & - & 0.0_wp, 0.0_wp, -1.0_wp, & - & 0.0_wp, 1.0_wp, 0.0_wp, & - & 1.0_wp, 0.0_wp, 0.0_wp & - & ], [3,3]) - + real(wp),parameter :: Ry90(3,3) = reshape([ & + & 0.0_wp,0.0_wp,-1.0_wp, & + & 0.0_wp,1.0_wp,0.0_wp, & + & 1.0_wp,0.0_wp,0.0_wp & + & ], [3,3]) call rdensemble(fname,nall,structures) nat = structures(1)%nat @@ -194,10 +194,10 @@ subroutine rotalign_tool(fname) c1(1:3,:) = structures(i)%xyz(1:3,:)*autoaa call axis(nat,at,c1,rot(1:3,i)) c2 = c1 - structures(i)%xyz = c2*aatoau + structures(i)%xyz = c2*aatoau write (*,'(3f10.2)') rot(1:3,i) end do - + deallocate (rot,at,c2,c1) call wrensemble('rotalign.xyz',nall,structures) From 9c7d0748e4121a47bc1fd310b1a4b98265c74e99 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 4 Nov 2025 23:18:27 +0100 Subject: [PATCH 067/374] valgrind clean up --- src/classes.f90 | 28 ++++++++++++++-------------- src/confparse.f90 | 8 +++++--- src/crest_main.f90 | 3 +-- src/parsing/parse_calcdata.f90 | 2 ++ 4 files changed, 22 insertions(+), 19 deletions(-) diff --git a/src/classes.f90 b/src/classes.f90 index 3d5eac48..78e8e62b 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -383,19 +383,19 @@ module crest_data logical :: omp_allow_nested = .true. !> allow nested OpenMP threadding !>--- various names and flags - character(len=128) :: ensemblename !> ensemble input name for SCREEN,MDOPT and CREGEN - character(len=128) :: ensemblename2 !> another ensemble input name - character(len=128) :: fixfile - character(len=512) :: constraints !> name of the constraint file - character(len=20) :: solvent !> the solvent + character(len=128) :: ensemblename = '' !> ensemble input name for SCREEN,MDOPT and CREGEN + character(len=128) :: ensemblename2 = '' !> another ensemble input name + character(len=128) :: fixfile = '' + character(len=512) :: constraints = '' !> name of the constraint file + character(len=20) :: solvent = '' !> the solvent character(len=:),allocatable :: solv !> the entrie gbsa flag including solvent - character(len=20) :: gfnver !> GFN version - character(len=20) :: gfnver2 !> GFN version (multilevel) - character(len=20) :: lmover !> GFN version for LMO computation in xtb_lmo subroutine - character(len=512) :: ProgName !> name of the xtb executable (+ path) - character(len=512) :: ProgIFF !> name of xtbiff for QCG-mode - character(len=512) :: homedir !> original directory from which calculation was started - character(len=512) :: scratchdir !> path to the scratch directory + character(len=20) :: gfnver = '' !> GFN version + character(len=20) :: gfnver2 = '' !> GFN version (multilevel) + character(len=20) :: lmover = '' !> GFN version for LMO computation in xtb_lmo subroutine + character(len=512) :: ProgName = '' !> name of the xtb executable (+ path) + character(len=512) :: ProgIFF = '' !> name of xtbiff for QCG-mode + character(len=512) :: homedir = '' !> original directory from which calculation was started + character(len=512) :: scratchdir = '' !> path to the scratch directory character(len=:),allocatable :: cmd character(len=:),allocatable :: inputcoords character(len=:),allocatable :: wbofile @@ -467,8 +467,8 @@ module crest_data character(len=:), allocatable :: directed_file !name of the directed list character(len=64), allocatable :: directed_list(:,:) !How many solvents at which atom to add integer, allocatable :: directed_number(:) !Numbers of solvents added per defined atom - character(len=20) :: ensemble_opt !> Method for ensemble optimization in qcg mode - character(len=20) :: freqver !> Method for frequency computation in qcg mode + character(len=20) :: ensemble_opt = '' !> Method for ensemble optimization in qcg mode + character(len=20) :: freqver = '' !> Method for frequency computation in qcg mode real(wp) :: freq_scal !> Frequency scaling factor character(len=:),allocatable :: solu_file,solv_file !> solute and solvent input file character(len=5) :: docking_qcg_flag = '--qcg' diff --git a/src/confparse.f90 b/src/confparse.f90 index f2a225cb..3a694fe3 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -850,9 +850,11 @@ subroutine parseflags(env,arg,nra) !========================================================================================! !> after this point there should always be a "coord" file present !========================================================================================! - allocate (env%includeRMSD(env%nat)) - env%includeRMSD = 1 - + if(.not.allocated(env%includeRMSD))then + allocate (env%includeRMSD(env%nat)) + env%includeRMSD = 1 + endif + !========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>! !> parse the input flags diff --git a/src/crest_main.f90 b/src/crest_main.f90 index d51d82c9..7d8a2ded 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -50,8 +50,7 @@ program CREST !=========================================================================================! !> set defaults and pars flags args = iargc() - l = len_trim(cmd) - allocate (arg(args),source=repeat(' ',l)) + allocate (arg(args),source=repeat(' ',1024)) do i = 1,args call getarg(i,arg(i)) end do diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index b02b21c5..937bda49 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -1033,6 +1033,7 @@ subroutine parse_md_auto(env,mddat,kv,rd) mddat%active_potentials = kv%value_ia case ('includermsd','atlist+') + nat=env%ref%nat call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) if (.not.allocated(env%includeRMSD)) allocate (env%includeRMSD(nat),source=1) do j = 1,nat @@ -1040,6 +1041,7 @@ subroutine parse_md_auto(env,mddat,kv,rd) end do case ('excludermsd','atlist-') + nat=env%ref%nat call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) if (.not.allocated(env%includeRMSD)) allocate (env%includeRMSD(nat),source=1) do j = 1,nat From 72fb69ece7190aca2da0401c72e10d8d9793498a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 5 Nov 2025 02:10:40 +0100 Subject: [PATCH 068/374] fix include/exludermsd logic for standalone metadynamics runtype --- src/algos/parallel.f90 | 5 +- src/choose_settings.f90 | 152 +++++++++++++++------------ src/dynamics/dynamics_module.f90 | 72 ++++++------- src/dynamics/metadynamics_module.f90 | 37 ++++--- src/parsing/parse_calcdata.f90 | 70 +++++++----- 5 files changed, 191 insertions(+), 145 deletions(-) diff --git a/src/algos/parallel.f90 b/src/algos/parallel.f90 index 4b26db75..e245ccf6 100644 --- a/src/algos/parallel.f90 +++ b/src/algos/parallel.f90 @@ -1006,7 +1006,7 @@ subroutine parallel_md_block_printout(MD,vz) if (MD%shk%shake_mode == 2) then write (stdout,'(2x,"| SHAKE algorithm :",a5," (all bonds) |")') to_str(MD%shake) else - write (stdout,'(2x,"| SHAKE algorithm :",a5," (H only) |")') to_str(MD%shake) + write (stdout,'(2x,"| SHAKE algorithm :",a5," (H only) |")') to_str(MD%shake) end if end if if (allocated(MD%active_potentials)) then @@ -1024,6 +1024,9 @@ subroutine parallel_md_block_printout(MD,vz) else write (stdout,'(2x,"| Vbias exponent (α) :",f8.4," |")') MD%mtd(1)%alpha end if + if (allocated(MD%mtd(1)%atinclude))then + write (stdout,'(2x,"| # active atoms :",i9," atoms |")') count(MD%mtd(1)%atinclude,1) + endif end if !$omp end critical diff --git a/src/choose_settings.f90 b/src/choose_settings.f90 index 901d5d7d..13c38b29 100644 --- a/src/choose_settings.f90 +++ b/src/choose_settings.f90 @@ -30,17 +30,17 @@ subroutine md_length_setup(env) use crest_parameters use crest_data use strucrd - use zdata, only:readwbo + use zdata,only:readwbo implicit none !> IN/OUTPUT type(systemdata) :: env !> MAIN STORAGE OS SYSTEM DATA !> LOCAL real(wp) :: total,minimum,lenthr real(wp) :: flex,av1,rfac,nciflex - type(coord) :: mol + type(coord) :: mol logical :: ex -!> get reference geometry - call env%ref%to( mol ) +!> get reference geometry + call env%ref%to(mol) !> at least 5ps per MTD minimum = 5.0d0 @@ -50,19 +50,19 @@ subroutine md_length_setup(env) call smallhead('Generating MTD length from a flexibility measure') if ((env%crestver .ne. crest_solv).and..not.env%NCI) then - write(stdout,'(1x,a)',advance='no') 'Calculating GFN0-xTB WBOs ...' + write (stdout,'(1x,a)',advance='no') 'Calculating GFN0-xTB WBOs ...' !>-- xtb singlepoint to get WBOs (always GFN0) call xtbsp(env,0) write (stdout,'(1x,a)') 'done.' !>-- save those WBOs to the reference - inquire(file='wbo',exist = ex) - if(ex)then - if(.not.allocated(env%ref%wbo)) allocate(env%ref%wbo( mol%nat, mol%nat), source=0.0_wp) - call readwbo('wbo',mol%nat, env%ref%wbo) - endif + inquire (file='wbo',exist=ex) + if (ex) then + if (.not.allocated(env%ref%wbo)) allocate (env%ref%wbo(mol%nat,mol%nat),source=0.0_wp) + call readwbo('wbo',mol%nat,env%ref%wbo) + end if !>-- covalent flexibility measure based on WBO and structure only - call flexi( mol, env%rednat, env%includeRMSD, flex) + call flexi(mol,env%rednat,env%includeRMSD,flex) !>-- NCI flexi based on E(HB)/Nat and E(disp)/Nat call nciflexi(env,nciflex) write (stdout,'(1x,'' covalent flexibility measure :'',f8.3)') flex @@ -118,9 +118,9 @@ subroutine md_length_setup(env) !>-- ONLY use generated MD length if not already set by the user if (env%mdtime .le. 0.0d0) then - if(env%mddat%length_ps > 0.0_wp)then + if (env%mddat%length_ps > 0.0_wp) then total = env%mddat%length_ps - write(stdout,'(1x,"t(MTD) / ps set via calculator :", f8.1)') total + write (stdout,'(1x,"t(MTD) / ps set via calculator :", f8.1)') total else if (total .gt. lenthr) then total = lenthr call mtdwarning(lenthr*rfac) @@ -135,9 +135,9 @@ subroutine md_length_setup(env) & env%mdtime*float(env%nmetadyn),env%nmetadyn !> A MTD Vbias snapshot is taken every 1 ps - if(allocated(env%metadlist))then + if (allocated(env%metadlist)) then env%metadlist(:) = ceiling(env%mdtime) - endif + end if return end subroutine md_length_setup @@ -149,7 +149,7 @@ subroutine defaultGF(env) !* Setmetadynamics default Guiding Force Parameter !* There are different combinations depending on the runtype !************************************************************ - use crest_parameters + use crest_parameters use crest_data use filemod implicit none @@ -200,7 +200,7 @@ subroutine defaultGF(env) !+++++++++++++++++++++++++++++++++++++++++++++++++++++++! select case (env%runver) !---------- "-quick","-squick" - case (2,5) + case (2,5) na = 3 nk = 2 nmtdyn = na*nk @@ -209,7 +209,7 @@ subroutine defaultGF(env) alpinc = 2.0 ! increment kinc = 2.0 ! increment !---------- "-mquick" - case (6) + case (6) na = 3 nk = 2 nmtdyn = na*nk @@ -218,7 +218,7 @@ subroutine defaultGF(env) alpinc = 2.0 ! increment kinc = 2.0 ! increment !---------- "-qcg" - case (3) + case (3) na = 4 nk = 3 nmtdyn = na*nk @@ -227,7 +227,7 @@ subroutine defaultGF(env) alpinc = (3./2.) ! increment kinc = (3./2.) ! increment !---------- "-nci" - case (4) + case (4) na = 3 nk = 2 nmtdyn = na*nk @@ -236,7 +236,7 @@ subroutine defaultGF(env) alpinc = 2.0 ! increment kinc = 2.0 ! increment !---------- "-singlerun" - case (45) + case (45) na = 1 nk = 1 nmtdyn = na*nk @@ -254,7 +254,7 @@ subroutine defaultGF(env) alpinc = 2.0 ! increment kinc = 2.0 ! increment !---------- "-compress" - case (77) + case (77) na = 3 nk = 3 nmtdyn = na*nk @@ -263,7 +263,7 @@ subroutine defaultGF(env) alpinc = 1.61803 ! increment kinc = 2.0 ! increment !--------- "search_1" - case (crest_s1,crest_mecp) + case (crest_s1,crest_mecp) na = 3 nk = 3 nmtdyn = (na*nk) @@ -280,7 +280,7 @@ subroutine defaultGF(env) alpinc = (5./3.) ! increment kinc = 1.5d0 ! increment !---------- "-entropy" - case (111) + case (111) na = 6 nk = 4 nmtdyn = (na*nk) @@ -395,13 +395,13 @@ subroutine adjustnormmd(env) !>--- first the number of normMDs on low conformers if (env%nrotammds .le. 0) then !> if no user input was set !> multiple short MDs, which has a better parallel efficiency - !> default is 4 - env%nrotammds = max(1,nint(float(env%nmetadyn)/4.0d0)) + !> default is 4 + env%nrotammds = max(1,nint(float(env%nmetadyn)/4.0d0)) end if !>--- then the temperature range if (env%temps .le. 0) then - !> at how many different temperatures? + !> at how many different temperatures? !> starting at 400k and increasing 100K for each (200 K for -entropy mode) env%temps = 2 if (env%entropic) then @@ -414,7 +414,7 @@ subroutine adjustnormmd(env) !==============================================! !>--- settings for static MTDS in entropy mode !==============================================! - if (env%entropymd) then + if (env%entropymd) then env%emtd%iter = 20 !> max number of iterations env%emtd%nbias = min(150,nint(env%tmtd/4)) !> max number of bias structures env%emtd%nbiasgrow = min(1.4d0,1.2d0+env%tmtd*1.d-3) !> increase of nBias in each cycle @@ -476,55 +476,71 @@ subroutine env_to_mddat(env) implicit none type(systemdata) :: env real(wp) :: dum + integer :: i,j,nat !!>--- dont override user-defined settings ! if(env%mddat%requested) return !> we will check if any default settings were already set individually, instead !> the if-statements in the following take care of that !>--- necessary transfer global settings into mddat object - if(env%mddat%length_ps <= 0.0_wp)then - !> total runtime in ps - env%mddat%length_ps = env%mdtime - else - env%mdtime = env%mddat%length_ps - endif - if(env%mddat%tstep <= 0.0_wp)then - !> time step in fs - env%mddat%tstep = env%mdstep - endif - !> simulation steps (would be recovered automatically later, but just to make sure) - env%mddat%length_steps = nint(env%mddat%length_ps*1000.0_wp / env%mddat%tstep) - if(env%mddat%tsoll <= 0.0_wp)then - !> target temperature - env%mddat%tsoll = env%mdtemp - endif - - if( env%mddat%dumpstep <= 0.0_wp ) then - !> dump frequency in fs - env%mddat%dumpstep = float(env%mddumpxyz) - endif - if(env%mddat%sdump <= 0)then - !> trajectory structure dump every x steps - dum = max(1.0_wp, (env%mddat%dumpstep / env%mddat%tstep)) - env%mddat%sdump = nint(dum) - endif - - !> The SHAKE setup (special condition referring to the default) - env%mddat%shake = env%mddat%shake .and.(env%shake > 0) !> SHAKE algorithm? - if( env%mddat%shake .and. env%mddat%shk%shake_mode == 0)then - env%mddat%shk%shake_mode = env%shake !> H-only shake =1, all atom =2 - endif - - if(env%mddat%md_hmass <= 0.0_wp)then - !> hydrogen mass (to enable longer timesteps) - env%mddat%md_hmass = env%hmass - endif - - ! TODO: WBO reader if shake is applied and wbo file is present + if (env%mddat%length_ps <= 0.0_wp) then + !> total runtime in ps + env%mddat%length_ps = env%mdtime + else + env%mdtime = env%mddat%length_ps + end if + if (env%mddat%tstep <= 0.0_wp) then + !> time step in fs + env%mddat%tstep = env%mdstep + end if + !> simulation steps (would be recovered automatically later, but just to make sure) + env%mddat%length_steps = nint(env%mddat%length_ps*1000.0_wp/env%mddat%tstep) + if (env%mddat%tsoll <= 0.0_wp) then + !> target temperature + env%mddat%tsoll = env%mdtemp + end if + + if (env%mddat%dumpstep <= 0.0_wp) then + !> dump frequency in fs + env%mddat%dumpstep = real(env%mddumpxyz,wp) + end if + if (env%mddat%sdump <= 0) then + !> trajectory structure dump every x steps + dum = max(1.0_wp, (env%mddat%dumpstep/env%mddat%tstep)) + env%mddat%sdump = nint(dum) + end if + + !> The SHAKE setup (special condition referring to the default) + env%mddat%shake = env%mddat%shake.and.(env%shake > 0) !> SHAKE algorithm? + if (env%mddat%shake.and.env%mddat%shk%shake_mode == 0) then + env%mddat%shk%shake_mode = env%shake !> H-only shake =1, all atom =2 + end if + + if (env%mddat%md_hmass <= 0.0_wp) then + !> hydrogen mass (to enable longer timesteps) + env%mddat%md_hmass = env%hmass + end if + + if (allocated(env%mddat%mtd)) then + nat = env%ref%nat + if (sum(env%includeRMSD) < nat) then + do i = 1,env%mddat%npot + if (.not.allocated(env%mddat%mtd(i)%atinclude)) then + allocate (env%mddat%mtd(i)%atinclude(nat),source=.false.) + else + env%mddat%mtd(i)%atinclude = .false. + end if + do j = 1,nat + if (env%includeRMSD(j) == 1) env%mddat%mtd(i)%atinclude(j) = .true. + end do + end do + end if + end if + + ! TODO: WBO reader if shake is applied and wbo file is present !>--- set flag to signal present settings env%mddat%requested = .true. end subroutine env_to_mddat - diff --git a/src/dynamics/dynamics_module.f90 b/src/dynamics/dynamics_module.f90 index e71d63f1..b17bb7dd 100644 --- a/src/dynamics/dynamics_module.f90 +++ b/src/dynamics/dynamics_module.f90 @@ -198,30 +198,30 @@ subroutine dynamics(mol,dat,calc,pr,term) !>--- settings printout if (pr) then - write (*,*) - write (*,'("> ",a)') 'Molecular dynamics settings' - write (*,'('' MD time /ps :'',f10.2)') dat%length_ps - write (*,'('' dt /fs :'',f10.2)') dat%tstep - write (*,'('' temperature /K :'',f10.2)') dat%tsoll - write (*,'('' max steps :'',i10 )') dat%length_steps - write (*,'('' block length (av.) :'',i10 )') dat%blockl - write (*,'('' dumpstep(trj) /fs :'',f10.2,i6)') dat%dumpstep,dat%sdump - write (*,'('' # deg. of freedom :'',i10 )') nfreedom + write (stdout,*) + write (stdout,'(1x,15("─"),1x,a,1x,14("─"))') 'Molecular Dynamics Settings' + write (stdout,'(" MD time /ps",t25, ":",f10.2)') dat%length_ps + write (stdout,'(" dt /fs",t25, ":",f10.2)') dat%tstep + write (stdout,'(" temperature /K",t25, ":",f10.2)') dat%tsoll + write (stdout,'(" max steps",t25, ":",i10 )') dat%length_steps + write (stdout,'(" block length (av.)",t25,":",i10 )') dat%blockl + write (stdout,'(" dumpstep(trj) /fs",t25, ":",f10.2,1x,"(",i0,")")') dat%dumpstep,dat%sdump + write (stdout,'(" # deg. of freedom",t25, ":",i10 )') nfreedom if(calc%nfreeze > 0)then - write (*,'('' # frozen atoms :'',i10 )') calc%nfreeze + write (stdout,'(" # frozen atoms",t25, ":",i10 )') calc%nfreeze endif call thermostatprint(dat,pr) - write (*,'('' SHAKE constraint :'',8x,l)') dat%shake + write (stdout,'(" SHAKE constraint",t25, ":",9x,l)') dat%shake if (dat%shake) then if (dat%shk%shake_mode == 2) then - write (*,'('' # SHAKE bonds :'',i10,a)') dat%nshake,' (all bonds)' + write (stdout,'(" # SHAKE bonds",t25,":",i10,a)') dat%nshake,' (all bonds)' elseif (dat%shk%shake_mode == 1) then - write (*,'('' # SHAKE bonds :'',i10,a)') dat%nshake,' (H only)' + write (stdout,'(" # SHAKE bonds",t25,":",i10,a)') dat%nshake,' (H only)' end if end if - write (*,'('' hydrogen mass /u :'',f10.5 )') dat%md_hmass + write (stdout,'(" hydrogen mass /u",t25,":",f10.5 )') dat%md_hmass if(allocated(dat%active_potentials))then - write (*,'('' active potentials :'',i10)') size(dat%active_potentials,1) + write (stdout,'(" active potentials",t25,":",i10)') size(dat%active_potentials,1) endif end if @@ -292,12 +292,12 @@ subroutine dynamics(mol,dat,calc,pr,term) !>--- begin printout if (pr) then - write (*,'(/,"> ",a)') 'Starting simulation' + write (stdout,'(/,"> ",a)') 'Starting simulation' if (.not.dat%thermostat) then - write (*,'(/,11x,"time (ps)",7x,"",8x,"Ekin",5x,"",7x,"T",12x, & + write (stdout,'(/,11x,"time (ps)",7x,"",8x,"Ekin",5x,"",7x,"T",12x, & & "Etot",7x,"error")') else - write (*,'(/,11x,"time (ps)",7x,"",8x,"Ekin",5x,"",7x,"T",12x, & + write (stdout,'(/,11x,"time (ps)",7x,"",8x,"Ekin",5x,"",7x,"T",12x, & & "Etot")') end if end if @@ -363,12 +363,12 @@ subroutine dynamics(mol,dat,calc,pr,term) if (pr) then rt = float(t)*dat%tstep + rtshift if (.not.dat%thermostat) then - write (*,'(i7,f10.2,F16.5,F12.4,2F8.1,F16.5,4F10.4)') & + write (stdout,'(i7,f10.2,F16.5,F12.4,2F8.1,F16.5,4F10.4)') & & t,0.001_wp*rt, (Epav+Epot)/float(t), & & Ekin,Tav/float(t),temp,Epot+Ekin, & & Edum/float(t)-Epot-Ekin else - write (*,'(i7,f10.2,F16.5,F12.4,2F8.1,F16.5)') & + write (stdout,'(i7,f10.2,F16.5,F12.4,2F8.1,F16.5)') & & t,0.001_wp*rt, (Epav+epot)/float(t), & & Ekin,Tav/float(t),temp,Epot+Ekin end if @@ -471,13 +471,13 @@ subroutine dynamics(mol,dat,calc,pr,term) !>--- averages printout if (pr) then - write (*,*) - write (*,*) 'average properties ' - write (*,*) '----------------------' - write (*,*) ' / Eh :',Epav/float(t) - write (*,*) ' / Eh :',Ekav/float(t) - write (*,*) ' / Eh :', (Ekav+Epav)/float(t) - write (*,*) ' / K :',Tav/float(t) + write (stdout,*) + write (stdout,*) 'average properties ' + write (stdout,*) '----------------------' + write (stdout,*) ' / Eh :',Epav/float(t) + write (stdout,*) ' / Eh :',Ekav/float(t) + write (stdout,*) ' / Eh :', (Ekav+Epav)/float(t) + write (stdout,*) ' / K :',Tav/float(t) end if !>--- write restart file @@ -488,11 +488,11 @@ subroutine dynamics(mol,dat,calc,pr,term) if (pr) then select case (term) case (0) - write (*,*) 'normal MD termination' + write (stdout,*) 'normal MD termination' case (1) write (stderr,*) 'error in MD calculation' case (2) - write (*,*) 'MD terminated, but still taking as converged.' + write (stdout,*) 'MD terminated, but still taking as converged.' end select end if @@ -595,8 +595,8 @@ subroutine u_block(mol,dat,epot,temp,pr,bdump) slope = 99.0_wp end if if (pr) then - write (*,'(''block / :'',f14.5,f7.1,4x, & - & ''drift:'',d10.2,3x,''Tbath :'',f6.1)') & + write (stdout,'("block / :",f14.5,f7.1,4x, & + & "drift:",d10.2,3x,"Tbath :",f6.1)') & & bave,bavt,slope,dat%tsoll end if else @@ -610,7 +610,7 @@ subroutine u_block(mol,dat,epot,temp,pr,bdump) contains subroutine regress(n1,n2,rege,slope) implicit none - real(wp) :: rege(*),slope + real(wp) :: rege(stdout),slope integer :: n1,n2,n real(wp) :: sx,sy,sxx,sxy,x integer :: i,j,k,l,ich,och,io @@ -724,7 +724,7 @@ subroutine rdmdrestart(mol,dat,velo,fail,rtshift) fail = .true. end if if(.not.fail)then - write (*,'(1x,a,8x,l)') 'read restart file :',.not.fail + write (stdout,'(1x,a,8x,l)') 'read restart file :',.not.fail endif return @@ -821,12 +821,12 @@ subroutine thermostatprint(dat,pr) if (dat%thermostat) then select case (trim(dat%thermotype)) case ('berendsen') - write (*,'('' thermostat :'',1x,a )') trim(dat%thermotype) + write (stdout,'(" thermostat",t25,":",1x,a )') trim(dat%thermotype) case default !>-- (also berendsen thermostat) - write (*,'('' thermostat :'',1x,a )') 'berendsen' + write (stdout,'(" thermostat",t25,":",1x,a )') 'berendsen' end select else - write (*,'('' thermostat :'',1x,a )') 'OFF' + write (stdout,'(" thermostat",t25,":",1x,a )') 'OFF' end if return diff --git a/src/dynamics/metadynamics_module.f90 b/src/dynamics/metadynamics_module.f90 index 587028e3..f4cd42d5 100644 --- a/src/dynamics/metadynamics_module.f90 +++ b/src/dynamics/metadynamics_module.f90 @@ -101,7 +101,9 @@ subroutine mtd_ini(mol,pot,tstep,mdlength,pr) integer,allocatable :: at(:) if (pr) then - write (stdout,'(">--- metadynamics parameter ---")') + write (stdout,'(1X,17("─"))', advance='no') + write (stdout,'(1X,"Metadynamics Parameters")', advance='no') + write (stdout,'(1X,17("─"))') end if dum1 = anint((mdlength*1000.0_wp)/tstep) @@ -158,7 +160,7 @@ subroutine mtd_ini(mol,pot,tstep,mdlength,pr) if (nat .ne. mol%nat) then !> can't do that! something is wrong if (allocated(pot%cvxyz)) deallocate (pot%cvxyz) pot%mtdtype = 0 - write (*,'(1x,a)') '*WARNING* static metadynamics setup failed! Mismatch of #atoms' + write (stdout,'(1x,a)') '*WARNING* static metadynamics setup failed! Mismatch of #atoms' !return error stop end if @@ -180,9 +182,9 @@ subroutine mtd_ini(mol,pot,tstep,mdlength,pr) !>--- printout if (pr) then call pot%info(stdout) + write (stdout,'(1X,59("─"))') end if - return end subroutine mtd_ini @@ -226,25 +228,30 @@ subroutine mtd_info(self,iunit) !write (iunit,'(" --- metadynamics parameter ---")') select case (self%mtdtype) case (cv_std_mtd) - write (iunit,'(" MTD/CV type :",1x,a)') 'standard' + write (iunit,'(" MTD/CV type",t25,":",1x,a)') 'standard' case (cv_rmsd) - write (*,'(" MTD/CV type :",1x,a)') 'RMSD bias' + write (stdout,'(" MTD/CV type",t25,":",1x,a)') 'RMSD bias' case (cv_rmsd_static) - write (iunit,'(" MTD/CV type :",1x,a)') 'RMSD bias (static)' + write (iunit,'(" MTD/CV type",t25,":",1x,a)') 'RMSD bias (static)' end select - write (iunit,'(" kpush /Eh :",f10.4)') self%kpush - write (iunit,'(" alpha /bohr⁻² :",f10.4)') self%alpha + write (iunit,'(" kpush /Eh",t25,":",f10.4)') self%kpush + write (iunit,'(" alpha /Bohr⁻²",t28,":",f10.4)') self%alpha select case (self%mtdtype) case (cv_rmsd) - write (iunit,'(" ramp :",f10.4,1x,i0)') self%ramp,check_dump_steps_rmsd(self) - write (iunit,'(" dump/fs :",f10.4,1x,i0 )') self%cvdump_fs,self%cvdumpstep - write (iunit,'(" # CVs (max) :",i10 )') self%maxsave + write (iunit,'(" ramp rate",t25,":",f10.4,1x,"(",i0,")")') self%ramp,check_dump_steps_rmsd(self) + write (iunit,'(" dump/fs",t25,":",f10.4,1x,"(",i0,")")') self%cvdump_fs,self%cvdumpstep + write (iunit,'(" # CVs (max)",t25,":",i10 )') self%maxsave case (cv_rmsd_static) - if (allocated(self%biasfile)) write (iunit,'(" reading from :",1x,a)') self%biasfile - write (iunit,'(" ramp (adjust.):",f10.4,1x,i0)') self%ramp,check_dump_steps_rmsd(self) - write (iunit,'(" # CVs (loaded):",i10 )') self%maxsave + if (allocated(self%biasfile)) write (iunit,'(" reading from",t25,":",1x,a)') self%biasfile + write (iunit,'(" ramp (adjust.)",t25,":",f10.4,1x,i0)') self%ramp,check_dump_steps_rmsd(self) + write (iunit,'(" # CVs (loaded)",t25,":",i10 )') self%maxsave end select + if (self%mtdtype == cv_rmsd.or.self%mtdtype == cv_rmsd_static) then + if (allocated(self%atinclude)) then + write (iunit,'(" # of atoms affected",t25,":",i10)') count(self%atinclude,1) + end if + end if return end subroutine mtd_info @@ -278,7 +285,7 @@ subroutine cv_dump(mol,pot,cv,pr) call rmsdcv_perturb(mol%nat,pot%cvxyz(:,:,pot%ncur)) end if if (pr) then - write (*,'(2x,"adding snapshot to metadynamics bias, now at ",i0," CVs")') pot%ncur + write (stdout,'(2x,"adding snapshot to metadynamics bias, now at ",i0," CVs")') pot%ncur end if end if diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 937bda49..590e2990 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -243,11 +243,11 @@ subroutine parse_setting_auto(env,job,kv,rd) job%id = jobtype%gfnff case ('pvol','libpvol','pv') job%id = jobtype%libpvol - case ('gxtb_dev') - job%id = jobtype%turbomole - job%rdgrad = .true. - job%binary = 'gxtb' - job%other ='-grad' + case ('gxtb_dev') + job%id = jobtype%turbomole + job%rdgrad = .true. + job%binary = 'gxtb' + job%other = '-grad' case ('none') job%id = jobtype%unknown case ('lj','lennard-jones') @@ -985,7 +985,7 @@ subroutine parse_dynamics_data(env,mddat,dict,included,istat) included = .true. call parse_mddat(env,blk,mddat,istat) else if (blk%header == 'dynamics.meta') then - call parse_metadyn(blk,mddat,istat) + call parse_metadyn(env,blk,mddat,istat) included = .true. end if end do @@ -1033,15 +1033,15 @@ subroutine parse_md_auto(env,mddat,kv,rd) mddat%active_potentials = kv%value_ia case ('includermsd','atlist+') - nat=env%ref%nat + nat = env%ref%nat call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) - if (.not.allocated(env%includeRMSD)) allocate (env%includeRMSD(nat),source=1) + if (.not.allocated(env%includeRMSD)) allocate (env%includeRMSD(nat),source=0) do j = 1,nat if (atlist(j)) env%includeRMSD(j) = 1 end do case ('excludermsd','atlist-') - nat=env%ref%nat + nat = env%ref%nat call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) if (.not.allocated(env%includeRMSD)) allocate (env%includeRMSD(nat),source=1) do j = 1,nat @@ -1094,13 +1094,14 @@ end subroutine parse_md_auto !========================================================================================! - subroutine parse_metadyn(blk,mddat,istat) + subroutine parse_metadyn(env,blk,mddat,istat) !************************************************** !* The following routines are used to !* read information into the "metadynamics" object !* and add it to a mol.dynamics data object !*************************************************** implicit none + type(systemdata),intent(inout) :: env type(datablock),intent(in) :: blk type(mddata),intent(inout) :: mddat integer,intent(inout) :: istat @@ -1112,7 +1113,7 @@ subroutine parse_metadyn(blk,mddat,istat) success = .false. if (blk%header .ne. 'dynamics.meta') return do i = 1,blk%nkv - call parse_metadyn_auto(mtd,blk%kv_list(i),success,rd) + call parse_metadyn_auto(env,mtd,blk%kv_list(i),success,rd) if (.not.rd) then istat = istat+1 write (stdout,fmturk) '[['//blk%header//']]-block',blk%kv_list(i)%key @@ -1121,12 +1122,15 @@ subroutine parse_metadyn(blk,mddat,istat) if (success) call mddat%add(mtd) return end subroutine parse_metadyn - subroutine parse_metadyn_auto(mtd,kv,success,rd) + subroutine parse_metadyn_auto(env,mtd,kv,success,rd) implicit none + type(systemdata),intent(inout) :: env type(keyvalue) :: kv type(mtdpot) :: mtd logical,intent(inout) :: success logical,intent(out) :: rd + integer :: j,nat + logical,allocatable :: atlist(:) rd = .true. select case (kv%key) @@ -1160,6 +1164,22 @@ subroutine parse_metadyn_auto(mtd,kv,success,rd) mtd%mtdtype = cv_rmsd_static mtd%biasfile = kv%value_c + case ('includermsd','atlist+') + nat = env%ref%nat + call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) + if (.not.allocated(mtd%atinclude)) allocate (mtd%atinclude(nat),source=.false.) + do j = 1,nat + if (atlist(j)) mtd%atinclude(j) = .true. + end do + + case ('excludermsd','atlist-') + nat = env%ref%nat + call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) + if (.not.allocated(mtd%atinclude)) allocate (mtd%atinclude(nat),source=.true.) + do j = 1,nat + if (atlist(j)) mtd%atinclude(j) = .false. + end do + case default rd = .false. return @@ -1235,8 +1255,8 @@ subroutine parse_bh_auto(env,bh,kv,rd) bh%maxsave = kv%value_i case ('seed') - if(.not.allocated(bh%seed)) allocate(bh%seed) - bh%seed = kv%value_i + if (.not.allocated(bh%seed)) allocate (bh%seed) + bh%seed = kv%value_i case ('step','stepsize') select case (kv%id) @@ -1246,7 +1266,7 @@ subroutine parse_bh_auto(env,bh,kv,rd) bh%stepsize(1) = kv%value_f case (valuetypes%float_array) n = min(size(kv%value_fa,1),3) - bh%stepsize(1:n) = kv%value_fa(1:n) + bh%stepsize(1:n) = kv%value_fa(1:n) case default !>--- keyword was recognized, but invalid argument supplied write (stdout,fmtura) kv%rawvalue @@ -1257,15 +1277,15 @@ subroutine parse_bh_auto(env,bh,kv,rd) bh%maxsteps = kv%value_i case ('steptype') - select case(kv%value_c) - case('cartesian') - bh%steptype=0 - case('internal') - bh%steptype=1 - case('dihedral') - bh%steptype=2 - case('intermol') - bh%steptype=3 + select case (kv%value_c) + case ('cartesian') + bh%steptype = 0 + case ('internal') + bh%steptype = 1 + case ('dihedral') + bh%steptype = 2 + case ('intermol') + bh%steptype = 3 case default write (stdout,fmtura) trim(kv%value_c) call creststop(status_config) @@ -1274,7 +1294,7 @@ subroutine parse_bh_auto(env,bh,kv,rd) case ('temp','T') bh%temp = kv%value_f - case ('parallel') + case ('parallel') bh%parallel = kv%value_b case default From 1e291343a309ab420cdd7fa6850abb5c87cb711b Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 5 Nov 2025 21:13:40 +0100 Subject: [PATCH 069/374] merge -notopo with -noreftopo --- src/confparse.f90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/confparse.f90 b/src/confparse.f90 index 3a694fe3..ad8224b4 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -1646,7 +1646,7 @@ subroutine parseflags(env,arg,nra) env%preopt = .false. case ('-topo','-topocheck') env%checktopo = .true. - case ('-notopo','-notopocheck') + case ('-notopo','-notopocheck','-noreftopo') env%checktopo = .false. ctmp = trim(arg(i+1)) if (ctmp(1:1) .ne. '-') then @@ -1655,7 +1655,6 @@ subroutine parseflags(env,arg,nra) env%checktopo = .true. end if end if - case ('-noreftopo') env%reftopo = .false. case ('-ezcheck','-checkez') env%checkiso = .true. From 3c712b9f033d2ce63169f74dc6391e4fbc8af826 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 5 Nov 2025 21:56:47 +0100 Subject: [PATCH 070/374] mini refactor; fallback calculator, opt printout --- src/confparse.f90 | 24 ++++++++++-------------- src/legacy_wrappers.f90 | 26 ++++++++++++++++++++++++++ src/optimize/optutils.f90 | 5 +++-- 3 files changed, 39 insertions(+), 16 deletions(-) diff --git a/src/confparse.f90 b/src/confparse.f90 index ad8224b4..ab508a2a 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -46,7 +46,7 @@ subroutine parseflags(env,arg,nra) use optimize_module use parse_inputfile use crest_restartlog - use lwoniom_module + implicit none type(systemdata),intent(inout) :: env integer,intent(in) :: nra @@ -2291,24 +2291,20 @@ subroutine parseflags(env,arg,nra) flush (stdout) call env2calc_setup(env) write (stdout,*) 'done.' - if (env%crestver .ne. crest_sorting) then - call env%calc%info(stdout) - end if - end if -!>--- pass on opt-level to new calculator - if (.not.env%legacy) then - env%calc%optlev = nint(env%optlev) end if -!>--- ONIOM setup from toml file - if (allocated(env%ONIOM_toml)) then - allocate (env%calc%ONIOM) - call ONIOM_read_toml(env%ONIOM_toml,env%nat,env%ref%at,env%ref%xyz,env%calc%ONIOM) - call env%calc%ONIOMexpand() - end if +!>--- pass on other settings (from cli) to new calculator + if (.not.env%legacy) then + call env2calc_modify(env) + endif !>--- important printouts if (.not.env%legacy) then + + if (env%crestver .ne. crest_sorting) then + call env%calc%info(stdout) + end if + call print_frozen(env) end if diff --git a/src/legacy_wrappers.f90 b/src/legacy_wrappers.f90 index e4080f99..789d4feb 100644 --- a/src/legacy_wrappers.f90 +++ b/src/legacy_wrappers.f90 @@ -141,6 +141,32 @@ end subroutine env2calc ! env%calc = calc end subroutine env2calc_setup +subroutine env2calc_modify(env) +!****************************************** +!* Modify the calc object within env with +!* additional settings +!****************************************** + use crest_data + use crest_calculator + use strucrd + use lwoniom_module + implicit none + !> INOUT + type(systemdata),intent(inout) :: env + !> LOCAL + +!>--- pass on opt-level to new calculator + env%calc%optlev = nint(env%optlev) + +!>--- ONIOM setup from toml file + if (allocated(env%ONIOM_toml)) then + if (.not.allocated(env%calc%ONIOM)) allocate (env%calc%ONIOM) + call ONIOM_read_toml(env%ONIOM_toml,env%nat,env%ref%at,env%ref%xyz,env%calc%ONIOM) + call env%calc%ONIOMexpand() + end if + +end subroutine env2calc_modify + !================================================================================! subroutine confscript2i(env,tim) use iso_fortran_env,only:wp => real64 diff --git a/src/optimize/optutils.f90 b/src/optimize/optutils.f90 index b31005ae..148cd121 100644 --- a/src/optimize/optutils.f90 +++ b/src/optimize/optutils.f90 @@ -334,7 +334,8 @@ subroutine print_optsummary(calc,tight,nvar,maxcycle,maxmicro, & '(10x,"│",3x,a,i18, 10x,"│")' character(len=*),parameter :: chrfmt = & '(10x,"│",3x,a,a18, 10x,"│")' - + character(len=*),parameter :: chrfmt2 = & + '(10x,"│",3x,a,a14, t63,"│")' !>--- set params engine = calc%opt_engine iupdat = calc%iupdat @@ -410,7 +411,7 @@ subroutine print_optsummary(calc,tight,nvar,maxcycle,maxmicro, & write (*,chrfmt) "Hessian update ","schlegel" end select end if - write (*,chrfmt) "write crestopt.log.xyz",bool2string(wr) + write (*,chrfmt2) "write crestopt.log.xyz",bool2string(wr) if (linear) then write (*,chrfmt) "linear (good luck)",bool2string(linear) else From b7754161bb0873ccf410d3c2a8da1cf699c248df Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 5 Nov 2025 23:49:51 +0100 Subject: [PATCH 071/374] prepare tblite efield implementation --- src/calculator/calc_type.f90 | 1 + src/classes.f90 | 1 + src/confparse.f90 | 15 +++++++++++++ src/crest_pars.f90 | 43 +++++++++++++++++++++--------------- src/legacy_wrappers.f90 | 14 +++++++++++- 5 files changed, 55 insertions(+), 19 deletions(-) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 2a415451..fd169cf1 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -130,6 +130,7 @@ module calc_type logical :: getlmocent = .false. integer :: nprot = 0 real(wp),allocatable :: protxyz(:,:) + real(wp),allocatable :: efield(:) !> in V/Å !>--- API constructs integer :: tblitelvl = 2 diff --git a/src/classes.f90 b/src/classes.f90 index 78e8e62b..7bfbda02 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -311,6 +311,7 @@ module crest_data integer,allocatable :: topo(:) real(wp),allocatable :: charges(:) real(wp),allocatable :: wbo(:,:) + real(wp),allocatable :: efield(:) contains procedure :: rdcharges => read_charges procedure :: to => ref_to_mol diff --git a/src/confparse.f90 b/src/confparse.f90 index ab508a2a..9f3fe2e8 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -1264,6 +1264,21 @@ subroutine parseflags(env,arg,nra) env%ref%ichrg = idum end if end if + + case ('-efield') !> electric field in V/Ang, only compatibe with tblite + if(.not.allocated(env%ref%efield)) allocate(env%ref%efield(3), source=0.0_wp) + if (nra >= i+3) then + ctmp = trim(arg(i+1)) + read(ctmp,*,iostat=io) env%ref%efield(1) + ctmp = trim(arg(i+2)) + read(ctmp,*,iostat=io) env%ref%efield(2) + ctmp = trim(arg(i+3)) + read(ctmp,*,iostat=io) env%ref%efield(3) + write(stdout,'(" --efield: ",3(1x,es10.3)," V/Å")') env%ref%efield(1:3) + else + write(stdout,'(a)') + endif + case ('-dscal','-dispscal','-dscal_global','-dispscal_global') env%cts%dispscal_md = .true. if (index(argument,'_global') .ne. 0) then diff --git a/src/crest_pars.f90 b/src/crest_pars.f90 index c18ebbe7..3cc7719c 100644 --- a/src/crest_pars.f90 +++ b/src/crest_pars.f90 @@ -1,22 +1,22 @@ module crest_parameters - use iso_fortran_env, only: wp => real64, sp => real32 - use iso_fortran_env, only: ap => real64 - use iso_fortran_env, only: dp => int64 - use iso_fortran_env, only: int8,int16,int32,int64,real64,real32 - use iso_fortran_env, only: stdout => output_unit - use iso_fortran_env, only: stderr => error_unit + use iso_fortran_env,only:wp => real64,sp => real32 + use iso_fortran_env,only:ap => real64 + use iso_fortran_env,only:dp => int64 + use iso_fortran_env,only:int8,int16,int32,int64,real64,real32 + use iso_fortran_env,only:stdout => output_unit + use iso_fortran_env,only:stderr => error_unit public :: wp,sp,ap,dp,stdout,stderr public :: int8,int16,int32,int64,real64,real32 real(wp),parameter,public :: bohr = 0.52917726_wp - real(wp),parameter,public :: angstrom = 1.0_wp / bohr + real(wp),parameter,public :: angstrom = 1.0_wp/bohr real(wp),parameter,public :: autoaa = bohr real(wp),parameter,public :: aatoau = angstrom - real(wp),parameter,public :: pi = acos(0.0_wp)*2.0_wp - real(wp),parameter,public :: radtodeg = 180.0_wp / pi - real(wp),parameter,public :: degtorad = 1.0_wp / radtodeg + real(wp),parameter,public :: pi = acos(0.0_wp)*2.0_wp + real(wp),parameter,public :: radtodeg = 180.0_wp/pi + real(wp),parameter,public :: degtorad = 1.0_wp/radtodeg real(wp),parameter,public :: amutokg = 1.660539040e-27_wp real(wp),parameter,public :: autokj = 2625.49964038_wp @@ -26,8 +26,16 @@ module crest_parameters real(wp),parameter,public :: kcaltokj = autokj/autokcal real(wp),parameter,public :: autorcm = 219474.63067_wp real(wp),parameter,public :: rcmtoau = 1.0_wp/autorcm - real(wp),parameter,public :: metokg = 9.10938356e-31_wp - real(wp),parameter,public :: kgtome = 1.0_wp/metokg + real(wp),parameter,public :: metokg = 9.10938356e-31_wp + real(wp),parameter,public :: kgtome = 1.0_wp/metokg + + real(wp),parameter,public :: c_vacuum = 299792458e0_wp + !> Coulomb to atomic charge units (electrons) + real(wp),public,parameter :: autoc = 1.6021766208e-19_wp + real(wp),parameter,public :: ctoau = 1.0_wp/autoc + real(wp),parameter,private :: fine_structure_constant = 7.2973525693e-3_wp + real(wp),parameter,public :: jtoau = 1.0_wp/(metokg*c_vacuum**2*fine_structure_constant**2) + real(wp),parameter,public :: vatoau = jtoau/(ctoau*aatoau) real(wp),parameter,public :: Rcal = 8.31446261815324_wp/kcaltokj real(wp),parameter,public :: kB = 3.166808578545117e-06_wp @@ -35,14 +43,13 @@ module crest_parameters real(wp),parameter,public :: planck = 6.62606957e-34_wp ! J*s real(wp),parameter,public :: hbar = planck/(2.0_wp*pi) - real(wp),public,parameter :: lightspeed = 137.0359990740_wp + real(wp),public,parameter :: lightspeed = 137.0359990740_wp !> femtosectons to atomic time units - real(wp), public, parameter :: fstoau = 41.3413733365614_wp - !> Coulomb to atomic charge units (electrons) - real(wp), public, parameter :: autoc = 1.6021766208e-19_wp + real(wp),public,parameter :: fstoau = 41.3413733365614_wp + !> Debye to atomic units - real(wp), public, parameter :: autod = autoc * lightspeed * autoaa**2 * fstoau * 1.0e+16_wp - real(wp), public, parameter :: dtoau = 1.0_wp / autod + real(wp),public,parameter :: autod = autoc*lightspeed*autoaa**2*fstoau*1.0e+16_wp + real(wp),public,parameter :: dtoau = 1.0_wp/autod character(len=1),public,parameter :: sep = '/' character(len=12),public,parameter :: dev0 = ' 2>/dev/null' diff --git a/src/legacy_wrappers.f90 b/src/legacy_wrappers.f90 index 789d4feb..b62bb967 100644 --- a/src/legacy_wrappers.f90 +++ b/src/legacy_wrappers.f90 @@ -146,18 +146,30 @@ subroutine env2calc_modify(env) !* Modify the calc object within env with !* additional settings !****************************************** + use crest_parameters use crest_data use crest_calculator use strucrd - use lwoniom_module + use lwoniom_module implicit none !> INOUT type(systemdata),intent(inout) :: env !> LOCAL + integer :: i,j !>--- pass on opt-level to new calculator env%calc%optlev = nint(env%optlev) +!>--- pass electric field to tblite + if (allocated(env%ref%efield)) then + do i = 1,env%calc%ncalculations + if (env%calc%calcs(i)%id == jobtype%tblite) then + if (.not.allocated(env%calc%calcs(i)%efield)) allocate (env%calc%calcs(i)%efield(3),source=0.0_wp) + env%calc%calcs(i)%efield(1:3) = env%ref%efield(1:3) + end if + end do + end if + !>--- ONIOM setup from toml file if (allocated(env%ONIOM_toml)) then if (.not.allocated(env%calc%ONIOM)) allocate (env%calc%ONIOM) From 47337280bb21f5b7e6f4085fbd61bcc2eb503fa6 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 6 Nov 2025 00:51:50 +0100 Subject: [PATCH 072/374] working tblite+efield calculation --- src/calculator/api_engrad.f90 | 2 + src/calculator/tblite_api.F90 | 96 ++++++++++++++++++++++++----------- 2 files changed, 67 insertions(+), 31 deletions(-) diff --git a/src/calculator/api_engrad.f90 b/src/calculator/api_engrad.f90 index 2db81965..5cce6086 100644 --- a/src/calculator/api_engrad.f90 +++ b/src/calculator/api_engrad.f90 @@ -95,6 +95,8 @@ subroutine tblite_engrad(mol,calc,energy,grad,iostatus) call tblite_addsettings(calc%tblite,calc%maxscc,calc%rdwbo,calc%saveint,calc%accuracy) + call tblite_add_efield(calc%tblite,calc%efield) + call tblite_add_solv(mol,calc%chrg,calc%uhf,calc%tblite, & & calc%solvmodel,calc%solvent) end if diff --git a/src/calculator/tblite_api.F90 b/src/calculator/tblite_api.F90 index 34e72df4..294fb00e 100644 --- a/src/calculator/tblite_api.F90 +++ b/src/calculator/tblite_api.F90 @@ -23,7 +23,8 @@ !====================================================! module tblite_api - use iso_fortran_env,only:wp => real64,stdout => output_unit +! use iso_fortran_env,only:wp => real64,stdout => output_unit + use crest_parameters use strucrd #ifdef WITH_TBLITE use mctc_env,only:error_type @@ -96,6 +97,7 @@ module tblite_api public :: tblite_setup,tblite_singlepoint,tblite_addsettings public :: tblite_getwbos public :: tblite_add_solv + public :: tblite_add_efield public :: tblite_getcharges public :: tblite_getdipole @@ -136,22 +138,22 @@ subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite) tblite%lvl = lvl select case (tblite%lvl) case (xtblvl%gfn1) - if (pr) call tblite%ctx%message("tblite> setting up GFN1-xTB calculation") + if (pr) call tblite%ctx%message("tblite> Setting up GFN1-xTB calculation") call new_gfn1_calculator(tblite%calc,mctcmol,error) case (xtblvl%gfn2) - if (pr) call tblite%ctx%message("tblite> setting up GFN2-xTB calculation") + if (pr) call tblite%ctx%message("tblite> Setting up GFN2-xTB calculation") call new_gfn2_calculator(tblite%calc,mctcmol,error) case (xtblvl%ipea1) - if (pr) call tblite%ctx%message("tblite> setting up IPEA1-xTB calculation") + if (pr) call tblite%ctx%message("tblite> Setting up IPEA1-xTB calculation") call new_ipea1_calculator(tblite%calc,mctcmol,error) case (xtblvl%ceh) - if (pr) call tblite%ctx%message("tblite> setting up CEH calculation") + if (pr) call tblite%ctx%message("tblite> Setting up CEH calculation") call new_ceh_calculator(tblite%calc,mctcmol,error) case (xtblvl%eeq) - if (pr) call tblite%ctx%message("tblite> setting up D4 EEQ charges calculation") + if (pr) call tblite%ctx%message("tblite> Setting up D4 EEQ charges calculation") call new_ceh_calculator(tblite%calc,mctcmol,error) !> doesn't matter but needs initialization case (xtblvl%param) - if (pr) call tblite%ctx%message("tblite> setting up xtb calculator from parameter file") + if (pr) call tblite%ctx%message("tblite> Setting up xtb calculator from parameter file") if (allocated(tblite%paramfile)) then call tblite_read_param_record(tblite%paramfile,param,io) call new_xtb_calculator(tblite%calc,mctcmol,param,error) @@ -167,6 +169,7 @@ subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite) call tblite%ctx%message("Error: Unknown method in tblite!") error stop end select + if (pr) call tblite%ctx%message('') !>-- setup wavefunction object etemp_au = etemp*ktoau @@ -226,7 +229,7 @@ subroutine tblite_add_solv(mol,chrg,uhf,tblite,smodel,solvent) end if select case (tblite%lvl) case (xtblvl%gfn1) - method ='gfn1' + method = 'gfn1' case (xtblvl%gfn2) method = 'gfn2' end select @@ -251,19 +254,19 @@ subroutine tblite_add_solv(mol,chrg,uhf,tblite,smodel,solvent) case ('gbsa') if (pr) call tblite%ctx%message("tblite> using GBSA/"//solvdum) alpb_tmp%dielectric_const = solv_data%eps - alpb_tmp%alpb=.false. + alpb_tmp%alpb = .false. !alpb_tmp%method=method - alpb_tmp%solvent=solv_data%solvent + alpb_tmp%solvent = solv_data%solvent !alpb_tmp%xtb=.true. - allocate (solv_inp%alpb, source=alpb_tmp) - cds_tmp%alpb=.false. - cds_tmp%solvent=solv_data%solvent - !cds_tmp%method=method - allocate (solv_inp%cds, source=cds_tmp) - shift_tmp%alpb=.false. - shift_tmp%solvent=solv_data%solvent + allocate (solv_inp%alpb,source=alpb_tmp) + cds_tmp%alpb = .false. + cds_tmp%solvent = solv_data%solvent + !cds_tmp%method=method + allocate (solv_inp%cds,source=cds_tmp) + shift_tmp%alpb = .false. + shift_tmp%solvent = solv_data%solvent !shift_tmp%method=method - allocate (solv_inp%shift, source=shift_tmp) + allocate (solv_inp%shift,source=shift_tmp) case ('cpcm') if (pr) call tblite%ctx%message("tblite> using CPCM/"//solvdum) allocate (solv_inp%cpcm) @@ -271,27 +274,27 @@ subroutine tblite_add_solv(mol,chrg,uhf,tblite,smodel,solvent) case ('alpb') if (pr) call tblite%ctx%message("tblite> using ALPB/"//solvdum) alpb_tmp%dielectric_const = solv_data%eps - alpb_tmp%alpb=.true. + alpb_tmp%alpb = .true. !alpb_tmp%method=method - alpb_tmp%solvent=solv_data%solvent + alpb_tmp%solvent = solv_data%solvent !alpb_tmp%xtb=.true. - allocate (solv_inp%alpb, source=alpb_tmp) - cds_tmp%alpb=.true. - cds_tmp%solvent=solv_data%solvent - !cds_tmp%method=method - allocate (solv_inp%cds, source=cds_tmp) - shift_tmp%alpb=.true. - shift_tmp%solvent=solv_data%solvent + allocate (solv_inp%alpb,source=alpb_tmp) + cds_tmp%alpb = .true. + cds_tmp%solvent = solv_data%solvent + !cds_tmp%method=method + allocate (solv_inp%cds,source=cds_tmp) + shift_tmp%alpb = .true. + shift_tmp%solvent = solv_data%solvent !shift_tmp%method=method - allocate (solv_inp%shift, source=shift_tmp) + allocate (solv_inp%shift,source=shift_tmp) case default if (pr) call tblite%ctx%message("tblite> Unknown tblite implicit solvation model!") return end select - str = 'tblite> WARNING: implicit solvation energies are not entirely '// & - &'consistent with the xtb implementation.' - if (pr) call tblite%ctx%message(str) + !str = 'tblite> WARNING: implicit solvation energies are not entirely '// & + !&'consistent with the xtb implementation.' + !if (pr) call tblite%ctx%message(str) !>--- add electrostatic (Born part) to calculator call new_solvation(solv,mctcmol,solv_inp,error,method) @@ -444,6 +447,37 @@ subroutine tblite_addsettings(tblite,maxscc,rdwbo,saveint,accuracy) #endif end subroutine tblite_addsettings + subroutine tblite_add_efield(tblite,efield) +!********************************************************** +!* tblite_add_efield +!* if efield is allocated, add it to the tblite calculator +!********************************************************** +#ifdef WITH_TBLITE + use tblite_container,only:container_type + use tblite_external_field,only:electric_field +#endif + implicit none + type(tblite_data),intent(inout) :: tblite + real(wp),intent(in),allocatable :: efield(:) + class(container_type),allocatable :: cont + logical :: pr + character(len=90) :: str +#ifdef WITH_TBLITE + pr = (tblite%ctx%verbosity > 0) + if (allocated(efield)) then + if (pr) then + write (str,'(a,3(es10.3),a)') "tblite> Calculation includes the following electric field:" + call tblite%ctx%message(trim(str)) + write (str,'(8x, a,3(es15.5,1x),a)') "[",efield,"] V/Å" + call tblite%ctx%message(trim(str)) + call tblite%ctx%message('') + end if + cont = electric_field(efield*vatoau) + call tblite%calc%push_back(cont) + end if +#endif + end subroutine tblite_add_efield + !========================================================================================! subroutine tblite_getwbos(tblite,nat,wbo) From 9f8b0a7f477238efe9f47b7c5b322b65a852f759 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 6 Nov 2025 10:46:10 +0100 Subject: [PATCH 073/374] add efield keyword for toml inputs --- src/parsing/parse_calcdata.f90 | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 590e2990..a1fa5b79 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -175,6 +175,7 @@ subroutine parse_setting_auto(env,job,kv,rd) type(keyvalue) :: kv logical,intent(out) :: rd logical :: ex + integer :: n rd = .true. select case (kv%key) @@ -191,6 +192,15 @@ subroutine parse_setting_auto(env,job,kv,rd) job%proberad = kv%value_f case ('radscal','pvol_radscal') job%pvradscal = kv%value_f + case ('efield') + n = size(kv%value_fa,1) + if (n .ne. 3) then + !>--- keyword was recognized, but invalid argument supplied + write (stdout,fmtura) trim(kv%rawvalue) + call creststop(status_config) + end if + allocate (job%efield(3),source=0.0_wp) + job%efield(:) = kv%value_fa(:) !>--- integers case ('uhf','multiplicity') @@ -1101,7 +1111,7 @@ subroutine parse_metadyn(env,blk,mddat,istat) !* and add it to a mol.dynamics data object !*************************************************** implicit none - type(systemdata),intent(inout) :: env + type(systemdata),intent(inout) :: env type(datablock),intent(in) :: blk type(mddata),intent(inout) :: mddat integer,intent(inout) :: istat @@ -1129,7 +1139,7 @@ subroutine parse_metadyn_auto(env,mtd,kv,success,rd) type(mtdpot) :: mtd logical,intent(inout) :: success logical,intent(out) :: rd - integer :: j,nat + integer :: j,nat logical,allocatable :: atlist(:) rd = .true. From 4651ea3dd58266735f5552d43256c3b6142a1a56 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 8 Nov 2025 00:13:40 +0100 Subject: [PATCH 074/374] Prepare CEH charge initialization for tblite and gfnff --- src/algos/playground.f90 | 16 ++-- src/calculator/api_engrad.f90 | 43 ++++++---- src/calculator/api_helpers.F90 | 4 +- src/calculator/calc_type.f90 | 1 + src/calculator/tblite_api.F90 | 143 +++++++++++++++++++++++++++++++-- src/iomod.F90 | 49 ++++++++++- 6 files changed, 222 insertions(+), 34 deletions(-) diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index de0714f4..9b2b68e0 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -49,7 +49,7 @@ subroutine crest_playground(env,tim) logical :: connected,fail real(wp) :: energy - real(wp),allocatable :: grad(:,:),geo(:,:),csv(:,:) + real(wp),allocatable :: grad(:,:),geo(:,:),csv(:,:),q(:) type(canonical_sorter) :: can !========================================================================================! @@ -78,12 +78,14 @@ subroutine crest_playground(env,tim) call engrad(mol,calc,energy,grad,io) call calculation_summary(calc,mol,energy,grad) - - write(stdout,*) - write(stdout,*) 'CANGEN algorithm' - call can%init(mol,calc%calcs(1)%wbo,'apsp+',heavy=.false.) - call can%stereo(mol) - call can%rankprint(mol) + block + use tblite_api + use iomod, only: dump_array_to_tmp + call tblite_quick_ceh_q(mol,q,env%chrg,pr=.true.) + write(*,*) 'q:' + write(*,*) q + write(*,*) dump_array_to_tmp(q) + end block !========================================================================================! call tim%stop(14) diff --git a/src/calculator/api_engrad.f90 b/src/calculator/api_engrad.f90 index 5cce6086..ce083b94 100644 --- a/src/calculator/api_engrad.f90 +++ b/src/calculator/api_engrad.f90 @@ -1,7 +1,7 @@ !================================================================================! ! This file is part of crest. ! -! Copyright (C) 2021 - 2023 Philipp Pracht +! Copyright (C) 2021 - 2025 Philipp Pracht ! ! crest is free software: you can redistribute it and/or modify it under ! the terms of the GNU Lesser General Public License as published by @@ -27,7 +27,7 @@ module api_engrad use iso_fortran_env,only:wp => real64,stdout => output_unit use strucrd use calc_type - use iomod,only:makedir,directory_exist,remove + use iomod,only:makedir,directory_exist,remove,dump_array_to_tmp !> API modules use api_helpers use tblite_api @@ -63,7 +63,6 @@ subroutine tblite_engrad(mol,calc,energy,grad,iostatus) real(wp),intent(inout) :: grad(3,mol%nat) integer,intent(out) :: iostatus - character(len=:),allocatable :: cpath logical :: loadnew,pr integer :: i,j,k,l,ich,och,io @@ -76,22 +75,22 @@ subroutine tblite_engrad(mol,calc,energy,grad,iostatus) call tblite_init(calc,loadnew) !>--- tblite printout handling call api_handle_output(calc,'tblite.out',mol,pr) - if (pr .or. calc%prstdout) then + if (pr.or.calc%prstdout) then !> tblite uses its context (ctx) type, rather than calc%prch calc%tblite%ctx%unit = calc%prch calc%tblite%ctx%verbosity = 1 - if(calc%prstdout)then + if (calc%prstdout) then !> special case, fwd to stdout (be carefule with this!) calc%tblite%ctx%unit = stdout calc%tblite%ctx%verbosity = 2 - endif + end if else calc%tblite%ctx%verbosity = 0 end if !>-- populate parameters and wavefunction if (loadnew) then - call tblite_setup(mol,calc%chrg,calc%uhf,calc%tblitelvl,calc%etemp,calc%tblite) + call tblite_setup(mol,calc%chrg,calc%uhf,calc%tblitelvl,calc%etemp,calc%tblite,calc%ceh_guess) call tblite_addsettings(calc%tblite,calc%maxscc,calc%rdwbo,calc%saveint,calc%accuracy) @@ -107,7 +106,7 @@ subroutine tblite_engrad(mol,calc,energy,grad,iostatus) call tblite_singlepoint(mol,calc%chrg,calc%uhf,calc%tblite, & & energy,grad,iostatus) if (iostatus /= 0) return - if(.not.calc%prstdout) & + if (.not.calc%prstdout) & & call api_print_e_grd(pr,calc%prch,mol,energy,grad) !>--- postprocessing, getting other data @@ -136,7 +135,6 @@ subroutine gfn0_engrad(mol,calc,g0calc,energy,grad,iostatus) integer,intent(out) :: iostatus !> LOCAL type(gfn0_results) :: res - character(len=:),allocatable :: cpath logical :: loadnew logical :: pr @@ -163,7 +161,7 @@ subroutine gfn0_engrad(mol,calc,g0calc,energy,grad,iostatus) if (iostatus /= 0) return if (pr) then call gfn0_print(calc%prch,g0calc,res) - if(.not.calc%prstdout) & + if (.not.calc%prstdout) & & call api_print_e_grd(pr,calc%prch,mol,energy,grad) end if @@ -193,7 +191,6 @@ subroutine gfn0occ_engrad(mol,calc,g0calc,energy,grad,iostatus) integer,intent(out) :: iostatus !> LOCAL type(gfn0_results) :: res - character(len=:),allocatable :: cpath logical :: loadnew,pr integer :: i,j,k,l,ich,och,io logical :: ex @@ -219,7 +216,7 @@ subroutine gfn0occ_engrad(mol,calc,g0calc,energy,grad,iostatus) if (iostatus /= 0) return if (pr) then call gfn0_print(calc%prch,g0calc,res) - if(.not.calc%prstdout) & + if (.not.calc%prstdout) & & call api_print_e_grd(pr,calc%prch,mol,energy,grad) end if @@ -245,13 +242,14 @@ subroutine gfnff_engrad(mol,calc,energy,grad,iostatus) real(wp),intent(inout) :: grad(3,mol%nat) integer,intent(out) :: iostatus - character(len=:),allocatable :: cpath logical :: loadnew,pr integer :: i,j,k,l,ich,och,io logical :: ex + character(len=:),allocatable :: tmpchrgs + real(wp),allocatable :: q(:) iostatus = 0 pr = .false. -!>--- setup system call information +!>--- setup calculation data !$omp critical call gfnff_init(calc,loadnew) !>--- printout handling @@ -259,7 +257,19 @@ subroutine gfnff_engrad(mol,calc,energy,grad,iostatus) !>--- populate parameters and neighbourlists if (loadnew) then + if (calc%ceh_guess) then + !> A bit hacky and additional I/O, but would need adjusting submodule code otherwise + call tblite_quick_ceh_q(mol,q,calc%chrg) + tmpchrgs = dump_array_to_tmp(q) + calc%ff_dat%refcharges = tmpchrgs + end if + call gfnff_api_setup(mol,calc%chrg,calc%ff_dat,iostatus,pr,calc%prch) + + if (calc%ceh_guess) then + call remove(tmpchrgs) + deallocate (q) + end if end if !$omp end critical if (iostatus /= 0) return @@ -272,7 +282,7 @@ subroutine gfnff_engrad(mol,calc,energy,grad,iostatus) !>--- printout if (pr) then call gfnff_printout(calc%prch,calc%ff_dat) - if(.not.calc%prstdout) & + if (.not.calc%prstdout) & & call api_print_e_grd(pr,calc%prch,mol,energy,grad) end if @@ -298,7 +308,6 @@ subroutine libpvol_engrad(mol,calc,energy,grad,iostatus) real(wp),intent(inout) :: grad(3,mol%nat) integer,intent(out) :: iostatus - character(len=:),allocatable :: cpath logical :: loadnew,pr integer :: i,j,k,l,ich,och,io logical :: ex @@ -326,7 +335,7 @@ subroutine libpvol_engrad(mol,calc,energy,grad,iostatus) !>--- printout if (pr) then !> the libpvol_sp call includes the printout within libpvol-lib - if(.not.calc%prstdout) & + if (.not.calc%prstdout) & & call api_print_e_grd(pr,calc%prch,mol,energy,grad) end if diff --git a/src/calculator/api_helpers.F90 b/src/calculator/api_helpers.F90 index 81ee45e0..0b1eccc7 100644 --- a/src/calculator/api_helpers.F90 +++ b/src/calculator/api_helpers.F90 @@ -21,7 +21,7 @@ module api_helpers use iso_fortran_env,only:wp => real64,stdout => output_unit use strucrd use calc_type - use iomod,only:makedir,directory_exist,remove + use iomod,only:makedir,directory_exist,remove,random_tmp_name !> APIs use tblite_api use gfn0_api @@ -390,6 +390,8 @@ subroutine libpvol_initcheck(calc,loadnew) #endif end subroutine libpvol_initcheck + + !========================================================================================! !========================================================================================! end module api_helpers diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index fd169cf1..56e91ebf 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -151,6 +151,7 @@ module calc_type !>--- tblite data type(tblite_data),allocatable :: tblite character(len=:),allocatable :: tbliteparam + logical :: ceh_guess = .false. !>--- GFN0-xTB data type(gfn0_data),allocatable :: g0calc diff --git a/src/calculator/tblite_api.F90 b/src/calculator/tblite_api.F90 index 294fb00e..8ed1b8b2 100644 --- a/src/calculator/tblite_api.F90 +++ b/src/calculator/tblite_api.F90 @@ -31,7 +31,7 @@ module tblite_api use mctc_io,only:structure_type,new use tblite_context_type,only:tblite_ctx => context_type use tblite_wavefunction_type,only:wavefunction_type,new_wavefunction - use tblite_wavefunction,only:sad_guess,eeq_guess + use tblite_wavefunction,only:sad_guess,eeq_guess,shell_partition use tblite_xtb,xtb_calculator => xtb_calculator use tblite_xtb_calculator,only:new_xtb_calculator use tblite_param,only:param_record @@ -100,6 +100,7 @@ module tblite_api public :: tblite_add_efield public :: tblite_getcharges public :: tblite_getdipole + public :: tblite_quick_ceh_q !========================================================================================! !========================================================================================! @@ -107,7 +108,7 @@ module tblite_api !========================================================================================! !========================================================================================! - subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite) + subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite,ceh_guess) !***************************************************************** !* subroutine tblite_setup initializes the tblite object which is !* passed between the CREST calculators and this module @@ -119,6 +120,7 @@ subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite) type(tblite_data),intent(inout) :: tblite integer,intent(in) :: lvl real(wp),intent(in) :: etemp + logical,intent(in),optional :: ceh_guess #ifdef WITH_TBLITE type(structure_type) :: mctcmol type(error_type),allocatable :: error @@ -175,6 +177,9 @@ subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite) etemp_au = etemp*ktoau call new_wavefunction(tblite%wfn,mol%nat,tblite%calc%bas%nsh, & & tblite%calc%bas%nao,1,etemp_au) + if (ceh_guess) then + call tblite_internal_ceh_guess(mctcmol,tblite) + end if #else /* WITH_TBLITE */ write (stdout,*) 'Error: Compiled without tblite support!' @@ -466,11 +471,11 @@ subroutine tblite_add_efield(tblite,efield) pr = (tblite%ctx%verbosity > 0) if (allocated(efield)) then if (pr) then - write (str,'(a,3(es10.3),a)') "tblite> Calculation includes the following electric field:" - call tblite%ctx%message(trim(str)) + write (str,'(a,3(es10.3),a)') "tblite> Calculation includes the following electric field:" + call tblite%ctx%message(trim(str)) write (str,'(8x, a,3(es15.5,1x),a)') "[",efield,"] V/Å" call tblite%ctx%message(trim(str)) - call tblite%ctx%message('') + call tblite%ctx%message('') end if cont = electric_field(efield*vatoau) call tblite%calc%push_back(cont) @@ -599,6 +604,134 @@ subroutine tblite_read_param_record(paramfile,param,io) end subroutine tblite_read_param_record #endif +!========================================================================================! + +#ifdef WITH_TBLITE + subroutine tblite_internal_ceh_guess(mctcmol,tblite) + !********************************************************* + !* Init the tblite calculator with a set of CEH charges + !********************************************************* + implicit none + type(tblite_data),intent(inout) :: tblite + type(structure_type),intent(in) :: mctcmol + !> LOCAL + type(wavefunction_type) :: wfn_ceh + type(xtb_calculator) :: calc_ceh + type(error_type),allocatable :: error + integer :: verbosity + logical :: pr + real(wp),parameter :: etemp_guess_au = 4000.0_wp*ktoau + + !> if we only do a eeq or ceh calc, we don't need this, so return + select case (tblite%lvl) + case default + continue + case (xtblvl%ceh,xtblvl%eeq) + return + end select + + pr = (tblite%ctx%verbosity > 0) + if (tblite%ctx%verbosity > 1) then + verbosity = tblite%ctx%verbosity + else + verbosity = 0 + end if + + !> ceh guess calculator and wavefunction + call new_ceh_calculator(calc_ceh,mctcmol,error) + if (allocated(error)) return + call new_wavefunction(wfn_ceh,mctcmol%nat,calc_ceh%bas%nsh, & + & calc_ceh%bas%nao,1,etemp_guess_au) + + !> TODO ceh guess efield + + call ceh_singlepoint(tblite%ctx,calc_ceh,mctcmol,wfn_ceh, & + & tblite%accuracy,verbosity) + + if (tblite%ctx%failed()) then + if (pr) then + call tblite%ctx%get_error(error) + call tblite%ctx%message("CEH singlepoint calculation failed") + call tblite%ctx%message("-> "//error%message) + end if + return + end if + + !> pass on to actual calculator + tblite%wfn%qat(:,1) = wfn_ceh%qat(:,1) + call shell_partition(mctcmol,tblite%calc,tblite%wfn) + + end subroutine tblite_internal_ceh_guess +#endif + +!========================================================================================! + + subroutine tblite_quick_ceh_q(mol,q,chrg,uhf,pr) + !********************************************************* + !* Calculate CEH charges + !********************************************************* + implicit none + type(coord),intent(in) :: mol + integer,intent(in) :: chrg + real(wp),intent(out),allocatable :: q(:) + integer,intent(in),optional :: uhf + logical,intent(in),optional :: pr +#ifdef WITH_TBLITE + type(structure_type) :: mctcmol + !> LOCAL + type(wavefunction_type) :: wfn_ceh + type(xtb_calculator) :: calc_ceh + type(tblite_ctx) :: ctx + type(error_type),allocatable :: error +#endif + integer :: verbosity,uhf_loc + logical :: pr_loc + real(wp),parameter :: etemp_guess_au = 4000.0_wp*ktoau + real(wp),parameter :: accuracy=1.0_wp + + pr_loc = .false. + if(present(pr)) pr_loc = pr + verbosity = 0 + if(pr_loc) verbosity = 2 + + allocate(q(mol%nat), source=0.0_wp) + +#ifdef WITH_TBLITE + uhf_loc = 0 + if (present(uhf)) uhf_loc = uhf + + !>--- make an mctcmol object from mol + call tblite_mol2mol(mol,chrg,uhf_loc,mctcmol) + + !> ceh guess calculator and wavefunction + call new_ceh_calculator(calc_ceh,mctcmol,error) + if (allocated(error)) return + call new_wavefunction(wfn_ceh,mctcmol%nat,calc_ceh%bas%nsh, & + & calc_ceh%bas%nao,1,etemp_guess_au) + + !> TODO ceh guess efield + + call ceh_singlepoint(ctx,calc_ceh,mctcmol,wfn_ceh, & + & accuracy,verbosity) + + if (ctx%failed()) then + if (pr_loc) then + call ctx%get_error(error) + call ctx%message("CEH singlepoint calculation failed") + call ctx%message("-> "//error%message) + end if + return + end if + + !> pass on the charges + q(:) = wfn_ceh%qat(:,1) +#else /* WITH_TBLITE */ + write (stdout,*) 'Error: Compiled without tblite support!' + write (stdout,*) 'Use -DWITH_TBLITE=true in the setup to enable this function' + error stop +#endif + end subroutine tblite_quick_ceh_q + !========================================================================================! !========================================================================================! end module tblite_api diff --git a/src/iomod.F90 b/src/iomod.F90 index 1a03bb4d..e2bddd67 100644 --- a/src/iomod.F90 +++ b/src/iomod.F90 @@ -63,10 +63,10 @@ end function c_isatty end interface interface - function get_peak_rss_kb() bind(C, name="get_peak_rss_kb") result(kb) - import :: c_long_long - integer(c_long_long) :: kb - end function + function get_peak_rss_kb() bind(C,name="get_peak_rss_kb") result(kb) + import :: c_long_long + integer(c_long_long) :: kb + end function end interface interface wrshort @@ -1231,6 +1231,47 @@ subroutine split_path(fullpath,dir_part,base_part,has_slash) end subroutine split_path +!=========================================================================================! + + function random_tmp_name() result(fname) + implicit none + character(len=20) :: fname + character(len=16) :: core + integer :: i,idx + real(wp) :: idxr + character(len=*),parameter :: letters = & + & "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + integer,parameter :: lenletters = len(letters) + + do i = 1,len(core) + call random_number(idxr) + idx = int(idxr*lenletters)+1 + core(i:i) = letters(idx:idx) + end do + + fname = trim(core)//".tmp" + end function random_tmp_name + +!==========================================================================================! +! + function dump_array_to_tmp(arr) result(fname) + implicit none + real(wp),intent(in) :: arr(:) + character(len=:),allocatable :: fname + integer :: unit,i + + fname = trim(random_tmp_name()) + + open (newunit=unit,file=fname,status="replace",action="write",iostat=i) + if (i /= 0) stop "Could not open temp file." + + do i = 1,size(arr) + write (unit,'(f25.15)') arr(i) + end do + + close (unit) + end function dump_array_to_tmp + !========================================================================================! !========================================================================================! !========================================================================================! From 94859785c1cd9836daa1de87a9afb27c4af47360 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 8 Nov 2025 16:59:21 +0100 Subject: [PATCH 075/374] Add toml and cli arg for ceh_guess --- src/calculator/api_engrad.f90 | 5 ++++- src/calculator/tblite_api.F90 | 4 +++- src/classes.f90 | 1 + src/confparse.f90 | 3 +++ src/legacy_wrappers.f90 | 7 +++++++ src/parsing/parse_calcdata.f90 | 2 ++ 6 files changed, 20 insertions(+), 2 deletions(-) diff --git a/src/calculator/api_engrad.f90 b/src/calculator/api_engrad.f90 index ce083b94..ddcf60e3 100644 --- a/src/calculator/api_engrad.f90 +++ b/src/calculator/api_engrad.f90 @@ -258,8 +258,11 @@ subroutine gfnff_engrad(mol,calc,energy,grad,iostatus) !>--- populate parameters and neighbourlists if (loadnew) then if (calc%ceh_guess) then + if(pr)then + write(calc%prch,'(/,a)') 'Initializing (fragement) charges from CEH model' + endif !> A bit hacky and additional I/O, but would need adjusting submodule code otherwise - call tblite_quick_ceh_q(mol,q,calc%chrg) + call tblite_quick_ceh_q(mol,q,calc%chrg,pr=pr,prch=calc%prch) tmpchrgs = dump_array_to_tmp(q) calc%ff_dat%refcharges = tmpchrgs end if diff --git a/src/calculator/tblite_api.F90 b/src/calculator/tblite_api.F90 index 8ed1b8b2..a3a35697 100644 --- a/src/calculator/tblite_api.F90 +++ b/src/calculator/tblite_api.F90 @@ -666,7 +666,7 @@ end subroutine tblite_internal_ceh_guess !========================================================================================! - subroutine tblite_quick_ceh_q(mol,q,chrg,uhf,pr) + subroutine tblite_quick_ceh_q(mol,q,chrg,uhf,pr,prch) !********************************************************* !* Calculate CEH charges !********************************************************* @@ -676,6 +676,7 @@ subroutine tblite_quick_ceh_q(mol,q,chrg,uhf,pr) real(wp),intent(out),allocatable :: q(:) integer,intent(in),optional :: uhf logical,intent(in),optional :: pr + integer,intent(in),optional :: prch #ifdef WITH_TBLITE type(structure_type) :: mctcmol !> LOCAL @@ -699,6 +700,7 @@ subroutine tblite_quick_ceh_q(mol,q,chrg,uhf,pr) #ifdef WITH_TBLITE uhf_loc = 0 if (present(uhf)) uhf_loc = uhf + if(present(prch)) ctx%unit=prch !>--- make an mctcmol object from mol call tblite_mol2mol(mol,chrg,uhf_loc,mctcmol) diff --git a/src/classes.f90 b/src/classes.f90 index 7bfbda02..5a4ec50f 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -539,6 +539,7 @@ module crest_data logical :: autozsort !> do the ZSORT in the beginning ? logical :: allowrestart = .true. !> allow restart in crest algos? logical :: better !> found a better conformer and restart in V1 + logical :: ceh_guess = .false. !> use CEH guess in tblite or gfnff, if available logical :: cff !> CFF used in QCG-energy calculation logical :: cluster = .false. !> perform a clustering analysis logical :: checktopo = .true. !> perform topolgy check in CREGEN diff --git a/src/confparse.f90 b/src/confparse.f90 index 9f3fe2e8..c7302fb3 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -1279,6 +1279,9 @@ subroutine parseflags(env,arg,nra) write(stdout,'(a)') endif + case ('-ceh_guess') + env%ceh_guess=.true. + case ('-dscal','-dispscal','-dscal_global','-dispscal_global') env%cts%dispscal_md = .true. if (index(argument,'_global') .ne. 0) then diff --git a/src/legacy_wrappers.f90 b/src/legacy_wrappers.f90 index b62bb967..c895d61f 100644 --- a/src/legacy_wrappers.f90 +++ b/src/legacy_wrappers.f90 @@ -170,6 +170,13 @@ subroutine env2calc_modify(env) end do end if + !>--- pass on CEH guess flag + if (env%ceh_guess) then + do i = 1,env%calc%ncalculations + env%calc%calcs(i)%ceh_guess = env%ceh_guess + end do + end if + !>--- ONIOM setup from toml file if (allocated(env%ONIOM_toml)) then if (.not.allocated(env%calc%ONIOM)) allocate (env%calc%ONIOM) diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index a1fa5b79..5f8bdf2f 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -462,6 +462,8 @@ subroutine parse_setting_auto(env,job,kv,rd) job%apiclean = kv%value_b case ('lmo','lmocent') job%getlmocent = kv%value_b + case ('ceh_guess') + job%ceh_guess = kv%value_b case default !>--- keyword not correctly read/found From c6e41f21817c203e8ef321f4a991059d9006f459 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 8 Nov 2025 17:54:46 +0100 Subject: [PATCH 076/374] Start QCG refactor --- src/printouts.f90 | 188 --------------------------------- src/qcg/CMakeLists.txt | 1 + src/qcg/qcg_printouts.f90 | 213 ++++++++++++++++++++++++++++++++++++++ src/qcg/solvtool.f90 | 6 ++ 4 files changed, 220 insertions(+), 188 deletions(-) create mode 100644 src/qcg/qcg_printouts.f90 diff --git a/src/printouts.f90 b/src/printouts.f90 index 90ab7e26..bf4b3a62 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -540,24 +540,6 @@ end subroutine zsortwarning2 !========================================================================================! -subroutine qcg_head() - implicit none - write (*,*) - write (*,'(2x,''========================================'')') - write (*,'(2x,''| ---------------- |'')') - write (*,'(2x,''| Q C G |'')') - write (*,'(2x,''| ---------------- |'')') - write (*,'(2x,''| Quantum Cluster Growth |'')') - write (*,'(2x,''| University of Bonn, MCTC |'')') - write (*,'(2x,''========================================'')') - write (*,'(2x,'' S. Grimme, S. Spicher, C. Plett.'')') - write (*,*) - write (*,'(3x,''Cite work conducted with this code as'')') - write (*,'(/,3x,''S. Spicher, C. Plett, P. Pracht, A. Hansen, S. Grimme, JCTC, 2022, 18, 3174-3189.'')') - write (*,*) -end subroutine qcg_head - -!========================================================================================! subroutine msreact_head() implicit none @@ -1001,176 +983,6 @@ subroutine checkbinary(env) return end subroutine checkbinary -!========================================================================================! -!========================================================================================! -!> QCG-printouts -!==============================================================================! -!========================================================================================! - -subroutine print_qcg_grow() - implicit none - write (*,*) - write (*,'(2x,''========================================='')') - write (*,'(2x,''| quantum cluster growth: GROW |'')') - write (*,'(2x,''========================================='')') - write (*,*) -end subroutine print_qcg_grow -subroutine pr_qcg_fastgrow() - implicit none - write (*,*) - write (*,'(2x,''========================================='')') - write (*,'(2x,''| quantum cluster growth: FASTGROW |'')') - write (*,'(2x,''========================================='')') - write (*,*) -end subroutine pr_qcg_fastgrow -subroutine print_qcg_ensemble() - implicit none - write (*,*) - write (*,'(2x,''========================================='')') - write (*,'(2x,''| quantum cluster growth: ENSEMBLE |'')') - write (*,'(2x,''========================================='')') - write (*,*) -end subroutine print_qcg_ensemble -subroutine print_qcg_opt() - implicit none - write (*,*) - write (*,'(2x,''========================================='')') - write (*,'(2x,''| quantum cluster growth: OPT |'')') - write (*,'(2x,''========================================='')') - write (*,*) - write (*,'(2x,''Very tight post optimization of lowest cluster'')') -end subroutine print_qcg_opt -subroutine pr_qcg_fill() - implicit none - write (*,*) - write (*,'(2x,''========================================='')') - write (*,'(2x,''| quantum cluster growth: CFF |'')') - write (*,'(2x,''========================================='')') - write (*,*) - write (*,'(2x,''CUT-FREEZE-FILL Algorithm to generate reference solvent cluster'')') -end subroutine pr_qcg_fill -subroutine pr_qcg_freq() - implicit none - write (*,*) - write (*,'(2x,''========================================='')') - write (*,'(2x,''| Frequency evaluation |'')') - write (*,'(2x,''========================================='')') - write (*,*) -end subroutine pr_qcg_freq -subroutine pr_eval_solute() - implicit none - write (*,*) - write (*,'(2x,''________________________________________________________________________'')') - write (*,*) - write (*,'(2x,''__________________ Solute Cluster Generation _____________________'')') - write (*,*) - write (*,'(2x,''________________________________________________________________________'')') - write (*,*) -end subroutine pr_eval_solute -subroutine pr_eval_solvent() - implicit none - write (*,*) - write (*,*) - write (*,'(2x,''________________________________________________________________________'')') - write (*,*) - write (*,'(2x,''_________________ Solvent Cluster Generation _____________________'')') - write (*,*) - write (*,'(2x,''________________________________________________________________________'')') - write (*,*) -end subroutine pr_eval_solvent -subroutine pr_eval_eval() - implicit none - write (*,*) - write (*,*) - write (*,'(2x,''________________________________________________________________________'')') - write (*,*) - write (*,'(2x,''_________________________ Evaluation ____________________________'')') - write (*,*) - write (*,'(2x,''________________________________________________________________________'')') - write (*,*) - write (*,*) -end subroutine pr_eval_eval -subroutine pr_freq_energy() - implicit none - write (*,'(2x,"# H(T) SVIB SROT STRA G(T)")') - write (*,'(2x," [kcal/mol] [ cal/mol/K ] [kcal/mol]")') - write (*,'(2x,"--------------------------------------------------------")') -end subroutine pr_freq_energy -subroutine pr_eval_1(G,H) - use iso_fortran_env,only:wp => real64 - implicit none - real(wp),intent(in) :: G,H - write (*,'(2x,"-----------------------------------------------------")') - write (*,'(2x,"Gsolv and Hsolv ref. state: [1 M gas/solution] ")') - write (*,'(2x,"G_solv (incl.RRHO) =",F8.2," kcal/mol")') G - write (*,'(2x,"H_solv (incl.RRHO) =",F8.2," kcal/mol")') H - write (*,'(2x,"-----------------------------------------------------")') - write (*,*) -end subroutine pr_eval_1 -subroutine pr_eval_2(srange,G,scal) - use iso_fortran_env,only:wp => real64 - implicit none -! Dummy - integer,intent(in) :: srange - real(wp),intent(in) :: G(srange) - real(wp),intent(in) :: scal(srange) -! Stack - integer :: i - write (*,'(2x,"-----------------------------------------------------")') - write (*,'(2x,"Solvation free energies with scaled translational")') - write (*,'(2x,"and rotational degrees of freedom: Gsolv (scaling)")') - do i = 1,srange - write (*,'(10x,">>",2x,f8.2," (",f4.2,")",4x,"<<")') G(i),scal(i) - end do - write (*,'(2x,"-----------------------------------------------------")') -end subroutine pr_eval_2 -subroutine pr_eval_3(srange,freqscal,scal,G) - use iso_fortran_env,only:wp => real64 - implicit none -! Dummy - integer,intent(in) :: srange - integer,intent(in) :: freqscal - real(wp),intent(in) :: scal - real(wp),intent(in) :: G(srange) - write (*,*) - write (*,'(2x,"==================================================")') - write (*,'(2x,"| Gsolv with SCALED RRHO contributions: ",f4.2,4x"|")') scal - write (*,'(2x,"| [1 bar gas/ 1 M solution] |")') - write (*,'(2x,"| |")') - write (*,'(2x,"| G_solv (incl.RRHO)+dV(T)=",F8.2," kcal/mol |")') G(freqscal) - write (*,'(2x,"==================================================")') - write (*,*) -end subroutine pr_eval_3 -subroutine pr_fill_energy() - implicit none - write (*,'(x,'' Size'',2x,''Cluster '',2x,''E /Eh '',7x,''De/kcal'',3x,& - &''Detot/kcal'',2x,''Opt'',4x)') -end subroutine pr_fill_energy -subroutine pr_ensemble_energy() - implicit none - write (*,*) - write (*,'(x,'' Cluster'',3x,''E /Eh '',7x,& - &''Density'',2x,''Efix'',7x,''R av/act.'',1x,& - &''Surface'',3x,''Opt'',4x)') -end subroutine pr_ensemble_energy -subroutine pr_qcg_esolv() - implicit none - write (*,*) - write (*,'(2x,''========================================='')') - write (*,'(2x,''| quantum cluster growth: ESOLV |'')') - write (*,'(2x,''| |'')') -end subroutine pr_qcg_esolv -subroutine pr_grow_energy() - implicit none - write (*,'(x,'' Size'',7x,''E'',8x,''De'',7x,''Detot'',6x,& - &''Density'',5x,''Eatom'',4x,''av. R'', 1x,'' Rlast'',3x,& - &''Volume'',4x,''Opt'')') - write (*,'(12x,''[Eh]'',4x,''[kcal]'',5x,''[kcal]'',5x,& - &''[u/Å^3]'',5x,''[kcal]'',3x,''[bohr]'', 1x,''[bohr]'',1x,& - &''[bohr^3]'')') - -end subroutine pr_grow_energy - !========================================================================================! !========================================================================================! diff --git a/src/qcg/CMakeLists.txt b/src/qcg/CMakeLists.txt index 785a6c22..40d62b3c 100644 --- a/src/qcg/CMakeLists.txt +++ b/src/qcg/CMakeLists.txt @@ -20,6 +20,7 @@ list(APPEND srcs "${dir}/volume.f90" "${dir}/solvtool_misc.f90" "${dir}/solvtool.f90" + "${dir}/qcg_printouts.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/qcg/qcg_printouts.f90 b/src/qcg/qcg_printouts.f90 new file mode 100644 index 00000000..b0adae54 --- /dev/null +++ b/src/qcg/qcg_printouts.f90 @@ -0,0 +1,213 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2021-2025 Christoph Plett, Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module qcg_printouts + use crest_parameters,only:stdout,wp + implicit none + public + +contains + + subroutine qcg_head() + implicit none + write (stdout,*) + write (stdout,'(2x,''========================================'')') + write (stdout,'(2x,''| ---------------- |'')') + write (stdout,'(2x,''| Q C G |'')') + write (stdout,'(2x,''| ---------------- |'')') + write (stdout,'(2x,''| Quantum Cluster Growth |'')') + write (stdout,'(2x,''| University of Bonn, MCTC |'')') + write (stdout,'(2x,''========================================'')') + write (stdout,'(2x,'' S. Grimme, S. Spicher, C. Plett.'')') + write (stdout,*) + write (stdout,'(3x,''Cite work conducted with this code as'')') + write (stdout,'(/,3x,''S. Spicher, C. Plett, P. Pracht, A. Hansen, S. Grimme, JCTC, 2022, 18, 3174-3189.'')') + write (stdout,*) + end subroutine qcg_head + +!========================================================================================! +!========================================================================================! +!> QCG-printouts +!==============================================================================! +!========================================================================================! + + subroutine print_qcg_grow() + implicit none + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| quantum cluster growth: GROW |'')') + write (stdout,'(2x,''========================================='')') + write (stdout,*) + end subroutine print_qcg_grow + subroutine pr_qcg_fastgrow() + implicit none + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| quantum cluster growth: FASTGROW |'')') + write (stdout,'(2x,''========================================='')') + write (stdout,*) + end subroutine pr_qcg_fastgrow + subroutine print_qcg_ensemble() + implicit none + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| quantum cluster growth: ENSEMBLE |'')') + write (stdout,'(2x,''========================================='')') + write (stdout,*) + end subroutine print_qcg_ensemble + subroutine print_qcg_opt() + implicit none + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| quantum cluster growth: OPT |'')') + write (stdout,'(2x,''========================================='')') + write (stdout,*) + write (stdout,'(2x,''Very tight post optimization of lowest cluster'')') + end subroutine print_qcg_opt + subroutine pr_qcg_fill() + implicit none + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| quantum cluster growth: CFF |'')') + write (stdout,'(2x,''========================================='')') + write (stdout,*) + write (stdout,'(2x,''CUT-FREEZE-FILL Algorithm to generate reference solvent cluster'')') + end subroutine pr_qcg_fill + subroutine pr_qcg_freq() + implicit none + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| Frequency evaluation |'')') + write (stdout,'(2x,''========================================='')') + write (stdout,*) + end subroutine pr_qcg_freq + subroutine pr_eval_solute() + implicit none + write (stdout,*) + write (stdout,'(2x,''________________________________________________________________________'')') + write (stdout,*) + write (stdout,'(2x,''__________________ Solute Cluster Generation _____________________'')') + write (stdout,*) + write (stdout,'(2x,''________________________________________________________________________'')') + write (stdout,*) + end subroutine pr_eval_solute + subroutine pr_eval_solvent() + implicit none + write (stdout,*) + write (stdout,*) + write (stdout,'(2x,''________________________________________________________________________'')') + write (stdout,*) + write (stdout,'(2x,''_________________ Solvent Cluster Generation _____________________'')') + write (stdout,*) + write (stdout,'(2x,''________________________________________________________________________'')') + write (stdout,*) + end subroutine pr_eval_solvent + subroutine pr_eval_eval() + implicit none + write (stdout,*) + write (stdout,*) + write (stdout,'(2x,''________________________________________________________________________'')') + write (stdout,*) + write (stdout,'(2x,''_________________________ Evaluation ____________________________'')') + write (stdout,*) + write (stdout,'(2x,''________________________________________________________________________'')') + write (stdout,*) + write (stdout,*) + end subroutine pr_eval_eval + subroutine pr_freq_energy() + implicit none + write (stdout,'(2x,"# H(T) SVIB SROT STRA G(T)")') + write (stdout,'(2x," [kcal/mol] [ cal/mol/K ] [kcal/mol]")') + write (stdout,'(2x,"--------------------------------------------------------")') + end subroutine pr_freq_energy + subroutine pr_eval_1(G,H) + implicit none + real(wp),intent(in) :: G,H + write (stdout,'(2x,"-----------------------------------------------------")') + write (stdout,'(2x,"Gsolv and Hsolv ref. state: [1 M gas/solution] ")') + write (stdout,'(2x,"G_solv (incl.RRHO) =",F8.2," kcal/mol")') G + write (stdout,'(2x,"H_solv (incl.RRHO) =",F8.2," kcal/mol")') H + write (stdout,'(2x,"-----------------------------------------------------")') + write (stdout,*) + end subroutine pr_eval_1 + subroutine pr_eval_2(srange,G,scal) + implicit none +! Dummy + integer,intent(in) :: srange + real(wp),intent(in) :: G(srange) + real(wp),intent(in) :: scal(srange) +! Stack + integer :: i + write (stdout,'(2x,"-----------------------------------------------------")') + write (stdout,'(2x,"Solvation free energies with scaled translational")') + write (stdout,'(2x,"and rotational degrees of freedom: Gsolv (scaling)")') + do i = 1,srange + write (stdout,'(10x,">>",2x,f8.2," (",f4.2,")",4x,"<<")') G(i),scal(i) + end do + write (stdout,'(2x,"-----------------------------------------------------")') + end subroutine pr_eval_2 + subroutine pr_eval_3(srange,freqscal,scal,G) + implicit none +! Dummy + integer,intent(in) :: srange + integer,intent(in) :: freqscal + real(wp),intent(in) :: scal + real(wp),intent(in) :: G(srange) + write (stdout,*) + write (stdout,'(2x,"==================================================")') + write (stdout,'(2x,"| Gsolv with SCALED RRHO contributions: ",f4.2,4x"|")') scal + write (stdout,'(2x,"| [1 bar gas/ 1 M solution] |")') + write (stdout,'(2x,"| |")') + write (stdout,'(2x,"| G_solv (incl.RRHO)+dV(T)=",F8.2," kcal/mol |")') G(freqscal) + write (stdout,'(2x,"==================================================")') + write (stdout,*) + end subroutine pr_eval_3 + subroutine pr_fill_energy() + implicit none + write (stdout,'(x,'' Size'',2x,''Cluster '',2x,''E /Eh '',7x,''De/kcal'',3x,& + &''Detot/kcal'',2x,''Opt'',4x)') + end subroutine pr_fill_energy + subroutine pr_ensemble_energy() + implicit none + write (stdout,*) + write (stdout,'(x,'' Cluster'',3x,''E /Eh '',7x,& + &''Density'',2x,''Efix'',7x,''R av/act.'',1x,& + &''Surface'',3x,''Opt'',4x)') + end subroutine pr_ensemble_energy + subroutine pr_qcg_esolv() + implicit none + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| quantum cluster growth: ESOLV |'')') + write (stdout,'(2x,''| |'')') + end subroutine pr_qcg_esolv + subroutine pr_grow_energy() + implicit none + write (stdout,'(x,'' Size'',7x,''E'',8x,''De'',7x,''Detot'',6x,& + &''Density'',5x,''Eatom'',4x,''av. R'', 1x,'' Rlast'',3x,& + &''Volume'',4x,''Opt'')') + write (stdout,'(12x,''[Eh]'',4x,''[kcal]'',5x,''[kcal]'',5x,& + &''[u/Å^3]'',5x,''[kcal]'',3x,''[bohr]'', 1x,''[bohr]'',1x,& + &''[bohr^3]'')') + + end subroutine pr_grow_energy + +!========================================================================================! +!========================================================================================! +end module qcg_printouts diff --git a/src/qcg/solvtool.f90 b/src/qcg/solvtool.f90 index 575e093c..dca76065 100644 --- a/src/qcg/solvtool.f90 +++ b/src/qcg/solvtool.f90 @@ -24,6 +24,7 @@ !======================================================! subroutine crest_solvtool(env, tim) use iso_fortran_env, wp => real64 + use qcg_printouts use crest_data use iomod use zdata @@ -450,6 +451,7 @@ end subroutine read_directed_input subroutine qcg_grow(env, solu, solv, clus, tim) use crest_parameters use crest_data + use qcg_printouts use iomod use zdata use strucrd @@ -844,6 +846,7 @@ end subroutine qcg_grow subroutine qcg_ensemble(env, solu, solv, clus, ens, tim, fname_results) use crest_parameters use crest_data + use qcg_printouts use iomod use zdata use strucrd @@ -1499,6 +1502,7 @@ end subroutine qcg_ensemble subroutine qcg_cff(env, solu, solv, clus, ens, solv_ens, tim) use crest_parameters use crest_data + use qcg_printouts use iomod use zdata use strucrd @@ -1965,6 +1969,7 @@ end subroutine qcg_cff subroutine qcg_freq(env, tim, solu, solv, solu_ens, solv_ens) use crest_parameters use crest_data + use qcg_printouts use iomod use zdata use strucrd @@ -2220,6 +2225,7 @@ end subroutine qcg_freq subroutine qcg_eval(env, solu, solu_ens, solv_ens) use iso_fortran_env, wp => real64 use crest_data + use qcg_printouts use iomod use zdata use strucrd From a9ff2448a8d7a57cb404e009ae7f0dced48aaee7 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 8 Nov 2025 20:08:09 +0100 Subject: [PATCH 077/374] Move code around in QCG --- src/miscdata.f90 | 24 + src/qcg/CMakeLists.txt | 1 + src/qcg/qcg_printouts.f90 | 72 + src/qcg/solvtool.f90 | 5585 ++++++++++++++++++------------------- src/qcg/solvtool_misc.f90 | 1415 +++++----- src/qcg/volume.f90 | 1077 ++++--- 6 files changed, 4106 insertions(+), 4068 deletions(-) diff --git a/src/miscdata.f90 b/src/miscdata.f90 index 79dc3a7f..d2359ae2 100644 --- a/src/miscdata.f90 +++ b/src/miscdata.f90 @@ -99,6 +99,30 @@ module miscdata & 1.36_wp,1.43_wp,1.46_wp,1.58_wp,1.48_wp,1.57_wp ] ! Nh-Og !&> +!&< + !> Colvlent Radii as used in QCG. No idea where they originate from; Legacy. + real(wp),parameter :: rcov_qcg(1:94) = [ & + & 2.18230009,1.73469996,3.49559999,3.09820008,3.21600008, & + & 2.91030002,2.62249994,2.48169994,2.29959989,2.13739991, & + & 3.70819998,3.48390007,4.01060009,3.79169989,3.50169992, & + & 3.31069994,3.10459995,2.91479993,4.24109983,4.10349989, & + & 3.89030004,3.76419997,3.72110009,3.44140005,3.54620004, & + & 3.44210005,3.43269992,3.34619999,3.30080009,3.23090005, & + & 3.95790005,3.86190009,3.66249990,3.52679992,3.36619997, & + & 3.20959997,4.61759996,4.47639990,4.21960020,4.05970001, & + & 3.85960007,3.75430012,3.56900001,3.46230006,3.39750004, & + & 3.35249996,3.33080006,3.46199989,4.26230001,4.18739986, & + & 4.01499987,3.89010000,3.73799992,3.58890009,5.05670023, & + & 5.18139982,4.62610006,4.62010002,4.57019997,4.52710009, & + & 4.48960018,4.45149994,4.42339993,4.12430000,4.24270010, & + & 4.15409994,4.27939987,4.24499989,4.22079992,4.19859982, & + & 4.01300001,4.24499989,4.09800005,3.98550010,3.89549994, & + & 3.74900007,3.44560003,3.35249996,3.25640011,3.35990000, & + & 4.31269979,4.27640009,4.11749983,4.00540018,3.86439991, & + & 3.72160006,5.07959986,4.92939997,4.70429993,4.42519999, & + & 4.45940018,4.39569998,4.35389996,4.43410015] +!&> + !&< !> D3 pairwise van-der-Waals radii (only homoatomic pairs present here) diff --git a/src/qcg/CMakeLists.txt b/src/qcg/CMakeLists.txt index 40d62b3c..f004ec32 100644 --- a/src/qcg/CMakeLists.txt +++ b/src/qcg/CMakeLists.txt @@ -21,6 +21,7 @@ list(APPEND srcs "${dir}/solvtool_misc.f90" "${dir}/solvtool.f90" "${dir}/qcg_printouts.f90" + # "${dir}/qcg_utils.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/qcg/qcg_printouts.f90 b/src/qcg/qcg_printouts.f90 index b0adae54..04106d3c 100644 --- a/src/qcg/qcg_printouts.f90 +++ b/src/qcg/qcg_printouts.f90 @@ -19,6 +19,9 @@ module qcg_printouts use crest_parameters,only:stdout,wp + + use crest_data + use iomod implicit none public @@ -41,6 +44,67 @@ subroutine qcg_head() write (stdout,*) end subroutine qcg_head + subroutine write_qcg_setup(env) + implicit none + type(systemdata) :: env + + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| quantum cluster growth: INPUT |'')') + write (stdout,'(2x,''========================================='')') + write (stdout,*) + select case (env%qcg_runtype) + case (0) + write (stdout,'(2x,''QCG: Only Cluster Generation'')') + case (1) + write (stdout,'(2x,''QCG: Cluster + Ensemble Generation'')') + if (env%ensemble_method .eq. 0) write (stdout,'(2x,''Ensemble generated via CREST'')') + if (env%ensemble_method .eq. 1) write (stdout,'(2x,''Ensemble generated via MD Simulation'')') + if (env%ensemble_method .eq. 2) write (stdout,'(2x,''Ensemble generated via MetaDynamic'')') + case (2) + write (stdout,'(2x,''QCG: Calculation of delta E_solv'')') + if (env%ensemble_method .eq. 0) write (stdout,'(2x,''Ensemble generated via CREST'')') + if (env%ensemble_method .eq. 1) write (stdout,'(2x,''Ensemble generated via MD Simulation'')') + if (env%ensemble_method .eq. 2) write (stdout,'(2x,''Ensemble generated via MetaDynamic'')') + case (3) + write (stdout,'(2x,''QCG: Calculation of delta G_solv'')') + if (env%ensemble_method .eq. 0) write (stdout,'(2x,''Ensemble generated via CREST'')') + if (env%ensemble_method .eq. 1) write (stdout,'(2x,''Ensemble generated via MD Simulation'')') + if (env%ensemble_method .eq. 2) write (stdout,'(2x,''Ensemble generated via MetaDynamic'')') + case default + continue + end select + write (stdout,*) + write (stdout,'(2x,''input parameters '')') + write (stdout,'(2x,''solute : '',a)') trim(env%solu_file) + write (stdout,'(2x,''charge : '',i0)') env%chrg + write (stdout,'(2x,''uhf : '',i0)') env%uhf + write (stdout,'(2x,''solvent : '',a)') trim(env%solv_file) + if (env%nsolv .ne. 0) then + write (stdout,'(2x,''# of solvents to add : '',i0)') env%nsolv + else if (env%nsolv .eq. 0) then + write (stdout,'(2x,''# of solvents to add : until convergence, but maximal'',1x,i4)') env%max_solv + end if + if (env%nqcgclust .ne. 0) then + write (stdout,'(2x,''# of cluster generated : '',i0)') env%nqcgclust + else + write (stdout,'(2x,''Cluster generated that are above 10 % populated '')') + end if + + write (stdout,'(2x,''# of CPUs used : '',i0)') env%Threads + if (env%solvent .eq. '') then + write (stdout,'(2x,''No gbsa/alpb model'' )') + else + write (stdout,'(2x,''Solvation model : '',a)') env%solvent + end if + write (stdout,'(2x,''xtb opt level : '',a)') trim(optlevflag(env%optlev)) + write (stdout,'(2x,''System temperature [K] : '',F5.1)') env%tboltz + write (stdout,'(2x,''RRHO scaling factor : '',F4.2)') env%freq_scal + write (stdout,*) + if (env%use_xtbiff) write (stdout,'(2x,''Use of xTB-IFF standalone requested'')') + + end subroutine write_qcg_setup + !========================================================================================! !========================================================================================! !> QCG-printouts @@ -208,6 +272,14 @@ subroutine pr_grow_energy() end subroutine pr_grow_energy + subroutine pr_freq_file(ich) + implicit none + integer :: ich + write (ich,'(2x,"# H(T) SVIB SROT STRA G(T)")') + write (ich,'(2x," [kcal/mol] [ cal/mol/K ] [kcal/mol]")') + write (ich,'(2x,"--------------------------------------------------------")') + end subroutine pr_freq_file + !========================================================================================! !========================================================================================! end module qcg_printouts diff --git a/src/qcg/solvtool.f90 b/src/qcg/solvtool.f90 index dca76065..14b88092 100644 --- a/src/qcg/solvtool.f90 +++ b/src/qcg/solvtool.f90 @@ -16,2700 +16,2646 @@ ! You should have received a copy of the GNU Lesser General Public License ! along with crest. If not, see . !================================================================================! -!===================================================================! -! This file contains routines related to QCG and microsolvation -!===================================================================! -!======================================================! -! main routine -!======================================================! -subroutine crest_solvtool(env, tim) - use iso_fortran_env, wp => real64 - use qcg_printouts - use crest_data - use iomod - use zdata - use strucrd - implicit none - - type(systemdata):: env ! MAIN STORAGE OS SYSTEM DATA - type(timer):: tim - !> Information about solvent, solute and cluster - type(zmolecule) :: solute, solvent, cluster, cluster_backup - type(ensemble) :: full_ensemble, solvent_ensemble - - integer :: progress,io - character(len=512) :: thispath - - real(wp), parameter :: eh = 627.509541d0 + +!> This file contains routines related to QCG and microsolvation + +subroutine crest_solvtool(env,tim) +!*********************************************** +!* Main driver for all QCG runtypes +!*********************************************** + use iso_fortran_env,wp => real64 + use qcg_printouts + use crest_data + use iomod + use zdata + use strucrd + implicit none + + type(systemdata):: env ! MAIN STORAGE OS SYSTEM DATA + type(timer):: tim + !> Information about solvent, solute and cluster + type(zmolecule) :: solute,solvent,cluster,cluster_backup + type(ensemble) :: full_ensemble,solvent_ensemble + + integer :: progress,io + character(len=512) :: thispath + + real(wp),parameter :: eh = 627.509541d0 !--- Molecule settings - solute%nmol = 1 - solvent%nmol = 1 - cluster%nmol = 1 + solute%nmol = 1 + solvent%nmol = 1 + cluster%nmol = 1 - progress = 0 - call getcwd(thispath) + progress = 0 + call getcwd(thispath) - !>----------------------------------- - call qcg_head() - !>----------------------------------- + !>----------------------------------- + call qcg_head() + !>----------------------------------- !> Check, if xtb is present - call checkprog_silent(env%ProgName,.true.,iostat=io) - if(io /= 0 ) error stop 'No xtb found' + call checkprog_silent(env%ProgName,.true.,iostat=io) + if (io /= 0) error stop 'No xtb found' !> Check, if xtbiff is present (if it is required) - if (env%use_xtbiff) then - call checkprog_silent(env%ProgIFF,.true.,iostat=io) - if(io /= 0 ) error stop 'No xtbiff found' - else - write (*, *) - write (*, *) ' The use of the aISS algorithm is requested (recommend).' - write (*, *) ' This requires xtb version 6.6.0 or newer.' - write (*, *) ' xTB-IFF can still be used with the --xtbiff flag.' - write (*, *) - end if + if (env%use_xtbiff) then + call checkprog_silent(env%ProgIFF,.true.,iostat=io) + if (io /= 0) error stop 'No xtbiff found' + else + write (*,*) + write (*,*) ' The use of the aISS algorithm is requested (recommend).' + write (*,*) ' This requires xtb version 6.7.1 or newer.' + write (*,*) ' xTB-IFF can still be used with the --xtbiff flag.' + write (*,*) + end if !------------------------------------------------------------------------------ ! Setup !------------------------------------------------------------------------------ - call write_qcg_setup(env) !Just an outprint of setup - call read_qcg_input(env, solute, solvent) !Reading mol. data and determining r,V,A - call qcg_setup(env, solute, solvent) - call qcg_restart(env, progress, solute, solvent, cluster, full_ensemble,& - & solvent_ensemble, cluster_backup) + call write_qcg_setup(env) !Just an outprint of setup + call read_qcg_input(env,solute,solvent) !Reading mol. data and determining r,V,A + call qcg_setup(env,solute,solvent) + call qcg_restart(env,progress,solute,solvent,cluster,full_ensemble,& + & solvent_ensemble,cluster_backup) !----------------------------------------------------------------------------- ! Grow !----------------------------------------------------------------------------- - if (progress .le. env%qcg_runtype .and. progress .eq. 0) then - cluster = solute - call qcg_grow(env, solute, solvent, cluster, tim) - if (.not. env%cff) then - allocate (cluster_backup%at(cluster%nat)) - allocate (cluster_backup%xyz(3, cluster%nat)) - cluster_backup = cluster - end if - progress = progress + 1 - call chdir(thispath) - end if + if (progress .le. env%qcg_runtype.and.progress .eq. 0) then + cluster = solute + call qcg_grow(env,solute,solvent,cluster,tim) + if (.not.env%cff) then + allocate (cluster_backup%at(cluster%nat)) + allocate (cluster_backup%xyz(3,cluster%nat)) + cluster_backup = cluster + end if + progress = progress+1 + call chdir(thispath) + end if !------------------------------------------------------------------------------ ! Ensemble search !------------------------------------------------------------------------------ - if (progress .le. env%qcg_runtype .and. progress .eq. 1) then - call print_qcg_ensemble() - call qcg_ensemble(env, solute, solvent, cluster, full_ensemble, tim, 'ensemble') - progress = progress + 1 - call chdir(thispath) - end if + if (progress .le. env%qcg_runtype.and.progress .eq. 1) then + call print_qcg_ensemble() + call qcg_ensemble(env,solute,solvent,cluster,full_ensemble,tim,'ensemble') + progress = progress+1 + call chdir(thispath) + end if !------------------------------------------------------------------------------ ! Solvent cluster generation !------------------------------------------------------------------------------ - if (progress .le. env%qcg_runtype .and. progress .eq. 2) then !esolv - call pr_eval_solvent() - if (env%cff) then !CFF - call qcg_cff(env, solute, solvent, cluster, full_ensemble,& - & solvent_ensemble, tim) - else !Normal ensemble generation - call print_qcg_ensemble() - call cluster%deallocate - allocate (cluster%at(cluster_backup%nat)) - allocate (cluster%xyz(3, cluster_backup%nat)) - cluster = cluster_backup - deallocate (cluster_backup%at) - deallocate (cluster_backup%xyz) - env%solv_md = .true. - call qcg_ensemble(env, solute, solvent, cluster, solvent_ensemble,& - & tim, 'solvent_ensemble') - end if - call pr_qcg_esolv() - write (*, '(2x,"|",9x,F8.2," kcal/mol ",12x,"|")') & - & full_ensemble%g - solvent_ensemble%g - (solute%energy*eh) - write (*, '(2x,''========================================='')') - call chdir(thispath) - progress = progress + 1 - end if + if (progress .le. env%qcg_runtype.and.progress .eq. 2) then !esolv + call pr_eval_solvent() + if (env%cff) then !CFF + call qcg_cff(env,solute,solvent,cluster,full_ensemble,& + & solvent_ensemble,tim) + else !Normal ensemble generation + call print_qcg_ensemble() + call cluster%deallocate + allocate (cluster%at(cluster_backup%nat)) + allocate (cluster%xyz(3,cluster_backup%nat)) + cluster = cluster_backup + deallocate (cluster_backup%at) + deallocate (cluster_backup%xyz) + env%solv_md = .true. + call qcg_ensemble(env,solute,solvent,cluster,solvent_ensemble,& + & tim,'solvent_ensemble') + end if + call pr_qcg_esolv() + write (*,'(2x,"|",9x,F8.2," kcal/mol ",12x,"|")') & + & full_ensemble%g-solvent_ensemble%g-(solute%energy*eh) + write (*,'(2x,''========================================='')') + call chdir(thispath) + progress = progress+1 + end if !------------------------------------------------------------------------------ ! Frequency computation and evaluation !------------------------------------------------------------------------------ - if (progress .le. env%qcg_runtype .and. progress .eq. 3) then !gsolv - call qcg_freq(env, tim, solute, solvent, full_ensemble, solvent_ensemble) - call qcg_eval(env, solute, full_ensemble, solvent_ensemble) + if (progress .le. env%qcg_runtype.and.progress .eq. 3) then !gsolv + call qcg_freq(env,tim,solute,solvent,full_ensemble,solvent_ensemble) + call qcg_eval(env,solute,full_ensemble,solvent_ensemble) - progress = progress + 1 - end if + progress = progress+1 + end if - !<---------------------------------- + !<---------------------------------- ! call tim%stop(2) !stop a timer !------------------------------------------------------------------------------ ! Cleanup and deallocation !------------------------------------------------------------------------------ - if (env%scratchdir .ne. 'qcg_tmp') call qcg_cleanup(env) - if (.not. env%keepModef) call rmrf('qcg_tmp') - call solute%deallocate - call solvent%deallocate - call cluster%deallocate - call full_ensemble%deallocate - call solvent_ensemble%deallocate - return + if (env%scratchdir .ne. 'qcg_tmp') call qcg_cleanup(env) + if (.not.env%keepModef) call rmrf('qcg_tmp') + call solute%deallocate + call solvent%deallocate + call cluster%deallocate + call full_ensemble%deallocate + call solvent_ensemble%deallocate + return end subroutine crest_solvtool -subroutine qcg_setup(env, solu, solv) - use iso_fortran_env, wp => real64 - use crest_data - use iomod - use zdata - use strucrd - use axis_module - implicit none - - type(systemdata):: env - type(zmolecule) :: solv, solu - - integer :: io, f, r - integer :: num_O, num_H, i - character(len=*), parameter :: outfmt = '(1x,1x,a,1x,f14.7,a,1x)' - logical :: e_there, tmp, used_tmp - character(len=512) :: thispath, tmp_grow - character(len=40) :: solv_tmp - character(len=80) :: atmp - character(len=20) :: gfnver_tmp - - call getcwd(thispath) - - ! Remove scratch dir, if present - inquire (file='./qcg_tmp/solute_properties/solute', exist=tmp) - if (tmp) call rmrf('qcg_tmp') !User given scratch dir will be removed anyway after run - - ! Make scratch directories - if (env%scratchdir .eq. '') then !check if scratch was not set - env%scratchdir = 'qcg_tmp' - io = makedir('qcg_tmp') - end if - if(env%fixfile /= 'none selected') then - call copysub(env%fixfile, env%scratchdir) - end if - call chdir(env%scratchdir) - - f = makedir('solute_properties') - if(env%fixfile /= 'none selected') then - call copysub(env%fixfile, env%scratchdir) - end if - r = makedir('solvent_properties') - - if (.not. env%nopreopt) then - write (*, *) - write (*, '(2x,''========================================='')') - write (*, '(2x,''| Preoptimization |'')') - write (*, '(2x,''========================================='')') - end if - - solv_tmp = env%solv - env%solv = '' +!==============================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< real64 + use crest_data + use iomod + use zdata + use strucrd + use axis_module + implicit none + + type(systemdata):: env + type(zmolecule) :: solv,solu + + integer :: io,f,r + integer :: num_O,num_H,i + character(len=*),parameter :: outfmt = '(1x,1x,a,1x,f14.7,a,1x)' + logical :: e_there,tmp,used_tmp + character(len=512) :: thispath,tmp_grow + character(len=40) :: solv_tmp + character(len=80) :: atmp + character(len=20) :: gfnver_tmp + + call getcwd(thispath) + + ! Remove scratch dir, if present + inquire (file='./qcg_tmp/solute_properties/solute',exist=tmp) + if (tmp) call rmrf('qcg_tmp') !User given scratch dir will be removed anyway after run + + ! Make scratch directories + if (env%scratchdir .eq. '') then !check if scratch was not set + env%scratchdir = 'qcg_tmp' + io = makedir('qcg_tmp') + end if + if (env%fixfile /= 'none selected') then + call copysub(env%fixfile,env%scratchdir) + end if + call chdir(env%scratchdir) + + f = makedir('solute_properties') + if (env%fixfile /= 'none selected') then + call copysub(env%fixfile,env%scratchdir) + end if + r = makedir('solvent_properties') + + if (.not.env%nopreopt) then + write (*,*) + write (*,'(2x,''========================================='')') + write (*,'(2x,''| Preoptimization |'')') + write (*,'(2x,''========================================='')') + end if + + solv_tmp = env%solv + env%solv = '' !---- Properties solute - call chdir('solute_properties') - call env%wrtCHRG('') !Write three lines in QCG mode, but xtb anyway only reads first one + call chdir('solute_properties') + call env%wrtCHRG('') !Write three lines in QCG mode, but xtb anyway only reads first one !---- Geometry preoptimization solute - if (env%final_gfn2_opt) then !If GFN2 final opt, solute also GFN2 optimized - gfnver_tmp = env%gfnver - env%gfnver = '--gfn2' - end if + if (env%final_gfn2_opt) then !If GFN2 final opt, solute also GFN2 optimized + gfnver_tmp = env%gfnver + env%gfnver = '--gfn2' + end if - if ((.not. env%nopreopt) .and. (solu%nat /= 1)) then - call xtb_opt_qcg(env, solu, .true.) - end if + if ((.not.env%nopreopt).and.(solu%nat /= 1)) then + call xtb_opt_qcg(env,solu,.true.) + end if !--- Axistrf - call axistrf(solu%nat, solu%nat, solu%at, solu%xyz) - call wrc0('solute', solu%nat, solu%at, solu%xyz) + call axistrf(solu%nat,solu%nat,solu%at,solu%xyz) + call wrc0('solute',solu%nat,solu%at,solu%xyz) !---- LMO/SP-Computation solute - if (env%use_xtbiff) then - write (*, *) 'Generating LMOs for solute' - call xtb_lmo(env, 'solute') - else - call xtb_sp_qcg(env, 'solute') - end if - - if (env%final_gfn2_opt) then !If GFN2 final opt, solute also GFN2 optimized - env%gfnver = gfnver_tmp - end if - - call grepval('xtb.out', '| TOTAL ENERGY', e_there, solu%energy) - if (.not. e_there) then - write (*, *) 'Total Energy of solute not found' - else - write (*, outfmt) 'Total Energy of solute: ', solu%energy, ' Eh' - end if - - if (env%use_xtbiff) then - call rename('xtblmoinfo', 'solute.lmo') - end if - - call chdir(thispath) + if (env%use_xtbiff) then + write (*,*) 'Generating LMOs for solute' + call xtb_lmo(env,'solute') + else + call xtb_sp_qcg(env,'solute') + end if + + if (env%final_gfn2_opt) then !If GFN2 final opt, solute also GFN2 optimized + env%gfnver = gfnver_tmp + end if + + call grepval('xtb.out','| TOTAL ENERGY',e_there,solu%energy) + if (.not.e_there) then + write (*,*) 'Total Energy of solute not found' + else + write (*,outfmt) 'Total Energy of solute: ',solu%energy,' Eh' + end if + + if (env%use_xtbiff) then + call rename('xtblmoinfo','solute.lmo') + end if + + call chdir(thispath) ! No constraints for solvent possible - used_tmp = env%cts%used - env%cts%used = .false. + used_tmp = env%cts%used + env%cts%used = .false. !---- Properties solvent - call chdir(env%scratchdir) - call chdir('solvent_properties') - !No charges for solvent written. This is currently not possible + call chdir(env%scratchdir) + call chdir('solvent_properties') + !No charges for solvent written. This is currently not possible !---- Geometry preoptimization solvent - if ((.not. env%nopreopt) .and. (solv%nat /= 1)) then - call xtb_opt_qcg(env, solv, .false.) - end if - call wrc0('solvent', solv%nat, solv%at, solv%xyz) + if ((.not.env%nopreopt).and.(solv%nat /= 1)) then + call xtb_opt_qcg(env,solv,.false.) + end if + call wrc0('solvent',solv%nat,solv%at,solv%xyz) !---- LMO-Computation solvent - if (env%use_xtbiff) then - write (*, *) 'Generating LMOs for solvent' - call xtb_lmo(env, 'solvent')!,solv%chrg) - else - call xtb_sp_qcg(env, 'solvent') - end if - - call grepval('xtb.out', '| TOTAL ENERGY', e_there, solv%energy) - if (.not. e_there) then - write (*, '(1x,a)') 'Total Energy of solvent not found' - else - write (*, outfmt) 'Total energy of solvent:', solv%energy, ' Eh' - end if - - if (env%use_xtbiff) then - call rename('xtblmoinfo', 'solvent.lmo') - end if - - call chdir(thispath) + if (env%use_xtbiff) then + write (*,*) 'Generating LMOs for solvent' + call xtb_lmo(env,'solvent')!,solv%chrg) + else + call xtb_sp_qcg(env,'solvent') + end if + + call grepval('xtb.out','| TOTAL ENERGY',e_there,solv%energy) + if (.not.e_there) then + write (*,'(1x,a)') 'Total Energy of solvent not found' + else + write (*,outfmt) 'Total energy of solvent:',solv%energy,' Eh' + end if + + if (env%use_xtbiff) then + call rename('xtblmoinfo','solvent.lmo') + end if + + call chdir(thispath) !---- Overwriting solute and solvent in original folder - call wrc0('solute', solu%nat, solu%at, solu%xyz) - call wrc0('solvent', solv%nat, solv%at, solv%xyz) + call wrc0('solute',solu%nat,solu%at,solu%xyz) + call wrc0('solvent',solv%nat,solv%at,solv%xyz) - num_O = 0 - num_H = 0 + num_O = 0 + num_H = 0 !--- Check, if water is solvent - if (solv%nat .eq. 3) then - do i = 1, solv%nat - if (solv%at(i) .eq. 8) num_O = num_O + 1 - if (solv%at(i) .eq. 1) num_H = num_H + 1 - end do - end if - if (num_O .eq. 1 .AND. num_H .eq. 2) then - env%water = .true. - if (.not. env%noconst) env%constrain_solu = .true. - end if + if (solv%nat .eq. 3) then + do i = 1,solv%nat + if (solv%at(i) .eq. 8) num_O = num_O+1 + if (solv%at(i) .eq. 1) num_H = num_H+1 + end do + end if + if (num_O .eq. 1.AND.num_H .eq. 2) then + env%water = .true. + if (.not.env%noconst) env%constrain_solu = .true. + end if - env%solv = solv_tmp - env%cts%used = used_tmp + env%solv = solv_tmp + env%cts%used = used_tmp end subroutine qcg_setup -subroutine read_qcg_input(env, solu, solv) - use iso_fortran_env, wp => real64 - use crest_data - use iomod - use zdata - use strucrd - use atmasses - implicit none - - type(systemdata) :: env - type(zmolecule), intent(inout) :: solu, solv - logical :: pr - real(wp), parameter :: amutokg = 1.66053886E-27 - real(wp), parameter :: third = 1.0d0/3.0d0 - integer :: i - real(wp) :: r_solu, r_solv - - pr = .true. +!==============================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< real64 + use crest_data + use iomod + use zdata + use strucrd + use atmasses + implicit none + + type(systemdata) :: env + type(zmolecule),intent(inout) :: solu,solv + logical :: pr + real(wp),parameter :: amutokg = 1.66053886E-27 + real(wp),parameter :: third = 1.0d0/3.0d0 + integer :: i + real(wp) :: r_solu,r_solv + + pr = .true. !--- Read in solu and solv coordinates and make solute and solvent file in WD - call inputcoords_qcg(env, solu, solv) + call inputcoords_qcg(env,solu,solv) !--- CMA-Trafo - call cma_shifting(solu, solv) + call cma_shifting(solu,solv) !--- Setting solute charge and uhf to input - solu%chrg = env%chrg - solu%uhf = env%uhf + solu%chrg = env%chrg + solu%uhf = env%uhf !--- Getting r, V, A - write (*, *) - write (*, *) 'Solute geometry' - call get_sphere(.true., solu, .true.) !r,V,A of solute - write (*, *) 'Solvent geometry' - call get_sphere(.true., solv, .true.) !r,V,A of solvent - - r_solu = solu%vtot**third - r_solv = solv%vtot**third - write (*, *) - write (*, '(2x,''radius of solute : '',f8.2)') r_solu - write (*, '(2x,''radius of solvent : '',f8.2)') r_solv + write (*,*) + write (*,*) 'Solute geometry' + call get_sphere(.true.,solu,.true.) !r,V,A of solute + write (*,*) 'Solvent geometry' + call get_sphere(.true.,solv,.true.) !r,V,A of solvent + + r_solu = solu%vtot**third + r_solv = solv%vtot**third + write (*,*) + write (*,'(2x,''radius of solute : '',f8.2)') r_solu + write (*,'(2x,''radius of solvent : '',f8.2)') r_solv !--- Determine masses (for later density computation) - do i = 1, solu%nat - solu%mass = solu%mass + ams(solu%at(i)) - end do - do i = 1, solv%nat - solv%mass = solv%mass + ams(solv%at(i)) - end do - solu%mass = solu%mass*amutokg - solv%mass = solv%mass*amutokg + do i = 1,solu%nat + solu%mass = solu%mass+ams(solu%at(i)) + end do + do i = 1,solv%nat + solv%mass = solv%mass+ams(solv%at(i)) + end do + solu%mass = solu%mass*amutokg + solv%mass = solv%mass*amutokg !--- If directed docking is requested, it is read in here: - if(allocated(env%directed_file)) then - if (env%use_xtbiff) error stop 'xTB-IFF does not support directed docking. & - &Please use the aISS algorithm of xtb.' - call read_directed_input(env) - end if + if (allocated(env%directed_file)) then + if (env%use_xtbiff) error stop 'xTB-IFF does not support directed docking. & + &Please use the aISS algorithm of xtb.' + call read_directed_input(env) + end if end subroutine read_qcg_input +!==============================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Read input for directed docking subroutine read_directed_input(env) - use iso_fortran_env, wp => real64 - use crest_data - implicit none - - type(systemdata) :: env - - integer :: nlines - integer :: io, ich, i, i_check - integer :: index - character(len=512) :: dum - character(len=1), parameter :: delim_space = ' ', delim_tab = achar(9) - - open (newunit=ich, file=env%directed_file) - !First check number of lines - nlines = 0 - do - read(ich,*,iostat=io) - if (io /= 0) exit - nlines = nlines + 1 - end do - !Allocate directed list - !First entry is the atom number, Second how many solvents to add to this atom - allocate(env%directed_list(nlines,2)) - allocate(env%directed_number(nlines), source = 0) - !Now read lines into directed_list - rewind(ich) - do i=1, nlines - read(ich,'(A)') dum - !> Remove leading tab and spaces first - dum = adjustl(dum) !Leading spaces are removed - index = SCAN(trim(dum), delim_tab) - if (index == 1) then !Leading tab -> remove it - dum = dum(2:) - end if - index = SCAN(trim(dum), delim_space) - if (index == 0) then !No space = check for tab - index = SCAN(trim(dum), delim_tab) - end if - if (index == 0) then !Second value is missing - write(*,'(a,1x,i0)') "No second value found in directed list on line", i - error stop - end if - env%directed_list(i, 1) = dum(1:index-1) - env%directed_list(i, 2) = dum(index+1:) - !Remove multiple spaces - env%directed_list(i, 2) = adjustl(env%directed_list(i, 2)) - !Check, if spaces are still in second argument (e.g. a third number is giveb) - index = SCAN(trim(env%directed_list(i, 2)), delim_space) - if (index == 0) index = SCAN(trim(dum), delim_tab) - if (index /= 0) then - write(*,'(a,1x,i0)') "Too many values at line", i - error stop - end if - !> Make array with which solvent molecule at which atom to add - read(env%directed_list(i,2), *, iostat=io) env%directed_number(i) - env%directed_number(i) = sum(env%directed_number) - if (io/= 0) then - write(*,'(a,1x,i0)') "Second value is no number in line", i - error stop - end if - end do - close(ich) - write(*,*) 'Performing directed docking' - do i=1, nlines - write(*,'(a,1x,a,1x,a,1x,a)') 'Docking', trim(env%directed_list(i,2)),& - & 'solvent molecules at', trim(env%directed_list(i,1)) - end do + use iso_fortran_env,wp => real64 + use crest_data + implicit none + + type(systemdata) :: env + + integer :: nlines + integer :: io,ich,i,i_check + integer :: index + character(len=512) :: dum + character(len=1),parameter :: delim_space = ' ',delim_tab = achar(9) + + open (newunit=ich,file=env%directed_file) + !First check number of lines + nlines = 0 + do + read (ich,*,iostat=io) + if (io /= 0) exit + nlines = nlines+1 + end do + !Allocate directed list + !First entry is the atom number, Second how many solvents to add to this atom + allocate (env%directed_list(nlines,2)) + allocate (env%directed_number(nlines),source=0) + !Now read lines into directed_list + rewind (ich) + do i = 1,nlines + read (ich,'(A)') dum + !> Remove leading tab and spaces first + dum = adjustl(dum) !Leading spaces are removed + index = SCAN(trim(dum),delim_tab) + if (index == 1) then !Leading tab -> remove it + dum = dum(2:) + end if + index = SCAN(trim(dum),delim_space) + if (index == 0) then !No space = check for tab + index = SCAN(trim(dum),delim_tab) + end if + if (index == 0) then !Second value is missing + write (*,'(a,1x,i0)') "No second value found in directed list on line",i + error stop + end if + env%directed_list(i,1) = dum(1:index-1) + env%directed_list(i,2) = dum(index+1:) + !Remove multiple spaces + env%directed_list(i,2) = adjustl(env%directed_list(i,2)) + !Check, if spaces are still in second argument (e.g. a third number is giveb) + index = SCAN(trim(env%directed_list(i,2)),delim_space) + if (index == 0) index = SCAN(trim(dum),delim_tab) + if (index /= 0) then + write (*,'(a,1x,i0)') "Too many values at line",i + error stop + end if + !> Make array with which solvent molecule at which atom to add + read (env%directed_list(i,2),*,iostat=io) env%directed_number(i) + env%directed_number(i) = sum(env%directed_number) + if (io /= 0) then + write (*,'(a,1x,i0)') "Second value is no number in line",i + error stop + end if + end do + close (ich) + write (*,*) 'Performing directed docking' + do i = 1,nlines + write (*,'(a,1x,a,1x,a,1x,a)') 'Docking',trim(env%directed_list(i,2)),& + & 'solvent molecules at',trim(env%directed_list(i,1)) + end do end subroutine read_directed_input +!==============================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< real64 + use strucrd,only:i2e + implicit none + + integer :: i,j + integer :: n,at(n) + real(wp) :: dum(3) + real(wp) :: rx,ry,rz + real(wp) :: xyz(3,n),r1(3) + real(wp),optional :: r2(3) + real :: x,y,z,f,rr + character(len=*) :: fname + integer :: ich11 + end subroutine both_ellipsout + end interface + + if (env%nsolv .gt. 0) then + allocate (e_each_cycle(env%nsolv)) + allocate (E_inter(env%nsolv)) + else + allocate (e_each_cycle(env%max_solv)) + allocate (E_inter(env%max_solv)) + end if -subroutine qcg_grow(env, solu, solv, clus, tim) - use crest_parameters - use crest_data - use qcg_printouts - use iomod - use zdata - use strucrd - implicit none - - type(systemdata) :: env - type(zmolecule) :: solu, solv, clus - type(timer) :: tim - - integer :: minE_pos, m - integer :: iter = 1 - integer :: i, j, io, v - integer :: max_cycle - logical :: e_there, high_e, success, neg_E - real(wp) :: etmp(500) - real(wp), allocatable :: e_each_cycle(:) - real(wp) :: dens, dum, efix - real(wp) :: e_diff = 0.0_wp - real(wp), parameter :: eh = 627.509541d0 - real(wp), allocatable :: E_inter(:) - real(wp) :: shr = 0.0_wp - real(wp) :: shr_av = 0.0_wp - real(wp) :: mean = 0.0_wp - real(wp) :: mean_old = 0.0_wp - real(wp) :: mean_diff = 0.0_wp - character(len=*), parameter :: outfmt = '(1x,1x,a,1x,f14.7,a,1x)' - character(len=512) :: thispath, resultspath - character(len=20) :: gfnver_tmp - integer :: ich99, ich15, ich88 - character(len=LEN(env%solv)) :: solv_tmp - logical :: gbsa_tmp - - interface - subroutine both_ellipsout(fname, n, at, xyz, r1, r2) - use iso_fortran_env, only: wp => real64 - use strucrd, only: i2e - implicit none - - integer :: i, j - integer :: n, at(n) - real(wp) :: dum(3) - real(wp) :: rx, ry, rz - real(wp) :: xyz(3, n), r1(3) - real(wp), optional :: r2(3) - real :: x, y, z, f, rr - character(len=*) :: fname - integer :: ich11 - end subroutine both_ellipsout - end interface - - if (env%nsolv .gt. 0) then - allocate (e_each_cycle(env%nsolv)) - allocate (E_inter(env%nsolv)) - else - allocate (e_each_cycle(env%max_solv)) - allocate (E_inter(env%max_solv)) - end if - - call tim%start(5, 'Grow') - - call pr_eval_solute() - call print_qcg_grow() - call getcwd(thispath) - io = makedir('grow') - call chdir('grow') !Results directory + call tim%start(5,'Grow') + + call pr_eval_solute() + call print_qcg_grow() + call getcwd(thispath) + io = makedir('grow') + call chdir('grow') !Results directory !--- Output Files - open (newunit=ich99, file='qcg_energy.dat') - write (ich99, '(i0,2F20.8)') 0, solu%energy, solv%energy - open (newunit=ich15, file='qcg_grow.xyz') ! for molden movie - open (newunit=ich88, file='qcg_conv.dat') ! for convergence check - write (ich88, '('' # Energy Run. Aver. Diff / au.'')') - - call getcwd(resultspath) - call chdir(thispath) - - if (env%water) then - if (.not. env%user_wscal) then - if (solu%nat .lt. 18) then - env%potscal = 0.7_wp - else - env%potscal = 0.8_wp - end if - write (*, *) - write (*, '(2x,''Water as solvent recognized,& - & adjusting scaling factor for outer wall pot to '',F4.2)')& - & env%potscal - write (*, *) + open (newunit=ich99,file='qcg_energy.dat') + write (ich99,'(i0,2F20.8)') 0,solu%energy,solv%energy + open (newunit=ich15,file='qcg_grow.xyz') ! for molden movie + open (newunit=ich88,file='qcg_conv.dat') ! for convergence check + write (ich88,'('' # Energy Run. Aver. Diff / au.'')') + + call getcwd(resultspath) + call chdir(thispath) + + if (env%water) then + if (.not.env%user_wscal) then + if (solu%nat .lt. 18) then + env%potscal = 0.7_wp + else + env%potscal = 0.8_wp end if - end if - if (env%constrain_solu) write (*, '(2x,''Constraining solute during Growth '')') - - call get_ellipsoid(env, solu, solv, clus, .true.) - call pr_grow_energy() - - call chdir(env%scratchdir) - v = makedir('tmp_grow') - if(env%fixfile /= 'none selected') then - call copysub(env%fixfile, 'tmp_grow') - end if - if (env%use_xtbiff) then - call copy('solute_properties/solute.lmo', 'tmp_grow/solute.lmo') - call copy('solvent_properties/solvent.lmo', 'tmp_grow/solvent.lmo') - end if - call chdir('tmp_grow') - call wrc0('solute', solu%nat, solu%at, solu%xyz) - call wrc0('solvent', solv%nat, solv%at, solv%xyz) - call env%wrtCHRG('') !Write .CHRG file for docking - - call ellipsout('solute_cavity.coord', clus%nat, clus%at, clus%xyz, solu%ell_abc) - solv%ell_abc = clus%ell_abc - - clus%chrg = solu%chrg - clus%uhf = solu%uhf - - if (env%nsolv .gt. 0) then - max_cycle = env%nsolv !User set number of solvents to add - else - max_cycle = env%max_solv !No solvent number set - end if + write (*,*) + write (*,'(2x,''Water as solvent recognized,& + & adjusting scaling factor for outer wall pot to '',F4.2)')& + & env%potscal + write (*,*) + end if + end if + if (env%constrain_solu) write (*,'(2x,''Constraining solute during Growth '')') + + call get_ellipsoid(env,solu,solv,clus,.true.) + call pr_grow_energy() + + call chdir(env%scratchdir) + v = makedir('tmp_grow') + if (env%fixfile /= 'none selected') then + call copysub(env%fixfile,'tmp_grow') + end if + if (env%use_xtbiff) then + call copy('solute_properties/solute.lmo','tmp_grow/solute.lmo') + call copy('solvent_properties/solvent.lmo','tmp_grow/solvent.lmo') + end if + call chdir('tmp_grow') + call wrc0('solute',solu%nat,solu%at,solu%xyz) + call wrc0('solvent',solv%nat,solv%at,solv%xyz) + call env%wrtCHRG('') !Write .CHRG file for docking + + call ellipsout('solute_cavity.coord',clus%nat,clus%at,clus%xyz,solu%ell_abc) + solv%ell_abc = clus%ell_abc + + clus%chrg = solu%chrg + clus%uhf = solu%uhf + + if (env%nsolv .gt. 0) then + max_cycle = env%nsolv !User set number of solvents to add + else + max_cycle = env%max_solv !No solvent number set + end if !-------------------------------------------------------- ! Start Loop !-------------------------------------------------------- - do iter = 1, max_cycle - e_there = .false. - success = .false. - high_e = .false. - neg_E = .false. + do iter = 1,max_cycle + e_there = .false. + success = .false. + high_e = .false. + neg_E = .false. !---- LMO-Computation - if (iter .gt. 1) then - call get_ellipsoid(env, solu, solv, clus, .false.) - if (env%use_xtbiff) then - call xtb_lmo(env, 'xtbopt.coord')!,clus%chrg) - call grepval('xtb.out', '| TOTAL ENERGY', e_there, clus%energy) - if (.not. e_there) then - write (*, '(1x,a)') 'Total Energy of cluster LMO computation not found' - end if - call rename('xtblmoinfo', 'cluster.lmo') - end if + if (iter .gt. 1) then + call get_ellipsoid(env,solu,solv,clus,.false.) + if (env%use_xtbiff) then + call xtb_lmo(env,'xtbopt.coord')!,clus%chrg) + call grepval('xtb.out','| TOTAL ENERGY',e_there,clus%energy) + if (.not.e_there) then + write (*,'(1x,a)') 'Total Energy of cluster LMO computation not found' + end if + call rename('xtblmoinfo','cluster.lmo') end if - - call both_ellipsout('twopot_1.coord', clus%nat, clus%at, clus%xyz,& - & clus%ell_abc, solu%ell_abc) - - do while (.not. success) !For restart with larger wall pot - if (iter .eq. 1) then - if (env%use_xtbiff) then - call xtb_iff(env, 'solute.lmo', 'solvent.lmo', solu, solv) - !solu for nat of core pot. solv for outer ellips - call check_iff(neg_E) - else - call xtb_dock(env, 'solute', 'solvent', solu, solv) - call check_dock(neg_E) - end if + end if + + call both_ellipsout('twopot_1.coord',clus%nat,clus%at,clus%xyz,& + & clus%ell_abc,solu%ell_abc) + + do while (.not.success) !For restart with larger wall pot + if (iter .eq. 1) then + if (env%use_xtbiff) then + call xtb_iff(env,'solute.lmo','solvent.lmo',solu,solv) + !solu for nat of core pot. solv for outer ellips + call check_iff(neg_E) + else + call xtb_dock(env,'solute','solvent',solu,solv) + call check_dock(neg_E) + end if !-- If Interaction Energy is not negativ and existent, wall pot. too small and increase - if (neg_E) then - success = .true. - else - if (env%potscal .lt. 1.0_wp) then - write (*, *) ' Wall Potential too small, increasing size by 5 %' - solv%ell_abc = solv%ell_abc*1.05_wp - env%potscal = env%potscal*1.05_wp - if (env%potscal .gt. 1.0_wp) env%potscal = 1.0_wp - write (*, '('' New scaling factor '',F4.2)') env%potscal - else - success = .true. - end if - end if - else - if (env%use_xtbiff) then - call xtb_iff(env, 'cluster.lmo', 'solvent.lmo', solu, clus) - call check_iff(neg_E) - else - call xtb_dock(env, 'cluster.coord', 'solvent', solu, clus) - call check_dock(neg_E) - end if - - if (neg_E) then - success = .true. - else - if (env%potscal .lt. 1.0_wp) then - write (*, *) ' Wall Potential too small, increasing size by 5 %' - clus%ell_abc = clus%ell_abc*1.05_wp - env%potscal = env%potscal*1.05_wp - if (env%potscal .gt. 1.0_wp) env%potscal = 1.0_wp - write (*, '('' New scaling factor '',F4.2)') env%potscal - else - success = .true. - end if - end if - end if - end do - -!--- Increase cluster size - call clus%deallocate - clus%nat = clus%nat + solv%nat - allocate (clus%at(clus%nat)) - allocate (clus%xyz(3, clus%nat)) - clus%nmol = clus%nmol + 1 - -!--- Select xtb-IFF stucture to proceed - if (env%use_xtbiff) then - call rdxtbiffE('xtbscreen.xyz', m, clus%nat, etmp) !Get energy of screening - minE_pos = minloc(etmp(1:m), dim=1) !Get minimum of those - !Read the struc into clus%xyz - call rdxmolselec('xtbscreen.xyz', minE_pos, clus%nat, clus%at, clus%xyz) + if (neg_E) then + success = .true. + else + if (env%potscal .lt. 1.0_wp) then + write (*,*) ' Wall Potential too small, increasing size by 5 %' + solv%ell_abc = solv%ell_abc*1.05_wp + env%potscal = env%potscal*1.05_wp + if (env%potscal .gt. 1.0_wp) env%potscal = 1.0_wp + write (*,'('' New scaling factor '',F4.2)') env%potscal + else + success = .true. + end if + end if else - call rdcoord('best.xyz', clus%nat, clus%at, clus%xyz, clus%energy) + if (env%use_xtbiff) then + call xtb_iff(env,'cluster.lmo','solvent.lmo',solu,clus) + call check_iff(neg_E) + else + call xtb_dock(env,'cluster.coord','solvent',solu,clus) + call check_dock(neg_E) + end if + + if (neg_E) then + success = .true. + else + if (env%potscal .lt. 1.0_wp) then + write (*,*) ' Wall Potential too small, increasing size by 5 %' + clus%ell_abc = clus%ell_abc*1.05_wp + env%potscal = env%potscal*1.05_wp + if (env%potscal .gt. 1.0_wp) env%potscal = 1.0_wp + write (*,'('' New scaling factor '',F4.2)') env%potscal + else + success = .true. + end if + end if end if + end do - call remove('cluster.coord') - call wrc0('cluster.coord', clus%nat, clus%at, clus%xyz) - call both_ellipsout('twopot_2.coord', clus%nat, clus%at, clus%xyz,& - & clus%ell_abc, solu%ell_abc) +!--- Increase cluster size + call clus%deallocate + clus%nat = clus%nat+solv%nat + allocate (clus%at(clus%nat)) + allocate (clus%xyz(3,clus%nat)) + clus%nmol = clus%nmol+1 - success = .false. +!--- Select xtb-IFF stucture to proceed + if (env%use_xtbiff) then + call rdxtbiffE('xtbscreen.xyz',m,clus%nat,etmp) !Get energy of screening + minE_pos = minloc(etmp(1:m),dim=1) !Get minimum of those + !Read the struc into clus%xyz + call rdxmolselec('xtbscreen.xyz',minE_pos,clus%nat,clus%at,clus%xyz) + else + call rdcoord('best.xyz',clus%nat,clus%at,clus%xyz,clus%energy) + end if + + call remove('cluster.coord') + call wrc0('cluster.coord',clus%nat,clus%at,clus%xyz) + call both_ellipsout('twopot_2.coord',clus%nat,clus%at,clus%xyz,& + & clus%ell_abc,solu%ell_abc) + + success = .false. !--- Cluster restart, if interaction energy not negativ (wall pot. too small) - gfnver_tmp = env%gfnver !> backup original level of theory - do while (.not. success) + gfnver_tmp = env%gfnver !> backup original level of theory + do while (.not.success) !--- Cluster optimization - if (env%cts%used) then - call write_reference(env, solu, clus) !new fixed file - end if + if (env%cts%used) then + call write_reference(env,solu,clus) !new fixed file + end if - if (env%use_xtbiff) then - call opt_cluster(env, solu, clus, 'cluster.coord', .false.) - call rdcoord('xtbopt.coord', clus%nat, clus%at, clus%xyz) - end if + if (env%use_xtbiff) then + call opt_cluster(env,solu,clus,'cluster.coord',.false.) + call rdcoord('xtbopt.coord',clus%nat,clus%at,clus%xyz) + end if !--- Interaction energy - !gfnver_tmp = env%gfnver - env%gfnver = env%lmover - gbsa_tmp = env%gbsa - solv_tmp = env%solv - env%gbsa = .false. - env%solv = '' - call get_interaction_E(env, solu, solv, clus, iter, E_inter) - env%gbsa = gbsa_tmp - env%solv = solv_tmp - if (E_inter(iter) .lt. 0) then - success = .true. - else - if (env%potscal .lt. 1.0_wp) then - write (*, *) ' Interaction Energy positiv, increasing outer wall pot by 5 %' - clus%ell_abc = clus%ell_abc*1.05_wp - env%potscal = env%potscal*1.05_wp - if (env%potscal .gt. 1.0_wp) env%potscal = 1.0_wp - write (*, '('' New scaling factor '',F4.2)') env%potscal - else - success = .true. - end if - end if - end do - env%gfnver = gfnver_tmp + !gfnver_tmp = env%gfnver + env%gfnver = env%lmover + gbsa_tmp = env%gbsa + solv_tmp = env%solv + env%gbsa = .false. + env%solv = '' + call get_interaction_E(env,solu,solv,clus,iter,E_inter) + env%gbsa = gbsa_tmp + env%solv = solv_tmp + if (E_inter(iter) .lt. 0) then + success = .true. + else + if (env%potscal .lt. 1.0_wp) then + write (*,*) ' Interaction Energy positiv, increasing outer wall pot by 5 %' + clus%ell_abc = clus%ell_abc*1.05_wp + env%potscal = env%potscal*1.05_wp + if (env%potscal .gt. 1.0_wp) env%potscal = 1.0_wp + write (*,'('' New scaling factor '',F4.2)') env%potscal + else + success = .true. + end if + end if + end do + env%gfnver = gfnver_tmp !--- For output - if (env%use_xtbiff) then - call grepval('xtb.out', '| TOTAL ENERGY', e_there, clus%energy) - call wrc0('optimized_cluster.coord', clus%nat, clus%at, clus%xyz) - if (.not. e_there) then - write (*, '(1x,a)') 'Total Energy of cluster not found.' - end if - else - !Energy already read from xyz file + if (env%use_xtbiff) then + call grepval('xtb.out','| TOTAL ENERGY',e_there,clus%energy) + call wrc0('optimized_cluster.coord',clus%nat,clus%at,clus%xyz) + if (.not.e_there) then + write (*,'(1x,a)') 'Total Energy of cluster not found.' end if - e_each_cycle(iter) = clus%energy + else + !Energy already read from xyz file + end if + e_each_cycle(iter) = clus%energy !--- Calclulate fix energy + diff. energy - efix = clus%energy/sqrt(float(clus%nat)) - dum = solu%energy - if (iter .gt. 1) dum = e_each_cycle(iter - 1) - e_diff = e_diff + eh*(e_each_cycle(iter) - solv%energy - dum) - call ellipsout('cluster_cavity.coord', clus%nat, clus%at, clus%xyz, clus%ell_abc) - call both_ellipsout('twopot_cavity.coord', clus%nat, clus%at, clus%xyz,& - & clus%ell_abc, solu%ell_abc) + efix = clus%energy/sqrt(float(clus%nat)) + dum = solu%energy + if (iter .gt. 1) dum = e_each_cycle(iter-1) + e_diff = e_diff+eh*(e_each_cycle(iter)-solv%energy-dum) + call ellipsout('cluster_cavity.coord',clus%nat,clus%at,clus%xyz,clus%ell_abc) + call both_ellipsout('twopot_cavity.coord',clus%nat,clus%at,clus%xyz,& + & clus%ell_abc,solu%ell_abc) !--- Density calculations - call get_sphere(.false., clus, .false.) !V, A of new cluster - dens = 0.001*(solu%mass + iter*solv%mass)/(1.0d-30*clus%vtot*bohr**3) + call get_sphere(.false.,clus,.false.) !V, A of new cluster + dens = 0.001*(solu%mass+iter*solv%mass)/(1.0d-30*clus%vtot*bohr**3) !--- Movie file - write (ich15, *) clus%nat - write (ich15, '('' SCF done '',2F16.8)') eh*(e_each_cycle(iter) - solv%energy - dum) - do j = 1, clus%nat - write (ich15, '(a,1x,3F24.10)') i2e(clus%at(j)), clus%xyz(1:3, j)*bohr - end do + write (ich15,*) clus%nat + write (ich15,'('' SCF done '',2F16.8)') eh*(e_each_cycle(iter)-solv%energy-dum) + do j = 1,clus%nat + write (ich15,'(a,1x,3F24.10)') i2e(clus%at(j)),clus%xyz(1:3,j)*bohr + end do !--- Output - ! dist of new mol from solute for output - call analyze_cluster(iter, clus%nat, solu%nat, solv%nat, clus%xyz, clus%at, shr_av, shr) + ! dist of new mol from solute for output + call analyze_cluster(iter,clus%nat,solu%nat,solv%nat,clus%xyz,clus%at,shr_av,shr) - write (*, '(x,i4,F13.6,1x,f7.2,3x,f8.2,6x,f6.3,3x,f8.3,3x,2f6.1,2x,f8.1,3x,a,x)') & - & iter, e_each_cycle(iter), eh*(e_each_cycle(iter) - solv%energy - dum),& - & e_diff, dens, efix, shr_av, shr, clus%vtot, trim(optlevflag(env%optlev)) - write (ich99, '(i4,F20.10,3x,f8.1)') iter, e_each_cycle(iter), clus%vtot + write (*,'(x,i4,F13.6,1x,f7.2,3x,f8.2,6x,f6.3,3x,f8.3,3x,2f6.1,2x,f8.1,3x,a,x)') & + & iter,e_each_cycle(iter),eh*(e_each_cycle(iter)-solv%energy-dum),& + & e_diff,dens,efix,shr_av,shr,clus%vtot,trim(optlevflag(env%optlev)) + write (ich99,'(i4,F20.10,3x,f8.1)') iter,e_each_cycle(iter),clus%vtot !--- Calculate moving average - mean_old = mean - do i = 0, iter - 1 - mean = mean + E_inter(iter - i) - end do - mean = mean/iter - mean_diff = mean - mean_old - write (ich88, '(i5,1x,3F13.8)') iter, E_inter(iter)*eh, mean, mean_diff + mean_old = mean + do i = 0,iter-1 + mean = mean+E_inter(iter-i) + end do + mean = mean/iter + mean_diff = mean-mean_old + write (ich88,'(i5,1x,3F13.8)') iter,E_inter(iter)*eh,mean,mean_diff !--- Check if converged when no nsolv was given - if (env%nsolv .eq. 0) then - if (abs(mean_diff) .lt. 1.0d-4 .and. iter .gt. 5) then - env%nsolv = iter - exit - end if - if (iter .eq. env%max_solv) then - write (*, '(1x,''No convergence could be reached upon adding'',1x,i4,1x,& - & ''solvent molecules.'')') env%max_solv - write (*, *) ' Proceeding.' - env%nsolv = env%max_solv - exit - end if + if (env%nsolv .eq. 0) then + if (abs(mean_diff) .lt. 1.0d-4.and.iter .gt. 5) then + env%nsolv = iter + exit + end if + if (iter .eq. env%max_solv) then + write (*,'(1x,''No convergence could be reached upon adding'',1x,i4,1x,& + & ''solvent molecules.'')') env%max_solv + write (*,*) ' Proceeding.' + env%nsolv = env%max_solv + exit end if + end if !----------------------------------------------- ! End loop !----------------------------------------------- - end do - - if (env%nsolv .eq. 0) env%nsolv = iter !if no env%solv was given - - if (env%gfnver .ne. '--gfn2' .and. env%final_gfn2_opt) then - gfnver_tmp = env%gfnver - env%gfnver = '--gfn2' - write (*, '(2x,''Final gfn2 optimization'')') - call opt_cluster(env, solu, clus, 'cluster.coord', .false.) - call rdcoord('xtbopt.coord', clus%nat, clus%at, clus%xyz) - call wrc0('cluster.coord', clus%nat, clus%at, clus%xyz) - call grepval('xtb_sp.out', '| TOTAL ENERGY', e_there, clus%energy) - if (.not. e_there) then - write (*, '(1x,a)') 'Total Energy of cluster not found.' - else - write (*, '(2x,''Total gfn2-energy of cluster/Eh:'',f20.6)') clus%energy - end if - env%gfnver = gfnver_tmp - end if + end do + + if (env%nsolv .eq. 0) env%nsolv = iter !if no env%solv was given + + if (env%gfnver .ne. '--gfn2'.and.env%final_gfn2_opt) then + gfnver_tmp = env%gfnver + env%gfnver = '--gfn2' + write (*,'(2x,''Final gfn2 optimization'')') + call opt_cluster(env,solu,clus,'cluster.coord',.false.) + call rdcoord('xtbopt.coord',clus%nat,clus%at,clus%xyz) + call wrc0('cluster.coord',clus%nat,clus%at,clus%xyz) + call grepval('xtb_sp.out','| TOTAL ENERGY',e_there,clus%energy) + if (.not.e_there) then + write (*,'(1x,a)') 'Total Energy of cluster not found.' + else + write (*,'(2x,''Total gfn2-energy of cluster/Eh:'',f20.6)') clus%energy + end if + env%gfnver = gfnver_tmp + end if - call wrxyz('cluster.xyz', clus%nat, clus%at, clus%xyz*bohr) + call wrxyz('cluster.xyz',clus%nat,clus%at,clus%xyz*bohr) !--- One optimization without Wall Potential and with implicit model - gfnver_tmp = env%gfnver - if (env%final_gfn2_opt) env%gfnver = '--gfn2' - call opt_cluster(env, solu, clus, 'cluster.xyz', .true.) - env%gfnver = gfnver_tmp - call rename('xtbopt.xyz', 'cluster_optimized.xyz') - call copysub('cluster_optimized.xyz', resultspath) + gfnver_tmp = env%gfnver + if (env%final_gfn2_opt) env%gfnver = '--gfn2' + call opt_cluster(env,solu,clus,'cluster.xyz',.true.) + env%gfnver = gfnver_tmp + call rename('xtbopt.xyz','cluster_optimized.xyz') + call copysub('cluster_optimized.xyz',resultspath) !--- output and files - write (*, *) - write (*, '(2x,''Growth finished after '',i0,'' solvents added'')') env%nsolv - write (*, '(2x,''Results can be found in grow directory'')') - write (*, '(2x,''Energy list in file '')') - write (*, '(2x,''Interaction energy in file '')') - write (*, '(2x,''Growing process in '')') - write (*, '(2x,''Final geometry after grow in and '')') - write (*, '(2x,''Final geometry optimized without wall potential in '')') - write (*, '(2x,''Potentials and geometry written in and '')') - - close (ich99) - close (ich88) - close (ich15) + write (*,*) + write (*,'(2x,''Growth finished after '',i0,'' solvents added'')') env%nsolv + write (*,'(2x,''Results can be found in grow directory'')') + write (*,'(2x,''Energy list in file '')') + write (*,'(2x,''Interaction energy in file '')') + write (*,'(2x,''Growing process in '')') + write (*,'(2x,''Final geometry after grow in and '')') + write (*,'(2x,''Final geometry optimized without wall potential in '')') + write (*,'(2x,''Potentials and geometry written in and '')') + + close (ich99) + close (ich88) + close (ich15) !--- Saving results and cleanup - call copysub('cluster.coord', resultspath) - call copysub('cluster.xyz', resultspath) - call copysub('twopot_cavity.coord', resultspath) - call copysub('cluster_cavity.coord', resultspath) - call copysub('solute_cavity.coord', resultspath) + call copysub('cluster.coord',resultspath) + call copysub('cluster.xyz',resultspath) + call copysub('twopot_cavity.coord',resultspath) + call copysub('cluster_cavity.coord',resultspath) + call copysub('solute_cavity.coord',resultspath) ! call rename('xcontrol','wall_potential') - env%constrain_solu = .false. - call write_wall(env, solu%nat, solu%ell_abc, clus%ell_abc, 'wall_potential') - call copysub('wall_potential', resultspath) + env%constrain_solu = .false. + call write_wall(env,solu%nat,solu%ell_abc,clus%ell_abc,'wall_potential') + call copysub('wall_potential',resultspath) - call chdir(thispath) - call chdir(env%scratchdir) - if (.not. env%keepModef) call rmrf('tmp_grow') + call chdir(thispath) + call chdir(env%scratchdir) + if (.not.env%keepModef) call rmrf('tmp_grow') - deallocate (e_each_cycle, E_inter) + deallocate (e_each_cycle,E_inter) - call tim%stop(5) + call tim%stop(5) end subroutine qcg_grow -subroutine qcg_ensemble(env, solu, solv, clus, ens, tim, fname_results) - use crest_parameters - use crest_data - use qcg_printouts - use iomod - use zdata - use strucrd - use utilities - use cregen_interface - implicit none - - type(systemdata) :: env - type(zmolecule) :: solu, solv, clus - type(ensemble) :: ens, dum - type(timer) :: tim - - integer :: i, j, k - integer :: io, f, r, ich,T,Tn - integer :: minpos - character(len=512) :: thispath, resultspath, tmppath, tmppath2 - character(len=512) :: scratchdir_tmp - character(len=512) :: jobcall - character(len=256) :: inpnam, outnam - character(len=80) :: fname, pipe, to - character(len=*) :: fname_results - character(len=64) :: comment - character(len=20) :: gfnver_tmp - character(len=LEN(env%solv)) :: solv_tmp - logical :: gbsa_tmp - logical :: ex, mdfail, e_there - logical :: checkiso_tmp, cbonds_tmp - real(wp), allocatable :: e_fix(:), e_clus(:) - real(wp), parameter :: eh = 627.509541d0 - real(wp) :: S, H, G, dens, shr, shr_av - real(wp) :: sasa - real(wp) :: newtemp, newmdtime, newmdstep, newhmass - real(wp) :: newmetadlist, newmetadexp, newmetadfac - real(wp) :: optlev_tmp - real(wp) :: e0 - real(wp), allocatable :: de(:) - real(wp), allocatable :: p(:) - integer :: ich98, ich65, ich48 - logical :: not_param = .false. - type(timer) :: tim_dum !Dummy timer to avoid double counting - - interface - subroutine aver(pr, env, runs, e_tot, S, H, G, sasa, a_present, a_tot) - use iso_fortran_env, only: wp => real64 - use crest_data - - implicit none - type(systemdata), intent(in) :: env - integer, intent(in) :: runs - real(wp), intent(inout) :: e_tot - real(wp), intent(in), optional :: a_tot - real(wp), intent(out) :: S - real(wp), intent(out) :: H - real(wp), intent(out) :: G - real(wp), intent(out) :: sasa - logical, intent(in) :: pr, a_present - dimension e_tot(runs) - dimension a_tot(runs) - end subroutine aver - end interface - - if (.not. env%solv_md) then - call tim%start(6, 'Solute-Ensemble') - else - call tim%start(7, 'Solvent-Ensemble') - end if - - call tim_dum%init(20) +!==============================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< real64 + use crest_data + + implicit none + type(systemdata),intent(in) :: env + integer,intent(in) :: runs + real(wp),intent(inout) :: e_tot + real(wp),intent(in),optional :: a_tot + real(wp),intent(out) :: S + real(wp),intent(out) :: H + real(wp),intent(out) :: G + real(wp),intent(out) :: sasa + logical,intent(in) :: pr,a_present + dimension e_tot(runs) + dimension a_tot(runs) + end subroutine aver + end interface + + if (.not.env%solv_md) then + call tim%start(6,'Solute-Ensemble') + else + call tim%start(7,'Solvent-Ensemble') + end if + + call tim_dum%init(20) !--- Setting up directories - call getcwd(thispath) - f = makedir(fname_results) - call chdir(fname_results) - call getcwd(resultspath) - call chdir(thispath) + call getcwd(thispath) + f = makedir(fname_results) + call chdir(fname_results) + call getcwd(resultspath) + call chdir(thispath) !--- Setting defaults - env%cts%NCI = .true. !Activating to have wall pot. written in coord file for xtb - optlev_tmp = env%optlev - env%optlev = 0.0d0 - gbsa_tmp = env%gbsa - solv_tmp = env%solv - env%gbsa = .false. - env%solv = '' + env%cts%NCI = .true. !Activating to have wall pot. written in coord file for xtb + optlev_tmp = env%optlev + env%optlev = 0.0d0 + gbsa_tmp = env%gbsa + solv_tmp = env%solv + env%gbsa = .false. + env%solv = '' !--- Setting up potential constraints - allocate (env%cts%pots(10)) - env%cts%pots = '' - write (env%cts%pots(1), '("$wall")') - write (env%cts%pots(2), '(2x,"potential=polynomial")') - write (env%cts%pots(3), '(2x,"ellipsoid:",1x,3(g0,",",1x),"all")') clus%ell_abc - if (.not. env%solv_md) write (env%cts%pots(4), '(2x,"ellipsoid:",1x,3(g0,",",1x),"1-",i0)')& - & solu%ell_abc, solu%nat - - if (env%cts%used) then - call write_reference(env, solu, clus) !new fixed file - call copysub(env%fixfile, env%scratchdir) - end if - - call chdir(env%scratchdir) - scratchdir_tmp = env%scratchdir - if (.not. env%solv_md) then - io = makedir('tmp_MTD') - call copysub('.CHRG', 'tmp_MTD') - call copysub('.UHF', 'tmp_MTD') - if (env%cts%used) call copysub(env%fixfile, 'tmp_MTD') - call chdir('tmp_MTD') - else - io = makedir('tmp_solv_MTD') - call chdir('tmp_solv_MTD') - end if - call getcwd(tmppath2) - call wrc0('crest_input', clus%nat, clus%at, clus%xyz) - - if (env%solv_md) then - call wr_cluster_cut('crest_input', solu%nat, solv%nat, env%nsolv,& - & 'solute_cut.coord', 'solvent_shell.coord') - call remove('crest_input') - call copy('solvent_shell.coord', 'crest_input') - deallocate (clus%at) - deallocate (clus%xyz) - call rdnat('solvent_shell.coord', clus%nat) - allocate (clus%at(clus%nat), clus%xyz(3, clus%nat)) - call rdcoord('solvent_shell.coord', clus%nat, clus%at, clus%xyz) - end if + allocate (env%cts%pots(10)) + env%cts%pots = '' + write (env%cts%pots(1),'("$wall")') + write (env%cts%pots(2),'(2x,"potential=polynomial")') + write (env%cts%pots(3),'(2x,"ellipsoid:",1x,3(g0,",",1x),"all")') clus%ell_abc + if (.not.env%solv_md) write (env%cts%pots(4),'(2x,"ellipsoid:",1x,3(g0,",",1x),"1-",i0)')& + & solu%ell_abc,solu%nat + + if (env%cts%used) then + call write_reference(env,solu,clus) !new fixed file + call copysub(env%fixfile,env%scratchdir) + end if + + call chdir(env%scratchdir) + scratchdir_tmp = env%scratchdir + if (.not.env%solv_md) then + io = makedir('tmp_MTD') + call copysub('.CHRG','tmp_MTD') + call copysub('.UHF','tmp_MTD') + if (env%cts%used) call copysub(env%fixfile,'tmp_MTD') + call chdir('tmp_MTD') + else + io = makedir('tmp_solv_MTD') + call chdir('tmp_solv_MTD') + end if + call getcwd(tmppath2) + call wrc0('crest_input',clus%nat,clus%at,clus%xyz) + + if (env%solv_md) then + call wr_cluster_cut('crest_input',solu%nat,solv%nat,env%nsolv,& + & 'solute_cut.coord','solvent_shell.coord') + call remove('crest_input') + call copy('solvent_shell.coord','crest_input') + deallocate (clus%at) + deallocate (clus%xyz) + call rdnat('solvent_shell.coord',clus%nat) + allocate (clus%at(clus%nat),clus%xyz(3,clus%nat)) + call rdcoord('solvent_shell.coord',clus%nat,clus%at,clus%xyz) + end if - !For newcregen: If env%crestver .eq. crest_solv .and. .not. env%QCG then conffile .eq. .true. - env%QCG = .false. - call inputcoords(env, 'crest_input') - call defaultGF(env) !Setting MTD parameter + !For newcregen: If env%crestver .eq. crest_solv .and. .not. env%QCG then conffile .eq. .true. + env%QCG = .false. + call inputcoords(env,'crest_input') + call defaultGF(env) !Setting MTD parameter !--- Special constraints for gff to safeguard stability - if (env%ensemble_opt .eq. '--gff') then - checkiso_tmp = env%checkiso - env%checkiso = .true. - cbonds_tmp = env%cts%cbonds_md - env%cts%cbonds_md = .true. - call autoBondConstraint_withEZ('coord', env%forceconst, env%wbofile) - call rd_cbonds('bondlengths', env) - end if - - gfnver_tmp = env%gfnver - write (*, *) ' Method for ensemble search:', env%ensemble_opt + if (env%ensemble_opt .eq. '--gff') then + checkiso_tmp = env%checkiso + env%checkiso = .true. + cbonds_tmp = env%cts%cbonds_md + env%cts%cbonds_md = .true. + call autoBondConstraint_withEZ('coord',env%forceconst,env%wbofile) + call rd_cbonds('bondlengths',env) + end if + + gfnver_tmp = env%gfnver + write (*,*) ' Method for ensemble search:',env%ensemble_opt ! if (env%ens_const) write(*,*) ' Solute fixed during ensemble generation' - env%gfnver = env%ensemble_opt !Setting method for ensemble search - - !---------------------------------------------------------------- - ! Case selection of normal Crest, MD or MTD - !---------------------------------------------------------------- - - select case (env%ensemble_method) - case (-1:0) !qcgmtd/Crest runtype - - !Defaults - !General settings: - if (.not. env%user_mdstep) then - if (env%ensemble_opt .EQ. '--gff') then - env%mdstep = 1.5d0 - else - env%mdstep = 5.0d0 - end if - end if - !Runtype specific settings: - if(env%ensemble_method == 0) then - if (.not. env%user_dumxyz) then - env%mddumpxyz = 200 - end if - if (.not. env%user_mdtime) then - env%mdtime = 10.0 - end if - else if(env%ensemble_method == -1) then - if (.not. env%user_dumxyz) then - env%mddumpxyz = 50 - end if - if (.not. env%user_mdtime) then - env%mdtime = 5.0 - end if - env%nmdtemp = 100 - env%MaxRestart = 6 - endif - - env%iterativeV2 = .true. !Safeguards more precise ensemble search - write (*, *) 'Starting ensemble cluster generation by CREST routine' - call confscript2i(env, tim_dum) !Calling ensemble search - call copy('crest_rotamers.xyz', 'crest_rotamers_0.xyz') - - case (1:2) ! Single MD or MTD - - !---- Setting threads - call new_ompautoset(env,'auto',1,T,Tn) - - !--- Setting new defaults for MD/MTD in qcg - if (env%mdtemp .lt. 0.0d0) then - newtemp = 400.00d0 - else if (.not. env%user_temp) then - newtemp = 298.0 - else - newtemp = env%mdtemp - end if + env%gfnver = env%ensemble_opt !Setting method for ensemble search - if (.not. env%user_mdtime) then - newmdtime = 100.0 !100.0 - else - newmdtime = env%mdtime - end if + !---------------------------------------------------------------- + ! Case selection of normal Crest, MD or MTD + !---------------------------------------------------------------- - if (.not. env%user_dumxyz) then - env%mddumpxyz = 1000 - end if + select case (env%ensemble_method) + case (-1:0) !qcgmtd/Crest runtype - if (.not. env%user_mdstep) then - if (env%ensemble_opt .ne. '--gff') then - newmdstep = 4.0d0 - else - newmdstep = 1.5d0 - end if + !Defaults + !General settings: + if (.not.env%user_mdstep) then + if (env%ensemble_opt .EQ. '--gff') then + env%mdstep = 1.5d0 else - newmdstep = env%mdstep + env%mdstep = 5.0d0 end if - - if (env%ensemble_opt .ne. '--gff') then - newhmass = 4.0 - else - newhmass = 5.0 + end if + !Runtype specific settings: + if (env%ensemble_method == 0) then + if (.not.env%user_dumxyz) then + env%mddumpxyz = 200 end if - - if (.not. allocated(env%metadfac)) then - allocate (env%metadfac(1)) - allocate (env%metadexp(1)) - allocate (env%metadlist(1)) + if (.not.env%user_mdtime) then + env%mdtime = 10.0 end if - newmetadfac = 0.02_wp - newmetadexp = 0.1_wp - newmetadlist = 10.0_wp - - fname = 'coord' - pipe = ' > xtb.out 2>/dev/null' - - !--- Writing constraining file xcontrol - !--- Providing xcontrol overwrites constraints in coord file - - open (newunit=ich, file='xcontrol') - if (env%cts%NCI) then - do i = 1, 10 - if (trim(env%cts%pots(i)) .ne. '') then - write (ich, '(a)') trim(env%cts%pots(i)) - end if - end do + else if (env%ensemble_method == -1) then + if (.not.env%user_dumxyz) then + env%mddumpxyz = 50 end if - - if (.not. env%solv_md) then - write (ich, '(a)') '$constrain' - write (ich, '(2x,a,i0)') 'atoms: 1-', solu%nat - write (ich, '(2x,a)') 'force constant=0.5' - write (ich, '(2x,a,a)') 'reference=ref.coord' + if (.not.env%user_mdtime) then + env%mdtime = 5.0 end if - - write (ich, '(a)') '$md' - write (ich, '(2x,a,f10.2)') 'hmass=', newhmass - write (ich, '(2x,a,f10.2)') 'time=', newmdtime - write (ich, '(2x,a,f10.2)') 'temp=', newtemp - write (ich, '(2x,a,f10.2)') 'step=', newmdstep - write (ich, '(2x,a,i0)') 'shake=', env%shake - write (ich, '(2x,a,i0)') 'dump=', env%mddumpxyz - write (ich, '(2x,a)') 'dumpxyz=500.0' - - if (env%ensemble_method .EQ. 2) then - write (ich, '(a)') '$metadyn' - write (ich, '(2x,a,i0,a,i0)') 'atoms: ', solu%nat + 1, '-', clus%nat - write (ich, '(2x,a,f10.2)') 'save=', newmetadlist - write (ich, '(2x,a,f10.2)') 'kpush=', newmetadfac - write (ich, '(2x,a,f10.2)') 'alp=', newmetadexp + env%nmdtemp = 100 + env%MaxRestart = 6 + end if + + env%iterativeV2 = .true. !Safeguards more precise ensemble search + write (*,*) 'Starting ensemble cluster generation by CREST routine' + call confscript2i(env,tim_dum) !Calling ensemble search + call copy('crest_rotamers.xyz','crest_rotamers_0.xyz') + + case (1:2) ! Single MD or MTD + + !---- Setting threads + call new_ompautoset(env,'auto',1,T,Tn) + + !--- Setting new defaults for MD/MTD in qcg + if (env%mdtemp .lt. 0.0d0) then + newtemp = 400.00d0 + else if (.not.env%user_temp) then + newtemp = 298.0 + else + newtemp = env%mdtemp + end if + + if (.not.env%user_mdtime) then + newmdtime = 100.0 !100.0 + else + newmdtime = env%mdtime + end if + + if (.not.env%user_dumxyz) then + env%mddumpxyz = 1000 + end if + + if (.not.env%user_mdstep) then + if (env%ensemble_opt .ne. '--gff') then + newmdstep = 4.0d0 + else + newmdstep = 1.5d0 end if - - if (env%cts%cbonds_md) call write_cts_CBONDS(ich, env%cts) - - close (ich) + else + newmdstep = env%mdstep + end if + + if (env%ensemble_opt .ne. '--gff') then + newhmass = 4.0 + else + newhmass = 5.0 + end if + + if (.not.allocated(env%metadfac)) then + allocate (env%metadfac(1)) + allocate (env%metadexp(1)) + allocate (env%metadlist(1)) + end if + newmetadfac = 0.02_wp + newmetadexp = 0.1_wp + newmetadlist = 10.0_wp + + fname = 'coord' + pipe = ' > xtb.out 2>/dev/null' + + !--- Writing constraining file xcontrol + !--- Providing xcontrol overwrites constraints in coord file + + open (newunit=ich,file='xcontrol') + if (env%cts%NCI) then + do i = 1,10 + if (trim(env%cts%pots(i)) .ne. '') then + write (ich,'(a)') trim(env%cts%pots(i)) + end if + end do + end if + + if (.not.env%solv_md) then + write (ich,'(a)') '$constrain' + write (ich,'(2x,a,i0)') 'atoms: 1-',solu%nat + write (ich,'(2x,a)') 'force constant=0.5' + write (ich,'(2x,a,a)') 'reference=ref.coord' + end if + + write (ich,'(a)') '$md' + write (ich,'(2x,a,f10.2)') 'hmass=',newhmass + write (ich,'(2x,a,f10.2)') 'time=',newmdtime + write (ich,'(2x,a,f10.2)') 'temp=',newtemp + write (ich,'(2x,a,f10.2)') 'step=',newmdstep + write (ich,'(2x,a,i0)') 'shake=',env%shake + write (ich,'(2x,a,i0)') 'dump=',env%mddumpxyz + write (ich,'(2x,a)') 'dumpxyz=500.0' + + if (env%ensemble_method .EQ. 2) then + write (ich,'(a)') '$metadyn' + write (ich,'(2x,a,i0,a,i0)') 'atoms: ',solu%nat+1,'-',clus%nat + write (ich,'(2x,a,f10.2)') 'save=',newmetadlist + write (ich,'(2x,a,f10.2)') 'kpush=',newmetadfac + write (ich,'(2x,a,f10.2)') 'alp=',newmetadexp + end if + + if (env%cts%cbonds_md) call write_cts_CBONDS(ich,env%cts) + + close (ich) !--- Writing jobcall - write (jobcall, '(a,1x,a,1x,a,'' --md --input xcontrol '',a,1x,a,a)') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), trim(env%solv), pipe + write (jobcall,'(a,1x,a,1x,a,'' --md --input xcontrol '',a,1x,a,a)') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),pipe !--- slightly different jobcall for QMDFF usage - if (env%useqmdff) then - write (jobcall, '(a,1x,a,1x,a,'' --md --input xcontrol --qmdff'',a,1x,a,a)') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), trim(env%solv), pipe - end if + if (env%useqmdff) then + write (jobcall,'(a,1x,a,1x,a,'' --md --input xcontrol --qmdff'',a,1x,a,a)') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),pipe + end if !--- MD - if (env%ensemble_method .EQ. 1) then - call normalMD(fname, env, 1, newtemp, newmdtime) - write (*, *) 'Starting MD with the settings:' - write (*, '('' MD time /ps :'',f8.1)') newmdtime - write (*, '('' MD Temperature /K :'',f8.1)') newtemp - write (*, '('' dt /fs :'',f8.1)') newmdstep - write (tmppath, '(a,i0)') 'NORMMD1' - - r = makedir(tmppath) - call copysub('xcontrol', tmppath) - call chdir(tmppath) - call copy('coord', 'ref.coord') - call chdir(tmppath2) - - call command('cd '//trim(tmppath)//' && '//trim(jobcall), io) - - inquire (file=trim(tmppath)//'/'//'xtb.trj', exist=ex) - if (.not. ex .or. io .ne. 0) then - write (*, '(a,i0,a)') '*Warning: MD seemingly failed (no xtb.trj)*' - else - write (*, *) '*MD finished*' - end if - - if (env%trackorigin) then - call set_trj_origins('NORMMD', 'md') - end if - call chdir('NORMMD1') - end if + if (env%ensemble_method .EQ. 1) then + call normalMD(fname,env,1,newtemp,newmdtime) + write (*,*) 'Starting MD with the settings:' + write (*,'('' MD time /ps :'',f8.1)') newmdtime + write (*,'('' MD Temperature /K :'',f8.1)') newtemp + write (*,'('' dt /fs :'',f8.1)') newmdstep + write (tmppath,'(a,i0)') 'NORMMD1' + + r = makedir(tmppath) + call copysub('xcontrol',tmppath) + call chdir(tmppath) + call copy('coord','ref.coord') + call chdir(tmppath2) -!--- MTD + call command('cd '//trim(tmppath)//' && '//trim(jobcall),io) - if (env%ensemble_method .EQ. 2) then - call MetaMD(env, 1, newmdtime, env%metadfac(1), env%metadexp(1), & - & env%metadlist(1)) - write (*, '(a,i4,a)') 'Starting Meta-MD with the settings:' - write (*, '('' MTD time /ps :'',f8.1)') newmdtime - write (*, '('' dt /fs :'',f8.1)') newmdstep - write (*, '('' MTD Temperature /K :'',f8.1)') newtemp - write (*, '('' dumpstep(trj) /fs :'',i8)') env%mddumpxyz - write (*, '('' Vbias factor k /Eh :'',f8.4)') newmetadfac - write (*, '('' Vbias exp α /bohr⁻²:'',f8.2)') newmetadexp + inquire (file=trim(tmppath)//'/'//'xtb.trj',exist=ex) + if (.not.ex.or.io .ne. 0) then + write (*,'(a,i0,a)') '*Warning: MD seemingly failed (no xtb.trj)*' + else + write (*,*) '*MD finished*' + end if - write (tmppath, '(a,i0)') 'METADYN1' - r = makedir(tmppath) - call copysub('xcontrol', tmppath) - call chdir(tmppath) - call copy('coord', 'ref.coord') + if (env%trackorigin) then + call set_trj_origins('NORMMD','md') + end if + call chdir('NORMMD1') + end if - call chdir(tmppath2) +!--- MTD - call command('cd '//trim(tmppath)//' && '//trim(jobcall), io) + if (env%ensemble_method .EQ. 2) then + call MetaMD(env,1,newmdtime,env%metadfac(1),env%metadexp(1), & + & env%metadlist(1)) + write (*,'(a,i4,a)') 'Starting Meta-MD with the settings:' + write (*,'('' MTD time /ps :'',f8.1)') newmdtime + write (*,'('' dt /fs :'',f8.1)') newmdstep + write (*,'('' MTD Temperature /K :'',f8.1)') newtemp + write (*,'('' dumpstep(trj) /fs :'',i8)') env%mddumpxyz + write (*,'('' Vbias factor k /Eh :'',f8.4)') newmetadfac + write (*,'('' Vbias exp α /bohr⁻²:'',f8.2)') newmetadexp + + write (tmppath,'(a,i0)') 'METADYN1' + r = makedir(tmppath) + call copysub('xcontrol',tmppath) + call chdir(tmppath) + call copy('coord','ref.coord') - inquire (file=trim(tmppath)//'/'//'xtb.trj', exist=ex) - if (.not. ex .or. io .ne. 0) then - write (*, '(a,i0,a)') '*Warning: Meta-MTD seemingly failed (no xtb.trj)*' - else - write (*, *) '*MTD finished*' - end if + call chdir(tmppath2) - if (env%trackorigin) then - call set_trj_origins('METADYN', 'mtd') - end if + call command('cd '//trim(tmppath)//' && '//trim(jobcall),io) - call chdir('METADYN1') + inquire (file=trim(tmppath)//'/'//'xtb.trj',exist=ex) + if (.not.ex.or.io .ne. 0) then + write (*,'(a,i0,a)') '*Warning: Meta-MTD seemingly failed (no xtb.trj)*' + else + write (*,*) '*MTD finished*' + end if + if (env%trackorigin) then + call set_trj_origins('METADYN','mtd') end if - call rename('xtb.trj', 'crest_rotamers_0.xyz') - call copysub('crest_rotamers_0.xyz', tmppath2) - call dum%open('crest_rotamers_0.xyz') + call chdir('METADYN1') + + end if + + call rename('xtb.trj','crest_rotamers_0.xyz') + call copysub('crest_rotamers_0.xyz',tmppath2) + call dum%open('crest_rotamers_0.xyz') !--- M(T)D stability check - call minigrep('xtb.out', 'M(T)D is unstable, emergency exit', mdfail) - if (dum%nall .eq. 1) then - call copysub('xtb.out', resultspath) - write (*, *) 'ERROR : M(T)D results only in one structure' - if (mdfail) then - write (*, *) ' It was unstable' - else - write (*, *) ' The M(T)D time step might be too large or the M(T)D time too short.' - end if - call copysub('xtb.out', resultspath) - error stop ' Please check the xtb.out file in the ensemble folder' - end if + call minigrep('xtb.out','M(T)D is unstable, emergency exit',mdfail) + if (dum%nall .eq. 1) then + call copysub('xtb.out',resultspath) + write (*,*) 'ERROR : M(T)D results only in one structure' if (mdfail) then - write (*, *) - write (*, *) ' WARNING: The M(T)D was unstable.' - write (*, *) ' Please check the xtb.out file in the ensemble folder.' - write (*, *) - call copysub('xtb.out', resultspath) + write (*,*) ' It was unstable' + else + write (*,*) ' The M(T)D time step might be too large or the M(T)D time too short.' end if - call dum%deallocate - call chdir(tmppath2) - call wrc0('coord', clus%nat, clus%at, clus%xyz) - call inputcoords(env, 'coord') !Necessary + call copysub('xtb.out',resultspath) + error stop ' Please check the xtb.out file in the ensemble folder' + end if + if (mdfail) then + write (*,*) + write (*,*) ' WARNING: The M(T)D was unstable.' + write (*,*) ' Please check the xtb.out file in the ensemble folder.' + write (*,*) + call copysub('xtb.out',resultspath) + end if + call dum%deallocate + call chdir(tmppath2) + call wrc0('coord',clus%nat,clus%at,clus%xyz) + call inputcoords(env,'coord') !Necessary !--- Optimization - call print_qcg_opt - !if (env%gfnver .eq. '--gfn2') - call multilevel_opt(env, 99) + call print_qcg_opt + !if (env%gfnver .eq. '--gfn2') + call multilevel_opt(env,99) - end select + end select - env%QCG = .true. + env%QCG = .true. !--- Optimization with gfn2 if necessary - if (env%final_gfn2_opt) then - gfnver_tmp = env%gfnver + if (env%final_gfn2_opt) then + gfnver_tmp = env%gfnver ! if (env%gfnver .ne. '--gfn2') then - write (*, '(2x,a)') 'GFN2-xTB optimization' - env%gfnver = '--gfn2' - call rmrf('OPTIM') - call multilevel_opt(env, 99) - end if + write (*,'(2x,a)') 'GFN2-xTB optimization' + env%gfnver = '--gfn2' + call rmrf('OPTIM') + call multilevel_opt(env,99) + end if !--- Final optimization without potentials - call rmrf('OPTIM') - env%optlev = 1.0d0 !Higher precision for less scattering - env%cts%NCI = .false. !Dactivating the wall pot. - env%cts%pots = '' - deallocate (env%cts%pots) - call multilevel_opt(env, 99) + call rmrf('OPTIM') + env%optlev = 1.0d0 !Higher precision for less scattering + env%cts%NCI = .false. !Dactivating the wall pot. + env%cts%pots = '' + deallocate (env%cts%pots) + call multilevel_opt(env,99) !Clustering to exclude similar structures if requested with -cluster if (env%properties == 70) then - write(*,'(3x,''Clustering the remaining structures'')') + write (*,'(3x,''Clustering the remaining structures'')') call checkname_xyz(crefile,inpnam,outnam) - call ccegen(env, .false. , inpnam) + call ccegen(env,.false.,inpnam) call move(trim(clusterfile),trim(outnam)) end if !--- Energy sorting and removal of dublicates - env%gbsa = gbsa_tmp - env%solv = solv_tmp - call newcregen(env, 0) - call checkname_xyz(crefile, inpnam, outnam) - call copy(inpnam, 'ensemble.xyz') - call ens%open('ensemble.xyz') !Read in ensemble - call clus%deallocate() - clus%nat = ens%nat - allocate (clus%at(clus%nat)) - allocate (clus%xyz(3, clus%nat)) + env%gbsa = gbsa_tmp + env%solv = solv_tmp + call newcregen(env,0) + call checkname_xyz(crefile,inpnam,outnam) + call copy(inpnam,'ensemble.xyz') + call ens%open('ensemble.xyz') !Read in ensemble + call clus%deallocate() + clus%nat = ens%nat + allocate (clus%at(clus%nat)) + allocate (clus%xyz(3,clus%nat)) !------------------------------------------------------------- ! SP with GBSA model and without wall potentials !------------------------------------------------------------- - !--- Write folder with xyz-coordinates - do i = 1, ens%nall - call rdxmolselec('ensemble.xyz', i, clus%nat, clus%at, clus%xyz) - write (to, '("TMPSP",i0)') i - io = makedir(trim(to)) - call copysub('.UHF', to) - call copysub('.CHRG', to) - call chdir(to) - call wrxyz('cluster.xyz', clus%nat, clus%at, clus%xyz*bohr) - call chdir(tmppath2) - end do - !--- SP - write (*, *) - call ens_sp(env, 'cluster.xyz', ens%nall, 'TMPSP') - !--- Getting energy - do i = 1, ens%nall - call rdxmolselec('ensemble.xyz', i, clus%nat, clus%at, clus%xyz) - write (to, '("TMPSP",i0)') i - call chdir(to) - call grepval('xtb_sp.out', '| TOTAL ENERGY', e_there, ens%er(i)) - call chdir(tmppath2) - end do - - if (.not. e_there) then - write (*, *) - write (*, *) 'Energy not found. Error in xTB computations occured' - call chdir(to) - call minigrep('xtb_sp.out', 'solv_model_loadInternalParam', not_param) - call chdir(tmppath2) - if (not_param) then - write (*, *) ' !!!WARNIG: CHOSEN SOLVENT NOT PARAMETERIZED & - & FOR IMPLICIT SOLVATION MODEL!!!' - write (*, '('' CHECK IF '',A,'' IS AVAILABLE IN xTB'')') env%solv - write (*, *) ' PLEASE RESTART THE ENSEMBLE GENERATION WITH AVAILABLE& - & PARAMETERIZATION IF YOU NEED ENERGIES' - call copysub('crest_conformers.xyz', resultspath) - write (*, *) ' The enesemble can be found in the directory& - & as ' - error stop - end if - end if + !--- Write folder with xyz-coordinates + do i = 1,ens%nall + call rdxmolselec('ensemble.xyz',i,clus%nat,clus%at,clus%xyz) + write (to,'("TMPSP",i0)') i + io = makedir(trim(to)) + call copysub('.UHF',to) + call copysub('.CHRG',to) + call chdir(to) + call wrxyz('cluster.xyz',clus%nat,clus%at,clus%xyz*bohr) + call chdir(tmppath2) + end do + !--- SP + write (*,*) + call ens_sp(env,'cluster.xyz',ens%nall,'TMPSP') + !--- Getting energy + do i = 1,ens%nall + call rdxmolselec('ensemble.xyz',i,clus%nat,clus%at,clus%xyz) + write (to,'("TMPSP",i0)') i + call chdir(to) + call grepval('xtb_sp.out','| TOTAL ENERGY',e_there,ens%er(i)) + call chdir(tmppath2) + end do + + if (.not.e_there) then + write (*,*) + write (*,*) 'Energy not found. Error in xTB computations occured' + call chdir(to) + call minigrep('xtb_sp.out','solv_model_loadInternalParam',not_param) + call chdir(tmppath2) + if (not_param) then + write (*,*) ' !!!WARNIG: CHOSEN SOLVENT NOT PARAMETERIZED & + & FOR IMPLICIT SOLVATION MODEL!!!' + write (*,'('' CHECK IF '',A,'' IS AVAILABLE IN xTB'')') env%solv + write (*,*) ' PLEASE RESTART THE ENSEMBLE GENERATION WITH AVAILABLE& + & PARAMETERIZATION IF YOU NEED ENERGIES' + call copysub('crest_conformers.xyz',resultspath) + write (*,*) ' The enesemble can be found in the directory& + & as ' + error stop + end if + end if - env%gfnver = gfnver_tmp - call ens%write('full_ensemble.xyz') + env%gfnver = gfnver_tmp + call ens%write('full_ensemble.xyz') !--- crest_best structure - minpos = minloc(ens%er, dim=1) - write (to, '("TMPSP",i0)') minpos - call chdir(to) - call rdxmol('cluster.xyz', clus%nat, clus%at, clus%xyz) - call chdir(tmppath2) - write (comment, '(F20.8)') ens%er(minpos) - inquire (file='crest_best.xyz', exist=ex) - if (ex) then - call rmrf('crest_best.xyz') !remove crest_best from - end if - call wrxyz('crest_best.xyz', clus%nat, clus%at, clus%xyz, comment) + minpos = minloc(ens%er,dim=1) + write (to,'("TMPSP",i0)') minpos + call chdir(to) + call rdxmol('cluster.xyz',clus%nat,clus%at,clus%xyz) + call chdir(tmppath2) + write (comment,'(F20.8)') ens%er(minpos) + inquire (file='crest_best.xyz',exist=ex) + if (ex) then + call rmrf('crest_best.xyz') !remove crest_best from + end if + call wrxyz('crest_best.xyz',clus%nat,clus%at,clus%xyz,comment) !------------------------------------------------------------- ! Processing results !------------------------------------------------------------- - allocate (e_fix(ens%nall)) - allocate (e_clus(ens%nall)) + allocate (e_fix(ens%nall)) + allocate (e_clus(ens%nall)) - call pr_ensemble_energy() + call pr_ensemble_energy() - open (newunit=ich98, file='cluster_energy.dat') - write (ich98, '(3x,''#'',9x,''Energy [Eh]'',6x,''SASA'')') + open (newunit=ich98,file='cluster_energy.dat') + write (ich98,'(3x,''#'',9x,''Energy [Eh]'',6x,''SASA'')') !--- Fixation energy of optimization - do i = 1, ens%nall - call chdir('OPTIM') - write (to, '("TMPCONF",i0)') i - call chdir(to) - call grepval('xtb.out', ' :: add. restraining', e_there, e_fix(i)) - call chdir(tmppath2) - - call rdxmolselec('full_ensemble.xyz', i, clus%nat, clus%at, clus%xyz) - call get_sphere(.false., clus, .false.) - dens = 0.001*(solu%mass + env%nsolv*solv%mass)/(1.0d-30*clus%vtot*bohr**3) - if (env%solv_md) then - call analyze_cluster(env%nsolv - 1, clus%nat, solv%nat, solv%nat, clus%xyz, clus%at, shr_av, shr) - else - call analyze_cluster(env%nsolv, clus%nat, solu%nat, solv%nat, clus%xyz, clus%at, shr_av, shr) - end if - write (ich98, '(i4,F20.10,3x,f8.1)') env%nsolv, ens%er(i), clus%atot - write (*, '(x,i4,4x,F13.6,2x,f6.3,1x,f8.3,2x,2f6.1,3x,f8.1,3x,a)') & - & i, ens%er(i), dens, e_fix(i), shr_av, shr, clus%atot, trim(optlevflag(env%optlev)) - e_fix(i) = e_fix(i)*eh/sqrt(float(clus%nat)) - end do - close (ich98) - call copysub('cluster_energy.dat', resultspath) + do i = 1,ens%nall + call chdir('OPTIM') + write (to,'("TMPCONF",i0)') i + call chdir(to) + call grepval('xtb.out',' :: add. restraining',e_there,e_fix(i)) + call chdir(tmppath2) + + call rdxmolselec('full_ensemble.xyz',i,clus%nat,clus%at,clus%xyz) + call get_sphere(.false.,clus,.false.) + dens = 0.001*(solu%mass+env%nsolv*solv%mass)/(1.0d-30*clus%vtot*bohr**3) + if (env%solv_md) then + call analyze_cluster(env%nsolv-1,clus%nat,solv%nat,solv%nat,clus%xyz,clus%at,shr_av,shr) + else + call analyze_cluster(env%nsolv,clus%nat,solu%nat,solv%nat,clus%xyz,clus%at,shr_av,shr) + end if + write (ich98,'(i4,F20.10,3x,f8.1)') env%nsolv,ens%er(i),clus%atot + write (*,'(x,i4,4x,F13.6,2x,f6.3,1x,f8.3,2x,2f6.1,3x,f8.1,3x,a)') & + & i,ens%er(i),dens,e_fix(i),shr_av,shr,clus%atot,trim(optlevflag(env%optlev)) + e_fix(i) = e_fix(i)*eh/sqrt(float(clus%nat)) + end do + close (ich98) + call copysub('cluster_energy.dat',resultspath) !--- Checking Boltzmann weighting - write (*, *) - call remove('full_ensemble.xyz') - call sort_ensemble(ens, ens%er, 'full_ensemble.xyz') - e_clus = ens%er*eh - call sort_min(ens%nall, 1, 1, e_clus) - ens%er = e_clus/eh !Overwrite ensemble energy with sorted one - allocate (de(ens%nall), source=0.0d0) - allocate (p(ens%nall), source=0.0d0) - e0 = e_clus(1) - de(1:ens%nall) = (e_clus(1:ens%nall) - e0) - call qcg_boltz(env, ens%nall, de, p) - k = 0 - if (.not. env%user_nclust) env%nqcgclust = 0 !Needed for solvent ensemble - if (env%nqcgclust .eq. 0) then - do i = 1, ens%nall !Count how many are above 10% - if ((p(i)) .gt. 0.1) then - k = k + 1 - end if - end do - if ((k .eq. 0) .or. (k .gt. 10)) then - k = 10 !If too many structures are relevant, set it 10 - else if ((k .lt. 4) .and. (ens%nall .ge. 4)) then - k = 4 !If too less structures are relevant, set it 4 - else if (ens%nall .gt. 0) then - k=ens%nall - else - error stop 'No structure left. Something went wrong.' + write (*,*) + call remove('full_ensemble.xyz') + call sort_ensemble(ens,ens%er,'full_ensemble.xyz') + e_clus = ens%er*eh + call sort_min(ens%nall,1,1,e_clus) + ens%er = e_clus/eh !Overwrite ensemble energy with sorted one + allocate (de(ens%nall),source=0.0d0) + allocate (p(ens%nall),source=0.0d0) + e0 = e_clus(1) + de(1:ens%nall) = (e_clus(1:ens%nall)-e0) + call qcg_boltz(env,ens%nall,de,p) + k = 0 + if (.not.env%user_nclust) env%nqcgclust = 0 !Needed for solvent ensemble + if (env%nqcgclust .eq. 0) then + do i = 1,ens%nall !Count how many are above 10% + if ((p(i)) .gt. 0.1) then + k = k+1 end if - write (*, '(2x,a,1x,i0)') 'Conformers taken:', k - env%nqcgclust = k - else - if (env%nqcgclust .gt. ens%nall) then - k = ens%nall !Input larger than remaining structures - write (*, '(''Less than '',1x,i0,1x,''structures remain'')') env%nqcgclust - write (*, '(''Only '',1x,i0,1x,''structures are taken'')') ens%nall - if (env%cff) env%nqcgclust = ens%nall !Only for CFF, else a second qcg_ensemble run starts for solvent + end do + if ((k .eq. 0).or.(k .gt. 10)) then + k = 10 !If too many structures are relevant, set it 10 + else if ((k .lt. 4).and.(ens%nall .ge. 4)) then + k = 4 !If too less structures are relevant, set it 4 + else if (ens%nall .gt. 0) then + k = ens%nall + else + error stop 'No structure left. Something went wrong.' + end if + write (*,'(2x,a,1x,i0)') 'Conformers taken:',k + env%nqcgclust = k + else + if (env%nqcgclust .gt. ens%nall) then + k = ens%nall !Input larger than remaining structures + write (*,'(''Less than '',1x,i0,1x,''structures remain'')') env%nqcgclust + write (*,'(''Only '',1x,i0,1x,''structures are taken'')') ens%nall + if (env%cff) env%nqcgclust = ens%nall !Only for CFF, else a second qcg_ensemble run starts for solvent + else + write (*,'(''Taking '',1x,i0,1x,''structures'')') env%nqcgclust + k = env%nqcgclust !user input + end if + end if + + open (newunit=ich65,file='final_ensemble.xyz') + do i = 1,k + open (newunit=ich48,file='full_population.dat') + write (ich48,'(2x, ''cluster'',2x,''E_norm [Eh]'',2x, ''De [kcal]'', 4x, ''p'')') + do j = 1,ens%nall + if (j .lt. 10) then + write (ich48,'(5x,i0,3x,f11.6,5x,f6.4,3x,f6.4)') j,e_clus(j)/eh,de(j),p(j) else - write (*, '(''Taking '',1x,i0,1x,''structures'')') env%nqcgclust - k = env%nqcgclust !user input + write (ich48,'(5x,i0,2x,f11.6,5x,f6.4,3x,f6.4)') j,e_clus(j)/eh,de(j),p(j) end if - end if - - open (newunit=ich65, file='final_ensemble.xyz') - do i = 1, k - open (newunit=ich48, file='full_population.dat') - write (ich48, '(2x, ''cluster'',2x,''E_norm [Eh]'',2x, ''De [kcal]'', 4x, ''p'')') - do j = 1, ens%nall - if (j .lt. 10) then - write (ich48, '(5x,i0,3x,f11.6,5x,f6.4,3x,f6.4)') j, e_clus(j)/eh, de(j), p(j) - else - write (ich48, '(5x,i0,2x,f11.6,5x,f6.4,3x,f6.4)') j, e_clus(j)/eh, de(j), p(j) - end if - end do - close (ich48) + end do + close (ich48) !--- Take k energetic least structures (written at beginning of file) - call rdxmolselec('full_ensemble.xyz', i, clus%nat, clus%at, clus%xyz) - call wrxyz(ich65, clus%nat, clus%at, clus%xyz*bohr, ens%er(i)) - end do - close (ich65) + call rdxmolselec('full_ensemble.xyz',i,clus%nat,clus%at,clus%xyz) + call wrxyz(ich65,clus%nat,clus%at,clus%xyz*bohr,ens%er(i)) + end do + close (ich65) - call ens%deallocate() - call ens%open('final_ensemble.xyz') - ens%er = e_clus(1:k)/eh + call ens%deallocate() + call ens%open('final_ensemble.xyz') + ens%er = e_clus(1:k)/eh !--- Getting G,S,H - write (*, *) - write (*, '(2x,''------------------------------------------------------------------------'')') - write (*, '(2x,''------------------------------------------------------------------------'')') - write (*, '(2x,''Boltz. averaged energy of final cluster:'')') - call aver(.true., env, ens%nall, e_clus(1:ens%nall), S, H, G, sasa, .false.) - write (*, '(7x,''G /Eh :'',F14.8)') G/eh - write (*, '(7x,''T*S /kcal :'',f8.3)') S + write (*,*) + write (*,'(2x,''------------------------------------------------------------------------'')') + write (*,'(2x,''------------------------------------------------------------------------'')') + write (*,'(2x,''Boltz. averaged energy of final cluster:'')') + call aver(.true.,env,ens%nall,e_clus(1:ens%nall),S,H,G,sasa,.false.) + write (*,'(7x,''G /Eh :'',F14.8)') G/eh + write (*,'(7x,''T*S /kcal :'',f8.3)') S - ens%g = G - ens%s = S + ens%g = G + ens%s = S - deallocate (e_fix) - deallocate (e_clus) + deallocate (e_fix) + deallocate (e_clus) !---Folder management - call rename('cregen.out.tmp', 'thermo_data') - call copysub('thermo_data', resultspath) - call copysub('crest_best.xyz', resultspath) - call copysub('cre_members.out', resultspath) - call copysub('full_ensemble.xyz', resultspath) - call copysub('final_ensemble.xyz', resultspath) - call copysub('population.dat', resultspath) - call copysub('full_population.dat', resultspath) + call rename('cregen.out.tmp','thermo_data') + call copysub('thermo_data',resultspath) + call copysub('crest_best.xyz',resultspath) + call copysub('cre_members.out',resultspath) + call copysub('full_ensemble.xyz',resultspath) + call copysub('final_ensemble.xyz',resultspath) + call copysub('population.dat',resultspath) + call copysub('full_population.dat',resultspath) !---Deleting ensemble tmp - call chdir(thispath) - call chdir(env%scratchdir) - if (.not. env%keepModef) call rmrf(tmppath2) + call chdir(thispath) + call chdir(env%scratchdir) + if (.not.env%keepModef) call rmrf(tmppath2) !----Outprint - write (*, *) - write (*, '(2x,''Ensemble generation finished.'')') - write (*, '(2x,''Results can be found in ensemble directory'')') - write (*, '(2x,''Lowest energy conformer in file '')') - write (*, '(2x,''List of full ensemble in file '')') - write (*, '(2x,''List of used ensemble in file '')') - write (*, '(2x,''Thermodynamical data in file '')') - write (*, '(2x,''Population of full ensemble in file '')') - write (*, '(2x,''Population in file '')') - - env%gfnver = gfnver_tmp - env%optlev = optlev_tmp - if (env%ensemble_opt .eq. '--gff') then - env%cts%cbonds_md = cbonds_tmp - env%checkiso = checkiso_tmp - end if - - call tim_dum%clear - - if (.not. env%solv_md) then - call tim%stop(6) - else - call tim%stop(7) - end if + write (*,*) + write (*,'(2x,''Ensemble generation finished.'')') + write (*,'(2x,''Results can be found in ensemble directory'')') + write (*,'(2x,''Lowest energy conformer in file '')') + write (*,'(2x,''List of full ensemble in file '')') + write (*,'(2x,''List of used ensemble in file '')') + write (*,'(2x,''Thermodynamical data in file '')') + write (*,'(2x,''Population of full ensemble in file '')') + write (*,'(2x,''Population in file '')') + + env%gfnver = gfnver_tmp + env%optlev = optlev_tmp + if (env%ensemble_opt .eq. '--gff') then + env%cts%cbonds_md = cbonds_tmp + env%checkiso = checkiso_tmp + end if + + call tim_dum%clear + + if (.not.env%solv_md) then + call tim%stop(6) + else + call tim%stop(7) + end if end subroutine qcg_ensemble -subroutine qcg_cff(env, solu, solv, clus, ens, solv_ens, tim) - use crest_parameters - use crest_data - use qcg_printouts - use iomod - use zdata - use strucrd - - implicit none - - type(systemdata) :: env - type(timer) :: tim - type(zmolecule) :: solu, solv, clus - type(ensemble) :: solv_ens - type(ensemble), intent(in) :: ens - - integer :: i, j, k, iter - integer :: io, r - integer :: nsolv, n_ini - integer :: ipos, dum - integer :: v_ratio - integer :: minE_pos, m, nat_tot - integer :: nat_frag1 !number of atoms larger fragment (=solvent shell) - integer :: conv(env%nqcgclust + 1) - integer :: solv_added, minpos - character(len=512) :: thispath, resultspath, tmppath, tmppath2 - character(len=64) :: fname_lmo1, fname_lmo2, comment - character(len=20) :: to - real(wp), allocatable :: e_empty(:), inner_ell_abc(:, :) - real(wp), allocatable :: outer_ell_abc(:, :) - real(wp), allocatable :: e_cur(:, :) - real(wp) :: e_cluster(env%nqcgclust) - real(wp), parameter :: eh = 627.509541d0 - real(wp) :: S, H, G - real(wp) :: sasa, tmp_optlev - real(wp) :: etmp(500) - real(wp) :: e_fix(env%nqcgclust), e_norm(env%nqcgclust) - real(wp) :: dum_e, de - real(wp) :: de_tot(env%nqcgclust) - real(wp) :: shr = 0 - real(wp) :: shr_av = 0 - real(wp) :: dens, atotS - logical :: ex, skip, e_there - logical :: all_converged - logical, allocatable :: converged(:), nothing_added(:) - - character(len=20) :: gfnver_tmp - real(wp) :: optlev_tmp - integer :: ich98, ich31 - - interface - subroutine aver(pr, env, runs, e_tot, S, H, G, sasa, a_present, a_tot) - use iso_fortran_env, only: wp => real64 - use crest_data - - implicit none - type(systemdata), intent(in) :: env - integer, intent(in) :: runs - real(wp), intent(inout) :: e_tot - real(wp), intent(in), optional :: a_tot - real(wp), intent(out) :: S - real(wp), intent(out) :: H - real(wp), intent(out) :: G - real(wp), intent(out) :: sasa - logical, intent(in) :: pr, a_present - dimension e_tot(runs) - dimension a_tot(runs) - end subroutine aver - end interface - - call tim%start(8, 'CFF') - - allocate (e_empty(env%nqcgclust)) - allocate (converged(env%nqcgclust)) - allocate (nothing_added(env%nqcgclust)) - allocate (outer_ell_abc(env%nqcgclust, 3)) - allocate (inner_ell_abc(env%nqcgclust, 3)) - - v_ratio = nint(solu%vtot/solv%vtot) - allocate (e_cur(env%nsolv + v_ratio, env%nqcgclust), source=0.0d0) +!==============================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< real64 + use crest_data + + implicit none + type(systemdata),intent(in) :: env + integer,intent(in) :: runs + real(wp),intent(inout) :: e_tot + real(wp),intent(in),optional :: a_tot + real(wp),intent(out) :: S + real(wp),intent(out) :: H + real(wp),intent(out) :: G + real(wp),intent(out) :: sasa + logical,intent(in) :: pr,a_present + dimension e_tot(runs) + dimension a_tot(runs) + end subroutine aver + end interface + + call tim%start(8,'CFF') + + allocate (e_empty(env%nqcgclust)) + allocate (converged(env%nqcgclust)) + allocate (nothing_added(env%nqcgclust)) + allocate (outer_ell_abc(env%nqcgclust,3)) + allocate (inner_ell_abc(env%nqcgclust,3)) + + v_ratio = nint(solu%vtot/solv%vtot) + allocate (e_cur(env%nsolv+v_ratio,env%nqcgclust),source=0.0d0) !--- Setting defaults (same as ensemble optimization to have comparable structures) - optlev_tmp = env%optlev - env%optlev = 1.0d0 !Increaseing percision for ensemble search to minimze scattering - gfnver_tmp = env%gfnver - if (env%final_gfn2_opt) then - env%gfnver = '--gfn2' - else - env%gfnver = env%ensemble_opt !CFF always with ensemble method - end if - nothing_added = .false. - - dum = 0 - converged = .false. - all_converged = .false. - nat_tot = clus%nat - solu%nat!*env%nqcgclust - - if (solu%vtot/solv%vtot .lt. 1.0d0) then - skip = .true. - else - skip = .false. - end if + optlev_tmp = env%optlev + env%optlev = 1.0d0 !Increaseing percision for ensemble search to minimze scattering + gfnver_tmp = env%gfnver + if (env%final_gfn2_opt) then + env%gfnver = '--gfn2' + else + env%gfnver = env%ensemble_opt !CFF always with ensemble method + end if + nothing_added = .false. -!--- Folder management - call getcwd(thispath) - r = makedir('solvent_ensemble') - call chdir('solvent_ensemble') - call getcwd(resultspath) - call chdir(thispath) - call chdir(env%scratchdir) - call getcwd(tmppath) - io = makedir('tmp_CFF') - call chdir('tmp_CFF') - call getcwd(tmppath2) - call chdir(tmppath) - call chdir('solvent_properties') - if (env%use_xtbiff) then - call copysub('solvent.lmo', tmppath2) - else - call copysub('solvent', tmppath2) - end if - call chdir(tmppath2) + dum = 0 + converged = .false. + all_converged = .false. + nat_tot = clus%nat-solu%nat!*env%nqcgclust -!--- SP of each cluster - call ens%write('ensemble.xyz') - do i = 1, env%nqcgclust - call rdxmolselec('ensemble.xyz', i, clus%nat, clus%at, clus%xyz) - clus%nmol = clus%nat/solv%nat - write (to, '("TMPCFF",i0)') i - io = makedir(trim(to)) - if (env%use_xtbiff) then - call copysub('solvent.lmo', to) - else - call copysub('solvent', to) - end if - call chdir(to) - call wrc0('cluster.coord', clus%nat, clus%at, clus%xyz) - call wr_cluster_cut('cluster.coord', solu%nat, solv%nat, env%nsolv, 'solute_cut.coord', 'solvent_shell.coord') - call xtb_sp_qcg(env, 'solvent_shell.coord') - call grepval('xtb.out', '| TOTAL ENERGY', ex, e_empty(i)) - call copy('solvent_shell.coord', 'solvent_cluster.coord') - call copy('solvent_cluster.coord', 'filled_cluster.coord') - call get_ellipsoid(env, solu, solv, clus, .false.) !solu, to have same cavity to fill solvent in - outer_ell_abc(i, 1:3) = clus%ell_abc(1:3) - inner_ell_abc(i, 1:3) = solu%ell_abc(1:3) - call chdir(tmppath2) - end do + if (solu%vtot/solv%vtot .lt. 1.0d0) then + skip = .true. + else + skip = .false. + end if - if (skip) write (*, '(2x,''solute smaller than solvent, cff skipped'')') +!--- Folder management + call getcwd(thispath) + r = makedir('solvent_ensemble') + call chdir('solvent_ensemble') + call getcwd(resultspath) + call chdir(thispath) + call chdir(env%scratchdir) + call getcwd(tmppath) + io = makedir('tmp_CFF') + call chdir('tmp_CFF') + call getcwd(tmppath2) + call chdir(tmppath) + call chdir('solvent_properties') + if (env%use_xtbiff) then + call copysub('solvent.lmo',tmppath2) + else + call copysub('solvent',tmppath2) + end if + call chdir(tmppath2) - clus%nat = clus%nat - solu%nat - n_ini = clus%nat +!--- SP of each cluster + call ens%write('ensemble.xyz') + do i = 1,env%nqcgclust + call rdxmolselec('ensemble.xyz',i,clus%nat,clus%at,clus%xyz) + clus%nmol = clus%nat/solv%nat + write (to,'("TMPCFF",i0)') i + io = makedir(trim(to)) + if (env%use_xtbiff) then + call copysub('solvent.lmo',to) + else + call copysub('solvent',to) + end if + call chdir(to) + call wrc0('cluster.coord',clus%nat,clus%at,clus%xyz) + call wr_cluster_cut('cluster.coord',solu%nat,solv%nat,env%nsolv,'solute_cut.coord','solvent_shell.coord') + call xtb_sp_qcg(env,'solvent_shell.coord') + call grepval('xtb.out','| TOTAL ENERGY',ex,e_empty(i)) + call copy('solvent_shell.coord','solvent_cluster.coord') + call copy('solvent_cluster.coord','filled_cluster.coord') + call get_ellipsoid(env,solu,solv,clus,.false.) !solu, to have same cavity to fill solvent in + outer_ell_abc(i,1:3) = clus%ell_abc(1:3) + inner_ell_abc(i,1:3) = solu%ell_abc(1:3) + call chdir(tmppath2) + end do + + if (skip) write (*,'(2x,''solute smaller than solvent, cff skipped'')') + + clus%nat = clus%nat-solu%nat + n_ini = clus%nat !--- If solvent molecules are added - if (.not. skip) then - call pr_qcg_fill() - write (*, '(2x,''now adding solvents to fill cluster...'')') - call pr_fill_energy() - write (*, '(2x,''------------------------------------------------------------------------'')') - nat_frag1 = env%nsolv*solv%nat - - iter = 0 + if (.not.skip) then + call pr_qcg_fill() + write (*,'(2x,''now adding solvents to fill cluster...'')') + call pr_fill_energy() + write (*,'(2x,''------------------------------------------------------------------------'')') + nat_frag1 = env%nsolv*solv%nat + + iter = 0 !--- Main cycle for addition of solvent molecules - convergence: do while (.not. all_converged) - k = 0 - iter = iter + 1 - !--- Setting array, with only numbers of dirs that are not converged - do i = 1, env%nqcgclust - if (.not. converged(i)) then - k = k + 1 - conv(k) = i - conv(env%nqcgclust + 1) = k !How many jobs are open - else - cycle - end if - end do - conv(k + 1:env%nqcgclust) = 0 - - if (env%use_xtbiff) then + convergence: do while (.not.all_converged) + k = 0 + iter = iter+1 + !--- Setting array, with only numbers of dirs that are not converged + do i = 1,env%nqcgclust + if (.not.converged(i)) then + k = k+1 + conv(k) = i + conv(env%nqcgclust+1) = k !How many jobs are open + else + cycle + end if + end do + conv(k+1:env%nqcgclust) = 0 + + if (env%use_xtbiff) then !----------- LMO computation for solvent cluster--------------------------------------------------- - call ensemble_lmo(env, 'solvent_cluster.coord', solv, conv(env%nqcgclust + 1),& - & 'TMPCFF', conv) + call ensemble_lmo(env,'solvent_cluster.coord',solv,conv(env%nqcgclust+1),& + & 'TMPCFF',conv) !-------------------------------------------------------------------------------------------------- - do i = 1, env%nqcgclust - if (.not. converged(i)) then - write (to, '("TMPCFF",i0)') i - call chdir(to) - call rename('xtblmoinfo', 'solvent_cluster.lmo') - call chdir(tmppath2) - else - cycle - end if - end do - end if + do i = 1,env%nqcgclust + if (.not.converged(i)) then + write (to,'("TMPCFF",i0)') i + call chdir(to) + call rename('xtblmoinfo','solvent_cluster.lmo') + call chdir(tmppath2) + else + cycle + end if + end do + end if - call chdir(tmppath2) + call chdir(tmppath2) - fname_lmo1 = 'solvent_cluster.lmo' - fname_lmo2 = 'solvent.lmo' + fname_lmo1 = 'solvent_cluster.lmo' + fname_lmo2 = 'solvent.lmo' !--- Solvent addition to the cluster--------------------------------------------- - if (env%use_xtbiff) then - call ensemble_iff(env, outer_ell_abc, nat_frag1, fname_lmo1, fname_lmo2,& - &conv(env%nqcgclust + 1), 'TMPCFF', conv) - else - call ensemble_dock(env, outer_ell_abc, nat_frag1, 'solvent_cluster.coord',& - &'solvent', clus%nat, solv%nat, conv(env%nqcgclust + 1), 'TMPCFF', conv) - end if + if (env%use_xtbiff) then + call ensemble_iff(env,outer_ell_abc,nat_frag1,fname_lmo1,fname_lmo2,& + &conv(env%nqcgclust+1),'TMPCFF',conv) + else + call ensemble_dock(env,outer_ell_abc,nat_frag1,'solvent_cluster.coord',& + &'solvent',clus%nat,solv%nat,conv(env%nqcgclust+1),'TMPCFF',conv) + end if !-------------------------------------------------------------------------------- - nat_frag1 = nat_frag1 + solv%nat - - !--- Increase cluster size - deallocate (clus%at) - deallocate (clus%xyz) - clus%nat = clus%nat + solv%nat - allocate (clus%at(clus%nat)) - allocate (clus%xyz(3, clus%nat)) - clus%nmol = clus%nmol + 1 - - do i = 1, env%nqcgclust - if (.not. converged(i)) then - write (to, '("TMPCFF",i0)') i - call chdir(to) - call remove('xtbrestart') - call remove('xcontrol') - - if (env%use_xtbiff) then - !--- Select xtb-IFF stucture to proceed - call rdxtbiffE('xtbscreen.xyz', m, clus%nat, etmp) !Get energy of screening - minE_pos = minloc(etmp(1:m), dim=1) !Get minimum of those - call rdxmolselec('xtbscreen.xyz', minE_pos, clus%nat, clus%at, clus%xyz) !Read the struc into clus%xyz - call wrc0('solvent_cluster.coord', clus%nat, clus%at, clus%xyz) - else - call rdcoord('best.xyz', clus%nat, clus%at, clus%xyz, e_cur(iter, i)) - call wrc0('solvent_cluster.coord', clus%nat, clus%at, clus%xyz) - end if - - !--- Check if converged - call fill_take(env, solv%nat, clus%nat, inner_ell_abc(i, 1:3), ipos) - if (ipos .eq. 0) then - converged(i) = .true. - write (*, '(2x,''no more solvents can be placed inside cavity of cluster: '',i0)') i - write (*, '(2x,''previous cluster taken...'')') - if (iter .eq. 1) nothing_added(i) = .true. - end if - call chdir(tmppath2) - - else - cycle - end if - end do + nat_frag1 = nat_frag1+solv%nat + + !--- Increase cluster size + deallocate (clus%at) + deallocate (clus%xyz) + clus%nat = clus%nat+solv%nat + allocate (clus%at(clus%nat)) + allocate (clus%xyz(3,clus%nat)) + clus%nmol = clus%nmol+1 + + do i = 1,env%nqcgclust + if (.not.converged(i)) then + write (to,'("TMPCFF",i0)') i + call chdir(to) + call remove('xtbrestart') + call remove('xcontrol') + + if (env%use_xtbiff) then + !--- Select xtb-IFF stucture to proceed + call rdxtbiffE('xtbscreen.xyz',m,clus%nat,etmp) !Get energy of screening + minE_pos = minloc(etmp(1:m),dim=1) !Get minimum of those + call rdxmolselec('xtbscreen.xyz',minE_pos,clus%nat,clus%at,clus%xyz) !Read the struc into clus%xyz + call wrc0('solvent_cluster.coord',clus%nat,clus%at,clus%xyz) + else + call rdcoord('best.xyz',clus%nat,clus%at,clus%xyz,e_cur(iter,i)) + call wrc0('solvent_cluster.coord',clus%nat,clus%at,clus%xyz) + end if + + !--- Check if converged + call fill_take(env,solv%nat,clus%nat,inner_ell_abc(i,1:3),ipos) + if (ipos .eq. 0) then + converged(i) = .true. + write (*,'(2x,''no more solvents can be placed inside cavity of cluster: '',i0)') i + write (*,'(2x,''previous cluster taken...'')') + if (iter .eq. 1) nothing_added(i) = .true. + end if + call chdir(tmppath2) + + else + cycle + end if + end do !--- Check, if a structure was converged and iff was not necessary - k = 0 - do i = 1, env%nqcgclust - if (.not. converged(i)) then - k = k + 1 - conv(k) = i - conv(env%nqcgclust + 1) = k !How many jobs are open - else - cycle - end if - end do - conv(k + 1:env%nqcgclust) = 0 + k = 0 + do i = 1,env%nqcgclust + if (.not.converged(i)) then + k = k+1 + conv(k) = i + conv(env%nqcgclust+1) = k !How many jobs are open + else + cycle + end if + end do + conv(k+1:env%nqcgclust) = 0 ! if(env%use_xtbiff) then !--- Parallel optimization------------------------------------------------------------------- - call cff_opt(.false., env, 'solvent_cluster.coord', n_ini, conv(env%nqcgclust + 1)& - &, 'TMPCFF', conv, nothing_added) + call cff_opt(.false.,env,'solvent_cluster.coord',n_ini,conv(env%nqcgclust+1)& + &,'TMPCFF',conv,nothing_added) !---------------------------------------------------------------------------------------------- ! end if - do i = 1, env%nqcgclust - if (.not. converged(i)) then - write (to, '("TMPCFF",i0)') i - call chdir(to) - if (env%use_xtbiff) then - call copy('xtbopt.coord', 'solvent_cluster.coord') - call grepval('xtb_sp.out', '| TOTAL ENERGY', e_there, e_cur(iter, i)) - end if - dum_e = e_empty(i) - if (iter - nsolv .gt. 1) dum_e = e_cur(iter - 1, i) - de = eh*(e_cur(iter, i) - solv%energy - dum_e) - de_tot(i) = de_tot(i) + de - !---- Check if solvent added is repulsive - if (de .gt. 0) then - converged(i) = .true. - write (*, '(2x,''adding solvent is repulsive for cluster: '',i0)') i - write (*, '(2x,''previous cluster taken...'')') - if (iter .eq. 1) nothing_added(i) = .true. - else !Only if the addition was not repulsive - call copy('solvent_cluster.coord', 'filled_cluster.coord') - write (*, '(i4,5x,i3,1x,F13.6,3x,f7.2,5x,f7.2,4x,a)') & - & iter + env%nsolv, i, e_cur(iter, i), de, de_tot(i),& - & trim(optlevflag(env%optlev)) - end if - call chdir(tmppath2) - end if - end do - - !--- Check if everything is converged - dum = 0 - do i = 1, env%nqcgclust - if (converged(1)) then - dum = dum + 1 - end if - end do - - if (dum .eq. env%nqcgclust) then - all_converged = .true. - else - nat_tot = nat_tot + solv%nat - end if - - write (*, '(2x,''------------------------------------------------------------------------'')') - !--- Or if maximum solvent is added - if (iter - nsolv .eq. v_ratio) then - write (*, '(2x,''volume filled'')') - all_converged = .true. - call copy('solvent_cluster.coord', 'filled_cluster.coord') - end if - - end do convergence - - end if - - !Now in every TMPPath the final cluster file filled_cluster.coord is present + do i = 1,env%nqcgclust + if (.not.converged(i)) then + write (to,'("TMPCFF",i0)') i + call chdir(to) + if (env%use_xtbiff) then + call copy('xtbopt.coord','solvent_cluster.coord') + call grepval('xtb_sp.out','| TOTAL ENERGY',e_there,e_cur(iter,i)) + end if + dum_e = e_empty(i) + if (iter-nsolv .gt. 1) dum_e = e_cur(iter-1,i) + de = eh*(e_cur(iter,i)-solv%energy-dum_e) + de_tot(i) = de_tot(i)+de + !---- Check if solvent added is repulsive + if (de .gt. 0) then + converged(i) = .true. + write (*,'(2x,''adding solvent is repulsive for cluster: '',i0)') i + write (*,'(2x,''previous cluster taken...'')') + if (iter .eq. 1) nothing_added(i) = .true. + else !Only if the addition was not repulsive + call copy('solvent_cluster.coord','filled_cluster.coord') + write (*,'(i4,5x,i3,1x,F13.6,3x,f7.2,5x,f7.2,4x,a)') & + & iter+env%nsolv,i,e_cur(iter,i),de,de_tot(i),& + & trim(optlevflag(env%optlev)) + end if + call chdir(tmppath2) + end if + end do + + !--- Check if everything is converged + dum = 0 + do i = 1,env%nqcgclust + if (converged(1)) then + dum = dum+1 + end if + end do + + if (dum .eq. env%nqcgclust) then + all_converged = .true. + else + nat_tot = nat_tot+solv%nat + end if + + write (*,'(2x,''------------------------------------------------------------------------'')') + !--- Or if maximum solvent is added + if (iter-nsolv .eq. v_ratio) then + write (*,'(2x,''volume filled'')') + all_converged = .true. + call copy('solvent_cluster.coord','filled_cluster.coord') + end if + + end do convergence + + end if + + !Now in every TMPPath the final cluster file filled_cluster.coord is present !--------------------------------------------------------------------- ! Final Optimization !--------------------------------------------------------------------- - tmp_optlev = env%optlev - if (env%optlev .lt. 1.0) env%optlev = 1.0d0 !higher accuracy - - if (.not. skip) then - call cff_opt(.true., env, 'filled_cluster.coord', n_ini, conv(env%nqcgclust + 1),& - & 'TMPCFF', conv, nothing_added) - else - n_ini = 0 !If this is 0, no constraining will be done (optimization of total system) - nothing_added = .true. - call cff_opt(.true., env, 'filled_cluster.coord', n_ini, env%nqcgclust, 'TMPCFF',& - & conv, nothing_added) - end if - env%optlev = tmp_optlev + tmp_optlev = env%optlev + if (env%optlev .lt. 1.0) env%optlev = 1.0d0 !higher accuracy + + if (.not.skip) then + call cff_opt(.true.,env,'filled_cluster.coord',n_ini,conv(env%nqcgclust+1),& + & 'TMPCFF',conv,nothing_added) + else + n_ini = 0 !If this is 0, no constraining will be done (optimization of total system) + nothing_added = .true. + call cff_opt(.true.,env,'filled_cluster.coord',n_ini,env%nqcgclust,'TMPCFF',& + & conv,nothing_added) + end if + env%optlev = tmp_optlev - call pr_ensemble_energy() + call pr_ensemble_energy() - solv_ens%nall = env%nqcgclust - solv_ens%nat = nat_tot + solv_ens%nall = env%nqcgclust + solv_ens%nat = nat_tot !--- Getting results-------------------------------------------------------------- - open (newunit=ich31, file='crest_rotamers_0.xyz') - open (newunit=ich98, file='cluster_energy.dat') - write (ich98, '(3x,''#'',11x,''Energy [Eh]'',6x,''SASA'')') + open (newunit=ich31,file='crest_rotamers_0.xyz') + open (newunit=ich98,file='cluster_energy.dat') + write (ich98,'(3x,''#'',11x,''Energy [Eh]'',6x,''SASA'')') - do i = 1, env%nqcgclust - write (to, '("TMPCFF",i0)') i - call chdir(to) - call copy('xtbopt.coord', 'final_cluster.coord') + do i = 1,env%nqcgclust + write (to,'("TMPCFF",i0)') i + call chdir(to) + call copy('xtbopt.coord','final_cluster.coord') !--- Reading structure - call clus%deallocate() - call rdnat('final_cluster.coord', clus%nat) - allocate (clus%at(clus%nat), clus%xyz(3, clus%nat)) - call rdcoord('final_cluster.coord', clus%nat, clus%at, clus%xyz) + call clus%deallocate() + call rdnat('final_cluster.coord',clus%nat) + allocate (clus%at(clus%nat),clus%xyz(3,clus%nat)) + call rdcoord('final_cluster.coord',clus%nat,clus%at,clus%xyz) !--- Getting energy and calculating properties - call grepval('xtb_sp.out', '| TOTAL ENERGY', e_there, e_cluster(i)) - call grepval('xtb_sp.out', ' :: add. restraining', e_there, e_fix(i)) - e_fix(i) = e_fix(i)*eh/sqrt(float(clus%nat)) - call get_sphere(.false., clus, .false.) - if (clus%nat .gt. n_ini) then - solv_added = (clus%nat - (n_ini))/solv%nat - else - solv_added = 0 - end if - dens = 0.001*((clus%nat/solv%nat)*solv%mass)/(1.0d-30*clus%vtot*bohr**3) - call analyze_cluster(solv_added, clus%nat, n_ini, solv%nat, clus%xyz, clus%at, shr_av, shr) - e_norm(i) = e_cluster(i)*env%nsolv/(clus%nat/solv%nat) - atotS = clus%atot*env%nsolv/(clus%nat/solv%nat) + call grepval('xtb_sp.out','| TOTAL ENERGY',e_there,e_cluster(i)) + call grepval('xtb_sp.out',' :: add. restraining',e_there,e_fix(i)) + e_fix(i) = e_fix(i)*eh/sqrt(float(clus%nat)) + call get_sphere(.false.,clus,.false.) + if (clus%nat .gt. n_ini) then + solv_added = (clus%nat-(n_ini))/solv%nat + else + solv_added = 0 + end if + dens = 0.001*((clus%nat/solv%nat)*solv%mass)/(1.0d-30*clus%vtot*bohr**3) + call analyze_cluster(solv_added,clus%nat,n_ini,solv%nat,clus%xyz,clus%at,shr_av,shr) + e_norm(i) = e_cluster(i)*env%nsolv/(clus%nat/solv%nat) + atotS = clus%atot*env%nsolv/(clus%nat/solv%nat) !--- Writing outputfiles - write (ich31, '(2x,i0)') clus%nat - write (ich31, '(2x,f18.8,2x,a)') e_cluster(i) - do j = 1, clus%nat - write (ich31, '(1x,a2,1x,3f20.10)') i2e(clus%at(j), 'nc'), clus%xyz(1:3, j)*bohr - end do + write (ich31,'(2x,i0)') clus%nat + write (ich31,'(2x,f18.8,2x,a)') e_cluster(i) + do j = 1,clus%nat + write (ich31,'(1x,a2,1x,3f20.10)') i2e(clus%at(j),'nc'),clus%xyz(1:3,j)*bohr + end do - write (ich98, '(''No'',i4,F20.10,3x,f8.1)') i, e_norm(i), atotS + write (ich98,'(''No'',i4,F20.10,3x,f8.1)') i,e_norm(i),atotS !--- Print to screen - write (*, '(x,i4,4x,F13.6,2x,f6.3,1x,f8.3,2x,2f6.1,3x,f8.1,3x,a)') & - & i, e_norm(i), dens, e_fix(i), shr_av, shr, atotS, trim(optlevflag(env%optlev)) + write (*,'(x,i4,4x,F13.6,2x,f6.3,1x,f8.3,2x,2f6.1,3x,f8.1,3x,a)') & + & i,e_norm(i),dens,e_fix(i),shr_av,shr,atotS,trim(optlevflag(env%optlev)) - call chdir(tmppath2) - end do + call chdir(tmppath2) + end do - close (ich98) - close (ich31) + close (ich98) + close (ich31) - call solv_ens%deallocate() - call solv_ens%open('crest_rotamers_0.xyz') + call solv_ens%deallocate() + call solv_ens%open('crest_rotamers_0.xyz') - solv_ens%er = e_cluster - call copy('crest_rotamers_0.xyz', 'crest_ensemble.xyz') + solv_ens%er = e_cluster + call copy('crest_rotamers_0.xyz','crest_ensemble.xyz') !--- crest_best structure - minpos = minloc(solv_ens%er, dim=1) - write (to, '("TMPCFF",i0)') minpos - call chdir(to) - call clus%deallocate - call rdnat('final_cluster.coord', clus%nat) - allocate (clus%at(clus%nat), clus%xyz(3, clus%nat)) - call rdcoord('final_cluster.coord', clus%nat, clus%at, clus%xyz) - clus%xyz = clus%xyz*bohr - call chdir(tmppath2) - write (comment, '(F20.8)') solv_ens%er(minpos) - call wrxyz('crest_best.xyz', clus%nat, clus%at, clus%xyz, comment) + minpos = minloc(solv_ens%er,dim=1) + write (to,'("TMPCFF",i0)') minpos + call chdir(to) + call clus%deallocate + call rdnat('final_cluster.coord',clus%nat) + allocate (clus%at(clus%nat),clus%xyz(3,clus%nat)) + call rdcoord('final_cluster.coord',clus%nat,clus%at,clus%xyz) + clus%xyz = clus%xyz*bohr + call chdir(tmppath2) + write (comment,'(F20.8)') solv_ens%er(minpos) + call wrxyz('crest_best.xyz',clus%nat,clus%at,clus%xyz,comment) !--- Boltz. average------------------------------------------------------------------------- - write (*, *) - write (*, '(2x,''------------------------------------------------------------------------'')') - write (*, '(2x,''------------------------------------------------------------------------'')') - write (*, '(2x,''Boltz. averaged energy of final cluster:'')') - e_cluster = solv_ens%er*eh - e_norm = e_norm*eh - call sort_min(env%nqcgclust, 1, 1, e_norm) - call aver(.true., env, solv_ens%nall, e_norm(1:env%nqcgclust), S, H, G, sasa, .false.) - write (*, '(7x,''G /Eh :'',F14.8)') G/eh - write (*, '(7x,''T*S /kcal :'',f8.3)') S - solv_ens%er = e_norm/eh !normalized energy needed for final evaluation - - solv_ens%g = G - solv_ens%s = S + write (*,*) + write (*,'(2x,''------------------------------------------------------------------------'')') + write (*,'(2x,''------------------------------------------------------------------------'')') + write (*,'(2x,''Boltz. averaged energy of final cluster:'')') + e_cluster = solv_ens%er*eh + e_norm = e_norm*eh + call sort_min(env%nqcgclust,1,1,e_norm) + call aver(.true.,env,solv_ens%nall,e_norm(1:env%nqcgclust),S,H,G,sasa,.false.) + write (*,'(7x,''G /Eh :'',F14.8)') G/eh + write (*,'(7x,''T*S /kcal :'',f8.3)') S + solv_ens%er = e_norm/eh !normalized energy needed for final evaluation + + solv_ens%g = G + solv_ens%s = S !--- Cleanup - call copysub('crest_ensemble.xyz', resultspath) - call copysub('cluster_energy.dat', resultspath) - call copysub('crest_best.xyz', resultspath) - call copysub('population.dat', resultspath) - call chdir(tmppath) - if (.not. env%keepModef) call rmrf('tmp_CFF') - call chdir(thispath) + call copysub('crest_ensemble.xyz',resultspath) + call copysub('cluster_energy.dat',resultspath) + call copysub('crest_best.xyz',resultspath) + call copysub('population.dat',resultspath) + call chdir(tmppath) + if (.not.env%keepModef) call rmrf('tmp_CFF') + call chdir(thispath) !--- Printouts - write (*, *) - write (*, '(2x,''Solvent cluster generation finished.'')') - write (*, '(2x,''Results can be found in solvent_cluster directory'')') - write (*, '(2x,''Structures in file '')') - write (*, '(2x,''Energies in file '')') - write (*, '(2x,''Population in file '')') + write (*,*) + write (*,'(2x,''Solvent cluster generation finished.'')') + write (*,'(2x,''Results can be found in solvent_cluster directory'')') + write (*,'(2x,''Structures in file '')') + write (*,'(2x,''Energies in file '')') + write (*,'(2x,''Population in file '')') - env%gfnver = gfnver_tmp - env%optlev = optlev_tmp + env%gfnver = gfnver_tmp + env%optlev = optlev_tmp - deallocate (e_empty) - deallocate (converged) - deallocate (outer_ell_abc) - deallocate (inner_ell_abc) + deallocate (e_empty) + deallocate (converged) + deallocate (outer_ell_abc) + deallocate (inner_ell_abc) - call tim%stop(8) + call tim%stop(8) end subroutine qcg_cff -subroutine qcg_freq(env, tim, solu, solv, solu_ens, solv_ens) - use crest_parameters - use crest_data - use qcg_printouts - use iomod - use zdata - use strucrd - - implicit none - - type(systemdata) :: env - type(timer) :: tim - type(zmolecule) :: solu, solv, clus - type(ensemble) :: solu_ens, solv_ens - - integer :: r, io, f, g, h - integer :: i - character(len=512) :: thispath, resultspath, tmppath, tmppath2 - character(len=80) :: to - character(len=20) :: gfnver_tmp - real(wp) :: optlev_tmp - real(wp) :: gt(3) - real(wp) :: ht(3) - real(wp) :: svib(3) - real(wp) :: srot(3) - real(wp) :: stra(3) - integer :: ich65, ich56, ich33, ich81 - logical :: opt - - call tim%start(9, 'Frequencies') - - call pr_qcg_freq() +!==============================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Frequency calculation - opt = .true. - call ens_freq(env, 'cluster.xyz', solu_ens%nall, 'TMPFREQ', opt) - call chdir(tmppath2) + opt = .true. + call ens_freq(env,'cluster.xyz',solu_ens%nall,'TMPFREQ',opt) + call chdir(tmppath2) + + write (*,*) ' SOLVENT CLUSTER' + if (env%cff) then + call chdir('tmp_solv') + call ens_freq(env,'solvent_cut.coord',solu_ens%nall,'TMPFREQ',opt) + call chdir(tmppath2) + end if - write (*, *) ' SOLVENT CLUSTER' - if (env%cff) then - call chdir('tmp_solv') - call ens_freq(env, 'solvent_cut.coord', solu_ens%nall, 'TMPFREQ', opt) - call chdir(tmppath2) - end if + call clus%deallocate() - call clus%deallocate() + !--- Frequencies solvent cluster (only, if not cff was used) + if (.not.env%cff) then + call chdir('tmp_solv') + call solv_ens%write('solvent_ensemble.xyz') - !--- Frequencies solvent cluster (only, if not cff was used) - if (.not. env%cff) then + do i = 1,solv_ens%nall + write (to,'("TMPFREQ",i0)') i + io = makedir(trim(to)) + call copysub('.UHF',to) + call copysub('.CHRG',to) + call chdir(to) + open (newunit=ich65,file='solv_cluster.xyz') + call wrxyz(ich65,solv_ens%nat,solv_ens%at,solv_ens%xyz(:,:,i)) + close (ich65) + call chdir(tmppath2) call chdir('tmp_solv') - call solv_ens%write('solvent_ensemble.xyz') - - do i = 1, solv_ens%nall - write (to, '("TMPFREQ",i0)') i - io = makedir(trim(to)) - call copysub('.UHF', to) - call copysub('.CHRG', to) - call chdir(to) - open (newunit=ich65, file='solv_cluster.xyz') - call wrxyz(ich65, solv_ens%nat, solv_ens%at, solv_ens%xyz(:, :, i)) - close (ich65) - call chdir(tmppath2) - call chdir('tmp_solv') - end do + end do !> Frequency calculation - call ens_freq(env, 'solv_cluster.xyz', solv_ens%nall, 'TMPFREQ', opt) - call chdir(tmppath2) - end if + call ens_freq(env,'solv_cluster.xyz',solv_ens%nall,'TMPFREQ',opt) + call chdir(tmppath2) + end if !---------------------------------------------------------------------------- ! Data read out !---------------------------------------------------------------------------- !--- Solute in gas phase - write (*, *) - write (*, *) ' Solute Gas properties' - call pr_freq_energy() - open (newunit=ich56, file='solute.dat') - call pr_freq_file(ich56) - write (*, '(2x,5f10.2)') ht(3), svib(3), srot(3), stra(3), gt(3) - write (ich56, '(2x,5f10.2)') ht(3), svib(3), srot(3), stra(3), gt(3) - close (ich56) + write (*,*) + write (*,*) ' Solute Gas properties' + call pr_freq_energy() + open (newunit=ich56,file='solute.dat') + call pr_freq_file(ich56) + write (*,'(2x,5f10.2)') ht(3),svib(3),srot(3),stra(3),gt(3) + write (ich56,'(2x,5f10.2)') ht(3),svib(3),srot(3),stra(3),gt(3) + close (ich56) !--- Solute cluster - write (*, *) - write (*, *) ' Solute cluster properties' - open (newunit=ich33, file='solute_cluster.dat') - - call chdir('tmp_solu') - - allocate (solu_ens%gt(solu_ens%nall)) - allocate (solu_ens%ht(solu_ens%nall)) - allocate (solu_ens%svib(solu_ens%nall)) - allocate (solu_ens%srot(solu_ens%nall)) - allocate (solu_ens%stra(solu_ens%nall)) - - call pr_freq_energy() - call pr_freq_file(ich33) - - do i = 1, solu_ens%nall - write (to, '("TMPFREQ",i0)') i - call chdir(to) - call rdtherm('xtb_freq.out', ht(1), svib(1), srot(1), stra(1), gt(1)) - write (*, '(2x,i0,2x,5f10.2)') i, ht(1), svib(1), srot(1), stra(1), gt(1) - write (ich33, '(2x,i0,2x,5f10.2)') i, ht(1), svib(1), srot(1), stra(1), gt(1) - solu_ens%gt(i) = gt(1) - solu_ens%ht(i) = ht(1) - solu_ens%svib(i) = svib(1) - solu_ens%srot(i) = srot(1) - solu_ens%stra(i) = stra(1) - - call chdir(tmppath2) - call chdir('tmp_solu') - end do - close (ich33) + write (*,*) + write (*,*) ' Solute cluster properties' + open (newunit=ich33,file='solute_cluster.dat') + + call chdir('tmp_solu') + + allocate (solu_ens%gt(solu_ens%nall)) + allocate (solu_ens%ht(solu_ens%nall)) + allocate (solu_ens%svib(solu_ens%nall)) + allocate (solu_ens%srot(solu_ens%nall)) + allocate (solu_ens%stra(solu_ens%nall)) + + call pr_freq_energy() + call pr_freq_file(ich33) + + do i = 1,solu_ens%nall + write (to,'("TMPFREQ",i0)') i + call chdir(to) + call rdtherm('xtb_freq.out',ht(1),svib(1),srot(1),stra(1),gt(1)) + write (*,'(2x,i0,2x,5f10.2)') i,ht(1),svib(1),srot(1),stra(1),gt(1) + write (ich33,'(2x,i0,2x,5f10.2)') i,ht(1),svib(1),srot(1),stra(1),gt(1) + solu_ens%gt(i) = gt(1) + solu_ens%ht(i) = ht(1) + solu_ens%svib(i) = svib(1) + solu_ens%srot(i) = srot(1) + solu_ens%stra(i) = stra(1) + + call chdir(tmppath2) + call chdir('tmp_solu') + end do + close (ich33) !--- Solvent cluster - write (*, *) - write (*, *) ' Solvent cluster properties' - call chdir(tmppath2) - open (newunit=ich81, file='solvent_cluster.dat') - - call chdir('tmp_solv') - - allocate (solv_ens%gt(solv_ens%nall)) - allocate (solv_ens%ht(solv_ens%nall)) - allocate (solv_ens%svib(solv_ens%nall)) - allocate (solv_ens%srot(solv_ens%nall)) - allocate (solv_ens%stra(solv_ens%nall)) - - call pr_freq_energy() - call pr_freq_file(ich81) - - do i = 1, solv_ens%nall - write (to, '("TMPFREQ",i0)') i - call chdir(to) - call rdtherm('xtb_freq.out', ht(2), svib(2), srot(2), stra(2), gt(2)) - write (*, '(2x,i0,2x,5f10.2)') i, ht(2), svib(2), srot(2), stra(2), gt(2) - write (ich81, '(2x,i0,2x,5f10.2)') i, ht(2), svib(2), srot(2), stra(2), gt(2) - solv_ens%gt(i) = gt(2) - solv_ens%ht(i) = ht(2) - solv_ens%svib(i) = svib(2) - solv_ens%srot(i) = srot(2) - solv_ens%stra(i) = stra(2) - call chdir(tmppath2) - call chdir('tmp_solv') - end do - close (ich81) + write (*,*) + write (*,*) ' Solvent cluster properties' + call chdir(tmppath2) + open (newunit=ich81,file='solvent_cluster.dat') + + call chdir('tmp_solv') + + allocate (solv_ens%gt(solv_ens%nall)) + allocate (solv_ens%ht(solv_ens%nall)) + allocate (solv_ens%svib(solv_ens%nall)) + allocate (solv_ens%srot(solv_ens%nall)) + allocate (solv_ens%stra(solv_ens%nall)) + + call pr_freq_energy() + call pr_freq_file(ich81) + + do i = 1,solv_ens%nall + write (to,'("TMPFREQ",i0)') i + call chdir(to) + call rdtherm('xtb_freq.out',ht(2),svib(2),srot(2),stra(2),gt(2)) + write (*,'(2x,i0,2x,5f10.2)') i,ht(2),svib(2),srot(2),stra(2),gt(2) + write (ich81,'(2x,i0,2x,5f10.2)') i,ht(2),svib(2),srot(2),stra(2),gt(2) + solv_ens%gt(i) = gt(2) + solv_ens%ht(i) = ht(2) + solv_ens%svib(i) = svib(2) + solv_ens%srot(i) = srot(2) + solv_ens%stra(i) = stra(2) + call chdir(tmppath2) + call chdir('tmp_solv') + end do + close (ich81) !--- Saving results - call chdir(tmppath2) - call copysub('solute.dat', resultspath) - call copysub('solute_cluster.dat', resultspath) - call copysub('solvent_cluster.dat', resultspath) + call chdir(tmppath2) + call copysub('solute.dat',resultspath) + call copysub('solute_cluster.dat',resultspath) + call copysub('solvent_cluster.dat',resultspath) !--- Deleting tmp directory - call chdir(tmppath) - if (.not. env%keepModef) call rmrf(tmppath2) - call chdir(thispath) + call chdir(tmppath) + if (.not.env%keepModef) call rmrf(tmppath2) + call chdir(thispath) - env%gfnver = gfnver_tmp - env%optlev = optlev_tmp + env%gfnver = gfnver_tmp + env%optlev = optlev_tmp - call tim%stop(9) + call tim%stop(9) end subroutine qcg_freq -subroutine qcg_eval(env, solu, solu_ens, solv_ens) - use iso_fortran_env, wp => real64 - use crest_data - use qcg_printouts - use iomod - use zdata - use strucrd - - implicit none - - type(systemdata) :: env - type(zmolecule) :: solu - type(ensemble) :: solu_ens, solv_ens - - character(len=512) :: thispath - - integer :: i, j - integer :: srange - integer :: freqscal - real(wp) :: g1(solu_ens%nall) - real(wp) :: g2(solv_ens%nall) - real(wp) :: g3 - real(wp) :: Gsolv(20) - real(wp) :: Hsolv - real(wp) :: G_solute(20) - real(wp) :: H_solute - real(wp) :: G_solvent(20) - real(wp) :: H_solvent - real(wp) :: G_mono(20) - real(wp) :: H_mono - real(wp) :: S(20) - real(wp) :: volw - real(wp) :: sasa - real(wp) :: dum, dum1, dum2 - real(wp) :: e_solute(solu_ens%nall) - real(wp) :: e_solvent(solv_ens%nall) - real(wp) :: scal(20) - integer :: ich23 - real(wp), parameter :: eh = 627.509541d0 - - interface - subroutine aver(pr, env, runs, e_tot, S, H, G, sasa, a_present, a_tot) - use iso_fortran_env, only: wp => real64 - use crest_data - - implicit none - type(systemdata), intent(in) :: env - integer, intent(in) :: runs - real(wp), intent(inout) :: e_tot - real(wp), intent(in), optional :: a_tot - real(wp), intent(out) :: S - real(wp), intent(out) :: H - real(wp), intent(out) :: G - real(wp), intent(out) :: sasa - logical, intent(in) :: pr, a_present - dimension e_tot(runs) - dimension a_tot(runs) - end subroutine aver - end interface - - call pr_eval_eval() - - call getcwd(thispath) - - freqscal = nint(env%freq_scal/0.05) - srange = 20 - do i = 1, srange - scal(i) = 0.05*i - end do +!==============================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< real64 + use crest_data + use qcg_printouts + use iomod + use zdata + use strucrd + + implicit none + + type(systemdata) :: env + type(zmolecule) :: solu + type(ensemble) :: solu_ens,solv_ens + + character(len=512) :: thispath + + integer :: i,j + integer :: srange + integer :: freqscal + real(wp) :: g1(solu_ens%nall) + real(wp) :: g2(solv_ens%nall) + real(wp) :: g3 + real(wp) :: Gsolv(20) + real(wp) :: Hsolv + real(wp) :: G_solute(20) + real(wp) :: H_solute + real(wp) :: G_solvent(20) + real(wp) :: H_solvent + real(wp) :: G_mono(20) + real(wp) :: H_mono + real(wp) :: S(20) + real(wp) :: volw + real(wp) :: sasa + real(wp) :: dum,dum1,dum2 + real(wp) :: e_solute(solu_ens%nall) + real(wp) :: e_solvent(solv_ens%nall) + real(wp) :: scal(20) + integer :: ich23 + real(wp),parameter :: eh = 627.509541d0 + + interface + subroutine aver(pr,env,runs,e_tot,S,H,G,sasa,a_present,a_tot) + use iso_fortran_env,only:wp => real64 + use crest_data + + implicit none + type(systemdata),intent(in) :: env + integer,intent(in) :: runs + real(wp),intent(inout) :: e_tot + real(wp),intent(in),optional :: a_tot + real(wp),intent(out) :: S + real(wp),intent(out) :: H + real(wp),intent(out) :: G + real(wp),intent(out) :: sasa + logical,intent(in) :: pr,a_present + dimension e_tot(runs) + dimension a_tot(runs) + end subroutine aver + end interface + + call pr_eval_eval() + + call getcwd(thispath) + + freqscal = nint(env%freq_scal/0.05) + srange = 20 + do i = 1,srange + scal(i) = 0.05*i + end do !--- Solute Cluster - !H_solv - do i = 1, solu_ens%nall - e_solute(i) = solu_ens%er(i)*eh + solu_ens%ht(i) - end do - call aver(.false., env, solu_ens%nall, e_solute, dum1, H_solute, dum2, sasa, .false.) - !G_solv - do i = 1, srange - do j = 1, solu_ens%nall - g1(j) = solu_ens%ht(j) - (env%tboltz*(solu_ens%svib(j) + scal(i)*(solu_ens%srot(j) + solu_ens%stra(j)))/1000) - e_solute(j) = solu_ens%er(j)*eh + g1(j) - end do - call aver(.false., env, solu_ens%nall, e_solute, S(i), dum, G_solute(i), sasa, .false.) - end do + !H_solv + do i = 1,solu_ens%nall + e_solute(i) = solu_ens%er(i)*eh+solu_ens%ht(i) + end do + call aver(.false.,env,solu_ens%nall,e_solute,dum1,H_solute,dum2,sasa,.false.) + !G_solv + do i = 1,srange + do j = 1,solu_ens%nall + g1(j) = solu_ens%ht(j)-(env%tboltz*(solu_ens%svib(j)+scal(i)*(solu_ens%srot(j)+solu_ens%stra(j)))/1000) + e_solute(j) = solu_ens%er(j)*eh+g1(j) + end do + call aver(.false.,env,solu_ens%nall,e_solute,S(i),dum,G_solute(i),sasa,.false.) + end do !--- Solvent Cluster - !H_solv - do i = 1, solv_ens%nall - e_solvent(i) = solv_ens%er(i)*eh + solv_ens%ht(i) - end do - call aver(.false., env, solv_ens%nall, e_solvent, dum1, H_solvent, dum2, sasa, .false.) - - !G_solv - do i = 1, srange - do j = 1, solv_ens%nall - g2(j) = solv_ens%ht(j) - & - & (env%tboltz*(solv_ens%svib(j) + scal(i)*(solv_ens%srot(j) + solv_ens%stra(j)))/1000) - e_solvent(j) = solv_ens%er(j)*eh + g2(j) - end do - call aver(.false., env, solv_ens%nall, e_solvent, S(i), dum, G_solvent(i), sasa, .false.) - end do + !H_solv + do i = 1,solv_ens%nall + e_solvent(i) = solv_ens%er(i)*eh+solv_ens%ht(i) + end do + call aver(.false.,env,solv_ens%nall,e_solvent,dum1,H_solvent,dum2,sasa,.false.) + + !G_solv + do i = 1,srange + do j = 1,solv_ens%nall + g2(j) = solv_ens%ht(j)- & + & (env%tboltz*(solv_ens%svib(j)+scal(i)*(solv_ens%srot(j)+solv_ens%stra(j)))/1000) + e_solvent(j) = solv_ens%er(j)*eh+g2(j) + end do + call aver(.false.,env,solv_ens%nall,e_solvent,S(i),dum,G_solvent(i),sasa,.false.) + end do !--- Solute gas phase - H_mono = solu%energy*eh + solu%ht - do i = 1, srange - g3 = solu%ht - (env%tboltz*(solu%svib + scal(i)*(solu%srot + solu%stra))/1000) - G_mono(i) = solu%energy*eh + g3 - end do + H_mono = solu%energy*eh+solu%ht + do i = 1,srange + g3 = solu%ht-(env%tboltz*(solu%svib+scal(i)*(solu%srot+solu%stra))/1000) + G_mono(i) = solu%energy*eh+g3 + end do - Gsolv(1:20) = G_solute(1:20) - G_solvent(1:20) - G_mono(1:20) - Hsolv = H_solute - H_solvent - H_mono + Gsolv(1:20) = G_solute(1:20)-G_solvent(1:20)-G_mono(1:20) + Hsolv = H_solute-H_solvent-H_mono !--- Calculate Volume work and include - volw = (env%tboltz*8.31451/1000./4.184)*log(24.47d0*env%tboltz/298.15) - Gsolv(1:20) = Gsolv(1:20) - volw - Hsolv = Hsolv - volw - call pr_eval_1(Gsolv(20), Hsolv) - call pr_eval_2(srange, Gsolv, scal) - call pr_eval_3(srange, freqscal, env%freq_scal, Gsolv) + volw = (env%tboltz*8.31451/1000./4.184)*log(24.47d0*env%tboltz/298.15) + Gsolv(1:20) = Gsolv(1:20)-volw + Hsolv = Hsolv-volw + call pr_eval_1(Gsolv(20),Hsolv) + call pr_eval_2(srange,Gsolv,scal) + call pr_eval_3(srange,freqscal,env%freq_scal,Gsolv) ! Save Result - open (newunit=ich23, file='frequencies/result.dat') - write (ich23, '("Solvation Free Energy [kcal/mol] :")') - write (ich23, '(f8.2)') Gsolv(freqscal) - close (ich23) + open (newunit=ich23,file='frequencies/result.dat') + write (ich23,'("Solvation Free Energy [kcal/mol] :")') + write (ich23,'(f8.2)') Gsolv(freqscal) + close (ich23) end subroutine qcg_eval -subroutine write_qcg_setup(env) - use crest_data - use iomod - implicit none - - type(systemdata) :: env - - write (*, *) - write (*, '(2x,''========================================='')') - write (*, '(2x,''| quantum cluster growth: INPUT |'')') - write (*, '(2x,''========================================='')') - write (*, *) - select case (env%qcg_runtype) - case (0) - write (*, '(2x,''QCG: Only Cluster Generation'')') - case (1) - write (*, '(2x,''QCG: Cluster + Ensemble Generation'')') - if (env%ensemble_method .eq. 0) write (*, '(2x,''Ensemble generated via CREST'')') - if (env%ensemble_method .eq. 1) write (*, '(2x,''Ensemble generated via MD Simulation'')') - if (env%ensemble_method .eq. 2) write (*, '(2x,''Ensemble generated via MetaDynamic'')') - case (2) - write (*, '(2x,''QCG: Calculation of delta E_solv'')') - if (env%ensemble_method .eq. 0) write (*, '(2x,''Ensemble generated via CREST'')') - if (env%ensemble_method .eq. 1) write (*, '(2x,''Ensemble generated via MD Simulation'')') - if (env%ensemble_method .eq. 2) write (*, '(2x,''Ensemble generated via MetaDynamic'')') - case (3) - write (*, '(2x,''QCG: Calculation of delta G_solv'')') - if (env%ensemble_method .eq. 0) write (*, '(2x,''Ensemble generated via CREST'')') - if (env%ensemble_method .eq. 1) write (*, '(2x,''Ensemble generated via MD Simulation'')') - if (env%ensemble_method .eq. 2) write (*, '(2x,''Ensemble generated via MetaDynamic'')') - case default - continue - end select - write (*, *) - write (*, '(2x,''input parameters '')') - write (*, '(2x,''solute : '',a)') trim(env%solu_file) - write (*, '(2x,''charge : '',i0)') env%chrg - write (*, '(2x,''uhf : '',i0)') env%uhf - write (*, '(2x,''solvent : '',a)') trim(env%solv_file) - if (env%nsolv .ne. 0) then - write (*, '(2x,''# of solvents to add : '',i0)') env%nsolv - else if (env%nsolv .eq. 0) then - write (*, '(2x,''# of solvents to add : until convergence, but maximal'',1x,i4)') env%max_solv - end if - if (env%nqcgclust .ne. 0) then - write (*, '(2x,''# of cluster generated : '',i0)') env%nqcgclust - else - write (*, '(2x,''Cluster generated that are above 10 % populated '')') - end if - - write (*, '(2x,''# of CPUs used : '',i0)') env%Threads - if (env%solvent .eq. '') then - write (*, '(2x,''No gbsa/alpb model'' )') - else - write (*, '(2x,''Solvation model : '',a)') env%solvent - end if - write (*, '(2x,''xtb opt level : '',a)') trim(optlevflag(env%optlev)) - write (*, '(2x,''System temperature [K] : '',F5.1)') env%tboltz - write (*, '(2x,''RRHO scaling factor : '',F4.2)') env%freq_scal - write (*, *) - if (env%use_xtbiff) write (*, '(2x,''Use of xTB-IFF standalone requested'')') - -end subroutine write_qcg_setup - -subroutine get_sphere(pr, zmol, r_logical) - use crest_parameters, only : wp - use zdata - - implicit none - type(zmolecule), intent(inout) :: zmol - type(zmolecule) :: dum - logical :: pr - logical :: r_logical !Determines wether r is overwritten or not - real(wp), parameter :: pi43 = 3.1415926540d0*4.0d0/3.0d0 - real(wp), parameter :: pi = 3.1415926540d0 - real(wp), parameter :: third = 1.0d0/3.0d0 - real(wp), parameter :: bohr = 0.52917726d0 - - integer :: i - real*8 :: rad(zmol%nat), xyz_tmp(3, zmol%nat) - real(wp), allocatable :: rcov(:) - - allocate (rcov(94)) - rcov = (/ & - & 2.18230009, 1.73469996, 3.49559999, 3.09820008, 3.21600008, & - & 2.91030002, 2.62249994, 2.48169994, 2.29959989, 2.13739991, & - & 3.70819998, 3.48390007, 4.01060009, 3.79169989, 3.50169992, & - & 3.31069994, 3.10459995, 2.91479993, 4.24109983, 4.10349989, & - & 3.89030004, 3.76419997, 3.72110009, 3.44140005, 3.54620004, & - & 3.44210005, 3.43269992, 3.34619999, 3.30080009, 3.23090005, & - & 3.95790005, 3.86190009, 3.66249990, 3.52679992, 3.36619997, & - & 3.20959997, 4.61759996, 4.47639990, 4.21960020, 4.05970001, & - & 3.85960007, 3.75430012, 3.56900001, 3.46230006, 3.39750004, & - & 3.35249996, 3.33080006, 3.46199989, 4.26230001, 4.18739986, & - & 4.01499987, 3.89010000, 3.73799992, 3.58890009, 5.05670023, & - & 5.18139982, 4.62610006, 4.62010002, 4.57019997, 4.52710009, & - & 4.48960018, 4.45149994, 4.42339993, 4.12430000, 4.24270010, & - & 4.15409994, 4.27939987, 4.24499989, 4.22079992, 4.19859982, & - & 4.01300001, 4.24499989, 4.09800005, 3.98550010, 3.89549994, & - & 3.74900007, 3.44560003, 3.35249996, 3.25640011, 3.35990000, & - & 4.31269979, 4.27640009, 4.11749983, 4.00540018, 3.86439991, & - & 3.72160006, 5.07959986, 4.92939997, 4.70429993, 4.42519999, & - & 4.45940018, 4.39569998, 4.35389996, 4.43410015/) - - do i = 1, zmol%nat - rad(i) = bohr*rcov(zmol%at(i))*1.40 ! scale factor adjusted to rough - xyz_tmp(1:3, i) = bohr*zmol%xyz(1:3, i) - end do - - dum = zmol - dum%xyz = xyz_tmp - - call get_volume(dum, rad) - - zmol%atot = dum%atot/bohr**2 - zmol%vtot = dum%vtot/bohr**3 - - if (r_logical) then - zmol%rtot = zmol%vtot*3.0/4.d0/pi - zmol%rtot = zmol%rtot**(1.d0/3.d0) - end if - - if (pr) then - if (r_logical) then - write (*, '(2x,''molecular radius (Bohr**1):'',F8.2)') zmol%rtot - end if - write (*, '(2x,''molecular area (Bohr**2):'',F8.2)') zmol%atot - write (*, '(2x,''molecular volume (Bohr**3):'',F8.2)') zmol%vtot - end if +!==============================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< real64 - use crest_data - use iomod - use zdata - use strucrd - use axis_module, only: cma - implicit none +!==============================================================================! - type(zmolecule) :: solu, solv +subroutine cma_shifting(solu,solv) + use iso_fortran_env,wp => real64 + use crest_data + use iomod + use zdata + use strucrd + use axis_module,only:cma + implicit none + + type(zmolecule) :: solu,solv - integer :: i + integer :: i - call cma(solu%nat, solu%at, solu%xyz, solu%cma) - call cma(solv%nat, solv%at, solv%xyz, solv%cma) + call cma(solu%nat,solu%at,solu%xyz,solu%cma) + call cma(solv%nat,solv%at,solv%xyz,solv%cma) - do i = 1, solu%nat - solu%xyz(1:3, i) = solu%xyz(1:3, i) - solu%cma(1:3) - end do - do i = 1, solv%nat - solv%xyz(1:3, i) = solv%xyz(1:3, i) - solv%cma(1:3) - end do + do i = 1,solu%nat + solu%xyz(1:3,i) = solu%xyz(1:3,i)-solu%cma(1:3) + end do + do i = 1,solv%nat + solv%xyz(1:3,i) = solv%xyz(1:3,i)-solv%cma(1:3) + end do end subroutine cma_shifting -subroutine get_ellipsoid(env, solu, solv, clus, pr1) - use iso_fortran_env, wp => real64 - use crest_data - use iomod - use zdata - use strucrd - use axis_module - implicit none - - type(systemdata) :: env - type(zmolecule) :: solu, solv, clus - type(zmolecule) :: dummy_solu, dummy_solv - real(wp) :: rabc_solu(3), rabc_solv(3) - real(wp) :: aniso, sola - real(wp) :: rmax_solu, rmax_solv - real(wp) :: boxr, roff, r - character(len=10) :: fname - logical :: ex, pr, pr1 - - real(wp), parameter :: pi43 = 3.1415926540d0*4.0d0/3.0d0 - real(wp), parameter :: pi = 3.1415926540d0 - real(wp), parameter :: third = 1.0d0/3.0d0 - - pr = .false. !Outprint deactivated - - fname = 'eaxis.qcg' - inquire (file=fname, exist=ex) - - if (pr1) then !First time called +!==============================================================================! +! +subroutine get_ellipsoid(env,solu,solv,clus,pr1) + use iso_fortran_env,wp => real64 + use crest_data + use iomod + use zdata + use strucrd + use axis_module + implicit none + + type(systemdata) :: env + type(zmolecule) :: solu,solv,clus + type(zmolecule) :: dummy_solu,dummy_solv + real(wp) :: rabc_solu(3),rabc_solv(3) + real(wp) :: aniso,sola + real(wp) :: rmax_solu,rmax_solv + real(wp) :: boxr,roff,r + character(len=10) :: fname + logical :: ex,pr,pr1 + + real(wp),parameter :: pi43 = 3.1415926540d0*4.0d0/3.0d0 + real(wp),parameter :: pi = 3.1415926540d0 + real(wp),parameter :: third = 1.0d0/3.0d0 + + pr = .false. !Outprint deactivated + + fname = 'eaxis.qcg' + inquire (file=fname,exist=ex) + + if (pr1) then !First time called !--- Moving all coords to the origin (transformation) - call axistrf(solu%nat, solu%nat, solu%at, solu%xyz) + call axistrf(solu%nat,solu%nat,solu%at,solu%xyz) ! call axistrf(solv%nat,solv%nat,solv%at,solv%xyz) !Not done in original QCG code - call axistrf(clus%nat, solu%nat, clus%at, clus%xyz) + call axistrf(clus%nat,solu%nat,clus%at,clus%xyz) !--- Overwrite solute and solvent coord in original file with transformed and optimized ones - call wrc0('solute', solu%nat, solu%at, solu%xyz) - call wrc0('solvent', solv%nat, solv%at, solv%xyz) + call wrc0('solute',solu%nat,solu%at,solu%xyz) + call wrc0('solvent',solv%nat,solv%at,solv%xyz) !--- Getting axis - write (*, *) 'Solute:' - call axis(pr1, solu%nat, solu%at, solu%xyz, solu%eax) - write (*, *) 'Solvent:' - call axis(pr1, solv%nat, solv%at, solv%xyz, solv%eax) - write (*, *) - end if + write (*,*) 'Solute:' + call axis(pr1,solu%nat,solu%at,solu%xyz,solu%eax) + write (*,*) 'Solvent:' + call axis(pr1,solv%nat,solv%at,solv%xyz,solv%eax) + write (*,*) + end if !--- Computing anisotropy factor of solute and solvent - sola = sqrt(1.+(solu%eax(1) - solu%eax(3))/((solu%eax(1) + solu%eax(2) + solu%eax(3))/3.)) - aniso = sqrt(1.+(solv%eax(1) - solv%eax(3))/((solv%eax(1) + solv%eax(2) + solv%eax(3))/3.)) ! =1 for a spherical system + sola = sqrt(1.+(solu%eax(1)-solu%eax(3))/((solu%eax(1)+solu%eax(2)+solu%eax(3))/3.)) + aniso = sqrt(1.+(solv%eax(1)-solv%eax(3))/((solv%eax(1)+solv%eax(2)+solv%eax(3))/3.)) ! =1 for a spherical system !--- Get maximum intramoleclar distance of solute and solvent - call getmaxrad(solu%nat, solu%at, solu%xyz, rmax_solu) - call getmaxrad(solv%nat, solv%at, solv%xyz, rmax_solv) + call getmaxrad(solu%nat,solu%at,solu%xyz,rmax_solu) + call getmaxrad(solv%nat,solv%at,solv%xyz,rmax_solv) !--- Getting V and A of dummies - dummy_solu = solu - dummy_solv = solv !Why is dummy_solv%vtot different to solv%vtot - call get_sphere(.false., dummy_solu, .false.) - call get_sphere(.false., dummy_solv, .false.) + dummy_solu = solu + dummy_solv = solv !Why is dummy_solv%vtot different to solv%vtot + call get_sphere(.false.,dummy_solu,.false.) + call get_sphere(.false.,dummy_solv,.false.) !--- Computation of outer Wall - roff = sola*dummy_solu%vtot/1000 - boxr = ((0.5*aniso*clus%nmol*dummy_solv%vtot + dummy_solu%vtot)/pi43)**third + roff + rmax_solv*0.5 !0.5 both - r = (boxr**3/(solu%eax(1)*solu%eax(2)*solu%eax(3)))**third ! volume of ellipsoid = volume of sphere - rabc_solv = solu%eax*r ! outer solvent wall + roff = sola*dummy_solu%vtot/1000 + boxr = ((0.5*aniso*clus%nmol*dummy_solv%vtot+dummy_solu%vtot)/pi43)**third+roff+rmax_solv*0.5 !0.5 both + r = (boxr**3/(solu%eax(1)*solu%eax(2)*solu%eax(3)))**third ! volume of ellipsoid = volume of sphere + rabc_solv = solu%eax*r ! outer solvent wall !--- Computation of inner wall - roff = sola*dummy_solu%vtot/1000 - boxr = ((sola*dummy_solu%vtot)/pi43)**third + roff + rmax_solu*0.1 !0.1 before - r = (boxr**3/(solu%eax(1)*solu%eax(2)*solu%eax(3)))**third ! volume of ellipsoid = volume of sphere - rabc_solu = solu%eax*r - dummy_solu%ell_abc(1) = solu%eax(1)**2/sum((solu%eax(1:3))**2) - dummy_solu%ell_abc(2) = solu%eax(2)**2/sum((solu%eax(1:3))**2) - dummy_solu%ell_abc(3) = solu%eax(3)**2/sum((solu%eax(1:3))**2) - rabc_solu = dummy_solu%ell_abc*r - - solu%aniso = sola - solv%aniso = aniso - solu%ell_abc = rabc_solu - clus%ell_abc = rabc_solv*env%potscal - - if (pr1) then - write (*, '(2x,''solvent anisotropy :'',4f10.3)') aniso - write (*, '(2x,''solute anisotropy :'',4f10.3)') sola - write (*, '(2x,''roff inner wall :'',4f10.3)') roff - write (*, '(2x,''solute max dist :'',4f10.3)') rmax_solu - write (*, '(2x,''solvent max dist :'',4f10.3)') rmax_solv - write (*, '(2x,''inner unit axis :'',3f10.3)') dummy_solu%ell_abc(1:3) - write (*, '(2x,''inner ellipsoid/Bohr :'',3f10.3)') rabc_solu(1:3) - write (*, '(2x,''scaling factor outer ellipsoid:'',3f10.3)') env%potscal - write (*, '(2x,''outer ellipsoid/Bohr :'',3f10.3)') clus%ell_abc(1:3) - if (env%potscal .gt. 1.0_wp) write & - &(*, '(2x,''!!!WARNING: A SCALING FACTOR LARGER 1.0 IS ONLY FOR MICROSOLVATION RECOMMENDED'')') - write (*, *) - end if + roff = sola*dummy_solu%vtot/1000 + boxr = ((sola*dummy_solu%vtot)/pi43)**third+roff+rmax_solu*0.1 !0.1 before + r = (boxr**3/(solu%eax(1)*solu%eax(2)*solu%eax(3)))**third ! volume of ellipsoid = volume of sphere + rabc_solu = solu%eax*r + dummy_solu%ell_abc(1) = solu%eax(1)**2/sum((solu%eax(1:3))**2) + dummy_solu%ell_abc(2) = solu%eax(2)**2/sum((solu%eax(1:3))**2) + dummy_solu%ell_abc(3) = solu%eax(3)**2/sum((solu%eax(1:3))**2) + rabc_solu = dummy_solu%ell_abc*r + + solu%aniso = sola + solv%aniso = aniso + solu%ell_abc = rabc_solu + clus%ell_abc = rabc_solv*env%potscal + + if (pr1) then + write (*,'(2x,''solvent anisotropy :'',4f10.3)') aniso + write (*,'(2x,''solute anisotropy :'',4f10.3)') sola + write (*,'(2x,''roff inner wall :'',4f10.3)') roff + write (*,'(2x,''solute max dist :'',4f10.3)') rmax_solu + write (*,'(2x,''solvent max dist :'',4f10.3)') rmax_solv + write (*,'(2x,''inner unit axis :'',3f10.3)') dummy_solu%ell_abc(1:3) + write (*,'(2x,''inner ellipsoid/Bohr :'',3f10.3)') rabc_solu(1:3) + write (*,'(2x,''scaling factor outer ellipsoid:'',3f10.3)') env%potscal + write (*,'(2x,''outer ellipsoid/Bohr :'',3f10.3)') clus%ell_abc(1:3) + if (env%potscal .gt. 1.0_wp) write & + &(*,'(2x,''!!!WARNING: A SCALING FACTOR LARGER 1.0 IS ONLY FOR MICROSOLVATION RECOMMENDED'')') + write (*,*) + end if end subroutine get_ellipsoid -subroutine getmaxrad(n, at, xyz, r) - use crest_parameters, only : wp - implicit none - real(wp) :: xyz(3, n), r - integer :: n, at(n) - - real(wp) :: rx, ry, rz, rr - integer :: i, j - real(wp), allocatable :: rcov(:) - - allocate (rcov(94)) - rcov = (/ & - & 2.18230009, 1.73469996, 3.49559999, 3.09820008, 3.21600008, & - & 2.91030002, 2.62249994, 2.48169994, 2.29959989, 2.13739991, & - & 3.70819998, 3.48390007, 4.01060009, 3.79169989, 3.50169992, & - & 3.31069994, 3.10459995, 2.91479993, 4.24109983, 4.10349989, & - & 3.89030004, 3.76419997, 3.72110009, 3.44140005, 3.54620004, & - & 3.44210005, 3.43269992, 3.34619999, 3.30080009, 3.23090005, & - & 3.95790005, 3.86190009, 3.66249990, 3.52679992, 3.36619997, & - & 3.20959997, 4.61759996, 4.47639990, 4.21960020, 4.05970001, & - & 3.85960007, 3.75430012, 3.56900001, 3.46230006, 3.39750004, & - & 3.35249996, 3.33080006, 3.46199989, 4.26230001, 4.18739986, & - & 4.01499987, 3.89010000, 3.73799992, 3.58890009, 5.05670023, & - & 5.18139982, 4.62610006, 4.62010002, 4.57019997, 4.52710009, & - & 4.48960018, 4.45149994, 4.42339993, 4.12430000, 4.24270010, & - & 4.15409994, 4.27939987, 4.24499989, 4.22079992, 4.19859982, & - & 4.01300001, 4.24499989, 4.09800005, 3.98550010, 3.89549994, & - & 3.74900007, 3.44560003, 3.35249996, 3.25640011, 3.35990000, & - & 4.31269979, 4.27640009, 4.11749983, 4.00540018, 3.86439991, & - & 3.72160006, 5.07959986, 4.92939997, 4.70429993, 4.42519999, & - & 4.45940018, 4.39569998, 4.35389996, 4.43410015/) - - r = 0 - do i = 1, n - 1 - do j = i + 1, n - rx = xyz(1, i) - xyz(1, j) - ry = xyz(2, i) - xyz(2, j) - rz = xyz(3, i) - xyz(3, j) - rr = sqrt(rx**2 + ry**2 + rz**2) + rcov(at(i)) + rcov(at(j)) - if (rr .gt. r) r = rr - end do - end do - - deallocate (rcov) +!==============================================================================! +subroutine getmaxrad(n,at,xyz,r) + use crest_parameters,only:wp + use miscdata, only: rcov_qcg + implicit none + real(wp) :: xyz(3,n),r + integer :: n,at(n) + real(wp) :: rx,ry,rz,rr + integer :: i,j + + r = 0 + do i = 1,n-1 + do j = i+1,n + rx = xyz(1,i)-xyz(1,j) + ry = xyz(2,i)-xyz(2,j) + rz = xyz(3,i)-xyz(3,j) + rr = sqrt(rx**2+ry**2+rz**2)+rcov_qcg(at(i))+rcov_qcg(at(j)) + if (rr .gt. r) r = rr + end do + end do end subroutine getmaxrad -subroutine ellipsout(fname, n, at, xyz, r1) - use iso_fortran_env, only: wp => real64 - use strucrd, only: i2e - implicit none - - integer :: i - integer :: n, at(n) - real(wp) :: xyz(3, n), r1(3) - real(wp) :: x, y, z, f, rr - character(len=*) :: fname - integer :: ich11 - - open (newunit=ich11, file=fname) - write (ich11, '(a)') '$coord' - do i = 1, n - write (ich11, '(3F24.14,6x,a)') xyz(1, i), xyz(2, i), xyz(3, i), i2e(at(i)) - end do - do i = 1, 500 - call random_number(x) - call random_number(f) - if (f .gt. 0.5) x = -x - call random_number(y) - call random_number(f) - if (f .gt. 0.5) y = -y - call random_number(z) - call random_number(f) - if (f .gt. 0.5) z = -z - rr = sqrt(x*x + y*y + z*z) - x = x*r1(1)/rr - y = y*r1(2)/rr - z = z*r1(3)/rr - write (ich11, '(3F24.14,6x,a2)') x, y, z, 'he' - end do - write (ich11, '(a)') '$end' - close (ich11) +!==============================================================================! + +subroutine ellipsout(fname,n,at,xyz,r1) + use iso_fortran_env,only:wp => real64 + use strucrd,only:i2e + implicit none + + integer :: i + integer :: n,at(n) + real(wp) :: xyz(3,n),r1(3) + real(wp) :: x,y,z,f,rr + character(len=*) :: fname + integer :: ich11 + + open (newunit=ich11,file=fname) + write (ich11,'(a)') '$coord' + do i = 1,n + write (ich11,'(3F24.14,6x,a)') xyz(1,i),xyz(2,i),xyz(3,i),i2e(at(i)) + end do + do i = 1,500 + call random_number(x) + call random_number(f) + if (f .gt. 0.5) x = -x + call random_number(y) + call random_number(f) + if (f .gt. 0.5) y = -y + call random_number(z) + call random_number(f) + if (f .gt. 0.5) z = -z + rr = sqrt(x*x+y*y+z*z) + x = x*r1(1)/rr + y = y*r1(2)/rr + z = z*r1(3)/rr + write (ich11,'(3F24.14,6x,a2)') x,y,z,'he' + end do + write (ich11,'(a)') '$end' + close (ich11) end subroutine ellipsout -subroutine both_ellipsout(fname, n, at, xyz, r1, r2) - use iso_fortran_env, only: wp => real64 - use strucrd, only: i2e - implicit none - - integer :: i - integer :: n, at(n) - real(wp) :: xyz(3, n), r1(3) - real(wp), optional :: r2(3) - real(wp) :: x, y, z, f, rr - character(len=*) :: fname - integer :: ich11 - - open (newunit=ich11, file=fname) - write (ich11, '(a)') '$coord' - do i = 1, n - write (ich11, '(3F24.14,6x,a)') xyz(1, i), xyz(2, i), xyz(3, i), i2e(at(i)) - end do - do i = 1, 500 +!==============================================================================! + +subroutine both_ellipsout(fname,n,at,xyz,r1,r2) + use iso_fortran_env,only:wp => real64 + use strucrd,only:i2e + implicit none + + integer :: i + integer :: n,at(n) + real(wp) :: xyz(3,n),r1(3) + real(wp),optional :: r2(3) + real(wp) :: x,y,z,f,rr + character(len=*) :: fname + integer :: ich11 + + open (newunit=ich11,file=fname) + write (ich11,'(a)') '$coord' + do i = 1,n + write (ich11,'(3F24.14,6x,a)') xyz(1,i),xyz(2,i),xyz(3,i),i2e(at(i)) + end do + do i = 1,500 + call random_number(x) + call random_number(f) + if (f .gt. 0.5) x = -x + call random_number(y) + call random_number(f) + if (f .gt. 0.5) y = -y + call random_number(z) + call random_number(f) + if (f .gt. 0.5) z = -z + rr = sqrt(x*x+y*y+z*z) + x = x*r1(1)/rr + y = y*r1(2)/rr + z = z*r1(3)/rr + write (ich11,'(3F24.14,6x,a2)') x,y,z,'he' + end do + if (present(r2)) then + do i = 1,100 call random_number(x) call random_number(f) if (f .gt. 0.5) x = -x @@ -2719,610 +2665,571 @@ subroutine both_ellipsout(fname, n, at, xyz, r1, r2) call random_number(z) call random_number(f) if (f .gt. 0.5) z = -z - rr = sqrt(x*x + y*y + z*z) - x = x*r1(1)/rr - y = y*r1(2)/rr - z = z*r1(3)/rr - write (ich11, '(3F24.14,6x,a2)') x, y, z, 'he' - end do - if (present(r2)) then - do i = 1, 100 - call random_number(x) - call random_number(f) - if (f .gt. 0.5) x = -x - call random_number(y) - call random_number(f) - if (f .gt. 0.5) y = -y - call random_number(z) - call random_number(f) - if (f .gt. 0.5) z = -z - rr = sqrt(x*x + y*y + z*z) - x = x*r2(1)/rr - y = y*r2(2)/rr - z = z*r2(3)/rr - write (ich11, '(3F24.14,6x,a2)') x, y, z, 'b' - end do - end if - write (ich11, '(a)') '$end' - close (ich11) + rr = sqrt(x*x+y*y+z*z) + x = x*r2(1)/rr + y = y*r2(2)/rr + z = z*r2(3)/rr + write (ich11,'(3F24.14,6x,a2)') x,y,z,'b' + end do + end if + write (ich11,'(a)') '$end' + close (ich11) end subroutine both_ellipsout -subroutine get_interaction_E(env, solu, solv, clus, iter, E_inter) - use iso_fortran_env, wp => real64 - use crest_data - use iomod - use zdata - use strucrd - implicit none - - type(systemdata) :: env - type(zmolecule), intent(in) :: solu, solv, clus - real(wp) :: e_cluster, e_solute, e_solvent - real(wp) :: E_inter(env%nsolv) ! interaction energy - integer :: iter - logical :: e_there - - call remove('cluster.coord') - -!--- Prepare input coordinate files - call wrc0('cluster.coord', clus%nat, clus%at, clus%xyz) - call wr_cluster_cut('cluster.coord', solu%nat, solv%nat, iter, 'solute_cut.coord', 'solvent_cut.coord') - -!--- Perform single point calculations and recieve energies - call xtb_sp_qcg(env, 'solute_cut.coord') - call grepval('xtb.out', '| TOTAL ENERGY', e_there, e_solute) - if (.not. e_there) write (*, *) 'Solute energy not found' - call xtb_sp_qcg(env, 'solvent_cut.coord') - call grepval('xtb.out', '| TOTAL ENERGY', e_there, e_solvent) - if (.not. e_there) write (*, *) 'Solvent energy not found' - call xtb_sp_qcg(env, 'cluster.coord') - call grepval('xtb.out', '| TOTAL ENERGY', e_there, e_cluster) - if (.not. e_there) write (*, *) 'Cluster energy not found' - - E_inter(iter) = e_cluster - e_solute - e_solvent - -end subroutine get_interaction_E - -subroutine analyze_cluster(nsolv, n, nS, nM, xyz, at, av, last) - use iso_fortran_env, only: wp => real64 - use axis_module, only: cma - implicit none - real(wp) xyz(3, n) - real(wp) av, last - integer n, nS, nM, nsolv, at(n) - real(wp) xyzM(3, nM) - integer atm(nM) - real(wp) xyzS(3, nS) - integer atS(nS) - real(wp) x1(3), x2(3), r - integer i, is, ie - - if (nsolv .eq. 1) return - xyzS(1:3, 1:nS) = xyz(1:3, 1:nS) - atS(1:nS) = at(1:nS) - call cma(nS, atS, xyzS, x1) - - av = 0 - do i = 1, nsolv - is = nS + (i - 1)*nM + 1 - ie = is + nM - 1 - xyzM(1:3, 1:nM) = xyz(1:3, is:ie) - atM(1:nM) = at(is:ie) - call cma(nM, atM, xyzM, x2) - r = sqrt((x1(1) - x2(1))**2 + (x1(2) - x2(2))**2 + (x1(3) - x2(3))**2) - if (i .lt. nsolv) then - av = av + r - else - last = r - end if - end do - av = av/float(nsolv - 1) +!==============================================================================! + +subroutine analyze_cluster(nsolv,n,nS,nM,xyz,at,av,last) + use iso_fortran_env,only:wp => real64 + use axis_module,only:cma + implicit none + real(wp) xyz(3,n) + real(wp) av,last + integer n,nS,nM,nsolv,at(n) + real(wp) xyzM(3,nM) + integer atm(nM) + real(wp) xyzS(3,nS) + integer atS(nS) + real(wp) x1(3),x2(3),r + integer i,is,ie + + if (nsolv .eq. 1) return + xyzS(1:3,1:nS) = xyz(1:3,1:nS) + atS(1:nS) = at(1:nS) + call cma(nS,atS,xyzS,x1) + + av = 0 + do i = 1,nsolv + is = nS+(i-1)*nM+1 + ie = is+nM-1 + xyzM(1:3,1:nM) = xyz(1:3,is:ie) + atM(1:nM) = at(is:ie) + call cma(nM,atM,xyzM,x2) + r = sqrt((x1(1)-x2(1))**2+(x1(2)-x2(2))**2+(x1(3)-x2(3))**2) + if (i .lt. nsolv) then + av = av+r + else + last = r + end if + end do + av = av/float(nsolv-1) end subroutine analyze_cluster -subroutine aver(pr, env, runs, e_tot, S, H, G, sasa, a_present, a_tot) - use iso_fortran_env, only: wp => real64 - use crest_data +!==============================================================================! - implicit none +subroutine aver(pr,env,runs,e_tot,S,H,G,sasa,a_present,a_tot) + use iso_fortran_env,only:wp => real64 + use crest_data + + implicit none !---- Dummy - type(systemdata), intent(in) :: env - integer, intent(in) :: runs - real(wp), intent(inout) :: e_tot - real(wp), intent(in), optional :: a_tot - real(wp), intent(out) :: S - real(wp), intent(out) :: H - real(wp), intent(out) :: G - real(wp), intent(out) :: sasa + type(systemdata),intent(in) :: env + integer,intent(in) :: runs + real(wp),intent(inout) :: e_tot + real(wp),intent(in),optional :: a_tot + real(wp),intent(out) :: S + real(wp),intent(out) :: H + real(wp),intent(out) :: G + real(wp),intent(out) :: sasa !---- Stack - logical, intent(in) :: pr, a_present - integer :: j, jmin - real(wp) :: A - real(wp) :: e0 - real(wp), allocatable :: de(:) - real(wp), allocatable :: p(:) - real(wp) :: pmax - real(wp) :: eav - real(wp) :: area - real(wp) :: beta - real(wp) :: temp - integer :: ich48 - real(wp), parameter :: eh = 627.509541d0 - dimension e_tot(runs) - dimension a_tot(runs) - - temp = env%tboltz - allocate (de(runs), source=0.0d0) - allocate (p(runs), source=0.0d0) - - beta = 1./(temp*8.314510/4.184/1000.+1.d-14) - e0 = e_tot(1) - de(1:runs) = (e_tot(1:runs) - e0) - call qcg_boltz(env, runs, de, p) - - A = 0 - eav = 0 - pmax = 0 - area = 0 - do j = 1, runs - A = A + p(j)*log(p(j) + 1.d-12) - eav = eav + p(j)*e_tot(j) - if (p(j) .gt. pmax) then - pmax = p(j) - jmin = j + logical,intent(in) :: pr,a_present + integer :: j,jmin + real(wp) :: A + real(wp) :: e0 + real(wp),allocatable :: de(:) + real(wp),allocatable :: p(:) + real(wp) :: pmax + real(wp) :: eav + real(wp) :: area + real(wp) :: beta + real(wp) :: temp + integer :: ich48 + real(wp),parameter :: eh = 627.509541d0 + dimension e_tot(runs) + dimension a_tot(runs) + + temp = env%tboltz + allocate (de(runs),source=0.0d0) + allocate (p(runs),source=0.0d0) + + beta = 1./(temp*8.314510/4.184/1000.+1.d-14) + e0 = e_tot(1) + de(1:runs) = (e_tot(1:runs)-e0) + call qcg_boltz(env,runs,de,p) + + A = 0 + eav = 0 + pmax = 0 + area = 0 + do j = 1,runs + A = A+p(j)*log(p(j)+1.d-12) + eav = eav+p(j)*e_tot(j) + if (p(j) .gt. pmax) then + pmax = p(j) + jmin = j + end if + if (a_present) area = area+p(j)*a_tot(j) + end do + sasa = area + S = (1./beta)*A + H = eav + G = eav+S + if (pr) then + open (newunit=ich48,file='population.dat') + write (ich48,'(2x, ''cluster'',2x,''E_norm [Eh]'',2x, ''De [kcal]'', 4x, ''p'')') + do j = 1,runs + if (j .lt. 10) then + write (ich48,'(5x,i0,3x,f11.6,5x,f6.4,3x,f6.4)') j,e_tot(j)/eh,de(j),p(j) + else + write (ich48,'(5x,i0,2x,f11.6,5x,f6.4,3x,f6.4)') j,e_tot(j)/eh,de(j),p(j) end if - if (a_present) area = area + p(j)*a_tot(j) - end do - sasa = area - S = (1./beta)*A - H = eav - G = eav + S - if (pr) then - open (newunit=ich48, file='population.dat') - write (ich48, '(2x, ''cluster'',2x,''E_norm [Eh]'',2x, ''De [kcal]'', 4x, ''p'')') - do j = 1, runs - if (j .lt. 10) then - write (ich48, '(5x,i0,3x,f11.6,5x,f6.4,3x,f6.4)') j, e_tot(j)/eh, de(j), p(j) - else - write (ich48, '(5x,i0,2x,f11.6,5x,f6.4,3x,f6.4)') j, e_tot(j)/eh, de(j), p(j) - end if - end do - write (ich48, *) - write (ich48, '(''Ensemble free energy [Eh]:'', f20.10)') G/eh - close (ich48) - end if + end do + write (ich48,*) + write (ich48,'(''Ensemble free energy [Eh]:'', f20.10)') G/eh + close (ich48) + end if - deallocate (de, p) + deallocate (de,p) end subroutine aver -subroutine qcg_boltz(env, n, e, p) - use iso_fortran_env, only: wp => real64 - use crest_data - implicit none - type(systemdata), intent(in) :: env - integer, intent(in) :: n - real(wp), intent(in) :: e(*) - real(wp), intent(out) :: p(*) - integer :: i - real(wp) :: temp - real(wp) :: f, hsum, esum - - temp = env%tboltz - f = 8.314*temp/4.184d+3 - esum = 0 - do i = 1, n - esum = esum + exp(-e(i)/f) - end do - hsum = 0 - do i = 1, n - p(i) = exp(-e(i)/f)/esum - end do +!==============================================================================! +! +subroutine qcg_boltz(env,n,e,p) + use iso_fortran_env,only:wp => real64 + use crest_data + implicit none + type(systemdata),intent(in) :: env + integer,intent(in) :: n + real(wp),intent(in) :: e(*) + real(wp),intent(out) :: p(*) + integer :: i + real(wp) :: temp + real(wp) :: f,hsum,esum + + temp = env%tboltz + f = 8.314*temp/4.184d+3 + esum = 0 + do i = 1,n + esum = esum+exp(-e(i)/f) + end do + hsum = 0 + do i = 1,n + p(i) = exp(-e(i)/f)/esum + end do end subroutine qcg_boltz -subroutine fill_take(env, n2, n12, rabc, ipos) - use iso_fortran_env, only: wp => real64 - use crest_data - use strucrd - use axis_module, only: cma - implicit none - - type(systemdata) :: env - integer, intent(in) :: n2, n12 - real(wp), intent(in) :: rabc(3) - integer, intent(out) :: ipos - integer :: i, m, n21 - integer :: at2(n2), at12(n12) - integer :: counter - real(wp) :: xyz2(3, n2), xyz12(3, n12) - real(wp) :: etmp(100) - real(wp) :: eabc - real(wp) :: cma2(3) - real(wp), allocatable :: dist(:) - - eabc = 0 - counter = 0 - n21 = n12 - n2 + 1 - if (env%use_xtbiff) then - call rdxtbiffE('xtbscreen.xyz', m, n12, etmp) - else - call rdxtbiffE('best.xyz', m, n12, etmp) - end if - - allocate (dist(m), source=0.0d0) - dist = 0.0d0 - - do i = 1, m - if (env%use_xtbiff) then - call rdxmolselec('xtbscreen.xyz', i, n12, at12, xyz12) - else - call rdxmolselec('final_structures.xyz', i, n12, at12, xyz12) - end if +!==============================================================================! - at2(1:n2) = at12(n21:n12) - xyz2(1:3, 1:n2) = xyz12(1:3, n21:n12) - call cma(n2, at2, xyz2, cma2) - call calc_dist(cma2, rabc, dist(i), eabc) - if (eabc .gt. 1.0d0) then - dist(i) = 1.0d42 - counter = counter + 1 - end if - end do +subroutine fill_take(env,n2,n12,rabc,ipos) + use iso_fortran_env,only:wp => real64 + use crest_data + use strucrd + use axis_module,only:cma + implicit none + + type(systemdata) :: env + integer,intent(in) :: n2,n12 + real(wp),intent(in) :: rabc(3) + integer,intent(out) :: ipos + integer :: i,m,n21 + integer :: at2(n2),at12(n12) + integer :: counter + real(wp) :: xyz2(3,n2),xyz12(3,n12) + real(wp) :: etmp(100) + real(wp) :: eabc + real(wp) :: cma2(3) + real(wp),allocatable :: dist(:) + + eabc = 0 + counter = 0 + n21 = n12-n2+1 + if (env%use_xtbiff) then + call rdxtbiffE('xtbscreen.xyz',m,n12,etmp) + else + call rdxtbiffE('best.xyz',m,n12,etmp) + end if + + allocate (dist(m),source=0.0d0) + dist = 0.0d0 - ipos = minloc(dist(1:m), dim=1) + do i = 1,m + if (env%use_xtbiff) then + call rdxmolselec('xtbscreen.xyz',i,n12,at12,xyz12) + else + call rdxmolselec('final_structures.xyz',i,n12,at12,xyz12) + end if - if (counter .eq. m) ipos = 0 + at2(1:n2) = at12(n21:n12) + xyz2(1:3,1:n2) = xyz12(1:3,n21:n12) + call cma(n2,at2,xyz2,cma2) + call calc_dist(cma2,rabc,dist(i),eabc) + if (eabc .gt. 1.0d0) then + dist(i) = 1.0d42 + counter = counter+1 + end if + end do - deallocate (dist) + ipos = minloc(dist(1:m),dim=1) + + if (counter .eq. m) ipos = 0 + + deallocate (dist) end subroutine fill_take -subroutine calc_dist(xyz, rabc, dist, eabc) - use iso_fortran_env, only: wp => real64 - implicit none +!==============================================================================! + +subroutine calc_dist(xyz,rabc,dist,eabc) + use iso_fortran_env,only:wp => real64 + implicit none - real(wp), intent(in) :: xyz(3) - real(wp), intent(in) :: rabc(3) - real(wp), intent(out) :: dist - real(wp), intent(out) :: eabc - real(wp) :: center(3), rc(3) + real(wp),intent(in) :: xyz(3) + real(wp),intent(in) :: rabc(3) + real(wp),intent(out) :: dist + real(wp),intent(out) :: eabc + real(wp) :: center(3),rc(3) - center = 0.d0 - rc = (xyz(1:3) - center) - dist = norm2(rc) - eabc = sum((xyz(1:3)**2)/(rabc(1:3)**2)) + center = 0.d0 + rc = (xyz(1:3)-center) + dist = norm2(rc) + eabc = sum((xyz(1:3)**2)/(rabc(1:3)**2)) end subroutine calc_dist -subroutine sort_min(i, j, col, A) - use iso_fortran_env, only: wp => real64 - implicit none - integer, intent(in) :: i, j, col - real*8, intent(inout) :: A(i, j) - real*8 :: buf(j) - integer :: nsize, irow, krow +!==============================================================================! + +subroutine sort_min(i,j,col,A) + use iso_fortran_env,only:wp => real64 + implicit none + integer,intent(in) :: i,j,col + real*8,intent(inout) :: A(i,j) + real*8 :: buf(j) + integer :: nsize,irow,krow ! dimension A(i,j) - nsize = i - - do irow = 1, nsize - krow = minloc(A(irow:nsize, col), dim=1) + irow - 1 - buf(:) = A(irow, :) - A(irow, :) = A(krow, :) - A(krow, :) = buf(:) - end do + nsize = i + + do irow = 1,nsize + krow = minloc(A(irow:nsize,col),dim=1)+irow-1 + buf(:) = A(irow,:) + A(irow,:) = A(krow,:) + A(krow,:) = buf(:) + end do end subroutine sort_min -subroutine sort_ensemble(ens, e_ens, fname) - use iso_fortran_env, only: wp => real64 - use crest_data - use strucrd - implicit none - type(ensemble) :: ens - real(wp) :: e_ens(ens%nall), dum(ens%nall) - character(len=*) :: fname - integer :: ich - integer :: i, e_min +!==============================================================================! + +subroutine sort_ensemble(ens,e_ens,fname) + use iso_fortran_env,only:wp => real64 + use crest_data + use strucrd + implicit none + type(ensemble) :: ens + real(wp) :: e_ens(ens%nall),dum(ens%nall) + character(len=*) :: fname + integer :: ich + integer :: i,e_min - dum = e_ens + dum = e_ens - open (newunit=ich, file=fname) + open (newunit=ich,file=fname) - do i = 1, ens%nall - e_min = minloc(dum, dim=1) - call wrxyz(ich, ens%nat, ens%at, ens%xyz(:, :, e_min), e_ens(e_min)) - dum(e_min) = 0.0d0 - end do - close (ich) + do i = 1,ens%nall + e_min = minloc(dum,dim=1) + call wrxyz(ich,ens%nat,ens%at,ens%xyz(:,:,e_min),e_ens(e_min)) + dum(e_min) = 0.0d0 + end do + close (ich) end subroutine sort_ensemble -subroutine rdtherm(fname, ht, svib, srot, stra, gt) - use iso_fortran_env, only: wp => real64 - use crest_data - use iomod +!==============================================================================! + +subroutine rdtherm(fname,ht,svib,srot,stra,gt) + use iso_fortran_env,only:wp => real64 + use crest_data + use iomod - implicit none + implicit none ! Dummy - real(wp), intent(out) :: ht - real(wp), intent(out) :: gt - real(wp), intent(out) :: svib - real(wp), intent(out) :: srot - real(wp), intent(out) :: stra + real(wp),intent(out) :: ht + real(wp),intent(out) :: gt + real(wp),intent(out) :: svib + real(wp),intent(out) :: srot + real(wp),intent(out) :: stra ! Stack - integer :: nn - integer :: io - integer :: counter - integer :: hg_line - real(wp) :: xx(20) - logical :: ende - character(len=*) :: fname - character(len=128) :: a - real(wp), parameter :: eh = 627.509541d0 - integer :: ich - - ende = .false. - counter = 0 - hg_line = 0 - - open (newunit=ich, file=fname) - do while (.not. ende) - read (ich, '(a)', iostat=io) a - if (io .lt. 0) then - ende = .true. - cycle - end if - if (index(a, 'G(T)/Eh ') .ne. 0) then - hg_line = counter - end if - if (index(a, ' VIB ') .ne. 0) then - call readl(a, xx, nn) - svib = xx(5) - if (svib .eq. 0.0d0) then - call readl(a, xx, nn) - svib = xx(4) - end if - end if - if (index(a, ' ROT ') .ne. 0) then - call readl(a, xx, nn) - srot = xx(4) + integer :: nn + integer :: io + integer :: counter + integer :: hg_line + real(wp) :: xx(20) + logical :: ende + character(len=*) :: fname + character(len=128) :: a + real(wp),parameter :: eh = 627.509541d0 + integer :: ich + + ende = .false. + counter = 0 + hg_line = 0 + + open (newunit=ich,file=fname) + do while (.not.ende) + read (ich,'(a)',iostat=io) a + if (io .lt. 0) then + ende = .true. + cycle + end if + if (index(a,'G(T)/Eh ') .ne. 0) then + hg_line = counter + end if + if (index(a,' VIB ') .ne. 0) then + call readl(a,xx,nn) + svib = xx(5) + if (svib .eq. 0.0d0) then + call readl(a,xx,nn) + svib = xx(4) end if - if (index(a, ' TR ') .ne. 0) then - call readl(a, xx, nn) - stra = xx(4) - end if - if (counter .eq. hg_line + 2) then - call readl(a, xx, nn) - ht = xx(3)*eh - gt = xx(5)*eh - end if - counter = counter + 1 - end do - close (ich) + end if + if (index(a,' ROT ') .ne. 0) then + call readl(a,xx,nn) + srot = xx(4) + end if + if (index(a,' TR ') .ne. 0) then + call readl(a,xx,nn) + stra = xx(4) + end if + if (counter .eq. hg_line+2) then + call readl(a,xx,nn) + ht = xx(3)*eh + gt = xx(5)*eh + end if + counter = counter+1 + end do + close (ich) end subroutine rdtherm -subroutine pr_freq_file(ich) - implicit none - integer :: ich - write (ich, '(2x,"# H(T) SVIB SROT STRA G(T)")') - write (ich, '(2x," [kcal/mol] [ cal/mol/K ] [kcal/mol]")') - write (ich, '(2x,"--------------------------------------------------------")') -end subroutine pr_freq_file - -subroutine qcg_restart(env, progress, solu, solv, clus, solu_ens, solv_ens, clus_backup) - use iso_fortran_env, wp => real64 - use crest_data - use iomod - use zdata - use strucrd - - implicit none - - type(systemdata) :: env - type(zmolecule) :: solu, solv, clus, clus_backup - type(ensemble) :: solu_ens, solv_ens - integer :: progress - - integer :: i - character(len=512) :: thispath - character(len=6) :: counter - character(len=7) :: counter2 - character(len=8) :: counter3 - logical :: grow, solu_ensemble, solv_ensemble - logical :: solv_cff, solv_present, freq, tmp, ex - real(wp), allocatable :: xyz(:, :) - real(wp), parameter :: eh = 627.509541d0 - - grow = .false. - solu_ensemble = .false. - solv_ensemble = .false. - solv_cff = .false. - solv_present = .false. - freq = .false. - tmp = .false. - - inquire (file='./grow/cluster.coord', exist=grow) - inquire (file='./ensemble/final_ensemble.xyz', exist=solu_ensemble) - inquire (file='./solvent_ensemble/final_ensemble.xyz', exist=solv_ensemble) - inquire (file='./solvent_ensemble/crest_ensemble.xyz', exist=solv_cff) - inquire (file='./frequencies/result.dat', exist=freq) - - if (solv_cff .or. solv_ensemble) solv_present = .true. - - call getcwd(thispath) + +!==============================================================================! + +subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup) + use iso_fortran_env,wp => real64 + use crest_data + use iomod + use zdata + use strucrd + + implicit none + + type(systemdata) :: env + type(zmolecule) :: solu,solv,clus,clus_backup + type(ensemble) :: solu_ens,solv_ens + integer :: progress + + integer :: i + character(len=512) :: thispath + character(len=6) :: counter + character(len=7) :: counter2 + character(len=8) :: counter3 + logical :: grow,solu_ensemble,solv_ensemble + logical :: solv_cff,solv_present,freq,tmp,ex + real(wp),allocatable :: xyz(:,:) + real(wp),parameter :: eh = 627.509541d0 + + grow = .false. + solu_ensemble = .false. + solv_ensemble = .false. + solv_cff = .false. + solv_present = .false. + freq = .false. + tmp = .false. + + inquire (file='./grow/cluster.coord',exist=grow) + inquire (file='./ensemble/final_ensemble.xyz',exist=solu_ensemble) + inquire (file='./solvent_ensemble/final_ensemble.xyz',exist=solv_ensemble) + inquire (file='./solvent_ensemble/crest_ensemble.xyz',exist=solv_cff) + inquire (file='./frequencies/result.dat',exist=freq) + + if (solv_cff.or.solv_ensemble) solv_present = .true. + + call getcwd(thispath) !--------------------------------------------------------------------------------- ! Check, if everything needed is present !--------------------------------------------------------------------------------- - if (freq .and. ((.not. grow) .or. (.not. solu_ensemble) .or. (.not. solv_ensemble))) then - progress = 0 - call rmrf('frequencies') - freq = .false. - end if + if (freq.and.((.not.grow).or.(.not.solu_ensemble).or.(.not.solv_ensemble))) then + progress = 0 + call rmrf('frequencies') + freq = .false. + end if - if (solv_present .and. ((.not. grow) .or. (.not. solu_ensemble))) then - progress = 0 - call rmrf('solvent_ensemble') - solv_present = .false. - solv_cff = .false. - solv_ensemble = .false. - end if + if (solv_present.and.((.not.grow).or.(.not.solu_ensemble))) then + progress = 0 + call rmrf('solvent_ensemble') + solv_present = .false. + solv_cff = .false. + solv_ensemble = .false. + end if - if (solu_ensemble .and. (.not. grow)) then - progress = 0 - call rmrf('ensemble') - solu_ensemble = .false. - end if + if (solu_ensemble.and.(.not.grow)) then + progress = 0 + call rmrf('ensemble') + solu_ensemble = .false. + end if !------------------------------------------------------------- ! Data read out !------------------------------------------------------------- !--- Grow process - if (grow) then - env%qcg_restart = .true. - call chdir('grow') - call rdnat('cluster.coord', clus%nat) - allocate (clus%at(clus%nat), clus%xyz(3, clus%nat)) - call rdcoord('cluster.coord', clus%nat, clus%at, clus%xyz) - clus%nmol = (clus%nat - solu%nat)/solv%nat + 1 - allocate (xyz(3, clus%nat)) - xyz = clus%xyz - call get_ellipsoid(env, solu, solv, clus, .true.) - clus%xyz = xyz !Needed, because get_ellipsoid performs axistransformation and not fitting potential - deallocate (xyz) - - if (.not. env%cff) then - allocate (clus_backup%at(clus%nat)) - allocate (clus_backup%xyz(3, clus%nat)) - clus_backup = clus - end if - - if (clus%nmol - 1 .ge. env%nsolv) then - progress = 1 - env%nsolv = clus%nmol - 1 - write (*, *) - write (*, *) - write (*, '(''Found cluster with '',i0,'' solvents'')') env%nsolv - call chdir(thispath) - else - error stop 'The found cluster is smaller than nsolv. Please restart the whole computaion by removing the grow directory' - !Future implementation continue grow process - call chdir(thispath) - if (solu_ensemble) call rmrf('ensemble') - if (solv_ensemble) call rmrf('solvent_ensemble') - if (freq) call rmrf('frequencies') - solu_ensemble = .false. - solv_ensemble = .false. - freq = .false. - progress = 0 - end if - end if + if (grow) then + env%qcg_restart = .true. + call chdir('grow') + call rdnat('cluster.coord',clus%nat) + allocate (clus%at(clus%nat),clus%xyz(3,clus%nat)) + call rdcoord('cluster.coord',clus%nat,clus%at,clus%xyz) + clus%nmol = (clus%nat-solu%nat)/solv%nat+1 + allocate (xyz(3,clus%nat)) + xyz = clus%xyz + call get_ellipsoid(env,solu,solv,clus,.true.) + clus%xyz = xyz !Needed, because get_ellipsoid performs axistransformation and not fitting potential + deallocate (xyz) + + if (.not.env%cff) then + allocate (clus_backup%at(clus%nat)) + allocate (clus_backup%xyz(3,clus%nat)) + clus_backup = clus + end if + + if (clus%nmol-1 .ge. env%nsolv) then + progress = 1 + env%nsolv = clus%nmol-1 + write (*,*) + write (*,*) + write (*,'(''Found cluster with '',i0,'' solvents'')') env%nsolv + call chdir(thispath) + else + error stop 'The found cluster is smaller than nsolv. Please restart the whole computaion by removing the grow directory' + !Future implementation continue grow process + call chdir(thispath) + if (solu_ensemble) call rmrf('ensemble') + if (solv_ensemble) call rmrf('solvent_ensemble') + if (freq) call rmrf('frequencies') + solu_ensemble = .false. + solv_ensemble = .false. + freq = .false. + progress = 0 + end if + end if !--- Solute Ensemble - if (solu_ensemble) then - call chdir('ensemble') - call solu_ens%open('final_ensemble.xyz') - call rdensemble('final_ensemble.xyz', solu_ens%nat, solu_ens%nall, solu_ens%at, solu_ens%xyz, solu_ens%er) - env%nqcgclust = solu_ens%nall - write (*, '(" Ensemble of solute-cluster found.")') - write (*, '(" Taking all ", i0, " structures")') env%nqcgclust - call grepval('population.dat', 'Ensemble free energy [Eh]:', ex, solu_ens%G) - solu_ens%G = solu_ens%G*eh - write (*, *) 'Solute Ensmeble Free E [kcal/mol]', solu_ens%G - call chdir(thispath) - progress = 2 - end if + if (solu_ensemble) then + call chdir('ensemble') + call solu_ens%open('final_ensemble.xyz') + call rdensemble('final_ensemble.xyz',solu_ens%nat,solu_ens%nall,solu_ens%at,solu_ens%xyz,solu_ens%er) + env%nqcgclust = solu_ens%nall + write (*,'(" Ensemble of solute-cluster found.")') + write (*,'(" Taking all ", i0, " structures")') env%nqcgclust + call grepval('population.dat','Ensemble free energy [Eh]:',ex,solu_ens%G) + solu_ens%G = solu_ens%G*eh + write (*,*) 'Solute Ensmeble Free E [kcal/mol]',solu_ens%G + call chdir(thispath) + progress = 2 + end if !--- Solvent Ensemble - if (solv_present) then - call chdir('solvent_ensemble') - write (*, '(" Ensemble of solvent-cluster found.")') - - !--- Case CFF - if (solv_cff) then - call solv_ens%open('crest_ensemble.xyz') - do i = 1, solv_ens%nall - if (i .le. 9) then - write (counter, '(''No '',i1)') i - call grepval('cluster_energy.dat', counter, ex, solv_ens%er(i)) - else if (i .le. 99) then - write (counter2, '(''No '',i2)') i - call grepval('cluster_energy.dat', counter2, ex, solv_ens%er(i)) - else - write (counter3, '(''No '',i3)') i - call grepval('cluster_energy.dat', counter3, ex, solv_ens%er(i)) - end if - write (*, *) 'Energy of cluster', i, solv_ens%er(i) - end do - end if - - !--- Case MD/Crest run - if (solv_ensemble) then - call solv_ens%open('final_ensemble.xyz') - call rdensemble('final_ensemble.xyz', solv_ens%nat, solv_ens%nall, solv_ens%at, solv_ens%xyz, solv_ens%er) - end if - call grepval('population.dat', 'Ensemble free energy [Eh]:', ex, solv_ens%G) - solv_ens%G = solv_ens%G*eh - write (*, *) 'solvent ensmeble free E [kcal/mol]', solv_ens%G - call chdir(thispath) - progress = 3 - end if + if (solv_present) then + call chdir('solvent_ensemble') + write (*,'(" Ensemble of solvent-cluster found.")') + + !--- Case CFF + if (solv_cff) then + call solv_ens%open('crest_ensemble.xyz') + do i = 1,solv_ens%nall + if (i .le. 9) then + write (counter,'(''No '',i1)') i + call grepval('cluster_energy.dat',counter,ex,solv_ens%er(i)) + else if (i .le. 99) then + write (counter2,'(''No '',i2)') i + call grepval('cluster_energy.dat',counter2,ex,solv_ens%er(i)) + else + write (counter3,'(''No '',i3)') i + call grepval('cluster_energy.dat',counter3,ex,solv_ens%er(i)) + end if + write (*,*) 'Energy of cluster',i,solv_ens%er(i) + end do + end if + + !--- Case MD/Crest run + if (solv_ensemble) then + call solv_ens%open('final_ensemble.xyz') + call rdensemble('final_ensemble.xyz',solv_ens%nat,solv_ens%nall,solv_ens%at,solv_ens%xyz,solv_ens%er) + end if + call grepval('population.dat','Ensemble free energy [Eh]:',ex,solv_ens%G) + solv_ens%G = solv_ens%G*eh + write (*,*) 'solvent ensmeble free E [kcal/mol]',solv_ens%G + call chdir(thispath) + progress = 3 + end if !--- Frequencies - if (freq) then - write (*, *) - write (*, *) - write (*, *) ' Nothing to do' - progress = 4 - end if + if (freq) then + write (*,*) + write (*,*) + write (*,*) ' Nothing to do' + progress = 4 + end if end subroutine qcg_restart +!==============================================================================! +! subroutine qcg_cleanup(env) - use crest_data + use crest_data - implicit none + implicit none - type(systemdata) :: env - character(len=280) :: thispath - logical :: tmp + type(systemdata) :: env + character(len=280) :: thispath + logical :: tmp - call getcwd(thispath) - call chdir(env%scratchdir) - inquire (file='./solute_properties/solute', exist=tmp) - if (tmp) then - call rmrf('solute_properties') - call rmrf('solvent_properties') - end if + call getcwd(thispath) + call chdir(env%scratchdir) + inquire (file='./solute_properties/solute',exist=tmp) + if (tmp) then + call rmrf('solute_properties') + call rmrf('solvent_properties') + end if end subroutine qcg_cleanup -subroutine write_reference(env, solu, clus) - use iso_fortran_env, wp => real64 - use crest_data - use zdata, only: zmolecule - use iomod - use strucrd - - implicit none - type(systemdata):: env ! MAIN STORAGE OS SYSTEM DATA - type(zmolecule) :: solu, clus - type(zmolecule) :: ref_mol, ref_clus - - ref_mol = solu - call rdcoord(env%solu_file, ref_mol%nat, ref_mol%at, ref_mol%xyz) !original solute coordinates - call remove(env%fixfile) - ref_clus = clus - ref_clus%xyz(1:3, 1:solu%nat) = solu%xyz - call wrc0(env%fixfile, ref_clus%nat, ref_clus%at, ref_clus%xyz) +!==============================================================================! -end subroutine write_reference +subroutine write_reference(env,solu,clus) + use iso_fortran_env,wp => real64 + use crest_data + use zdata,only:zmolecule + use iomod + use strucrd + + implicit none + type(systemdata):: env ! MAIN STORAGE OS SYSTEM DATA + type(zmolecule) :: solu,clus + type(zmolecule) :: ref_mol,ref_clus + ref_mol = solu + call rdcoord(env%solu_file,ref_mol%nat,ref_mol%at,ref_mol%xyz) !original solute coordinates + call remove(env%fixfile) + ref_clus = clus + ref_clus%xyz(1:3,1:solu%nat) = solu%xyz + call wrc0(env%fixfile,ref_clus%nat,ref_clus%at,ref_clus%xyz) + +end subroutine write_reference !========================================================================================! !> Convert given QCG coordinate files into (TM format) !> Write "solute" and "solvent" coordinate files !========================================================================================! -subroutine inputcoords_qcg(env, solute, solvent) +subroutine inputcoords_qcg(env,solute,solvent) use iso_fortran_env,only:wp => real64 use crest_data use strucrd @@ -3330,8 +3237,8 @@ subroutine inputcoords_qcg(env, solute, solvent) use iomod implicit none - type(systemdata), intent(inout) :: env - type(zmolecule), intent(out) :: solute, solvent + type(systemdata),intent(inout) :: env + type(zmolecule),intent(out) :: solute,solvent logical :: ex11,ex21,solu,solv type(coord) :: mol @@ -3344,9 +3251,9 @@ subroutine inputcoords_qcg(env, solute, solvent) inquire (file=env%solu_file,exist=ex11) inquire (file='solute',exist=solu) if (solu) call copy('solute','solute.old') !Backup solute file - if ((.not. ex11) .and. (.not. solu)) then + if ((.not.ex11).and.(.not.solu)) then error stop 'No (valid) solute file! exit.' - else if ((.not. ex11) .and. (solu)) then + else if ((.not.ex11).and.(solu)) then env%solu_file = 'solute' end if @@ -3354,9 +3261,9 @@ subroutine inputcoords_qcg(env, solute, solvent) inquire (file=env%solv_file,exist=ex21) inquire (file='solvent',exist=solv) if (solu) call copy('solvent','solvent.old') !Backup solvent file - if ((.not. ex21) .and. (.not. solv)) then + if ((.not.ex21).and.(.not.solv)) then error stop 'No (valid) solvent file! exit.' - else if ((.not. ex11) .and. (solu)) then + else if ((.not.ex11).and.(solu)) then env%solu_file = 'solvent' end if @@ -3393,3 +3300,5 @@ subroutine inputcoords_qcg(env, solute, solvent) return end subroutine inputcoords_qcg + +!==============================================================================! diff --git a/src/qcg/solvtool_misc.f90 b/src/qcg/solvtool_misc.f90 index 3ff1ca92..7dd1724a 100644 --- a/src/qcg/solvtool_misc.f90 +++ b/src/qcg/solvtool_misc.f90 @@ -20,84 +20,84 @@ !-------------------------------------------------------------------------------------------- ! A quick single point xtb calculation without wbo !-------------------------------------------------------------------------------------------- -subroutine xtb_sp_qcg(env, fname) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - implicit none - character(len=*) :: fname - type(systemdata) :: env - character(len=512) :: jobcall - character(*), parameter :: pipe = ' > xtb.out 2> /dev/null' - integer :: io,T,Tn - call remove('gfnff_topo') - call remove('energy') - call remove('charges') - call remove('xtbrestart') +subroutine xtb_sp_qcg(env,fname) + use iso_fortran_env,only:wp => real64 + use iomod + use crest_data + implicit none + character(len=*) :: fname + type(systemdata) :: env + character(len=512) :: jobcall + character(*),parameter :: pipe = ' > xtb.out 2> /dev/null' + integer :: io,T,Tn + call remove('gfnff_topo') + call remove('energy') + call remove('charges') + call remove('xtbrestart') !---- setting threads - call new_ompautoset(env,'auto',1,T,Tn) + call new_ompautoset(env,'auto',1,T,Tn) !---- jobcall - write (jobcall, '(a,1x,a,1x,a,'' --sp '',a,1x,a)') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), trim(env%solv), trim(pipe) + write (jobcall,'(a,1x,a,1x,a,'' --sp '',a,1x,a)') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) - call command(trim(jobcall), io) + call command(trim(jobcall),io) !---- cleanup - call remove('energy') - call remove('charges') - call remove('xtbrestart') - call remove('xtbtopo.mol') - call remove('gfnff_topo') + call remove('energy') + call remove('charges') + call remove('xtbrestart') + call remove('xtbtopo.mol') + call remove('gfnff_topo') end subroutine xtb_sp_qcg !-------------------------------------------------------------------------------------------- ! A quick single xtb optimization gets zmol and overwrites it with optimized stuff !-------------------------------------------------------------------------------------------- -subroutine xtb_opt_qcg(env, zmol, constrain) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use zdata - use strucrd - - implicit none - type(systemdata), intent(in) :: env - type(zmolecule), intent(inout) :: zmol - - character(:), allocatable :: fname - character(len=512) :: jobcall - logical :: constrain - logical :: const - character(*), parameter :: pipe = ' > xtb_opt.out 2> /dev/null' - integer :: io,T,Tn +subroutine xtb_opt_qcg(env,zmol,constrain) + use iso_fortran_env,only:wp => real64 + use iomod + use crest_data + use zdata + use strucrd + + implicit none + type(systemdata),intent(in) :: env + type(zmolecule),intent(inout) :: zmol + + character(:),allocatable :: fname + character(len=512) :: jobcall + logical :: constrain + logical :: const + character(*),parameter :: pipe = ' > xtb_opt.out 2> /dev/null' + integer :: io,T,Tn !--- Write coordinated - fname = 'coord' - call wrc0(fname, zmol%nat, zmol%at, zmol%xyz) !write coord for xtbopt routine + fname = 'coord' + call wrc0(fname,zmol%nat,zmol%at,zmol%xyz) !write coord for xtbopt routine !---- setting threads - call new_ompautoset(env,'auto',1,T,Tn) + call new_ompautoset(env,'auto',1,T,Tn) !---- jobcall & Handling constraints - if(constrain .AND. env%cts%used) then - call write_constraint(env, fname, 'xcontrol') - call wrc0('coord.ref', zmol%nat, zmol%at, zmol%xyz) !write coord for xtbopt routine - write (jobcall, '(a,1x,a,1x,a,'' --opt --input xcontrol '',a,1x,a)') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), trim(env%solv), trim(pipe) - else - write (jobcall, '(a,1x,a,1x,a,'' --opt '',a,1x,a)') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), trim(env%solv), trim(pipe) - end if - - call command(trim(jobcall), io) + if (constrain.AND.env%cts%used) then + call write_constraint(env,fname,'xcontrol') + call wrc0('coord.ref',zmol%nat,zmol%at,zmol%xyz) !write coord for xtbopt routine + write (jobcall,'(a,1x,a,1x,a,'' --opt --input xcontrol '',a,1x,a)') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) + else + write (jobcall,'(a,1x,a,1x,a,'' --opt '',a,1x,a)') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) + end if + + call command(trim(jobcall),io) !---- cleanup - call rdcoord('xtbopt.coord', zmol%nat, zmol%at, zmol%xyz) - call remove('energy') - call remove('charges') - call remove('xtbrestart') - call remove('xtbtopo.mol') - call remove('gfnff_topo') + call rdcoord('xtbopt.coord',zmol%nat,zmol%at,zmol%xyz) + call remove('energy') + call remove('charges') + call remove('xtbrestart') + call remove('xtbtopo.mol') + call remove('gfnff_topo') end subroutine xtb_opt_qcg !___________________________________________________________________________________ @@ -105,40 +105,40 @@ end subroutine xtb_opt_qcg ! An xTB single point calculation and lmo generation on all available threads !___________________________________________________________________________________ -subroutine xtb_lmo(env, fname)!,chrg) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use zdata - implicit none - type(systemdata) :: env - character(len=*), intent(in) :: fname - character(len=80) :: pipe - character(len=512) :: jobcall - integer :: T,Tn,io +subroutine xtb_lmo(env,fname)!,chrg) + use iso_fortran_env,only:wp => real64 + use iomod + use crest_data + use zdata + implicit none + type(systemdata) :: env + character(len=*),intent(in) :: fname + character(len=80) :: pipe + character(len=512) :: jobcall + integer :: T,Tn,io - pipe = ' > xtb.out 2>/dev/null' + pipe = ' > xtb.out 2>/dev/null' !---- setting threads - call new_ompautoset(env,'auto',1,T,Tn) + call new_ompautoset(env,'auto',1,T,Tn) !---- jobcall, special gbsa treatment not needed, as the entire flag is included in env%solv - write (jobcall, '(a,1x,a,1x,a,'' --sp --lmo '',a)') & - & trim(env%ProgName), trim(fname), trim(env%lmover), trim(pipe) - call command(trim(jobcall), exitstat=io) - - if(io /= 0)then - write(*,*) 'error in xtb_lmo' - stop - endif + write (jobcall,'(a,1x,a,1x,a,'' --sp --lmo '',a)') & + & trim(env%ProgName),trim(fname),trim(env%lmover),trim(pipe) + call command(trim(jobcall),exitstat=io) + + if (io /= 0) then + write (*,*) 'error in xtb_lmo' + stop + end if !--- cleanup - call remove('wbo') - call remove('charges') - call remove('xtbrestart') - call remove('xtbscreen.xyz') - call remove('lmocent.coord') - call remove('coordprot.0') + call remove('wbo') + call remove('charges') + call remove('xtbrestart') + call remove('xtbscreen.xyz') + call remove('lmocent.coord') + call remove('coordprot.0') end subroutine xtb_lmo !___________________________________________________________________________________ @@ -146,42 +146,42 @@ end subroutine xtb_lmo ! An xTB-IFF calculation on all available threads !___________________________________________________________________________________ -subroutine xtb_iff(env, file_lmo1, file_lmo2, solu, clus) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use zdata +subroutine xtb_iff(env,file_lmo1,file_lmo2,solu,clus) + use iso_fortran_env,only:wp => real64 + use iomod + use crest_data + use zdata - implicit none + implicit none - type(systemdata) :: env - type(zmolecule), intent(in) :: solu, clus - character(len=80) :: pipe - character(len=512) :: jobcall - character(len=*) :: file_lmo1, file_lmo2 - integer :: T,Tn + type(systemdata) :: env + type(zmolecule),intent(in) :: solu,clus + character(len=80) :: pipe + character(len=512) :: jobcall + character(len=*) :: file_lmo1,file_lmo2 + integer :: T,Tn !--- Option setting - pipe = ' > iff.out 2>/dev/null' + pipe = ' > iff.out 2>/dev/null' !--- Setting threads - call new_ompautoset(env,'auto',1,T,Tn) + call new_ompautoset(env,'auto',1,T,Tn) !--- Jobcall - if (env%sameRandomNumber) then - write (jobcall, '(a,1x,a,1x,a,'' -nfrag1 '',i3,'' -ellips '',3f9.3,'' -qcg -test '',a)') & - & trim(env%ProgIFF), trim(file_lmo1), trim(file_lmo2), solu%nat, clus%ell_abc, trim(pipe) - else - write (jobcall, '(a,1x,a,1x,a,'' -nfrag1 '',i3,'' -ellips '',3f9.3,'' -qcg '',a)') & - & trim(env%ProgIFF), trim(file_lmo1), trim(file_lmo2), solu%nat, clus%ell_abc, trim(pipe) + if (env%sameRandomNumber) then + write (jobcall,'(a,1x,a,1x,a,'' -nfrag1 '',i3,'' -ellips '',3f9.3,'' -qcg -test '',a)') & + & trim(env%ProgIFF),trim(file_lmo1),trim(file_lmo2),solu%nat,clus%ell_abc,trim(pipe) + else + write (jobcall,'(a,1x,a,1x,a,'' -nfrag1 '',i3,'' -ellips '',3f9.3,'' -qcg '',a)') & + & trim(env%ProgIFF),trim(file_lmo1),trim(file_lmo2),solu%nat,clus%ell_abc,trim(pipe) ! & trim(env%ProgIFF),trim(solvent_file),trim(solute_file),solu%nat,clus%ell_abc,trim(pipe) - end if - call command(trim(jobcall)) + end if + call command(trim(jobcall)) !--- Cleanup - call remove('xtbiff_bestsofar.xyz') - call remove('xtbiff_genstart.xyz') - call remove('xtbrestart') + call remove('xtbiff_bestsofar.xyz') + call remove('xtbiff_genstart.xyz') + call remove('xtbrestart') end subroutine xtb_iff @@ -190,58 +190,58 @@ end subroutine xtb_iff ! An xTB docking on all available threads !___________________________________________________________________________________ -subroutine xtb_dock(env, fnameA, fnameB, solu, clus) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use zdata +subroutine xtb_dock(env,fnameA,fnameB,solu,clus) + use iso_fortran_env,only:wp => real64 + use iomod + use crest_data + use zdata - implicit none + implicit none - type(systemdata) :: env - type(zmolecule), intent(in) :: solu, clus - character(len=*), intent(in) :: fnameA, fnameB - character(len=80) :: pipe - character(len=512) :: jobcall - integer :: i, ich, T, Tn + type(systemdata) :: env + type(zmolecule),intent(in) :: solu,clus + character(len=*),intent(in) :: fnameA,fnameB + character(len=80) :: pipe + character(len=512) :: jobcall + integer :: i,ich,T,Tn - call remove('xtb_dock.out') - call remove('xcontrol') + call remove('xtb_dock.out') + call remove('xcontrol') - pipe = ' 2>/dev/null' + pipe = ' 2>/dev/null' !---- writing wall pot in xcontrol - call write_wall(env, solu%nat, solu%ell_abc, clus%ell_abc, 'xcontrol') + call write_wall(env,solu%nat,solu%ell_abc,clus%ell_abc,'xcontrol') !---- Write directed stuff, if requested - if (allocated(env%directed_file)) then - do i=1, size(env%directed_number) - if & - & ((i==1 .and. env%directed_number(i) >= clus%nmol) .OR. & - & (env%directed_number(i) >= clus%nmol .and. env%directed_number(i-1) < clus%nmol)) & - & then - open(newunit=ich, file='xcontrol', status='old', position='append', action='write') - write(ich,'("$directed")') - write(ich,'(a,1x,a)') 'atoms:', trim(env%directed_list(i,1)) - write(ich,'("$end")') - end if - end do - end if + if (allocated(env%directed_file)) then + do i = 1,size(env%directed_number) + if & + & ((i == 1.and.env%directed_number(i) >= clus%nmol).OR. & + & (env%directed_number(i) >= clus%nmol.and.env%directed_number(i-1) < clus%nmol)) & + & then + open (newunit=ich,file='xcontrol',status='old',position='append',action='write') + write (ich,'("$directed")') + write (ich,'(a,1x,a)') 'atoms:',trim(env%directed_list(i,1)) + write (ich,'("$end")') + end if + end do + end if !--- Setting threads - call new_ompautoset(env,'auto',1,T,Tn) + call new_ompautoset(env,'auto',1,T,Tn) !--- Jobcall docking - write (jobcall, '(a,1x,''dock'',1x,a,1x,a,1x,a,1x,f4.2,1x,''--nfrag1'',1x,i0,1x,a,1x, & - & ''--input xcontrol > xtb_dock.out'',a)') & - & trim(env%ProgName), trim(fnameA), trim(fnameB), trim(env%gfnver),& - & env%optlev, solu%nat, trim(env%docking_qcg_flag), trim(pipe) - call command(trim(jobcall)) + write (jobcall,'(a,1x,''dock'',1x,a,1x,a,1x,a,1x,f4.2,1x,''--nfrag1'',1x,i0,1x,a,1x, & + & ''--input xcontrol > xtb_dock.out'',a)') & + & trim(env%ProgName),trim(fnameA),trim(fnameB),trim(env%gfnver),& + & env%optlev,solu%nat,trim(env%docking_qcg_flag),trim(pipe) + call command(trim(jobcall)) ! cleanup - call remove('wbo') - call remove('charges') - call remove('xtbrestart') + call remove('wbo') + call remove('charges') + call remove('xtbrestart') end subroutine xtb_dock @@ -250,63 +250,63 @@ end subroutine xtb_dock ! An xTB optimization on all available threads !___________________________________________________________________________________ -subroutine opt_cluster(env, solu, clus, fname, without_pot) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use zdata +subroutine opt_cluster(env,solu,clus,fname,without_pot) + use iso_fortran_env,only:wp => real64 + use iomod + use crest_data + use zdata - implicit none + implicit none - type(systemdata) :: env - type(zmolecule), intent(in) :: solu, clus - character(len=*), intent(in) :: fname - logical, optional, intent(in) :: without_pot - character(len=80) :: pipe - character(len=:),allocatable :: jobcall - integer :: T,Tn + type(systemdata) :: env + type(zmolecule),intent(in) :: solu,clus + character(len=*),intent(in) :: fname + logical,optional,intent(in) :: without_pot + character(len=80) :: pipe + character(len=:),allocatable :: jobcall + integer :: T,Tn - if (env%niceprint) then - call printprogbar(0.0_wp) - end if + if (env%niceprint) then + call printprogbar(0.0_wp) + end if - call remove('xtb.out') - pipe = ' 2>/dev/null' + call remove('xtb.out') + pipe = ' 2>/dev/null' !---- writing wall pot in xcontrol - if (.not. without_pot) then - call write_wall(env, solu%nat, solu%ell_abc, clus%ell_abc, 'xcontrol') - end if + if (.not.without_pot) then + call write_wall(env,solu%nat,solu%ell_abc,clus%ell_abc,'xcontrol') + end if !--- Setting threads - call new_ompautoset(env,'subprocess',1,T,Tn) + call new_ompautoset(env,'subprocess',1,T,Tn) !--- Jobcall optimization - jobcall = trim(env%ProgName)//' '//trim(fname)//' --opt '//optlevflag(env%optlev) - jobcall = trim(jobcall)//' '//trim(env%gfnver) - if(without_pot)then - jobcall = trim(jobcall)//' '//trim(env%solv) - endif - jobcall = trim(jobcall)//' > xtb_opt.out 2>/dev/null' - call command(trim(jobcall)) + jobcall = trim(env%ProgName)//' '//trim(fname)//' --opt '//optlevflag(env%optlev) + jobcall = trim(jobcall)//' '//trim(env%gfnver) + if (without_pot) then + jobcall = trim(jobcall)//' '//trim(env%solv) + end if + jobcall = trim(jobcall)//' > xtb_opt.out 2>/dev/null' + call command(trim(jobcall)) ! cleanup - call remove('wbo') - call remove('charges') - call remove('xtbrestart') + call remove('wbo') + call remove('charges') + call remove('xtbrestart') !--- Jobcall SP for gbsa model - if (.not. without_pot) then - jobcall = trim(env%ProgName)//' xtbopt.coord --sp '//trim(env%gfnver) - jobcall = trim(jobcall)//' '//trim(env%solv) - jobcall = trim(jobcall)//' > xtb_sp.out 2>/dev/null' - end if - call command(trim(jobcall)) + if (.not.without_pot) then + jobcall = trim(env%ProgName)//' xtbopt.coord --sp '//trim(env%gfnver) + jobcall = trim(jobcall)//' '//trim(env%solv) + jobcall = trim(jobcall)//' > xtb_sp.out 2>/dev/null' + end if + call command(trim(jobcall)) ! cleanup - call remove('wbo') - call remove('charges') - call remove('xtbrestart') + call remove('wbo') + call remove('charges') + call remove('xtbrestart') end subroutine opt_cluster @@ -315,65 +315,65 @@ end subroutine opt_cluster ! xTB LMO calculation performed in parallel !___________________________________________________________________________________ -subroutine ensemble_lmo(env, fname, self, NTMP, TMPdir, conv) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use zdata - - implicit none - type(systemdata) :: env - type(zmolecule), intent(in) :: self - character(len=*), intent(in) :: fname !file base name - character(len=*), intent(in) :: TMPdir !directory name - integer, intent(in) :: NTMP !number of structures to be optimized - integer, intent(in) :: conv(env%nqcgclust + 1) - integer :: i, k,T, Tn - integer :: vz - character(len=20) :: pipe - character(len=512) :: thispath, tmppath - character(len=1024) :: jobcall - real(wp) :: percent +subroutine ensemble_lmo(env,fname,self,NTMP,TMPdir,conv) + use iso_fortran_env,only:wp => real64 + use iomod + use crest_data + use zdata + + implicit none + type(systemdata) :: env + type(zmolecule),intent(in) :: self + character(len=*),intent(in) :: fname !file base name + character(len=*),intent(in) :: TMPdir !directory name + integer,intent(in) :: NTMP !number of structures to be optimized + integer,intent(in) :: conv(env%nqcgclust+1) + integer :: i,k,T,Tn + integer :: vz + character(len=20) :: pipe + character(len=512) :: thispath,tmppath + character(len=1024) :: jobcall + real(wp) :: percent ! setting the threads for correct parallelization - call new_ompautoset(env,'auto',NTMP,T,Tn) + call new_ompautoset(env,'auto',NTMP,T,Tn) - pipe = '2>/dev/null' + pipe = '2>/dev/null' - !create the system call (it is the same for every optimization) + !create the system call (it is the same for every optimization) - write (jobcall, '(a,1x,a,1x,a,'' --sp --lmo --chrg '',f4.1,1x,a,'' >xtb_lmo.out'')') & - & trim(env%ProgName), trim(fname), trim(env%lmover), self%chrg, trim(pipe) - k = 0 !counting the finished jobs + write (jobcall,'(a,1x,a,1x,a,'' --sp --lmo --chrg '',f4.1,1x,a,'' >xtb_lmo.out'')') & + & trim(env%ProgName),trim(fname),trim(env%lmover),self%chrg,trim(pipe) + k = 0 !counting the finished jobs !___________________________________________________________________________________ !$omp parallel & !$omp shared( vz,jobcall,NTMP,percent,k,TMPdir,conv ) !$omp single - do i = 1, NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath ) - write (tmppath, '(a,i0)') trim(TMPdir), conv(vz) - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical - k = k + 1 - percent = float(k)/float(NTMP)*100 - !$omp end critical - !$omp end task - end do + do i = 1,NTMP + vz = i + !$omp task firstprivate( vz ) private( tmppath ) + write (tmppath,'(a,i0)') trim(TMPdir),conv(vz) + call command('cd '//trim(tmppath)//' && '//trim(jobcall)) + !$omp critical + k = k+1 + percent = float(k)/float(NTMP)*100 + !$omp end critical + !$omp end task + end do !$omp taskwait !$omp end single !$omp end parallel !___________________________________________________________________________________ - call getcwd(thispath) - do i = 1, NTMP - write (tmppath, '(a,i0)') trim(TMPdir), i - call chdir(trim(tmppath)) - call remove('xtbrestart') - call chdir(trim(thispath)) - end do + call getcwd(thispath) + do i = 1,NTMP + write (tmppath,'(a,i0)') trim(TMPdir),i + call chdir(trim(tmppath)) + call remove('xtbrestart') + call chdir(trim(thispath)) + end do end subroutine ensemble_lmo @@ -382,61 +382,61 @@ end subroutine ensemble_lmo ! xTB-IFF calculation performed in parallel !___________________________________________________________________________________ -subroutine ensemble_iff(env, outer_ell_abc, nfrag1, frag1_file, frag2_file, NTMP, TMPdir, conv) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use zdata - - implicit none - type(systemdata) :: env - - character(len=*), intent(in) :: TMPdir !directory name - integer, intent(in) :: NTMP !number of structures to be optimized - integer, intent(in) :: nfrag1 !#atoms of larger fragment - integer, intent(in) :: conv(env%nqcgclust + 1) - real(wp), intent(in) :: outer_ell_abc(env%nqcgclust, 3) - - integer :: i, k - integer :: vz,T,Tn - character(len=20) :: pipe - character(len=512) :: tmppath - character(len=1024) :: jobcall - character(len=64), intent(in) :: frag1_file - character(len=64), intent(in) :: frag2_file - character(len=64) :: frag1 - character(len=64) :: frag2 - real(wp) :: percent +subroutine ensemble_iff(env,outer_ell_abc,nfrag1,frag1_file,frag2_file,NTMP,TMPdir,conv) + use iso_fortran_env,only:wp => real64 + use iomod + use crest_data + use zdata + + implicit none + type(systemdata) :: env + + character(len=*),intent(in) :: TMPdir !directory name + integer,intent(in) :: NTMP !number of structures to be optimized + integer,intent(in) :: nfrag1 !#atoms of larger fragment + integer,intent(in) :: conv(env%nqcgclust+1) + real(wp),intent(in) :: outer_ell_abc(env%nqcgclust,3) + + integer :: i,k + integer :: vz,T,Tn + character(len=20) :: pipe + character(len=512) :: tmppath + character(len=1024) :: jobcall + character(len=64),intent(in) :: frag1_file + character(len=64),intent(in) :: frag2_file + character(len=64) :: frag1 + character(len=64) :: frag2 + real(wp) :: percent ! some options - pipe = '2>/dev/null' - frag1 = 'solvent_cluster.lmo' - frag2 = 'solvent.lmo' + pipe = '2>/dev/null' + frag1 = 'solvent_cluster.lmo' + frag2 = 'solvent.lmo' ! setting the threads for correct parallelization - call new_ompautoset(env,'auto',NTMP,T,Tn) + call new_ompautoset(env,'auto',NTMP,T,Tn) - k = 0 !counting the finished jobs + k = 0 !counting the finished jobs !___________________________________________________________________________________ !$omp parallel & !$omp shared( vz,NTMP,percent,k,TMPdir,conv ) !$omp single - do i = 1, NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath,jobcall ) + do i = 1,NTMP + vz = i + !$omp task firstprivate( vz ) private( tmppath,jobcall ) ! create the system call - write (jobcall, '(a,1x,a,1x,a,'' -nfrag1 '',i3,'' -ellips '',3f9.3,'' -qcg '',a,'' >iff.out'')') & -& trim(env%ProgIFF), trim(frag1_file), trim(frag2_file), nfrag1, outer_ell_abc(conv(vz), 1:3)*0.9, trim(pipe) - write (tmppath, '(a,i0)') trim(TMPdir), conv(vz) - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical - k = k + 1 - percent = float(k)/float(NTMP)*100 - !$omp end critical - !$omp end task - end do + write (jobcall,'(a,1x,a,1x,a,'' -nfrag1 '',i3,'' -ellips '',3f9.3,'' -qcg '',a,'' >iff.out'')') & +& trim(env%ProgIFF),trim(frag1_file),trim(frag2_file),nfrag1,outer_ell_abc(conv(vz),1:3)*0.9,trim(pipe) + write (tmppath,'(a,i0)') trim(TMPdir),conv(vz) + call command('cd '//trim(tmppath)//' && '//trim(jobcall)) + !$omp critical + k = k+1 + percent = float(k)/float(NTMP)*100 + !$omp end critical + !$omp end task + end do !$omp taskwait !$omp end single !$omp end parallel @@ -450,91 +450,91 @@ end subroutine ensemble_iff ! xTB docking calculation performed in parallel !___________________________________________________________________________________ -subroutine ensemble_dock(env, outer_ell_abc, nfrag1, frag1_file, frag2_file, n_shell& - &, n_solvent, NTMP, TMPdir, conv) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use zdata - - implicit none - type(systemdata) :: env - - character(len=*), intent(in) :: TMPdir !directory name - integer, intent(in) :: NTMP !number of structures to be optimized - integer, intent(in) :: nfrag1 !#atoms of larger fragment - integer, intent(in) :: conv(env%nqcgclust + 1) - real(wp), intent(in) :: outer_ell_abc(env%nqcgclust, 3) - integer, intent(in) :: n_shell, n_solvent - - integer :: i, k - integer :: vz, T,Tn - character(len=20) :: pipe - character(len=1024) :: jobcall - character(len=512) :: thispath, tmppath - character(len=*), intent(in) :: frag1_file - character(len=*), intent(in) :: frag2_file - character(len=64) :: frag1 - character(len=64) :: frag2 - real(wp) :: percent - character(len=2) :: flag - integer :: ich31 +subroutine ensemble_dock(env,outer_ell_abc,nfrag1,frag1_file,frag2_file,n_shell& + &,n_solvent,NTMP,TMPdir,conv) + use iso_fortran_env,only:wp => real64 + use iomod + use crest_data + use zdata + + implicit none + type(systemdata) :: env + + character(len=*),intent(in) :: TMPdir !directory name + integer,intent(in) :: NTMP !number of structures to be optimized + integer,intent(in) :: nfrag1 !#atoms of larger fragment + integer,intent(in) :: conv(env%nqcgclust+1) + real(wp),intent(in) :: outer_ell_abc(env%nqcgclust,3) + integer,intent(in) :: n_shell,n_solvent + + integer :: i,k + integer :: vz,T,Tn + character(len=20) :: pipe + character(len=1024) :: jobcall + character(len=512) :: thispath,tmppath + character(len=*),intent(in) :: frag1_file + character(len=*),intent(in) :: frag2_file + character(len=64) :: frag1 + character(len=64) :: frag2 + real(wp) :: percent + character(len=2) :: flag + integer :: ich31 ! some options - pipe = '2>/dev/null' - frag1 = 'solvent_cluster.coord' - frag2 = 'solvent' - call getcwd(thispath) + pipe = '2>/dev/null' + frag1 = 'solvent_cluster.coord' + frag2 = 'solvent' + call getcwd(thispath) ! setting the threads for correct parallelization - call new_ompautoset(env,'auto',NTMP,T,Tn) - - write (jobcall, '(a,1x,''dock'',1x,a,1x,a,1x,a,1x,f4.2,1x,''--nfrag1'',1x,i0,1x,& - & ''--input xcontrol --fast > xtb_dock.out '',a)') & - & trim(env%ProgName), trim(frag1_file), trim(frag2_file),& - & trim(env%gfnver), env%optlev, nfrag1, trim(pipe) - - flag = '$' - do i = 1, NTMP - vz = i - write (tmppath, '(a,i0)') trim(TMPdir), conv(i) - call chdir(trim(tmppath)) - open (newunit=ich31, file='xcontrol') - write (ich31, '(a,"fix")') trim(flag) - write (ich31, '(3x,"atoms: 1-",i0)') n_shell !Initial number of atoms (starting solvent shell) - write (ich31, '(a,"wall")') trim(flag) - write (31, '(3x,"potential=polynomial")') - write (ich31, '(3x,"ellipsoid:",1x,3(g0,",",1x),i0,"-",i0)') outer_ell_abc(conv(vz), :), & - & n_shell + 1, n_shell + n_solvent !Initial number of atoms (starting solvent shell) - close (ich31) - call chdir(trim(thispath)) - end do - - k = 0 !counting the finished jobs + call new_ompautoset(env,'auto',NTMP,T,Tn) + + write (jobcall,'(a,1x,''dock'',1x,a,1x,a,1x,a,1x,f4.2,1x,''--nfrag1'',1x,i0,1x,& + & ''--input xcontrol --fast > xtb_dock.out '',a)') & + & trim(env%ProgName),trim(frag1_file),trim(frag2_file),& + & trim(env%gfnver),env%optlev,nfrag1,trim(pipe) + + flag = '$' + do i = 1,NTMP + vz = i + write (tmppath,'(a,i0)') trim(TMPdir),conv(i) + call chdir(trim(tmppath)) + open (newunit=ich31,file='xcontrol') + write (ich31,'(a,"fix")') trim(flag) + write (ich31,'(3x,"atoms: 1-",i0)') n_shell !Initial number of atoms (starting solvent shell) + write (ich31,'(a,"wall")') trim(flag) + write (31,'(3x,"potential=polynomial")') + write (ich31,'(3x,"ellipsoid:",1x,3(g0,",",1x),i0,"-",i0)') outer_ell_abc(conv(vz),:), & + & n_shell+1,n_shell+n_solvent !Initial number of atoms (starting solvent shell) + close (ich31) + call chdir(trim(thispath)) + end do + + k = 0 !counting the finished jobs !___________________________________________________________________________________ !$omp parallel & !$omp shared( vz,NTMP,percent,k,TMPdir,conv,n_shell,n_solvent,jobcall ) !$omp single - do i = 1, NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath ) - write (tmppath, '(a,i0)') trim(TMPdir), conv(vz) - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical - k = k + 1 - percent = float(k)/float(NTMP)*100 - !$omp end critical - !$omp end task - end do + do i = 1,NTMP + vz = i + !$omp task firstprivate( vz ) private( tmppath ) + write (tmppath,'(a,i0)') trim(TMPdir),conv(vz) + call command('cd '//trim(tmppath)//' && '//trim(jobcall)) + !$omp critical + k = k+1 + percent = float(k)/float(NTMP)*100 + !$omp end critical + !$omp end task + end do !$omp taskwait !$omp end single !$omp end parallel !___________________________________________________________________________________ - call chdir(trim(thispath)) + call chdir(trim(thispath)) end subroutine ensemble_dock @@ -543,155 +543,155 @@ end subroutine ensemble_dock ! xTB CFF optimization performed in parallel !___________________________________________________________________________________ -subroutine cff_opt(postopt, env, fname, n12, NTMP, TMPdir, conv, nothing_added) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use strucrd - implicit none - - type(systemdata) :: env - character(len=*), intent(in) :: fname !file base name - character(len=*), intent(in) :: TMPdir !directory name - integer, intent(inout) :: NTMP !number of structures to be optimized - integer, intent(inout) :: conv(env%nqcgclust + 1) - logical, intent(in) :: postopt - logical, intent(in) :: nothing_added(env%nqcgclust) - integer :: i, k, n12 - integer :: vz,T,Tn - integer :: ich31 - character(len=20) :: pipe - character(len=512) :: thispath, tmppath - character(len=1024) :: jobcall - character(len=2) :: flag - real(wp) :: percent +subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) + use iso_fortran_env,only:wp => real64 + use iomod + use crest_data + use strucrd + implicit none + + type(systemdata) :: env + character(len=*),intent(in) :: fname !file base name + character(len=*),intent(in) :: TMPdir !directory name + integer,intent(inout) :: NTMP !number of structures to be optimized + integer,intent(inout) :: conv(env%nqcgclust+1) + logical,intent(in) :: postopt + logical,intent(in) :: nothing_added(env%nqcgclust) + integer :: i,k,n12 + integer :: vz,T,Tn + integer :: ich31 + character(len=20) :: pipe + character(len=512) :: thispath,tmppath + character(len=1024) :: jobcall + character(len=2) :: flag + real(wp) :: percent ! setting the threads for correct parallelization - call new_ompautoset(env,'auto',NTMP,T,Tn) + call new_ompautoset(env,'auto',NTMP,T,Tn) - if (postopt) then - write (*, '(2x,''Starting optimizations + SP of structures'')') - write (*, '(2x,i0,'' jobs to do.'')') NTMP - end if + if (postopt) then + write (*,'(2x,''Starting optimizations + SP of structures'')') + write (*,'(2x,i0,'' jobs to do.'')') NTMP + end if ! postopt eq true => post opt run, which has to be performed in every directory !!! - if (postopt) then - k = 0 - NTMP = env%nqcgclust - do i = 1, env%nqcgclust - k = k + 1 - conv(k) = i - conv(env%nqcgclust + 1) = k - end do - end if - pipe = '2>/dev/null' - - call getcwd(thispath) - do i = 1, NTMP - write (tmppath, '(a,i0)') trim(TMPdir), conv(i) - call chdir(trim(tmppath)) - open (newunit=ich31, file='xcontrol') - if (n12 .ne. 0) then - flag = '$' - write (ich31, '(a,"fix")') trim(flag) - write (ich31, '(3x,"atoms: 1-",i0)') n12 !Initial number of atoms (starting solvent shell) - end if - close (ich31) - if (postopt .and. nothing_added(i)) call remove('xcontrol') - call chdir(trim(thispath)) - end do + if (postopt) then + k = 0 + NTMP = env%nqcgclust + do i = 1,env%nqcgclust + k = k+1 + conv(k) = i + conv(env%nqcgclust+1) = k + end do + end if + pipe = '2>/dev/null' + + call getcwd(thispath) + do i = 1,NTMP + write (tmppath,'(a,i0)') trim(TMPdir),conv(i) + call chdir(trim(tmppath)) + open (newunit=ich31,file='xcontrol') + if (n12 .ne. 0) then + flag = '$' + write (ich31,'(a,"fix")') trim(flag) + write (ich31,'(3x,"atoms: 1-",i0)') n12 !Initial number of atoms (starting solvent shell) + end if + close (ich31) + if (postopt.and.nothing_added(i)) call remove('xcontrol') + call chdir(trim(thispath)) + end do !--- Jobcall - write (jobcall, '(a,1x,a,1x,a,'' --input xcontrol --opt '',i0,1x,a,'' >xtb.out'')') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), nint(env%optlev), trim(pipe) + write (jobcall,'(a,1x,a,1x,a,'' --input xcontrol --opt '',i0,1x,a,'' >xtb.out'')') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),nint(env%optlev),trim(pipe) - if (NTMP .lt. 1) then - write (*, '(2x,"No structures to be optimized")') - return - end if + if (NTMP .lt. 1) then + write (*,'(2x,"No structures to be optimized")') + return + end if - k = 0 !counting the finished jobs - if (postopt) call printprogbar(0.0_wp) + k = 0 !counting the finished jobs + if (postopt) call printprogbar(0.0_wp) !___________________________________________________________________________________ !$omp parallel & !$omp shared( vz,jobcall,NTMP,percent,k,TMPdir,conv ) !$omp single - do i = 1, NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath ) - write (tmppath, '(a,i0)') trim(TMPdir), conv(vz) - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical - k = k + 1 - percent = float(k)/float(NTMP)*100 - if (postopt) then - call printprogbar(percent) - end if - !$omp end critical - !$omp end task - end do + do i = 1,NTMP + vz = i + !$omp task firstprivate( vz ) private( tmppath ) + write (tmppath,'(a,i0)') trim(TMPdir),conv(vz) + call command('cd '//trim(tmppath)//' && '//trim(jobcall)) + !$omp critical + k = k+1 + percent = float(k)/float(NTMP)*100 + if (postopt) then + call printprogbar(percent) + end if + !$omp end critical + !$omp end task + end do !$omp taskwait !$omp end single !$omp end parallel !__________________________________________________________________________________ - do i = 1, NTMP - write (tmppath, '(a,i0)') trim(TMPdir), conv(i) - call chdir(trim(tmppath)) - call remove('xtbrestart') - call chdir(trim(thispath)) - end do + do i = 1,NTMP + write (tmppath,'(a,i0)') trim(TMPdir),conv(i) + call chdir(trim(tmppath)) + call remove('xtbrestart') + call chdir(trim(thispath)) + end do - !create the system call for sp (needed for gbsa model) - write (jobcall, '(a,1x,a,1x,a,'' --sp '',a,1x,a,'' >xtb_sp.out'')') & - & trim(env%ProgName), 'xtbopt.coord', trim(env%gfnver), trim(env%solv), trim(pipe) + !create the system call for sp (needed for gbsa model) + write (jobcall,'(a,1x,a,1x,a,'' --sp '',a,1x,a,'' >xtb_sp.out'')') & + & trim(env%ProgName),'xtbopt.coord',trim(env%gfnver),trim(env%solv),trim(pipe) - if (NTMP .lt. 1) then - write (*, '(2x,"Nothing to do")') - return - end if + if (NTMP .lt. 1) then + write (*,'(2x,"Nothing to do")') + return + end if - k = 0 !counting the finished jobs - if (postopt) call printprogbar(0.0_wp) + k = 0 !counting the finished jobs + if (postopt) call printprogbar(0.0_wp) !___________________________________________________________________________________ !$omp parallel & !$omp shared( vz,jobcall,NTMP,percent,k,TMPdir,conv ) !$omp single - do i = 1, NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath ) - write (tmppath, '(a,i0)') trim(TMPdir), conv(vz) - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical - k = k + 1 - percent = float(k)/float(NTMP)*100 - if (postopt) then - call printprogbar(percent) - end if - !$omp end critical - !$omp end task - end do + do i = 1,NTMP + vz = i + !$omp task firstprivate( vz ) private( tmppath ) + write (tmppath,'(a,i0)') trim(TMPdir),conv(vz) + call command('cd '//trim(tmppath)//' && '//trim(jobcall)) + !$omp critical + k = k+1 + percent = float(k)/float(NTMP)*100 + if (postopt) then + call printprogbar(percent) + end if + !$omp end critical + !$omp end task + end do !$omp taskwait !$omp end single !$omp end parallel !___________________________________________________________________________________ - do i = 1, NTMP - write (tmppath, '(a,i0)') trim(TMPdir), conv(i) - call chdir(trim(tmppath)) - call remove('xtbrestart') - !call remove('xcontrol') - call chdir(trim(thispath)) - end do - - if (postopt) then - write (*, *) '' - write (*, '(2x,"done.")') - end if + do i = 1,NTMP + write (tmppath,'(a,i0)') trim(TMPdir),conv(i) + call chdir(trim(tmppath)) + call remove('xtbrestart') + !call remove('xcontrol') + call chdir(trim(thispath)) + end do + + if (postopt) then + write (*,*) '' + write (*,'(2x,"done.")') + end if end subroutine cff_opt @@ -700,80 +700,80 @@ end subroutine cff_opt ! xTB SP performed in parallel !___________________________________________________________________________________ -subroutine ens_sp(env, fname, NTMP, TMPdir) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use strucrd - implicit none - - type(systemdata) :: env - character(len=*), intent(in) :: fname !file base name - character(len=*), intent(in) :: TMPdir !directory name - integer, intent(inout) :: NTMP !number of structures to be optimized - - integer :: i, k - integer :: vz, T, Tn - character(len=20) :: pipe - character(len=512) :: thispath, tmppath - character(len=1024) :: jobcall - real(wp) :: percent +subroutine ens_sp(env,fname,NTMP,TMPdir) + use iso_fortran_env,only:wp => real64 + use iomod + use crest_data + use strucrd + implicit none + + type(systemdata) :: env + character(len=*),intent(in) :: fname !file base name + character(len=*),intent(in) :: TMPdir !directory name + integer,intent(inout) :: NTMP !number of structures to be optimized + + integer :: i,k + integer :: vz,T,Tn + character(len=20) :: pipe + character(len=512) :: thispath,tmppath + character(len=1024) :: jobcall + real(wp) :: percent ! setting the threads for correct parallelization - call new_ompautoset(env,'auto',NTMP,T,Tn) + call new_ompautoset(env,'auto',NTMP,T,Tn) - write (*, '(2x,''Single point computation with GBSA model'')') - write (*, '(2x,i0,'' jobs to do.'')') NTMP + write (*,'(2x,''Single point computation with GBSA model'')') + write (*,'(2x,i0,'' jobs to do.'')') NTMP - pipe = '2>/dev/null' + pipe = '2>/dev/null' - call getcwd(thispath) + call getcwd(thispath) - if (NTMP .lt. 1) then - write (*, '(2x,"No structures to be optimized")') - return - end if + if (NTMP .lt. 1) then + write (*,'(2x,"No structures to be optimized")') + return + end if !--- Jobcall - write (jobcall, '(a,1x,a,1x,a,'' --sp '',a,1x,a,'' > xtb_sp.out'')') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), trim(env%solv), trim(pipe) + write (jobcall,'(a,1x,a,1x,a,'' --sp '',a,1x,a,'' > xtb_sp.out'')') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) - k = 0 !counting the finished jobs - call printprogbar(0.0_wp) + k = 0 !counting the finished jobs + call printprogbar(0.0_wp) !___________________________________________________________________________________ !$omp parallel & !$omp shared( vz,NTMP,percent,k,TMPdir,jobcall ) !$omp single - do i = 1, NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath ) - call initsignal() - !$omp critical - write (tmppath, '(a,i0)') trim(TMPdir), vz - !$omp end critical - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical - k = k + 1 - percent = float(k)/float(NTMP)*100 - call printprogbar(percent) - !$omp end critical - !$omp end task - end do + do i = 1,NTMP + vz = i + !$omp task firstprivate( vz ) private( tmppath ) + call initsignal() + !$omp critical + write (tmppath,'(a,i0)') trim(TMPdir),vz + !$omp end critical + call command('cd '//trim(tmppath)//' && '//trim(jobcall)) + !$omp critical + k = k+1 + percent = float(k)/float(NTMP)*100 + call printprogbar(percent) + !$omp end critical + !$omp end task + end do !$omp taskwait !$omp end single !$omp end parallel !__________________________________________________________________________________ - do i = 1, NTMP - write (tmppath, '(a,i0)') trim(TMPdir), i - call chdir(trim(tmppath)) - call remove('xtbrestart') - call chdir(trim(thispath)) - end do - write (*, *) '' - write (*, '(2x,"done.")') + do i = 1,NTMP + write (tmppath,'(a,i0)') trim(TMPdir),i + call chdir(trim(tmppath)) + call remove('xtbrestart') + call chdir(trim(thispath)) + end do + write (*,*) '' + write (*,'(2x,"done.")') end subroutine ens_sp @@ -782,84 +782,84 @@ end subroutine ens_sp ! xTB Freq compuatation performed in parallel !___________________________________________________________________________________ -subroutine ens_freq(env, fname, NTMP, TMPdir, opt) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use strucrd - implicit none - - type(systemdata) :: env - character(len=*), intent(in) :: fname !file base name - character(len=*), intent(in) :: TMPdir !directory name - integer, intent(inout) :: NTMP !number of structures to be optimized - - integer :: i, k - integer :: vz, T,Tn - character(len=20) :: pipe - character(len=512) :: thispath, tmppath - character(len=1024) :: jobcall - real(wp) :: percent - logical :: opt +subroutine ens_freq(env,fname,NTMP,TMPdir,opt) + use iso_fortran_env,only:wp => real64 + use iomod + use crest_data + use strucrd + implicit none + + type(systemdata) :: env + character(len=*),intent(in) :: fname !file base name + character(len=*),intent(in) :: TMPdir !directory name + integer,intent(inout) :: NTMP !number of structures to be optimized + + integer :: i,k + integer :: vz,T,Tn + character(len=20) :: pipe + character(len=512) :: thispath,tmppath + character(len=1024) :: jobcall + real(wp) :: percent + logical :: opt ! setting the threads for correct parallelization - call new_ompautoset(env,'auto',NTMP,T,Tn) + call new_ompautoset(env,'auto',NTMP,T,Tn) - write (*, '(2x,''Starting reoptimizations + Frequency computation of ensemble'')') - write (*, '(2x,i0,'' jobs to do.'')') NTMP + write (*,'(2x,''Starting reoptimizations + Frequency computation of ensemble'')') + write (*,'(2x,i0,'' jobs to do.'')') NTMP - pipe = '2>/dev/null' + pipe = '2>/dev/null' - call getcwd(thispath) + call getcwd(thispath) - if (NTMP .lt. 1) then - write (*, '(2x,"No structures to be optimized")') - return - end if + if (NTMP .lt. 1) then + write (*,'(2x,"No structures to be optimized")') + return + end if - k = 0 !counting the finished jobs - call printprogbar(0.0_wp) + k = 0 !counting the finished jobs + call printprogbar(0.0_wp) !--- Jobcall - if (.not. opt) then - write (jobcall, '(a,1x,a,1x,a,'' --hess '',a,'' >xtb_freq.out'')') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), trim(pipe) - else - write (jobcall, '(a,1x,a,1x,a,'' --ohess '',a,'' >xtb_freq.out'')') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), trim(pipe) - end if + if (.not.opt) then + write (jobcall,'(a,1x,a,1x,a,'' --hess '',a,'' >xtb_freq.out'')') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(pipe) + else + write (jobcall,'(a,1x,a,1x,a,'' --ohess '',a,'' >xtb_freq.out'')') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(pipe) + end if !___________________________________________________________________________________ !$omp parallel & !$omp shared( vz,NTMP,percent,k,TMPdir,jobcall ) !$omp single - do i = 1, NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath ) - write (tmppath, '(a,i0)') trim(TMPdir), i - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical - k = k + 1 - percent = float(k)/float(NTMP)*100 - call printprogbar(percent) - !$omp end critical - !$omp end task - end do + do i = 1,NTMP + vz = i + !$omp task firstprivate( vz ) private( tmppath ) + write (tmppath,'(a,i0)') trim(TMPdir),i + call command('cd '//trim(tmppath)//' && '//trim(jobcall)) + !$omp critical + k = k+1 + percent = float(k)/float(NTMP)*100 + call printprogbar(percent) + !$omp end critical + !$omp end task + end do !$omp taskwait !$omp end single !$omp end parallel !__________________________________________________________________________________ - do i = 1, NTMP - write (tmppath, '(a,i0)') trim(TMPdir), i - call chdir(trim(tmppath)) - call remove('xtbrestart') - call chdir(trim(thispath)) - end do - write (*, *) '' - write (*, '(2x,"done.")') + do i = 1,NTMP + write (tmppath,'(a,i0)') trim(TMPdir),i + call chdir(trim(tmppath)) + call remove('xtbrestart') + call chdir(trim(thispath)) + end do + write (*,*) '' + write (*,'(2x,"done.")') end subroutine ens_freq @@ -867,33 +867,33 @@ end subroutine ens_freq ! Read the Energies from a xtbiff output !============================================================! -subroutine rdxtbiffE(fname, m, n, e) +subroutine rdxtbiffE(fname,m,n,e) - implicit none - integer :: m, n - character(len=*),intent(in) :: fname - real*8 :: e(*) + implicit none + integer :: m,n + character(len=*),intent(in) :: fname + real*8 :: e(*) - character(len=128) :: line - real*8 :: xx(10) - integer :: ich, i, j, nn + character(len=128) :: line + real*8 :: xx(10) + integer :: ich,i,j,nn - open (newunit=ich, file=fname) + open (newunit=ich,file=fname) - j = 1 + j = 1 10 continue - read (ich, '(a)', end=999) line - read (ich, '(a)') line - call readl(line, xx, nn) - e(j) = xx(1) - do i = 1, n - read (ich, '(a)') line - end do - j = j + 1 - goto 10 + read (ich,'(a)',end=999) line + read (ich,'(a)') line + call readl(line,xx,nn) + e(j) = xx(1) + do i = 1,n + read (ich,'(a)') line + end do + j = j+1 + goto 10 999 close (ich) - m = j - 1 + m = j-1 end !============================================================! @@ -909,76 +909,76 @@ subroutine rdxtbiffE(fname, m, n, e) ! !============================================================! -subroutine wr_cluster_cut(fname_cluster, n1, n2, iter, fname_solu_cut, fname_solv_cut) - use iso_fortran_env, only: wp => real64 - use strucrd - - implicit none - integer, intent(in) :: n1, n2, iter - real(wp) :: xyz1(3, n1) - real(wp) :: xyz2(3, n2*iter) - integer :: at1(n1), at2(n2*iter) - character(len=*), intent(in) :: fname_cluster, fname_solu_cut, fname_solv_cut - character(len=256) :: atmp - character(len=2) :: a2 - integer :: ich, i, k, stat, io, io2 - - ich = 142 - open (unit=ich, file=fname_cluster, iostat=stat) - read (ich, '(a)') atmp - k = 1 - do i = 1, n1 - read (ich, '(a)', iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - call coordline(atmp, a2, xyz1(1:3, k), io2) - at1(k) = e2i(a2) - k = k + 1 - end do - k = 1 - do i = 1, n2*iter - read (ich, '(a)', iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - call coordline(atmp, a2, xyz2(1:3, k), io2) - at2(k) = e2i(a2) - k = k + 1 - end do - - call wrc0(fname_solu_cut, n1, at1, xyz1) - call wrc0(fname_solv_cut, n2*iter, at2, xyz2) - close (ich) +subroutine wr_cluster_cut(fname_cluster,n1,n2,iter,fname_solu_cut,fname_solv_cut) + use iso_fortran_env,only:wp => real64 + use strucrd + + implicit none + integer,intent(in) :: n1,n2,iter + real(wp) :: xyz1(3,n1) + real(wp) :: xyz2(3,n2*iter) + integer :: at1(n1),at2(n2*iter) + character(len=*),intent(in) :: fname_cluster,fname_solu_cut,fname_solv_cut + character(len=256) :: atmp + character(len=2) :: a2 + integer :: ich,i,k,stat,io,io2 + + ich = 142 + open (unit=ich,file=fname_cluster,iostat=stat) + read (ich,'(a)') atmp + k = 1 + do i = 1,n1 + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + call coordline(atmp,a2,xyz1(1:3,k),io2) + at1(k) = e2i(a2) + k = k+1 + end do + k = 1 + do i = 1,n2*iter + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + call coordline(atmp,a2,xyz2(1:3,k),io2) + at2(k) = e2i(a2) + k = k+1 + end do + + call wrc0(fname_solu_cut,n1,at1,xyz1) + call wrc0(fname_solv_cut,n2*iter,at2,xyz2) + close (ich) end subroutine wr_cluster_cut subroutine check_iff(neg_E) - use iso_fortran_env, only: wp => real64 - use crest_data + use iso_fortran_env,only:wp => real64 + use crest_data - implicit none - integer :: io, ich - real(wp) :: int_E - character(len=50) :: tmp - logical, intent(out) :: neg_E + implicit none + integer :: io,ich + real(wp) :: int_E + character(len=50) :: tmp + logical,intent(out) :: neg_E - logical :: ex - character(len=*), parameter :: filename = 'xtbscreen.xyz' + logical :: ex + character(len=*),parameter :: filename = 'xtbscreen.xyz' - neg_E = .false. - int_E = 0.0_wp + neg_E = .false. + int_E = 0.0_wp - inquire (file=filename, exist=ex) - if (.not. ex) return + inquire (file=filename,exist=ex) + if (.not.ex) return - open (newunit=ich, file=filename, status="old", iostat=io) - if (io == 0) read (ich, '(a)', iostat=io) - if (io == 0) read (ich, '(a)', iostat=io) tmp - close (ich) - if (io /= 0) return + open (newunit=ich,file=filename,status="old",iostat=io) + if (io == 0) read (ich,'(a)',iostat=io) + if (io == 0) read (ich,'(a)',iostat=io) tmp + close (ich) + if (io /= 0) return - tmp = adjustl(tmp(11:)) - read (tmp, *, iostat=io) int_E - neg_E = io == 0 .and. int_E < 0.0_wp + tmp = adjustl(tmp(11:)) + read (tmp,*,iostat=io) int_E + neg_E = io == 0.and.int_E < 0.0_wp end subroutine check_iff @@ -986,78 +986,117 @@ end subroutine check_iff ! write a wall potential in a file used as xtb input subroutine write_wall(env,n1,rabc1,rabc12,fname) - use iso_fortran_env, only : wp => real64 + use iso_fortran_env,only:wp => real64 use crest_data implicit none type(systemdata) :: env - integer, intent(in) :: n1 + integer,intent(in) :: n1 real(wp),intent(in) :: rabc1(3),rabc12(3) - character (len=8) :: flag + character(len=8) :: flag character(len=*) :: fname - open(unit=31,file=fname) - flag='$' - write(31,'(a,"wall")') trim(flag) - write(31,'(3x,"potential=polynomial")') - write(31,'(3x,"ellipsoid:",1x,3(g0,",",1x),"all")') rabc12 - write(31,'(3x,"ellipsoid:",1x,3(g0,",",1x),"1-",i0)') rabc1,n1 - if(env%constrain_solu) then - write(31,'("$fix")') - write(31,'(3x,"atoms: 1-",i0)') n1 + open (unit=31,file=fname) + flag = '$' + write (31,'(a,"wall")') trim(flag) + write (31,'(3x,"potential=polynomial")') + write (31,'(3x,"ellipsoid:",1x,3(g0,",",1x),"all")') rabc12 + write (31,'(3x,"ellipsoid:",1x,3(g0,",",1x),"1-",i0)') rabc1,n1 + if (env%constrain_solu) then + write (31,'("$fix")') + write (31,'(3x,"atoms: 1-",i0)') n1 end if call write_cts(31,env%cts) call write_cts_biasext(31,env%cts) - if(env%cts%used) then !Only, if user set constrians is an $end written - write(31,'(a)') '$end' + if (env%cts%used) then !Only, if user set constrians is an $end written + write (31,'(a)') '$end' end if - close(31) + close (31) end subroutine write_wall subroutine check_dock(neg_E) - use iso_fortran_env, only: wp => real64 - use crest_data - use iomod, only: minigrep, grepval + use iso_fortran_env,only:wp => real64 + use crest_data + use iomod,only:minigrep,grepval - implicit none - real(wp) :: int_E - logical, intent(out) :: neg_E - logical :: ex - character(len=*), parameter :: filename = 'xtbscreen.xyz' + implicit none + real(wp) :: int_E + logical,intent(out) :: neg_E + logical :: ex + character(len=*),parameter :: filename = 'xtbscreen.xyz' - neg_E = .false. - int_E = 0.0_wp + neg_E = .false. + int_E = 0.0_wp - call minigrep('xtb_dock.out', ' Lowest Interaction Energy: ********** kcal/mol', ex) - if (ex) return + call minigrep('xtb_dock.out',' Lowest Interaction Energy: ********** kcal/mol',ex) + if (ex) return - call grepval('xtb_dock.out', 'Lowest Interaction Energy:', ex, int_E) + call grepval('xtb_dock.out','Lowest Interaction Energy:',ex,int_E) - if (ex .and. int_E < 0.0_wp) neg_E = .true. + if (ex.and.int_E < 0.0_wp) neg_E = .true. end subroutine check_dock subroutine write_constraint(env,coord_name,fname) - use iso_fortran_env, only : wp => real64 + use iso_fortran_env,only:wp => real64 use crest_data use iomod implicit none type(systemdata) :: env - character(len=*),intent(in) :: fname, coord_name + character(len=*),intent(in) :: fname,coord_name - call copysub(coord_name, 'coord.ref') - open(unit=31,file=fname) + call copysub(coord_name,'coord.ref') + open (unit=31,file=fname) call write_cts(31,env%cts) call write_cts_biasext(31,env%cts) - if(env%cts%used) then !Only, if user set constrians is an $end written - write(31,'(a)') '$end' + if (env%cts%used) then !Only, if user set constrians is an $end written + write (31,'(a)') '$end' end if - close(31) + close (31) end subroutine write_constraint + + +!==============================================================================! + +subroutine get_interaction_E(env,solu,solv,clus,iter,E_inter) + use iso_fortran_env,wp => real64 + use crest_data + use iomod + use zdata + use strucrd + implicit none + + type(systemdata) :: env + type(zmolecule),intent(in) :: solu,solv,clus + real(wp) :: e_cluster,e_solute,e_solvent + real(wp) :: E_inter(env%nsolv) ! interaction energy + integer :: iter + logical :: e_there + + call remove('cluster.coord') + +!--- Prepare input coordinate files + call wrc0('cluster.coord',clus%nat,clus%at,clus%xyz) + call wr_cluster_cut('cluster.coord',solu%nat,solv%nat,iter,'solute_cut.coord','solvent_cut.coord') + +!--- Perform single point calculations and recieve energies + call xtb_sp_qcg(env,'solute_cut.coord') + call grepval('xtb.out','| TOTAL ENERGY',e_there,e_solute) + if (.not.e_there) write (*,*) 'Solute energy not found' + call xtb_sp_qcg(env,'solvent_cut.coord') + call grepval('xtb.out','| TOTAL ENERGY',e_there,e_solvent) + if (.not.e_there) write (*,*) 'Solvent energy not found' + call xtb_sp_qcg(env,'cluster.coord') + call grepval('xtb.out','| TOTAL ENERGY',e_there,e_cluster) + if (.not.e_there) write (*,*) 'Cluster energy not found' + + E_inter(iter) = e_cluster-e_solute-e_solvent + +end subroutine get_interaction_E diff --git a/src/qcg/volume.f90 b/src/qcg/volume.f90 index 01e726c9..8eff59e3 100644 --- a/src/qcg/volume.f90 +++ b/src/qcg/volume.f90 @@ -22,603 +22,596 @@ ! Jaroslav Skrivánek, Ming-Chya Wu ! Comput. Phys. Commun. 165(2005)59 -subroutine get_volume(zmol, rad) - use iso_fortran_env, wp => real64 - use zdata - implicit none - type(Zmolecule), intent(inout) :: zmol - real(wp), intent(in) :: rad(zmol%nat) - real(wp), allocatable :: xyz_rad(:, :) - integer, allocatable :: neigh_list(:) - integer, allocatable :: neigh_index(:) - integer, allocatable :: neigh_type(:) - real(wp) :: va_part(2) - integer :: i - - allocate (xyz_rad(zmol%nat, 4), neigh_list(zmol%nat), neigh_index(zmol%nat)) - allocate (neigh_type(zmol%nat**2)) - - zmol%vtot = 0d0 - zmol%atot = 0d0 +subroutine get_volume(zmol,rad) + use crest_parameters + use zdata + implicit none + type(Zmolecule),intent(inout) :: zmol + real(wp),intent(in) :: rad(zmol%nat) + real(wp),allocatable :: xyz_rad(:,:) + integer,allocatable :: neigh_list(:) + integer,allocatable :: neigh_index(:) + integer,allocatable :: neigh_type(:) + real(wp) :: va_part(2) + integer :: i + + allocate (xyz_rad(zmol%nat,4),neigh_list(zmol%nat),neigh_index(zmol%nat)) + allocate (neigh_type(zmol%nat**2)) + + zmol%vtot = 0d0 + zmol%atot = 0d0 !--- Copying Input - do i = 1, zmol%nat - xyz_rad(i, 1:3) = zmol%xyz(1:3, i) - xyz_rad(i, 4) = rad(i) - end do + do i = 1,zmol%nat + xyz_rad(i,1:3) = zmol%xyz(1:3,i) + xyz_rad(i,4) = rad(i) + end do !--- Checking neighbors (different to usual CREST neighbors to account for more atoms) - call create_neigh(zmol%nat, xyz_rad, neigh_list, & - & neigh_index, neigh_type) + call create_neigh(zmol%nat,xyz_rad,neigh_list, & + & neigh_index,neigh_type) !--- Compute V and A - do i = 1, zmol%nat - call calcVA(i, xyz_rad, neigh_list, neigh_index, & - & neigh_type, zmol%nat, va_part) - zmol%vtot = zmol%vtot + va_part(1) - zmol%atot = zmol%atot + va_part(2) - end do + do i = 1,zmol%nat + call calcVA(i,xyz_rad,neigh_list,neigh_index, & + & neigh_type,zmol%nat,va_part) + zmol%vtot = zmol%vtot+va_part(1) + zmol%atot = zmol%atot+va_part(2) + end do - deallocate (xyz_rad, neigh_type, neigh_index) - deallocate (neigh_list) + deallocate (xyz_rad,neigh_type,neigh_index) + deallocate (neigh_list) - return + return end subroutine get_volume -subroutine create_neigh(nat, xyz_rad, neigh_list, neigh_index, neigh_type) - use iso_fortran_env, wp => real64 - implicit none - - integer, intent(in) :: nat - real(wp), intent(in) :: xyz_rad(nat, 4) - integer :: neigh_list(nat), neigh_index(nat), neigh_type(nat**2) - - integer :: neigh_tmp(nat), dum(nat) - integer :: i, j - real(wp) :: x, y, z, d, ri, r - - neigh_index = 0 - neigh_index(1) = 1 - neigh_list = 0 - neigh_tmp = 0 - do i = 1, nat - !--- Check, if there are neighbors and which - neigh_list(i) = 0 - x = xyz_rad(i, 1) - y = xyz_rad(i, 2) - z = xyz_rad(i, 3) - r = xyz_rad(i, 4) - do j = 1, nat - if (j .NE. i) then - if (dabs(x - xyz_rad(j, 1)) .lt. r + xyz_rad(j, 4)) then - d = dsqrt((x - xyz_rad(j, 1))**2 + (y - xyz_rad(j, 2))**2 + (z - xyz_rad(j, 3))**2) - ri = xyz_rad(j, 4) - if (d .lt. r + ri) then - if (d + r .LE. ri) then - neigh_list(i) = -1 - exit - elseif (d + ri .gt. r) then - neigh_list(i) = neigh_list(i) + 1 - neigh_tmp(neigh_list(i)) = j - end if - end if +subroutine create_neigh(nat,xyz_rad,neigh_list,neigh_index,neigh_type) + use crest_parameters + implicit none + + integer,intent(in) :: nat + real(wp),intent(in) :: xyz_rad(nat,4) + integer :: neigh_list(nat),neigh_index(nat),neigh_type(nat**2) + + integer :: neigh_tmp(nat),dum(nat) + integer :: i,j + real(wp) :: x,y,z,d,ri,r + + neigh_index = 0 + neigh_index(1) = 1 + neigh_list = 0 + neigh_tmp = 0 + do i = 1,nat + !--- Check, if there are neighbors and which + neigh_list(i) = 0 + x = xyz_rad(i,1) + y = xyz_rad(i,2) + z = xyz_rad(i,3) + r = xyz_rad(i,4) + do j = 1,nat + if (j .NE. i) then + if (abs(x-xyz_rad(j,1)) .lt. r+xyz_rad(j,4)) then + d = sqrt((x-xyz_rad(j,1))**2+(y-xyz_rad(j,2))**2+(z-xyz_rad(j,3))**2) + ri = xyz_rad(j,4) + if (d .lt. r+ri) then + if (d+r .LE. ri) then + neigh_list(i) = -1 + exit + elseif (d+ri .gt. r) then + neigh_list(i) = neigh_list(i)+1 + neigh_tmp(neigh_list(i)) = j end if - end if - end do - dum = neigh_list !Somhow the first entry in neigh_list is overwritten in the following do cycle + end if + end if + end if + end do + dum = neigh_list !Somhow the first entry in neigh_list is overwritten in the following do cycle - !--- No neighbors - if (neigh_list(i) .LE. 0) then - neigh_index(i + 1) = neigh_index(i) + !--- No neighbors + if (neigh_list(i) .LE. 0) then + neigh_index(i+1) = neigh_index(i) !--- Neighbors - else - if(i < nat) then - neigh_index(i + 1) = neigh_index(i) + neigh_list(i) - end if - do j = 1, neigh_list(i) - neigh_type(neigh_index(i) + j - 1) = neigh_tmp(j) - end do + else + if (i < nat) then + neigh_index(i+1) = neigh_index(i)+neigh_list(i) end if - end do - neigh_list = dum + do j = 1,neigh_list(i) + neigh_type(neigh_index(i)+j-1) = neigh_tmp(j) + end do + end if + end do + neigh_list = dum - return + return end subroutine create_neigh -subroutine calcVA(num, xyz_rad, neigh_list, neigh_index, neigh_type, nat, va_part) - use iso_fortran_env, wp => real64 - implicit none - - integer, intent(in) :: num, nat - real(wp), intent(in) :: xyz_rad(nat, 4) - integer, intent(in) :: neigh_list(nat), neigh_index(nat), neigh_type(nat**2) - real(wp), intent(out) :: va_part(2) - real(wp) :: circles(nat, 4), single_sphere(nat, 4) - real(wp) :: int_parts(nat**2, 3), av_part(2) - real(wp) :: rad - - integer :: neigh_tmp(nat), nint_parts, npos - integer :: i, j - real(wp), parameter :: pi = 3.1415926540d0 - - !--- No neighbors - if (neigh_list(num) .eq. 0) then - va_part(1) = 4d0*pi*xyz_rad(num, 4)**3/3.d0 - va_part(2) = 4d0*pi*xyz_rad(num, 4)**2 - !--- Subset - elseif (neigh_list(num) .lt. 0) then - va_part(1) = 0d0 - va_part(2) = 0d0 - !--- Neighbors exist - else - - neigh_tmp(1) = num - - do i = 1, (neigh_list(num)) - neigh_tmp(i + 1) = neigh_type(neigh_index(num) + i - 1) - end do - do i = 1, neigh_list(num) + 1 - do j = 1, 4 - single_sphere(i, j) = xyz_rad(neigh_tmp(i), j) - end do +subroutine calcVA(num,xyz_rad,neigh_list,neigh_index,neigh_type,nat,va_part) + use crest_parameters + implicit none + + integer,intent(in) :: num,nat + real(wp),intent(in) :: xyz_rad(nat,4) + integer,intent(in) :: neigh_list(nat),neigh_index(nat),neigh_type(nat**2) + real(wp),intent(out) :: va_part(2) + real(wp) :: circles(nat,4),single_sphere(nat,4) + real(wp) :: int_parts(nat**2,3),av_part(2) + real(wp) :: rad + + integer :: neigh_tmp(nat),nint_parts,npos + integer :: i,j + + !--- No neighbors + if (neigh_list(num) .eq. 0) then + va_part(1) = 4d0*pi*xyz_rad(num,4)**3/3.d0 + va_part(2) = 4d0*pi*xyz_rad(num,4)**2 + !--- Subset + elseif (neigh_list(num) .lt. 0) then + va_part(1) = 0d0 + va_part(2) = 0d0 + !--- Neighbors exist + else + + neigh_tmp(1) = num + + do i = 1, (neigh_list(num)) + neigh_tmp(i+1) = neigh_type(neigh_index(num)+i-1) + end do + do i = 1,neigh_list(num)+1 + do j = 1,4 + single_sphere(i,j) = xyz_rad(neigh_tmp(i),j) end do + end do - va_part(1) = 0d0 - va_part(2) = 0d0 + va_part(1) = 0d0 + va_part(2) = 0d0 - call generate_integration_parts(single_sphere, circles, nat, neigh_list(num), int_parts, nint_parts) + call generate_integration_parts(single_sphere,circles,nat,neigh_list(num),int_parts,nint_parts) - npos = 0 - do i = 1, (neigh_list(num)) - if (circles(i, 4) .gt. 0) then - npos = npos + 1 - end if - end do - - rad = single_sphere(1, 4) - !--- Selective integration as overlap was found - if (npos .gt. 0) then - call integrate(circles, int_parts, nat, nint_parts, rad, single_sphere(1, 3), av_part) - va_part(1) = va_part(1) + av_part(1) - va_part(2) = va_part(2) + av_part(2) - !--- Complete integration - else - call integrate(circles, int_parts, nat, nint_parts, rad, single_sphere(1, 3), av_part) - va_part(1) = va_part(1) + av_part(1) + 4d0*pi*single_sphere(1, 4)**3/3d0 - va_part(2) = va_part(2) + av_part(2) + 4d0*pi*single_sphere(1, 4)**2 + npos = 0 + do i = 1, (neigh_list(num)) + if (circles(i,4) .gt. 0) then + npos = npos+1 end if - end if - - return + end do + + rad = single_sphere(1,4) + !--- Selective integration as overlap was found + if (npos .gt. 0) then + call integrate(circles,int_parts,nat,nint_parts,rad,single_sphere(1,3),av_part) + va_part(1) = va_part(1)+av_part(1) + va_part(2) = va_part(2)+av_part(2) + !--- Complete integration + else + call integrate(circles,int_parts,nat,nint_parts,rad,single_sphere(1,3),av_part) + va_part(1) = va_part(1)+av_part(1)+4d0*pi*single_sphere(1,4)**3/3d0 + va_part(2) = va_part(2)+av_part(2)+4d0*pi*single_sphere(1,4)**2 + end if + end if + + return end subroutine calcVA -subroutine generate_integration_parts(single_sphere, circles, nat, num_neigh, int_parts, num_parts) - - use iso_fortran_env, wp => real64 - implicit none - real(wp), intent(in) :: single_sphere(nat, 4) - real(wp), intent(out) :: circles(nat, 4) - integer, intent(in) :: nat, num_neigh - real(wp), intent(out) :: int_parts(nat**2, 3) - integer, intent(out) :: num_parts - - integer :: nna - real(wp) :: int_partsnew(nat**2, 3), rad, x, y, a, b, c, d - integer :: i, j, k - real(wp), parameter :: pi = 3.1415926540d0 - - num_parts = 0 - - !--- Create circles first - rad = single_sphere(1, 4) - do i = 1, (num_neigh) - x = single_sphere(1, 1) - single_sphere(i + 1, 1) - y = single_sphere(1, 2) - single_sphere(i + 1, 2) - a = 8d0*rad**2*x - b = 8d0*rad**2*y - c = x**2 + y**2 + (single_sphere(1, 3) + rad - single_sphere(i + 1, 3))**2 - single_sphere(i + 1, 4)**2 - d = 4d0*rad**2*(x**2 + y**2 + (single_sphere(1, 3) - rad - single_sphere(i + 1, 3))**2 - single_sphere(i + 1, 4)**2) - circles(i, 1) = -a/(2d0*c) - circles(i, 2) = -b/(2d0*c) - circles(i, 3) = dsqrt((a**2 + b**2 - 4d0*c*d)/(4d0*c**2)) - if (c .gt. 0) then - circles(i, 4) = -1 - else - circles(i, 4) = 1 +subroutine generate_integration_parts(single_sphere,circles,nat,num_neigh,int_parts,num_parts) + use crest_parameters + implicit none + real(wp),intent(in) :: single_sphere(nat,4) + real(wp),intent(out) :: circles(nat,4) + integer,intent(in) :: nat,num_neigh + real(wp),intent(out) :: int_parts(nat**2,3) + integer,intent(out) :: num_parts + + integer :: nna + real(wp) :: int_partsnew(nat**2,3),rad,x,y,a,b,c,d + integer :: i,j,k + + num_parts = 0 + + !--- Create circles first + rad = single_sphere(1,4) + do i = 1, (num_neigh) + x = single_sphere(1,1)-single_sphere(i+1,1) + y = single_sphere(1,2)-single_sphere(i+1,2) + a = 8d0*rad**2*x + b = 8d0*rad**2*y + c = x**2+y**2+(single_sphere(1,3)+rad-single_sphere(i+1,3))**2-single_sphere(i+1,4)**2 + d = 4d0*rad**2*(x**2+y**2+(single_sphere(1,3)-rad-single_sphere(i+1,3))**2-single_sphere(i+1,4)**2) + circles(i,1) = -a/(2d0*c) + circles(i,2) = -b/(2d0*c) + circles(i,3) = sqrt((a**2+b**2-4d0*c*d)/(4d0*c**2)) + if (c .gt. 0) then + circles(i,4) = -1 + else + circles(i,4) = 1 + end if + end do + + !--- And than integration parts + !--- Only one circle + if (num_neigh .eq. 1) then + num_parts = 1 + int_parts(1,1) = 1 + int_parts(1,2) = 0d0 + int_parts(1,3) = 2d0*pi*circles(1,4) + !--- More circles + else + do i = 1, (num_neigh) + call make_parts(i,circles,nat,num_neigh,nna,int_partsnew) + if (nna .gt. 0) then + do j = 1,nna + do k = 1,3 + int_parts(num_parts+j,k) = int_partsnew(j,k) + end do + end do + num_parts = num_parts+nna end if - end do - - !--- And than integration parts - !--- Only one circle - if (num_neigh .eq. 1) then - num_parts = 1 - int_parts(1, 1) = 1 - int_parts(1, 2) = 0d0 - int_parts(1, 3) = 2d0*pi*circles(1, 4) - !--- More circles - else - do i = 1, (num_neigh) - call make_parts(i, circles, nat, num_neigh, nna, int_partsnew) - if (nna .gt. 0) then - do j = 1, nna - do k = 1, 3 - int_parts(num_parts + j, k) = int_partsnew(j, k) - end do - end do - num_parts = num_parts + nna - end if - end do - end if - return + end do + end if + return end subroutine generate_integration_parts !--- Create parts that are integratet later -subroutine make_parts(num, circles, nat, num_neigh, no_arc, int_partsnew) - use iso_fortran_env, wp => real64 - implicit none - - integer, intent(in) :: num - real(wp), intent(in) :: circles(nat, 4) - integer, intent(in) :: nat, num_neigh - real(wp), intent(out) :: int_partsnew(nat**2, 3) - integer, intent(out) :: no_arc - - integer :: i, j, m, counter_angles, counter_no_angles, counter - real(wp) :: c11, c12, c13, c21, c22, c23, dist, int11, int12, int21, int22, dum - real(wp) :: angles(nat**2), anglesnew(nat**2) - logical :: minmax - real(wp), parameter :: pi = 3.1415926540d0 - - no_arc = 0 - counter_angles = 0 - - c11 = circles(num, 1) - c12 = circles(num, 2) - c13 = circles(num, 3) - do i = 1, (num_neigh) - if (i .NE. num) then - c21 = circles(i, 1) - c22 = circles(i, 2) - c23 = circles(i, 3) - dist = dsqrt((c11 - c21)**2 + (c12 - c22)**2) - if ((dist .lt. c23 + c13) .and. (dabs(c23 - c13) .lt. dist)) then - !--- Two intersections - call intersection(num, i, nat, circles, int11, int12, int21, int22) - angles(counter_angles + 1) = int11 - angles(counter_angles + 2) = int12 - counter_angles = counter_angles + 2 - end if +subroutine make_parts(num,circles,nat,num_neigh,no_arc,int_partsnew) + use crest_parameters + implicit none + + integer,intent(in) :: num + real(wp),intent(in) :: circles(nat,4) + integer,intent(in) :: nat,num_neigh + real(wp),intent(out) :: int_partsnew(nat**2,3) + integer,intent(out) :: no_arc + + integer :: i,j,m,counter_angles,counter_no_angles,counter + real(wp) :: c11,c12,c13,c21,c22,c23,dist,int11,int12,int21,int22,dum + real(wp) :: angles(nat**2),anglesnew(nat**2) + logical :: minmax + + no_arc = 0 + counter_angles = 0 + + c11 = circles(num,1) + c12 = circles(num,2) + c13 = circles(num,3) + do i = 1, (num_neigh) + if (i .NE. num) then + c21 = circles(i,1) + c22 = circles(i,2) + c23 = circles(i,3) + dist = sqrt((c11-c21)**2+(c12-c22)**2) + if ((dist .lt. c23+c13).and.(abs(c23-c13) .lt. dist)) then + !--- Two intersections + call intersection(num,i,nat,circles,int11,int12,int21,int22) + angles(counter_angles+1) = int11 + angles(counter_angles+2) = int12 + counter_angles = counter_angles+2 end if - end do - if (counter_angles .eq. 0) then - counter_no_angles = 0 - do i = 1, (num_neigh) - if (i .NE. num) then - - !--- Check overlapping circles - dist = dsqrt((circles(num, 1) + circles(num, 3) - circles(i, 1))**2 + & - & (circles(num, 2) - circles(i, 2))**2) - if (dist .lt. circles(i, 3)) then - if (circles(i, 4) .gt. 0) then - counter = 1 - else - counter = 0 - end if - elseif (dist .gt. circles(i, 3)) then - if (circles(i, 4) .gt. 0) then - counter = 0 - else - counter = 1 - end if + end if + end do + if (counter_angles .eq. 0) then + counter_no_angles = 0 + do i = 1, (num_neigh) + if (i .NE. num) then + + !--- Check overlapping circles + dist = sqrt((circles(num,1)+circles(num,3)-circles(i,1))**2+ & + & (circles(num,2)-circles(i,2))**2) + if (dist .lt. circles(i,3)) then + if (circles(i,4) .gt. 0) then + counter = 1 + else + counter = 0 + end if + elseif (dist .gt. circles(i,3)) then + if (circles(i,4) .gt. 0) then + counter = 0 + else + counter = 1 + end if + else + dist = sqrt((circles(num,1)-circles(i,1))**2+(circles(num,2)-circles(i,2))**2) + if (dist .lt. circles(i,3)) then + if (circles(i,4) .gt. 0) then + counter = 1 else - dist = dsqrt((circles(num, 1) - circles(i, 1))**2 + (circles(num, 2) - circles(i, 2))**2) - if (dist .lt. circles(i, 3)) then - if (circles(i, 4) .gt. 0) then - counter = 1 - else - counter = 0 - end if - else - if (circles(i, 4) .gt. 0) then - counter = 0 - else - counter = 1 - end if - end if + counter = 0 end if - - counter_no_angles = counter_no_angles + counter - end if - end do - if (counter_no_angles .eq. (num_neigh - 1)) then - no_arc = 1 - int_partsnew(1, 1) = num - int_partsnew(1, 2) = 0d0 - int_partsnew(1, 3) = 2d0*pi*circles(num, 4) - end if - else - if (circles(num, 4) .gt. 0) then - minmax = .true. - else - minmax = .false. - end if - !--- Sort angles - do i = 1, (counter_angles - 1) - counter = i - dum = angles(i) - do j = i + 1, counter_angles - if (minmax) then - if (dum .gt. angles(j)) then - counter = j - dum = angles(j) - end if + else + if (circles(i,4) .gt. 0) then + counter = 0 else - if (dum .lt. angles(j)) then - counter = j - dum = angles(j) - end if + counter = 1 end if - end do - if (counter .NE. i) then - angles(counter) = angles(i) - angles(i) = dum - end if - end do - - !--- Remove equals - m = 1 - anglesnew(1) = angles(1) - do i = 2, counter_angles - if (dabs(angles(i) - angles(i - 1)) .gt. 1d-12) then - m = m + 1 - anglesnew(m) = angles(i) - end if - end do - counter_angles = m - do i = 1, m - angles(i) = anglesnew(i) - end do - do i = 1, (counter_angles - 1) - counter_no_angles = 0 - do j = 1, (num_neigh) - if (j .NE. num) then - c21 = c11 + c13*dcos((angles(i) + angles(i + 1))/2d0) - c22 = c12 + c13*dsin((angles(i) + angles(i + 1))/2d0) - !--- Check, if point is inside circle - dist = dsqrt((c21 - circles(j, 1))**2 + (c22 - circles(j, 2))**2) - if (dist .lt. circles(j, 3)) then - if (circles(j, 4) .gt. 0) then - counter_no_angles = counter_no_angles + 1 - end if - else - if (circles(j, 4) .LE. 0) then - counter_no_angles = counter_no_angles + 1 - end if - end if + end if + end if - end if - end do - if (counter_no_angles .eq. (num_neigh - 1)) then - no_arc = no_arc + 1 - int_partsnew(no_arc, 1) = num - int_partsnew(no_arc, 2) = angles(i) - int_partsnew(no_arc, 3) = angles(i + 1) - angles(i) - end if + counter_no_angles = counter_no_angles+counter + end if + end do + if (counter_no_angles .eq. (num_neigh-1)) then + no_arc = 1 + int_partsnew(1,1) = num + int_partsnew(1,2) = 0d0 + int_partsnew(1,3) = 2d0*pi*circles(num,4) + end if + else + if (circles(num,4) .gt. 0) then + minmax = .true. + else + minmax = .false. + end if + !--- Sort angles + do i = 1, (counter_angles-1) + counter = i + dum = angles(i) + do j = i+1,counter_angles + if (minmax) then + if (dum .gt. angles(j)) then + counter = j + dum = angles(j) + end if + else + if (dum .lt. angles(j)) then + counter = j + dum = angles(j) + end if + end if end do + if (counter .NE. i) then + angles(counter) = angles(i) + angles(i) = dum + end if + end do + + !--- Remove equals + m = 1 + anglesnew(1) = angles(1) + do i = 2,counter_angles + if (abs(angles(i)-angles(i-1)) .gt. 1d-12) then + m = m+1 + anglesnew(m) = angles(i) + end if + end do + counter_angles = m + do i = 1,m + angles(i) = anglesnew(i) + end do + do i = 1, (counter_angles-1) counter_no_angles = 0 - do i = 1, (num_neigh) - if (i .NE. num) then - c21 = c11 + c13*dcos((angles(1) + 2d0*pi + angles(counter_angles))/2d0) - c22 = c12 + c13*dsin((angles(1) + 2d0*pi + angles(counter_angles))/2d0) - !--- Check, if point is inside circle - dist = dsqrt((c21 - circles(i, 1))**2 + (c22 - circles(i, 2))**2) - if (dist .lt. circles(i, 3)) then - if (circles(i, 4) .gt. 0) then - counter_no_angles = counter_no_angles + 1 - end if - else - if (circles(i, 4) .LE. 0) then - counter_no_angles = counter_no_angles + 1 - end if + do j = 1, (num_neigh) + if (j .NE. num) then + c21 = c11+c13*cos((angles(i)+angles(i+1))/2d0) + c22 = c12+c13*sin((angles(i)+angles(i+1))/2d0) + !--- Check, if point is inside circle + dist = sqrt((c21-circles(j,1))**2+(c22-circles(j,2))**2) + if (dist .lt. circles(j,3)) then + if (circles(j,4) .gt. 0) then + counter_no_angles = counter_no_angles+1 end if + else + if (circles(j,4) .LE. 0) then + counter_no_angles = counter_no_angles+1 + end if + end if - end if + end if end do - if (counter_no_angles .eq. (num_neigh - 1)) then - no_arc = no_arc + 1 - int_partsnew(no_arc, 1) = num - int_partsnew(no_arc, 2) = angles(counter_angles) - int_partsnew(no_arc, 3) = angles(1) + circles(num, 4)*2d0*pi - angles(counter_angles) + if (counter_no_angles .eq. (num_neigh-1)) then + no_arc = no_arc+1 + int_partsnew(no_arc,1) = num + int_partsnew(no_arc,2) = angles(i) + int_partsnew(no_arc,3) = angles(i+1)-angles(i) end if - end if + end do + counter_no_angles = 0 + do i = 1, (num_neigh) + if (i .NE. num) then + c21 = c11+c13*cos((angles(1)+2d0*pi+angles(counter_angles))/2d0) + c22 = c12+c13*sin((angles(1)+2d0*pi+angles(counter_angles))/2d0) + !--- Check, if point is inside circle + dist = sqrt((c21-circles(i,1))**2+(c22-circles(i,2))**2) + if (dist .lt. circles(i,3)) then + if (circles(i,4) .gt. 0) then + counter_no_angles = counter_no_angles+1 + end if + else + if (circles(i,4) .LE. 0) then + counter_no_angles = counter_no_angles+1 + end if + end if - return + end if + end do + if (counter_no_angles .eq. (num_neigh-1)) then + no_arc = no_arc+1 + int_partsnew(no_arc,1) = num + int_partsnew(no_arc,2) = angles(counter_angles) + int_partsnew(no_arc,3) = angles(1)+circles(num,4)*2d0*pi-angles(counter_angles) + end if + end if + + return end subroutine make_parts !--- Computation of angles of two intersection points -subroutine intersection(point1, point2, nat, circles, int11, int12, int21, int22) - - use iso_fortran_env, wp => real64 - implicit none - integer, intent(in) :: point1, point2, nat - real(wp), intent(in) :: circles(nat, 4) - real(wp), intent(out) :: int11, int12, int21, int22 - - real(wp) :: c11, c12, c13, c21, c22, c23, f1, f2, f3, f4 - real(wp), parameter :: pi = 3.1415926540d0 - - c11 = circles(point1, 1) - c12 = circles(point1, 2) - c13 = circles(point1, 3) - c21 = circles(point2, 1) - c22 = circles(point2, 2) - c23 = circles(point2, 3) - if (dabs(c21 - c11) .lt. 1d-12) then - f1 = ((c13**2 - c23**2)/(c22 - c12) - (c22 - c12))/2d0 - f2 = dsqrt(c23**2 - f1**2) - if (f1 .eq. 0) then - int21 = 0d0 - int22 = pi - elseif (f1 .gt. 0) then - int21 = datan(dabs(f1/f2)) - int22 = pi - int21 - else - int21 = pi + datan(dabs(f1/f2)) - int22 = 3d0*pi - int21 - end if - f1 = f1 + c22 - c12 - if (f1 .eq. 0) then - int11 = 0d0 - int12 = pi - elseif (f1 .gt. 0) then - int11 = datan(dabs(f1/f2)) - int12 = pi - int11 +subroutine intersection(point1,point2,nat,circles,int11,int12,int21,int22) + use crest_parameters + implicit none + integer,intent(in) :: point1,point2,nat + real(wp),intent(in) :: circles(nat,4) + real(wp),intent(out) :: int11,int12,int21,int22 + + real(wp) :: c11,c12,c13,c21,c22,c23,f1,f2,f3,f4 + + c11 = circles(point1,1) + c12 = circles(point1,2) + c13 = circles(point1,3) + c21 = circles(point2,1) + c22 = circles(point2,2) + c23 = circles(point2,3) + if (abs(c21-c11) .lt. 1d-12) then + f1 = ((c13**2-c23**2)/(c22-c12)-(c22-c12))/2d0 + f2 = sqrt(c23**2-f1**2) + if (f1 .eq. 0) then + int21 = 0d0 + int22 = pi + elseif (f1 .gt. 0) then + int21 = atan(abs(f1/f2)) + int22 = pi-int21 + else + int21 = pi+atan(abs(f1/f2)) + int22 = 3d0*pi-int21 + end if + f1 = f1+c22-c12 + if (f1 .eq. 0) then + int11 = 0d0 + int12 = pi + elseif (f1 .gt. 0) then + int11 = atan(abs(f1/f2)) + int12 = pi-int11 + else + int11 = pi+atan(abs(f1/f2)) + int12 = 3d0*pi-int11 + end if + else + f3 = ((c13**2-c23**2-(c22-c12)**2)/(c21-c11)-(c21-c11))/2d0 + f4 = (c12-c22)/(c21-c11) + f1 = (-f3*f4+sqrt((f4**2+1d0)*c23**2-f3**2))/(f4**2+1d0) + f2 = f3+f4*f1 + if (f2 .eq. 0) then + if (f1 .gt. 0) then + int21 = pi/2d0 else - int11 = pi + datan(dabs(f1/f2)) - int12 = 3d0*pi - int11 + int21 = -pi/2d0 end if - else - f3 = ((c13**2 - c23**2 - (c22 - c12)**2)/(c21 - c11) - (c21 - c11))/2d0 - f4 = (c12 - c22)/(c21 - c11) - f1 = (-f3*f4 + dsqrt((f4**2 + 1d0)*c23**2 - f3**2))/(f4**2 + 1d0) - f2 = f3 + f4*f1 - if (f2 .eq. 0) then - if (f1 .gt. 0) then - int21 = pi/2d0 - else - int21 = -pi/2d0 - end if - elseif (f2 .gt. 0) then - int21 = datan(f1/f2) + elseif (f2 .gt. 0) then + int21 = atan(f1/f2) + else + int21 = pi+atan(f1/f2) + end if + f1 = f1+c22-c12 + f2 = f2+c21-c11 + if (f2 .eq. 0) then + if (f1 .gt. 0) then + int11 = pi/2d0 else - int21 = pi + datan(f1/f2) + int11 = -pi/2d0 end if - f1 = f1 + c22 - c12 - f2 = f2 + c21 - c11 - if (f2 .eq. 0) then - if (f1 .gt. 0) then - int11 = pi/2d0 - else - int11 = -pi/2d0 - end if - elseif (f2 .gt. 0) then - int11 = datan(f1/f2) + elseif (f2 .gt. 0) then + int11 = atan(f1/f2) + else + int11 = pi+atan(f1/f2) + end if + f1 = (-f3*f4-sqrt((f4**2+1d0)*c23**2-f3**2))/(f4**2+1d0) + f2 = f3+f4*f1 + if (f2 .eq. 0) then + if (f1 .gt. 0) then + int22 = pi/2d0 else - int11 = pi + datan(f1/f2) + int22 = -pi/2d0 end if - f1 = (-f3*f4 - dsqrt((f4**2 + 1d0)*c23**2 - f3**2))/(f4**2 + 1d0) - f2 = f3 + f4*f1 - if (f2 .eq. 0) then - if (f1 .gt. 0) then - int22 = pi/2d0 - else - int22 = -pi/2d0 - end if - elseif (f2 .gt. 0) then - int22 = datan(f1/f2) + elseif (f2 .gt. 0) then + int22 = atan(f1/f2) + else + int22 = pi+atan(f1/f2) + end if + f1 = f1+c22-c12 + f2 = f2+c21-c11 + if (f2 .eq. 0) then + if (f1 .gt. 0) then + int12 = pi/2d0 else - int22 = pi + datan(f1/f2) + int12 = -pi/2d0 end if - f1 = f1 + c22 - c12 - f2 = f2 + c21 - c11 - if (f2 .eq. 0) then - if (f1 .gt. 0) then - int12 = pi/2d0 - else - int12 = -pi/2d0 - end if - elseif (f2 .gt. 0) then - int12 = datan(f1/f2) - else - int12 = pi + datan(f1/f2) - end if - end if - if (int11 .lt. 0) int11 = int11 + 2d0*pi - if (int12 .lt. 0) int12 = int12 + 2d0*pi - if (int21 .lt. 0) int21 = int21 + 2d0*pi - if (int22 .lt. 0) int22 = int22 + 2d0*pi - - return + elseif (f2 .gt. 0) then + int12 = atan(f1/f2) + else + int12 = pi+atan(f1/f2) + end if + end if + if (int11 .lt. 0) int11 = int11+2d0*pi + if (int12 .lt. 0) int12 = int12+2d0*pi + if (int21 .lt. 0) int21 = int21+2d0*pi + if (int22 .lt. 0) int22 = int22+2d0*pi + + return end subroutine intersection -subroutine integrate(circles, int_parts, nat, nint_parts, rad, z1, av_part) - use iso_fortran_env, wp => real64 - implicit none - - real(wp), intent(in) :: circles(nat, 4), int_parts(nat**2, 3) - integer, intent(in) :: nat, nint_parts - real(wp), intent(in) :: rad, z1 - real(wp), intent(inout) :: av_part(2) - - integer :: i - real(wp) :: x, y, z, pre_V, xz, yz, pre_A, f - real(wp) :: pa, pd, p1, pb, pc, p2, v1, v2, v3, vJ1, vJ2, vJ3 - real(wp) :: d_v, d_a, part1, part2, part3, part4 - real(wp), parameter :: pi = 3.1415926540d0 - - av_part(1) = 0d0 - av_part(2) = 0d0 - - do i = 1, nint_parts - x = circles(nint(int_parts(i, 1)), 1) !> int_parts is type real(wp) and therefore - y = circles(nint(int_parts(i, 1)), 2) !> should not be used as an array index? - z = circles(nint(int_parts(i, 1)), 3) !> added nint() - xz = x*z - yz = y*z - pre_V = (4d0*rad**2 + x**2 + y**2 + z**2)/2d0 - pre_A = dsqrt(pre_V**2 - xz**2 - yz**2) - f = z**2 - pre_V - if (dabs(dabs(int_parts(i, 3)) - 2d0*pi) .lt. 1d-12) then - v1 = 2d0*pi/pre_A - v2 = 2d0*pi*pre_V/(pre_A**3) - v3 = pi*(2d0*pre_V**2 + xz**2 + yz**2)/(pre_A**5) - vJ1 = pi + f/2d0*v1 - vJ2 = (v1 + f*v2)/4d0 - vJ3 = (v2 + f*v3)/8d0 - d_v = (128d0*vJ3*rad**7 + 8d0*vJ2*rad**5 + & - & 2d0*vJ1*rad**3)/3d0 - 8d0*rad**4*vJ2*(z1 + rad) - d_a = 2d0*vJ1*rad**2 - if (int_parts(i, 3) .lt. 0) then - d_v = -d_v - d_a = -d_a - end if - av_part(1) = av_part(1) + d_v - av_part(2) = av_part(2) + d_a +subroutine integrate(circles,int_parts,nat,nint_parts,rad,z1,av_part) + use crest_parameters + implicit none + + real(wp),intent(in) :: circles(nat,4),int_parts(nat**2,3) + integer,intent(in) :: nat,nint_parts + real(wp),intent(in) :: rad,z1 + real(wp),intent(inout) :: av_part(2) + + integer :: i + real(wp) :: x,y,z,pre_V,xz,yz,pre_A,f + real(wp) :: pa,pd,p1,pb,pc,p2,v1,v2,v3,vJ1,vJ2,vJ3 + real(wp) :: d_v,d_a,part1,part2,part3,part4 + + av_part(1) = 0d0 + av_part(2) = 0d0 + + do i = 1,nint_parts + x = circles(nint(int_parts(i,1)),1) !> int_parts is type real(wp) and therefore + y = circles(nint(int_parts(i,1)),2) !> should not be used as an array index? + z = circles(nint(int_parts(i,1)),3) !> added nint() + xz = x*z + yz = y*z + pre_V = (4d0*rad**2+x**2+y**2+z**2)/2d0 + pre_A = sqrt(pre_V**2-xz**2-yz**2) + f = z**2-pre_V + if (abs(abs(int_parts(i,3))-2d0*pi) .lt. 1d-12) then + v1 = 2d0*pi/pre_A + v2 = 2d0*pi*pre_V/(pre_A**3) + v3 = pi*(2d0*pre_V**2+xz**2+yz**2)/(pre_A**5) + vJ1 = pi+f/2d0*v1 + vJ2 = (v1+f*v2)/4d0 + vJ3 = (v2+f*v3)/8d0 + d_v = (128d0*vJ3*rad**7+8d0*vJ2*rad**5+ & + & 2d0*vJ1*rad**3)/3d0-8d0*rad**4*vJ2*(z1+rad) + d_a = 2d0*vJ1*rad**2 + if (int_parts(i,3) .lt. 0) then + d_v = -d_v + d_a = -d_a + end if + av_part(1) = av_part(1)+d_v + av_part(2) = av_part(2)+d_a + else + if (int_parts(i,3) .lt. 0) then + p2 = int_parts(i,2)+int_parts(i,3) + p1 = int_parts(i,2) else - if (int_parts(i, 3) .lt. 0) then - p2 = int_parts(i, 2) + int_parts(i, 3) - p1 = int_parts(i, 2) - else - p1 = int_parts(i, 2) + int_parts(i, 3) - p2 = int_parts(i, 2) - end if - v1 = 2d0*(pi/2d0 - datan((pre_V*dcos((p1 - p2)/2d0) + & - & xz*dcos((p2 + p1)/2d0) + yz*dsin((p2 + p1)/2d0))/ & - & (pre_A*dsin((p1 - p2)/2d0))))/pre_A - pa = dsin(p1) - pb = dcos(p1) - pc = dsin(p2) - pd = dcos(p2) - part1 = (-xz*pa + yz*pb)/(pre_V + xz*pb + yz*pa)**1 - part2 = (-xz*pc + yz*pd)/(pre_V + xz*pd + yz*pc)**1 - part3 = (-xz*pa + yz*pb)/(pre_V + xz*pb + yz*pa)**2 - part4 = (-xz*pc + yz*pd)/(pre_V + xz*pd + yz*pc)**2 - v2 = (part1 - part2 + pre_V*v1)/(pre_A**2) - v3 = (part3 - part4 + (part1 - part2)/pre_V + (2d0*pre_V**2 + xz**2 + yz**2)*v2/pre_V)/(2d0*pre_A**2) - vJ1 = ((p1 - p2) + f*v1)/2d0 - vJ2 = (v1 + f*v2)/4d0 - vJ3 = (v2 + f*v3)/8d0 - d_v = (128d0*vJ3*rad**7 + 8d0*vJ2*rad**5 + & - & 2d0*vJ1*rad**3)/3d0 - 8d0*rad**4*vJ2*(z1 + rad) - d_a = 2d0*vJ1*rad**2 - if (int_parts(i, 3) .lt. 0) then - d_v = -d_v - d_a = -d_a - end if - av_part(1) = av_part(1) + d_v - av_part(2) = av_part(2) + d_a + p1 = int_parts(i,2)+int_parts(i,3) + p2 = int_parts(i,2) + end if + v1 = 2d0*(pi/2d0-atan((pre_V*cos((p1-p2)/2d0)+ & + & xz*cos((p2+p1)/2d0)+yz*sin((p2+p1)/2d0))/ & + & (pre_A*sin((p1-p2)/2d0))))/pre_A + pa = sin(p1) + pb = cos(p1) + pc = sin(p2) + pd = cos(p2) + part1 = (-xz*pa+yz*pb)/(pre_V+xz*pb+yz*pa)**1 + part2 = (-xz*pc+yz*pd)/(pre_V+xz*pd+yz*pc)**1 + part3 = (-xz*pa+yz*pb)/(pre_V+xz*pb+yz*pa)**2 + part4 = (-xz*pc+yz*pd)/(pre_V+xz*pd+yz*pc)**2 + v2 = (part1-part2+pre_V*v1)/(pre_A**2) + v3 = (part3-part4+(part1-part2)/pre_V+(2d0*pre_V**2+xz**2+yz**2)*v2/pre_V)/(2d0*pre_A**2) + vJ1 = ((p1-p2)+f*v1)/2d0 + vJ2 = (v1+f*v2)/4d0 + vJ3 = (v2+f*v3)/8d0 + d_v = (128d0*vJ3*rad**7+8d0*vJ2*rad**5+ & + & 2d0*vJ1*rad**3)/3d0-8d0*rad**4*vJ2*(z1+rad) + d_a = 2d0*vJ1*rad**2 + if (int_parts(i,3) .lt. 0) then + d_v = -d_v + d_a = -d_a end if - end do + av_part(1) = av_part(1)+d_v + av_part(2) = av_part(2)+d_a + end if + end do - return + return end subroutine integrate From b32aa41718e11b9de2ee1ace0e8a72dac77b54c4 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 8 Nov 2025 22:28:35 +0100 Subject: [PATCH 078/374] Imports and parameters in QCG --- src/qcg/solvtool.f90 | 171 +++++++++++++++++--------------------- src/qcg/solvtool_misc.f90 | 34 ++++---- 2 files changed, 94 insertions(+), 111 deletions(-) diff --git a/src/qcg/solvtool.f90 b/src/qcg/solvtool.f90 index 14b88092..48ad9997 100644 --- a/src/qcg/solvtool.f90 +++ b/src/qcg/solvtool.f90 @@ -23,7 +23,7 @@ subroutine crest_solvtool(env,tim) !*********************************************** !* Main driver for all QCG runtypes !*********************************************** - use iso_fortran_env,wp => real64 + use crest_parameters,only:wp,autokcal use qcg_printouts use crest_data use iomod @@ -40,8 +40,6 @@ subroutine crest_solvtool(env,tim) integer :: progress,io character(len=512) :: thispath - real(wp),parameter :: eh = 627.509541d0 - !--- Molecule settings solute%nmol = 1 solvent%nmol = 1 @@ -65,7 +63,7 @@ subroutine crest_solvtool(env,tim) else write (*,*) write (*,*) ' The use of the aISS algorithm is requested (recommend).' - write (*,*) ' This requires xtb version 6.7.1 or newer.' + write (*,*) ' This requires xtb version 6.6.0 or newer.' write (*,*) ' xTB-IFF can still be used with the --xtbiff flag.' write (*,*) end if @@ -73,7 +71,6 @@ subroutine crest_solvtool(env,tim) !------------------------------------------------------------------------------ ! Setup !------------------------------------------------------------------------------ - call write_qcg_setup(env) !Just an outprint of setup call read_qcg_input(env,solute,solvent) !Reading mol. data and determining r,V,A call qcg_setup(env,solute,solvent) @@ -127,7 +124,7 @@ subroutine crest_solvtool(env,tim) end if call pr_qcg_esolv() write (*,'(2x,"|",9x,F8.2," kcal/mol ",12x,"|")') & - & full_ensemble%g-solvent_ensemble%g-(solute%energy*eh) + & full_ensemble%g-solvent_ensemble%g-(solute%energy*autokcal) write (*,'(2x,''========================================='')') call chdir(thispath) progress = progress+1 @@ -139,12 +136,9 @@ subroutine crest_solvtool(env,tim) if (progress .le. env%qcg_runtype.and.progress .eq. 3) then !gsolv call qcg_freq(env,tim,solute,solvent,full_ensemble,solvent_ensemble) call qcg_eval(env,solute,full_ensemble,solvent_ensemble) - progress = progress+1 end if - !<---------------------------------- -! call tim%stop(2) !stop a timer !------------------------------------------------------------------------------ ! Cleanup and deallocation @@ -323,7 +317,7 @@ end subroutine qcg_setup !==============================================================================! subroutine read_qcg_input(env,solu,solv) - use iso_fortran_env,wp => real64 + use crest_parameters use crest_data use iomod use zdata @@ -334,7 +328,6 @@ subroutine read_qcg_input(env,solu,solv) type(systemdata) :: env type(zmolecule),intent(inout) :: solu,solv logical :: pr - real(wp),parameter :: amutokg = 1.66053886E-27 real(wp),parameter :: third = 1.0d0/3.0d0 integer :: i real(wp) :: r_solu,r_solv @@ -383,13 +376,13 @@ subroutine read_qcg_input(env,solu,solv) end subroutine read_qcg_input -!==============================================================================! -!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Read input for directed docking subroutine read_directed_input(env) - use iso_fortran_env,wp => real64 + use crest_parameters use crest_data implicit none @@ -459,9 +452,9 @@ subroutine read_directed_input(env) end subroutine read_directed_input -!==============================================================================! -!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< real64 + use crest_parameters use strucrd,only:i2e implicit none @@ -741,7 +733,7 @@ end subroutine both_ellipsout efix = clus%energy/sqrt(float(clus%nat)) dum = solu%energy if (iter .gt. 1) dum = e_each_cycle(iter-1) - e_diff = e_diff+eh*(e_each_cycle(iter)-solv%energy-dum) + e_diff = e_diff+autokcal*(e_each_cycle(iter)-solv%energy-dum) call ellipsout('cluster_cavity.coord',clus%nat,clus%at,clus%xyz,clus%ell_abc) call both_ellipsout('twopot_cavity.coord',clus%nat,clus%at,clus%xyz,& & clus%ell_abc,solu%ell_abc) @@ -752,7 +744,7 @@ end subroutine both_ellipsout !--- Movie file write (ich15,*) clus%nat - write (ich15,'('' SCF done '',2F16.8)') eh*(e_each_cycle(iter)-solv%energy-dum) + write (ich15,'('' SCF done '',2F16.8)') autokcal*(e_each_cycle(iter)-solv%energy-dum) do j = 1,clus%nat write (ich15,'(a,1x,3F24.10)') i2e(clus%at(j)),clus%xyz(1:3,j)*bohr end do @@ -762,7 +754,7 @@ end subroutine both_ellipsout call analyze_cluster(iter,clus%nat,solu%nat,solv%nat,clus%xyz,clus%at,shr_av,shr) write (*,'(x,i4,F13.6,1x,f7.2,3x,f8.2,6x,f6.3,3x,f8.3,3x,2f6.1,2x,f8.1,3x,a,x)') & - & iter,e_each_cycle(iter),eh*(e_each_cycle(iter)-solv%energy-dum),& + & iter,e_each_cycle(iter),autokcal*(e_each_cycle(iter)-solv%energy-dum),& & e_diff,dens,efix,shr_av,shr,clus%vtot,trim(optlevflag(env%optlev)) write (ich99,'(i4,F20.10,3x,f8.1)') iter,e_each_cycle(iter),clus%vtot @@ -773,7 +765,7 @@ end subroutine both_ellipsout end do mean = mean/iter mean_diff = mean-mean_old - write (ich88,'(i5,1x,3F13.8)') iter,E_inter(iter)*eh,mean,mean_diff + write (ich88,'(i5,1x,3F13.8)') iter,E_inter(iter)*autokcal,mean,mean_diff !--- Check if converged when no nsolv was given if (env%nsolv .eq. 0) then @@ -858,9 +850,9 @@ end subroutine both_ellipsout end subroutine qcg_grow -!==============================================================================! -!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< real64 + use crest_parameters use crest_data implicit none @@ -1390,7 +1381,7 @@ end subroutine aver write (ich98,'(i4,F20.10,3x,f8.1)') env%nsolv,ens%er(i),clus%atot write (*,'(x,i4,4x,F13.6,2x,f6.3,1x,f8.3,2x,2f6.1,3x,f8.1,3x,a)') & & i,ens%er(i),dens,e_fix(i),shr_av,shr,clus%atot,trim(optlevflag(env%optlev)) - e_fix(i) = e_fix(i)*eh/sqrt(float(clus%nat)) + e_fix(i) = e_fix(i)*autokcal/sqrt(float(clus%nat)) end do close (ich98) call copysub('cluster_energy.dat',resultspath) @@ -1399,9 +1390,9 @@ end subroutine aver write (*,*) call remove('full_ensemble.xyz') call sort_ensemble(ens,ens%er,'full_ensemble.xyz') - e_clus = ens%er*eh + e_clus = ens%er*autokcal call sort_min(ens%nall,1,1,e_clus) - ens%er = e_clus/eh !Overwrite ensemble energy with sorted one + ens%er = e_clus/autokcal !Overwrite ensemble energy with sorted one allocate (de(ens%nall),source=0.0d0) allocate (p(ens%nall),source=0.0d0) e0 = e_clus(1) @@ -1444,9 +1435,9 @@ end subroutine aver write (ich48,'(2x, ''cluster'',2x,''E_norm [Eh]'',2x, ''De [kcal]'', 4x, ''p'')') do j = 1,ens%nall if (j .lt. 10) then - write (ich48,'(5x,i0,3x,f11.6,5x,f6.4,3x,f6.4)') j,e_clus(j)/eh,de(j),p(j) + write (ich48,'(5x,i0,3x,f11.6,5x,f6.4,3x,f6.4)') j,e_clus(j)/autokcal,de(j),p(j) else - write (ich48,'(5x,i0,2x,f11.6,5x,f6.4,3x,f6.4)') j,e_clus(j)/eh,de(j),p(j) + write (ich48,'(5x,i0,2x,f11.6,5x,f6.4,3x,f6.4)') j,e_clus(j)/autokcal,de(j),p(j) end if end do close (ich48) @@ -1459,7 +1450,7 @@ end subroutine aver call ens%deallocate() call ens%open('final_ensemble.xyz') - ens%er = e_clus(1:k)/eh + ens%er = e_clus(1:k)/autokcal !--- Getting G,S,H write (*,*) @@ -1467,7 +1458,7 @@ end subroutine aver write (*,'(2x,''------------------------------------------------------------------------'')') write (*,'(2x,''Boltz. averaged energy of final cluster:'')') call aver(.true.,env,ens%nall,e_clus(1:ens%nall),S,H,G,sasa,.false.) - write (*,'(7x,''G /Eh :'',F14.8)') G/eh + write (*,'(7x,''G /Eh :'',F14.8)') G/autokcal write (*,'(7x,''T*S /kcal :'',f8.3)') S ens%g = G @@ -1518,9 +1509,9 @@ end subroutine aver end subroutine qcg_ensemble -!==============================================================================! -!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< real64 + use crest_parameters use crest_data implicit none @@ -1806,7 +1796,7 @@ end subroutine aver end if dum_e = e_empty(i) if (iter-nsolv .gt. 1) dum_e = e_cur(iter-1,i) - de = eh*(e_cur(iter,i)-solv%energy-dum_e) + de = autokcal*(e_cur(iter,i)-solv%energy-dum_e) de_tot(i) = de_tot(i)+de !---- Check if solvent added is repulsive if (de .gt. 0) then @@ -1894,7 +1884,7 @@ end subroutine aver !--- Getting energy and calculating properties call grepval('xtb_sp.out','| TOTAL ENERGY',e_there,e_cluster(i)) call grepval('xtb_sp.out',' :: add. restraining',e_there,e_fix(i)) - e_fix(i) = e_fix(i)*eh/sqrt(float(clus%nat)) + e_fix(i) = e_fix(i)*autokcal/sqrt(float(clus%nat)) call get_sphere(.false.,clus,.false.) if (clus%nat .gt. n_ini) then solv_added = (clus%nat-(n_ini))/solv%nat @@ -1949,13 +1939,13 @@ end subroutine aver write (*,'(2x,''------------------------------------------------------------------------'')') write (*,'(2x,''------------------------------------------------------------------------'')') write (*,'(2x,''Boltz. averaged energy of final cluster:'')') - e_cluster = solv_ens%er*eh - e_norm = e_norm*eh + e_cluster = solv_ens%er*autokcal + e_norm = e_norm*autokcal call sort_min(env%nqcgclust,1,1,e_norm) call aver(.true.,env,solv_ens%nall,e_norm(1:env%nqcgclust),S,H,G,sasa,.false.) - write (*,'(7x,''G /Eh :'',F14.8)') G/eh + write (*,'(7x,''G /Eh :'',F14.8)') G/autokcal write (*,'(7x,''T*S /kcal :'',f8.3)') S - solv_ens%er = e_norm/eh !normalized energy needed for final evaluation + solv_ens%er = e_norm/autokcal !normalized energy needed for final evaluation solv_ens%g = G solv_ens%s = S @@ -2254,7 +2244,7 @@ end subroutine qcg_freq !==============================================================================! subroutine qcg_eval(env,solu,solu_ens,solv_ens) - use iso_fortran_env,wp => real64 + use crest_parameters use crest_data use qcg_printouts use iomod @@ -2291,11 +2281,10 @@ subroutine qcg_eval(env,solu,solu_ens,solv_ens) real(wp) :: e_solvent(solv_ens%nall) real(wp) :: scal(20) integer :: ich23 - real(wp),parameter :: eh = 627.509541d0 interface subroutine aver(pr,env,runs,e_tot,S,H,G,sasa,a_present,a_tot) - use iso_fortran_env,only:wp => real64 + use crest_parameters use crest_data implicit none @@ -2326,14 +2315,14 @@ end subroutine aver !--- Solute Cluster !H_solv do i = 1,solu_ens%nall - e_solute(i) = solu_ens%er(i)*eh+solu_ens%ht(i) + e_solute(i) = solu_ens%er(i)*autokcal+solu_ens%ht(i) end do call aver(.false.,env,solu_ens%nall,e_solute,dum1,H_solute,dum2,sasa,.false.) !G_solv do i = 1,srange do j = 1,solu_ens%nall g1(j) = solu_ens%ht(j)-(env%tboltz*(solu_ens%svib(j)+scal(i)*(solu_ens%srot(j)+solu_ens%stra(j)))/1000) - e_solute(j) = solu_ens%er(j)*eh+g1(j) + e_solute(j) = solu_ens%er(j)*autokcal+g1(j) end do call aver(.false.,env,solu_ens%nall,e_solute,S(i),dum,G_solute(i),sasa,.false.) end do @@ -2341,7 +2330,7 @@ end subroutine aver !--- Solvent Cluster !H_solv do i = 1,solv_ens%nall - e_solvent(i) = solv_ens%er(i)*eh+solv_ens%ht(i) + e_solvent(i) = solv_ens%er(i)*autokcal+solv_ens%ht(i) end do call aver(.false.,env,solv_ens%nall,e_solvent,dum1,H_solvent,dum2,sasa,.false.) @@ -2350,16 +2339,16 @@ end subroutine aver do j = 1,solv_ens%nall g2(j) = solv_ens%ht(j)- & & (env%tboltz*(solv_ens%svib(j)+scal(i)*(solv_ens%srot(j)+solv_ens%stra(j)))/1000) - e_solvent(j) = solv_ens%er(j)*eh+g2(j) + e_solvent(j) = solv_ens%er(j)*autokcal+g2(j) end do call aver(.false.,env,solv_ens%nall,e_solvent,S(i),dum,G_solvent(i),sasa,.false.) end do !--- Solute gas phase - H_mono = solu%energy*eh+solu%ht + H_mono = solu%energy*autokcal+solu%ht do i = 1,srange g3 = solu%ht-(env%tboltz*(solu%svib+scal(i)*(solu%srot+solu%stra))/1000) - G_mono(i) = solu%energy*eh+g3 + G_mono(i) = solu%energy*autokcal+g3 end do Gsolv(1:20) = G_solute(1:20)-G_solvent(1:20)-G_mono(1:20) @@ -2400,7 +2389,6 @@ subroutine get_sphere(pr,zmol,r_logical) integer :: i real(wp) :: rad(zmol%nat),xyz_tmp(3,zmol%nat) - do i = 1,zmol%nat rad(i) = bohr*rcov_qcg(zmol%at(i))*1.40 ! scale factor adjusted to rough xyz_tmp(1:3,i) = bohr*zmol%xyz(1:3,i) @@ -2431,7 +2419,7 @@ end subroutine get_sphere !==============================================================================! subroutine cma_shifting(solu,solv) - use iso_fortran_env,wp => real64 + use crest_parameters use crest_data use iomod use zdata @@ -2455,10 +2443,10 @@ subroutine cma_shifting(solu,solv) end subroutine cma_shifting -!==============================================================================! +!==============================================================================! ! subroutine get_ellipsoid(env,solu,solv,clus,pr1) - use iso_fortran_env,wp => real64 + use crest_parameters use crest_data use iomod use zdata @@ -2476,8 +2464,7 @@ subroutine get_ellipsoid(env,solu,solv,clus,pr1) character(len=10) :: fname logical :: ex,pr,pr1 - real(wp),parameter :: pi43 = 3.1415926540d0*4.0d0/3.0d0 - real(wp),parameter :: pi = 3.1415926540d0 + real(wp),parameter :: pi43 = pi*4.0d0/3.0d0 real(wp),parameter :: third = 1.0d0/3.0d0 pr = .false. !Outprint deactivated @@ -2555,11 +2542,11 @@ subroutine get_ellipsoid(env,solu,solv,clus,pr1) end subroutine get_ellipsoid -!==============================================================================! +!==============================================================================! subroutine getmaxrad(n,at,xyz,r) use crest_parameters,only:wp - use miscdata, only: rcov_qcg + use miscdata,only:rcov_qcg implicit none real(wp) :: xyz(3,n),r integer :: n,at(n) @@ -2578,10 +2565,10 @@ subroutine getmaxrad(n,at,xyz,r) end do end subroutine getmaxrad -!==============================================================================! +!==============================================================================! subroutine ellipsout(fname,n,at,xyz,r1) - use iso_fortran_env,only:wp => real64 + use crest_parameters use strucrd,only:i2e implicit none @@ -2618,10 +2605,10 @@ subroutine ellipsout(fname,n,at,xyz,r1) end subroutine ellipsout -!==============================================================================! +!==============================================================================! subroutine both_ellipsout(fname,n,at,xyz,r1,r2) - use iso_fortran_env,only:wp => real64 + use crest_parameters use strucrd,only:i2e implicit none @@ -2677,10 +2664,10 @@ subroutine both_ellipsout(fname,n,at,xyz,r1,r2) end subroutine both_ellipsout -!==============================================================================! +!==============================================================================! subroutine analyze_cluster(nsolv,n,nS,nM,xyz,at,av,last) - use iso_fortran_env,only:wp => real64 + use crest_parameters use axis_module,only:cma implicit none real(wp) xyz(3,n) @@ -2715,10 +2702,10 @@ subroutine analyze_cluster(nsolv,n,nS,nM,xyz,at,av,last) av = av/float(nsolv-1) end subroutine analyze_cluster -!==============================================================================! +!==============================================================================! subroutine aver(pr,env,runs,e_tot,S,H,G,sasa,a_present,a_tot) - use iso_fortran_env,only:wp => real64 + use crest_parameters use crest_data implicit none @@ -2744,7 +2731,6 @@ subroutine aver(pr,env,runs,e_tot,S,H,G,sasa,a_present,a_tot) real(wp) :: beta real(wp) :: temp integer :: ich48 - real(wp),parameter :: eh = 627.509541d0 dimension e_tot(runs) dimension a_tot(runs) @@ -2779,13 +2765,13 @@ subroutine aver(pr,env,runs,e_tot,S,H,G,sasa,a_present,a_tot) write (ich48,'(2x, ''cluster'',2x,''E_norm [Eh]'',2x, ''De [kcal]'', 4x, ''p'')') do j = 1,runs if (j .lt. 10) then - write (ich48,'(5x,i0,3x,f11.6,5x,f6.4,3x,f6.4)') j,e_tot(j)/eh,de(j),p(j) + write (ich48,'(5x,i0,3x,f11.6,5x,f6.4,3x,f6.4)') j,e_tot(j)/autokcal,de(j),p(j) else - write (ich48,'(5x,i0,2x,f11.6,5x,f6.4,3x,f6.4)') j,e_tot(j)/eh,de(j),p(j) + write (ich48,'(5x,i0,2x,f11.6,5x,f6.4,3x,f6.4)') j,e_tot(j)/autokcal,de(j),p(j) end if end do write (ich48,*) - write (ich48,'(''Ensemble free energy [Eh]:'', f20.10)') G/eh + write (ich48,'(''Ensemble free energy [Eh]:'', f20.10)') G/autokcal close (ich48) end if @@ -2796,7 +2782,7 @@ end subroutine aver !==============================================================================! ! subroutine qcg_boltz(env,n,e,p) - use iso_fortran_env,only:wp => real64 + use crest_parameters use crest_data implicit none type(systemdata),intent(in) :: env @@ -2822,7 +2808,7 @@ end subroutine qcg_boltz !==============================================================================! subroutine fill_take(env,n2,n12,rabc,ipos) - use iso_fortran_env,only:wp => real64 + use crest_parameters use crest_data use strucrd use axis_module,only:cma @@ -2880,7 +2866,7 @@ end subroutine fill_take !==============================================================================! subroutine calc_dist(xyz,rabc,dist,eabc) - use iso_fortran_env,only:wp => real64 + use crest_parameters implicit none real(wp),intent(in) :: xyz(3) @@ -2898,7 +2884,7 @@ end subroutine calc_dist !==============================================================================! subroutine sort_min(i,j,col,A) - use iso_fortran_env,only:wp => real64 + use crest_parameters implicit none integer,intent(in) :: i,j,col real*8,intent(inout) :: A(i,j) @@ -2918,7 +2904,7 @@ end subroutine sort_min !==============================================================================! subroutine sort_ensemble(ens,e_ens,fname) - use iso_fortran_env,only:wp => real64 + use crest_parameters use crest_data use strucrd implicit none @@ -2944,7 +2930,7 @@ end subroutine sort_ensemble !==============================================================================! subroutine rdtherm(fname,ht,svib,srot,stra,gt) - use iso_fortran_env,only:wp => real64 + use crest_parameters use crest_data use iomod @@ -2964,7 +2950,6 @@ subroutine rdtherm(fname,ht,svib,srot,stra,gt) logical :: ende character(len=*) :: fname character(len=128) :: a - real(wp),parameter :: eh = 627.509541d0 integer :: ich ende = .false. @@ -2999,19 +2984,18 @@ subroutine rdtherm(fname,ht,svib,srot,stra,gt) end if if (counter .eq. hg_line+2) then call readl(a,xx,nn) - ht = xx(3)*eh - gt = xx(5)*eh + ht = xx(3)*autokcal + gt = xx(5)*autokcal end if counter = counter+1 end do close (ich) end subroutine rdtherm - !==============================================================================! subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup) - use iso_fortran_env,wp => real64 + use crest_parameters use crest_data use iomod use zdata @@ -3032,7 +3016,6 @@ subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup logical :: grow,solu_ensemble,solv_ensemble logical :: solv_cff,solv_present,freq,tmp,ex real(wp),allocatable :: xyz(:,:) - real(wp),parameter :: eh = 627.509541d0 grow = .false. solu_ensemble = .false. @@ -3130,7 +3113,7 @@ subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup write (*,'(" Ensemble of solute-cluster found.")') write (*,'(" Taking all ", i0, " structures")') env%nqcgclust call grepval('population.dat','Ensemble free energy [Eh]:',ex,solu_ens%G) - solu_ens%G = solu_ens%G*eh + solu_ens%G = solu_ens%G*autokcal write (*,*) 'Solute Ensmeble Free E [kcal/mol]',solu_ens%G call chdir(thispath) progress = 2 @@ -3165,7 +3148,7 @@ subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup call rdensemble('final_ensemble.xyz',solv_ens%nat,solv_ens%nall,solv_ens%at,solv_ens%xyz,solv_ens%er) end if call grepval('population.dat','Ensemble free energy [Eh]:',ex,solv_ens%G) - solv_ens%G = solv_ens%G*eh + solv_ens%G = solv_ens%G*autokcal write (*,*) 'solvent ensmeble free E [kcal/mol]',solv_ens%G call chdir(thispath) progress = 3 @@ -3181,7 +3164,7 @@ subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup end subroutine qcg_restart -!==============================================================================! +!==============================================================================! ! subroutine qcg_cleanup(env) use crest_data @@ -3202,7 +3185,7 @@ subroutine qcg_cleanup(env) end subroutine qcg_cleanup -!==============================================================================! +!==============================================================================! subroutine write_reference(env,solu,clus) use iso_fortran_env,wp => real64 @@ -3230,7 +3213,7 @@ end subroutine write_reference !> Write "solute" and "solvent" coordinate files !========================================================================================! subroutine inputcoords_qcg(env,solute,solvent) - use iso_fortran_env,only:wp => real64 + use crest_parameters use crest_data use strucrd use zdata @@ -3301,4 +3284,4 @@ subroutine inputcoords_qcg(env,solute,solvent) return end subroutine inputcoords_qcg -!==============================================================================! +!==============================================================================! diff --git a/src/qcg/solvtool_misc.f90 b/src/qcg/solvtool_misc.f90 index 7dd1724a..8d301b15 100644 --- a/src/qcg/solvtool_misc.f90 +++ b/src/qcg/solvtool_misc.f90 @@ -21,7 +21,7 @@ ! A quick single point xtb calculation without wbo !-------------------------------------------------------------------------------------------- subroutine xtb_sp_qcg(env,fname) - use iso_fortran_env,only:wp => real64 + use crest_parameters use iomod use crest_data implicit none @@ -55,7 +55,7 @@ end subroutine xtb_sp_qcg ! A quick single xtb optimization gets zmol and overwrites it with optimized stuff !-------------------------------------------------------------------------------------------- subroutine xtb_opt_qcg(env,zmol,constrain) - use iso_fortran_env,only:wp => real64 + use crest_parameters use iomod use crest_data use zdata @@ -106,7 +106,7 @@ end subroutine xtb_opt_qcg !___________________________________________________________________________________ subroutine xtb_lmo(env,fname)!,chrg) - use iso_fortran_env,only:wp => real64 + use crest_parameters use iomod use crest_data use zdata @@ -147,7 +147,7 @@ end subroutine xtb_lmo !___________________________________________________________________________________ subroutine xtb_iff(env,file_lmo1,file_lmo2,solu,clus) - use iso_fortran_env,only:wp => real64 + use crest_parameters use iomod use crest_data use zdata @@ -191,7 +191,7 @@ end subroutine xtb_iff !___________________________________________________________________________________ subroutine xtb_dock(env,fnameA,fnameB,solu,clus) - use iso_fortran_env,only:wp => real64 + use crest_parameters use iomod use crest_data use zdata @@ -251,7 +251,7 @@ end subroutine xtb_dock !___________________________________________________________________________________ subroutine opt_cluster(env,solu,clus,fname,without_pot) - use iso_fortran_env,only:wp => real64 + use crest_parameters use iomod use crest_data use zdata @@ -316,7 +316,7 @@ end subroutine opt_cluster !___________________________________________________________________________________ subroutine ensemble_lmo(env,fname,self,NTMP,TMPdir,conv) - use iso_fortran_env,only:wp => real64 + use crest_parameters use iomod use crest_data use zdata @@ -383,7 +383,7 @@ end subroutine ensemble_lmo !___________________________________________________________________________________ subroutine ensemble_iff(env,outer_ell_abc,nfrag1,frag1_file,frag2_file,NTMP,TMPdir,conv) - use iso_fortran_env,only:wp => real64 + use crest_parameters use iomod use crest_data use zdata @@ -452,7 +452,7 @@ end subroutine ensemble_iff subroutine ensemble_dock(env,outer_ell_abc,nfrag1,frag1_file,frag2_file,n_shell& &,n_solvent,NTMP,TMPdir,conv) - use iso_fortran_env,only:wp => real64 + use crest_parameters use iomod use crest_data use zdata @@ -544,7 +544,7 @@ end subroutine ensemble_dock !___________________________________________________________________________________ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) - use iso_fortran_env,only:wp => real64 + use crest_parameters use iomod use crest_data use strucrd @@ -701,7 +701,7 @@ end subroutine cff_opt !___________________________________________________________________________________ subroutine ens_sp(env,fname,NTMP,TMPdir) - use iso_fortran_env,only:wp => real64 + use crest_parameters use iomod use crest_data use strucrd @@ -783,7 +783,7 @@ end subroutine ens_sp !___________________________________________________________________________________ subroutine ens_freq(env,fname,NTMP,TMPdir,opt) - use iso_fortran_env,only:wp => real64 + use crest_parameters use iomod use crest_data use strucrd @@ -910,7 +910,7 @@ subroutine rdxtbiffE(fname,m,n,e) !============================================================! subroutine wr_cluster_cut(fname_cluster,n1,n2,iter,fname_solu_cut,fname_solv_cut) - use iso_fortran_env,only:wp => real64 + use crest_parameters use strucrd implicit none @@ -952,7 +952,7 @@ subroutine wr_cluster_cut(fname_cluster,n1,n2,iter,fname_solu_cut,fname_solv_cut end subroutine wr_cluster_cut subroutine check_iff(neg_E) - use iso_fortran_env,only:wp => real64 + use crest_parameters use crest_data implicit none @@ -986,7 +986,7 @@ end subroutine check_iff ! write a wall potential in a file used as xtb input subroutine write_wall(env,n1,rabc1,rabc12,fname) - use iso_fortran_env,only:wp => real64 + use crest_parameters use crest_data implicit none @@ -1018,7 +1018,7 @@ subroutine write_wall(env,n1,rabc1,rabc12,fname) end subroutine write_wall subroutine check_dock(neg_E) - use iso_fortran_env,only:wp => real64 + use crest_parameters use crest_data use iomod,only:minigrep,grepval @@ -1041,7 +1041,7 @@ subroutine check_dock(neg_E) end subroutine check_dock subroutine write_constraint(env,coord_name,fname) - use iso_fortran_env,only:wp => real64 + use crest_parameters use crest_data use iomod From e0bbbff3f110a57880cccc957733ba28b1ca102a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 8 Nov 2025 22:56:28 +0100 Subject: [PATCH 079/374] More routines movearound in QCG --- src/qcg/CMakeLists.txt | 2 +- src/qcg/qcg_utils.f90 | 202 +++++++++++++++++++++++++++++++++ src/qcg/solvtool.f90 | 248 +---------------------------------------- 3 files changed, 208 insertions(+), 244 deletions(-) create mode 100644 src/qcg/qcg_utils.f90 diff --git a/src/qcg/CMakeLists.txt b/src/qcg/CMakeLists.txt index f004ec32..87ac0616 100644 --- a/src/qcg/CMakeLists.txt +++ b/src/qcg/CMakeLists.txt @@ -21,7 +21,7 @@ list(APPEND srcs "${dir}/solvtool_misc.f90" "${dir}/solvtool.f90" "${dir}/qcg_printouts.f90" - # "${dir}/qcg_utils.f90" + "${dir}/qcg_utils.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/qcg/qcg_utils.f90 b/src/qcg/qcg_utils.f90 new file mode 100644 index 00000000..8ea2a95b --- /dev/null +++ b/src/qcg/qcg_utils.f90 @@ -0,0 +1,202 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2021-2025 Christoph Plett, Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module qcg_utils + use crest_parameters,only:stdout,wp + use crest_data + use iomod + implicit none + public + +contains + +!========================================================================================! +!> Convert given QCG coordinate files into (TM format) +!> Write "solute" and "solvent" coordinate files +!========================================================================================! + subroutine inputcoords_qcg(env,solute,solvent) + use crest_parameters + use crest_data + use strucrd + use zdata + use iomod + implicit none + + type(systemdata),intent(inout) :: env + type(zmolecule),intent(out) :: solute,solvent + + logical :: ex11,ex21,solu,solv + type(coord) :: mol + type(zmolecule) :: zmol,zmol1 + integer :: i + +!--------------------Checking for input-------------! + + !Solute + inquire (file=env%solu_file,exist=ex11) + inquire (file='solute',exist=solu) + if (solu) call copy('solute','solute.old') !Backup solute file + if ((.not.ex11).and.(.not.solu)) then + error stop 'No (valid) solute file! exit.' + else if ((.not.ex11).and.(solu)) then + env%solu_file = 'solute' + end if + + !Solvent + inquire (file=env%solv_file,exist=ex21) + inquire (file='solvent',exist=solv) + if (solu) call copy('solvent','solvent.old') !Backup solvent file + if ((.not.ex21).and.(.not.solv)) then + error stop 'No (valid) solvent file! exit.' + else if ((.not.ex11).and.(solu)) then + env%solu_file = 'solvent' + end if + +!---------------Handling solute---------------------! + call mol%open(env%solu_file) + call mol%write('solute') + solute%nat = mol%nat + solute%at = mol%at + solute%xyz = mol%xyz + call mol%deallocate() + + !--- if the input was a SDF file, special handling + env%sdfformat = .false. + call checkcoordtype(env%solu_file,i) + if (i == 31.or.i == 32) then + !Add sdf stuff here, if somebody needs it + end if + +!---------------Handling solvent---------------------! + + call mol%open(env%solv_file) + call mol%write('solvent') + solvent%nat = mol%nat + solvent%at = mol%at + solvent%xyz = mol%xyz + call mol%deallocate() + + !--- if the input was a SDF file, special handling + env%sdfformat = .false. + call checkcoordtype(env%solv_file,i) + if (i == 31.or.i == 32) then + !Add sdf stuff here, if somebody needs it + end if + + return + end subroutine inputcoords_qcg + +!==============================================================================! + + subroutine write_reference(env,solu,clus) + use crest_data + use zdata,only:zmolecule + use iomod + use strucrd + implicit none + type(systemdata):: env ! MAIN STORAGE OS SYSTEM DATA + type(zmolecule) :: solu,clus + type(zmolecule) :: ref_mol,ref_clus + ref_mol = solu + call rdcoord(env%solu_file,ref_mol%nat,ref_mol%at,ref_mol%xyz) !original solute coordinates + call remove(env%fixfile) + ref_clus = clus + ref_clus%xyz(1:3,1:solu%nat) = solu%xyz + call wrc0(env%fixfile,ref_clus%nat,ref_clus%at,ref_clus%xyz) + end subroutine write_reference + +!=============================================================================! + + subroutine aver(pr,env,runs,e_tot,S,H,G,sasa,a_present,a_tot) + use crest_parameters + use crest_data + + implicit none +!---- Dummy + type(systemdata),intent(in) :: env + integer,intent(in) :: runs + real(wp),intent(inout) :: e_tot + real(wp),intent(in),optional :: a_tot + real(wp),intent(out) :: S + real(wp),intent(out) :: H + real(wp),intent(out) :: G + real(wp),intent(out) :: sasa +!---- Stack + logical,intent(in) :: pr,a_present + integer :: j,jmin + real(wp) :: A + real(wp) :: e0 + real(wp),allocatable :: de(:) + real(wp),allocatable :: p(:) + real(wp) :: pmax + real(wp) :: eav + real(wp) :: area + real(wp) :: beta + real(wp) :: temp + integer :: ich48 + dimension e_tot(runs) + dimension a_tot(runs) + + temp = env%tboltz + allocate (de(runs),source=0.0d0) + allocate (p(runs),source=0.0d0) + + beta = 1./(temp*8.314510/4.184/1000.+1.d-14) + e0 = e_tot(1) + de(1:runs) = (e_tot(1:runs)-e0) + call qcg_boltz(env,runs,de,p) + + A = 0 + eav = 0 + pmax = 0 + area = 0 + do j = 1,runs + A = A+p(j)*log(p(j)+1.d-12) + eav = eav+p(j)*e_tot(j) + if (p(j) .gt. pmax) then + pmax = p(j) + jmin = j + end if + if (a_present) area = area+p(j)*a_tot(j) + end do + sasa = area + S = (1./beta)*A + H = eav + G = eav+S + if (pr) then + open (newunit=ich48,file='population.dat') + write (ich48,'(2x, ''cluster'',2x,''E_norm [Eh]'',2x, ''De [kcal]'', 4x, ''p'')') + do j = 1,runs + if (j .lt. 10) then + write (ich48,'(5x,i0,3x,f11.6,5x,f6.4,3x,f6.4)') j,e_tot(j)/autokcal,de(j),p(j) + else + write (ich48,'(5x,i0,2x,f11.6,5x,f6.4,3x,f6.4)') j,e_tot(j)/autokcal,de(j),p(j) + end if + end do + write (ich48,*) + write (ich48,'(''Ensemble free energy [Eh]:'', f20.10)') G/autokcal + close (ich48) + end if + + deallocate (de,p) + + end subroutine aver + + !=============================================================================! +end module qcg_utils diff --git a/src/qcg/solvtool.f90 b/src/qcg/solvtool.f90 index 48ad9997..bf6e253d 100644 --- a/src/qcg/solvtool.f90 +++ b/src/qcg/solvtool.f90 @@ -323,6 +323,7 @@ subroutine read_qcg_input(env,solu,solv) use zdata use strucrd use atmasses + use qcg_utils implicit none type(systemdata) :: env @@ -463,6 +464,7 @@ subroutine qcg_grow(env,solu,solv,clus,tim) use iomod use zdata use strucrd + use qcg_utils implicit none type(systemdata) :: env @@ -863,6 +865,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) use strucrd use utilities use cregen_interface + use qcg_utils implicit none type(systemdata) :: env @@ -898,26 +901,6 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) logical :: not_param = .false. type(timer) :: tim_dum !Dummy timer to avoid double counting - interface - subroutine aver(pr,env,runs,e_tot,S,H,G,sasa,a_present,a_tot) - use crest_parameters - use crest_data - - implicit none - type(systemdata),intent(in) :: env - integer,intent(in) :: runs - real(wp),intent(inout) :: e_tot - real(wp),intent(in),optional :: a_tot - real(wp),intent(out) :: S - real(wp),intent(out) :: H - real(wp),intent(out) :: G - real(wp),intent(out) :: sasa - logical,intent(in) :: pr,a_present - dimension e_tot(runs) - dimension a_tot(runs) - end subroutine aver - end interface - if (.not.env%solv_md) then call tim%start(6,'Solute-Ensemble') else @@ -1520,7 +1503,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) use iomod use zdata use strucrd - + use qcg_utils implicit none type(systemdata) :: env @@ -1562,26 +1545,6 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) real(wp) :: optlev_tmp integer :: ich98,ich31 - interface - subroutine aver(pr,env,runs,e_tot,S,H,G,sasa,a_present,a_tot) - use crest_parameters - use crest_data - - implicit none - type(systemdata),intent(in) :: env - integer,intent(in) :: runs - real(wp),intent(inout) :: e_tot - real(wp),intent(in),optional :: a_tot - real(wp),intent(out) :: S - real(wp),intent(out) :: H - real(wp),intent(out) :: G - real(wp),intent(out) :: sasa - logical,intent(in) :: pr,a_present - dimension e_tot(runs) - dimension a_tot(runs) - end subroutine aver - end interface - call tim%start(8,'CFF') allocate (e_empty(env%nqcgclust)) @@ -2250,7 +2213,7 @@ subroutine qcg_eval(env,solu,solu_ens,solv_ens) use iomod use zdata use strucrd - + use qcg_utils implicit none type(systemdata) :: env @@ -2282,26 +2245,6 @@ subroutine qcg_eval(env,solu,solu_ens,solv_ens) real(wp) :: scal(20) integer :: ich23 - interface - subroutine aver(pr,env,runs,e_tot,S,H,G,sasa,a_present,a_tot) - use crest_parameters - use crest_data - - implicit none - type(systemdata),intent(in) :: env - integer,intent(in) :: runs - real(wp),intent(inout) :: e_tot - real(wp),intent(in),optional :: a_tot - real(wp),intent(out) :: S - real(wp),intent(out) :: H - real(wp),intent(out) :: G - real(wp),intent(out) :: sasa - logical,intent(in) :: pr,a_present - dimension e_tot(runs) - dimension a_tot(runs) - end subroutine aver - end interface - call pr_eval_eval() call getcwd(thispath) @@ -2702,83 +2645,6 @@ subroutine analyze_cluster(nsolv,n,nS,nM,xyz,at,av,last) av = av/float(nsolv-1) end subroutine analyze_cluster -!==============================================================================! - -subroutine aver(pr,env,runs,e_tot,S,H,G,sasa,a_present,a_tot) - use crest_parameters - use crest_data - - implicit none -!---- Dummy - type(systemdata),intent(in) :: env - integer,intent(in) :: runs - real(wp),intent(inout) :: e_tot - real(wp),intent(in),optional :: a_tot - real(wp),intent(out) :: S - real(wp),intent(out) :: H - real(wp),intent(out) :: G - real(wp),intent(out) :: sasa -!---- Stack - logical,intent(in) :: pr,a_present - integer :: j,jmin - real(wp) :: A - real(wp) :: e0 - real(wp),allocatable :: de(:) - real(wp),allocatable :: p(:) - real(wp) :: pmax - real(wp) :: eav - real(wp) :: area - real(wp) :: beta - real(wp) :: temp - integer :: ich48 - dimension e_tot(runs) - dimension a_tot(runs) - - temp = env%tboltz - allocate (de(runs),source=0.0d0) - allocate (p(runs),source=0.0d0) - - beta = 1./(temp*8.314510/4.184/1000.+1.d-14) - e0 = e_tot(1) - de(1:runs) = (e_tot(1:runs)-e0) - call qcg_boltz(env,runs,de,p) - - A = 0 - eav = 0 - pmax = 0 - area = 0 - do j = 1,runs - A = A+p(j)*log(p(j)+1.d-12) - eav = eav+p(j)*e_tot(j) - if (p(j) .gt. pmax) then - pmax = p(j) - jmin = j - end if - if (a_present) area = area+p(j)*a_tot(j) - end do - sasa = area - S = (1./beta)*A - H = eav - G = eav+S - if (pr) then - open (newunit=ich48,file='population.dat') - write (ich48,'(2x, ''cluster'',2x,''E_norm [Eh]'',2x, ''De [kcal]'', 4x, ''p'')') - do j = 1,runs - if (j .lt. 10) then - write (ich48,'(5x,i0,3x,f11.6,5x,f6.4,3x,f6.4)') j,e_tot(j)/autokcal,de(j),p(j) - else - write (ich48,'(5x,i0,2x,f11.6,5x,f6.4,3x,f6.4)') j,e_tot(j)/autokcal,de(j),p(j) - end if - end do - write (ich48,*) - write (ich48,'(''Ensemble free energy [Eh]:'', f20.10)') G/autokcal - close (ich48) - end if - - deallocate (de,p) - -end subroutine aver - !==============================================================================! ! subroutine qcg_boltz(env,n,e,p) @@ -2890,7 +2756,6 @@ subroutine sort_min(i,j,col,A) real*8,intent(inout) :: A(i,j) real*8 :: buf(j) integer :: nsize,irow,krow -! dimension A(i,j) nsize = i do irow = 1,nsize @@ -3168,13 +3033,10 @@ end subroutine qcg_restart ! subroutine qcg_cleanup(env) use crest_data - implicit none - type(systemdata) :: env character(len=280) :: thispath logical :: tmp - call getcwd(thispath) call chdir(env%scratchdir) inquire (file='./solute_properties/solute',exist=tmp) @@ -3182,106 +3044,6 @@ subroutine qcg_cleanup(env) call rmrf('solute_properties') call rmrf('solvent_properties') end if - end subroutine qcg_cleanup !==============================================================================! - -subroutine write_reference(env,solu,clus) - use iso_fortran_env,wp => real64 - use crest_data - use zdata,only:zmolecule - use iomod - use strucrd - - implicit none - type(systemdata):: env ! MAIN STORAGE OS SYSTEM DATA - type(zmolecule) :: solu,clus - type(zmolecule) :: ref_mol,ref_clus - - ref_mol = solu - call rdcoord(env%solu_file,ref_mol%nat,ref_mol%at,ref_mol%xyz) !original solute coordinates - call remove(env%fixfile) - ref_clus = clus - ref_clus%xyz(1:3,1:solu%nat) = solu%xyz - call wrc0(env%fixfile,ref_clus%nat,ref_clus%at,ref_clus%xyz) - -end subroutine write_reference - -!========================================================================================! -!> Convert given QCG coordinate files into (TM format) -!> Write "solute" and "solvent" coordinate files -!========================================================================================! -subroutine inputcoords_qcg(env,solute,solvent) - use crest_parameters - use crest_data - use strucrd - use zdata - use iomod - implicit none - - type(systemdata),intent(inout) :: env - type(zmolecule),intent(out) :: solute,solvent - - logical :: ex11,ex21,solu,solv - type(coord) :: mol - type(zmolecule) :: zmol,zmol1 - integer :: i - -!--------------------Checking for input-------------! - - !Solute - inquire (file=env%solu_file,exist=ex11) - inquire (file='solute',exist=solu) - if (solu) call copy('solute','solute.old') !Backup solute file - if ((.not.ex11).and.(.not.solu)) then - error stop 'No (valid) solute file! exit.' - else if ((.not.ex11).and.(solu)) then - env%solu_file = 'solute' - end if - - !Solvent - inquire (file=env%solv_file,exist=ex21) - inquire (file='solvent',exist=solv) - if (solu) call copy('solvent','solvent.old') !Backup solvent file - if ((.not.ex21).and.(.not.solv)) then - error stop 'No (valid) solvent file! exit.' - else if ((.not.ex11).and.(solu)) then - env%solu_file = 'solvent' - end if - -!---------------Handling solute---------------------! - call mol%open(env%solu_file) - call mol%write('solute') - solute%nat = mol%nat - solute%at = mol%at - solute%xyz = mol%xyz - call mol%deallocate() - - !--- if the input was a SDF file, special handling - env%sdfformat = .false. - call checkcoordtype(env%solu_file,i) - if (i == 31.or.i == 32) then - !Add sdf stuff here, if somebody needs it - end if - -!---------------Handling solvent---------------------! - - call mol%open(env%solv_file) - call mol%write('solvent') - solvent%nat = mol%nat - solvent%at = mol%at - solvent%xyz = mol%xyz - call mol%deallocate() - - !--- if the input was a SDF file, special handling - env%sdfformat = .false. - call checkcoordtype(env%solv_file,i) - if (i == 31.or.i == 32) then - !Add sdf stuff here, if somebody needs it - end if - - return -end subroutine inputcoords_qcg - -!==============================================================================! From 43d082b6e69af9afc45928efa38feb9107ad87d2 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 9 Nov 2025 01:54:20 +0100 Subject: [PATCH 080/374] Implement calculator call into xtb_sp_qcg --- src/classes.f90 | 92 +++++++++++++++++--------------- src/qcg/qcg_utils.f90 | 5 +- src/qcg/solvtool.f90 | 30 +++++------ src/qcg/solvtool_misc.f90 | 107 +++++++++++++++++++++++++------------- src/restartlog.f90 | 1 + 5 files changed, 140 insertions(+), 95 deletions(-) diff --git a/src/classes.f90 b/src/classes.f90 index 5a4ec50f..9affea57 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -28,7 +28,7 @@ module crest_data use bh_module,only:bh_class use strucrd,only:coord use crest_type_timer,only:timer - use lwoniom_module, only: lwoniom_input + use lwoniom_module,only:lwoniom_input implicit none public :: systemdata @@ -119,7 +119,7 @@ module crest_data integer,parameter,public :: status_normal = 0 !> success integer,parameter,public :: status_error = 1 !> general error integer,parameter,public :: status_ioerr = 2 !> general I/O error - integer,parameter,public :: status_args = 4 !> invalid subroutine arguments + integer,parameter,public :: status_args = 4 !> invalid subroutine arguments integer,parameter,public :: status_input = 10 !> Input file read error integer,parameter,public :: status_config = 20 !> invalid configuration integer,parameter,public :: status_failed = 155 !> general calculation failure @@ -183,7 +183,7 @@ module crest_data !************************************************************ !* separate settings for protonation and related procedures !************************************************************ - integer :: nfrag = 0 + integer :: nfrag = 0 integer :: newchrg = 0 integer :: iter = 1 real(wp) :: ewin = 30.0_wp !> separate EWIN threshold @@ -289,7 +289,7 @@ module crest_data integer :: pcap = 50000 !> limit number of structures logical :: avbhess = .false. !> use bhess in the msRRHO average calc. for all structures (expensive!) logical :: constrhess = .false. !> apply constraints in rrhoav? - logical :: printpop = .false. !> print a file with populations at different T + logical :: printpop = .false. !> print a file with populations at different T contains procedure :: get_temps => thermo_get_temps procedure :: read_temps => thermo_read_temps @@ -313,6 +313,7 @@ module crest_data real(wp),allocatable :: wbo(:,:) real(wp),allocatable :: efield(:) contains + procedure :: init => ref_init procedure :: rdcharges => read_charges procedure :: to => ref_to_mol procedure :: load => ref_load_mol @@ -384,7 +385,7 @@ module crest_data logical :: omp_allow_nested = .true. !> allow nested OpenMP threadding !>--- various names and flags - character(len=128) :: ensemblename = '' !> ensemble input name for SCREEN,MDOPT and CREGEN + character(len=128) :: ensemblename = '' !> ensemble input name for SCREEN,MDOPT and CREGEN character(len=128) :: ensemblename2 = '' !> another ensemble input name character(len=128) :: fixfile = '' character(len=512) :: constraints = '' !> name of the constraint file @@ -441,7 +442,7 @@ module crest_data !>--- NCI mode data real(wp) :: potscal = 1.0_wp - real(wp) :: potpad = 0.0_wp + real(wp) :: potpad = 0.0_wp character(len=:),allocatable :: potatlist !>--- Nanoreactor data @@ -465,9 +466,9 @@ module crest_data integer :: nqcgclust = 0 !> Number of cluster to be taken integer :: max_solv = 0 !> Maximal number of solvents added, if none is given integer :: ensemble_method = -1 !> Default -1 for qcgmtd, 0= crest, 1= standard MD, 2= MTD - character(len=:), allocatable :: directed_file !name of the directed list - character(len=64), allocatable :: directed_list(:,:) !How many solvents at which atom to add - integer, allocatable :: directed_number(:) !Numbers of solvents added per defined atom + character(len=:),allocatable :: directed_file !name of the directed list + character(len=64),allocatable :: directed_list(:,:) !How many solvents at which atom to add + integer,allocatable :: directed_number(:) !Numbers of solvents added per defined atom character(len=20) :: ensemble_opt = '' !> Method for ensemble optimization in qcg mode character(len=20) :: freqver = '' !> Method for frequency computation in qcg mode real(wp) :: freq_scal !> Frequency scaling factor @@ -518,14 +519,14 @@ module crest_data !================================================! !>--- msreact mode settings - logical :: msei =.true. ! use the ei mode as default - logical :: mscid =.false. ! use the cid mode - logical :: msnoiso =.false. ! print only dissociated structures in msreact - logical :: msiso =.false. ! only print non-dissociated structures in msreact - logical :: msmolbar =.false. ! sort out duplicates by molbar - logical :: msinchi =.false. ! sort out duplicates by inchi - logical :: mslargeprint=.false. ! dont remove temporary files - logical :: msattrh=.true. ! add attractive potential for H-atoms + logical :: msei = .true. ! use the ei mode as default + logical :: mscid = .false. ! use the cid mode + logical :: msnoiso = .false. ! print only dissociated structures in msreact + logical :: msiso = .false. ! only print non-dissociated structures in msreact + logical :: msmolbar = .false. ! sort out duplicates by molbar + logical :: msinchi = .false. ! sort out duplicates by inchi + logical :: mslargeprint = .false. ! dont remove temporary files + logical :: msattrh = .true. ! add attractive potential for H-atoms integer :: msnbonds = 3 ! distance of bonds up to nonds are stretched integer :: msnshifts = 0 ! number of random shifts applied to whole mol integer :: msnshifts2 = 0 ! number of random shifts applied to whole mol @@ -572,7 +573,7 @@ module crest_data logical :: legacy = .false. !> switch between the original system call routines of crest and newer, e.g. tblite implementations logical :: metadynset !> is the number of MTDs already set (V2) ? logical :: methautocorr !> try to automatically include Methyl equivalencies in CREGEN ? - logical :: multilevelopt =.true. !> perform the multileveloptimization + logical :: multilevelopt = .true. !> perform the multileveloptimization logical :: newcregen = .false. !> use the CREGEN rewrite logical :: NCI !> NCI special usage logical :: niceprint !> make a nice progress-bar printout @@ -604,7 +605,7 @@ module crest_data logical :: riso = .false. !> take only isomers in reactor mode logical :: rotamermds !> do additional MDs after second multilevel OPT step in V2 ? logical :: refine_presort = .false. !> run CREGEN at the beginning of crest_refine? - logical :: refine_esort = .false. !> if CREGEN is run after crest_refine, only sort energy? + logical :: refine_esort = .false. !> if CREGEN is run after crest_refine, only sort energy? logical :: sameRandomNumber = .false. !> QCG related, choose same random number for iff logical :: scallen !> scale the automatically determined MD length by some factor? logical :: scratch !> use scratch directory @@ -761,14 +762,13 @@ subroutine pqueue_removehybrid(self) return end subroutine pqueue_removehybrid - subroutine add_to_refinequeue(self,refinetype) implicit none class(systemdata) :: self integer :: refinetype integer :: idum integer,allocatable :: qdum(:) - if( refinetype <= 0 ) return + if (refinetype <= 0) return if (.not.allocated(self%refine_queue)) then allocate (self%refine_queue(1)) self%refine_queue(1) = refinetype @@ -836,6 +836,15 @@ subroutine wrtCHRG(self,dir) end subroutine wrtCHRG !========================================================================================! + subroutine ref_init(self,nat) + class(refdata) :: self + integer,intent(in) :: nat + if (allocated(self%at)) deallocate (self%at) + if (allocated(self%xyz)) deallocate (self%xyz) + allocate (self%at(nat),source=0) + allocate (self%xyz(3,nat),source=0.0_wp) + end subroutine ref_init + !> read atomic charges from a file (one line per atom) subroutine read_charges(self,chargesfilename,totchrg) implicit none @@ -869,8 +878,8 @@ subroutine ref_to_mol(self,mol) class(refdata) :: self type(coord) :: mol mol%nat = self%nat - if(allocated(self%at)) mol%at = self%at - if(allocated(self%xyz)) mol%xyz = self%xyz + if (allocated(self%at)) mol%at = self%at + if (allocated(self%xyz)) mol%xyz = self%xyz mol%chrg = self%ichrg mol%uhf = self%uhf return @@ -880,11 +889,12 @@ subroutine ref_load_mol(self,mol) implicit none class(refdata) :: self type(coord) :: mol - self%nat = mol%nat - self%at = mol%at - self%xyz = mol%xyz - self%ichrg = mol%chrg - self%uhf = mol%uhf + call self%init(mol%nat) + self%nat = mol%nat + self%at = mol%at + self%xyz = mol%xyz + self%ichrg = mol%chrg + self%uhf = mol%uhf return end subroutine ref_load_mol @@ -920,7 +930,7 @@ function optlevnum(flag) result(optlev) if (index(flag,'tight') .ne. 0) optlev = 1.0d0 if (index(flag,'verytight') .ne. 0) optlev = 2.0d0 if (index(flag,'vtight') .ne. 0) optlev = 2.0d0 - if (index(flag,'extreme') .ne. 0) optlev = 3.0d0 + if (index(flag,'extreme') .ne. 0) optlev = 3.0d0 if (index(flag,'3') .ne. 0) optlev = 3.0d0 if (index(flag,'2') .ne. 0) optlev = 2.0d0 if (index(flag,'1') .ne. 0) optlev = 1.0d0 @@ -948,23 +958,23 @@ subroutine optlev_to_multilev(optlev,multilev) real(wp),intent(in) :: optlev logical,intent(out) :: multilev(6) integer :: j - if (optlev <= 3.0d0)then !> "extreme" thresholds + if (optlev <= 3.0d0) then !> "extreme" thresholds multilev(:) = .false. multilev(6) = .true. multilev(4) = .true. multilev(1) = .true. - endif + end if j = optlevmap_alt(optlev) - j = max(j-1, 1) !> j is reduced by one - if (optlev <= 2.0d0)then !> "normal" to "vtight" - multilev(:) = .false. - multilev(1) = .true. - multilev(j) = .true. - endif - if (optlev <= -1.0d0)then !> "loose" to "crude" - multilev(:) = .false. - multilev(j) = .true. - endif + j = max(j-1,1) !> j is reduced by one + if (optlev <= 2.0d0) then !> "normal" to "vtight" + multilev(:) = .false. + multilev(1) = .true. + multilev(j) = .true. + end if + if (optlev <= -1.0d0) then !> "loose" to "crude" + multilev(:) = .false. + multilev(j) = .true. + end if end subroutine optlev_to_multilev !========================================================================================! diff --git a/src/qcg/qcg_utils.f90 b/src/qcg/qcg_utils.f90 index 8ea2a95b..fab7501d 100644 --- a/src/qcg/qcg_utils.f90 +++ b/src/qcg/qcg_utils.f90 @@ -74,7 +74,6 @@ subroutine inputcoords_qcg(env,solute,solvent) solute%nat = mol%nat solute%at = mol%at solute%xyz = mol%xyz - call mol%deallocate() !--- if the input was a SDF file, special handling env%sdfformat = .false. @@ -82,7 +81,9 @@ subroutine inputcoords_qcg(env,solute,solvent) if (i == 31.or.i == 32) then !Add sdf stuff here, if somebody needs it end if - + !--- Add as ref structure in env + call env%ref%load(mol) + call mol%deallocate() !---------------Handling solvent---------------------! call mol%open(env%solv_file) diff --git a/src/qcg/solvtool.f90 b/src/qcg/solvtool.f90 index bf6e253d..bda94560 100644 --- a/src/qcg/solvtool.f90 +++ b/src/qcg/solvtool.f90 @@ -172,7 +172,7 @@ subroutine qcg_setup(env,solu,solv) integer :: io,f,r integer :: num_O,num_H,i character(len=*),parameter :: outfmt = '(1x,1x,a,1x,f14.7,a,1x)' - logical :: e_there,tmp,used_tmp + logical :: e_there,tmp,used_tmp,gbsa_tmp character(len=512) :: thispath,tmp_grow character(len=40) :: solv_tmp character(len=80) :: atmp @@ -208,7 +208,9 @@ subroutine qcg_setup(env,solu,solv) end if solv_tmp = env%solv + gbsa_tmp = env%gbsa env%solv = '' + env%gbsa = .false. !---- Properties solute call chdir('solute_properties') @@ -231,16 +233,11 @@ subroutine qcg_setup(env,solu,solv) !---- LMO/SP-Computation solute if (env%use_xtbiff) then write (*,*) 'Generating LMOs for solute' - call xtb_lmo(env,'solute') + call xtb_lmo(env,'solute',e_there,solu%energy) else - call xtb_sp_qcg(env,'solute') + call xtb_sp_qcg(env,'solute',e_there,solu%energy) end if - - if (env%final_gfn2_opt) then !If GFN2 final opt, solute also GFN2 optimized - env%gfnver = gfnver_tmp - end if - - call grepval('xtb.out','| TOTAL ENERGY',e_there,solu%energy) + if (.not.e_there) then write (*,*) 'Total Energy of solute not found' else @@ -251,6 +248,10 @@ subroutine qcg_setup(env,solu,solv) call rename('xtblmoinfo','solute.lmo') end if + if (env%final_gfn2_opt) then !If GFN2 final opt, solute also GFN2 optimized + env%gfnver = gfnver_tmp + end if + call chdir(thispath) ! No constraints for solvent possible @@ -271,12 +272,11 @@ subroutine qcg_setup(env,solu,solv) !---- LMO-Computation solvent if (env%use_xtbiff) then write (*,*) 'Generating LMOs for solvent' - call xtb_lmo(env,'solvent')!,solv%chrg) + call xtb_lmo(env,'solvent',e_there,solv%energy) else - call xtb_sp_qcg(env,'solvent') + call xtb_sp_qcg(env,'solvent',e_there,solv%energy) end if - call grepval('xtb.out','| TOTAL ENERGY',e_there,solv%energy) if (.not.e_there) then write (*,'(1x,a)') 'Total Energy of solvent not found' else @@ -308,6 +308,7 @@ subroutine qcg_setup(env,solu,solv) end if env%solv = solv_tmp + env%gbsa = gbsa_tmp env%cts%used = used_tmp end subroutine qcg_setup @@ -594,8 +595,7 @@ end subroutine both_ellipsout if (iter .gt. 1) then call get_ellipsoid(env,solu,solv,clus,.false.) if (env%use_xtbiff) then - call xtb_lmo(env,'xtbopt.coord')!,clus%chrg) - call grepval('xtb.out','| TOTAL ENERGY',e_there,clus%energy) + call xtb_lmo(env,'xtbopt.coord',e_there,clus%energy) if (.not.e_there) then write (*,'(1x,a)') 'Total Energy of cluster LMO computation not found' end if @@ -1613,7 +1613,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) call chdir(to) call wrc0('cluster.coord',clus%nat,clus%at,clus%xyz) call wr_cluster_cut('cluster.coord',solu%nat,solv%nat,env%nsolv,'solute_cut.coord','solvent_shell.coord') - call xtb_sp_qcg(env,'solvent_shell.coord') + call xtb_sp_qcg(env,'solvent_shell.coord',ex,e_empty(i)) call grepval('xtb.out','| TOTAL ENERGY',ex,e_empty(i)) call copy('solvent_shell.coord','solvent_cluster.coord') call copy('solvent_cluster.coord','filled_cluster.coord') diff --git a/src/qcg/solvtool_misc.f90 b/src/qcg/solvtool_misc.f90 index 8d301b15..38eaea4c 100644 --- a/src/qcg/solvtool_misc.f90 +++ b/src/qcg/solvtool_misc.f90 @@ -17,38 +17,70 @@ ! along with crest. If not, see . !================================================================================! -!-------------------------------------------------------------------------------------------- -! A quick single point xtb calculation without wbo -!-------------------------------------------------------------------------------------------- -subroutine xtb_sp_qcg(env,fname) +subroutine xtb_sp_qcg(env,fname,success,eout) +!******************************************************** +!* xtb_sp_qcg +!* A quick single point xtb calculation without wbo +!******************************************************** use crest_parameters use iomod use crest_data + use crest_calculator + use strucrd implicit none - character(len=*) :: fname type(systemdata) :: env + character(len=*),intent(in) :: fname + logical,intent(out) :: success + real(wp),intent(out) :: eout + character(len=512) :: jobcall - character(*),parameter :: pipe = ' > xtb.out 2> /dev/null' + character(len=*),parameter :: pipe = ' > xtb.out 2> /dev/null' + logical,parameter :: debug = .false. integer :: io,T,Tn - call remove('gfnff_topo') - call remove('energy') - call remove('charges') - call remove('xtbrestart') + + success = .false. + eout = 0.0_wp + + if (env%legacy) then +!>---------------------------------------------- +!> The original implementation with systemcall + call remove('gfnff_topo') + call remove('energy') + call remove('charges') + call remove('xtbrestart') !---- setting threads - call new_ompautoset(env,'auto',1,T,Tn) + call new_ompautoset(env,'auto',1,T,Tn) !---- jobcall - write (jobcall,'(a,1x,a,1x,a,'' --sp '',a,1x,a)') & - & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) + write (jobcall,'(a,1x,a,1x,a,'' --sp '',a,1x,a)') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) - call command(trim(jobcall),io) + if (debug) write (*,*) trim(jobcall) + call command(trim(jobcall),io) + call grepval('xtb.out','| TOTAL ENERGY',success,eout) !---- cleanup - call remove('energy') - call remove('charges') - call remove('xtbrestart') - call remove('xtbtopo.mol') - call remove('gfnff_topo') + call remove('energy') + call remove('charges') + call remove('xtbrestart') + call remove('xtbtopo.mol') + call remove('gfnff_topo') + else +!>--------------------------------------------- +!> New implementation with calculator and api + block + type(calcdata) :: calc + type(coord) :: mol + real(wp),allocatable :: gradtmp(:,:) + + call mol%open(fname) + allocate (gradtmp(3,mol%nat)) + call env2calc(env,calc,mol) + if (debug) call calc%info(stdout) + call engrad(mol,calc,eout,gradtmp,io) + success = (io == 0) + end block + end if end subroutine xtb_sp_qcg !-------------------------------------------------------------------------------------------- @@ -105,19 +137,22 @@ end subroutine xtb_opt_qcg ! An xTB single point calculation and lmo generation on all available threads !___________________________________________________________________________________ -subroutine xtb_lmo(env,fname)!,chrg) +subroutine xtb_lmo(env,fname,success,eout) use crest_parameters use iomod use crest_data use zdata implicit none type(systemdata) :: env - character(len=*),intent(in) :: fname - character(len=80) :: pipe - character(len=512) :: jobcall + character(len=*),intent(in) :: fname + logical,intent(out) :: success + real(wp),intent(out) :: eout + character(len=*),parameter :: pipe = ' > xtb.out 2>/dev/null' + character(len=512) :: jobcall integer :: T,Tn,io - pipe = ' > xtb.out 2>/dev/null' + success = .false. + eout = 0.0_wp !---- setting threads call new_ompautoset(env,'auto',1,T,Tn) @@ -131,7 +166,7 @@ subroutine xtb_lmo(env,fname)!,chrg) write (*,*) 'error in xtb_lmo' stop end if - + call grepval('xtb.out','| TOTAL ENERGY',success,eout) !--- cleanup call remove('wbo') call remove('charges') @@ -1062,7 +1097,6 @@ subroutine write_constraint(env,coord_name,fname) end subroutine write_constraint - !==============================================================================! subroutine get_interaction_E(env,solu,solv,clus,iter,E_inter) @@ -1073,12 +1107,12 @@ subroutine get_interaction_E(env,solu,solv,clus,iter,E_inter) use strucrd implicit none - type(systemdata) :: env + type(systemdata) :: env type(zmolecule),intent(in) :: solu,solv,clus - real(wp) :: e_cluster,e_solute,e_solvent - real(wp) :: E_inter(env%nsolv) ! interaction energy - integer :: iter - logical :: e_there + real(wp) :: e_cluster,e_solute,e_solvent + real(wp) :: E_inter(env%nsolv) ! interaction energy + integer :: iter + logical :: e_there call remove('cluster.coord') @@ -1087,14 +1121,13 @@ subroutine get_interaction_E(env,solu,solv,clus,iter,E_inter) call wr_cluster_cut('cluster.coord',solu%nat,solv%nat,iter,'solute_cut.coord','solvent_cut.coord') !--- Perform single point calculations and recieve energies - call xtb_sp_qcg(env,'solute_cut.coord') - call grepval('xtb.out','| TOTAL ENERGY',e_there,e_solute) + call xtb_sp_qcg(env,'solute_cut.coord',e_there,e_solute) if (.not.e_there) write (*,*) 'Solute energy not found' - call xtb_sp_qcg(env,'solvent_cut.coord') - call grepval('xtb.out','| TOTAL ENERGY',e_there,e_solvent) + + call xtb_sp_qcg(env,'solvent_cut.coord',e_there,e_solvent) if (.not.e_there) write (*,*) 'Solvent energy not found' - call xtb_sp_qcg(env,'cluster.coord') - call grepval('xtb.out','| TOTAL ENERGY',e_there,e_cluster) + + call xtb_sp_qcg(env,'cluster.coord',e_there,e_cluster) if (.not.e_there) write (*,*) 'Cluster energy not found' E_inter(iter) = e_cluster-e_solute-e_solvent diff --git a/src/restartlog.f90 b/src/restartlog.f90 index 3584d12b..731c1387 100644 --- a/src/restartlog.f90 +++ b/src/restartlog.f90 @@ -206,6 +206,7 @@ subroutine dump_restart() if (debug) write (stdout,*) '%%% RESTART DEBUG dump summary' !> DO NOT OVERWRITE IF WE HAVEN'T REACHED THE PREVIOUS RESTART ENTRY POINT + if( restart_goal .eq. 0 ) return if( restart_tracker < restart_goal) return open (newunit=ich,file='crest.restart',status='replace',form='unformatted') From 272e1694dee4a36f8d704ae16d7ec4e4350fd003 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 14 Nov 2025 21:04:41 +0100 Subject: [PATCH 081/374] cont'd QCG refactor --- src/qcg/CMakeLists.txt | 4 +- src/qcg/{solvtool.f90 => qcg_main.f90} | 593 +------------------- src/qcg/{solvtool_misc.f90 => qcg_misc.f90} | 0 src/qcg/qcg_utils.f90 | 548 +++++++++++++++++- 4 files changed, 573 insertions(+), 572 deletions(-) rename src/qcg/{solvtool.f90 => qcg_main.f90} (83%) rename src/qcg/{solvtool_misc.f90 => qcg_misc.f90} (100%) diff --git a/src/qcg/CMakeLists.txt b/src/qcg/CMakeLists.txt index 87ac0616..fc761f62 100644 --- a/src/qcg/CMakeLists.txt +++ b/src/qcg/CMakeLists.txt @@ -18,8 +18,8 @@ set(dir "${CMAKE_CURRENT_SOURCE_DIR}") list(APPEND srcs "${dir}/volume.f90" - "${dir}/solvtool_misc.f90" - "${dir}/solvtool.f90" + "${dir}/qcg_misc.f90" + "${dir}/qcg_main.f90" "${dir}/qcg_printouts.f90" "${dir}/qcg_utils.f90" ) diff --git a/src/qcg/solvtool.f90 b/src/qcg/qcg_main.f90 similarity index 83% rename from src/qcg/solvtool.f90 rename to src/qcg/qcg_main.f90 index bda94560..7a7f9d09 100644 --- a/src/qcg/solvtool.f90 +++ b/src/qcg/qcg_main.f90 @@ -139,7 +139,6 @@ subroutine crest_solvtool(env,tim) progress = progress+1 end if - !------------------------------------------------------------------------------ ! Cleanup and deallocation !------------------------------------------------------------------------------ @@ -237,7 +236,7 @@ subroutine qcg_setup(env,solu,solv) else call xtb_sp_qcg(env,'solute',e_there,solu%energy) end if - + if (.not.e_there) then write (*,*) 'Total Energy of solute not found' else @@ -248,9 +247,9 @@ subroutine qcg_setup(env,solu,solv) call rename('xtblmoinfo','solute.lmo') end if - if (env%final_gfn2_opt) then !If GFN2 final opt, solute also GFN2 optimized - env%gfnver = gfnver_tmp - end if + if (env%final_gfn2_opt) then !If GFN2 final opt, solute also GFN2 optimized + env%gfnver = gfnver_tmp + end if call chdir(thispath) @@ -494,23 +493,23 @@ subroutine qcg_grow(env,solu,solv,clus,tim) character(len=LEN(env%solv)) :: solv_tmp logical :: gbsa_tmp - interface - subroutine both_ellipsout(fname,n,at,xyz,r1,r2) - use crest_parameters - use strucrd,only:i2e - implicit none - - integer :: i,j - integer :: n,at(n) - real(wp) :: dum(3) - real(wp) :: rx,ry,rz - real(wp) :: xyz(3,n),r1(3) - real(wp),optional :: r2(3) - real :: x,y,z,f,rr - character(len=*) :: fname - integer :: ich11 - end subroutine both_ellipsout - end interface +! interface +! subroutine both_ellipsout(fname,n,at,xyz,r1,r2) +! use crest_parameters +! use strucrd,only:i2e +! implicit none +! +! integer :: i,j +! integer :: n,at(n) +! real(wp) :: dum(3) +! real(wp) :: rx,ry,rz +! real(wp) :: xyz(3,n),r1(3) +! real(wp),optional :: r2(3) +! real :: x,y,z,f,rr +! character(len=*) :: fname +! integer :: ich11 +! end subroutine both_ellipsout +! end interface if (env%nsolv .gt. 0) then allocate (e_each_cycle(env%nsolv)) @@ -1899,8 +1898,8 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) !--- Boltz. average------------------------------------------------------------------------- write (*,*) - write (*,'(2x,''------------------------------------------------------------------------'')') - write (*,'(2x,''------------------------------------------------------------------------'')') + write (*,'(2x,''70("-")'')') + write (*,'(2x,''70("-")'')') write (*,'(2x,''Boltz. averaged energy of final cluster:'')') e_cluster = solv_ens%er*autokcal e_norm = e_norm*autokcal @@ -1953,7 +1952,7 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) use iomod use zdata use strucrd - + use qcg_utils implicit none type(systemdata) :: env @@ -2317,555 +2316,13 @@ end subroutine qcg_eval !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Date: Fri, 14 Nov 2025 21:36:55 +0100 Subject: [PATCH 082/374] cont'd QCG refactor --- src/qcg/qcg_main.f90 | 332 ++++++++++++++++++++---------------------- src/qcg/qcg_misc.f90 | 50 +++---- src/qcg/qcg_utils.f90 | 38 ++--- 3 files changed, 201 insertions(+), 219 deletions(-) diff --git a/src/qcg/qcg_main.f90 b/src/qcg/qcg_main.f90 index 7a7f9d09..861b4888 100644 --- a/src/qcg/qcg_main.f90 +++ b/src/qcg/qcg_main.f90 @@ -61,11 +61,11 @@ subroutine crest_solvtool(env,tim) call checkprog_silent(env%ProgIFF,.true.,iostat=io) if (io /= 0) error stop 'No xtbiff found' else - write (*,*) - write (*,*) ' The use of the aISS algorithm is requested (recommend).' - write (*,*) ' This requires xtb version 6.6.0 or newer.' - write (*,*) ' xTB-IFF can still be used with the --xtbiff flag.' - write (*,*) + write (stdout,*) + write (stdout,*) ' The use of the aISS algorithm is requested (recommend).' + write (stdout,*) ' This requires xtb version 6.6.0 or newer.' + write (stdout,*) ' xTB-IFF can still be used with the --xtbiff flag.' + write (stdout,*) end if !------------------------------------------------------------------------------ @@ -123,9 +123,9 @@ subroutine crest_solvtool(env,tim) & tim,'solvent_ensemble') end if call pr_qcg_esolv() - write (*,'(2x,"|",9x,F8.2," kcal/mol ",12x,"|")') & + write (stdout,'(2x,"|",9x,F8.2," kcal/mol ",12x,"|")') & & full_ensemble%g-solvent_ensemble%g-(solute%energy*autokcal) - write (*,'(2x,''========================================='')') + write (stdout,'(2x,''========================================='')') call chdir(thispath) progress = progress+1 end if @@ -200,10 +200,10 @@ subroutine qcg_setup(env,solu,solv) r = makedir('solvent_properties') if (.not.env%nopreopt) then - write (*,*) - write (*,'(2x,''========================================='')') - write (*,'(2x,''| Preoptimization |'')') - write (*,'(2x,''========================================='')') + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| Preoptimization |'')') + write (stdout,'(2x,''========================================='')') end if solv_tmp = env%solv @@ -231,16 +231,16 @@ subroutine qcg_setup(env,solu,solv) !---- LMO/SP-Computation solute if (env%use_xtbiff) then - write (*,*) 'Generating LMOs for solute' + write (stdout,*) 'Generating LMOs for solute' call xtb_lmo(env,'solute',e_there,solu%energy) else call xtb_sp_qcg(env,'solute',e_there,solu%energy) end if if (.not.e_there) then - write (*,*) 'Total Energy of solute not found' + write (stdout,*) 'Total Energy of solute not found' else - write (*,outfmt) 'Total Energy of solute: ',solu%energy,' Eh' + write (stdout,outfmt) 'Total Energy of solute: ',solu%energy,' Eh' end if if (env%use_xtbiff) then @@ -270,16 +270,16 @@ subroutine qcg_setup(env,solu,solv) !---- LMO-Computation solvent if (env%use_xtbiff) then - write (*,*) 'Generating LMOs for solvent' + write (stdout,*) 'Generating LMOs for solvent' call xtb_lmo(env,'solvent',e_there,solv%energy) else call xtb_sp_qcg(env,'solvent',e_there,solv%energy) end if if (.not.e_there) then - write (*,'(1x,a)') 'Total Energy of solvent not found' + write (stdout,'(1x,a)') 'Total Energy of solvent not found' else - write (*,outfmt) 'Total energy of solvent:',solv%energy,' Eh' + write (stdout,outfmt) 'Total energy of solvent:',solv%energy,' Eh' end if if (env%use_xtbiff) then @@ -346,17 +346,17 @@ subroutine read_qcg_input(env,solu,solv) solu%uhf = env%uhf !--- Getting r, V, A - write (*,*) - write (*,*) 'Solute geometry' + write (stdout,*) + write (stdout,*) 'Solute geometry' call get_sphere(.true.,solu,.true.) !r,V,A of solute - write (*,*) 'Solvent geometry' + write (stdout,*) 'Solvent geometry' call get_sphere(.true.,solv,.true.) !r,V,A of solvent r_solu = solu%vtot**third r_solv = solv%vtot**third - write (*,*) - write (*,'(2x,''radius of solute : '',f8.2)') r_solu - write (*,'(2x,''radius of solvent : '',f8.2)') r_solv + write (stdout,*) + write (stdout,'(2x,''radius of solute : '',f8.2)') r_solu + write (stdout,'(2x,''radius of solvent : '',f8.2)') r_solv !--- Determine masses (for later density computation) do i = 1,solu%nat @@ -422,7 +422,7 @@ subroutine read_directed_input(env) index = SCAN(trim(dum),delim_tab) end if if (index == 0) then !Second value is missing - write (*,'(a,1x,i0)') "No second value found in directed list on line",i + write (stdout,'(a,1x,i0)') "No second value found in directed list on line",i error stop end if env%directed_list(i,1) = dum(1:index-1) @@ -433,21 +433,21 @@ subroutine read_directed_input(env) index = SCAN(trim(env%directed_list(i,2)),delim_space) if (index == 0) index = SCAN(trim(dum),delim_tab) if (index /= 0) then - write (*,'(a,1x,i0)') "Too many values at line",i + write (stdout,'(a,1x,i0)') "Too many values at line",i error stop end if !> Make array with which solvent molecule at which atom to add read (env%directed_list(i,2),*,iostat=io) env%directed_number(i) env%directed_number(i) = sum(env%directed_number) if (io /= 0) then - write (*,'(a,1x,i0)') "Second value is no number in line",i + write (stdout,'(a,1x,i0)') "Second value is no number in line",i error stop end if end do close (ich) - write (*,*) 'Performing directed docking' + write (stdout,*) 'Performing directed docking' do i = 1,nlines - write (*,'(a,1x,a,1x,a,1x,a)') 'Docking',trim(env%directed_list(i,2)),& + write (stdout,'(a,1x,a,1x,a,1x,a)') 'Docking',trim(env%directed_list(i,2)),& & 'solvent molecules at',trim(env%directed_list(i,1)) end do @@ -493,24 +493,6 @@ subroutine qcg_grow(env,solu,solv,clus,tim) character(len=LEN(env%solv)) :: solv_tmp logical :: gbsa_tmp -! interface -! subroutine both_ellipsout(fname,n,at,xyz,r1,r2) -! use crest_parameters -! use strucrd,only:i2e -! implicit none -! -! integer :: i,j -! integer :: n,at(n) -! real(wp) :: dum(3) -! real(wp) :: rx,ry,rz -! real(wp) :: xyz(3,n),r1(3) -! real(wp),optional :: r2(3) -! real :: x,y,z,f,rr -! character(len=*) :: fname -! integer :: ich11 -! end subroutine both_ellipsout -! end interface - if (env%nsolv .gt. 0) then allocate (e_each_cycle(env%nsolv)) allocate (E_inter(env%nsolv)) @@ -544,14 +526,14 @@ subroutine qcg_grow(env,solu,solv,clus,tim) else env%potscal = 0.8_wp end if - write (*,*) - write (*,'(2x,''Water as solvent recognized,& + write (stdout,*) + write (stdout,'(2x,''Water as solvent recognized,& & adjusting scaling factor for outer wall pot to '',F4.2)')& & env%potscal - write (*,*) + write (stdout,*) end if end if - if (env%constrain_solu) write (*,'(2x,''Constraining solute during Growth '')') + if (env%constrain_solu) write (stdout,'(2x,''Constraining solute during Growth '')') call get_ellipsoid(env,solu,solv,clus,.true.) call pr_grow_energy() @@ -596,7 +578,7 @@ subroutine qcg_grow(env,solu,solv,clus,tim) if (env%use_xtbiff) then call xtb_lmo(env,'xtbopt.coord',e_there,clus%energy) if (.not.e_there) then - write (*,'(1x,a)') 'Total Energy of cluster LMO computation not found' + write (stdout,'(1x,a)') 'Total Energy of cluster LMO computation not found' end if call rename('xtblmoinfo','cluster.lmo') end if @@ -621,11 +603,11 @@ subroutine qcg_grow(env,solu,solv,clus,tim) success = .true. else if (env%potscal .lt. 1.0_wp) then - write (*,*) ' Wall Potential too small, increasing size by 5 %' + write (stdout,*) ' Wall Potential too small, increasing size by 5 %' solv%ell_abc = solv%ell_abc*1.05_wp env%potscal = env%potscal*1.05_wp if (env%potscal .gt. 1.0_wp) env%potscal = 1.0_wp - write (*,'('' New scaling factor '',F4.2)') env%potscal + write (stdout,'('' New scaling factor '',F4.2)') env%potscal else success = .true. end if @@ -643,11 +625,11 @@ subroutine qcg_grow(env,solu,solv,clus,tim) success = .true. else if (env%potscal .lt. 1.0_wp) then - write (*,*) ' Wall Potential too small, increasing size by 5 %' + write (stdout,*) ' Wall Potential too small, increasing size by 5 %' clus%ell_abc = clus%ell_abc*1.05_wp env%potscal = env%potscal*1.05_wp if (env%potscal .gt. 1.0_wp) env%potscal = 1.0_wp - write (*,'('' New scaling factor '',F4.2)') env%potscal + write (stdout,'('' New scaling factor '',F4.2)') env%potscal else success = .true. end if @@ -706,11 +688,11 @@ subroutine qcg_grow(env,solu,solv,clus,tim) success = .true. else if (env%potscal .lt. 1.0_wp) then - write (*,*) ' Interaction Energy positiv, increasing outer wall pot by 5 %' + write (stdout,*) ' Interaction Energy positiv, increasing outer wall pot by 5 %' clus%ell_abc = clus%ell_abc*1.05_wp env%potscal = env%potscal*1.05_wp if (env%potscal .gt. 1.0_wp) env%potscal = 1.0_wp - write (*,'('' New scaling factor '',F4.2)') env%potscal + write (stdout,'('' New scaling factor '',F4.2)') env%potscal else success = .true. end if @@ -723,7 +705,7 @@ subroutine qcg_grow(env,solu,solv,clus,tim) call grepval('xtb.out','| TOTAL ENERGY',e_there,clus%energy) call wrc0('optimized_cluster.coord',clus%nat,clus%at,clus%xyz) if (.not.e_there) then - write (*,'(1x,a)') 'Total Energy of cluster not found.' + write (stdout,'(1x,a)') 'Total Energy of cluster not found.' end if else !Energy already read from xyz file @@ -754,7 +736,7 @@ subroutine qcg_grow(env,solu,solv,clus,tim) ! dist of new mol from solute for output call analyze_cluster(iter,clus%nat,solu%nat,solv%nat,clus%xyz,clus%at,shr_av,shr) - write (*,'(x,i4,F13.6,1x,f7.2,3x,f8.2,6x,f6.3,3x,f8.3,3x,2f6.1,2x,f8.1,3x,a,x)') & + write (stdout,'(x,i4,F13.6,1x,f7.2,3x,f8.2,6x,f6.3,3x,f8.3,3x,2f6.1,2x,f8.1,3x,a,x)') & & iter,e_each_cycle(iter),autokcal*(e_each_cycle(iter)-solv%energy-dum),& & e_diff,dens,efix,shr_av,shr,clus%vtot,trim(optlevflag(env%optlev)) write (ich99,'(i4,F20.10,3x,f8.1)') iter,e_each_cycle(iter),clus%vtot @@ -775,9 +757,9 @@ subroutine qcg_grow(env,solu,solv,clus,tim) exit end if if (iter .eq. env%max_solv) then - write (*,'(1x,''No convergence could be reached upon adding'',1x,i4,1x,& + write (stdout,'(1x,''No convergence could be reached upon adding'',1x,i4,1x,& & ''solvent molecules.'')') env%max_solv - write (*,*) ' Proceeding.' + write (stdout,*) ' Proceeding.' env%nsolv = env%max_solv exit end if @@ -792,15 +774,15 @@ subroutine qcg_grow(env,solu,solv,clus,tim) if (env%gfnver .ne. '--gfn2'.and.env%final_gfn2_opt) then gfnver_tmp = env%gfnver env%gfnver = '--gfn2' - write (*,'(2x,''Final gfn2 optimization'')') + write (stdout,'(2x,''Final gfn2 optimization'')') call opt_cluster(env,solu,clus,'cluster.coord',.false.) call rdcoord('xtbopt.coord',clus%nat,clus%at,clus%xyz) call wrc0('cluster.coord',clus%nat,clus%at,clus%xyz) call grepval('xtb_sp.out','| TOTAL ENERGY',e_there,clus%energy) if (.not.e_there) then - write (*,'(1x,a)') 'Total Energy of cluster not found.' + write (stdout,'(1x,a)') 'Total Energy of cluster not found.' else - write (*,'(2x,''Total gfn2-energy of cluster/Eh:'',f20.6)') clus%energy + write (stdout,'(2x,''Total gfn2-energy of cluster/Eh:'',f20.6)') clus%energy end if env%gfnver = gfnver_tmp end if @@ -816,15 +798,15 @@ subroutine qcg_grow(env,solu,solv,clus,tim) call copysub('cluster_optimized.xyz',resultspath) !--- output and files - write (*,*) - write (*,'(2x,''Growth finished after '',i0,'' solvents added'')') env%nsolv - write (*,'(2x,''Results can be found in grow directory'')') - write (*,'(2x,''Energy list in file '')') - write (*,'(2x,''Interaction energy in file '')') - write (*,'(2x,''Growing process in '')') - write (*,'(2x,''Final geometry after grow in and '')') - write (*,'(2x,''Final geometry optimized without wall potential in '')') - write (*,'(2x,''Potentials and geometry written in and '')') + write (stdout,*) + write (stdout,'(2x,''Growth finished after '',i0,'' solvents added'')') env%nsolv + write (stdout,'(2x,''Results can be found in grow directory'')') + write (stdout,'(2x,''Energy list in file '')') + write (stdout,'(2x,''Interaction energy in file '')') + write (stdout,'(2x,''Growing process in '')') + write (stdout,'(2x,''Final geometry after grow in and '')') + write (stdout,'(2x,''Final geometry optimized without wall potential in '')') + write (stdout,'(2x,''Potentials and geometry written in and '')') close (ich99) close (ich88) @@ -981,8 +963,8 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) end if gfnver_tmp = env%gfnver - write (*,*) ' Method for ensemble search:',env%ensemble_opt -! if (env%ens_const) write(*,*) ' Solute fixed during ensemble generation' + write (stdout,*) ' Method for ensemble search:',env%ensemble_opt +! if (env%ens_const) write(stdout,*) ' Solute fixed during ensemble generation' env%gfnver = env%ensemble_opt !Setting method for ensemble search !---------------------------------------------------------------- @@ -1021,7 +1003,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) end if env%iterativeV2 = .true. !Safeguards more precise ensemble search - write (*,*) 'Starting ensemble cluster generation by CREST routine' + write (stdout,*) 'Starting ensemble cluster generation by CREST routine' call confscript2i(env,tim_dum) !Calling ensemble search call copy('crest_rotamers.xyz','crest_rotamers_0.xyz') @@ -1129,10 +1111,10 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) !--- MD if (env%ensemble_method .EQ. 1) then call normalMD(fname,env,1,newtemp,newmdtime) - write (*,*) 'Starting MD with the settings:' - write (*,'('' MD time /ps :'',f8.1)') newmdtime - write (*,'('' MD Temperature /K :'',f8.1)') newtemp - write (*,'('' dt /fs :'',f8.1)') newmdstep + write (stdout,*) 'Starting MD with the settings:' + write (stdout,'('' MD time /ps :'',f8.1)') newmdtime + write (stdout,'('' MD Temperature /K :'',f8.1)') newtemp + write (stdout,'('' dt /fs :'',f8.1)') newmdstep write (tmppath,'(a,i0)') 'NORMMD1' r = makedir(tmppath) @@ -1145,9 +1127,9 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) inquire (file=trim(tmppath)//'/'//'xtb.trj',exist=ex) if (.not.ex.or.io .ne. 0) then - write (*,'(a,i0,a)') '*Warning: MD seemingly failed (no xtb.trj)*' + write (stdout,'(a,i0,a)') '*Warning: MD seemingly failed (no xtb.trj)*' else - write (*,*) '*MD finished*' + write (stdout,*) '*MD finished*' end if if (env%trackorigin) then @@ -1161,13 +1143,13 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) if (env%ensemble_method .EQ. 2) then call MetaMD(env,1,newmdtime,env%metadfac(1),env%metadexp(1), & & env%metadlist(1)) - write (*,'(a,i4,a)') 'Starting Meta-MD with the settings:' - write (*,'('' MTD time /ps :'',f8.1)') newmdtime - write (*,'('' dt /fs :'',f8.1)') newmdstep - write (*,'('' MTD Temperature /K :'',f8.1)') newtemp - write (*,'('' dumpstep(trj) /fs :'',i8)') env%mddumpxyz - write (*,'('' Vbias factor k /Eh :'',f8.4)') newmetadfac - write (*,'('' Vbias exp α /bohr⁻²:'',f8.2)') newmetadexp + write (stdout,'(a,i4,a)') 'Starting Meta-MD with the settings:' + write (stdout,'('' MTD time /ps :'',f8.1)') newmdtime + write (stdout,'('' dt /fs :'',f8.1)') newmdstep + write (stdout,'('' MTD Temperature /K :'',f8.1)') newtemp + write (stdout,'('' dumpstep(trj) /fs :'',i8)') env%mddumpxyz + write (stdout,'('' Vbias factor k /Eh :'',f8.4)') newmetadfac + write (stdout,'('' Vbias exp α /bohr⁻²:'',f8.2)') newmetadexp write (tmppath,'(a,i0)') 'METADYN1' r = makedir(tmppath) @@ -1181,9 +1163,9 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) inquire (file=trim(tmppath)//'/'//'xtb.trj',exist=ex) if (.not.ex.or.io .ne. 0) then - write (*,'(a,i0,a)') '*Warning: Meta-MTD seemingly failed (no xtb.trj)*' + write (stdout,'(a,i0,a)') '*Warning: Meta-MTD seemingly failed (no xtb.trj)*' else - write (*,*) '*MTD finished*' + write (stdout,*) '*MTD finished*' end if if (env%trackorigin) then @@ -1202,20 +1184,20 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) call minigrep('xtb.out','M(T)D is unstable, emergency exit',mdfail) if (dum%nall .eq. 1) then call copysub('xtb.out',resultspath) - write (*,*) 'ERROR : M(T)D results only in one structure' + write (stdout,*) 'ERROR : M(T)D results only in one structure' if (mdfail) then - write (*,*) ' It was unstable' + write (stdout,*) ' It was unstable' else - write (*,*) ' The M(T)D time step might be too large or the M(T)D time too short.' + write (stdout,*) ' The M(T)D time step might be too large or the M(T)D time too short.' end if call copysub('xtb.out',resultspath) error stop ' Please check the xtb.out file in the ensemble folder' end if if (mdfail) then - write (*,*) - write (*,*) ' WARNING: The M(T)D was unstable.' - write (*,*) ' Please check the xtb.out file in the ensemble folder.' - write (*,*) + write (stdout,*) + write (stdout,*) ' WARNING: The M(T)D was unstable.' + write (stdout,*) ' Please check the xtb.out file in the ensemble folder.' + write (stdout,*) call copysub('xtb.out',resultspath) end if call dum%deallocate @@ -1236,7 +1218,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) if (env%final_gfn2_opt) then gfnver_tmp = env%gfnver ! if (env%gfnver .ne. '--gfn2') then - write (*,'(2x,a)') 'GFN2-xTB optimization' + write (stdout,'(2x,a)') 'GFN2-xTB optimization' env%gfnver = '--gfn2' call rmrf('OPTIM') call multilevel_opt(env,99) @@ -1252,7 +1234,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) !Clustering to exclude similar structures if requested with -cluster if (env%properties == 70) then - write (*,'(3x,''Clustering the remaining structures'')') + write (stdout,'(3x,''Clustering the remaining structures'')') call checkname_xyz(crefile,inpnam,outnam) call ccegen(env,.false.,inpnam) call move(trim(clusterfile),trim(outnam)) @@ -1286,7 +1268,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) call chdir(tmppath2) end do !--- SP - write (*,*) + write (stdout,*) call ens_sp(env,'cluster.xyz',ens%nall,'TMPSP') !--- Getting energy do i = 1,ens%nall @@ -1298,19 +1280,19 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) end do if (.not.e_there) then - write (*,*) - write (*,*) 'Energy not found. Error in xTB computations occured' + write (stdout,*) + write (stdout,*) 'Energy not found. Error in xTB computations occured' call chdir(to) call minigrep('xtb_sp.out','solv_model_loadInternalParam',not_param) call chdir(tmppath2) if (not_param) then - write (*,*) ' !!!WARNIG: CHOSEN SOLVENT NOT PARAMETERIZED & + write (stdout,*) ' !!!WARNIG: CHOSEN SOLVENT NOT PARAMETERIZED & & FOR IMPLICIT SOLVATION MODEL!!!' - write (*,'('' CHECK IF '',A,'' IS AVAILABLE IN xTB'')') env%solv - write (*,*) ' PLEASE RESTART THE ENSEMBLE GENERATION WITH AVAILABLE& + write (stdout,'('' CHECK IF '',A,'' IS AVAILABLE IN xTB'')') env%solv + write (stdout,*) ' PLEASE RESTART THE ENSEMBLE GENERATION WITH AVAILABLE& & PARAMETERIZATION IF YOU NEED ENERGIES' call copysub('crest_conformers.xyz',resultspath) - write (*,*) ' The enesemble can be found in the directory& + write (stdout,*) ' The enesemble can be found in the directory& & as ' error stop end if @@ -1361,7 +1343,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) call analyze_cluster(env%nsolv,clus%nat,solu%nat,solv%nat,clus%xyz,clus%at,shr_av,shr) end if write (ich98,'(i4,F20.10,3x,f8.1)') env%nsolv,ens%er(i),clus%atot - write (*,'(x,i4,4x,F13.6,2x,f6.3,1x,f8.3,2x,2f6.1,3x,f8.1,3x,a)') & + write (stdout,'(x,i4,4x,F13.6,2x,f6.3,1x,f8.3,2x,2f6.1,3x,f8.1,3x,a)') & & i,ens%er(i),dens,e_fix(i),shr_av,shr,clus%atot,trim(optlevflag(env%optlev)) e_fix(i) = e_fix(i)*autokcal/sqrt(float(clus%nat)) end do @@ -1369,7 +1351,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) call copysub('cluster_energy.dat',resultspath) !--- Checking Boltzmann weighting - write (*,*) + write (stdout,*) call remove('full_ensemble.xyz') call sort_ensemble(ens,ens%er,'full_ensemble.xyz') e_clus = ens%er*autokcal @@ -1397,16 +1379,16 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) else error stop 'No structure left. Something went wrong.' end if - write (*,'(2x,a,1x,i0)') 'Conformers taken:',k + write (stdout,'(2x,a,1x,i0)') 'Conformers taken:',k env%nqcgclust = k else if (env%nqcgclust .gt. ens%nall) then k = ens%nall !Input larger than remaining structures - write (*,'(''Less than '',1x,i0,1x,''structures remain'')') env%nqcgclust - write (*,'(''Only '',1x,i0,1x,''structures are taken'')') ens%nall + write (stdout,'(''Less than '',1x,i0,1x,''structures remain'')') env%nqcgclust + write (stdout,'(''Only '',1x,i0,1x,''structures are taken'')') ens%nall if (env%cff) env%nqcgclust = ens%nall !Only for CFF, else a second qcg_ensemble run starts for solvent else - write (*,'(''Taking '',1x,i0,1x,''structures'')') env%nqcgclust + write (stdout,'(''Taking '',1x,i0,1x,''structures'')') env%nqcgclust k = env%nqcgclust !user input end if end if @@ -1435,13 +1417,13 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) ens%er = e_clus(1:k)/autokcal !--- Getting G,S,H - write (*,*) - write (*,'(2x,''------------------------------------------------------------------------'')') - write (*,'(2x,''------------------------------------------------------------------------'')') - write (*,'(2x,''Boltz. averaged energy of final cluster:'')') + write (stdout,*) + write (stdout,'(2x,''------------------------------------------------------------------------'')') + write (stdout,'(2x,''------------------------------------------------------------------------'')') + write (stdout,'(2x,''Boltz. averaged energy of final cluster:'')') call aver(.true.,env,ens%nall,e_clus(1:ens%nall),S,H,G,sasa,.false.) - write (*,'(7x,''G /Eh :'',F14.8)') G/autokcal - write (*,'(7x,''T*S /kcal :'',f8.3)') S + write (stdout,'(7x,''G /Eh :'',F14.8)') G/autokcal + write (stdout,'(7x,''T*S /kcal :'',f8.3)') S ens%g = G ens%s = S @@ -1464,15 +1446,15 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) call chdir(env%scratchdir) if (.not.env%keepModef) call rmrf(tmppath2) !----Outprint - write (*,*) - write (*,'(2x,''Ensemble generation finished.'')') - write (*,'(2x,''Results can be found in ensemble directory'')') - write (*,'(2x,''Lowest energy conformer in file '')') - write (*,'(2x,''List of full ensemble in file '')') - write (*,'(2x,''List of used ensemble in file '')') - write (*,'(2x,''Thermodynamical data in file '')') - write (*,'(2x,''Population of full ensemble in file '')') - write (*,'(2x,''Population in file '')') + write (stdout,*) + write (stdout,'(2x,''Ensemble generation finished.'')') + write (stdout,'(2x,''Results can be found in ensemble directory'')') + write (stdout,'(2x,''Lowest energy conformer in file '')') + write (stdout,'(2x,''List of full ensemble in file '')') + write (stdout,'(2x,''List of used ensemble in file '')') + write (stdout,'(2x,''Thermodynamical data in file '')') + write (stdout,'(2x,''Population of full ensemble in file '')') + write (stdout,'(2x,''Population in file '')') env%gfnver = gfnver_tmp env%optlev = optlev_tmp @@ -1622,7 +1604,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) call chdir(tmppath2) end do - if (skip) write (*,'(2x,''solute smaller than solvent, cff skipped'')') + if (skip) write (stdout,'(2x,''solute smaller than solvent, cff skipped'')') clus%nat = clus%nat-solu%nat n_ini = clus%nat @@ -1630,9 +1612,9 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) !--- If solvent molecules are added if (.not.skip) then call pr_qcg_fill() - write (*,'(2x,''now adding solvents to fill cluster...'')') + write (stdout,'(2x,''now adding solvents to fill cluster...'')') call pr_fill_energy() - write (*,'(2x,''------------------------------------------------------------------------'')') + write (stdout,'(2x,''------------------------------------------------------------------------'')') nat_frag1 = env%nsolv*solv%nat iter = 0 @@ -1717,8 +1699,8 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) call fill_take(env,solv%nat,clus%nat,inner_ell_abc(i,1:3),ipos) if (ipos .eq. 0) then converged(i) = .true. - write (*,'(2x,''no more solvents can be placed inside cavity of cluster: '',i0)') i - write (*,'(2x,''previous cluster taken...'')') + write (stdout,'(2x,''no more solvents can be placed inside cavity of cluster: '',i0)') i + write (stdout,'(2x,''previous cluster taken...'')') if (iter .eq. 1) nothing_added(i) = .true. end if call chdir(tmppath2) @@ -1763,12 +1745,12 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) !---- Check if solvent added is repulsive if (de .gt. 0) then converged(i) = .true. - write (*,'(2x,''adding solvent is repulsive for cluster: '',i0)') i - write (*,'(2x,''previous cluster taken...'')') + write (stdout,'(2x,''adding solvent is repulsive for cluster: '',i0)') i + write (stdout,'(2x,''previous cluster taken...'')') if (iter .eq. 1) nothing_added(i) = .true. else !Only if the addition was not repulsive call copy('solvent_cluster.coord','filled_cluster.coord') - write (*,'(i4,5x,i3,1x,F13.6,3x,f7.2,5x,f7.2,4x,a)') & + write (stdout,'(i4,5x,i3,1x,F13.6,3x,f7.2,5x,f7.2,4x,a)') & & iter+env%nsolv,i,e_cur(iter,i),de,de_tot(i),& & trim(optlevflag(env%optlev)) end if @@ -1790,10 +1772,10 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) nat_tot = nat_tot+solv%nat end if - write (*,'(2x,''------------------------------------------------------------------------'')') + write (stdout,'(2x,''------------------------------------------------------------------------'')') !--- Or if maximum solvent is added if (iter-nsolv .eq. v_ratio) then - write (*,'(2x,''volume filled'')') + write (stdout,'(2x,''volume filled'')') all_converged = .true. call copy('solvent_cluster.coord','filled_cluster.coord') end if @@ -1868,7 +1850,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) write (ich98,'(''No'',i4,F20.10,3x,f8.1)') i,e_norm(i),atotS !--- Print to screen - write (*,'(x,i4,4x,F13.6,2x,f6.3,1x,f8.3,2x,2f6.1,3x,f8.1,3x,a)') & + write (stdout,'(x,i4,4x,F13.6,2x,f6.3,1x,f8.3,2x,2f6.1,3x,f8.1,3x,a)') & & i,e_norm(i),dens,e_fix(i),shr_av,shr,atotS,trim(optlevflag(env%optlev)) call chdir(tmppath2) @@ -1897,16 +1879,16 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) call wrxyz('crest_best.xyz',clus%nat,clus%at,clus%xyz,comment) !--- Boltz. average------------------------------------------------------------------------- - write (*,*) - write (*,'(2x,''70("-")'')') - write (*,'(2x,''70("-")'')') - write (*,'(2x,''Boltz. averaged energy of final cluster:'')') + write (stdout,*) + write (stdout,'(2x,''70("-")'')') + write (stdout,'(2x,''70("-")'')') + write (stdout,'(2x,''Boltz. averaged energy of final cluster:'')') e_cluster = solv_ens%er*autokcal e_norm = e_norm*autokcal call sort_min(env%nqcgclust,1,1,e_norm) call aver(.true.,env,solv_ens%nall,e_norm(1:env%nqcgclust),S,H,G,sasa,.false.) - write (*,'(7x,''G /Eh :'',F14.8)') G/autokcal - write (*,'(7x,''T*S /kcal :'',f8.3)') S + write (stdout,'(7x,''G /Eh :'',F14.8)') G/autokcal + write (stdout,'(7x,''T*S /kcal :'',f8.3)') S solv_ens%er = e_norm/autokcal !normalized energy needed for final evaluation solv_ens%g = G @@ -1922,12 +1904,12 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) call chdir(thispath) !--- Printouts - write (*,*) - write (*,'(2x,''Solvent cluster generation finished.'')') - write (*,'(2x,''Results can be found in solvent_cluster directory'')') - write (*,'(2x,''Structures in file '')') - write (*,'(2x,''Energies in file '')') - write (*,'(2x,''Population in file '')') + write (stdout,*) + write (stdout,'(2x,''Solvent cluster generation finished.'')') + write (stdout,'(2x,''Results can be found in solvent_cluster directory'')') + write (stdout,'(2x,''Structures in file '')') + write (stdout,'(2x,''Energies in file '')') + write (stdout,'(2x,''Population in file '')') env%gfnver = gfnver_tmp env%optlev = optlev_tmp @@ -2006,7 +1988,7 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) call copysub('.UHF','tmp_gas1') !--- Frequencies solute molecule - write (*,*) ' SOLUTE MOLECULE' + write (stdout,*) ' SOLUTE MOLECULE' call chdir('tmp_gas1') call wrc0('solute.coord',solu%nat,solu%at,solu%xyz) call chdir(tmppath2) @@ -2065,14 +2047,14 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) end do - write (*,*) ' SOLUTE CLUSTER' + write (stdout,*) ' SOLUTE CLUSTER' !> Frequency calculation opt = .true. call ens_freq(env,'cluster.xyz',solu_ens%nall,'TMPFREQ',opt) call chdir(tmppath2) - write (*,*) ' SOLVENT CLUSTER' + write (stdout,*) ' SOLVENT CLUSTER' if (env%cff) then call chdir('tmp_solv') call ens_freq(env,'solvent_cut.coord',solu_ens%nall,'TMPFREQ',opt) @@ -2108,18 +2090,18 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) !---------------------------------------------------------------------------- !--- Solute in gas phase - write (*,*) - write (*,*) ' Solute Gas properties' + write (stdout,*) + write (stdout,*) ' Solute Gas properties' call pr_freq_energy() open (newunit=ich56,file='solute.dat') call pr_freq_file(ich56) - write (*,'(2x,5f10.2)') ht(3),svib(3),srot(3),stra(3),gt(3) + write (stdout,'(2x,5f10.2)') ht(3),svib(3),srot(3),stra(3),gt(3) write (ich56,'(2x,5f10.2)') ht(3),svib(3),srot(3),stra(3),gt(3) close (ich56) !--- Solute cluster - write (*,*) - write (*,*) ' Solute cluster properties' + write (stdout,*) + write (stdout,*) ' Solute cluster properties' open (newunit=ich33,file='solute_cluster.dat') call chdir('tmp_solu') @@ -2137,7 +2119,7 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) write (to,'("TMPFREQ",i0)') i call chdir(to) call rdtherm('xtb_freq.out',ht(1),svib(1),srot(1),stra(1),gt(1)) - write (*,'(2x,i0,2x,5f10.2)') i,ht(1),svib(1),srot(1),stra(1),gt(1) + write (stdout,'(2x,i0,2x,5f10.2)') i,ht(1),svib(1),srot(1),stra(1),gt(1) write (ich33,'(2x,i0,2x,5f10.2)') i,ht(1),svib(1),srot(1),stra(1),gt(1) solu_ens%gt(i) = gt(1) solu_ens%ht(i) = ht(1) @@ -2151,8 +2133,8 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) close (ich33) !--- Solvent cluster - write (*,*) - write (*,*) ' Solvent cluster properties' + write (stdout,*) + write (stdout,*) ' Solvent cluster properties' call chdir(tmppath2) open (newunit=ich81,file='solvent_cluster.dat') @@ -2171,7 +2153,7 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) write (to,'("TMPFREQ",i0)') i call chdir(to) call rdtherm('xtb_freq.out',ht(2),svib(2),srot(2),stra(2),gt(2)) - write (*,'(2x,i0,2x,5f10.2)') i,ht(2),svib(2),srot(2),stra(2),gt(2) + write (stdout,'(2x,i0,2x,5f10.2)') i,ht(2),svib(2),srot(2),stra(2),gt(2) write (ich81,'(2x,i0,2x,5f10.2)') i,ht(2),svib(2),srot(2),stra(2),gt(2) solv_ens%gt(i) = gt(2) solv_ens%ht(i) = ht(2) @@ -2408,9 +2390,9 @@ subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup if (clus%nmol-1 .ge. env%nsolv) then progress = 1 env%nsolv = clus%nmol-1 - write (*,*) - write (*,*) - write (*,'(''Found cluster with '',i0,'' solvents'')') env%nsolv + write (stdout,*) + write (stdout,*) + write (stdout,'(''Found cluster with '',i0,'' solvents'')') env%nsolv call chdir(thispath) else error stop 'The found cluster is smaller than nsolv. Please restart the whole computaion by removing the grow directory' @@ -2432,11 +2414,11 @@ subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup call solu_ens%open('final_ensemble.xyz') call rdensemble('final_ensemble.xyz',solu_ens%nat,solu_ens%nall,solu_ens%at,solu_ens%xyz,solu_ens%er) env%nqcgclust = solu_ens%nall - write (*,'(" Ensemble of solute-cluster found.")') - write (*,'(" Taking all ", i0, " structures")') env%nqcgclust + write (stdout,'(" Ensemble of solute-cluster found.")') + write (stdout,'(" Taking all ", i0, " structures")') env%nqcgclust call grepval('population.dat','Ensemble free energy [Eh]:',ex,solu_ens%G) solu_ens%G = solu_ens%G*autokcal - write (*,*) 'Solute Ensmeble Free E [kcal/mol]',solu_ens%G + write (stdout,*) 'Solute Ensmeble Free E [kcal/mol]',solu_ens%G call chdir(thispath) progress = 2 end if @@ -2444,7 +2426,7 @@ subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup !--- Solvent Ensemble if (solv_present) then call chdir('solvent_ensemble') - write (*,'(" Ensemble of solvent-cluster found.")') + write (stdout,'(" Ensemble of solvent-cluster found.")') !--- Case CFF if (solv_cff) then @@ -2460,7 +2442,7 @@ subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup write (counter3,'(''No '',i3)') i call grepval('cluster_energy.dat',counter3,ex,solv_ens%er(i)) end if - write (*,*) 'Energy of cluster',i,solv_ens%er(i) + write (stdout,*) 'Energy of cluster',i,solv_ens%er(i) end do end if @@ -2471,16 +2453,16 @@ subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup end if call grepval('population.dat','Ensemble free energy [Eh]:',ex,solv_ens%G) solv_ens%G = solv_ens%G*autokcal - write (*,*) 'solvent ensmeble free E [kcal/mol]',solv_ens%G + write (stdout,*) 'solvent ensmeble free E [kcal/mol]',solv_ens%G call chdir(thispath) progress = 3 end if !--- Frequencies if (freq) then - write (*,*) - write (*,*) - write (*,*) ' Nothing to do' + write (stdout,*) + write (stdout,*) + write (stdout,*) ' Nothing to do' progress = 4 end if diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index 38eaea4c..0326a6ca 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -56,7 +56,7 @@ subroutine xtb_sp_qcg(env,fname,success,eout) write (jobcall,'(a,1x,a,1x,a,'' --sp '',a,1x,a)') & & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) - if (debug) write (*,*) trim(jobcall) + if (debug) write (stdout,*) trim(jobcall) call command(trim(jobcall),io) call grepval('xtb.out','| TOTAL ENERGY',success,eout) !---- cleanup @@ -101,7 +101,7 @@ subroutine xtb_opt_qcg(env,zmol,constrain) character(len=512) :: jobcall logical :: constrain logical :: const - character(*),parameter :: pipe = ' > xtb_opt.out 2> /dev/null' + character(stdout),parameter :: pipe = ' > xtb_opt.out 2> /dev/null' integer :: io,T,Tn !--- Write coordinated @@ -163,7 +163,7 @@ subroutine xtb_lmo(env,fname,success,eout) call command(trim(jobcall),exitstat=io) if (io /= 0) then - write (*,*) 'error in xtb_lmo' + write (stdout,*) 'error in xtb_lmo' stop end if call grepval('xtb.out','| TOTAL ENERGY',success,eout) @@ -605,8 +605,8 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) call new_ompautoset(env,'auto',NTMP,T,Tn) if (postopt) then - write (*,'(2x,''Starting optimizations + SP of structures'')') - write (*,'(2x,i0,'' jobs to do.'')') NTMP + write (stdout,'(2x,''Starting optimizations + SP of structures'')') + write (stdout,'(2x,i0,'' jobs to do.'')') NTMP end if ! postopt eq true => post opt run, which has to be performed in every directory !!! @@ -641,7 +641,7 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) & trim(env%ProgName),trim(fname),trim(env%gfnver),nint(env%optlev),trim(pipe) if (NTMP .lt. 1) then - write (*,'(2x,"No structures to be optimized")') + write (stdout,'(2x,"No structures to be optimized")') return end if @@ -684,7 +684,7 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) & trim(env%ProgName),'xtbopt.coord',trim(env%gfnver),trim(env%solv),trim(pipe) if (NTMP .lt. 1) then - write (*,'(2x,"Nothing to do")') + write (stdout,'(2x,"Nothing to do")') return end if @@ -724,8 +724,8 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) end do if (postopt) then - write (*,*) '' - write (*,'(2x,"done.")') + write (stdout,*) '' + write (stdout,'(2x,"done.")') end if end subroutine cff_opt @@ -757,15 +757,15 @@ subroutine ens_sp(env,fname,NTMP,TMPdir) ! setting the threads for correct parallelization call new_ompautoset(env,'auto',NTMP,T,Tn) - write (*,'(2x,''Single point computation with GBSA model'')') - write (*,'(2x,i0,'' jobs to do.'')') NTMP + write (stdout,'(2x,''Single point computation with GBSA model'')') + write (stdout,'(2x,i0,'' jobs to do.'')') NTMP pipe = '2>/dev/null' call getcwd(thispath) if (NTMP .lt. 1) then - write (*,'(2x,"No structures to be optimized")') + write (stdout,'(2x,"No structures to be optimized")') return end if @@ -807,8 +807,8 @@ subroutine ens_sp(env,fname,NTMP,TMPdir) call remove('xtbrestart') call chdir(trim(thispath)) end do - write (*,*) '' - write (*,'(2x,"done.")') + write (stdout,*) '' + write (stdout,'(2x,"done.")') end subroutine ens_sp @@ -840,15 +840,15 @@ subroutine ens_freq(env,fname,NTMP,TMPdir,opt) ! setting the threads for correct parallelization call new_ompautoset(env,'auto',NTMP,T,Tn) - write (*,'(2x,''Starting reoptimizations + Frequency computation of ensemble'')') - write (*,'(2x,i0,'' jobs to do.'')') NTMP + write (stdout,'(2x,''Starting reoptimizations + Frequency computation of ensemble'')') + write (stdout,'(2x,i0,'' jobs to do.'')') NTMP pipe = '2>/dev/null' call getcwd(thispath) if (NTMP .lt. 1) then - write (*,'(2x,"No structures to be optimized")') + write (stdout,'(2x,"No structures to be optimized")') return end if @@ -893,8 +893,8 @@ subroutine ens_freq(env,fname,NTMP,TMPdir,opt) call remove('xtbrestart') call chdir(trim(thispath)) end do - write (*,*) '' - write (*,'(2x,"done.")') + write (stdout,*) '' + write (stdout,'(2x,"done.")') end subroutine ens_freq @@ -903,14 +903,14 @@ end subroutine ens_freq !============================================================! subroutine rdxtbiffE(fname,m,n,e) - + use crest_parameters implicit none integer :: m,n character(len=*),intent(in) :: fname - real*8 :: e(*) + real(wp) :: e(:) character(len=128) :: line - real*8 :: xx(10) + real(wp) :: xx(10) integer :: ich,i,j,nn open (newunit=ich,file=fname) @@ -1122,13 +1122,13 @@ subroutine get_interaction_E(env,solu,solv,clus,iter,E_inter) !--- Perform single point calculations and recieve energies call xtb_sp_qcg(env,'solute_cut.coord',e_there,e_solute) - if (.not.e_there) write (*,*) 'Solute energy not found' + if (.not.e_there) write (stdout,*) 'Solute energy not found' call xtb_sp_qcg(env,'solvent_cut.coord',e_there,e_solvent) - if (.not.e_there) write (*,*) 'Solvent energy not found' + if (.not.e_there) write (stdout,*) 'Solvent energy not found' call xtb_sp_qcg(env,'cluster.coord',e_there,e_cluster) - if (.not.e_there) write (*,*) 'Cluster energy not found' + if (.not.e_there) write (stdout,*) 'Cluster energy not found' E_inter(iter) = e_cluster-e_solute-e_solvent diff --git a/src/qcg/qcg_utils.f90 b/src/qcg/qcg_utils.f90 index a022238e..ef9f5795 100644 --- a/src/qcg/qcg_utils.f90 +++ b/src/qcg/qcg_utils.f90 @@ -236,10 +236,10 @@ subroutine get_sphere(pr,zmol,r_logical) if (pr) then if (r_logical) then - write (*,'(2x,''molecular radius (Bohr**1):'',F8.2)') zmol%rtot + write (stdout,'(2x,''molecular radius (Bohr**1):'',F8.2)') zmol%rtot end if - write (*,'(2x,''molecular area (Bohr**2):'',F8.2)') zmol%atot - write (*,'(2x,''molecular volume (Bohr**3):'',F8.2)') zmol%vtot + write (stdout,'(2x,''molecular area (Bohr**2):'',F8.2)') zmol%atot + write (stdout,'(2x,''molecular volume (Bohr**3):'',F8.2)') zmol%vtot end if end subroutine get_sphere @@ -310,11 +310,11 @@ subroutine get_ellipsoid(env,solu,solv,clus,pr1) call wrc0('solvent',solv%nat,solv%at,solv%xyz) !--- Getting axis - write (*,*) 'Solute:' + write (stdout,*) 'Solute:' call axis(pr1,solu%nat,solu%at,solu%xyz,solu%eax) - write (*,*) 'Solvent:' + write (stdout,*) 'Solvent:' call axis(pr1,solv%nat,solv%at,solv%xyz,solv%eax) - write (*,*) + write (stdout,*) end if !--- Computing anisotropy factor of solute and solvent @@ -353,18 +353,18 @@ subroutine get_ellipsoid(env,solu,solv,clus,pr1) clus%ell_abc = rabc_solv*env%potscal if (pr1) then - write (*,'(2x,''solvent anisotropy :'',4f10.3)') aniso - write (*,'(2x,''solute anisotropy :'',4f10.3)') sola - write (*,'(2x,''roff inner wall :'',4f10.3)') roff - write (*,'(2x,''solute max dist :'',4f10.3)') rmax_solu - write (*,'(2x,''solvent max dist :'',4f10.3)') rmax_solv - write (*,'(2x,''inner unit axis :'',3f10.3)') dummy_solu%ell_abc(1:3) - write (*,'(2x,''inner ellipsoid/Bohr :'',3f10.3)') rabc_solu(1:3) - write (*,'(2x,''scaling factor outer ellipsoid:'',3f10.3)') env%potscal - write (*,'(2x,''outer ellipsoid/Bohr :'',3f10.3)') clus%ell_abc(1:3) + write (stdout,'(2x,''solvent anisotropy :'',4f10.3)') aniso + write (stdout,'(2x,''solute anisotropy :'',4f10.3)') sola + write (stdout,'(2x,''roff inner wall :'',4f10.3)') roff + write (stdout,'(2x,''solute max dist :'',4f10.3)') rmax_solu + write (stdout,'(2x,''solvent max dist :'',4f10.3)') rmax_solv + write (stdout,'(2x,''inner unit axis :'',3f10.3)') dummy_solu%ell_abc(1:3) + write (stdout,'(2x,''inner ellipsoid/Bohr :'',3f10.3)') rabc_solu(1:3) + write (stdout,'(2x,''scaling factor outer ellipsoid:'',3f10.3)') env%potscal + write (stdout,'(2x,''outer ellipsoid/Bohr :'',3f10.3)') clus%ell_abc(1:3) if (env%potscal .gt. 1.0_wp) write & - &(*,'(2x,''!!!WARNING: A SCALING FACTOR LARGER 1.0 IS ONLY FOR MICROSOLVATION RECOMMENDED'')') - write (*,*) + &(stdout,'(2x,''!!!WARNING: A SCALING FACTOR LARGER 1.0 IS ONLY FOR MICROSOLVATION RECOMMENDED'')') + write (stdout,*) end if end subroutine get_ellipsoid @@ -537,8 +537,8 @@ subroutine qcg_boltz(env,n,e,p) implicit none type(systemdata),intent(in) :: env integer,intent(in) :: n - real(wp),intent(in) :: e(*) - real(wp),intent(out) :: p(*) + real(wp),intent(in) :: e(:) + real(wp),intent(out) :: p(:) integer :: i real(wp) :: temp real(wp) :: f,hsum,esum From 65fb9ef0b80d02c783570bd521dac29127629eb3 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 14 Nov 2025 22:11:53 +0100 Subject: [PATCH 083/374] Replace deprecated zmolecule type in QCG with new polymorphic coord_qcg --- src/classes.f90 | 4 +-- src/qcg/CMakeLists.txt | 1 + src/qcg/qcg_coord_type.f90 | 71 ++++++++++++++++++++++++++++++++++++++ src/qcg/qcg_main.f90 | 36 +++++++++---------- src/qcg/qcg_misc.f90 | 40 ++++++++++----------- src/qcg/qcg_utils.f90 | 55 +++++++++++++++-------------- src/qcg/volume.f90 | 30 ++++++++-------- src/sorting/zdata.f90 | 16 --------- 8 files changed, 154 insertions(+), 99 deletions(-) create mode 100644 src/qcg/qcg_coord_type.f90 diff --git a/src/classes.f90 b/src/classes.f90 index 9affea57..67c23062 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -876,7 +876,7 @@ end subroutine read_charges subroutine ref_to_mol(self,mol) implicit none class(refdata) :: self - type(coord) :: mol + class(coord) :: mol mol%nat = self%nat if (allocated(self%at)) mol%at = self%at if (allocated(self%xyz)) mol%xyz = self%xyz @@ -888,7 +888,7 @@ end subroutine ref_to_mol subroutine ref_load_mol(self,mol) implicit none class(refdata) :: self - type(coord) :: mol + class(coord) :: mol call self%init(mol%nat) self%nat = mol%nat self%at = mol%at diff --git a/src/qcg/CMakeLists.txt b/src/qcg/CMakeLists.txt index fc761f62..034766bc 100644 --- a/src/qcg/CMakeLists.txt +++ b/src/qcg/CMakeLists.txt @@ -18,6 +18,7 @@ set(dir "${CMAKE_CURRENT_SOURCE_DIR}") list(APPEND srcs "${dir}/volume.f90" + "${dir}/qcg_coord_type.f90" "${dir}/qcg_misc.f90" "${dir}/qcg_main.f90" "${dir}/qcg_printouts.f90" diff --git a/src/qcg/qcg_coord_type.f90 b/src/qcg/qcg_coord_type.f90 new file mode 100644 index 00000000..c3aa2cb8 --- /dev/null +++ b/src/qcg/qcg_coord_type.f90 @@ -0,0 +1,71 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2025 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! +! +module qcg_coord_type + use crest_parameters,only:wp + use strucrd,only:coord + implicit none + public + + type,extends(coord) :: coord_qcg + !> new components that are added to the coord type: + integer :: nmol !> number of molecules + real(wp) :: cma(3) !> center of mass + real(wp) :: aniso !> anisotropy factor + real(wp) :: ell_abc(3) !> ellipsoid axis + real(wp) :: atot !> surface area + real(wp) :: vtot !> volume + real(wp) :: rtot !> radius + real(wp) :: mass !> mass + real(wp) :: gt !> gibbs free energy + real(wp) :: ht !> enthalpy + real(wp) :: svib !> vibrational entropy + real(wp) :: srot !> rotational entropy + real(wp) :: stra !> translational entropy + real(wp) :: eax(3) !> molecular axis + contains + procedure :: as_coord + end type coord_qcg + +!==============================================================================! +contains !> MODULE PROCEDURES START HERE +!==============================================================================! + + function as_coord(this) result(mol) + class(coord_qcg),intent(in) :: this + type(coord) :: mol + + mol%nat = this%nat + if (allocated(this%at)) mol%at = this%at + if (allocated(this%xyz)) mol%xyz = this%xyz + + mol%energy = this%energy + if (allocated(this%comment)) mol%comment = this%comment + mol%chrg = this%chrg + mol%uhf = this%uhf + mol%nbd = this%nbd + if (allocated(this%bond)) mol%bond = this%bond + if (allocated(this%lat)) mol%lat = this%lat + if (allocated(this%qat)) mol%qat = this%qat + mol%pdb = this%pdb + + end function as_coord + +end module qcg_coord_type + diff --git a/src/qcg/qcg_main.f90 b/src/qcg/qcg_main.f90 index 861b4888..b90d1d92 100644 --- a/src/qcg/qcg_main.f90 +++ b/src/qcg/qcg_main.f90 @@ -27,14 +27,14 @@ subroutine crest_solvtool(env,tim) use qcg_printouts use crest_data use iomod - use zdata + use qcg_coord_type use strucrd implicit none type(systemdata):: env ! MAIN STORAGE OS SYSTEM DATA type(timer):: tim !> Information about solvent, solute and cluster - type(zmolecule) :: solute,solvent,cluster,cluster_backup + type(coord_qcg) :: solute,solvent,cluster,cluster_backup type(ensemble) :: full_ensemble,solvent_ensemble integer :: progress,io @@ -160,13 +160,13 @@ subroutine qcg_setup(env,solu,solv) use iso_fortran_env,wp => real64 use crest_data use iomod - use zdata + use qcg_coord_type use strucrd use axis_module implicit none type(systemdata):: env - type(zmolecule) :: solv,solu + type(coord_qcg) :: solv,solu integer :: io,f,r integer :: num_O,num_H,i @@ -320,14 +320,14 @@ subroutine read_qcg_input(env,solu,solv) use crest_parameters use crest_data use iomod - use zdata + use qcg_coord_type use strucrd use atmasses use qcg_utils implicit none type(systemdata) :: env - type(zmolecule),intent(inout) :: solu,solv + type(coord_qcg),intent(inout) :: solu,solv logical :: pr real(wp),parameter :: third = 1.0d0/3.0d0 integer :: i @@ -462,13 +462,13 @@ subroutine qcg_grow(env,solu,solv,clus,tim) use crest_data use qcg_printouts use iomod - use zdata + use qcg_coord_type use strucrd use qcg_utils implicit none type(systemdata) :: env - type(zmolecule) :: solu,solv,clus + type(coord_qcg) :: solu,solv,clus type(timer) :: tim integer :: minE_pos,m @@ -842,7 +842,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) use crest_data use qcg_printouts use iomod - use zdata + use qcg_coord_type use strucrd use utilities use cregen_interface @@ -850,7 +850,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) implicit none type(systemdata) :: env - type(zmolecule) :: solu,solv,clus + type(coord_qcg) :: solu,solv,clus type(ensemble) :: ens,dum type(timer) :: tim @@ -1482,14 +1482,14 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) use crest_data use qcg_printouts use iomod - use zdata + use qcg_coord_type use strucrd use qcg_utils implicit none type(systemdata) :: env type(timer) :: tim - type(zmolecule) :: solu,solv,clus + type(coord_qcg) :: solu,solv,clus type(ensemble) :: solv_ens type(ensemble),intent(in) :: ens @@ -1932,14 +1932,14 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) use crest_data use qcg_printouts use iomod - use zdata + use qcg_coord_type use strucrd use qcg_utils implicit none type(systemdata) :: env type(timer) :: tim - type(zmolecule) :: solu,solv,clus + type(coord_qcg) :: solu,solv,clus type(ensemble) :: solu_ens,solv_ens integer :: r,io,f,g,h @@ -2192,13 +2192,13 @@ subroutine qcg_eval(env,solu,solu_ens,solv_ens) use crest_data use qcg_printouts use iomod - use zdata + use qcg_coord_type use strucrd use qcg_utils implicit none type(systemdata) :: env - type(zmolecule) :: solu + type(coord_qcg) :: solu type(ensemble) :: solu_ens,solv_ens character(len=512) :: thispath @@ -2302,13 +2302,13 @@ subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup use crest_parameters use crest_data use iomod - use zdata + use qcg_coord_type use strucrd use qcg_utils implicit none type(systemdata) :: env - type(zmolecule) :: solu,solv,clus,clus_backup + type(coord_qcg) :: solu,solv,clus,clus_backup type(ensemble) :: solu_ens,solv_ens integer :: progress diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index 0326a6ca..1d53259a 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -84,18 +84,18 @@ subroutine xtb_sp_qcg(env,fname,success,eout) end subroutine xtb_sp_qcg !-------------------------------------------------------------------------------------------- -! A quick single xtb optimization gets zmol and overwrites it with optimized stuff +! A quick single xtb optimization gets mol and overwrites it with optimized stuff !-------------------------------------------------------------------------------------------- -subroutine xtb_opt_qcg(env,zmol,constrain) +subroutine xtb_opt_qcg(env,mol,constrain) use crest_parameters use iomod use crest_data - use zdata + use qcg_coord_type use strucrd implicit none type(systemdata),intent(in) :: env - type(zmolecule),intent(inout) :: zmol + type(coord_qcg),intent(inout) :: mol character(:),allocatable :: fname character(len=512) :: jobcall @@ -106,7 +106,7 @@ subroutine xtb_opt_qcg(env,zmol,constrain) !--- Write coordinated fname = 'coord' - call wrc0(fname,zmol%nat,zmol%at,zmol%xyz) !write coord for xtbopt routine + call wrc0(fname,mol%nat,mol%at,mol%xyz) !write coord for xtbopt routine !---- setting threads call new_ompautoset(env,'auto',1,T,Tn) @@ -114,7 +114,7 @@ subroutine xtb_opt_qcg(env,zmol,constrain) !---- jobcall & Handling constraints if (constrain.AND.env%cts%used) then call write_constraint(env,fname,'xcontrol') - call wrc0('coord.ref',zmol%nat,zmol%at,zmol%xyz) !write coord for xtbopt routine + call wrc0('coord.ref',mol%nat,mol%at,mol%xyz) !write coord for xtbopt routine write (jobcall,'(a,1x,a,1x,a,'' --opt --input xcontrol '',a,1x,a)') & & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) else @@ -124,7 +124,7 @@ subroutine xtb_opt_qcg(env,zmol,constrain) call command(trim(jobcall),io) !---- cleanup - call rdcoord('xtbopt.coord',zmol%nat,zmol%at,zmol%xyz) + call rdcoord('xtbopt.coord',mol%nat,mol%at,mol%xyz) call remove('energy') call remove('charges') call remove('xtbrestart') @@ -141,7 +141,7 @@ subroutine xtb_lmo(env,fname,success,eout) use crest_parameters use iomod use crest_data - use zdata + use qcg_coord_type implicit none type(systemdata) :: env character(len=*),intent(in) :: fname @@ -185,12 +185,12 @@ subroutine xtb_iff(env,file_lmo1,file_lmo2,solu,clus) use crest_parameters use iomod use crest_data - use zdata + use qcg_coord_type implicit none type(systemdata) :: env - type(zmolecule),intent(in) :: solu,clus + type(coord_qcg),intent(in) :: solu,clus character(len=80) :: pipe character(len=512) :: jobcall character(len=*) :: file_lmo1,file_lmo2 @@ -229,12 +229,12 @@ subroutine xtb_dock(env,fnameA,fnameB,solu,clus) use crest_parameters use iomod use crest_data - use zdata + use qcg_coord_type implicit none type(systemdata) :: env - type(zmolecule),intent(in) :: solu,clus + type(coord_qcg),intent(in) :: solu,clus character(len=*),intent(in) :: fnameA,fnameB character(len=80) :: pipe character(len=512) :: jobcall @@ -289,12 +289,12 @@ subroutine opt_cluster(env,solu,clus,fname,without_pot) use crest_parameters use iomod use crest_data - use zdata + use qcg_coord_type implicit none type(systemdata) :: env - type(zmolecule),intent(in) :: solu,clus + type(coord_qcg),intent(in) :: solu,clus character(len=*),intent(in) :: fname logical,optional,intent(in) :: without_pot character(len=80) :: pipe @@ -354,11 +354,11 @@ subroutine ensemble_lmo(env,fname,self,NTMP,TMPdir,conv) use crest_parameters use iomod use crest_data - use zdata + use qcg_coord_type implicit none type(systemdata) :: env - type(zmolecule),intent(in) :: self + type(coord_qcg),intent(in) :: self character(len=*),intent(in) :: fname !file base name character(len=*),intent(in) :: TMPdir !directory name integer,intent(in) :: NTMP !number of structures to be optimized @@ -421,7 +421,7 @@ subroutine ensemble_iff(env,outer_ell_abc,nfrag1,frag1_file,frag2_file,NTMP,TMPd use crest_parameters use iomod use crest_data - use zdata + use qcg_coord_type implicit none type(systemdata) :: env @@ -490,7 +490,7 @@ subroutine ensemble_dock(env,outer_ell_abc,nfrag1,frag1_file,frag2_file,n_shell& use crest_parameters use iomod use crest_data - use zdata + use qcg_coord_type implicit none type(systemdata) :: env @@ -1103,12 +1103,12 @@ subroutine get_interaction_E(env,solu,solv,clus,iter,E_inter) use iso_fortran_env,wp => real64 use crest_data use iomod - use zdata + use qcg_coord_type use strucrd implicit none type(systemdata) :: env - type(zmolecule),intent(in) :: solu,solv,clus + type(coord_qcg),intent(in) :: solu,solv,clus real(wp) :: e_cluster,e_solute,e_solvent real(wp) :: E_inter(env%nsolv) ! interaction energy integer :: iter diff --git a/src/qcg/qcg_utils.f90 b/src/qcg/qcg_utils.f90 index ef9f5795..b45d834a 100644 --- a/src/qcg/qcg_utils.f90 +++ b/src/qcg/qcg_utils.f90 @@ -34,16 +34,15 @@ subroutine inputcoords_qcg(env,solute,solvent) use crest_parameters use crest_data use strucrd - use zdata + use qcg_coord_type use iomod implicit none type(systemdata),intent(inout) :: env - type(zmolecule),intent(out) :: solute,solvent + type(coord_qcg),intent(out) :: solute,solvent logical :: ex11,ex21,solu,solv - type(coord) :: mol - type(zmolecule) :: zmol,zmol1 + type(coord_qcg) :: mol integer :: i !--------------------Checking for input-------------! @@ -107,13 +106,13 @@ end subroutine inputcoords_qcg subroutine write_reference(env,solu,clus) use crest_data - use zdata,only:zmolecule + use qcg_coord_type use iomod use strucrd implicit none type(systemdata):: env ! MAIN STORAGE OS SYSTEM DATA - type(zmolecule) :: solu,clus - type(zmolecule) :: ref_mol,ref_clus + type(coord_qcg) :: solu,clus + type(coord_qcg) :: ref_mol,ref_clus ref_mol = solu call rdcoord(env%solu_file,ref_mol%nat,ref_mol%at,ref_mol%xyz) !original solute coordinates call remove(env%fixfile) @@ -201,45 +200,45 @@ end subroutine aver !==============================================================================! - subroutine get_sphere(pr,zmol,r_logical) + subroutine get_sphere(pr,mol,r_logical) use crest_parameters - use zdata + use qcg_coord_type use miscdata implicit none - type(zmolecule),intent(inout) :: zmol - type(zmolecule) :: dum + type(coord_qcg),intent(inout) :: mol + type(coord_qcg) :: dum logical :: pr logical :: r_logical !Determines wether r is overwritten or not real(wp),parameter :: pi43 = pi*4.0d0/3.0d0 real(wp),parameter :: third = 1.0d0/3.0d0 integer :: i - real(wp) :: rad(zmol%nat),xyz_tmp(3,zmol%nat) + real(wp) :: rad(mol%nat),xyz_tmp(3,mol%nat) external get_volume - do i = 1,zmol%nat - rad(i) = bohr*rcov_qcg(zmol%at(i))*1.40 ! scale factor adjusted to rough - xyz_tmp(1:3,i) = bohr*zmol%xyz(1:3,i) + do i = 1,mol%nat + rad(i) = bohr*rcov_qcg(mol%at(i))*1.40 ! scale factor adjusted to rough + xyz_tmp(1:3,i) = bohr*mol%xyz(1:3,i) end do - dum = zmol + dum = mol dum%xyz = xyz_tmp call get_volume(dum,rad) - zmol%atot = dum%atot/bohr**2 - zmol%vtot = dum%vtot/bohr**3 + mol%atot = dum%atot/bohr**2 + mol%vtot = dum%vtot/bohr**3 if (r_logical) then - zmol%rtot = zmol%vtot*3.0/4.d0/pi - zmol%rtot = zmol%rtot**(1.d0/3.d0) + mol%rtot = mol%vtot*3.0/4.d0/pi + mol%rtot = mol%rtot**(1.d0/3.d0) end if if (pr) then if (r_logical) then - write (stdout,'(2x,''molecular radius (Bohr**1):'',F8.2)') zmol%rtot + write (stdout,'(2x,''molecular radius (Bohr**1):'',F8.2)') mol%rtot end if - write (stdout,'(2x,''molecular area (Bohr**2):'',F8.2)') zmol%atot - write (stdout,'(2x,''molecular volume (Bohr**3):'',F8.2)') zmol%vtot + write (stdout,'(2x,''molecular area (Bohr**2):'',F8.2)') mol%atot + write (stdout,'(2x,''molecular volume (Bohr**3):'',F8.2)') mol%vtot end if end subroutine get_sphere @@ -249,12 +248,12 @@ subroutine cma_shifting(solu,solv) use crest_parameters use crest_data use iomod - use zdata + use qcg_coord_type use strucrd use axis_module,only:cma implicit none - type(zmolecule) :: solu,solv + type(coord_qcg) :: solu,solv integer :: i @@ -276,14 +275,14 @@ subroutine get_ellipsoid(env,solu,solv,clus,pr1) use crest_parameters use crest_data use iomod - use zdata + use qcg_coord_type use strucrd use axis_module implicit none type(systemdata) :: env - type(zmolecule) :: solu,solv,clus - type(zmolecule) :: dummy_solu,dummy_solv + type(coord_qcg) :: solu,solv,clus + type(coord_qcg) :: dummy_solu,dummy_solv real(wp) :: rabc_solu(3),rabc_solv(3) real(wp) :: aniso,sola real(wp) :: rmax_solu,rmax_solv diff --git a/src/qcg/volume.f90 b/src/qcg/volume.f90 index 8eff59e3..11d402f8 100644 --- a/src/qcg/volume.f90 +++ b/src/qcg/volume.f90 @@ -22,12 +22,12 @@ ! Jaroslav Skrivánek, Ming-Chya Wu ! Comput. Phys. Commun. 165(2005)59 -subroutine get_volume(zmol,rad) +subroutine get_volume(mol,rad) use crest_parameters - use zdata + use qcg_coord_type implicit none - type(Zmolecule),intent(inout) :: zmol - real(wp),intent(in) :: rad(zmol%nat) + type(coord_qcg),intent(inout) :: mol + real(wp),intent(in) :: rad(mol%nat) real(wp),allocatable :: xyz_rad(:,:) integer,allocatable :: neigh_list(:) integer,allocatable :: neigh_index(:) @@ -35,28 +35,28 @@ subroutine get_volume(zmol,rad) real(wp) :: va_part(2) integer :: i - allocate (xyz_rad(zmol%nat,4),neigh_list(zmol%nat),neigh_index(zmol%nat)) - allocate (neigh_type(zmol%nat**2)) + allocate (xyz_rad(mol%nat,4),neigh_list(mol%nat),neigh_index(mol%nat)) + allocate (neigh_type(mol%nat**2)) - zmol%vtot = 0d0 - zmol%atot = 0d0 + mol%vtot = 0d0 + mol%atot = 0d0 !--- Copying Input - do i = 1,zmol%nat - xyz_rad(i,1:3) = zmol%xyz(1:3,i) + do i = 1,mol%nat + xyz_rad(i,1:3) = mol%xyz(1:3,i) xyz_rad(i,4) = rad(i) end do !--- Checking neighbors (different to usual CREST neighbors to account for more atoms) - call create_neigh(zmol%nat,xyz_rad,neigh_list, & + call create_neigh(mol%nat,xyz_rad,neigh_list, & & neigh_index,neigh_type) !--- Compute V and A - do i = 1,zmol%nat + do i = 1,mol%nat call calcVA(i,xyz_rad,neigh_list,neigh_index, & - & neigh_type,zmol%nat,va_part) - zmol%vtot = zmol%vtot+va_part(1) - zmol%atot = zmol%atot+va_part(2) + & neigh_type,mol%nat,va_part) + mol%vtot = mol%vtot+va_part(1) + mol%atot = mol%atot+va_part(2) end do deallocate (xyz_rad,neigh_type,neigh_index) diff --git a/src/sorting/zdata.f90 b/src/sorting/zdata.f90 index c204467a..e87fad47 100644 --- a/src/sorting/zdata.f90 +++ b/src/sorting/zdata.f90 @@ -161,22 +161,6 @@ module zdata integer,allocatable :: map(:) integer,allocatable :: revmap(:) - !>--- QCG information - integer :: nmol !> number of molecules - real(wp) :: cma(3) !> center of mass - real(wp) :: aniso !> anisotropy factor - real(wp) :: ell_abc(3) !> ellipsoid axis - real(wp) :: atot !> surface area - real(wp) :: vtot !> volume - real(wp) :: rtot !> radius - real(wp) :: mass !> mass - real(wp) :: gt !> gibbs free energy - real(wp) :: ht !> enthalpy - real(wp) :: svib !> vibrational entropy - real(wp) :: srot !> rotational entropy - real(wp) :: stra !> translational entropy - real(wp) :: eax(3) !> molecular axis - !>--- procedures to be used with the zmol type contains procedure :: wrtable => wrtable !> write CNs and neighbours From 2b676951d8d96a6ba182747aac34dc8d70edfad3 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 14 Nov 2025 23:27:20 +0100 Subject: [PATCH 084/374] cont'd QCG refactor --- src/qcg/qcg_coord_type.f90 | 20 +++++++++ src/qcg/qcg_main.f90 | 24 ++++++----- src/qcg/qcg_misc.f90 | 87 ++++++++++++++++++++++++++------------ src/qcg/qcg_utils.f90 | 2 +- 4 files changed, 95 insertions(+), 38 deletions(-) diff --git a/src/qcg/qcg_coord_type.f90 b/src/qcg/qcg_coord_type.f90 index c3aa2cb8..9e732865 100644 --- a/src/qcg/qcg_coord_type.f90 +++ b/src/qcg/qcg_coord_type.f90 @@ -41,6 +41,7 @@ module qcg_coord_type real(wp) :: eax(3) !> molecular axis contains procedure :: as_coord + procedure :: from_coord end type coord_qcg !==============================================================================! @@ -67,5 +68,24 @@ function as_coord(this) result(mol) end function as_coord + subroutine from_coord(this,mol) + class(coord_qcg),intent(inout) :: this + type(coord),intent(in) :: mol + + this%nat = mol%nat + if (allocated(mol%at)) this%at = mol%at + if (allocated(mol%xyz)) this%xyz = mol%xyz + + this%energy = mol%energy + if (allocated(mol%comment)) this%comment = mol%comment + this%chrg = mol%chrg + this%uhf = mol%uhf + this%nbd = mol%nbd + if (allocated(mol%bond)) this%bond = mol%bond + if (allocated(mol%lat)) this%lat = mol%lat + if (allocated(mol%qat)) this%qat = mol%qat + this%pdb = mol%pdb + end subroutine from_coord + end module qcg_coord_type diff --git a/src/qcg/qcg_main.f90 b/src/qcg/qcg_main.f90 index b90d1d92..52119d4f 100644 --- a/src/qcg/qcg_main.f90 +++ b/src/qcg/qcg_main.f90 @@ -475,6 +475,7 @@ subroutine qcg_grow(env,solu,solv,clus,tim) integer :: iter = 1 integer :: i,j,io,v integer :: max_cycle + integer :: nat_backup logical :: e_there,high_e,success,neg_E real(wp) :: etmp(500) real(wp),allocatable :: e_each_cycle(:) @@ -501,7 +502,7 @@ subroutine qcg_grow(env,solu,solv,clus,tim) allocate (E_inter(env%max_solv)) end if - call tim%start(5,'Grow') + call tim%start(5,'QCG Grow') call pr_eval_solute() call print_qcg_grow() @@ -567,7 +568,7 @@ subroutine qcg_grow(env,solu,solv,clus,tim) !-------------------------------------------------------- ! Start Loop !-------------------------------------------------------- - do iter = 1,max_cycle + GROW_LOOP: do iter = 1,max_cycle e_there = .false. success = .false. high_e = .false. @@ -587,7 +588,7 @@ subroutine qcg_grow(env,solu,solv,clus,tim) call both_ellipsout('twopot_1.coord',clus%nat,clus%at,clus%xyz,& & clus%ell_abc,solu%ell_abc) - do while (.not.success) !For restart with larger wall pot + CHECKWALL: do while (.not.success) !For restart with larger wall pot if (iter .eq. 1) then if (env%use_xtbiff) then call xtb_iff(env,'solute.lmo','solvent.lmo',solu,solv) @@ -635,11 +636,12 @@ subroutine qcg_grow(env,solu,solv,clus,tim) end if end if end if - end do + end do CHECKWALL !--- Increase cluster size + nat_backup = clus%nat call clus%deallocate - clus%nat = clus%nat+solv%nat + clus%nat = nat_backup+solv%nat allocate (clus%at(clus%nat)) allocate (clus%xyz(3,clus%nat)) clus%nmol = clus%nmol+1 @@ -736,7 +738,7 @@ subroutine qcg_grow(env,solu,solv,clus,tim) ! dist of new mol from solute for output call analyze_cluster(iter,clus%nat,solu%nat,solv%nat,clus%xyz,clus%at,shr_av,shr) - write (stdout,'(x,i4,F13.6,1x,f7.2,3x,f8.2,6x,f6.3,3x,f8.3,3x,2f6.1,2x,f8.1,3x,a,x)') & + write (stdout,'(x,i4,F13.6,1x,f7.2,3x,es9.2,5x,f6.3,3x,f8.3,3x,2f6.1,2x,f8.1,3x,a,x)') & & iter,e_each_cycle(iter),autokcal*(e_each_cycle(iter)-solv%energy-dum),& & e_diff,dens,efix,shr_av,shr,clus%vtot,trim(optlevflag(env%optlev)) write (ich99,'(i4,F20.10,3x,f8.1)') iter,e_each_cycle(iter),clus%vtot @@ -767,7 +769,7 @@ subroutine qcg_grow(env,solu,solv,clus,tim) !----------------------------------------------- ! End loop !----------------------------------------------- - end do + end do GROW_LOOP if (env%nsolv .eq. 0) env%nsolv = iter !if no env%solv was given @@ -883,9 +885,9 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) type(timer) :: tim_dum !Dummy timer to avoid double counting if (.not.env%solv_md) then - call tim%start(6,'Solute-Ensemble') + call tim%start(6,'QCG Solute-Ensemble') else - call tim%start(7,'Solvent-Ensemble') + call tim%start(7,'QCG Solvent-Ensemble') end if call tim_dum%init(20) @@ -1526,7 +1528,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) real(wp) :: optlev_tmp integer :: ich98,ich31 - call tim%start(8,'CFF') + call tim%start(8,'QCG CFF') allocate (e_empty(env%nqcgclust)) allocate (converged(env%nqcgclust)) @@ -1956,7 +1958,7 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) integer :: ich65,ich56,ich33,ich81 logical :: opt - call tim%start(9,'Frequencies') + call tim%start(9,'QCG Frequencies') call pr_qcg_freq() diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index 1d53259a..1d3ac0d8 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -20,7 +20,7 @@ subroutine xtb_sp_qcg(env,fname,success,eout) !******************************************************** !* xtb_sp_qcg -!* A quick single point xtb calculation without wbo +!* A quick single point xtb calculation without wbo !******************************************************** use crest_parameters use iomod @@ -99,37 +99,72 @@ subroutine xtb_opt_qcg(env,mol,constrain) character(:),allocatable :: fname character(len=512) :: jobcall - logical :: constrain - logical :: const - character(stdout),parameter :: pipe = ' > xtb_opt.out 2> /dev/null' + logical :: constrain, const + real(wp) :: energy integer :: io,T,Tn + character(stdout),parameter :: pipe = ' > xtb_opt.out 2> /dev/null' + logical,parameter :: debug = .false. -!--- Write coordinated - fname = 'coord' - call wrc0(fname,mol%nat,mol%at,mol%xyz) !write coord for xtbopt routine -!---- setting threads - call new_ompautoset(env,'auto',1,T,Tn) + if (env%legacy) then + !> LEGACY version with syscall + + !--- Write coordinated + fname = 'coord' + call wrc0(fname,mol%nat,mol%at,mol%xyz) !write coord for xtbopt routine + + !---- setting threads + call new_ompautoset(env,'auto',1,T,Tn) + + !---- jobcall & Handling constraints + if (constrain.AND.env%cts%used) then + call write_constraint(env,fname,'xcontrol') + call wrc0('coord.ref',mol%nat,mol%at,mol%xyz) !write coord for xtbopt routine + write (jobcall,'(a,1x,a,1x,a,'' --opt --input xcontrol '',a,1x,a)') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) + else + write (jobcall,'(a,1x,a,1x,a,'' --opt '',a,1x,a)') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) + end if + + call command(trim(jobcall),io) + !---- cleanup + call rdcoord('xtbopt.coord',mol%nat,mol%at,mol%xyz) + call remove('energy') + call remove('charges') + call remove('xtbrestart') + call remove('xtbtopo.mol') + call remove('gfnff_topo') -!---- jobcall & Handling constraints - if (constrain.AND.env%cts%used) then - call write_constraint(env,fname,'xcontrol') - call wrc0('coord.ref',mol%nat,mol%at,mol%xyz) !write coord for xtbopt routine - write (jobcall,'(a,1x,a,1x,a,'' --opt --input xcontrol '',a,1x,a)') & - & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) else - write (jobcall,'(a,1x,a,1x,a,'' --opt '',a,1x,a)') & - & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) - end if - call command(trim(jobcall),io) -!---- cleanup - call rdcoord('xtbopt.coord',mol%nat,mol%at,mol%xyz) - call remove('energy') - call remove('charges') - call remove('xtbrestart') - call remove('xtbtopo.mol') - call remove('gfnff_topo') + !> NEW version with calculator + call new_ompautoset(env,'max',1,T,Tn) + block + use crest_calculator + use optimize_module + type(calcdata) :: calc + type(coord) :: molin,molout + real(wp),allocatable :: gradtmp(:,:) + + allocate (gradtmp(3,mol%nat)) + molin = mol%as_coord() + call env2calc(env,calc,molin) + if (debug) call calc%info(stdout) + + call optimize_geometry(molin,molout,calc,energy,gradtmp,debug,.false.,io) + + deallocate(gradtmp) + if(io == 0)then + call mol%from_coord(molout) + else + write(stdout,*) 'FAILURE in QCG optimization!' + write(stdout,*) 'Stopping run to avoid unecessary compuations' + call creststop(status_safety) + endif + end block + + end if end subroutine xtb_opt_qcg !___________________________________________________________________________________ diff --git a/src/qcg/qcg_utils.f90 b/src/qcg/qcg_utils.f90 index b45d834a..baa092a3 100644 --- a/src/qcg/qcg_utils.f90 +++ b/src/qcg/qcg_utils.f90 @@ -362,7 +362,7 @@ subroutine get_ellipsoid(env,solu,solv,clus,pr1) write (stdout,'(2x,''scaling factor outer ellipsoid:'',3f10.3)') env%potscal write (stdout,'(2x,''outer ellipsoid/Bohr :'',3f10.3)') clus%ell_abc(1:3) if (env%potscal .gt. 1.0_wp) write & - &(stdout,'(2x,''!!!WARNING: A SCALING FACTOR LARGER 1.0 IS ONLY FOR MICROSOLVATION RECOMMENDED'')') + &(stdout,'(2x,''!!!WARNING: A SCALING FACTOR LARGER 1.0 IS ONLY RECOMMENDED FOR MICROSOLVATION'')') write (stdout,*) end if From d377aebbdd1915cf0b1ecfd36aebb4c6f228bc6d Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 17 Nov 2025 21:42:39 +0100 Subject: [PATCH 085/374] New runtype aliases --- src/parsing/parse_maindata.f90 | 34 +++++++++++++++++++++++++++++++--- 1 file changed, 31 insertions(+), 3 deletions(-) diff --git a/src/parsing/parse_maindata.f90 b/src/parsing/parse_maindata.f90 index 14b3ebfe..deb971aa 100644 --- a/src/parsing/parse_maindata.f90 +++ b/src/parsing/parse_maindata.f90 @@ -175,11 +175,39 @@ subroutine parse_main_c(env,key,val,rd) env%preopt = .false. env%crestver = crest_mecp env%runver = crest_mecp - case ('imtd-gc') + case ('imtd-gc','mtd_search') env%preopt = .true. env%crestver = crest_imtd env%runver = 1 - case ('nci-mtd','nci') + case ('mtd_search_quick') + env%preopt = .true. + env%crestver = crest_imtd + env%quick = .true. + env%runver = 2 + env%ewin = 5.0d0 + env%optlev = 1.0d0 !> optlev tight for quick run + case ('mtd_search_mquick') + env%preopt = .true. + env%crestver = crest_imtd + env%rotamermds = .false. !> no NORMMD + env%performCross = .false. !> no GC + env%quick = .true. !> MTD settings from the quick-mode + env%superquick = .true. !> use user-set opt level in Multilevel opt. + env%Maxrestart = 1 !> only one MTD iteration + env%runver = 6 + env%optlev = 0.0d0 !> user-set opt level + env%ewin = 2.5d0 !> smaller energy window + case ('mtd_search_squick') + env%preopt = .true. + env%crestver = crest_imtd + env%rotamermds = .false. !> no NORMMD + env%performCross = .false. !> no GC + env%quick = .true. !> MTD settings from the quick-mode + env%superquick = .true. !> use user-set opt level in Multilevel opt. + env%runver = 5 + env%optlev = 0.0d0 !> user-set opt level + env%ewin = 5.0d0 !> smaller energy window + case ('nci-mtd','nci','nci_search') env%NCI = .true. env%runver = 4 env%autozsort = .false. @@ -187,7 +215,7 @@ subroutine parse_main_c(env,key,val,rd) env%rotamermds = .false. case ('bh','gmin') env%crestver = crest_bh - case ('entropy','imtd-smtd') + case ('entropy','imtd-smtd','entropy_search') env%crestver = crest_imtd !> the entropy mode acts as subtype of the crest_imtd algo env%properties = abs(p_CREentropy) env%autozsort = .false. !> turn off zsort (since we are not going to GC anyways) From 20010c0a423d9f2885fb376f23f841347e358a08 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 17 Nov 2025 22:51:15 +0100 Subject: [PATCH 086/374] deprecate xtbiff in QCG --- src/qcg/qcg_main.f90 | 153 +++----------------- src/qcg/qcg_misc.f90 | 287 -------------------------------------- src/qcg/qcg_printouts.f90 | 14 +- src/qcg/qcg_utils.f90 | 33 +++++ 4 files changed, 67 insertions(+), 420 deletions(-) diff --git a/src/qcg/qcg_main.f90 b/src/qcg/qcg_main.f90 index 52119d4f..e3e55809 100644 --- a/src/qcg/qcg_main.f90 +++ b/src/qcg/qcg_main.f90 @@ -58,13 +58,12 @@ subroutine crest_solvtool(env,tim) !> Check, if xtbiff is present (if it is required) if (env%use_xtbiff) then - call checkprog_silent(env%ProgIFF,.true.,iostat=io) - if (io /= 0) error stop 'No xtbiff found' + call xtbiff_print_deprecated() else write (stdout,*) - write (stdout,*) ' The use of the aISS algorithm is requested (recommend).' + write (stdout,*) ' The use of the aISS algorithm is the current standard implementation.' write (stdout,*) ' This requires xtb version 6.6.0 or newer.' - write (stdout,*) ' xTB-IFF can still be used with the --xtbiff flag.' + !write (stdout,*) ' xTB-IFF can still be used with the --xtbiff flag.' write (stdout,*) end if @@ -229,13 +228,8 @@ subroutine qcg_setup(env,solu,solv) call axistrf(solu%nat,solu%nat,solu%at,solu%xyz) call wrc0('solute',solu%nat,solu%at,solu%xyz) -!---- LMO/SP-Computation solute - if (env%use_xtbiff) then - write (stdout,*) 'Generating LMOs for solute' - call xtb_lmo(env,'solute',e_there,solu%energy) - else - call xtb_sp_qcg(env,'solute',e_there,solu%energy) - end if +!---- SP-Computation solute + call xtb_sp_qcg(env,'solute',e_there,solu%energy) if (.not.e_there) then write (stdout,*) 'Total Energy of solute not found' @@ -243,10 +237,6 @@ subroutine qcg_setup(env,solu,solv) write (stdout,outfmt) 'Total Energy of solute: ',solu%energy,' Eh' end if - if (env%use_xtbiff) then - call rename('xtblmoinfo','solute.lmo') - end if - if (env%final_gfn2_opt) then !If GFN2 final opt, solute also GFN2 optimized env%gfnver = gfnver_tmp end if @@ -268,13 +258,8 @@ subroutine qcg_setup(env,solu,solv) end if call wrc0('solvent',solv%nat,solv%at,solv%xyz) -!---- LMO-Computation solvent - if (env%use_xtbiff) then - write (stdout,*) 'Generating LMOs for solvent' - call xtb_lmo(env,'solvent',e_there,solv%energy) - else - call xtb_sp_qcg(env,'solvent',e_there,solv%energy) - end if +!---- SP-Computation solvent + call xtb_sp_qcg(env,'solvent',e_there,solv%energy) if (.not.e_there) then write (stdout,'(1x,a)') 'Total Energy of solvent not found' @@ -282,10 +267,6 @@ subroutine qcg_setup(env,solu,solv) write (stdout,outfmt) 'Total energy of solvent:',solv%energy,' Eh' end if - if (env%use_xtbiff) then - call rename('xtblmoinfo','solvent.lmo') - end if - call chdir(thispath) !---- Overwriting solute and solvent in original folder @@ -370,8 +351,6 @@ subroutine read_qcg_input(env,solu,solv) !--- If directed docking is requested, it is read in here: if (allocated(env%directed_file)) then - if (env%use_xtbiff) error stop 'xTB-IFF does not support directed docking. & - &Please use the aISS algorithm of xtb.' call read_directed_input(env) end if @@ -544,10 +523,6 @@ subroutine qcg_grow(env,solu,solv,clus,tim) if (env%fixfile /= 'none selected') then call copysub(env%fixfile,'tmp_grow') end if - if (env%use_xtbiff) then - call copy('solute_properties/solute.lmo','tmp_grow/solute.lmo') - call copy('solvent_properties/solvent.lmo','tmp_grow/solvent.lmo') - end if call chdir('tmp_grow') call wrc0('solute',solu%nat,solu%at,solu%xyz) call wrc0('solvent',solv%nat,solv%at,solv%xyz) @@ -573,16 +548,9 @@ subroutine qcg_grow(env,solu,solv,clus,tim) success = .false. high_e = .false. neg_E = .false. -!---- LMO-Computation +!---- Computation if (iter .gt. 1) then call get_ellipsoid(env,solu,solv,clus,.false.) - if (env%use_xtbiff) then - call xtb_lmo(env,'xtbopt.coord',e_there,clus%energy) - if (.not.e_there) then - write (stdout,'(1x,a)') 'Total Energy of cluster LMO computation not found' - end if - call rename('xtblmoinfo','cluster.lmo') - end if end if call both_ellipsout('twopot_1.coord',clus%nat,clus%at,clus%xyz,& @@ -590,14 +558,8 @@ subroutine qcg_grow(env,solu,solv,clus,tim) CHECKWALL: do while (.not.success) !For restart with larger wall pot if (iter .eq. 1) then - if (env%use_xtbiff) then - call xtb_iff(env,'solute.lmo','solvent.lmo',solu,solv) - !solu for nat of core pot. solv for outer ellips - call check_iff(neg_E) - else - call xtb_dock(env,'solute','solvent',solu,solv) - call check_dock(neg_E) - end if + call xtb_dock(env,'solute','solvent',solu,solv) + call check_dock(neg_E) !-- If Interaction Energy is not negativ and existent, wall pot. too small and increase if (neg_E) then @@ -614,13 +576,8 @@ subroutine qcg_grow(env,solu,solv,clus,tim) end if end if else - if (env%use_xtbiff) then - call xtb_iff(env,'cluster.lmo','solvent.lmo',solu,clus) - call check_iff(neg_E) - else - call xtb_dock(env,'cluster.coord','solvent',solu,clus) - call check_dock(neg_E) - end if + call xtb_dock(env,'cluster.coord','solvent',solu,clus) + call check_dock(neg_E) if (neg_E) then success = .true. @@ -647,14 +604,7 @@ subroutine qcg_grow(env,solu,solv,clus,tim) clus%nmol = clus%nmol+1 !--- Select xtb-IFF stucture to proceed - if (env%use_xtbiff) then - call rdxtbiffE('xtbscreen.xyz',m,clus%nat,etmp) !Get energy of screening - minE_pos = minloc(etmp(1:m),dim=1) !Get minimum of those - !Read the struc into clus%xyz - call rdxmolselec('xtbscreen.xyz',minE_pos,clus%nat,clus%at,clus%xyz) - else - call rdcoord('best.xyz',clus%nat,clus%at,clus%xyz,clus%energy) - end if + call rdcoord('best.xyz',clus%nat,clus%at,clus%xyz,clus%energy) call remove('cluster.coord') call wrc0('cluster.coord',clus%nat,clus%at,clus%xyz) @@ -671,11 +621,6 @@ subroutine qcg_grow(env,solu,solv,clus,tim) call write_reference(env,solu,clus) !new fixed file end if - if (env%use_xtbiff) then - call opt_cluster(env,solu,clus,'cluster.coord',.false.) - call rdcoord('xtbopt.coord',clus%nat,clus%at,clus%xyz) - end if - !--- Interaction energy !gfnver_tmp = env%gfnver env%gfnver = env%lmover @@ -703,15 +648,7 @@ subroutine qcg_grow(env,solu,solv,clus,tim) env%gfnver = gfnver_tmp !--- For output - if (env%use_xtbiff) then - call grepval('xtb.out','| TOTAL ENERGY',e_there,clus%energy) - call wrc0('optimized_cluster.coord',clus%nat,clus%at,clus%xyz) - if (.not.e_there) then - write (stdout,'(1x,a)') 'Total Energy of cluster not found.' - end if - else - !Energy already read from xyz file - end if + !Energy already read from xyz file e_each_cycle(iter) = clus%energy !--- Calclulate fix energy + diff. energy @@ -1505,7 +1442,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) integer :: conv(env%nqcgclust+1) integer :: solv_added,minpos character(len=512) :: thispath,resultspath,tmppath,tmppath2 - character(len=64) :: fname_lmo1,fname_lmo2,comment + character(len=64) :: comment character(len=20) :: to real(wp),allocatable :: e_empty(:),inner_ell_abc(:,:) real(wp),allocatable :: outer_ell_abc(:,:) @@ -1574,11 +1511,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) call getcwd(tmppath2) call chdir(tmppath) call chdir('solvent_properties') - if (env%use_xtbiff) then - call copysub('solvent.lmo',tmppath2) - else - call copysub('solvent',tmppath2) - end if + call copysub('solvent',tmppath2) call chdir(tmppath2) !--- SP of each cluster @@ -1588,11 +1521,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) clus%nmol = clus%nat/solv%nat write (to,'("TMPCFF",i0)') i io = makedir(trim(to)) - if (env%use_xtbiff) then - call copysub('solvent.lmo',to) - else - call copysub('solvent',to) - end if + call copysub('solvent',to) call chdir(to) call wrc0('cluster.coord',clus%nat,clus%at,clus%xyz) call wr_cluster_cut('cluster.coord',solu%nat,solv%nat,env%nsolv,'solute_cut.coord','solvent_shell.coord') @@ -1636,37 +1565,11 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) end do conv(k+1:env%nqcgclust) = 0 - if (env%use_xtbiff) then -!----------- LMO computation for solvent cluster--------------------------------------------------- - call ensemble_lmo(env,'solvent_cluster.coord',solv,conv(env%nqcgclust+1),& - & 'TMPCFF',conv) -!-------------------------------------------------------------------------------------------------- - - do i = 1,env%nqcgclust - if (.not.converged(i)) then - write (to,'("TMPCFF",i0)') i - call chdir(to) - call rename('xtblmoinfo','solvent_cluster.lmo') - call chdir(tmppath2) - else - cycle - end if - end do - end if - call chdir(tmppath2) - fname_lmo1 = 'solvent_cluster.lmo' - fname_lmo2 = 'solvent.lmo' - !--- Solvent addition to the cluster--------------------------------------------- - if (env%use_xtbiff) then - call ensemble_iff(env,outer_ell_abc,nat_frag1,fname_lmo1,fname_lmo2,& - &conv(env%nqcgclust+1),'TMPCFF',conv) - else - call ensemble_dock(env,outer_ell_abc,nat_frag1,'solvent_cluster.coord',& - &'solvent',clus%nat,solv%nat,conv(env%nqcgclust+1),'TMPCFF',conv) - end if + call ensemble_dock(env,outer_ell_abc,nat_frag1,'solvent_cluster.coord',& + &'solvent',clus%nat,solv%nat,conv(env%nqcgclust+1),'TMPCFF',conv) !-------------------------------------------------------------------------------- nat_frag1 = nat_frag1+solv%nat @@ -1686,16 +1589,8 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) call remove('xtbrestart') call remove('xcontrol') - if (env%use_xtbiff) then - !--- Select xtb-IFF stucture to proceed - call rdxtbiffE('xtbscreen.xyz',m,clus%nat,etmp) !Get energy of screening - minE_pos = minloc(etmp(1:m),dim=1) !Get minimum of those - call rdxmolselec('xtbscreen.xyz',minE_pos,clus%nat,clus%at,clus%xyz) !Read the struc into clus%xyz - call wrc0('solvent_cluster.coord',clus%nat,clus%at,clus%xyz) - else - call rdcoord('best.xyz',clus%nat,clus%at,clus%xyz,e_cur(iter,i)) - call wrc0('solvent_cluster.coord',clus%nat,clus%at,clus%xyz) - end if + call rdcoord('best.xyz',clus%nat,clus%at,clus%xyz,e_cur(iter,i)) + call wrc0('solvent_cluster.coord',clus%nat,clus%at,clus%xyz) !--- Check if converged call fill_take(env,solv%nat,clus%nat,inner_ell_abc(i,1:3),ipos) @@ -1725,21 +1620,15 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) end do conv(k+1:env%nqcgclust) = 0 -! if(env%use_xtbiff) then !--- Parallel optimization------------------------------------------------------------------- call cff_opt(.false.,env,'solvent_cluster.coord',n_ini,conv(env%nqcgclust+1)& &,'TMPCFF',conv,nothing_added) !---------------------------------------------------------------------------------------------- -! end if do i = 1,env%nqcgclust if (.not.converged(i)) then write (to,'("TMPCFF",i0)') i call chdir(to) - if (env%use_xtbiff) then - call copy('xtbopt.coord','solvent_cluster.coord') - call grepval('xtb_sp.out','| TOTAL ENERGY',e_there,e_cur(iter,i)) - end if dum_e = e_empty(i) if (iter-nsolv .gt. 1) dum_e = e_cur(iter-1,i) de = autokcal*(e_cur(iter,i)-solv%energy-dum_e) diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index 1d3ac0d8..d5c3f015 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -167,94 +167,6 @@ subroutine xtb_opt_qcg(env,mol,constrain) end if end subroutine xtb_opt_qcg -!___________________________________________________________________________________ -! -! An xTB single point calculation and lmo generation on all available threads -!___________________________________________________________________________________ - -subroutine xtb_lmo(env,fname,success,eout) - use crest_parameters - use iomod - use crest_data - use qcg_coord_type - implicit none - type(systemdata) :: env - character(len=*),intent(in) :: fname - logical,intent(out) :: success - real(wp),intent(out) :: eout - character(len=*),parameter :: pipe = ' > xtb.out 2>/dev/null' - character(len=512) :: jobcall - integer :: T,Tn,io - - success = .false. - eout = 0.0_wp - -!---- setting threads - call new_ompautoset(env,'auto',1,T,Tn) - -!---- jobcall, special gbsa treatment not needed, as the entire flag is included in env%solv - write (jobcall,'(a,1x,a,1x,a,'' --sp --lmo '',a)') & - & trim(env%ProgName),trim(fname),trim(env%lmover),trim(pipe) - call command(trim(jobcall),exitstat=io) - - if (io /= 0) then - write (stdout,*) 'error in xtb_lmo' - stop - end if - call grepval('xtb.out','| TOTAL ENERGY',success,eout) -!--- cleanup - call remove('wbo') - call remove('charges') - call remove('xtbrestart') - call remove('xtbscreen.xyz') - call remove('lmocent.coord') - call remove('coordprot.0') -end subroutine xtb_lmo - -!___________________________________________________________________________________ -! -! An xTB-IFF calculation on all available threads -!___________________________________________________________________________________ - -subroutine xtb_iff(env,file_lmo1,file_lmo2,solu,clus) - use crest_parameters - use iomod - use crest_data - use qcg_coord_type - - implicit none - - type(systemdata) :: env - type(coord_qcg),intent(in) :: solu,clus - character(len=80) :: pipe - character(len=512) :: jobcall - character(len=*) :: file_lmo1,file_lmo2 - integer :: T,Tn - -!--- Option setting - pipe = ' > iff.out 2>/dev/null' - -!--- Setting threads - call new_ompautoset(env,'auto',1,T,Tn) - -!--- Jobcall - if (env%sameRandomNumber) then - write (jobcall,'(a,1x,a,1x,a,'' -nfrag1 '',i3,'' -ellips '',3f9.3,'' -qcg -test '',a)') & - & trim(env%ProgIFF),trim(file_lmo1),trim(file_lmo2),solu%nat,clus%ell_abc,trim(pipe) - else - write (jobcall,'(a,1x,a,1x,a,'' -nfrag1 '',i3,'' -ellips '',3f9.3,'' -qcg '',a)') & - & trim(env%ProgIFF),trim(file_lmo1),trim(file_lmo2),solu%nat,clus%ell_abc,trim(pipe) -! & trim(env%ProgIFF),trim(solvent_file),trim(solute_file),solu%nat,clus%ell_abc,trim(pipe) - end if - call command(trim(jobcall)) - -!--- Cleanup - call remove('xtbiff_bestsofar.xyz') - call remove('xtbiff_genstart.xyz') - call remove('xtbrestart') - -end subroutine xtb_iff - !___________________________________________________________________________________ ! ! An xTB docking on all available threads @@ -380,141 +292,6 @@ subroutine opt_cluster(env,solu,clus,fname,without_pot) end subroutine opt_cluster -!___________________________________________________________________________________ -! -! xTB LMO calculation performed in parallel -!___________________________________________________________________________________ - -subroutine ensemble_lmo(env,fname,self,NTMP,TMPdir,conv) - use crest_parameters - use iomod - use crest_data - use qcg_coord_type - - implicit none - type(systemdata) :: env - type(coord_qcg),intent(in) :: self - character(len=*),intent(in) :: fname !file base name - character(len=*),intent(in) :: TMPdir !directory name - integer,intent(in) :: NTMP !number of structures to be optimized - integer,intent(in) :: conv(env%nqcgclust+1) - integer :: i,k,T,Tn - integer :: vz - character(len=20) :: pipe - character(len=512) :: thispath,tmppath - character(len=1024) :: jobcall - real(wp) :: percent - -! setting the threads for correct parallelization - call new_ompautoset(env,'auto',NTMP,T,Tn) - - pipe = '2>/dev/null' - - !create the system call (it is the same for every optimization) - - write (jobcall,'(a,1x,a,1x,a,'' --sp --lmo --chrg '',f4.1,1x,a,'' >xtb_lmo.out'')') & - & trim(env%ProgName),trim(fname),trim(env%lmover),self%chrg,trim(pipe) - k = 0 !counting the finished jobs -!___________________________________________________________________________________ - -!$omp parallel & -!$omp shared( vz,jobcall,NTMP,percent,k,TMPdir,conv ) -!$omp single - do i = 1,NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath ) - write (tmppath,'(a,i0)') trim(TMPdir),conv(vz) - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical - k = k+1 - percent = float(k)/float(NTMP)*100 - !$omp end critical - !$omp end task - end do -!$omp taskwait -!$omp end single -!$omp end parallel - -!___________________________________________________________________________________ - - call getcwd(thispath) - do i = 1,NTMP - write (tmppath,'(a,i0)') trim(TMPdir),i - call chdir(trim(tmppath)) - call remove('xtbrestart') - call chdir(trim(thispath)) - end do - -end subroutine ensemble_lmo - -!___________________________________________________________________________________ -! -! xTB-IFF calculation performed in parallel -!___________________________________________________________________________________ - -subroutine ensemble_iff(env,outer_ell_abc,nfrag1,frag1_file,frag2_file,NTMP,TMPdir,conv) - use crest_parameters - use iomod - use crest_data - use qcg_coord_type - - implicit none - type(systemdata) :: env - - character(len=*),intent(in) :: TMPdir !directory name - integer,intent(in) :: NTMP !number of structures to be optimized - integer,intent(in) :: nfrag1 !#atoms of larger fragment - integer,intent(in) :: conv(env%nqcgclust+1) - real(wp),intent(in) :: outer_ell_abc(env%nqcgclust,3) - - integer :: i,k - integer :: vz,T,Tn - character(len=20) :: pipe - character(len=512) :: tmppath - character(len=1024) :: jobcall - character(len=64),intent(in) :: frag1_file - character(len=64),intent(in) :: frag2_file - character(len=64) :: frag1 - character(len=64) :: frag2 - real(wp) :: percent - -! some options - pipe = '2>/dev/null' - frag1 = 'solvent_cluster.lmo' - frag2 = 'solvent.lmo' - -! setting the threads for correct parallelization - call new_ompautoset(env,'auto',NTMP,T,Tn) - - k = 0 !counting the finished jobs - -!___________________________________________________________________________________ - -!$omp parallel & -!$omp shared( vz,NTMP,percent,k,TMPdir,conv ) -!$omp single - do i = 1,NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath,jobcall ) -! create the system call - write (jobcall,'(a,1x,a,1x,a,'' -nfrag1 '',i3,'' -ellips '',3f9.3,'' -qcg '',a,'' >iff.out'')') & -& trim(env%ProgIFF),trim(frag1_file),trim(frag2_file),nfrag1,outer_ell_abc(conv(vz),1:3)*0.9,trim(pipe) - write (tmppath,'(a,i0)') trim(TMPdir),conv(vz) - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical - k = k+1 - percent = float(k)/float(NTMP)*100 - !$omp end critical - !$omp end task - end do -!$omp taskwait -!$omp end single -!$omp end parallel - -!___________________________________________________________________________________ - -end subroutine ensemble_iff - !___________________________________________________________________________________ ! ! xTB docking calculation performed in parallel @@ -933,39 +710,6 @@ subroutine ens_freq(env,fname,NTMP,TMPdir,opt) end subroutine ens_freq -!============================================================! -! Read the Energies from a xtbiff output -!============================================================! - -subroutine rdxtbiffE(fname,m,n,e) - use crest_parameters - implicit none - integer :: m,n - character(len=*),intent(in) :: fname - real(wp) :: e(:) - - character(len=128) :: line - real(wp) :: xx(10) - integer :: ich,i,j,nn - - open (newunit=ich,file=fname) - - j = 1 -10 continue - read (ich,'(a)',end=999) line - read (ich,'(a)') line - call readl(line,xx,nn) - e(j) = xx(1) - do i = 1,n - read (ich,'(a)') line - end do - j = j+1 - goto 10 - -999 close (ich) - m = j-1 -end - !============================================================! ! subroutine wr_cluster_cut ! Cuts a cluster file and and writes the parts @@ -1021,37 +765,6 @@ subroutine wr_cluster_cut(fname_cluster,n1,n2,iter,fname_solu_cut,fname_solv_cut end subroutine wr_cluster_cut -subroutine check_iff(neg_E) - use crest_parameters - use crest_data - - implicit none - integer :: io,ich - real(wp) :: int_E - character(len=50) :: tmp - logical,intent(out) :: neg_E - - logical :: ex - character(len=*),parameter :: filename = 'xtbscreen.xyz' - - neg_E = .false. - int_E = 0.0_wp - - inquire (file=filename,exist=ex) - if (.not.ex) return - - open (newunit=ich,file=filename,status="old",iostat=io) - if (io == 0) read (ich,'(a)',iostat=io) - if (io == 0) read (ich,'(a)',iostat=io) tmp - close (ich) - if (io /= 0) return - - tmp = adjustl(tmp(11:)) - read (tmp,*,iostat=io) int_E - neg_E = io == 0.and.int_E < 0.0_wp - -end subroutine check_iff - !---------------------------------------------------------------------------- ! write a wall potential in a file used as xtb input diff --git a/src/qcg/qcg_printouts.f90 b/src/qcg/qcg_printouts.f90 index 04106d3c..23894119 100644 --- a/src/qcg/qcg_printouts.f90 +++ b/src/qcg/qcg_printouts.f90 @@ -101,7 +101,6 @@ subroutine write_qcg_setup(env) write (stdout,'(2x,''System temperature [K] : '',F5.1)') env%tboltz write (stdout,'(2x,''RRHO scaling factor : '',F4.2)') env%freq_scal write (stdout,*) - if (env%use_xtbiff) write (stdout,'(2x,''Use of xTB-IFF standalone requested'')') end subroutine write_qcg_setup @@ -280,6 +279,19 @@ subroutine pr_freq_file(ich) write (ich,'(2x,"--------------------------------------------------------")') end subroutine pr_freq_file +!========================================================================================! + + subroutine xtbiff_print_deprecated() + external creststop + write (stdout,*) + write (stdout,*) 'WARNING WARNING WARNING' + write (stdout,*) ' The use of xtbiff in QCG is deprecated and is disabled' + write (stdout,*) ' following CREST 3.0.3, in favor of the aISS algorithm.' + write (stdout,*) ' This requires a current version of the xtb program.' + write (stdout,*) + call creststop(status_safety) + end subroutine xtbiff_print_deprecated + !========================================================================================! !========================================================================================! end module qcg_printouts diff --git a/src/qcg/qcg_utils.f90 b/src/qcg/qcg_utils.f90 index baa092a3..63bc65d4 100644 --- a/src/qcg/qcg_utils.f90 +++ b/src/qcg/qcg_utils.f90 @@ -742,5 +742,38 @@ subroutine rdtherm(fname,ht,svib,srot,stra,gt) close (ich) end subroutine rdtherm +!============================================================! +! Read the Energies from a xtbiff output +!============================================================! + + subroutine rdxtbiffE(fname,m,n,e) + use crest_parameters + implicit none + integer :: m,n + character(len=*),intent(in) :: fname + real(wp) :: e(:) + + character(len=128) :: line + real(wp) :: xx(10) + integer :: ich,i,j,nn + + open (newunit=ich,file=fname) + + j = 1 +10 continue + read (ich,'(a)',end=999) line + read (ich,'(a)') line + call readl(line,xx,nn) + e(j) = xx(1) + do i = 1,n + read (ich,'(a)') line + end do + j = j+1 + goto 10 + +999 close (ich) + m = j-1 + end subroutine rdxtbiffE + !==============================================================================! end module qcg_utils From 0eb056aba310a036674fdf261deda6d9bbe44d8f Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 17 Nov 2025 23:42:34 +0100 Subject: [PATCH 087/374] print chdir location for debugging (temporary) --- src/qcg/qcg_main.f90 | 206 +++++++++++++++++++++---------------------- src/qcg/qcg_misc.f90 | 59 ++++++++----- 2 files changed, 139 insertions(+), 126 deletions(-) diff --git a/src/qcg/qcg_main.f90 b/src/qcg/qcg_main.f90 index e3e55809..fd0802ae 100644 --- a/src/qcg/qcg_main.f90 +++ b/src/qcg/qcg_main.f90 @@ -88,7 +88,7 @@ subroutine crest_solvtool(env,tim) cluster_backup = cluster end if progress = progress+1 - call chdir(thispath) + call chdirdbug(thispath) end if !------------------------------------------------------------------------------ @@ -98,7 +98,7 @@ subroutine crest_solvtool(env,tim) call print_qcg_ensemble() call qcg_ensemble(env,solute,solvent,cluster,full_ensemble,tim,'ensemble') progress = progress+1 - call chdir(thispath) + call chdirdbug(thispath) end if !------------------------------------------------------------------------------ @@ -125,7 +125,7 @@ subroutine crest_solvtool(env,tim) write (stdout,'(2x,"|",9x,F8.2," kcal/mol ",12x,"|")') & & full_ensemble%g-solvent_ensemble%g-(solute%energy*autokcal) write (stdout,'(2x,''========================================='')') - call chdir(thispath) + call chdirdbug(thispath) progress = progress+1 end if @@ -190,7 +190,7 @@ subroutine qcg_setup(env,solu,solv) if (env%fixfile /= 'none selected') then call copysub(env%fixfile,env%scratchdir) end if - call chdir(env%scratchdir) + call chdirdbug(env%scratchdir) f = makedir('solute_properties') if (env%fixfile /= 'none selected') then @@ -211,7 +211,7 @@ subroutine qcg_setup(env,solu,solv) env%gbsa = .false. !---- Properties solute - call chdir('solute_properties') + call chdirdbug('solute_properties') call env%wrtCHRG('') !Write three lines in QCG mode, but xtb anyway only reads first one !---- Geometry preoptimization solute @@ -241,15 +241,15 @@ subroutine qcg_setup(env,solu,solv) env%gfnver = gfnver_tmp end if - call chdir(thispath) + call chdirdbug(thispath) ! No constraints for solvent possible used_tmp = env%cts%used env%cts%used = .false. !---- Properties solvent - call chdir(env%scratchdir) - call chdir('solvent_properties') + call chdirdbug(env%scratchdir) + call chdirdbug('solvent_properties') !No charges for solvent written. This is currently not possible !---- Geometry preoptimization solvent @@ -267,7 +267,7 @@ subroutine qcg_setup(env,solu,solv) write (stdout,outfmt) 'Total energy of solvent:',solv%energy,' Eh' end if - call chdir(thispath) + call chdirdbug(thispath) !---- Overwriting solute and solvent in original folder call wrc0('solute',solu%nat,solu%at,solu%xyz) @@ -487,7 +487,7 @@ subroutine qcg_grow(env,solu,solv,clus,tim) call print_qcg_grow() call getcwd(thispath) io = makedir('grow') - call chdir('grow') !Results directory + call chdirdbug('grow') !Results directory !--- Output Files open (newunit=ich99,file='qcg_energy.dat') @@ -497,7 +497,7 @@ subroutine qcg_grow(env,solu,solv,clus,tim) write (ich88,'('' # Energy Run. Aver. Diff / au.'')') call getcwd(resultspath) - call chdir(thispath) + call chdirdbug(thispath) if (env%water) then if (.not.env%user_wscal) then @@ -518,12 +518,12 @@ subroutine qcg_grow(env,solu,solv,clus,tim) call get_ellipsoid(env,solu,solv,clus,.true.) call pr_grow_energy() - call chdir(env%scratchdir) + call chdirdbug(env%scratchdir) v = makedir('tmp_grow') if (env%fixfile /= 'none selected') then call copysub(env%fixfile,'tmp_grow') end if - call chdir('tmp_grow') + call chdirdbug('tmp_grow') call wrc0('solute',solu%nat,solu%at,solu%xyz) call wrc0('solvent',solv%nat,solv%at,solv%xyz) call env%wrtCHRG('') !Write .CHRG file for docking @@ -762,8 +762,8 @@ subroutine qcg_grow(env,solu,solv,clus,tim) call write_wall(env,solu%nat,solu%ell_abc,clus%ell_abc,'wall_potential') call copysub('wall_potential',resultspath) - call chdir(thispath) - call chdir(env%scratchdir) + call chdirdbug(thispath) + call chdirdbug(env%scratchdir) if (.not.env%keepModef) call rmrf('tmp_grow') deallocate (e_each_cycle,E_inter) @@ -832,9 +832,9 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) !--- Setting up directories call getcwd(thispath) f = makedir(fname_results) - call chdir(fname_results) + call chdirdbug(fname_results) call getcwd(resultspath) - call chdir(thispath) + call chdirdbug(thispath) !--- Setting defaults env%cts%NCI = .true. !Activating to have wall pot. written in coord file for xtb @@ -859,17 +859,17 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) call copysub(env%fixfile,env%scratchdir) end if - call chdir(env%scratchdir) + call chdirdbug(env%scratchdir) scratchdir_tmp = env%scratchdir if (.not.env%solv_md) then io = makedir('tmp_MTD') call copysub('.CHRG','tmp_MTD') call copysub('.UHF','tmp_MTD') if (env%cts%used) call copysub(env%fixfile,'tmp_MTD') - call chdir('tmp_MTD') + call chdirdbug('tmp_MTD') else io = makedir('tmp_solv_MTD') - call chdir('tmp_solv_MTD') + call chdirdbug('tmp_solv_MTD') end if call getcwd(tmppath2) call wrc0('crest_input',clus%nat,clus%at,clus%xyz) @@ -1058,9 +1058,9 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) r = makedir(tmppath) call copysub('xcontrol',tmppath) - call chdir(tmppath) + call chdirdbug(tmppath) call copy('coord','ref.coord') - call chdir(tmppath2) + call chdirdbug(tmppath2) call command('cd '//trim(tmppath)//' && '//trim(jobcall),io) @@ -1074,7 +1074,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) if (env%trackorigin) then call set_trj_origins('NORMMD','md') end if - call chdir('NORMMD1') + call chdirdbug('NORMMD1') end if !--- MTD @@ -1093,10 +1093,10 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) write (tmppath,'(a,i0)') 'METADYN1' r = makedir(tmppath) call copysub('xcontrol',tmppath) - call chdir(tmppath) + call chdirdbug(tmppath) call copy('coord','ref.coord') - call chdir(tmppath2) + call chdirdbug(tmppath2) call command('cd '//trim(tmppath)//' && '//trim(jobcall),io) @@ -1111,7 +1111,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) call set_trj_origins('METADYN','mtd') end if - call chdir('METADYN1') + call chdirdbug('METADYN1') end if @@ -1140,7 +1140,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) call copysub('xtb.out',resultspath) end if call dum%deallocate - call chdir(tmppath2) + call chdirdbug(tmppath2) call wrc0('coord',clus%nat,clus%at,clus%xyz) call inputcoords(env,'coord') !Necessary @@ -1202,9 +1202,9 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) io = makedir(trim(to)) call copysub('.UHF',to) call copysub('.CHRG',to) - call chdir(to) + call chdirdbug(to) call wrxyz('cluster.xyz',clus%nat,clus%at,clus%xyz*bohr) - call chdir(tmppath2) + call chdirdbug(tmppath2) end do !--- SP write (stdout,*) @@ -1213,17 +1213,17 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) do i = 1,ens%nall call rdxmolselec('ensemble.xyz',i,clus%nat,clus%at,clus%xyz) write (to,'("TMPSP",i0)') i - call chdir(to) + call chdirdbug(to) call grepval('xtb_sp.out','| TOTAL ENERGY',e_there,ens%er(i)) - call chdir(tmppath2) + call chdirdbug(tmppath2) end do if (.not.e_there) then write (stdout,*) write (stdout,*) 'Energy not found. Error in xTB computations occured' - call chdir(to) + call chdirdbug(to) call minigrep('xtb_sp.out','solv_model_loadInternalParam',not_param) - call chdir(tmppath2) + call chdirdbug(tmppath2) if (not_param) then write (stdout,*) ' !!!WARNIG: CHOSEN SOLVENT NOT PARAMETERIZED & & FOR IMPLICIT SOLVATION MODEL!!!' @@ -1243,9 +1243,9 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) !--- crest_best structure minpos = minloc(ens%er,dim=1) write (to,'("TMPSP",i0)') minpos - call chdir(to) + call chdirdbug(to) call rdxmol('cluster.xyz',clus%nat,clus%at,clus%xyz) - call chdir(tmppath2) + call chdirdbug(tmppath2) write (comment,'(F20.8)') ens%er(minpos) inquire (file='crest_best.xyz',exist=ex) if (ex) then @@ -1267,11 +1267,11 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) !--- Fixation energy of optimization do i = 1,ens%nall - call chdir('OPTIM') + call chdirdbug('OPTIM') write (to,'("TMPCONF",i0)') i - call chdir(to) + call chdirdbug(to) call grepval('xtb.out',' :: add. restraining',e_there,e_fix(i)) - call chdir(tmppath2) + call chdirdbug(tmppath2) call rdxmolselec('full_ensemble.xyz',i,clus%nat,clus%at,clus%xyz) call get_sphere(.false.,clus,.false.) @@ -1381,8 +1381,8 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) call copysub('full_population.dat',resultspath) !---Deleting ensemble tmp - call chdir(thispath) - call chdir(env%scratchdir) + call chdirdbug(thispath) + call chdirdbug(env%scratchdir) if (.not.env%keepModef) call rmrf(tmppath2) !----Outprint write (stdout,*) @@ -1501,18 +1501,18 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) !--- Folder management call getcwd(thispath) r = makedir('solvent_ensemble') - call chdir('solvent_ensemble') + call chdirdbug('solvent_ensemble') call getcwd(resultspath) - call chdir(thispath) - call chdir(env%scratchdir) + call chdirdbug(thispath) + call chdirdbug(env%scratchdir) call getcwd(tmppath) io = makedir('tmp_CFF') - call chdir('tmp_CFF') + call chdirdbug('tmp_CFF') call getcwd(tmppath2) - call chdir(tmppath) - call chdir('solvent_properties') + call chdirdbug(tmppath) + call chdirdbug('solvent_properties') call copysub('solvent',tmppath2) - call chdir(tmppath2) + call chdirdbug(tmppath2) !--- SP of each cluster call ens%write('ensemble.xyz') @@ -1522,7 +1522,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) write (to,'("TMPCFF",i0)') i io = makedir(trim(to)) call copysub('solvent',to) - call chdir(to) + call chdirdbug(to) call wrc0('cluster.coord',clus%nat,clus%at,clus%xyz) call wr_cluster_cut('cluster.coord',solu%nat,solv%nat,env%nsolv,'solute_cut.coord','solvent_shell.coord') call xtb_sp_qcg(env,'solvent_shell.coord',ex,e_empty(i)) @@ -1532,7 +1532,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) call get_ellipsoid(env,solu,solv,clus,.false.) !solu, to have same cavity to fill solvent in outer_ell_abc(i,1:3) = clus%ell_abc(1:3) inner_ell_abc(i,1:3) = solu%ell_abc(1:3) - call chdir(tmppath2) + call chdirdbug(tmppath2) end do if (skip) write (stdout,'(2x,''solute smaller than solvent, cff skipped'')') @@ -1565,7 +1565,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) end do conv(k+1:env%nqcgclust) = 0 - call chdir(tmppath2) + call chdirdbug(tmppath2) !--- Solvent addition to the cluster--------------------------------------------- call ensemble_dock(env,outer_ell_abc,nat_frag1,'solvent_cluster.coord',& @@ -1585,7 +1585,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) do i = 1,env%nqcgclust if (.not.converged(i)) then write (to,'("TMPCFF",i0)') i - call chdir(to) + call chdirdbug(to) call remove('xtbrestart') call remove('xcontrol') @@ -1600,7 +1600,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) write (stdout,'(2x,''previous cluster taken...'')') if (iter .eq. 1) nothing_added(i) = .true. end if - call chdir(tmppath2) + call chdirdbug(tmppath2) else cycle @@ -1628,7 +1628,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) do i = 1,env%nqcgclust if (.not.converged(i)) then write (to,'("TMPCFF",i0)') i - call chdir(to) + call chdirdbug(to) dum_e = e_empty(i) if (iter-nsolv .gt. 1) dum_e = e_cur(iter-1,i) de = autokcal*(e_cur(iter,i)-solv%energy-dum_e) @@ -1645,7 +1645,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) & iter+env%nsolv,i,e_cur(iter,i),de,de_tot(i),& & trim(optlevflag(env%optlev)) end if - call chdir(tmppath2) + call chdirdbug(tmppath2) end if end do @@ -1707,7 +1707,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) do i = 1,env%nqcgclust write (to,'("TMPCFF",i0)') i - call chdir(to) + call chdirdbug(to) call copy('xtbopt.coord','final_cluster.coord') !--- Reading structure @@ -1744,7 +1744,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) write (stdout,'(x,i4,4x,F13.6,2x,f6.3,1x,f8.3,2x,2f6.1,3x,f8.1,3x,a)') & & i,e_norm(i),dens,e_fix(i),shr_av,shr,atotS,trim(optlevflag(env%optlev)) - call chdir(tmppath2) + call chdirdbug(tmppath2) end do close (ich98) @@ -1759,13 +1759,13 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) !--- crest_best structure minpos = minloc(solv_ens%er,dim=1) write (to,'("TMPCFF",i0)') minpos - call chdir(to) + call chdirdbug(to) call clus%deallocate call rdnat('final_cluster.coord',clus%nat) allocate (clus%at(clus%nat),clus%xyz(3,clus%nat)) call rdcoord('final_cluster.coord',clus%nat,clus%at,clus%xyz) clus%xyz = clus%xyz*bohr - call chdir(tmppath2) + call chdirdbug(tmppath2) write (comment,'(F20.8)') solv_ens%er(minpos) call wrxyz('crest_best.xyz',clus%nat,clus%at,clus%xyz,comment) @@ -1790,9 +1790,9 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) call copysub('cluster_energy.dat',resultspath) call copysub('crest_best.xyz',resultspath) call copysub('population.dat',resultspath) - call chdir(tmppath) + call chdirdbug(tmppath) if (.not.env%keepModef) call rmrf('tmp_CFF') - call chdir(thispath) + call chdirdbug(thispath) !--- Printouts write (stdout,*) @@ -1860,15 +1860,15 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) !--- Folder management call getcwd(thispath) r = makedir('frequencies') - call chdir('frequencies') + call chdirdbug('frequencies') call getcwd(resultspath) - call chdir(thispath) - call chdir(env%scratchdir) + call chdirdbug(thispath) + call chdirdbug(env%scratchdir) call getcwd(tmppath) io = makedir('tmp_freq') call copysub('.CHRG','tmp_freq') call copysub('.UHF','tmp_freq') - call chdir('tmp_freq') + call chdirdbug('tmp_freq') call getcwd(tmppath2) f = makedir('tmp_solu') call copysub('.CHRG','tmp_solu') @@ -1880,12 +1880,12 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) !--- Frequencies solute molecule write (stdout,*) ' SOLUTE MOLECULE' - call chdir('tmp_gas1') + call chdirdbug('tmp_gas1') call wrc0('solute.coord',solu%nat,solu%at,solu%xyz) - call chdir(tmppath2) + call chdirdbug(tmppath2) opt = .false. call ens_freq(env,'solute.coord',1,'tmp_gas',opt) - call chdir('tmp_gas1') + call chdirdbug('tmp_gas1') call rdtherm('xtb_freq.out',ht(3),svib(3),srot(3),stra(3),gt(3)) solu%gt = gt(3) solu%ht = ht(3) @@ -1893,10 +1893,10 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) solu%srot = srot(3) solu%stra = stra(3) - call chdir(tmppath2) + call chdirdbug(tmppath2) !--- Folder setup for cluster - call chdir('tmp_solu') + call chdirdbug('tmp_solu') call solu_ens%write('solute_ensemble.xyz') !--- All cluster are of the same size @@ -1915,26 +1915,26 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) io = makedir(trim(to)) call copysub('.UHF',to) call copysub('.CHRG',to) - call chdir(to) + call chdirdbug(to) open (newunit=ich65,file='cluster.xyz') call wrxyz(ich65,clus%nat,clus%at,clus%xyz*bohr) close (ich65) - call chdir(tmppath2) + call chdirdbug(tmppath2) !--- Solvent cluster (only if cff, than the solvent shell is taken, which was fixed all the time) if (env%cff) then - call chdir('tmp_solv') + call chdirdbug('tmp_solv') write (to,'("TMPFREQ",i0)') i io = makedir(trim(to)) - call chdir(to) + call chdirdbug(to) call wrc0('cluster.coord',clus%nat,clus%at,clus%xyz) call wr_cluster_cut('cluster.coord',solu%nat,solv%nat,env%nsolv,& & 'solute_cut.coord','solvent_cut.coord') - call chdir(tmppath2) + call chdirdbug(tmppath2) end if - call chdir('tmp_solu') + call chdirdbug('tmp_solu') end do @@ -1943,20 +1943,20 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) !> Frequency calculation opt = .true. call ens_freq(env,'cluster.xyz',solu_ens%nall,'TMPFREQ',opt) - call chdir(tmppath2) + call chdirdbug(tmppath2) write (stdout,*) ' SOLVENT CLUSTER' if (env%cff) then - call chdir('tmp_solv') + call chdirdbug('tmp_solv') call ens_freq(env,'solvent_cut.coord',solu_ens%nall,'TMPFREQ',opt) - call chdir(tmppath2) + call chdirdbug(tmppath2) end if call clus%deallocate() !--- Frequencies solvent cluster (only, if not cff was used) if (.not.env%cff) then - call chdir('tmp_solv') + call chdirdbug('tmp_solv') call solv_ens%write('solvent_ensemble.xyz') do i = 1,solv_ens%nall @@ -1964,16 +1964,16 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) io = makedir(trim(to)) call copysub('.UHF',to) call copysub('.CHRG',to) - call chdir(to) + call chdirdbug(to) open (newunit=ich65,file='solv_cluster.xyz') call wrxyz(ich65,solv_ens%nat,solv_ens%at,solv_ens%xyz(:,:,i)) close (ich65) - call chdir(tmppath2) - call chdir('tmp_solv') + call chdirdbug(tmppath2) + call chdirdbug('tmp_solv') end do !> Frequency calculation call ens_freq(env,'solv_cluster.xyz',solv_ens%nall,'TMPFREQ',opt) - call chdir(tmppath2) + call chdirdbug(tmppath2) end if !---------------------------------------------------------------------------- @@ -1995,7 +1995,7 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) write (stdout,*) ' Solute cluster properties' open (newunit=ich33,file='solute_cluster.dat') - call chdir('tmp_solu') + call chdirdbug('tmp_solu') allocate (solu_ens%gt(solu_ens%nall)) allocate (solu_ens%ht(solu_ens%nall)) @@ -2008,7 +2008,7 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) do i = 1,solu_ens%nall write (to,'("TMPFREQ",i0)') i - call chdir(to) + call chdirdbug(to) call rdtherm('xtb_freq.out',ht(1),svib(1),srot(1),stra(1),gt(1)) write (stdout,'(2x,i0,2x,5f10.2)') i,ht(1),svib(1),srot(1),stra(1),gt(1) write (ich33,'(2x,i0,2x,5f10.2)') i,ht(1),svib(1),srot(1),stra(1),gt(1) @@ -2018,18 +2018,18 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) solu_ens%srot(i) = srot(1) solu_ens%stra(i) = stra(1) - call chdir(tmppath2) - call chdir('tmp_solu') + call chdirdbug(tmppath2) + call chdirdbug('tmp_solu') end do close (ich33) !--- Solvent cluster write (stdout,*) write (stdout,*) ' Solvent cluster properties' - call chdir(tmppath2) + call chdirdbug(tmppath2) open (newunit=ich81,file='solvent_cluster.dat') - call chdir('tmp_solv') + call chdirdbug('tmp_solv') allocate (solv_ens%gt(solv_ens%nall)) allocate (solv_ens%ht(solv_ens%nall)) @@ -2042,7 +2042,7 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) do i = 1,solv_ens%nall write (to,'("TMPFREQ",i0)') i - call chdir(to) + call chdirdbug(to) call rdtherm('xtb_freq.out',ht(2),svib(2),srot(2),stra(2),gt(2)) write (stdout,'(2x,i0,2x,5f10.2)') i,ht(2),svib(2),srot(2),stra(2),gt(2) write (ich81,'(2x,i0,2x,5f10.2)') i,ht(2),svib(2),srot(2),stra(2),gt(2) @@ -2051,21 +2051,21 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) solv_ens%svib(i) = svib(2) solv_ens%srot(i) = srot(2) solv_ens%stra(i) = stra(2) - call chdir(tmppath2) - call chdir('tmp_solv') + call chdirdbug(tmppath2) + call chdirdbug('tmp_solv') end do close (ich81) !--- Saving results - call chdir(tmppath2) + call chdirdbug(tmppath2) call copysub('solute.dat',resultspath) call copysub('solute_cluster.dat',resultspath) call copysub('solvent_cluster.dat',resultspath) !--- Deleting tmp directory - call chdir(tmppath) + call chdirdbug(tmppath) if (.not.env%keepModef) call rmrf(tmppath2) - call chdir(thispath) + call chdirdbug(thispath) env%gfnver = gfnver_tmp env%optlev = optlev_tmp @@ -2261,7 +2261,7 @@ subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup !--- Grow process if (grow) then env%qcg_restart = .true. - call chdir('grow') + call chdirdbug('grow') call rdnat('cluster.coord',clus%nat) allocate (clus%at(clus%nat),clus%xyz(3,clus%nat)) call rdcoord('cluster.coord',clus%nat,clus%at,clus%xyz) @@ -2284,11 +2284,11 @@ subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup write (stdout,*) write (stdout,*) write (stdout,'(''Found cluster with '',i0,'' solvents'')') env%nsolv - call chdir(thispath) + call chdirdbug(thispath) else error stop 'The found cluster is smaller than nsolv. Please restart the whole computaion by removing the grow directory' !Future implementation continue grow process - call chdir(thispath) + call chdirdbug(thispath) if (solu_ensemble) call rmrf('ensemble') if (solv_ensemble) call rmrf('solvent_ensemble') if (freq) call rmrf('frequencies') @@ -2301,7 +2301,7 @@ subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup !--- Solute Ensemble if (solu_ensemble) then - call chdir('ensemble') + call chdirdbug('ensemble') call solu_ens%open('final_ensemble.xyz') call rdensemble('final_ensemble.xyz',solu_ens%nat,solu_ens%nall,solu_ens%at,solu_ens%xyz,solu_ens%er) env%nqcgclust = solu_ens%nall @@ -2310,13 +2310,13 @@ subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup call grepval('population.dat','Ensemble free energy [Eh]:',ex,solu_ens%G) solu_ens%G = solu_ens%G*autokcal write (stdout,*) 'Solute Ensmeble Free E [kcal/mol]',solu_ens%G - call chdir(thispath) + call chdirdbug(thispath) progress = 2 end if !--- Solvent Ensemble if (solv_present) then - call chdir('solvent_ensemble') + call chdirdbug('solvent_ensemble') write (stdout,'(" Ensemble of solvent-cluster found.")') !--- Case CFF @@ -2345,7 +2345,7 @@ subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup call grepval('population.dat','Ensemble free energy [Eh]:',ex,solv_ens%G) solv_ens%G = solv_ens%G*autokcal write (stdout,*) 'solvent ensmeble free E [kcal/mol]',solv_ens%G - call chdir(thispath) + call chdirdbug(thispath) progress = 3 end if @@ -2368,7 +2368,7 @@ subroutine qcg_cleanup(env) character(len=280) :: thispath logical :: tmp call getcwd(thispath) - call chdir(env%scratchdir) + call chdirdbug(env%scratchdir) inquire (file='./solute_properties/solute',exist=tmp) if (tmp) then call rmrf('solute_properties') diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index d5c3f015..0b3b3ec3 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -99,13 +99,12 @@ subroutine xtb_opt_qcg(env,mol,constrain) character(:),allocatable :: fname character(len=512) :: jobcall - logical :: constrain, const + logical :: constrain,const real(wp) :: energy integer :: io,T,Tn - character(stdout),parameter :: pipe = ' > xtb_opt.out 2> /dev/null' + character(stdout),parameter :: pipe = ' > xtb_opt.out 2> /dev/null' logical,parameter :: debug = .false. - if (env%legacy) then !> LEGACY version with syscall @@ -154,14 +153,14 @@ subroutine xtb_opt_qcg(env,mol,constrain) call optimize_geometry(molin,molout,calc,energy,gradtmp,debug,.false.,io) - deallocate(gradtmp) - if(io == 0)then - call mol%from_coord(molout) + deallocate (gradtmp) + if (io == 0) then + call mol%from_coord(molout) else - write(stdout,*) 'FAILURE in QCG optimization!' - write(stdout,*) 'Stopping run to avoid unecessary compuations' - call creststop(status_safety) - endif + write (stdout,*) 'FAILURE in QCG optimization!' + write (stdout,*) 'Stopping run to avoid unecessary compuations' + call creststop(status_safety) + end if end block end if @@ -345,7 +344,7 @@ subroutine ensemble_dock(env,outer_ell_abc,nfrag1,frag1_file,frag2_file,n_shell& do i = 1,NTMP vz = i write (tmppath,'(a,i0)') trim(TMPdir),conv(i) - call chdir(trim(tmppath)) + call chdirdbug(trim(tmppath)) open (newunit=ich31,file='xcontrol') write (ich31,'(a,"fix")') trim(flag) write (ich31,'(3x,"atoms: 1-",i0)') n_shell !Initial number of atoms (starting solvent shell) @@ -354,7 +353,7 @@ subroutine ensemble_dock(env,outer_ell_abc,nfrag1,frag1_file,frag2_file,n_shell& write (ich31,'(3x,"ellipsoid:",1x,3(g0,",",1x),i0,"-",i0)') outer_ell_abc(conv(vz),:), & & n_shell+1,n_shell+n_solvent !Initial number of atoms (starting solvent shell) close (ich31) - call chdir(trim(thispath)) + call chdirdbug(trim(thispath)) end do k = 0 !counting the finished jobs @@ -381,7 +380,7 @@ subroutine ensemble_dock(env,outer_ell_abc,nfrag1,frag1_file,frag2_file,n_shell& !$omp end parallel !___________________________________________________________________________________ - call chdir(trim(thispath)) + call chdirdbug(trim(thispath)) end subroutine ensemble_dock @@ -436,7 +435,7 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) call getcwd(thispath) do i = 1,NTMP write (tmppath,'(a,i0)') trim(TMPdir),conv(i) - call chdir(trim(tmppath)) + call chdirdbug(trim(tmppath)) open (newunit=ich31,file='xcontrol') if (n12 .ne. 0) then flag = '$' @@ -445,7 +444,7 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) end if close (ich31) if (postopt.and.nothing_added(i)) call remove('xcontrol') - call chdir(trim(thispath)) + call chdirdbug(trim(thispath)) end do !--- Jobcall @@ -486,9 +485,9 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) do i = 1,NTMP write (tmppath,'(a,i0)') trim(TMPdir),conv(i) - call chdir(trim(tmppath)) + call chdirdbug(trim(tmppath)) call remove('xtbrestart') - call chdir(trim(thispath)) + call chdirdbug(trim(thispath)) end do !create the system call for sp (needed for gbsa model) @@ -529,10 +528,10 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) do i = 1,NTMP write (tmppath,'(a,i0)') trim(TMPdir),conv(i) - call chdir(trim(tmppath)) + call chdirdbug(trim(tmppath)) call remove('xtbrestart') !call remove('xcontrol') - call chdir(trim(thispath)) + call chdirdbug(trim(thispath)) end do if (postopt) then @@ -615,9 +614,9 @@ subroutine ens_sp(env,fname,NTMP,TMPdir) do i = 1,NTMP write (tmppath,'(a,i0)') trim(TMPdir),i - call chdir(trim(tmppath)) + call chdirdbug(trim(tmppath)) call remove('xtbrestart') - call chdir(trim(thispath)) + call chdirdbug(trim(thispath)) end do write (stdout,*) '' write (stdout,'(2x,"done.")') @@ -701,9 +700,9 @@ subroutine ens_freq(env,fname,NTMP,TMPdir,opt) do i = 1,NTMP write (tmppath,'(a,i0)') trim(TMPdir),i - call chdir(trim(tmppath)) + call chdirdbug(trim(tmppath)) call remove('xtbrestart') - call chdir(trim(thispath)) + call chdirdbug(trim(thispath)) end do write (stdout,*) '' write (stdout,'(2x,"done.")') @@ -881,3 +880,17 @@ subroutine get_interaction_E(env,solu,solv,clus,iter,E_inter) E_inter(iter) = e_cluster-e_solute-e_solvent end subroutine get_interaction_E + +!===============================================================================! +subroutine chdirdbug(path) + implicit none + character(len=*),intent(in) :: path + logical,parameter :: debug = .true. + character(len=500) :: debugpath + call chdir(path) + if (debug) then + call getcwd(debugpath) + write (*,'(a,a)') '>>>>>>> NOW IN ',trim(debugpath) + end if +end subroutine chdirdbug + From e062a6fc8ed9e4c5999270ddc4308db0ab364277 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 17 Nov 2025 23:59:31 +0100 Subject: [PATCH 088/374] replace wrc0 --- src/qcg/qcg_main.f90 | 28 ++++++++++++++-------------- src/qcg/qcg_misc.f90 | 6 +++--- src/qcg/qcg_utils.f90 | 4 ++-- 3 files changed, 19 insertions(+), 19 deletions(-) diff --git a/src/qcg/qcg_main.f90 b/src/qcg/qcg_main.f90 index fd0802ae..3ea26618 100644 --- a/src/qcg/qcg_main.f90 +++ b/src/qcg/qcg_main.f90 @@ -226,7 +226,7 @@ subroutine qcg_setup(env,solu,solv) !--- Axistrf call axistrf(solu%nat,solu%nat,solu%at,solu%xyz) - call wrc0('solute',solu%nat,solu%at,solu%xyz) + call solu%write('solute') !---- SP-Computation solute call xtb_sp_qcg(env,'solute',e_there,solu%energy) @@ -256,7 +256,7 @@ subroutine qcg_setup(env,solu,solv) if ((.not.env%nopreopt).and.(solv%nat /= 1)) then call xtb_opt_qcg(env,solv,.false.) end if - call wrc0('solvent',solv%nat,solv%at,solv%xyz) + call solv%write('solvent') !---- SP-Computation solvent call xtb_sp_qcg(env,'solvent',e_there,solv%energy) @@ -270,8 +270,8 @@ subroutine qcg_setup(env,solu,solv) call chdirdbug(thispath) !---- Overwriting solute and solvent in original folder - call wrc0('solute',solu%nat,solu%at,solu%xyz) - call wrc0('solvent',solv%nat,solv%at,solv%xyz) + call solu%write('solute') + call solv%write('solvent') num_O = 0 num_H = 0 @@ -524,8 +524,8 @@ subroutine qcg_grow(env,solu,solv,clus,tim) call copysub(env%fixfile,'tmp_grow') end if call chdirdbug('tmp_grow') - call wrc0('solute',solu%nat,solu%at,solu%xyz) - call wrc0('solvent',solv%nat,solv%at,solv%xyz) + call solu%write('solute') + call solv%write('solvent') call env%wrtCHRG('') !Write .CHRG file for docking call ellipsout('solute_cavity.coord',clus%nat,clus%at,clus%xyz,solu%ell_abc) @@ -607,7 +607,7 @@ subroutine qcg_grow(env,solu,solv,clus,tim) call rdcoord('best.xyz',clus%nat,clus%at,clus%xyz,clus%energy) call remove('cluster.coord') - call wrc0('cluster.coord',clus%nat,clus%at,clus%xyz) + call clus%write('cluster.coord') call both_ellipsout('twopot_2.coord',clus%nat,clus%at,clus%xyz,& & clus%ell_abc,solu%ell_abc) @@ -716,7 +716,7 @@ subroutine qcg_grow(env,solu,solv,clus,tim) write (stdout,'(2x,''Final gfn2 optimization'')') call opt_cluster(env,solu,clus,'cluster.coord',.false.) call rdcoord('xtbopt.coord',clus%nat,clus%at,clus%xyz) - call wrc0('cluster.coord',clus%nat,clus%at,clus%xyz) + call clus%write('cluster.coord') call grepval('xtb_sp.out','| TOTAL ENERGY',e_there,clus%energy) if (.not.e_there) then write (stdout,'(1x,a)') 'Total Energy of cluster not found.' @@ -872,7 +872,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) call chdirdbug('tmp_solv_MTD') end if call getcwd(tmppath2) - call wrc0('crest_input',clus%nat,clus%at,clus%xyz) + call clus%write('crest_input') if (env%solv_md) then call wr_cluster_cut('crest_input',solu%nat,solv%nat,env%nsolv,& @@ -1141,7 +1141,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) end if call dum%deallocate call chdirdbug(tmppath2) - call wrc0('coord',clus%nat,clus%at,clus%xyz) + call clus%write('coord') call inputcoords(env,'coord') !Necessary !--- Optimization @@ -1523,7 +1523,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) io = makedir(trim(to)) call copysub('solvent',to) call chdirdbug(to) - call wrc0('cluster.coord',clus%nat,clus%at,clus%xyz) + call clus%write('cluster.coord') call wr_cluster_cut('cluster.coord',solu%nat,solv%nat,env%nsolv,'solute_cut.coord','solvent_shell.coord') call xtb_sp_qcg(env,'solvent_shell.coord',ex,e_empty(i)) call grepval('xtb.out','| TOTAL ENERGY',ex,e_empty(i)) @@ -1590,7 +1590,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) call remove('xcontrol') call rdcoord('best.xyz',clus%nat,clus%at,clus%xyz,e_cur(iter,i)) - call wrc0('solvent_cluster.coord',clus%nat,clus%at,clus%xyz) + call clus%write('solvent_cluster.coord') !--- Check if converged call fill_take(env,solv%nat,clus%nat,inner_ell_abc(i,1:3),ipos) @@ -1881,7 +1881,7 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) !--- Frequencies solute molecule write (stdout,*) ' SOLUTE MOLECULE' call chdirdbug('tmp_gas1') - call wrc0('solute.coord',solu%nat,solu%at,solu%xyz) + call solu%write('solute.coord') call chdirdbug(tmppath2) opt = .false. call ens_freq(env,'solute.coord',1,'tmp_gas',opt) @@ -1928,7 +1928,7 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) write (to,'("TMPFREQ",i0)') i io = makedir(trim(to)) call chdirdbug(to) - call wrc0('cluster.coord',clus%nat,clus%at,clus%xyz) + call clus%write('cluster.coord') call wr_cluster_cut('cluster.coord',solu%nat,solv%nat,env%nsolv,& & 'solute_cut.coord','solvent_cut.coord') diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index 0b3b3ec3..34665be2 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -110,7 +110,7 @@ subroutine xtb_opt_qcg(env,mol,constrain) !--- Write coordinated fname = 'coord' - call wrc0(fname,mol%nat,mol%at,mol%xyz) !write coord for xtbopt routine + call mol%write(fname) !---- setting threads call new_ompautoset(env,'auto',1,T,Tn) @@ -118,7 +118,7 @@ subroutine xtb_opt_qcg(env,mol,constrain) !---- jobcall & Handling constraints if (constrain.AND.env%cts%used) then call write_constraint(env,fname,'xcontrol') - call wrc0('coord.ref',mol%nat,mol%at,mol%xyz) !write coord for xtbopt routine + call mol%write('coord.ref') write (jobcall,'(a,1x,a,1x,a,'' --opt --input xcontrol '',a,1x,a)') & & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) else @@ -864,7 +864,7 @@ subroutine get_interaction_E(env,solu,solv,clus,iter,E_inter) call remove('cluster.coord') !--- Prepare input coordinate files - call wrc0('cluster.coord',clus%nat,clus%at,clus%xyz) + call clus%write('cluster.coord') call wr_cluster_cut('cluster.coord',solu%nat,solv%nat,iter,'solute_cut.coord','solvent_cut.coord') !--- Perform single point calculations and recieve energies diff --git a/src/qcg/qcg_utils.f90 b/src/qcg/qcg_utils.f90 index 63bc65d4..72a6470b 100644 --- a/src/qcg/qcg_utils.f90 +++ b/src/qcg/qcg_utils.f90 @@ -305,8 +305,8 @@ subroutine get_ellipsoid(env,solu,solv,clus,pr1) call axistrf(clus%nat,solu%nat,clus%at,clus%xyz) !--- Overwrite solute and solvent coord in original file with transformed and optimized ones - call wrc0('solute',solu%nat,solu%at,solu%xyz) - call wrc0('solvent',solv%nat,solv%at,solv%xyz) + call solu%write('solute') + call solv%write('solvent') !--- Getting axis write (stdout,*) 'Solute:' From 81dd42b266af7c8f514ac997966b64fd51e11ca5 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 18 Nov 2025 00:56:34 +0100 Subject: [PATCH 089/374] cont'd QCG refactor --- src/qcg/qcg_main.f90 | 3 +- src/qcg/qcg_misc.f90 | 88 +++++++++++++++++++++----------------------- 2 files changed, 43 insertions(+), 48 deletions(-) diff --git a/src/qcg/qcg_main.f90 b/src/qcg/qcg_main.f90 index 3ea26618..25d9255d 100644 --- a/src/qcg/qcg_main.f90 +++ b/src/qcg/qcg_main.f90 @@ -902,7 +902,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) end if gfnver_tmp = env%gfnver - write (stdout,*) ' Method for ensemble search:',env%ensemble_opt + write (stdout,*) 'Method for ensemble search: ',env%ensemble_opt ! if (env%ens_const) write(stdout,*) ' Solute fixed during ensemble generation' env%gfnver = env%ensemble_opt !Setting method for ensemble search @@ -1395,6 +1395,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) write (stdout,'(2x,''Population of full ensemble in file '')') write (stdout,'(2x,''Population in file '')') + !>--- restore settings env%gfnver = gfnver_tmp env%optlev = optlev_tmp if (env%ensemble_opt .eq. '--gff') then diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index 34665be2..5d4fd4ad 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -176,15 +176,14 @@ subroutine xtb_dock(env,fnameA,fnameB,solu,clus) use iomod use crest_data use qcg_coord_type - implicit none - type(systemdata) :: env + type(systemdata) :: env type(coord_qcg),intent(in) :: solu,clus character(len=*),intent(in) :: fnameA,fnameB - character(len=80) :: pipe - character(len=512) :: jobcall - integer :: i,ich,T,Tn + character(len=80) :: pipe + character(len=512) :: jobcall + integer :: i,ich,T,Tn call remove('xtb_dock.out') call remove('xcontrol') @@ -239,20 +238,15 @@ subroutine opt_cluster(env,solu,clus,fname,without_pot) implicit none - type(systemdata) :: env - type(coord_qcg),intent(in) :: solu,clus - character(len=*),intent(in) :: fname + type(systemdata) :: env + type(coord_qcg),intent(in) :: solu,clus + character(len=*),intent(in) :: fname logical,optional,intent(in) :: without_pot - character(len=80) :: pipe - character(len=:),allocatable :: jobcall + character(len=*),parameter :: pipe = ' 2>/dev/null' + character(len=:),allocatable :: jobcall integer :: T,Tn - if (env%niceprint) then - call printprogbar(0.0_wp) - end if - call remove('xtb.out') - pipe = ' 2>/dev/null' !---- writing wall pot in xcontrol if (.not.without_pot) then @@ -281,8 +275,8 @@ subroutine opt_cluster(env,solu,clus,fname,without_pot) jobcall = trim(env%ProgName)//' xtbopt.coord --sp '//trim(env%gfnver) jobcall = trim(jobcall)//' '//trim(env%solv) jobcall = trim(jobcall)//' > xtb_sp.out 2>/dev/null' + call command(trim(jobcall)) end if - call command(trim(jobcall)) ! cleanup call remove('wbo') @@ -324,7 +318,7 @@ subroutine ensemble_dock(env,outer_ell_abc,nfrag1,frag1_file,frag2_file,n_shell& character(len=64) :: frag2 real(wp) :: percent character(len=2) :: flag - integer :: ich31 + integer :: funit ! some options pipe = '2>/dev/null' @@ -345,14 +339,14 @@ subroutine ensemble_dock(env,outer_ell_abc,nfrag1,frag1_file,frag2_file,n_shell& vz = i write (tmppath,'(a,i0)') trim(TMPdir),conv(i) call chdirdbug(trim(tmppath)) - open (newunit=ich31,file='xcontrol') - write (ich31,'(a,"fix")') trim(flag) - write (ich31,'(3x,"atoms: 1-",i0)') n_shell !Initial number of atoms (starting solvent shell) - write (ich31,'(a,"wall")') trim(flag) - write (31,'(3x,"potential=polynomial")') - write (ich31,'(3x,"ellipsoid:",1x,3(g0,",",1x),i0,"-",i0)') outer_ell_abc(conv(vz),:), & + open (newunit=funit,file='xcontrol') + write (funit,'(a,"fix")') trim(flag) + write (funit,'(3x,"atoms: 1-",i0)') n_shell !Initial number of atoms (starting solvent shell) + write (funit,'(a,"wall")') trim(flag) + write (funit,'(3x,"potential=polynomial")') + write (funit,'(3x,"ellipsoid:",1x,3(g0,",",1x),i0,"-",i0)') outer_ell_abc(conv(vz),:), & & n_shell+1,n_shell+n_solvent !Initial number of atoms (starting solvent shell) - close (ich31) + close (funit) call chdirdbug(trim(thispath)) end do @@ -405,7 +399,7 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) logical,intent(in) :: nothing_added(env%nqcgclust) integer :: i,k,n12 integer :: vz,T,Tn - integer :: ich31 + integer :: funit character(len=20) :: pipe character(len=512) :: thispath,tmppath character(len=1024) :: jobcall @@ -436,13 +430,13 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) do i = 1,NTMP write (tmppath,'(a,i0)') trim(TMPdir),conv(i) call chdirdbug(trim(tmppath)) - open (newunit=ich31,file='xcontrol') + open (newunit=funit,file='xcontrol') if (n12 .ne. 0) then flag = '$' - write (ich31,'(a,"fix")') trim(flag) - write (ich31,'(3x,"atoms: 1-",i0)') n12 !Initial number of atoms (starting solvent shell) + write (funit,'(a,"fix")') trim(flag) + write (funit,'(3x,"atoms: 1-",i0)') n12 !Initial number of atoms (starting solvent shell) end if - close (ich31) + close (funit) if (postopt.and.nothing_added(i)) call remove('xcontrol') call chdirdbug(trim(thispath)) end do @@ -778,24 +772,24 @@ subroutine write_wall(env,n1,rabc1,rabc12,fname) real(wp),intent(in) :: rabc1(3),rabc12(3) character(len=8) :: flag character(len=*) :: fname + integer :: funit - open (unit=31,file=fname) + open (newunit=funit,file=fname) flag = '$' - write (31,'(a,"wall")') trim(flag) - write (31,'(3x,"potential=polynomial")') - write (31,'(3x,"ellipsoid:",1x,3(g0,",",1x),"all")') rabc12 - write (31,'(3x,"ellipsoid:",1x,3(g0,",",1x),"1-",i0)') rabc1,n1 + write (funit,'(a,"wall")') trim(flag) + write (funit,'(3x,"potential=polynomial")') + write (funit,'(3x,"ellipsoid:",1x,3(g0,",",1x),"all")') rabc12 + write (funit,'(3x,"ellipsoid:",1x,3(g0,",",1x),"1-",i0)') rabc1,n1 if (env%constrain_solu) then - write (31,'("$fix")') - write (31,'(3x,"atoms: 1-",i0)') n1 + write (funit,'("$fix")') + write (funit,'(3x,"atoms: 1-",i0)') n1 end if - call write_cts(31,env%cts) - call write_cts_biasext(31,env%cts) + call write_cts(funit,env%cts) + call write_cts_biasext(funit,env%cts) if (env%cts%used) then !Only, if user set constrians is an $end written - write (31,'(a)') '$end' + write (funit,'(a)') '$end' end if - - close (31) + close (funit) end subroutine write_wall @@ -831,16 +825,16 @@ subroutine write_constraint(env,coord_name,fname) type(systemdata) :: env character(len=*),intent(in) :: fname,coord_name + integer :: funit call copysub(coord_name,'coord.ref') - open (unit=31,file=fname) - call write_cts(31,env%cts) - call write_cts_biasext(31,env%cts) + open (newunit=funit,file=fname) + call write_cts(funit,env%cts) + call write_cts_biasext(funit,env%cts) if (env%cts%used) then !Only, if user set constrians is an $end written - write (31,'(a)') '$end' + write (funit,'(a)') '$end' end if - - close (31) + close (funit) end subroutine write_constraint From 09830464ca626f9e6f6722a415560e9a7a93f5fc Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 20 Nov 2025 21:23:33 +0100 Subject: [PATCH 090/374] Work on internally adapting constraints from 'cts' storage (legacy <-> calculator) --- src/algos/search_conformers.f90 | 2 + src/classes.f90 | 61 +++++-- src/legacy_algos/confscript2_misc.f90 | 2 +- src/parsing/constraining.f90 | 18 +- src/qcg/qcg_main.f90 | 214 ++---------------------- src/qcg/qcg_misc.f90 | 228 +++++++++++++++++++++++++- 6 files changed, 297 insertions(+), 228 deletions(-) diff --git a/src/algos/search_conformers.f90 b/src/algos/search_conformers.f90 index 07ce7519..46842502 100644 --- a/src/algos/search_conformers.f90 +++ b/src/algos/search_conformers.f90 @@ -80,6 +80,8 @@ subroutine crest_search_imtdgc(env,tim) return endif + !call env%calc%info(stdout) + !>--- sets the MD length according to a flexibility measure call md_length_setup(env) !>--- create the MD calculator saved to env diff --git a/src/classes.f90 b/src/classes.f90 index 67c23062..93bcd63e 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -34,7 +34,7 @@ module crest_data public :: systemdata public :: timer !> RE-EXPORT from crest_type_timer public :: protobj - public :: constra + public :: legacy_constraints public :: optlevflag,optlevnum,optlevmap_alt public :: optlev_to_multilev @@ -143,7 +143,7 @@ module crest_data !========================================================================================! !========================================================================================! - type :: constra + type :: legacy_constraints !**************************************************** !* separate settings for LEGACY constraint handling !**************************************************** @@ -173,9 +173,10 @@ module crest_data logical :: usermsdpot = .false. logical :: gesc_heavy = .false. contains - procedure :: allocate => allocate_constraints - procedure :: deallocate => deallocate_constraints - end type constra + procedure :: allocate => allocate_legacy_constraints + procedure :: deallocate => deallocate_legacy_constraints + procedure :: info => legacy_constraints_info + end type legacy_constraints !========================================================================================! @@ -438,7 +439,7 @@ module crest_data type(protobj) :: protb !>--- saved constraints - type(constra) :: cts + type(legacy_constraints) :: cts !>--- NCI mode data real(wp) :: potscal = 1.0_wp @@ -663,7 +664,6 @@ subroutine allocate_metadyn(self,n) end if return end subroutine allocate_metadyn -!========================================================================================! subroutine deallocate_metadyn(self) implicit none class(systemdata) :: self @@ -672,23 +672,56 @@ subroutine deallocate_metadyn(self) if (allocated(self%metadlist)) deallocate (self%metadlist) end subroutine deallocate_metadyn !========================================================================================! - subroutine allocate_constraints(self,n) + subroutine allocate_legacy_constraints(self,n) implicit none - class(constra) :: self + class(legacy_constraints) :: self integer,intent(in) :: n self%ndim = n allocate (self%sett(n)) allocate (self%buff(n)) self%sett = '' self%buff = '' - end subroutine allocate_constraints -!========================================================================================! - subroutine deallocate_constraints(self) + end subroutine allocate_legacy_constraints + + subroutine deallocate_legacy_constraints(self) implicit none - class(constra) :: self + class(legacy_constraints) :: self if (allocated(self%sett)) deallocate (self%sett) if (allocated(self%buff)) deallocate (self%buff) - end subroutine deallocate_constraints + end subroutine deallocate_legacy_constraints + + subroutine legacy_constraints_info(self) + implicit none + class(legacy_constraints) :: self + integer :: i + write (*,*) "legacy constraints set?",self%used + if (self%used) then + do i = 1,self%ndim + if (trim(self%sett(i)) .ne. '') then + write (*,'(a)') trim(self%sett(i)) + end if + end do + end if + + write (*,*) 'legacy constraints NCI?',self%NCI + if (self%NCI.and.allocated(self%pots)) then + do i = 1,10 + if (trim(self%pots(i)) .ne. '') then + write (*,'(a)') trim(self%pots(i)) + end if + end do + end if + + write (*,*) 'legacy constraints CBONDS?',allocated(self%cbonds) + if (allocated(self%cbonds)) then + do i = 1,min(10,self%n_cbonds) + if (trim(self%cbonds(i)) .ne. '') then + write (*,'(a)') trim(self%cbonds(i)) + end if + end do + if(self%n_cbonds>10) write(*,*) '... and some more' + end if + end subroutine legacy_constraints_info !========================================================================================! !========================================================================================! diff --git a/src/legacy_algos/confscript2_misc.f90 b/src/legacy_algos/confscript2_misc.f90 index 11be311e..b954896b 100644 --- a/src/legacy_algos/confscript2_misc.f90 +++ b/src/legacy_algos/confscript2_misc.f90 @@ -685,7 +685,7 @@ subroutine setMDrun2(fname,hmass,mdtime,mdtemp,mdstep,shake,mddumpxyz, & use crest_data use utilities implicit none - type(constra) :: cts + type(legacy_constraints) :: cts character(len=*) :: fname real(wp) :: hmass real(wp) :: mdtime diff --git a/src/parsing/constraining.f90 b/src/parsing/constraining.f90 index 43c62ce7..278fb835 100644 --- a/src/parsing/constraining.f90 +++ b/src/parsing/constraining.f90 @@ -326,7 +326,7 @@ end subroutine rdcoord_reduced subroutine sort_constraints(cts) use crest_data implicit none - type(constra) :: cts + type(legacy_constraints) :: cts character(len=128) :: atmp,btmp integer :: i,j @@ -376,7 +376,7 @@ end subroutine sort_constraints subroutine read_constrainbuffer(fname,cts) use crest_data implicit none - type(constra) :: cts + type(legacy_constraints) :: cts character(len=*) :: fname character(len=128) :: atmp @@ -418,7 +418,7 @@ end subroutine read_constrainbuffer subroutine write_cts(ich,cts) use crest_data implicit none - type(constra) :: cts + type(legacy_constraints) :: cts integer :: ich integer :: i !--- not really a "constraint", but convenient for the implementation: @@ -455,7 +455,7 @@ end subroutine write_cts subroutine write_cts_NCI(ich,cts) use crest_data implicit none - type(constra) :: cts + type(legacy_constraints) :: cts integer :: ich integer :: i !---- do it only if constaints are given @@ -476,7 +476,7 @@ end subroutine write_cts_NCI subroutine write_cts_NCI_pr(ich,cts) use crest_data implicit none - type(constra) :: cts + type(legacy_constraints) :: cts integer :: ich integer :: i !---- do it only if constaints are given @@ -497,7 +497,7 @@ subroutine write_cts_biasext(ich,cts) use crest_data use iomod implicit none - type(constra) :: cts + type(legacy_constraints) :: cts integer :: ich !---- do it only if constaints are given if (cts%usermsdpot) then @@ -758,7 +758,7 @@ end subroutine rdrcontrol subroutine write_cts_rcontrol(ich,cts) use crest_data implicit none - type(constra) :: cts + type(legacy_constraints) :: cts integer :: ich,i if (cts%ureactor) then do i = 1,cts%nrctrl @@ -806,7 +806,7 @@ end subroutine rd_cbonds subroutine write_cts_CBONDS(ich,cts) use crest_data implicit none - type(constra) :: cts + type(legacy_constraints) :: cts integer :: ich integer :: i !---- do it only if constaints are given @@ -826,7 +826,7 @@ end subroutine write_cts_CBONDS subroutine write_cts_DISP(ich,cts) use crest_data implicit none - type(constra) :: cts + type(legacy_constraints) :: cts integer :: ich character(len=40) :: dum !---- apply dispersion scaling factor (> xtb 6.4.0) diff --git a/src/qcg/qcg_main.f90 b/src/qcg/qcg_main.f90 index 25d9255d..c3586860 100644 --- a/src/qcg/qcg_main.f90 +++ b/src/qcg/qcg_main.f90 @@ -821,6 +821,8 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) logical :: not_param = .false. type(timer) :: tim_dum !Dummy timer to avoid double counting + logical,parameter :: debug = .true. + if (.not.env%solv_md) then call tim%start(6,'QCG Solute-Ensemble') else @@ -909,8 +911,12 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) !---------------------------------------------------------------- ! Case selection of normal Crest, MD or MTD !---------------------------------------------------------------- + if(debug)then + write(*,*) 'Entering sampling part next. We have these constraints:' + call env%cts%info() + endif - select case (env%ensemble_method) + ENSEMBLEGEN : select case (env%ensemble_method) case (-1:0) !qcgmtd/Crest runtype !Defaults @@ -947,209 +953,9 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) call copy('crest_rotamers.xyz','crest_rotamers_0.xyz') case (1:2) ! Single MD or MTD + call xtb_md_ensemble_qcg(env,solu,solv,clus,resultspath) - !---- Setting threads - call new_ompautoset(env,'auto',1,T,Tn) - - !--- Setting new defaults for MD/MTD in qcg - if (env%mdtemp .lt. 0.0d0) then - newtemp = 400.00d0 - else if (.not.env%user_temp) then - newtemp = 298.0 - else - newtemp = env%mdtemp - end if - - if (.not.env%user_mdtime) then - newmdtime = 100.0 !100.0 - else - newmdtime = env%mdtime - end if - - if (.not.env%user_dumxyz) then - env%mddumpxyz = 1000 - end if - - if (.not.env%user_mdstep) then - if (env%ensemble_opt .ne. '--gff') then - newmdstep = 4.0d0 - else - newmdstep = 1.5d0 - end if - else - newmdstep = env%mdstep - end if - - if (env%ensemble_opt .ne. '--gff') then - newhmass = 4.0 - else - newhmass = 5.0 - end if - - if (.not.allocated(env%metadfac)) then - allocate (env%metadfac(1)) - allocate (env%metadexp(1)) - allocate (env%metadlist(1)) - end if - newmetadfac = 0.02_wp - newmetadexp = 0.1_wp - newmetadlist = 10.0_wp - - fname = 'coord' - pipe = ' > xtb.out 2>/dev/null' - - !--- Writing constraining file xcontrol - !--- Providing xcontrol overwrites constraints in coord file - - open (newunit=ich,file='xcontrol') - if (env%cts%NCI) then - do i = 1,10 - if (trim(env%cts%pots(i)) .ne. '') then - write (ich,'(a)') trim(env%cts%pots(i)) - end if - end do - end if - - if (.not.env%solv_md) then - write (ich,'(a)') '$constrain' - write (ich,'(2x,a,i0)') 'atoms: 1-',solu%nat - write (ich,'(2x,a)') 'force constant=0.5' - write (ich,'(2x,a,a)') 'reference=ref.coord' - end if - - write (ich,'(a)') '$md' - write (ich,'(2x,a,f10.2)') 'hmass=',newhmass - write (ich,'(2x,a,f10.2)') 'time=',newmdtime - write (ich,'(2x,a,f10.2)') 'temp=',newtemp - write (ich,'(2x,a,f10.2)') 'step=',newmdstep - write (ich,'(2x,a,i0)') 'shake=',env%shake - write (ich,'(2x,a,i0)') 'dump=',env%mddumpxyz - write (ich,'(2x,a)') 'dumpxyz=500.0' - - if (env%ensemble_method .EQ. 2) then - write (ich,'(a)') '$metadyn' - write (ich,'(2x,a,i0,a,i0)') 'atoms: ',solu%nat+1,'-',clus%nat - write (ich,'(2x,a,f10.2)') 'save=',newmetadlist - write (ich,'(2x,a,f10.2)') 'kpush=',newmetadfac - write (ich,'(2x,a,f10.2)') 'alp=',newmetadexp - end if - - if (env%cts%cbonds_md) call write_cts_CBONDS(ich,env%cts) - - close (ich) - -!--- Writing jobcall - write (jobcall,'(a,1x,a,1x,a,'' --md --input xcontrol '',a,1x,a,a)') & - & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),pipe -!--- slightly different jobcall for QMDFF usage - if (env%useqmdff) then - write (jobcall,'(a,1x,a,1x,a,'' --md --input xcontrol --qmdff'',a,1x,a,a)') & - & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),pipe - end if - -!--- MD - if (env%ensemble_method .EQ. 1) then - call normalMD(fname,env,1,newtemp,newmdtime) - write (stdout,*) 'Starting MD with the settings:' - write (stdout,'('' MD time /ps :'',f8.1)') newmdtime - write (stdout,'('' MD Temperature /K :'',f8.1)') newtemp - write (stdout,'('' dt /fs :'',f8.1)') newmdstep - write (tmppath,'(a,i0)') 'NORMMD1' - - r = makedir(tmppath) - call copysub('xcontrol',tmppath) - call chdirdbug(tmppath) - call copy('coord','ref.coord') - call chdirdbug(tmppath2) - - call command('cd '//trim(tmppath)//' && '//trim(jobcall),io) - - inquire (file=trim(tmppath)//'/'//'xtb.trj',exist=ex) - if (.not.ex.or.io .ne. 0) then - write (stdout,'(a,i0,a)') '*Warning: MD seemingly failed (no xtb.trj)*' - else - write (stdout,*) '*MD finished*' - end if - - if (env%trackorigin) then - call set_trj_origins('NORMMD','md') - end if - call chdirdbug('NORMMD1') - end if - -!--- MTD - - if (env%ensemble_method .EQ. 2) then - call MetaMD(env,1,newmdtime,env%metadfac(1),env%metadexp(1), & - & env%metadlist(1)) - write (stdout,'(a,i4,a)') 'Starting Meta-MD with the settings:' - write (stdout,'('' MTD time /ps :'',f8.1)') newmdtime - write (stdout,'('' dt /fs :'',f8.1)') newmdstep - write (stdout,'('' MTD Temperature /K :'',f8.1)') newtemp - write (stdout,'('' dumpstep(trj) /fs :'',i8)') env%mddumpxyz - write (stdout,'('' Vbias factor k /Eh :'',f8.4)') newmetadfac - write (stdout,'('' Vbias exp α /bohr⁻²:'',f8.2)') newmetadexp - - write (tmppath,'(a,i0)') 'METADYN1' - r = makedir(tmppath) - call copysub('xcontrol',tmppath) - call chdirdbug(tmppath) - call copy('coord','ref.coord') - - call chdirdbug(tmppath2) - - call command('cd '//trim(tmppath)//' && '//trim(jobcall),io) - - inquire (file=trim(tmppath)//'/'//'xtb.trj',exist=ex) - if (.not.ex.or.io .ne. 0) then - write (stdout,'(a,i0,a)') '*Warning: Meta-MTD seemingly failed (no xtb.trj)*' - else - write (stdout,*) '*MTD finished*' - end if - - if (env%trackorigin) then - call set_trj_origins('METADYN','mtd') - end if - - call chdirdbug('METADYN1') - - end if - - call rename('xtb.trj','crest_rotamers_0.xyz') - call copysub('crest_rotamers_0.xyz',tmppath2) - call dum%open('crest_rotamers_0.xyz') - -!--- M(T)D stability check - call minigrep('xtb.out','M(T)D is unstable, emergency exit',mdfail) - if (dum%nall .eq. 1) then - call copysub('xtb.out',resultspath) - write (stdout,*) 'ERROR : M(T)D results only in one structure' - if (mdfail) then - write (stdout,*) ' It was unstable' - else - write (stdout,*) ' The M(T)D time step might be too large or the M(T)D time too short.' - end if - call copysub('xtb.out',resultspath) - error stop ' Please check the xtb.out file in the ensemble folder' - end if - if (mdfail) then - write (stdout,*) - write (stdout,*) ' WARNING: The M(T)D was unstable.' - write (stdout,*) ' Please check the xtb.out file in the ensemble folder.' - write (stdout,*) - call copysub('xtb.out',resultspath) - end if - call dum%deallocate - call chdirdbug(tmppath2) - call clus%write('coord') - call inputcoords(env,'coord') !Necessary - -!--- Optimization - call print_qcg_opt - !if (env%gfnver .eq. '--gfn2') - call multilevel_opt(env,99) - - end select + end select ENSEMBLEGEN env%QCG = .true. @@ -1171,6 +977,8 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) deallocate (env%cts%pots) call multilevel_opt(env,99) + stop + !Clustering to exclude similar structures if requested with -cluster if (env%properties == 70) then write (stdout,'(3x,''Clustering the remaining structures'')') diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index 5d4fd4ad..e54e5bef 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -166,6 +166,232 @@ subroutine xtb_opt_qcg(env,mol,constrain) end if end subroutine xtb_opt_qcg +subroutine xtb_md_ensemble_qcg(env,solu,solv,clus,resultspath) + use crest_parameters + use crest_data + use qcg_coord_type + use strucrd + use iomod + use qcg_printouts + implicit none + !> IN/OUTPUTS + type(systemdata),intent(inout) :: env + type(coord_qcg),intent(inout) :: solu + type(coord_qcg),intent(inout) :: solv + type(coord_qcg),intent(inout) :: clus + character(len=*),intent(in) :: resultspath + !> LOCAL + integer :: T,Tn,i,j,k,l,ich,r,io + real(wp) :: newtemp,newmdtime,newmdstep,newhmass + real(wp) :: newmetadfac,newmetadexp,newmetadlist + character(len=:),allocatable :: fname + character(len=512) :: tmppath,tmppath2 + character(len=1024) :: jobcall + logical :: ex,mdfail + type(ensemble) :: dum + character(len=*),parameter :: pipe = ' > xtb.out 2>/dev/null' + !---- Setting threads + call new_ompautoset(env,'auto',1,T,Tn) + + !--- Setting new defaults for MD/MTD in qcg + if (env%mdtemp .lt. 0.0d0) then + newtemp = 400.00d0 + else if (.not.env%user_temp) then + newtemp = 298.0 + else + newtemp = env%mdtemp + end if + + if (.not.env%user_mdtime) then + newmdtime = 100.0 !100.0 + else + newmdtime = env%mdtime + end if + + if (.not.env%user_dumxyz) then + env%mddumpxyz = 1000 + end if + + if (.not.env%user_mdstep) then + if (env%ensemble_opt .ne. '--gff') then + newmdstep = 4.0d0 + else + newmdstep = 1.5d0 + end if + else + newmdstep = env%mdstep + end if + + if (env%ensemble_opt .ne. '--gff') then + newhmass = 4.0 + else + newhmass = 5.0 + end if + + if (.not.allocated(env%metadfac)) then + allocate (env%metadfac(1)) + allocate (env%metadexp(1)) + allocate (env%metadlist(1)) + end if + newmetadfac = 0.02_wp + newmetadexp = 0.1_wp + newmetadlist = 10.0_wp + + fname = 'coord' + + !--- Writing constraining file xcontrol + !--- Providing xcontrol overwrites constraints in coord file + + open (newunit=ich,file='xcontrol') + if (env%cts%NCI) then + do i = 1,10 + if (trim(env%cts%pots(i)) .ne. '') then + write (ich,'(a)') trim(env%cts%pots(i)) + end if + end do + end if + + if (.not.env%solv_md) then + write (ich,'(a)') '$constrain' + write (ich,'(2x,a,i0)') 'atoms: 1-',solu%nat + write (ich,'(2x,a)') 'force constant=0.5' + write (ich,'(2x,a,a)') 'reference=ref.coord' + end if + + write (ich,'(a)') '$md' + write (ich,'(2x,a,f10.2)') 'hmass=',newhmass + write (ich,'(2x,a,f10.2)') 'time=',newmdtime + write (ich,'(2x,a,f10.2)') 'temp=',newtemp + write (ich,'(2x,a,f10.2)') 'step=',newmdstep + write (ich,'(2x,a,i0)') 'shake=',env%shake + write (ich,'(2x,a,i0)') 'dump=',env%mddumpxyz + write (ich,'(2x,a)') 'dumpxyz=500.0' + + if (env%ensemble_method .EQ. 2) then + write (ich,'(a)') '$metadyn' + write (ich,'(2x,a,i0,a,i0)') 'atoms: ',solu%nat+1,'-',clus%nat + write (ich,'(2x,a,f10.2)') 'save=',newmetadlist + write (ich,'(2x,a,f10.2)') 'kpush=',newmetadfac + write (ich,'(2x,a,f10.2)') 'alp=',newmetadexp + end if + + if (env%cts%cbonds_md) call write_cts_CBONDS(ich,env%cts) + + close (ich) + +!--- Writing jobcall + write (jobcall,'(a,1x,a,1x,a,'' --md --input xcontrol '',a,1x,a,a)') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),pipe +!--- slightly different jobcall for QMDFF usage + if (env%useqmdff) then + write (jobcall,'(a,1x,a,1x,a,'' --md --input xcontrol --qmdff'',a,1x,a,a)') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),pipe + end if + +!--- MD + if (env%ensemble_method .EQ. 1) then + call normalMD(fname,env,1,newtemp,newmdtime) + write (stdout,*) 'Starting MD with the settings:' + write (stdout,'('' MD time /ps :'',f8.1)') newmdtime + write (stdout,'('' MD Temperature /K :'',f8.1)') newtemp + write (stdout,'('' dt /fs :'',f8.1)') newmdstep + write (tmppath,'(a,i0)') 'NORMMD1' + + r = makedir(tmppath) + call copysub('xcontrol',tmppath) + call chdirdbug(tmppath) + call copy('coord','ref.coord') + call chdirdbug(tmppath2) + + call command('cd '//trim(tmppath)//' && '//trim(jobcall),io) + + inquire (file=trim(tmppath)//'/'//'xtb.trj',exist=ex) + if (.not.ex.or.io .ne. 0) then + write (stdout,'(a,i0,a)') '*Warning: MD seemingly failed (no xtb.trj)*' + else + write (stdout,*) '*MD finished*' + end if + + if (env%trackorigin) then + call set_trj_origins('NORMMD','md') + end if + call chdirdbug('NORMMD1') + end if + +!--- MTD + + if (env%ensemble_method .EQ. 2) then + call MetaMD(env,1,newmdtime,env%metadfac(1),env%metadexp(1), & + & env%metadlist(1)) + write (stdout,'(a,i4,a)') 'Starting Meta-MD with the settings:' + write (stdout,'('' MTD time /ps :'',f8.1)') newmdtime + write (stdout,'('' dt /fs :'',f8.1)') newmdstep + write (stdout,'('' MTD Temperature /K :'',f8.1)') newtemp + write (stdout,'('' dumpstep(trj) /fs :'',i8)') env%mddumpxyz + write (stdout,'('' Vbias factor k /Eh :'',f8.4)') newmetadfac + write (stdout,'('' Vbias exp α /bohr⁻²:'',f8.2)') newmetadexp + + write (tmppath,'(a,i0)') 'METADYN1' + r = makedir(tmppath) + call copysub('xcontrol',tmppath) + call chdirdbug(tmppath) + call copy('coord','ref.coord') + + call chdirdbug(tmppath2) + + call command('cd '//trim(tmppath)//' && '//trim(jobcall),io) + + inquire (file=trim(tmppath)//'/'//'xtb.trj',exist=ex) + if (.not.ex.or.io .ne. 0) then + write (stdout,'(a,i0,a)') '*Warning: Meta-MTD seemingly failed (no xtb.trj)*' + else + write (stdout,*) '*MTD finished*' + end if + + if (env%trackorigin) then + call set_trj_origins('METADYN','mtd') + end if + + call chdirdbug('METADYN1') + + end if + + call rename('xtb.trj','crest_rotamers_0.xyz') + call copysub('crest_rotamers_0.xyz',tmppath2) + call dum%open('crest_rotamers_0.xyz') + +!--- M(T)D stability check + call minigrep('xtb.out','M(T)D is unstable, emergency exit',mdfail) + if (dum%nall .eq. 1) then + call copysub('xtb.out',resultspath) + write (stdout,*) 'ERROR : M(T)D results only in one structure' + if (mdfail) then + write (stdout,*) ' It was unstable' + else + write (stdout,*) ' The M(T)D time step might be too large or the M(T)D time too short.' + end if + call copysub('xtb.out',resultspath) + error stop ' Please check the xtb.out file in the ensemble folder' + end if + if (mdfail) then + write (stdout,*) + write (stdout,*) ' WARNING: The M(T)D was unstable.' + write (stdout,*) ' Please check the xtb.out file in the ensemble folder.' + write (stdout,*) + call copysub('xtb.out',resultspath) + end if + call dum%deallocate + call chdirdbug(tmppath2) + call clus%write('coord') + call inputcoords(env,'coord') !Necessary + +!--- Optimization + call print_qcg_opt + !if (env%gfnver .eq. '--gfn2') + call multilevel_opt(env,99) + +end subroutine xtb_md_ensemble_qcg + !___________________________________________________________________________________ ! ! An xTB docking on all available threads @@ -275,7 +501,7 @@ subroutine opt_cluster(env,solu,clus,fname,without_pot) jobcall = trim(env%ProgName)//' xtbopt.coord --sp '//trim(env%gfnver) jobcall = trim(jobcall)//' '//trim(env%solv) jobcall = trim(jobcall)//' > xtb_sp.out 2>/dev/null' - call command(trim(jobcall)) + call command(trim(jobcall)) end if ! cleanup From b463b95a35bd00afd510397ee6a153c0fdc5f6d4 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 20 Nov 2025 22:33:58 +0100 Subject: [PATCH 091/374] refactor parse_xtbinput.f90 --- src/parsing/parse_xtbinput.f90 | 201 ++++++++++++++++----------------- 1 file changed, 96 insertions(+), 105 deletions(-) diff --git a/src/parsing/parse_xtbinput.f90 b/src/parsing/parse_xtbinput.f90 index 197dafef..dd2c3fd2 100644 --- a/src/parsing/parse_xtbinput.f90 +++ b/src/parsing/parse_xtbinput.f90 @@ -1,7 +1,7 @@ !================================================================================! ! This file is part of crest. ! -! Copyright (C) 2023 Philipp Pracht +! Copyright (C) 2023-2025 Philipp Pracht ! ! crest is free software: you can redistribute it and/or modify it under ! the terms of the GNU Lesser General Public License as published by @@ -27,6 +27,7 @@ module parse_xtbinput use crest_parameters use crest_data + use crest_calculator, only: calcdata use parse_datastruct use parse_keyvalue use parse_block @@ -59,22 +60,26 @@ subroutine parse_xtb_inputfile(env,fname) !* and storing information in env !********************************************* implicit none - type(systemdata) :: env - character(len=*) :: fname + type(systemdata),intent(inout) :: env + character(len=*),intent(in) :: fname type(root_object),allocatable,target :: dict type(datablock),pointer :: blk logical :: ex character(len=:),allocatable :: hdr integer :: i,j,k,l + type(coord) :: mol inquire (file=fname,exist=ex) if (.not.ex) return - allocate(dict) + allocate (dict) call parse_xtb_input_fallback(fname,dict) !call dict%print() + !> get the ref structure + call env%ref%to(mol) + write (stdout,'(a,a,a)') 'Parsing xtb-type input file ',trim(fname), & & ' to set up calculators ...' !> iterate through the blocks and save the necessary information @@ -83,13 +88,14 @@ subroutine parse_xtb_inputfile(env,fname) hdr = trim(blk%header) select case (hdr) case ('constrain') - call get_xtb_constraint_block(env,blk) + call get_xtb_constraint_block(env%calc,mol,blk) case ('wall') - call get_xtb_wall_block(env,blk) + call get_xtb_wall_block(env%calc,mol,env%potscal,blk) case ('fix') - call get_xtb_fix_block(env,blk) + call get_xtb_fix_block(env%calc,mol,blk) case ('metadyn') - call get_xtb_metadyn_block(env,blk) + call get_xtb_metadyn_block(env%calc,mol,env%mtd_kscal, & + & env%includeRMSD,env%rednat,blk) case default write (stdout,'(a,a,a)') 'xtb-style input block: "$',trim(hdr),'" not defined for CREST' end select @@ -100,19 +106,20 @@ end subroutine parse_xtb_inputfile !========================================================================================! - subroutine get_xtb_constraint_block(env,blk) + subroutine get_xtb_constraint_block(calc,mol,blk) !******************************************************************** !* This is the fallback reader for xtb input files to set up a dict !******************************************************************** implicit none - type(systemdata),intent(inout) :: env - type(filetype) :: file + !> IN/OUTPUT + type(calcdata),intent(inout) :: calc + type(coord),intent(in) :: mol + type(datablock),intent(in),target :: blk + !> LOCAL integer :: i,j,k,io type(keyvalue),pointer :: kv - type(datablock),intent(in),target :: blk real(wp) :: force_constant,dist,angl real(wp) :: rdum - type(coord) :: mol type(coord) :: molref logical :: useref logical,allocatable :: pairwise(:) @@ -138,7 +145,6 @@ subroutine get_xtb_constraint_block(env,blk) case ('reference') !> a reference geometry (must be the same molecule as the input) - call env%ref%to(mol) call molref%open(kv%rawvalue) if (any(mol%at(:) .ne. molref%at(:))) then write (stdout,'(a,/,a)') '**ERROR** while reading xtb-style input:',& @@ -151,9 +157,6 @@ subroutine get_xtb_constraint_block(env,blk) end select end do -!>--- get reference input geometry - call env%ref%to(mol) - !>--- then the common constraints: distance, angle, dihedral do i = 1,blk%nkv kv => blk%kv_list(i) @@ -163,7 +166,7 @@ subroutine get_xtb_constraint_block(env,blk) !> already read above case ('distance','bond') - if (kv%na .eq. 3 .or. kv%na .eq. 4) then + if (kv%na .eq. 3.or.kv%na .eq. 4) then read (kv%value_rawa(1),*,iostat=io) i1 if (io == 0) read (kv%value_rawa(2),*,iostat=io) i2 if (io == 0) then @@ -180,12 +183,12 @@ subroutine get_xtb_constraint_block(env,blk) !if(io == 0 .and. kv%na == 4)then ! read (kv%value_rawa(3),*,iostat=io) rdum !endif - if(io == 0)then + if (io == 0) then call cons%deallocate() call cons%bondconstraint(i1,i2,dist,force_constant) if (debug) call cons%print(stdout) - call env%calc%add(cons) - endif + call calc%add(cons) + end if end if end if @@ -207,7 +210,7 @@ subroutine get_xtb_constraint_block(env,blk) call cons%deallocate() call cons%angleconstraint(i1,i2,i3,angl,force_constant) if (debug) call cons%print(stdout) - call env%calc%add(cons) + call calc%add(cons) end if end if @@ -230,7 +233,7 @@ subroutine get_xtb_constraint_block(env,blk) call cons%deallocate() call cons%dihedralconstraint(i1,i2,i3,i4,angl,force_constant) if (debug) call cons%print(stdout) - call env%calc%add(cons) + call calc%add(cons) end if end if @@ -238,29 +241,29 @@ subroutine get_xtb_constraint_block(env,blk) read (kv%value_rawa(1),*,iostat=io) atm1 if (io == 0) read (kv%value_rawa(2),*,iostat=io) atm2 if (io == 0) read (kv%value_rawa(3),*,iostat=io) dum1 - if(io==0)then - dum1 = dum1*aatoau - dum1 = max(0.0_wp,dum1) !> can't be negative - select case (kv%na) - case (3) - dum2 = huge(dum2)/3.0_wp !> some huge value - call cons%bondrangeconstraint(atm1,atm2,dum1,dum2) - case (4) - if (io == 0) read (kv%value_rawa(4),*,iostat=io) dum2 - dum2 = dum2*aatoau - call cons%bondrangeconstraint(atm1,atm2,dum1,dum2) - case (5) - if (io == 0) read (kv%value_rawa(5),*,iostat=io) dum3 - call cons%bondrangeconstraint(atm1,atm2,dum1,dum2,beta=dum3) - case (6) - if (io == 0) read (kv%value_rawa(6),*,iostat=io) dum4 - call cons%bondrangeconstraint(atm1,atm2,dum1,dum2,beta=dum3,T=dum4) - case default - error stop '**ERROR** wrong number of arguments in bondrange constraint' - end select - call env%calc%add(cons) - if (debug) call cons%print(stdout) - endif + if (io == 0) then + dum1 = dum1*aatoau + dum1 = max(0.0_wp,dum1) !> can't be negative + select case (kv%na) + case (3) + dum2 = huge(dum2)/3.0_wp !> some huge value + call cons%bondrangeconstraint(atm1,atm2,dum1,dum2) + case (4) + if (io == 0) read (kv%value_rawa(4),*,iostat=io) dum2 + dum2 = dum2*aatoau + call cons%bondrangeconstraint(atm1,atm2,dum1,dum2) + case (5) + if (io == 0) read (kv%value_rawa(5),*,iostat=io) dum3 + call cons%bondrangeconstraint(atm1,atm2,dum1,dum2,beta=dum3) + case (6) + if (io == 0) read (kv%value_rawa(6),*,iostat=io) dum4 + call cons%bondrangeconstraint(atm1,atm2,dum1,dum2,beta=dum3,T=dum4) + case default + error stop '**ERROR** wrong number of arguments in bondrange constraint' + end select + call calc%add(cons) + if (debug) call cons%print(stdout) + end if case ('atoms') if (.not.allocated(pairwise)) allocate (pairwise(mol%nat),source=.false.) call get_atlist(mol%nat,atlist,kv%rawvalue,mol%at) @@ -296,10 +299,10 @@ subroutine get_xtb_constraint_block(env,blk) k = 0 do i = 1,mol%nat do j = 1,i-1 - if (pairwise(i).and.pairwise(j)) k = k +1 - enddo - enddo - allocate(conslist(k)) + if (pairwise(i).and.pairwise(j)) k = k+1 + end do + end do + allocate (conslist(k)) k = 0 do i = 1,mol%nat do j = 1,i-1 @@ -309,42 +312,41 @@ subroutine get_xtb_constraint_block(env,blk) else dist = mol%dist(j,i) end if - k = k + 1 + k = k+1 !call cons%deallocate() call conslist(k)%bondconstraint(j,i,dist,force_constant) if (debug) call conslist(k)%print(stdout) - !call env%calc%add(cons) end if end do end do - call env%calc%add(k,conslist) - deallocate (conslist) + call calc%add(k,conslist) + deallocate (conslist) deallocate (pairwise) end if - end subroutine get_xtb_constraint_block - subroutine get_xtb_wall_block(env,blk) + subroutine get_xtb_wall_block(calc,mol,potscal,blk) !************************************** !* This is a reader for the $wall block !*************************************** implicit none - type(systemdata),intent(inout) :: env - type(filetype) :: file + !> IN/OUTPUT + type(calcdata),intent(inout) :: calc + type(coord),intent(in) :: mol + real(wp),intent(inout) :: potscal + type(datablock),intent(in),target :: blk + !> LOCAL integer :: i,j,k,io type(keyvalue),pointer :: kv - type(datablock),intent(in),target :: blk real(wp) :: force_constant,dist,angl real(wp) :: T,alpha,beta real(wp) :: rdum,rabc(3),r1,r2,r3 - type(coord) :: mol - logical,allocatable :: pairwise(:) logical,allocatable :: atlist(:) integer :: i1,i2,i3,i4 integer :: pot type(constraint) :: cons - if(debug) write(*,*) 'parsing $wall block' + if (debug) write (*,*) 'parsing $wall block' !>--- asome defaults force_constant = 1.0_wp @@ -353,9 +355,6 @@ subroutine get_xtb_wall_block(env,blk) T = 300.0_wp pot = 1 !> 1= polynomial, 2= logfermi -!>--- get reference input geometry - call env%ref%to(mol) - !>--- get the parameters first do i = 1,blk%nkv kv => blk%kv_list(i) @@ -401,7 +400,7 @@ subroutine get_xtb_wall_block(env,blk) if (kv%na > 0) then if (trim(kv%value_rawa(1)) .eq. 'auto') then !> determine sphere - call wallpot_core(mol,rabc,potscal=env%potscal) + call wallpot_core(mol,rabc,potscal=potscal) rdum = maxval(rabc(:)) rabc(:) = rdum else @@ -417,15 +416,15 @@ subroutine get_xtb_wall_block(env,blk) call cons%ellipsoid(mol%nat,atlist,rabc,T,beta,.true.) end select if (debug) call cons%print(stdout) - call env%calc%add(cons) + call calc%add(cons) end if case ('ellipsoid') - if(debug) write(*,*) 'parsing ellipsoid',kv%na + if (debug) write (*,*) 'parsing ellipsoid',kv%na if (kv%na > 0) then if (trim(kv%value_rawa(1)) .eq. 'auto') then !> determine ellipsoid - call wallpot_core(mol,rabc,potscal=env%potscal) + call wallpot_core(mol,rabc,potscal=potscal) else read (kv%value_rawa(1),*,iostat=io) r1 if (io == 0) read (kv%value_rawa(2),*,iostat=io) r2 @@ -445,7 +444,7 @@ subroutine get_xtb_wall_block(env,blk) call cons%ellipsoid(mol%nat,atlist,rabc,T,beta,.true.) end select if (debug) call cons%print(stdout) - call env%calc%add(cons) + call calc%add(cons) end if case default @@ -453,31 +452,28 @@ subroutine get_xtb_wall_block(env,blk) end select end do - end subroutine get_xtb_wall_block - subroutine get_xtb_fix_block(env,blk) + subroutine get_xtb_fix_block(calc,mol,blk) !************************************** !* This is a reader for the $fix block !*************************************** implicit none - type(systemdata),intent(inout) :: env - type(filetype) :: file + !> IN/OUTPUT + type(calcdata),intent(inout) :: calc + type(coord),intent(in) :: mol + type(datablock),intent(in),target :: blk + !> LOCAL integer :: i,j,k,io type(keyvalue),pointer :: kv - type(datablock),intent(in),target :: blk real(wp) :: force_constant,dist,angl real(wp) :: T,alpha,beta real(wp) :: rdum,rabc(3),r1,r2,r3 - type(coord) :: mol logical,allocatable :: pairwise(:) logical,allocatable :: atlist(:) integer :: i1,i2,i3,i4 integer :: pot -!>--- get reference input geometry - call env%ref%to(mol) - !>--- get the parameters first do i = 1,blk%nkv kv => blk%kv_list(i) @@ -517,7 +513,7 @@ subroutine get_xtb_fix_block(env,blk) if (allocated(pairwise)) then i1 = count(pairwise) - env%calc%nfreeze = i1 + calc%nfreeze = i1 if (debug) then write (stdout,'("> ",a)') 'Frozen atoms:' do i = 1,mol%nat @@ -525,35 +521,33 @@ subroutine get_xtb_fix_block(env,blk) end do write (stdout,*) end if - call move_alloc(pairwise,env%calc%freezelist) + call move_alloc(pairwise,calc%freezelist) end if - end subroutine get_xtb_fix_block - - - subroutine get_xtb_metadyn_block(env,blk) + subroutine get_xtb_metadyn_block(calc,mol,mtd_kscal,includeRMSD,rednat,blk) !************************************** !* This is a reader for the $metadyn block !*************************************** implicit none - type(systemdata),intent(inout) :: env - type(filetype) :: file + !> IN/OUTPUT + type(calcdata),intent(inout) :: calc + type(coord),intent(in) :: mol + real(wp),intent(inout) :: mtd_kscal + integer,allocatable,intent(inout) :: includeRMSD(:) + integer,intent(inout) :: rednat + type(datablock),intent(in),target :: blk + !> LOCAL integer :: i,j,k,io type(keyvalue),pointer :: kv - type(datablock),intent(in),target :: blk real(wp) :: force_constant,dist,angl real(wp) :: T,alpha,beta real(wp) :: rdum,rabc(3),r1,r2,r3 - type(coord) :: mol logical,allocatable :: pairwise(:) logical,allocatable :: atlist(:) integer :: i1,i2,i3,i4 integer :: pot -!>--- get reference input geometry - call env%ref%to(mol) - !>--- get the parameters first do i = 1,blk%nkv kv => blk%kv_list(i) @@ -584,12 +578,11 @@ subroutine get_xtb_metadyn_block(env,blk) if (i1 == mol%at(j)) pairwise(j) = .true. end do end if - + case ('kscal') !> define a global metadynamics k-push scaling factor - read(kv%rawvalue,*) r1 - env%mtd_kscal = r1 - + read (kv%rawvalue,*) r1 + mtd_kscal = r1 case default write (stdout,'(a,a,a)') 'xtb-style input key: "',kv%key,'" not defined for CREST' @@ -606,17 +599,16 @@ subroutine get_xtb_metadyn_block(env,blk) end do write (stdout,*) end if - if(.not.allocated(env%includeRMSD)) allocate(env%includeRMSD(mol%nat), source=0) - do i=1,mol%nat - if(pairwise(i)) env%includeRMSD(i) = 1 - enddo - env%rednat = i1 + if (.not.allocated(includeRMSD)) allocate (includeRMSD(mol%nat),source=0) + do i = 1,mol%nat + if (pairwise(i)) includeRMSD(i) = 1 + end do + rednat = i1 end if call mol%deallocate() end subroutine get_xtb_metadyn_block - !========================================================================================! subroutine parse_xtb_input_fallback(fname,dict) @@ -737,7 +729,7 @@ subroutine get_xtb_keyvalue(kv,str,io) call kv%deallocate() io = 0 tmpstr = adjustl(lowercase(str)) - tmpstr_rc=adjustl(trim(str)) + tmpstr_rc = adjustl(trim(str)) !> key-value conditions l(1) = index(tmpstr,'=') @@ -792,7 +784,6 @@ subroutine get_xtb_keyvalue(kv,str,io) end if end subroutine get_xtb_keyvalue - subroutine get_xtb_rawa(kv,str,io) implicit none class(keyvalue),intent(inout) :: kv @@ -803,7 +794,7 @@ subroutine get_xtb_rawa(kv,str,io) integer :: i,j,k,na,plast integer :: l(3) - if(allocated(kv%value_rawa)) deallocate(kv%value_rawa) + if (allocated(kv%value_rawa)) deallocate (kv%value_rawa) vtmp = trim(adjustl(str)) From 5496bce79b72507c6726675df9774a9b95062e3f Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 20 Nov 2025 23:58:13 +0100 Subject: [PATCH 092/374] work on implementing calculator structure in QCG --- src/filemod.f90 | 4 - src/parsing/parse_xtbinput.f90 | 150 ++++++++++++++++++++++++++++++++- src/qcg/qcg_main.f90 | 96 +++++++++++---------- 3 files changed, 202 insertions(+), 48 deletions(-) diff --git a/src/filemod.f90 b/src/filemod.f90 index 15e437d3..5e36f8d3 100644 --- a/src/filemod.f90 +++ b/src/filemod.f90 @@ -17,12 +17,9 @@ ! along with crest. If not, see . !================================================================================! - !> fortran module for simple plain-text file handling module filemod - use iso_fortran_env,wp => real64 - implicit none public :: filetype @@ -426,7 +423,6 @@ function lwidth(fname) close (ich) end function lwidth - !========================================================================================! !get n-th element of a line (seperated by blanks) function getlarg(line,n) diff --git a/src/parsing/parse_xtbinput.f90 b/src/parsing/parse_xtbinput.f90 index dd2c3fd2..9ee56ade 100644 --- a/src/parsing/parse_xtbinput.f90 +++ b/src/parsing/parse_xtbinput.f90 @@ -27,7 +27,7 @@ module parse_xtbinput use crest_parameters use crest_data - use crest_calculator, only: calcdata + use crest_calculator,only:calcdata use parse_datastruct use parse_keyvalue use parse_block @@ -48,6 +48,8 @@ module parse_xtbinput module procedure :: parse_xtb_input_fallback end interface parse_xtbinputfile + public :: parse_constraints_from_cts + !========================================================================================! !========================================================================================! contains !> MODULE PROCEDURES START HERE @@ -901,5 +903,151 @@ subroutine clearxtbheader(hdr) return end subroutine clearxtbheader +!============================================================================! + + subroutine parse_constraints_from_cts(calc,mol,cts) +!********************************************* +!* Routine for parsing cts objects into calcdata +!********************************************* + implicit none + !> IN/OUTPUT + type(calcdata),intent(inout) :: calc + class(coord),intent(inout) :: mol !> polymorphic class(!) to use in qcg + type(legacy_constraints),intent(in) :: cts + !> LOCAL + type(root_object),allocatable,target :: dict + type(datablock),pointer :: blk + logical :: ex + character(len=:),allocatable :: hdr + integer :: i,j,k,l + !> some defaults/fallbacks + real(wp) :: potscal = 1.0_wp + integer :: rednat + integer,allocatable :: includeRMSD(:) + real(wp) :: mtd_kscal + + allocate (dict) + !call parse_xtb_input_fallback(fname,dict) + call parse_cts_internal(cts,dict) + !call dict%print() + + write (stdout,'(a,a,a)') 'Parsing xtb-type constraints from internal backup to set up calculators ...' + !> iterate through the blocks and save the necessary information + do i = 1,dict%nblk + blk => dict%blk_list(i) + hdr = trim(blk%header) + select case (hdr) + case ('constrain') + call get_xtb_constraint_block(calc,mol,blk) + case ('wall') + call get_xtb_wall_block(calc,mol,potscal,blk) + case ('fix') + call get_xtb_fix_block(calc,mol,blk) + case ('metadyn') + call get_xtb_metadyn_block(calc,mol,mtd_kscal, & + & includeRMSD,rednat,blk) + case default + write (stdout,'(a,a,a)') 'xtb-style input block: "$',trim(hdr),'" not defined for CREST' + end select + end do + + if (debug) stop + end subroutine parse_constraints_from_cts + + subroutine parse_cts_internal(cts,dict) +!******************************************************************** +!* This is the fallback reader for xtb constraints from cts to set up a dict +!******************************************************************** + implicit none + !> IN/OUTPUT + type(legacy_constraints),intent(in) :: cts + type(root_object),intent(out) :: dict + !> LOCAL + type(filetype) :: file + integer :: i,j,k,io,b + logical :: get_root_kv + type(keyvalue) :: kvdum + type(datablock) :: blkdum + character(len=:),allocatable :: dummy + + call dict%new() +!>--- parse cts into a "file" --> internal storage + k = 0 + if (cts%used) then + do i = 1,cts%ndim + if (trim(cts%sett(i)) .ne. '') k = k+1 + end do + end if + if (cts%NCI.and.allocated(cts%pots)) then + do i = 1,10 + if (trim(cts%pots(i)) .ne. '') k = k+1 + end do + end if + if (allocated(cts%cbonds)) then + do i = 1,cts%n_cbonds + if (trim(cts%cbonds(i)) .ne. '') k = k+1 + end do + end if + b = 128 + file%lwidth = b + dummy = repeat(' ',b+5) + file%nlines = k + file%current_line = 1 + allocate (file%f(k),source=dummy) + k=0 + if (cts%used) then + do i = 1,cts%ndim + if (trim(cts%sett(i)) .ne. '')then + k = k+1 + file%f(k) = trim(cts%sett(i)) + endif + end do + end if + if (cts%NCI.and.allocated(cts%pots)) then + do i = 1,10 + if (trim(cts%pots(i)) .ne. '')then + k = k+1 + file%f(k) = trim(cts%pots(i)) + endif + end do + end if + if (allocated(cts%cbonds)) then + do i = 1,cts%n_cbonds + if (trim(cts%cbonds(i)) .ne. '')then + k = k+1 + file%f(k) = trim(cts%cbonds(i)) + endif + end do + end if + + dict%filename = "internal cts" + call remove_comments(file) + +!>--- all valid key-values must be in $-blocks, no root-level ones + get_root_kv = .false. +!>--- the loop where the input file is read + do i = 1,file%nlines + if (file%current_line > i) cycle + !> key-value pairs of the root dict (ignored for xtb) + if (get_root_kv) then + call get_keyvalue(kvdum,file%line(i),io) + if (io == 0) then + call dict%addkv(kvdum) !> add to dict + end if + end if + + !> the $-blocks + if (isxtbheader(file%line(i))) then + get_root_kv = .false. + call read_xtbdatablock(file,i,blkdum) + call dict%addblk(blkdum) !> add to dict + end if + end do + + call file%close() + + return + end subroutine parse_cts_internal + !========================================================================================! end module parse_xtbinput diff --git a/src/qcg/qcg_main.f90 b/src/qcg/qcg_main.f90 index c3586860..d7a7f7a7 100644 --- a/src/qcg/qcg_main.f90 +++ b/src/qcg/qcg_main.f90 @@ -779,13 +779,15 @@ end subroutine qcg_grow subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) use crest_parameters use crest_data - use qcg_printouts + use cregen_interface + use crest_calculator use iomod + use parse_xtbinput use qcg_coord_type + use qcg_printouts + use qcg_utils use strucrd use utilities - use cregen_interface - use qcg_utils implicit none type(systemdata) :: env @@ -808,19 +810,19 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) logical :: gbsa_tmp logical :: ex,mdfail,e_there logical :: checkiso_tmp,cbonds_tmp - real(wp),allocatable :: e_fix(:),e_clus(:) + real(wp),allocatable :: e_fix(:),e_clus(:) real(wp) :: S,H,G,dens,shr,shr_av real(wp) :: sasa real(wp) :: newtemp,newmdtime,newmdstep,newhmass real(wp) :: newmetadlist,newmetadexp,newmetadfac real(wp) :: optlev_tmp real(wp) :: e0 - real(wp),allocatable :: de(:) - real(wp),allocatable :: p(:) + real(wp),allocatable :: de(:) + real(wp),allocatable :: p(:) integer :: ich98,ich65,ich48 logical :: not_param = .false. type(timer) :: tim_dum !Dummy timer to avoid double counting - + type(calcdata) :: calc_tmp logical,parameter :: debug = .true. if (.not.env%solv_md) then @@ -911,49 +913,57 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) !---------------------------------------------------------------- ! Case selection of normal Crest, MD or MTD !---------------------------------------------------------------- - if(debug)then - write(*,*) 'Entering sampling part next. We have these constraints:' - call env%cts%info() - endif + if (debug) then + write (*,*) 'Entering sampling part next. We have these constraints:' + call env%cts%info() + write (*,*) ' for structure:' + call clus%append(stdout) + end if - ENSEMBLEGEN : select case (env%ensemble_method) + if (.not.env%legacy) then + calc_tmp = env%calc + call parse_constraints_from_cts(env%calc,clus,env%cts) + call env%calc%info(stdout) + end if + + ENSEMBLEGEN:select case(env%ensemble_method) case (-1:0) !qcgmtd/Crest runtype - !Defaults - !General settings: - if (.not.env%user_mdstep) then - if (env%ensemble_opt .EQ. '--gff') then - env%mdstep = 1.5d0 - else - env%mdstep = 5.0d0 - end if + !> Some custom Defaults for running the standard search + !General settings: + if (.not.env%user_mdstep) then + if (env%ensemble_opt .EQ. '--gff') then + env%mdstep = 1.5d0 + else + env%mdstep = 5.0d0 end if - !Runtype specific settings: - if (env%ensemble_method == 0) then - if (.not.env%user_dumxyz) then - env%mddumpxyz = 200 - end if - if (.not.env%user_mdtime) then - env%mdtime = 10.0 - end if - else if (env%ensemble_method == -1) then - if (.not.env%user_dumxyz) then - env%mddumpxyz = 50 - end if - if (.not.env%user_mdtime) then - env%mdtime = 5.0 - end if - env%nmdtemp = 100 - env%MaxRestart = 6 + end if + !Runtype specific settings: + if (env%ensemble_method == 0) then + if (.not.env%user_dumxyz) then + env%mddumpxyz = 200 + end if + if (.not.env%user_mdtime) then + env%mdtime = 10.0 + end if + else if (env%ensemble_method == -1) then + if (.not.env%user_dumxyz) then + env%mddumpxyz = 50 end if + if (.not.env%user_mdtime) then + env%mdtime = 5.0 + end if + env%nmdtemp = 100 + env%MaxRestart = 6 + end if - env%iterativeV2 = .true. !Safeguards more precise ensemble search - write (stdout,*) 'Starting ensemble cluster generation by CREST routine' - call confscript2i(env,tim_dum) !Calling ensemble search - call copy('crest_rotamers.xyz','crest_rotamers_0.xyz') + env%iterativeV2 = .true. !Safeguards more precise ensemble search + write (stdout,*) 'Starting ensemble cluster generation by CREST routine' + call confscript2i(env,tim_dum) !Calling ensemble search + call copy('crest_rotamers.xyz','crest_rotamers_0.xyz') case (1:2) ! Single MD or MTD - call xtb_md_ensemble_qcg(env,solu,solv,clus,resultspath) + call xtb_md_ensemble_qcg(env,solu,solv,clus,resultspath) end select ENSEMBLEGEN @@ -977,7 +987,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) deallocate (env%cts%pots) call multilevel_opt(env,99) - stop + stop !TODO TODO TODO TODO !Clustering to exclude similar structures if requested with -cluster if (env%properties == 70) then From 2b95a2dfbd41a5d732247edca03785e949b0e7ed Mon Sep 17 00:00:00 2001 From: Lukas Rindt Date: Tue, 25 Nov 2025 16:44:03 +0100 Subject: [PATCH 093/374] storage type functioning --- src/calculator/hessian_reconstruct.f90 | 65 ++++++++++++++++++++++++++ 1 file changed, 65 insertions(+) create mode 100644 src/calculator/hessian_reconstruct.f90 diff --git a/src/calculator/hessian_reconstruct.f90 b/src/calculator/hessian_reconstruct.f90 new file mode 100644 index 00000000..611e90ff --- /dev/null +++ b/src/calculator/hessian_reconstruct.f90 @@ -0,0 +1,65 @@ +module hessian_reconstruct + use iso_fortran_env,only:wp => real64 + implicit none + private + + public cashed_hessian + + type :: cashed_hessian + + integer :: steps = 10 + real(wp), allocatable :: gradient(:,:,:) + real(wp), allocatable :: coords(:,:,:) + real(wp), allocatable :: energy(:) + real(wp), allocatable :: order(:) + integer :: stepcount = 0 + + contains + + procedure :: alloc => cashed_hessian_allocate + procedure :: dealloc => cashed_hessian_deallocate + procedure :: update => update_cashed_hessian + + end type cashed_hessian + +contains + +subroutine cashed_hessian_allocate(self, N, steps) +integer, intent(in) :: N, steps +class(cashed_hessian) :: self + +self%steps = steps +allocate(self%gradient(steps,3,N)) +allocate(self%coords(steps,3,N)) +allocate(self%energy(steps)) +allocate(self%order(steps)) + +self%order(:) = 0.0_wp + +end subroutine cashed_hessian_allocate + +subroutine cashed_hessian_deallocate(self) +class(cashed_hessian) :: self + +if(allocated(self%gradient)) deallocate(self%gradient) +if(allocated(self%coords)) deallocate(self%coords) +if(allocated(self%energy)) deallocate(self%energy) +if(allocated(self%order)) deallocate(self%order) + +end subroutine cashed_hessian_deallocate + +subroutine update_cashed_hessian(self, gradient, energy, coords) +class(cashed_hessian) :: self +real(wp), intent(in) :: gradient(:,:), energy, coords(:,:) +integer :: idx + +self%stepcount = self%stepcount + 1 +idx = minloc(self%order,1) +self%order(idx) = self%stepcount +self%gradient(idx,:,:) = gradient +self%energy(idx) = energy +self%coords(idx,:,:) = coords + +end subroutine update_cashed_hessian + +end module hessian_reconstruct \ No newline at end of file From 1f8bea31fa8f396439f7cfcd14efee7ad932be8c Mon Sep 17 00:00:00 2001 From: Lukas Rindt Date: Tue, 25 Nov 2025 16:46:00 +0100 Subject: [PATCH 094/374] storage type functioning complete --- src/calculator/CMakeLists.txt | 1 + src/calculator/calc_type.f90 | 6 ++++++ src/calculator/calculator.F90 | 4 ++++ src/optimize/optimize_module.f90 | 19 ++++++++++++++++++- 4 files changed, 29 insertions(+), 1 deletion(-) diff --git a/src/calculator/CMakeLists.txt b/src/calculator/CMakeLists.txt index 13e1cd2e..d0f4bb6b 100644 --- a/src/calculator/CMakeLists.txt +++ b/src/calculator/CMakeLists.txt @@ -38,6 +38,7 @@ list(APPEND srcs "${dir}/generic_sc.f90" "${dir}/turbom_sc.f90" "${dir}/subprocess_engrad.f90" + "${dir}/hessian_reconstruct.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 3b61bc49..d5f8bb1d 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -29,6 +29,7 @@ module calc_type !>--- other types use orca_type use lwoniom_module + use hessian_reconstruct implicit none character(len=*),public,parameter :: sep = '/' @@ -266,6 +267,11 @@ module calc_type integer,allocatable :: ONIOMmap(:) !> map ONIOM fragments to calculation_settings integer,allocatable :: ONIOMrevmap(:) !> map calculation settings to ONIOM frags (or zero) +!>--- Hessian Reconstructor + type(cashed_hessian), allocatable :: chess + logical :: do_HU = .true. + integer :: hu_steps = 10 + !>--- Type procedures contains procedure :: reset => calculation_reset diff --git a/src/calculator/calculator.F90 b/src/calculator/calculator.F90 index 85e02162..e1222f4b 100644 --- a/src/calculator/calculator.F90 +++ b/src/calculator/calculator.F90 @@ -297,6 +297,10 @@ subroutine engrad_mol(mol,calc,energy,gradient,iostatus) !********************************************** call calc%freezegrad(gradient) + if (calc%do_HU) then + call calc%chess%update(gradient, energy, mol%xyz) + end if + return end subroutine engrad_mol diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index 42fbe67f..fbe92d57 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -72,6 +72,12 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) !$omp end critical endif + !> Check if Hessian Reconstruct is called + if (calc%do_HU) then + allocate(calc%chess) + call calc%chess%alloc(mol%nat,calc%hu_steps) + endif + !> initial singlepoint call engrad(molnew,calc,etot,grd,iostatus) @@ -92,7 +98,18 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) write(stdout,'(a)') 'Unknown optimization engine!' stop end select - molnew%energy = etot + molnew%energy = etot + + print*, "Energies", calc%chess%energy + print*, "Gradients", calc%chess%gradient + print*, "Coords", calc%chess%coords + print*, "Order", calc%chess%order + + if (calc%do_HU) then + call calc%chess%dealloc() + endif + + return end subroutine optimize_geometry From 8c39901e2f4b2333dddced0c5b7430fa0292a27e Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 26 Nov 2025 11:56:34 +0100 Subject: [PATCH 095/374] Avoid duplicate wall potential due to cli flag logic --- src/confparse.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/confparse.f90 b/src/confparse.f90 index c7302fb3..831ef7ad 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -2168,7 +2168,7 @@ subroutine parseflags(env,arg,nra) end if !>--- automatic wall potential for the LEGACY version - if (env%NCI.or.env%wallsetup.and.env%legacy) then + if ((env%NCI.or.env%wallsetup).and.env%legacy) then call wallpot(env) if (env%wallsetup) then write (*,'(2x,a)') 'Automatically generated ellipsoide potential:' From 75174cd6e1264e88d0ab20a767f0f02d3607c888 Mon Sep 17 00:00:00 2001 From: Lukas Rindt Date: Wed, 26 Nov 2025 16:05:36 +0100 Subject: [PATCH 096/374] lbfgs implemented --- src/calculator/calc_type.f90 | 146 ++++++++++---------- src/calculator/calculator.F90 | 14 +- src/calculator/hessian_reconstruct.f90 | 176 ++++++++++++++++++------- src/optimize/optimize_module.f90 | 3 +- 4 files changed, 208 insertions(+), 131 deletions(-) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index d5f8bb1d..a664b7b0 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -127,10 +127,10 @@ module calc_type real(wp),allocatable :: dipgrad(:,:) !> other properties - logical,allocatable :: getsasa(:) + logical,allocatable :: getsasa(:) logical :: getlmocent = .false. integer :: nprot = 0 - real(wp),allocatable :: protxyz(:,:) + real(wp),allocatable :: protxyz(:,:) !>--- API constructs integer :: tblitelvl = 2 @@ -268,7 +268,7 @@ module calc_type integer,allocatable :: ONIOMrevmap(:) !> map calculation settings to ONIOM frags (or zero) !>--- Hessian Reconstructor - type(cashed_hessian), allocatable :: chess + type(cashed_hessian),allocatable :: chess logical :: do_HU = .true. integer :: hu_steps = 10 @@ -359,10 +359,10 @@ subroutine calculation_deallocate_params(self) integer :: i,j,k if (self%ncalculations > 0) then do i = 1,self%ncalculations - if(allocated(self%calcs(i)%tblite)) deallocate(self%calcs(i)%tblite) - if(allocated(self%calcs(i)%g0calc)) deallocate(self%calcs(i)%g0calc) - if(allocated(self%calcs(i)%ff_dat)) deallocate(self%calcs(i)%ff_dat) - if(allocated(self%calcs(i)%libpvol)) deallocate(self%calcs(i)%libpvol) + if (allocated(self%calcs(i)%tblite)) deallocate (self%calcs(i)%tblite) + if (allocated(self%calcs(i)%g0calc)) deallocate (self%calcs(i)%g0calc) + if (allocated(self%calcs(i)%ff_dat)) deallocate (self%calcs(i)%ff_dat) + if (allocated(self%calcs(i)%libpvol)) deallocate (self%calcs(i)%libpvol) end do end if end subroutine calculation_deallocate_params @@ -601,21 +601,21 @@ subroutine calculation_increase_charge(self,dchrg) !****************************************************************** !* increase the charge of all calculation_settings objects by one !* or the specified dchrg -!****************************************************************** +!****************************************************************** implicit none class(calcdata) :: self integer,intent(in),optional :: dchrg integer :: i,j - if(self%ncalculations > 0)then - if(present(dchrg))then - j = dchrg - else - j = 1 - endif - do i=1,self%ncalculations - self%calcs(i)%chrg = self%calcs(i)%chrg + j - enddo - endif + if (self%ncalculations > 0) then + if (present(dchrg)) then + j = dchrg + else + j = 1 + end if + do i = 1,self%ncalculations + self%calcs(i)%chrg = self%calcs(i)%chrg+j + end do + end if return end subroutine calculation_increase_charge @@ -625,21 +625,21 @@ subroutine calculation_decrease_charge(self,dchrg) !****************************************************************** !* decrease the charge of all calculation_settings objects by one !* or the specified dchrg -!****************************************************************** +!****************************************************************** implicit none class(calcdata) :: self integer,intent(in),optional :: dchrg integer :: i,j - if(self%ncalculations > 0)then - if(present(dchrg))then - j = dchrg - else - j = 1 - endif - do i=1,self%ncalculations - self%calcs(i)%chrg = self%calcs(i)%chrg - j - enddo - endif + if (self%ncalculations > 0) then + if (present(dchrg)) then + j = dchrg + else + j = 1 + end if + do i = 1,self%ncalculations + self%calcs(i)%chrg = self%calcs(i)%chrg-j + end do + end if return end subroutine calculation_decrease_charge @@ -665,9 +665,9 @@ subroutine calc_set_active(self,ids) self%calcs(i)%active = .false. else !>--- and all other to active - if(self%calcs(i)%weight == 0.0_wp)then - self%calcs(i)%weight = 1.0_wp - endif + if (self%calcs(i)%weight == 0.0_wp) then + self%calcs(i)%weight = 1.0_wp + end if self%calcs(i)%active = .true. end if end do @@ -894,8 +894,6 @@ subroutine calculation_info(self,iunit) return end subroutine calculation_info - - !=========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< CALCULATION_SETTINGS associated routines @@ -1006,29 +1004,29 @@ subroutine calculation_settings_autocomplete(self,id) self%calcspace = 'calculation.level.'//trim(nmbr) end if - if (self%pr .and. self%prch.ne.stdout) then + if (self%pr.and.self%prch .ne. stdout) then self%prch = self%prch+id end if end subroutine calculation_settings_autocomplete !>--- create a short calculation info flag - subroutine calculation_settings_shortflag(self) + subroutine calculation_settings_shortflag(self) implicit none class(calculation_settings) :: self integer :: i,j - select case( self%id ) - case( jobtype%xtbsys ) + select case (self%id) + case (jobtype%xtbsys) self%shortflag = 'xtb subprocess' - case( jobtype%generic ) - self%shortflag = 'generic subprocess' - case( jobtype%turbomole ) + case (jobtype%generic) + self%shortflag = 'generic subprocess' + case (jobtype%turbomole) self%shortflag = 'TURBOMOLE subprocess' - case( jobtype%orca ) + case (jobtype%orca) self%shortflag = 'ORCA subprocess' - case( jobtype%terachem ) + case (jobtype%terachem) self%shortflag = 'TeraChem subprocess' - case( jobtype%tblite ) + case (jobtype%tblite) select case (self%tblitelvl) case (xtblvl%gfn2) self%shortflag = 'GFN2-xTB' @@ -1043,23 +1041,23 @@ subroutine calculation_settings_shortflag(self) case (xtblvl%param) self%shortflag = 'parameter file: '//trim(self%tbliteparam) end select - case( jobtype%gfn0 ) - self%shortflag = 'GFN0-xTB' - case( jobtype%gfn0occ ) - self%shortflag = 'GFN0-xTB*' - case( jobtype%gfnff ) - self%shortflag = 'GFN-FF' - case( jobtype%libpvol ) - self%shortflag = 'LIVPVOL' - case( jobtype%lj ) - self%shortflag = 'LJ' + case (jobtype%gfn0) + self%shortflag = 'GFN0-xTB' + case (jobtype%gfn0occ) + self%shortflag = 'GFN0-xTB*' + case (jobtype%gfnff) + self%shortflag = 'GFN-FF' + case (jobtype%libpvol) + self%shortflag = 'LIVPVOL' + case (jobtype%lj) + self%shortflag = 'LJ' case default self%shortflag = 'undefined' end select - if(allocated(self%solvmodel).and.allocated(self%solvent))then + if (allocated(self%solvmodel).and.allocated(self%solvent)) then self%shortflag = self%shortflag//'/'//trim(self%solvmodel) - self%shortflag = self%shortflag//'('//trim(self%solvent)//')' - endif + self%shortflag = self%shortflag//'('//trim(self%solvent)//')' + end if end subroutine calculation_settings_shortflag !>-- generate a unique print id for the calculation @@ -1101,7 +1099,7 @@ subroutine calculation_settings_info(self,iunit) character(len=20) :: atmp logical :: gxtbwarn - gxtbwarn=.false. + gxtbwarn = .false. if (allocated(self%description)) then write (iunit,'(" :",1x,a)') trim(self%description) @@ -1122,12 +1120,12 @@ subroutine calculation_settings_info(self,iunit) end if if (any((/jobtype%orca,jobtype%xtbsys,jobtype%turbomole, & & jobtype%generic,jobtype%terachem/) == self%id)) then - if(index(self%binary,'gxtb').ne.0)then - write(iunit,fmt4) 'g-xTB (development version)' + if (index(self%binary,'gxtb') .ne. 0) then + write (iunit,fmt4) 'g-xTB (development version)' gxtbwarn = .true. - else + else write (iunit,'(" :",3x,a,a)') 'selected binary : ',trim(self%binary) - endif + end if end if if (self%refine_lvl > 0) then write (atmp,*) 'refinement stage' @@ -1147,7 +1145,7 @@ subroutine calculation_settings_info(self,iunit) write (iunit,fmt3) atmp,trim(self%solvmodel) end if if (allocated(self%solvent)) then - write (atmp,*) 'Solvent' + write (atmp,*) 'Solvent' write (iunit,fmt3) atmp,trim(self%solvent) end if @@ -1179,16 +1177,16 @@ subroutine calculation_settings_info(self,iunit) end select write (iunit,fmt1) trim(atmp),self%ONIOM_id else - if(self%weight .ne. 1.0_wp)then + if (self%weight .ne. 1.0_wp) then write (atmp,*) 'Weight' write (iunit,fmt2) atmp,self%weight - endif + end if end if - if(gxtbwarn)then - write(iunit,fmt4) 'WARNING: This currently is the development version of g-xTB.' - write(iunit,fmt4) 'WARNING: Gradients are NUMERICAL (i.e., expensive and noisy!)' - endif + if (gxtbwarn) then + write (iunit,fmt4) 'WARNING: This currently is the development version of g-xTB.' + write (iunit,fmt4) 'WARNING: Gradients are NUMERICAL (i.e., expensive and noisy!)' + end if end subroutine calculation_settings_info @@ -1221,14 +1219,14 @@ subroutine create_calclevel_shortcut(self,levelstring) self%rdgrad = .false. self%binary = 'gp3' case ('gxtb','gxtb_dev') - self%id = jobtype%turbomole - self%rdgrad = .false. + self%id = jobtype%turbomole + self%rdgrad = .false. self%binary = 'gxtb' self%rdwbo = .false. - if(index(levelstring,'_dev').ne.0)then + if (index(levelstring,'_dev') .ne. 0) then self%other = '-grad' - self%rdgrad=.true. - endif + self%rdgrad = .true. + end if case ('orca') self%id = jobtype%orca diff --git a/src/calculator/calculator.F90 b/src/calculator/calculator.F90 index e1222f4b..4cd1695e 100644 --- a/src/calculator/calculator.F90 +++ b/src/calculator/calculator.F90 @@ -298,7 +298,7 @@ subroutine engrad_mol(mol,calc,energy,gradient,iostatus) call calc%freezegrad(gradient) if (calc%do_HU) then - call calc%chess%update(gradient, energy, mol%xyz) + call calc%chess%update(gradient,energy,mol%xyz) end if return @@ -402,7 +402,7 @@ subroutine numgrad_core(molptr,calc,id,iostatus) integer :: i,j,k,l,ich,och,io,pnat type(coord),allocatable :: moltmp - real(wp) :: energy,el,er, step,step2 + real(wp) :: energy,el,er,step,step2 real(wp),allocatable :: ngrd(:,:) !real(wp),parameter :: step = 0.0005_wp !real(wp),parameter :: step2 = 0.5_wp/step @@ -414,13 +414,13 @@ subroutine numgrad_core(molptr,calc,id,iostatus) step = calc%calcs(id)%gradstep step2 = 0.5_wp/step - !> back up energy + !> back up energy energy = calc%etmp(id) !> allocate temprorary gradient space !$omp critical - allocate(ngrd(3,pnat), source=0.0_wp) - allocate(moltmp, source=molptr) + allocate (ngrd(3,pnat),source=0.0_wp) + allocate (moltmp,source=molptr) !$omp end critical do i = 1,molptr%nat @@ -441,8 +441,8 @@ subroutine numgrad_core(molptr,calc,id,iostatus) !> transfer tmp gradient to the calc object calc%grdtmp(:,1:pnat,id) = ngrd(:,1:pnat) !$omp critical - deallocate(moltmp) - deallocate(ngrd) + deallocate (moltmp) + deallocate (ngrd) !$omp end critical !> restore the energy diff --git a/src/calculator/hessian_reconstruct.f90 b/src/calculator/hessian_reconstruct.f90 index 611e90ff..80e54e56 100644 --- a/src/calculator/hessian_reconstruct.f90 +++ b/src/calculator/hessian_reconstruct.f90 @@ -7,59 +7,137 @@ module hessian_reconstruct type :: cashed_hessian - integer :: steps = 10 - real(wp), allocatable :: gradient(:,:,:) - real(wp), allocatable :: coords(:,:,:) - real(wp), allocatable :: energy(:) - real(wp), allocatable :: order(:) - integer :: stepcount = 0 + integer :: steps = 10 + real(wp),allocatable :: gradient(:,:,:) + real(wp),allocatable :: coords(:,:,:) + real(wp),allocatable :: energy(:) + real(wp),allocatable :: s(:,:),y(:,:),B(:,:),H(:,:),p(:),rho(:),V(:,:,:),I(:,:) + integer,allocatable :: order(:),natm + integer :: stepcount = 0 contains - procedure :: alloc => cashed_hessian_allocate - procedure :: dealloc => cashed_hessian_deallocate - procedure :: update => update_cashed_hessian + procedure :: alloc => cashed_hessian_allocate + procedure :: dealloc => cashed_hessian_deallocate + procedure :: update => update_cashed_hessian + procedure :: construct_hessian_lbfgs + procedure :: compute_intermediates - end type cashed_hessian + end type cashed_hessian contains -subroutine cashed_hessian_allocate(self, N, steps) -integer, intent(in) :: N, steps -class(cashed_hessian) :: self - -self%steps = steps -allocate(self%gradient(steps,3,N)) -allocate(self%coords(steps,3,N)) -allocate(self%energy(steps)) -allocate(self%order(steps)) - -self%order(:) = 0.0_wp - -end subroutine cashed_hessian_allocate - -subroutine cashed_hessian_deallocate(self) -class(cashed_hessian) :: self - -if(allocated(self%gradient)) deallocate(self%gradient) -if(allocated(self%coords)) deallocate(self%coords) -if(allocated(self%energy)) deallocate(self%energy) -if(allocated(self%order)) deallocate(self%order) - -end subroutine cashed_hessian_deallocate - -subroutine update_cashed_hessian(self, gradient, energy, coords) -class(cashed_hessian) :: self -real(wp), intent(in) :: gradient(:,:), energy, coords(:,:) -integer :: idx - -self%stepcount = self%stepcount + 1 -idx = minloc(self%order,1) -self%order(idx) = self%stepcount -self%gradient(idx,:,:) = gradient -self%energy(idx) = energy -self%coords(idx,:,:) = coords - -end subroutine update_cashed_hessian - -end module hessian_reconstruct \ No newline at end of file + subroutine cashed_hessian_allocate(self,N,steps) + integer,intent(in) :: N,steps + class(cashed_hessian),intent(inout) :: self + + self%steps = steps + allocate (self%gradient(steps,3,N)) + allocate (self%coords(steps,3,N)) + allocate (self%energy(steps)) + allocate (self%order(steps)) + allocate (self%s(self%steps-1,3*self%natm)) + allocate (self%y(self%steps-1,3*self%natm)) + allocate (self%p(self%steps-1)) + allocate (self%rho(self%steps-1)) + allocate (self%V(self%steps-1,3*self%natm,3*self%natm)) + allocate (self%I(3*self%natm,3*self%natm)) + self%natm = N + + self%order(:) = 0 + + end subroutine cashed_hessian_allocate + + subroutine cashed_hessian_deallocate(self) + class(cashed_hessian),intent(inout) :: self + + if (allocated(self%gradient)) deallocate (self%gradient) + if (allocated(self%coords)) deallocate (self%coords) + if (allocated(self%energy)) deallocate (self%energy) + if (allocated(self%order)) deallocate (self%order) + + end subroutine cashed_hessian_deallocate + + subroutine update_cashed_hessian(self,gradient,energy,coords) + class(cashed_hessian),intent(inout) :: self + real(wp),intent(in) :: gradient(:,:),energy,coords(:,:) + integer :: idx + + self%stepcount = self%stepcount+1 + idx = minloc(self%order,1) + self%order(idx) = self%stepcount + self%gradient(idx,:,:) = gradient + self%energy(idx) = energy + self%coords(idx,:,:) = coords + + end subroutine update_cashed_hessian + + recursive subroutine construct_hessian_lbfgs(self,n) + class(cashed_hessian),intent(inout) :: self + integer,intent(in) :: n + real(wp),allocatable :: temp(:,:) + + allocate (temp(3*self%natm,3*self%natm)) + if (n == 0) then + call self%compute_intermediates() + allocate (self%B(3*self%natm,3*self%natm)) + self%B = self%I + else + call self%construct_hessian_lbfgs(n-1) + temp = matmul(matmul(TRANSPOSE(self%V(n,:,:)),self%B),self%V(n,:,:))-self%p(n)*(matmul(reshape(self%s(n,:), [3*self%natm,1]),reshape(self%s(n,:), [1,3*self%natm]))) + self%B = temp + end if + + end subroutine construct_hessian_lbfgs + + subroutine compute_intermediates(self) + class(cashed_hessian),intent(inout) :: self + integer :: i,j,k + real(wp), allocatable :: tmp(:),tmp_coords(:,:),tmp_grads(:,:) + + allocate (tmp_coords(self%steps,3*self%natm)) + allocate (tmp_grads(self%steps,3*self%natm)) + allocate (tmp(self%steps)) + allocate (self%s(self%steps-1,3*self%natm)) + allocate (self%y(self%steps-1,3*self%natm)) + allocate (self%p(self%steps-1)) + allocate (self%rho(self%steps-1)) + allocate (self%V(self%steps-1,3*self%natm,3*self%natm)) + allocate (self%I(3*self%natm,3*self%natm)) + + tmp = self%order + self%I = 0.0_wp + + do k = 1,3*self%natm + self%I(k,k) = 1.0_wp + end do + + tmp_coords = reshape(self%coords,[self%steps,3*self%natm]) + tmp_grads = reshape(self%gradient,[self%steps,3*self%natm]) + + if (minval(tmp) == 0) then + print*,"ERROR: Number of recursive steps for hessian reconstruction larger than number of geoemtry optimization steps!" + else + do i = 1,self%steps + if (i == 1) then + j = minloc(tmp,1) + tmp(j) = HUGE(tmp(j)) + else + j = minloc(tmp,1) + if (j == 1) then + self%s(i-1,:) = tmp_coords(j,:)-tmp_coords(self%steps,:) + self%y(i-1,:) = tmp_grads(j,:)-tmp_grads(self%steps,:) + else + self%s(i-1,:) = tmp_coords(j,:)-tmp_coords(j-1,:) + self%y(i-1,:) = tmp_grads(j,:)-tmp_grads(j-1,:) + end if + self%p(i-1) = 1/(dot_product(self%y(i-1,:),self%s(i-1,:))) + self%V(i-1,:,:) = self%I-self%p(i-1)*(matmul(reshape(self%y(i-1,:), [3*self%natm,1]),reshape(self%s(i-1,:), [1,3*self%natm]))) + tmp(j) = HUGE(tmp(j)) + end if + end do + end if + + end subroutine compute_intermediates + +end module hessian_reconstruct diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index fbe92d57..40114060 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -107,8 +107,9 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) if (calc%do_HU) then call calc%chess%dealloc() + deallocate(calc%chess) endif - + return end subroutine optimize_geometry From e4c66880aefde52ebbf3ce914a2e01c98fce6822 Mon Sep 17 00:00:00 2001 From: Lukas Rindt Date: Fri, 28 Nov 2025 12:23:04 +0100 Subject: [PATCH 097/374] lbfgs implemented and tested with random numbers --- src/calculator/hessian_reconstruct.f90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/calculator/hessian_reconstruct.f90 b/src/calculator/hessian_reconstruct.f90 index 80e54e56..2c58f581 100644 --- a/src/calculator/hessian_reconstruct.f90 +++ b/src/calculator/hessian_reconstruct.f90 @@ -55,6 +55,12 @@ subroutine cashed_hessian_deallocate(self) if (allocated(self%coords)) deallocate (self%coords) if (allocated(self%energy)) deallocate (self%energy) if (allocated(self%order)) deallocate (self%order) + if (allocated(self%s)) deallocate (self%s) + if (allocated(self%y)) deallocate (self%y) + if (allocated(self%p)) deallocate (self%p) + if (allocated(self%rho)) deallocate (self%rho) + if (allocated(self%V)) deallocate (self%V) + if (allocated(self%I)) deallocate (self%I) end subroutine cashed_hessian_deallocate @@ -84,7 +90,7 @@ recursive subroutine construct_hessian_lbfgs(self,n) self%B = self%I else call self%construct_hessian_lbfgs(n-1) - temp = matmul(matmul(TRANSPOSE(self%V(n,:,:)),self%B),self%V(n,:,:))-self%p(n)*(matmul(reshape(self%s(n,:), [3*self%natm,1]),reshape(self%s(n,:), [1,3*self%natm]))) + temp = matmul(matmul(TRANSPOSE(self%V(n,:,:)),self%B),self%V(n,:,:))+self%p(n)*(matmul(reshape(self%s(n,:), [3*self%natm,1]),reshape(self%s(n,:), [1,3*self%natm]))) self%B = temp end if @@ -93,17 +99,11 @@ end subroutine construct_hessian_lbfgs subroutine compute_intermediates(self) class(cashed_hessian),intent(inout) :: self integer :: i,j,k - real(wp), allocatable :: tmp(:),tmp_coords(:,:),tmp_grads(:,:) + real(wp),allocatable :: tmp(:),tmp_coords(:,:),tmp_grads(:,:) allocate (tmp_coords(self%steps,3*self%natm)) allocate (tmp_grads(self%steps,3*self%natm)) allocate (tmp(self%steps)) - allocate (self%s(self%steps-1,3*self%natm)) - allocate (self%y(self%steps-1,3*self%natm)) - allocate (self%p(self%steps-1)) - allocate (self%rho(self%steps-1)) - allocate (self%V(self%steps-1,3*self%natm,3*self%natm)) - allocate (self%I(3*self%natm,3*self%natm)) tmp = self%order self%I = 0.0_wp @@ -112,8 +112,8 @@ subroutine compute_intermediates(self) self%I(k,k) = 1.0_wp end do - tmp_coords = reshape(self%coords,[self%steps,3*self%natm]) - tmp_grads = reshape(self%gradient,[self%steps,3*self%natm]) + tmp_coords = reshape(self%coords, [self%steps,3*self%natm]) + tmp_grads = reshape(self%gradient, [self%steps,3*self%natm]) if (minval(tmp) == 0) then print*,"ERROR: Number of recursive steps for hessian reconstruction larger than number of geoemtry optimization steps!" From 1061b2acdab005d13522fdce0838d834564d0a21 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 28 Nov 2025 20:39:28 +0100 Subject: [PATCH 098/374] cont'd QCG refactor --- src/confparse.f90 | 64 +++++++----- src/qcg/qcg_main.f90 | 230 +++++++++++++++++------------------------- src/qcg/qcg_misc.f90 | 114 ++++++++++++++++++++- src/qcg/qcg_utils.f90 | 15 +++ 4 files changed, 256 insertions(+), 167 deletions(-) diff --git a/src/confparse.f90 b/src/confparse.f90 index 831ef7ad..81effe30 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -332,9 +332,9 @@ subroutine parseflags(env,arg,nra) env%preopt = .true. !>--- check for (TOML) input file call find_input_file(arg,nra,idum) - if(idum.ne.0)then + if (idum .ne. 0) then call parseinputfile(env,trim(arg(idum))) - endif + end if !>--- first arg loop do i = 1,nra @@ -847,14 +847,7 @@ subroutine parseflags(env,arg,nra) else call inputcoords(env,trim(arg(1))) end if -!========================================================================================! -!> after this point there should always be a "coord" file present -!========================================================================================! - if(.not.allocated(env%includeRMSD))then - allocate (env%includeRMSD(env%nat)) - env%includeRMSD = 1 - endif - + !========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>! !> parse the input flags @@ -1266,21 +1259,21 @@ subroutine parseflags(env,arg,nra) end if case ('-efield') !> electric field in V/Ang, only compatibe with tblite - if(.not.allocated(env%ref%efield)) allocate(env%ref%efield(3), source=0.0_wp) + if (.not.allocated(env%ref%efield)) allocate (env%ref%efield(3),source=0.0_wp) if (nra >= i+3) then ctmp = trim(arg(i+1)) - read(ctmp,*,iostat=io) env%ref%efield(1) - ctmp = trim(arg(i+2)) - read(ctmp,*,iostat=io) env%ref%efield(2) - ctmp = trim(arg(i+3)) - read(ctmp,*,iostat=io) env%ref%efield(3) - write(stdout,'(" --efield: ",3(1x,es10.3)," V/Å")') env%ref%efield(1:3) + read (ctmp,*,iostat=io) env%ref%efield(1) + ctmp = trim(arg(i+2)) + read (ctmp,*,iostat=io) env%ref%efield(2) + ctmp = trim(arg(i+3)) + read (ctmp,*,iostat=io) env%ref%efield(3) + write (stdout,'(" --efield: ",3(1x,es10.3)," V/Å")') env%ref%efield(1:3) else - write(stdout,'(a)') - endif + write (stdout,'(a)') + end if - case ('-ceh_guess') - env%ceh_guess=.true. + case ('-ceh_guess') + env%ceh_guess = .true. case ('-dscal','-dispscal','-dscal_global','-dispscal_global') env%cts%dispscal_md = .true. @@ -2314,14 +2307,14 @@ subroutine parseflags(env,arg,nra) !>--- pass on other settings (from cli) to new calculator if (.not.env%legacy) then call env2calc_modify(env) - endif + end if !>--- important printouts if (.not.env%legacy) then - if (env%crestver .ne. crest_sorting) then - call env%calc%info(stdout) - end if + if (env%crestver .ne. crest_sorting) then + call env%calc%info(stdout) + end if call print_frozen(env) end if @@ -2517,7 +2510,8 @@ subroutine inputcoords(env,arg) character(len=:),allocatable :: arg2 type(coord) :: mol type(zmolecule) :: zmol - integer :: i + integer :: i,idiff + integer,allocatable :: tmpinclude(:) !>--- Redirect for QCG input reading if (env%QCG) then @@ -2602,6 +2596,24 @@ subroutine inputcoords(env,arg) env%protb%nfrag = zmol%nfrag call zmol%deallocate() +!>--- Repair logic of includeRMSD array (especially for something like QCG) + if (.not.allocated(env%includeRMSD)) then + allocate (env%includeRMSD(env%ref%nat)) + env%includeRMSD(:) = 1 + else + !> assuming if the current includeRMSD is smaller than the + !> current system we have *appended* some atoms + idiff = size(env%includeRMSD,1) + if (idiff < env%ref%nat) then + allocate (tmpinclude(env%ref%nat),source=1) + do i = 1,idiff + tmpinclude(i) = env%includeRMSD(i) + end do + !deallocate(env%includeRMSD) + call move_alloc(tmpinclude,env%includeRMSD) + end if + end if + return end subroutine inputcoords diff --git a/src/qcg/qcg_main.f90 b/src/qcg/qcg_main.f90 index d7a7f7a7..b1c2f98d 100644 --- a/src/qcg/qcg_main.f90 +++ b/src/qcg/qcg_main.f90 @@ -790,38 +790,34 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) use utilities implicit none - type(systemdata) :: env - type(coord_qcg) :: solu,solv,clus - type(ensemble) :: ens,dum - type(timer) :: tim - - integer :: i,j,k - integer :: io,f,r,ich,T,Tn - integer :: minpos - character(len=512) :: thispath,resultspath,tmppath,tmppath2 - character(len=512) :: scratchdir_tmp - character(len=512) :: jobcall - character(len=256) :: inpnam,outnam - character(len=80) :: fname,pipe,to - character(len=*) :: fname_results - character(len=64) :: comment - character(len=20) :: gfnver_tmp - character(len=LEN(env%solv)) :: solv_tmp - logical :: gbsa_tmp - logical :: ex,mdfail,e_there - logical :: checkiso_tmp,cbonds_tmp - real(wp),allocatable :: e_fix(:),e_clus(:) - real(wp) :: S,H,G,dens,shr,shr_av - real(wp) :: sasa - real(wp) :: newtemp,newmdtime,newmdstep,newhmass - real(wp) :: newmetadlist,newmetadexp,newmetadfac - real(wp) :: optlev_tmp - real(wp) :: e0 - real(wp),allocatable :: de(:) - real(wp),allocatable :: p(:) - integer :: ich98,ich65,ich48 - logical :: not_param = .false. - type(timer) :: tim_dum !Dummy timer to avoid double counting + type(systemdata) :: env + type(coord_qcg) :: solu,solv,clus + type(ensemble) :: ens,dum + type(timer) :: tim + + integer :: i,j,k,io,f,r,ich,T,Tn,minpos + character(len=512) :: thispath,resultspath,tmppath,tmppath2 + character(len=512) :: scratchdir_tmp + character(len=512) :: jobcall + character(len=256) :: inpnam,outnam + character(len=80) :: fname,pipe,to + character(len=*) :: fname_results + character(len=64) :: comment + character(len=:),allocatable :: gfnver_tmp + character(len=:),allocatable :: solv_tmp + logical :: gbsa_tmp,ex,mdfail,e_there,checkiso_tmp,cbonds_tmp + real(wp),allocatable :: e_fix(:),e_clus(:) + real(wp) :: S,H,G,dens,shr,shr_av + real(wp) :: sasa + real(wp) :: newtemp,newmdtime,newmdstep,newhmass + real(wp) :: newmetadlist,newmetadexp,newmetadfac + real(wp) :: optlev_tmp + real(wp) :: e0 + real(wp),allocatable :: de(:) + real(wp),allocatable :: p(:) + integer :: ich98,ich65,ich48 + logical :: not_param = .false. + type(timer) :: tim_dum !Dummy timer to avoid double counting type(calcdata) :: calc_tmp logical,parameter :: debug = .true. @@ -840,7 +836,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) call getcwd(resultspath) call chdirdbug(thispath) -!--- Setting defaults +!--- Setting defaults and backups env%cts%NCI = .true. !Activating to have wall pot. written in coord file for xtb optlev_tmp = env%optlev env%optlev = 0.0d0 @@ -913,17 +909,12 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) !---------------------------------------------------------------- ! Case selection of normal Crest, MD or MTD !---------------------------------------------------------------- - if (debug) then - write (*,*) 'Entering sampling part next. We have these constraints:' - call env%cts%info() - write (*,*) ' for structure:' - call clus%append(stdout) - end if + !> Parse contraints (wall potentials etc.) into new calculator + !> if we are using it. if (.not.env%legacy) then calc_tmp = env%calc - call parse_constraints_from_cts(env%calc,clus,env%cts) - call env%calc%info(stdout) + call qcg_envcalc_reinit(env,clus,.true.,.true.) end if ENSEMBLEGEN:select case(env%ensemble_method) @@ -970,26 +961,40 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) env%QCG = .true. !--- Optimization with gfn2 if necessary - if (env%final_gfn2_opt) then + if (env%final_gfn2_opt.and.env%gfnver .ne. '--gfn2') then gfnver_tmp = env%gfnver -! if (env%gfnver .ne. '--gfn2') then write (stdout,'(2x,a)') 'GFN2-xTB optimization' env%gfnver = '--gfn2' - call rmrf('OPTIM') - call multilevel_opt(env,99) + + if (.not.env%legacy) then + !> reinit calculator with GFN2 + call qcg_envcalc_reinit(env,clus,.true.,.true.) + call checkname_xyz(crefile,inpnam,outnam) + call crest_multilevel_wrap(env,trim(inpnam),0) + else + call rmrf('OPTIM') + call multilevel_opt(env,99) + end if + write (stdout,*) end if -!--- Final optimization without potentials - call rmrf('OPTIM') +!--- Final optimization without wall potentials env%optlev = 1.0d0 !Higher precision for less scattering env%cts%NCI = .false. !Dactivating the wall pot. env%cts%pots = '' deallocate (env%cts%pots) - call multilevel_opt(env,99) - stop !TODO TODO TODO TODO + if (.not.env%legacy) then + !> wall potential was turned off, add any other constraint back in + call qcg_envcalc_reinit(env,clus,.true.,.true.) + call checkname_xyz(crefile,inpnam,outnam) + call crest_multilevel_wrap(env,trim(inpnam),0) + else + call rmrf('OPTIM') + call multilevel_opt(env,99) + end if - !Clustering to exclude similar structures if requested with -cluster +!--- Clustering to exclude similar structures if requested with -cluster if (env%properties == 70) then write (stdout,'(3x,''Clustering the remaining structures'')') call checkname_xyz(crefile,inpnam,outnam) @@ -1009,72 +1014,19 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) allocate (clus%at(clus%nat)) allocate (clus%xyz(3,clus%nat)) -!------------------------------------------------------------- -! SP with GBSA model and without wall potentials -!------------------------------------------------------------- - !--- Write folder with xyz-coordinates - do i = 1,ens%nall - call rdxmolselec('ensemble.xyz',i,clus%nat,clus%at,clus%xyz) - write (to,'("TMPSP",i0)') i - io = makedir(trim(to)) - call copysub('.UHF',to) - call copysub('.CHRG',to) - call chdirdbug(to) - call wrxyz('cluster.xyz',clus%nat,clus%at,clus%xyz*bohr) - call chdirdbug(tmppath2) - end do - !--- SP - write (stdout,*) - call ens_sp(env,'cluster.xyz',ens%nall,'TMPSP') - !--- Getting energy - do i = 1,ens%nall - call rdxmolselec('ensemble.xyz',i,clus%nat,clus%at,clus%xyz) - write (to,'("TMPSP",i0)') i - call chdirdbug(to) - call grepval('xtb_sp.out','| TOTAL ENERGY',e_there,ens%er(i)) - call chdirdbug(tmppath2) - end do - - if (.not.e_there) then - write (stdout,*) - write (stdout,*) 'Energy not found. Error in xTB computations occured' - call chdirdbug(to) - call minigrep('xtb_sp.out','solv_model_loadInternalParam',not_param) - call chdirdbug(tmppath2) - if (not_param) then - write (stdout,*) ' !!!WARNIG: CHOSEN SOLVENT NOT PARAMETERIZED & - & FOR IMPLICIT SOLVATION MODEL!!!' - write (stdout,'('' CHECK IF '',A,'' IS AVAILABLE IN xTB'')') env%solv - write (stdout,*) ' PLEASE RESTART THE ENSEMBLE GENERATION WITH AVAILABLE& - & PARAMETERIZATION IF YOU NEED ENERGIES' - call copysub('crest_conformers.xyz',resultspath) - write (stdout,*) ' The enesemble can be found in the directory& - & as ' - error stop - end if - end if - env%gfnver = gfnver_tmp - call ens%write('full_ensemble.xyz') +!------------------------------------------------------------- +! SP with Implicit solvation model and without wall potentials +!------------------------------------------------------------- -!--- crest_best structure - minpos = minloc(ens%er,dim=1) - write (to,'("TMPSP",i0)') minpos - call chdirdbug(to) - call rdxmol('cluster.xyz',clus%nat,clus%at,clus%xyz) - call chdirdbug(tmppath2) - write (comment,'(F20.8)') ens%er(minpos) - inquire (file='crest_best.xyz',exist=ex) - if (ex) then - call rmrf('crest_best.xyz') !remove crest_best from - end if - call wrxyz('crest_best.xyz',clus%nat,clus%at,clus%xyz,comment) + call ens_sp_with_io(env,ens,clus,resultspath) + stop !TODO TODO TODO TODO !------------------------------------------------------------- ! Processing results !------------------------------------------------------------- - + env%gfnver = gfnver_tmp allocate (e_fix(ens%nall)) allocate (e_clus(ens%nall)) @@ -1175,8 +1127,8 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) !--- Getting G,S,H write (stdout,*) - write (stdout,'(2x,''------------------------------------------------------------------------'')') - write (stdout,'(2x,''------------------------------------------------------------------------'')') + write (stdout,'(2x,70("-"))') + write (stdout,'(2x,70("-"))') write (stdout,'(2x,''Boltz. averaged energy of final cluster:'')') call aver(.true.,env,ens%nall,e_clus(1:ens%nall),S,H,G,sasa,.false.) write (stdout,'(7x,''G /Eh :'',F14.8)') G/autokcal @@ -1364,7 +1316,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) call pr_qcg_fill() write (stdout,'(2x,''now adding solvents to fill cluster...'')') call pr_fill_energy() - write (stdout,'(2x,''------------------------------------------------------------------------'')') + write (stdout,'(2x,70("-"))') nat_frag1 = env%nsolv*solv%nat iter = 0 @@ -1482,7 +1434,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) nat_tot = nat_tot+solv%nat end if - write (stdout,'(2x,''------------------------------------------------------------------------'')') + write (stdout,'(2x,70("-"))') !--- Or if maximum solvent is added if (iter-nsolv .eq. v_ratio) then write (stdout,'(2x,''volume filled'')') @@ -1907,34 +1859,34 @@ subroutine qcg_eval(env,solu,solu_ens,solv_ens) use qcg_utils implicit none - type(systemdata) :: env - type(coord_qcg) :: solu - type(ensemble) :: solu_ens,solv_ens + type(systemdata) :: env + type(coord_qcg) :: solu + type(ensemble) :: solu_ens,solv_ens - character(len=512) :: thispath + character(len=512) :: thispath - integer :: i,j - integer :: srange - integer :: freqscal - real(wp) :: g1(solu_ens%nall) - real(wp) :: g2(solv_ens%nall) - real(wp) :: g3 - real(wp) :: Gsolv(20) - real(wp) :: Hsolv - real(wp) :: G_solute(20) - real(wp) :: H_solute - real(wp) :: G_solvent(20) - real(wp) :: H_solvent - real(wp) :: G_mono(20) - real(wp) :: H_mono - real(wp) :: S(20) - real(wp) :: volw - real(wp) :: sasa - real(wp) :: dum,dum1,dum2 - real(wp) :: e_solute(solu_ens%nall) - real(wp) :: e_solvent(solv_ens%nall) - real(wp) :: scal(20) - integer :: ich23 + integer :: i,j + integer :: srange + integer :: freqscal + real(wp) :: g1(solu_ens%nall) + real(wp) :: g2(solv_ens%nall) + real(wp) :: g3 + real(wp) :: Gsolv(20) + real(wp) :: Hsolv + real(wp) :: G_solute(20) + real(wp) :: H_solute + real(wp) :: G_solvent(20) + real(wp) :: H_solvent + real(wp) :: G_mono(20) + real(wp) :: H_mono + real(wp) :: S(20) + real(wp) :: volw + real(wp) :: sasa + real(wp) :: dum,dum1,dum2 + real(wp) :: e_solute(solu_ens%nall) + real(wp) :: e_solvent(solv_ens%nall) + real(wp) :: scal(20) + integer :: ich23 call pr_eval_eval() diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index e54e5bef..a8864dfe 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -765,6 +765,80 @@ end subroutine cff_opt ! ! xTB SP performed in parallel !___________________________________________________________________________________ +subroutine ens_sp_with_io(env,ens,clus,resultspath) + use crest_parameters + use crest_data + use qcg_coord_type + use strucrd + use iomod + implicit none + type(systemdata),intent(inout) :: env + type(ensemble),intent(inout) :: ens + type(coord_qcg),intent(inout) :: clus + character(len=512),intent(in) :: resultspath + character(len=512) :: tmppath2,to,comment + integer :: i,io,minpos + logical :: e_there,not_param,ex + + call getcwd(tmppath2) + + !--- Write folder with xyz-coordinates + do i = 1,ens%nall + call rdxmolselec('ensemble.xyz',i,clus%nat,clus%at,clus%xyz) + write (to,'("TMPSP",i0)') i + io = makedir(trim(to)) + call copysub('.UHF',to) + call copysub('.CHRG',to) + call chdirdbug(to) + call wrxyz('cluster.xyz',clus%nat,clus%at,clus%xyz*bohr) + call chdirdbug(tmppath2) + end do + !--- SP + write (stdout,*) + call ens_sp(env,'cluster.xyz',ens%nall,'TMPSP') + !--- Getting energy + do i = 1,ens%nall + call rdxmolselec('ensemble.xyz',i,clus%nat,clus%at,clus%xyz) + write (to,'("TMPSP",i0)') i + call chdirdbug(to) + call grepval('xtb_sp.out','| TOTAL ENERGY',e_there,ens%er(i)) + call chdirdbug(tmppath2) + end do + + if (.not.e_there) then + write (stdout,*) + write (stdout,*) 'Energy not found. Error in xTB computations occured' + call chdirdbug(to) + call minigrep('xtb_sp.out','solv_model_loadInternalParam',not_param) + call chdirdbug(tmppath2) + if (not_param) then + write (stdout,*) ' !!!WARNIG: CHOSEN SOLVENT NOT PARAMETERIZED & + & FOR IMPLICIT SOLVATION MODEL!!!' + write (stdout,'('' CHECK IF '',A,'' IS AVAILABLE IN xTB'')') env%solv + write (stdout,*) ' PLEASE RESTART THE ENSEMBLE GENERATION WITH AVAILABLE& + & PARAMETERIZATION IF YOU NEED ENERGIES' + call copysub('crest_conformers.xyz',resultspath) + write (stdout,*) ' The enesemble can be found in the directory& + & as ' + error stop + end if + end if + call ens%write('full_ensemble.xyz') + +!--- crest_best structure + minpos = minloc(ens%er,dim=1) + write (to,'("TMPSP",i0)') minpos + call chdirdbug(to) + call rdxmol('cluster.xyz',clus%nat,clus%at,clus%xyz) + call chdirdbug(tmppath2) + write (comment,'(F20.8)') ens%er(minpos) + inquire (file='crest_best.xyz',exist=ex) + if (ex) then + call rmrf('crest_best.xyz') !remove crest_best from + end if + call wrxyz('crest_best.xyz',clus%nat,clus%at,clus%xyz,trim(comment)) + +end subroutine ens_sp_with_io subroutine ens_sp(env,fname,NTMP,TMPdir) use crest_parameters @@ -788,7 +862,9 @@ subroutine ens_sp(env,fname,NTMP,TMPdir) ! setting the threads for correct parallelization call new_ompautoset(env,'auto',NTMP,T,Tn) - write (stdout,'(2x,''Single point computation with GBSA model'')') + write (stdout,'(2x,''---------------------------------------------'')') + write (stdout,'(2x,''Single point computation with GBSA/ALPB model'')') + write (stdout,'(2x,''---------------------------------------------'')') write (stdout,'(2x,i0,'' jobs to do.'')') NTMP pipe = '2>/dev/null' @@ -1105,7 +1181,7 @@ end subroutine get_interaction_E subroutine chdirdbug(path) implicit none character(len=*),intent(in) :: path - logical,parameter :: debug = .true. + logical,parameter :: debug = .false. character(len=500) :: debugpath call chdir(path) if (debug) then @@ -1114,3 +1190,37 @@ subroutine chdirdbug(path) end if end subroutine chdirdbug +!===============================================================================! +subroutine qcg_envcalc_reinit(env,mol,addconstraints,printinfo) + use crest_parameters + use crest_data + use qcg_coord_type + use strucrd + use parse_xtbinput + implicit none + type(systemdata),intent(inout) :: env + type(coord),intent(inout) :: mol + logical,intent(in) :: addconstraints + logical,intent(in) :: printinfo + + !> clear old data + if (allocated(env%calc%calcs)) deallocate (env%calc%calcs) + env%calc%ncalculations = 0 + + !> and re-initialize + call env2calc(env,env%calc,mol) + + !> add constraints from 'cts' if we want this + if (addconstraints) then + if (allocated(env%calc%cons)) deallocate (env%calc%cons) + env%calc%nconstraints = 0 + call parse_constraints_from_cts(env%calc,mol,env%cts) + end if + + !> do a printout to stdout, if selected + if (printinfo) then + call env%calc%info(stdout) + end if + +end subroutine qcg_envcalc_reinit + diff --git a/src/qcg/qcg_utils.f90 b/src/qcg/qcg_utils.f90 index 72a6470b..4d1de82a 100644 --- a/src/qcg/qcg_utils.f90 +++ b/src/qcg/qcg_utils.f90 @@ -775,5 +775,20 @@ subroutine rdxtbiffE(fname,m,n,e) m = j-1 end subroutine rdxtbiffE +!==============================================================================! + + + + + + + + + + + + + + !==============================================================================! end module qcg_utils From 4136f8d394e0c5b2e47ddd86763d74c1fd036b91 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 30 Nov 2025 21:14:09 +0100 Subject: [PATCH 099/374] Working qcg-ensemble refactor --- src/algos/parallel.f90 | 1 + src/parsing/parse_xtbinput.f90 | 1 + src/qcg/qcg_main.f90 | 68 +++++++++++++++++++++------------- src/qcg/qcg_utils.f90 | 52 ++++++++------------------ src/strucreader.f90 | 68 +++++++++++++++++++++++----------- 5 files changed, 107 insertions(+), 83 deletions(-) diff --git a/src/algos/parallel.f90 b/src/algos/parallel.f90 index e245ccf6..8590fe70 100644 --- a/src/algos/parallel.f90 +++ b/src/algos/parallel.f90 @@ -80,6 +80,7 @@ subroutine crest_sploop(env,nat,nall,at,xyz,eread) !* subroutine crest_sploop !* This subroutine performs concurrent singlepoint evaluations !* for the given ensemble. Input eread is overwritten +!* xyz must be in Bohrs !*************************************************************** use crest_parameters,only:wp,stdout,sep use crest_calculator diff --git a/src/parsing/parse_xtbinput.f90 b/src/parsing/parse_xtbinput.f90 index 9ee56ade..8f794196 100644 --- a/src/parsing/parse_xtbinput.f90 +++ b/src/parsing/parse_xtbinput.f90 @@ -266,6 +266,7 @@ subroutine get_xtb_constraint_block(calc,mol,blk) call calc%add(cons) if (debug) call cons%print(stdout) end if + case ('atoms') if (.not.allocated(pairwise)) allocate (pairwise(mol%nat),source=.false.) call get_atlist(mol%nat,atlist,kv%rawvalue,mol%at) diff --git a/src/qcg/qcg_main.f90 b/src/qcg/qcg_main.f90 index b1c2f98d..b429d584 100644 --- a/src/qcg/qcg_main.f90 +++ b/src/qcg/qcg_main.f90 @@ -1013,22 +1013,32 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) clus%nat = ens%nat allocate (clus%at(clus%nat)) allocate (clus%xyz(3,clus%nat)) - - + write (stdout,'(1x,i0,a)') ens%nall,' structures remaining.' + write (stdout,*) !------------------------------------------------------------- ! SP with Implicit solvation model and without wall potentials !------------------------------------------------------------- + if (env%legacy) then + !> old, I/O-heavy version + call ens_sp_with_io(env,ens,clus,resultspath) + else + !> use internal parallel loop, but remember to convert to Bohrs for that + clus%at(:) = ens%at(:) + clus%xyz(1:3,1:clus%nat) = ens%xyz(1:3,1:ens%nat,1)*aatoau + call qcg_envcalc_reinit(env,clus,.true.,.true.) - call ens_sp_with_io(env,ens,clus,resultspath) + ens%xyz = ens%xyz*aatoau + call crest_sploop(env,ens%nat,ens%nall,ens%at,ens%xyz,ens%er) + ens%xyz = ens%xyz*autoaa + end if - stop !TODO TODO TODO TODO !------------------------------------------------------------- ! Processing results !------------------------------------------------------------- - env%gfnver = gfnver_tmp - allocate (e_fix(ens%nall)) - allocate (e_clus(ens%nall)) + env%gfnver = gfnver_tmp + allocate (e_fix(ens%nall),source=0.0_wp) + allocate (e_clus(ens%nall),source=0.0_wp) call pr_ensemble_energy() @@ -1037,13 +1047,19 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) !--- Fixation energy of optimization do i = 1,ens%nall - call chdirdbug('OPTIM') - write (to,'("TMPCONF",i0)') i - call chdirdbug(to) - call grepval('xtb.out',' :: add. restraining',e_there,e_fix(i)) - call chdirdbug(tmppath2) + if (env%legacy) then + !> old I/O-heady version + call chdirdbug('OPTIM') + write (to,'("TMPCONF",i0)') i + call chdirdbug(to) + call grepval('xtb.out',' :: add. restraining',e_there,e_fix(i)) + call chdirdbug(tmppath2) + call rdxmolselec('full_ensemble.xyz',i,clus%nat,clus%at,clus%xyz) + else + !> quicker version, simply load from 'ens' + call ens%get_mol(i,clus) + end if - call rdxmolselec('full_ensemble.xyz',i,clus%nat,clus%at,clus%xyz) call get_sphere(.false.,clus,.false.) dens = 0.001*(solu%mass+env%nsolv*solv%mass)/(1.0d-30*clus%vtot*bohr**3) if (env%solv_md) then @@ -1054,7 +1070,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) write (ich98,'(i4,F20.10,3x,f8.1)') env%nsolv,ens%er(i),clus%atot write (stdout,'(x,i4,4x,F13.6,2x,f6.3,1x,f8.3,2x,2f6.1,3x,f8.1,3x,a)') & & i,ens%er(i),dens,e_fix(i),shr_av,shr,clus%atot,trim(optlevflag(env%optlev)) - e_fix(i) = e_fix(i)*autokcal/sqrt(float(clus%nat)) + e_fix(i) = e_fix(i)*autokcal/sqrt(real(clus%nat,wp)) end do close (ich98) call copysub('cluster_energy.dat',resultspath) @@ -1062,7 +1078,7 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) !--- Checking Boltzmann weighting write (stdout,*) call remove('full_ensemble.xyz') - call sort_ensemble(ens,ens%er,'full_ensemble.xyz') + call qcg_dump_sorted_ensemble(ens,ens%er,'full_ensemble.xyz') e_clus = ens%er*autokcal call sort_min(ens%nall,1,1,e_clus) ens%er = e_clus/autokcal !Overwrite ensemble energy with sorted one @@ -1131,8 +1147,8 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) write (stdout,'(2x,70("-"))') write (stdout,'(2x,''Boltz. averaged energy of final cluster:'')') call aver(.true.,env,ens%nall,e_clus(1:ens%nall),S,H,G,sasa,.false.) - write (stdout,'(7x,''G /Eh :'',F14.8)') G/autokcal - write (stdout,'(7x,''T*S /kcal :'',f8.3)') S + write (stdout,'(7x,''G /Eh :'',f15.8)') G/autokcal + write (stdout,'(7x,''T*S /kcal :'',f15.8)') S ens%g = G ens%s = S @@ -1156,14 +1172,16 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) if (.not.env%keepModef) call rmrf(tmppath2) !----Outprint write (stdout,*) - write (stdout,'(2x,''Ensemble generation finished.'')') - write (stdout,'(2x,''Results can be found in ensemble directory'')') - write (stdout,'(2x,''Lowest energy conformer in file '')') - write (stdout,'(2x,''List of full ensemble in file '')') - write (stdout,'(2x,''List of used ensemble in file '')') - write (stdout,'(2x,''Thermodynamical data in file '')') - write (stdout,'(2x,''Population of full ensemble in file '')') - write (stdout,'(2x,''Population in file '')') + write (stdout,'(2x,"Ensemble generation finished.")') + write (stdout,'(2x,"Results can be found in the [ensemble] directory:")') + write (stdout,'(2x,"--> What? --> Where?")') + write (stdout,'(2x,"Lowest energy conformer crest_best.xyz")') + write (stdout,'(2x,"List of full ensemble full_ensemble.xyz")') + write (stdout,'(2x,"List of used ensemble final_ensemble.xyz")') + write (stdout,'(2x,"Ensemble thermodyn data thermo_data")') + write (stdout,'(2x,"Population of selected population.dat")') + write (stdout,'(2x,"Population of full ensemble full_population.dat")') + !>--- restore settings env%gfnver = gfnver_tmp diff --git a/src/qcg/qcg_utils.f90 b/src/qcg/qcg_utils.f90 index 4d1de82a..fb453ba3 100644 --- a/src/qcg/qcg_utils.f90 +++ b/src/qcg/qcg_utils.f90 @@ -653,29 +653,27 @@ end subroutine sort_min !==============================================================================! - subroutine sort_ensemble(ens,e_ens,fname) + subroutine qcg_dump_sorted_ensemble(ens,e_ens,fname) use crest_parameters use crest_data use strucrd implicit none - type(ensemble) :: ens - real(wp) :: e_ens(ens%nall),dum(ens%nall) - character(len=*) :: fname - integer :: ich - integer :: i,e_min - - dum = e_ens - + type(ensemble),intent(in) :: ens + real(wp),intent(in) :: e_ens(ens%nall) + real(wp),allocatable :: dum(:) + character(len=*) :: fname + integer :: ich,i,e_min + allocate(dum(ens%nall)) + dum(:) = e_ens(:) open (newunit=ich,file=fname) - do i = 1,ens%nall e_min = minloc(dum,dim=1) call wrxyz(ich,ens%nat,ens%at,ens%xyz(:,:,e_min),e_ens(e_min)) - dum(e_min) = 0.0d0 + dum(e_min) = huge(1.0_wp) end do close (ich) - - end subroutine sort_ensemble + deallocate(dum) + end subroutine qcg_dump_sorted_ensemble !==============================================================================! @@ -692,15 +690,11 @@ subroutine rdtherm(fname,ht,svib,srot,stra,gt) real(wp),intent(out) :: srot real(wp),intent(out) :: stra ! Stack - integer :: nn - integer :: io - integer :: counter - integer :: hg_line - real(wp) :: xx(20) - logical :: ende - character(len=*) :: fname - character(len=128) :: a - integer :: ich + integer :: nn,io,counter,hg_line,ich + real(wp) :: xx(20) + logical :: ende + character(len=*) :: fname + character(len=128) :: a ende = .false. counter = 0 @@ -776,19 +770,5 @@ subroutine rdxtbiffE(fname,m,n,e) end subroutine rdxtbiffE !==============================================================================! - - - - - - - - - - - - - - !==============================================================================! end module qcg_utils diff --git a/src/strucreader.f90 b/src/strucreader.f90 index 4f42da0a..3189b1c8 100644 --- a/src/strucreader.f90 +++ b/src/strucreader.f90 @@ -50,6 +50,7 @@ module strucrd !>--- some constants and name mappings real(wp),parameter :: bohr = 0.52917726_wp + real(wp),parameter :: aatoau = 1.0_wp/bohr real(wp),parameter :: autokcal = 627.509541_wp !>-- filetypes as integers integer,parameter :: tmcoord = 1 @@ -242,13 +243,13 @@ module strucrd procedure :: deallocate => deallocate_ensembletype !clear memory space procedure :: open => openensemble !read an ensemble file procedure :: write => write_ensemble !write to file - + procedure :: get_mol => ensemble_get_mol !extract the i-th mol from ensemble type end type ensemble !==========================================================================================! type :: mollist - integer :: nall = 0 - type(coord),allocatable :: structure(:) + integer :: nall = 0 + type(coord),allocatable :: structure(:) end type mollist !=========================================================================================! @@ -774,6 +775,29 @@ subroutine openensemble(self,fname) return end subroutine openensemble + subroutine ensemble_get_mol(self,i,mol) + class(ensemble) :: self + integer,intent(in) :: i + class(coord),intent(inout) :: mol + integer :: n + logical :: reinitialize + if (i > self%nall) error stop 'can´t get molecule from ensemble. i>nall' + if (i < 1) error stop 'can´t get molecule from ensemble. i<1' + n = self%nat + reinitialize = (mol%nat == n) + if (reinitialize) then + mol%nat = n + if (allocated(mol%at)) deallocate (mol%at) + allocate (mol%at(n),source=0) + if (allocated(mol%xyz)) deallocate (mol%xyz) + allocate (mol%xyz(3,n),source=0.0_wp) + end if + mol%energy = self%er(i) + mol%at(:) = self%at(:) + !> Important, ens is in Angström, mol is in Bohrs + mol%xyz(1:3,1:n) = self%xyz(1:3,1:n,i)*aatoau + end subroutine ensemble_get_mol + !=========================================================================================! !=========================================================================================! ! 2. ROUTINES FOR READING SINGLE STRUCTURES (COORDS) @@ -1229,7 +1253,7 @@ end subroutine rdPDB ! nat - number of atoms ! ! On Output: at - atom number as integer -! xyz - coordinates (in Angström) +! xyz - coordinates (in Bohr) !============================================================! subroutine rdxmolselec(fname,m,nat,at,xyz,comment) @@ -1729,7 +1753,7 @@ subroutine wrxyz_channel_energy(ch,nat,at,xyz,er) integer :: i,j,k,ich,io logical :: ex write (ch,'(2x,i0)') nat - write (ch,'(2x,f18.8)') er + write (ch,'(2x,a,f18.8)') "energy=",er do j = 1,nat write (ch,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) end do @@ -1972,7 +1996,7 @@ subroutine appendcoord(self,io) if (allocated(self%comment)) then call wrxyz(io,self%nat,self%at,self%xyz,trim(self%comment)) else if (self%energy .ne. 0.0_wp) then - write (atmp,'(a,f22.10)') ' Etot= ',self%energy + write (atmp,'(a,f22.10)') ' energy= ',self%energy call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) else call wrxyz(io,self%nat,self%at,self%xyz) @@ -1990,9 +2014,9 @@ subroutine appendlog(self,io,energy,gnorm) character(len=64) :: atmp self%xyz = self%xyz*bohr !to Angström if (present(gnorm).and.present(energy)) then - write (atmp,'(a,f22.10,a,f16.8)') ' Etot= ',energy,' grad.norm.= ',gnorm + write (atmp,'(a,f22.10,a,f16.8)') ' energy= ',energy,' grad.norm.= ',gnorm else if (present(energy)) then - write (atmp,'(a,f22.10)') ' Etot= ',energy + write (atmp,'(a,f22.10)') ' energy= ',energy else atmp = '' end if @@ -2383,20 +2407,20 @@ end subroutine get_atlist !=========================================================================================! subroutine atswp(self,ati,atj) - !******************************** - !* swap atom ati with atj in mol - !******************************** - implicit none - class(coord),intent(inout) :: self - integer,intent(in) :: ati,atj - real(wp) :: xyztmp(3) - integer :: attmp - xyztmp(1:3) = self%xyz(1:3,ati) - attmp = self%at(ati) - self%xyz(1:3,ati) = self%xyz(1:3,atj) - self%at(ati) = self%at(atj) - self%xyz(1:3,atj) = xyztmp(1:3) - self%at(atj) = attmp + !******************************** + !* swap atom ati with atj in mol + !******************************** + implicit none + class(coord),intent(inout) :: self + integer,intent(in) :: ati,atj + real(wp) :: xyztmp(3) + integer :: attmp + xyztmp(1:3) = self%xyz(1:3,ati) + attmp = self%at(ati) + self%xyz(1:3,ati) = self%xyz(1:3,atj) + self%at(ati) = self%at(atj) + self%xyz(1:3,atj) = xyztmp(1:3) + self%at(atj) = attmp end subroutine atswp !=========================================================================================! From 8546f2473bb49b26d1b233bed34cb5bee812890c Mon Sep 17 00:00:00 2001 From: Lukas Rindt Date: Mon, 1 Dec 2025 16:48:09 +0100 Subject: [PATCH 100/374] thermocalc refactored --- src/algos/hessian_tools.f90 | 7 +- src/algos/numhess.f90 | 20 +- src/calculator/calculator.F90 | 2 +- src/calculator/hessian_reconstruct.f90 | 12 +- src/entropy/CMakeLists.txt | 1 + src/entropy/entropic.f90 | 2 + src/entropy/thermocalc.f90 | 266 +--------------------- src/entropy/thermochem_module.f90 | 296 +++++++++++++++++++++++++ src/minitools.f90 | 1 + src/optimize/optimize_module.f90 | 2 + src/symmetry2.f90 | 7 + 11 files changed, 334 insertions(+), 282 deletions(-) create mode 100644 src/entropy/thermochem_module.f90 diff --git a/src/algos/hessian_tools.f90 b/src/algos/hessian_tools.f90 index 0b330903..aa713508 100644 --- a/src/algos/hessian_tools.f90 +++ b/src/algos/hessian_tools.f90 @@ -32,7 +32,7 @@ module hessian_tools use crest_data use crest_calculator use strucrd - use optimize_module + !use optimize_module use optimize_maths use iomod @@ -45,7 +45,7 @@ module hessian_tools !=========================================================================================! - subroutine frequencies(nat,at,xyz,nat3,calc,prj_mw_hess,freq,io) + subroutine frequencies(nat,at,xyz,nat3,prj_mw_hess,freq,io) !************************************************* !* Returns the Frequencies from a Hessian in cm-1 !************************************************* @@ -54,7 +54,6 @@ subroutine frequencies(nat,at,xyz,nat3,calc,prj_mw_hess,freq,io) integer,intent(in) :: nat integer,intent(in) :: at(nat) real(wp),intent(in) :: xyz(3,nat) - type(calcdata) :: calc real(wp) :: prj_mw_hess(nat3,nat3) integer :: io,nat3 @@ -569,7 +568,7 @@ subroutine calculate_frequencies(calc,nat,at,xyz,freq,io,constraints) call prj_mw_hess(nat,at,nat3,xyz, hessian(:,:)) !>-- Computes the Frequencies - call frequencies(nat,at,xyz,nat3, calc, hessian(:,:), freq(:),io) + call frequencies(nat,at,xyz,nat3, hessian(:,:), freq(:),io) end do deallocate( hessian ) diff --git a/src/algos/numhess.f90 b/src/algos/numhess.f90 index 84cb22df..af706f3b 100644 --- a/src/algos/numhess.f90 +++ b/src/algos/numhess.f90 @@ -146,7 +146,7 @@ subroutine crest_numhess(env,tim) call prj_mw_hess(mol%nat,mol%at,nat3,mol%xyz,heff) !>-- Comp. of Frequencies - call frequencies(mol%nat,mol%at,mol%xyz,nat3,calc,heff,freq(:,n_freqs),io) + call frequencies(mol%nat,mol%at,mol%xyz,nat3,heff,freq(:,n_freqs),io) !>-- Printout of vibspectrum call print_vib_spectrum(mol%nat,mol%at,nat3,mol%xyz,freq(:,n_freqs),'','vibspectrum') @@ -190,7 +190,7 @@ subroutine crest_numhess(env,tim) call prj_mw_hess(mol%nat,mol%at,nat3,mol%xyz,hess(:,:,i)) !>-- Computes the Frequencies - call frequencies(mol%nat,mol%at,mol%xyz,nat3,calc,hess(:,:,i),freq(:,i),io) + call frequencies(mol%nat,mol%at,mol%xyz,nat3,hess(:,:,i),freq(:,i),io) if (io .ne. 0) then write (stdout,*) 'FAILED!' @@ -233,7 +233,7 @@ subroutine crest_numhess(env,tim) call prj_mw_hess(mol%nat,mol%at,nat3,mol%xyz,ohess(:,:)) !>-- Computes the Frequencies (in cm^-1) - call frequencies(mol%nat,mol%at,mol%xyz,nat3,calc,ohess(:,:),ofreq(:),io) + call frequencies(mol%nat,mol%at,mol%xyz,nat3,ohess(:,:),ofreq(:),io) !>-- Prints vibspectrum (cm^-1) with artifical intensities call print_vib_spectrum(mol%nat,mol%at,nat3,mol%xyz,ofreq(:), & @@ -276,13 +276,14 @@ subroutine numhess_thermostat(env,mol,nat3,hess,freq,etot) use crest_parameters use crest_data use strucrd + use thermochem_module implicit none !> INPUT type(systemdata) :: env - type(coord) :: mol + type(coord), intent(inout) :: mol integer,intent(in) :: nat3 real(wp),intent(in) :: hess(nat3,nat3) - real(wp),intent(in) :: freq(nat3) + real(wp),intent(inout) :: freq(nat3) real(wp),intent(in) :: etot !> LOCAL real(wp) :: ithr,fscal,sthr @@ -310,8 +311,8 @@ subroutine numhess_thermostat(env,mol,nat3,hess,freq,etot) !write(*,*) nrt temps = env%thermo%temps - !> calcthermo wants input in Angstroem - call calcthermo(mol%nat,mol%at,mol%xyz*autoaa,freq,.true., & + !> calcthermo wants input in Bohr + call calcthermo(mol%nat,mol%at,mol%xyz,freq,.true., & & ithr,fscal,sthr,nt,temps,et,ht,gt,stot) !> printout @@ -342,6 +343,7 @@ subroutine thermo_standalone(env) use crest_parameters use crest_data use strucrd + use thermochem_module implicit none !> INPUT type(systemdata) :: env @@ -415,8 +417,8 @@ subroutine thermo_standalone(env) !write(*,*) nrt temps = env%thermo%temps - !> calcthermo wants input in Angstroem - call calcthermo(mol%nat,mol%at,mol%xyz*autoaa,freq,.true., & + !> calcthermo wants input in Bohr + call calcthermo(mol%nat,mol%at,mol%xyz,freq,.true., & & ithr,fscal,sthr,nt,temps,et,ht,gt,stot) !> printout diff --git a/src/calculator/calculator.F90 b/src/calculator/calculator.F90 index 4cd1695e..b80e2a96 100644 --- a/src/calculator/calculator.F90 +++ b/src/calculator/calculator.F90 @@ -297,7 +297,7 @@ subroutine engrad_mol(mol,calc,energy,gradient,iostatus) !********************************************** call calc%freezegrad(gradient) - if (calc%do_HU) then + if (calc%do_HU .and. allocated(calc%chess)) then call calc%chess%update(gradient,energy,mol%xyz) end if diff --git a/src/calculator/hessian_reconstruct.f90 b/src/calculator/hessian_reconstruct.f90 index 2c58f581..c6c14c54 100644 --- a/src/calculator/hessian_reconstruct.f90 +++ b/src/calculator/hessian_reconstruct.f90 @@ -1,5 +1,6 @@ module hessian_reconstruct use iso_fortran_env,only:wp => real64 + !use hessian_tools, only:frequencies implicit none private @@ -32,17 +33,18 @@ subroutine cashed_hessian_allocate(self,N,steps) class(cashed_hessian),intent(inout) :: self self%steps = steps + self%natm = N allocate (self%gradient(steps,3,N)) allocate (self%coords(steps,3,N)) allocate (self%energy(steps)) allocate (self%order(steps)) - allocate (self%s(self%steps-1,3*self%natm)) - allocate (self%y(self%steps-1,3*self%natm)) + allocate (self%s(self%steps-1,3*N)) + allocate (self%y(self%steps-1,3*N)) allocate (self%p(self%steps-1)) allocate (self%rho(self%steps-1)) - allocate (self%V(self%steps-1,3*self%natm,3*self%natm)) - allocate (self%I(3*self%natm,3*self%natm)) - self%natm = N + allocate (self%V(self%steps-1,3*N,3*N)) + allocate (self%I(3*N,3*N)) + self%order(:) = 0 diff --git a/src/entropy/CMakeLists.txt b/src/entropy/CMakeLists.txt index 20af53d3..38ce822c 100644 --- a/src/entropy/CMakeLists.txt +++ b/src/entropy/CMakeLists.txt @@ -22,6 +22,7 @@ list(APPEND srcs "${dir}/mie.f90" "${dir}/entropic.f90" "${dir}/entropy.f90" + "${dir}/thermochem_module.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/entropy/entropic.f90 b/src/entropy/entropic.f90 index bb5471e5..8b4d0c76 100644 --- a/src/entropy/entropic.f90 +++ b/src/entropy/entropic.f90 @@ -1254,6 +1254,7 @@ subroutine analsym(zmol,fac,pr) !******************************************************* use crest_parameters,only:wp,idp => dp use zdata + use getsymmetry implicit none type(zmolecule) :: zmol real(wp),intent(out) :: fac @@ -1287,6 +1288,7 @@ end subroutine analsym subroutine analsym_geo(grp,nat,xyz,at,fac,pr,sfsm) use crest_parameters,only:wp,idp => dp use zdata + use getsymmetry implicit none type(zequal) :: grp real(wp),intent(out) :: fac diff --git a/src/entropy/thermocalc.f90 b/src/entropy/thermocalc.f90 index 2aa2e64f..e63af984 100644 --- a/src/entropy/thermocalc.f90 +++ b/src/entropy/thermocalc.f90 @@ -21,268 +21,6 @@ !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC! !=========================================================================================! -subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar) -!*********************************************************************** -!* Prepare the calculation of thermodynamic properties of a structure -!* In particular, determine rotational constants and check the symmetry -!*********************************************************************** - use crest_parameters,only:wp,bohr,stdout - use atmasses,only:molweight - use iomod,only:to_lower - use axis_module - implicit none - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) !> in Angstroem - logical,intent(in) :: pr - real(wp),intent(out) :: molmass - real(wp),intent(inout) :: rabc(3) - real(wp),intent(out) :: avmom - real(wp),intent(out) :: symnum - - real(wp) :: a,b,c - character(len=4) :: sfsym - character(len=3) :: sym,symchar - real(wp),parameter :: desy = 0.1_wp - integer,parameter :: maxat = 200 - - !>--- molecular mass in amu - molmass = molweight(nat,at) - - if (pr) then - write (stdout,'(1x,a,f15.2)') 'Mol. weight /amu : ',molmass - end if - - !>--- rotational constants in cm-1 - rabc = 0.0d0 - call axis(nat,at,xyz,rabc(1:3),avmom) - a = rabc(3) - b = rabc(2) - c = rabc(1) - rabc(1) = a - rabc(3) = c - if (pr) then - write (stdout,'(1x,a,3f15.2)') 'Rot. const. /MHz : ',rabc(1:3) - end if - rabc = rabc/2.99792458d+4 ! MHz to cm-1 - if (pr) then - write (stdout,'(1x,a,3f15.2)') 'Rot. const. /cm-1 : ',rabc(1:3) - end if - - !>--- symmetry number from rotational symmetry - xyz = xyz/bohr - call getsymmetry2(.false.,6,nat,at,xyz,desy,maxat,sfsym) - xyz = xyz*bohr - sym = sfsym(1:3) - symchar = sym - symnum = 1.0d0 - if (a .lt. 1.d-9.or.b .lt. 1.d-9.or.c .lt. 1.d-9) then - if (index(sym,'d') .ne. 0) symnum = 2.0d0 - else - call to_lower(sym) - if (index(sym,'c2') .ne. 0) symnum = 2.0d0 - if (index(sym,'s4') .ne. 0) symnum = 2.0d0 - if (index(sym,'c3') .ne. 0) symnum = 3.0d0 - if (index(sym,'s6') .ne. 0) symnum = 3.0d0 - if (index(sym,'c4') .ne. 0) symnum = 4.0d0 - if (index(sym,'s8') .ne. 0) symnum = 4.0d0 - if (index(sym,'c5') .ne. 0) symnum = 5.0d0 - if (index(sym,'c6') .ne. 0) symnum = 6.0d0 - if (index(sym,'c7') .ne. 0) symnum = 7.0d0 - if (index(sym,'c8') .ne. 0) symnum = 8.0d0 - if (index(sym,'c9') .ne. 0) symnum = 9.0d0 - if (index(sym,'d2') .ne. 0) symnum = 4.0d0 - if (index(sym,'d3') .ne. 0) symnum = 6.0d0 - if (index(sym,'d4') .ne. 0) symnum = 8.0d0 - if (index(sym,'d5') .ne. 0) symnum = 10.0d0 - if (index(sym,'d6') .ne. 0) symnum = 12.0d0 - if (index(sym,'d7') .ne. 0) symnum = 14.0d0 - if (index(sym,'d8') .ne. 0) symnum = 16.0d0 - if (index(sym,'d9') .ne. 0) symnum = 18.0d0 - if (index(sym,'t') .ne. 0) symnum = 12.0d0 - if (index(sym,'td') .ne. 0) symnum = 12.0d0 - if (index(sym,'th') .ne. 0) symnum = 12.0d0 - if (index(sym,'o') .ne. 0) symnum = 24.0d0 - if (index(sym,'oh') .ne. 0) symnum = 24.0d0 - if (index(sym,'ih') .ne. 0) symnum = 60.0d0 - end if - - if (pr) then - write (stdout,'(1x,a,4x,a)') 'Symmetry:',sym - end if - return -end subroutine prepthermo - -!=========================================================================================! -subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & - & et,ht,gt,stot) -!************************************************************** -!* Calculate thermodynamic contributions for a given structure -!* from it's frequencies (from second derivatives/the Hessian) -!* Based on xtb's "print_thermo" routine -!************************************************************** - use crest_parameters,only:wp,bohr,stdout - use crest_thermo - use atmasses,only:molweight - use iomod,only:to_lower - implicit none - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) !in Angstroem - real(wp),intent(inout) :: freq(3*nat) !in cm-1 - logical,intent(in) :: pr - real(wp),intent(in) :: ithr !imag. inv. in cm-1 - real(wp),intent(in) :: fscal !freq scaling - real(wp),intent(in) :: sthr !rotor cut - integer,intent(in) :: nt - real(wp),intent(in) :: temps(nt) - real(wp) :: et(nt) !< enthalpy in Eh - real(wp) :: ht(nt) !< enthalpy in Eh - real(wp) :: gt(nt) !< free energy in Eh - real(wp) :: stot(nt) !< entropy in cal/molK - real(wp) :: ts(nt) !< entropy*T in Eh - real(wp) :: rabc(3),a,b,c - real(wp) :: avmom - real(wp) :: molmass - real(wp) :: sym - real(wp) :: zp - character(len=3) :: symchar - logical :: pr2 - logical :: linear = .false. - logical :: atom = .false. - integer :: nvib_theo - integer :: nvib,nimag - real(wp) :: vibthr - real(wp),allocatable :: vibs(:) - - integer :: i,j - integer :: n3,rt - real(wp) :: adum(nt) - character(len=64) :: atmp - - character(len=*),parameter :: outfmt = & - & '(9x,"::",1x,a,f24.12,1x,a,1x,"::")' - character(len=*),parameter :: dblfmt = & - & '(10x,":",2x,a,f24.7,1x,a,1x,":")' - character(len=*),parameter :: intfmt = & - & '(10x,":",2x,a,i24, 6x,":")' - character(len=*),parameter :: chrfmt = & - & '(10x,":",2x,a,a24, 6x,":")' - - real(wp),parameter :: autorcm = 219474.63067_wp - real(wp),parameter :: rcmtoau = 1.0_wp/autorcm - real(wp),parameter :: autocal = 627.50947428_wp*1000.0_wp - - call prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,sym,symchar) - - n3 = 3*nat - allocate (vibs(n3)) - vibthr = 1.0 - a = rabc(1) - b = rabc(2) - c = rabc(3) - - nvib_theo = 3*nat-6 - if (c .lt. 1.d-10 .or. (symchar=='din')) linear = .true. - if (linear) nvib_theo = 3*nat-5 - - if (a+b+c .lt. 1.d-6) then - atom = .true. - nvib = 0 - nvib_theo = 0 - end if - - nvib = 0 - vibs = 0.0 - do i = 1,n3 - if (abs(freq(i)) .gt. vibthr) then - nvib = nvib+1 - vibs(nvib) = freq(i) - end if - end do - !> scale - vibs(1:nvib) = vibs(1:nvib)*fscal - - !> invert imaginary modes - nimag = 0 - do i = 1,nvib - if (vibs(i) .lt. 0.and.vibs(i) .gt. ithr) then - vibs(i) = -vibs(i) - if (pr) write (stdout,'(a,i5," :",f10.2)') 'Inverting frequency',i,vibs(i) - end if - if (vibs(i) < 0.0) then - nimag = nimag+1 - end if - end do - - if (pr) then - write (stdout,'(a)') - write (stdout,'(10x,51("."))') - write (stdout,'(10x,":",22x,a,22x,":")') "SETUP" - write (stdout,'(10x,":",49("."),":")') - write (stdout,intfmt) "# frequencies ",nvib - write (stdout,intfmt) "# imaginary freq.",nimag - write (atmp,*) linear - write (stdout,chrfmt) "linear? ",trim(atmp) - write (stdout,chrfmt) "symmetry ",adjustr(symchar) - write (stdout,intfmt) "rotational number",nint(sym) - write (stdout,dblfmt) "scaling factor ",fscal," " - write (stdout,dblfmt) "rotor cutoff ",sthr,"cm⁻¹" - write (stdout,dblfmt) "imag. cutoff ",ithr,"cm⁻¹" - write (stdout,'(10x,":",49("."),":")') - end if - - vibs = vibs*rcmtoau ! thermodyn needs vibs and zp in Eh - - zp = 0.5_wp*sum(vibs(1:nvib)) - adum = abs(temps-298.15d0) - rt = minloc(adum,1) !temperature closest to 298.15 is the ref. - do j = 1,nt - if ((j == rt).and.pr) then - pr2 = .true. - else - pr2 = .false. - end if - if (pr2) then - call print_thermo_sthr_ts(stdout,nvib,vibs,avmom,sthr,temps(j)) - end if - call thermodyn(stdout,a,b,c,avmom,linear,atom,sym,molmass,vibs,nvib, & - & temps(j),sthr,et(j),ht(j),gt(j),ts(j),zp,pr2) - stot(j) = (ts(j)/temps(j))*autocal - end do - - if ((nt > 1).and.pr) then - write (stdout,'(a)') - write (stdout,'(a10)',advance='no') "T/K" - write (stdout,'(a16)',advance='no') "H(0)-H(T)+PV" - write (stdout,'(a16)',advance='no') "H(T)/Eh" - write (stdout,'(a16)',advance='no') "T*S/Eh" - write (stdout,'(a16)',advance='no') "G(T)/Eh" - write (stdout,'(a)') - write (stdout,'(3x,72("-"))') - do i = 1,nt - write (stdout,'(3f10.2)',advance='no') temps(i) - write (stdout,'(3e16.6)',advance='no') ht(i) - write (stdout,'(3e16.6)',advance='no') et(i) - write (stdout,'(3e16.6)',advance='no') ts(i) - write (stdout,'(3e16.6)',advance='no') gt(i) - if (i == rt) then - write (stdout,'(1x,"(used)")') - else - write (stdout,'(a)') - end if - end do - write (stdout,'(3x,72("-"))') - end if - - deallocate (vibs) - return -end subroutine calcthermo - -!=========================================================================================! -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -!=========================================================================================! - subroutine thermo_wrap_legacy(env,pr,nat,at,xyz,dirname, & & nt,temps,et,ht,gt,stot,bhess) !********************************************** @@ -295,6 +33,7 @@ subroutine thermo_wrap_legacy(env,pr,nat,at,xyz,dirname, & use crest_data use iomod use strucrd + use thermochem_module implicit none !> INPUT type(systemdata) :: env @@ -485,6 +224,7 @@ subroutine thermo_wrap_new(env,pr,nat,at,xyz,dirname, & use iomod use strucrd use hessian_tools + use thermochem_module implicit none !> INPUT type(systemdata) :: env @@ -567,7 +307,7 @@ subroutine thermo_wrap_new(env,pr,nat,at,xyz,dirname, & !>-- Projects and mass-weights the Hessian call prj_mw_hess(mol%nat,mol%at,nfreq,mol%xyz,hess) !>-- Computes the Frequencies - call frequencies(mol%nat,mol%at,mol%xyz,nfreq,calctmp,hess,freq,io) + call frequencies(mol%nat,mol%at,mol%xyz,nfreq,hess,freq,io) !$omp end critical !>--- get thermodynamics diff --git a/src/entropy/thermochem_module.f90 b/src/entropy/thermochem_module.f90 new file mode 100644 index 00000000..f3304dac --- /dev/null +++ b/src/entropy/thermochem_module.f90 @@ -0,0 +1,296 @@ +module thermochem_module + !use iso_fortran_env,only:wp => real64 + use crest_parameters + use getsymmetry + use hessian_tools + !use hessian_tools, only:frequencies + implicit none + private + + public calcthermo + + contains + + subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar) +!*********************************************************************** +!* Prepare the calculation of thermodynamic properties of a structure +!* In particular, determine rotational constants and check the symmetry +!*********************************************************************** + !use crest_parameters,only:wp,bohr,stdout, aatoau, autoaa + use atmasses,only:molweight + use iomod,only:to_lower + use axis_module + implicit none + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) !> in Angstroem + logical,intent(in) :: pr + real(wp),intent(out) :: molmass + real(wp),intent(inout) :: rabc(3) + real(wp),intent(out) :: avmom + real(wp),intent(out) :: symnum + + real(wp) :: a,b,c + character(len=4) :: sfsym + character(len=3) :: sym,symchar + real(wp),parameter :: desy = 0.1_wp + integer,parameter :: maxat = 200 + + !>--- molecular mass in amu + molmass = molweight(nat,at) + + if (pr) then + write (stdout,'(1x,a,f15.2)') 'Mol. weight /amu : ',molmass + end if + + !>--- rotational constants in cm-1 + rabc = 0.0d0 + call axis(nat,at,xyz,rabc(1:3),avmom) + a = rabc(3) + b = rabc(2) + c = rabc(1) + rabc(1) = a + rabc(3) = c + if (pr) then + write (stdout,'(1x,a,3f15.2)') 'Rot. const. /MHz : ',rabc(1:3) + end if + rabc = rabc/2.99792458d+4 ! MHz to cm-1 + if (pr) then + write (stdout,'(1x,a,3f15.2)') 'Rot. const. /cm-1 : ',rabc(1:3) + end if + + !>--- symmetry number from rotational symmetry + xyz = xyz/bohr + call getsymmetry2(.false.,6,nat,at,xyz,desy,maxat,sfsym) + xyz = xyz*bohr + sym = sfsym(1:3) + symchar = sym + symnum = 1.0d0 + if (a .lt. 1.d-9.or.b .lt. 1.d-9.or.c .lt. 1.d-9) then + if (index(sym,'d') .ne. 0) symnum = 2.0d0 + else + call to_lower(sym) + if (index(sym,'c2') .ne. 0) symnum = 2.0d0 + if (index(sym,'s4') .ne. 0) symnum = 2.0d0 + if (index(sym,'c3') .ne. 0) symnum = 3.0d0 + if (index(sym,'s6') .ne. 0) symnum = 3.0d0 + if (index(sym,'c4') .ne. 0) symnum = 4.0d0 + if (index(sym,'s8') .ne. 0) symnum = 4.0d0 + if (index(sym,'c5') .ne. 0) symnum = 5.0d0 + if (index(sym,'c6') .ne. 0) symnum = 6.0d0 + if (index(sym,'c7') .ne. 0) symnum = 7.0d0 + if (index(sym,'c8') .ne. 0) symnum = 8.0d0 + if (index(sym,'c9') .ne. 0) symnum = 9.0d0 + if (index(sym,'d2') .ne. 0) symnum = 4.0d0 + if (index(sym,'d3') .ne. 0) symnum = 6.0d0 + if (index(sym,'d4') .ne. 0) symnum = 8.0d0 + if (index(sym,'d5') .ne. 0) symnum = 10.0d0 + if (index(sym,'d6') .ne. 0) symnum = 12.0d0 + if (index(sym,'d7') .ne. 0) symnum = 14.0d0 + if (index(sym,'d8') .ne. 0) symnum = 16.0d0 + if (index(sym,'d9') .ne. 0) symnum = 18.0d0 + if (index(sym,'t') .ne. 0) symnum = 12.0d0 + if (index(sym,'td') .ne. 0) symnum = 12.0d0 + if (index(sym,'th') .ne. 0) symnum = 12.0d0 + if (index(sym,'o') .ne. 0) symnum = 24.0d0 + if (index(sym,'oh') .ne. 0) symnum = 24.0d0 + if (index(sym,'ih') .ne. 0) symnum = 60.0d0 + end if + + if (pr) then + write (stdout,'(1x,a,4x,a)') 'Symmetry:',sym + end if + return +end subroutine prepthermo + +subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & + & et,ht,gt,stot) +!************************************************************** +!* Calculate thermodynamic contributions for a given structure +!* from it's frequencies (from second derivatives/the Hessian) +!* Based on xtb's "print_thermo" routine +!************************************************************** + use crest_parameters,only:wp,bohr,stdout + use crest_thermo + use atmasses,only:molweight + use iomod,only:to_lower + implicit none + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) !in Bohr + real(wp),intent(inout) :: freq(3*nat) !in cm-1 + logical,intent(in) :: pr + real(wp),intent(in) :: ithr !imag. inv. in cm-1 + real(wp),intent(in) :: fscal !freq scaling + real(wp),intent(in) :: sthr !rotor cut + integer,intent(in) :: nt + real(wp),intent(in) :: temps(nt) + real(wp) :: et(nt) !< enthalpy in Eh + real(wp) :: ht(nt) !< enthalpy in Eh + real(wp) :: gt(nt) !< free energy in Eh + real(wp) :: stot(nt) !< entropy in cal/molK + real(wp) :: ts(nt) !< entropy*T in Eh + real(wp) :: rabc(3),a,b,c + real(wp) :: avmom + real(wp) :: molmass + real(wp) :: sym + real(wp) :: zp + character(len=3) :: symchar + logical :: pr2 + logical :: linear = .false. + logical :: atom = .false. + integer :: nvib_theo + integer :: nvib,nimag + real(wp) :: vibthr + real(wp),allocatable :: vibs(:) + + integer :: i,j + integer :: n3,rt + real(wp) :: adum(nt) + character(len=64) :: atmp + + character(len=*),parameter :: outfmt = & + & '(9x,"::",1x,a,f24.12,1x,a,1x,"::")' + character(len=*),parameter :: dblfmt = & + & '(10x,":",2x,a,f24.7,1x,a,1x,":")' + character(len=*),parameter :: intfmt = & + & '(10x,":",2x,a,i24, 6x,":")' + character(len=*),parameter :: chrfmt = & + & '(10x,":",2x,a,a24, 6x,":")' + + real(wp),parameter :: autorcm = 219474.63067_wp + real(wp),parameter :: rcmtoau = 1.0_wp/autorcm + real(wp),parameter :: autocal = 627.50947428_wp*1000.0_wp + + xyz =xyz*autoaa + + call prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,sym,symchar) + + n3 = 3*nat + allocate (vibs(n3)) + vibthr = 1.0 + a = rabc(1) + b = rabc(2) + c = rabc(3) + + nvib_theo = 3*nat-6 + if (c .lt. 1.d-10 .or. (symchar=='din')) linear = .true. + if (linear) nvib_theo = 3*nat-5 + + if (a+b+c .lt. 1.d-6) then + atom = .true. + nvib = 0 + nvib_theo = 0 + end if + + nvib = 0 + vibs = 0.0 + do i = 1,n3 + if (abs(freq(i)) .gt. vibthr) then + nvib = nvib+1 + vibs(nvib) = freq(i) + end if + end do + !> scale + vibs(1:nvib) = vibs(1:nvib)*fscal + + !> invert imaginary modes + nimag = 0 + do i = 1,nvib + if (vibs(i) .lt. 0.and.vibs(i) .gt. ithr) then + vibs(i) = -vibs(i) + if (pr) write (stdout,'(a,i5," :",f10.2)') 'Inverting frequency',i,vibs(i) + end if + if (vibs(i) < 0.0) then + nimag = nimag+1 + end if + end do + + if (pr) then + write (stdout,'(a)') + write (stdout,'(10x,51("."))') + write (stdout,'(10x,":",22x,a,22x,":")') "SETUP" + write (stdout,'(10x,":",49("."),":")') + write (stdout,intfmt) "# frequencies ",nvib + write (stdout,intfmt) "# imaginary freq.",nimag + write (atmp,*) linear + write (stdout,chrfmt) "linear? ",trim(atmp) + write (stdout,chrfmt) "symmetry ",adjustr(symchar) + write (stdout,intfmt) "rotational number",nint(sym) + write (stdout,dblfmt) "scaling factor ",fscal," " + write (stdout,dblfmt) "rotor cutoff ",sthr,"cm⁻¹" + write (stdout,dblfmt) "imag. cutoff ",ithr,"cm⁻¹" + write (stdout,'(10x,":",49("."),":")') + end if + + vibs = vibs*rcmtoau ! thermodyn needs vibs and zp in Eh + + zp = 0.5_wp*sum(vibs(1:nvib)) + adum = abs(temps-298.15d0) + rt = minloc(adum,1) !temperature closest to 298.15 is the ref. + do j = 1,nt + if ((j == rt).and.pr) then + pr2 = .true. + else + pr2 = .false. + end if + if (pr2) then + call print_thermo_sthr_ts(stdout,nvib,vibs,avmom,sthr,temps(j)) + end if + call thermodyn(stdout,a,b,c,avmom,linear,atom,sym,molmass,vibs,nvib, & + & temps(j),sthr,et(j),ht(j),gt(j),ts(j),zp,pr2) + stot(j) = (ts(j)/temps(j))*autocal + end do + + if ((nt > 1).and.pr) then + write (stdout,'(a)') + write (stdout,'(a10)',advance='no') "T/K" + write (stdout,'(a16)',advance='no') "H(0)-H(T)+PV" + write (stdout,'(a16)',advance='no') "H(T)/Eh" + write (stdout,'(a16)',advance='no') "T*S/Eh" + write (stdout,'(a16)',advance='no') "G(T)/Eh" + write (stdout,'(a)') + write (stdout,'(3x,72("-"))') + do i = 1,nt + write (stdout,'(3f10.2)',advance='no') temps(i) + write (stdout,'(3e16.6)',advance='no') ht(i) + write (stdout,'(3e16.6)',advance='no') et(i) + write (stdout,'(3e16.6)',advance='no') ts(i) + write (stdout,'(3e16.6)',advance='no') gt(i) + if (i == rt) then + write (stdout,'(1x,"(used)")') + else + write (stdout,'(a)') + end if + end do + write (stdout,'(3x,72("-"))') + end if + + xyz =xyz*aatoau + + deallocate (vibs) + return +end subroutine calcthermo + +subroutine calc_thermo_from_hess(mol, hess, pr, nt) +type(coord), intent(inout) :: mol +integer :: nat3 +integer :: io +logical :: pr +real(wp) :: ithr, fscal, sthr, temps(nt) +integer, intent(in) :: nt +real(wp) :: et(nt),ht(nt),gt(nt),stot(nt) +real(wp), intent(inout) :: hess(:,:) +real(wp), allocatable :: freq(:) + +call prj_mw_hess(mol%nat,mol%at,nat3,mol%xyz,hess) + +call frequencies(mol%nat,mol%at,mol%xyz,nat3,hess,freq,io) + +call calcthermo(mol%nat,mol%at,mol%xyz,freq,pr,ithr,fscal,sthr,nt,temps, & + & et,ht,gt,stot) + +end subroutine calc_thermo_from_hess + + +end module thermochem_module \ No newline at end of file diff --git a/src/minitools.f90 b/src/minitools.f90 index a6be69f2..fdd5c49b 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -477,6 +477,7 @@ subroutine ensemble_analsym(fname,pr) !***************************************************************** use crest_parameters use strucrd + use getsymmetry implicit none character(len=*) :: fname logical :: pr diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index 40114060..bc93540f 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -100,10 +100,12 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) end select molnew%energy = etot + if (calc%do_HU) then print*, "Energies", calc%chess%energy print*, "Gradients", calc%chess%gradient print*, "Coords", calc%chess%coords print*, "Order", calc%chess%order + endif if (calc%do_HU) then call calc%chess%dealloc() diff --git a/src/symmetry2.f90 b/src/symmetry2.f90 index 1083c3cc..b3220f72 100644 --- a/src/symmetry2.f90 +++ b/src/symmetry2.f90 @@ -15,6 +15,12 @@ ! You should have received a copy of the GNU Lesser General Public License ! along with xtb. If not, see . +Module getsymmetry + +private +public getsymmetry2 +contains + Subroutine get_schoenflies(n,iat,xyz,sfsym,paramar) Use iso_c_binding Implicit None @@ -134,3 +140,4 @@ subroutine getsymmetry2(pr,iunit,n,iat,xyz,symthr,maxatdesy,sfsym) End subroutine getsymmetry2 +end module getsymmetry \ No newline at end of file From 8874618f632b68c4d87f6507fd61a148a25502b1 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 9 Dec 2025 11:38:31 +0100 Subject: [PATCH 101/374] cont'd QCG refactor --- src/algos/numhess.f90 | 155 +++++++++++++++----------------- src/parsing/confparse2.f90 | 2 + src/qcg/qcg_main.f90 | 32 ++++--- src/qcg/qcg_misc.f90 | 178 +++++++++++++++++++++++++++++++++---- 4 files changed, 258 insertions(+), 109 deletions(-) diff --git a/src/algos/numhess.f90 b/src/algos/numhess.f90 index 84cb22df..9d817e68 100644 --- a/src/algos/numhess.f90 +++ b/src/algos/numhess.f90 @@ -76,22 +76,21 @@ subroutine crest_numhess(env,tim) !========================================================================================! !>--- start with an initial single point - write(stdout,'(a)') repeat(":",80) + write (stdout,'(a)') repeat(":",80) write (stdout,'(1x,a)') 'Initial singlepoint calculation ...' - allocate(grad0(3,mol%nat),source=0.0_wp) - allocate(energies0( calc%ncalculations ), source=0.0_wp) - - call engrad(mol,calc,energy,grad0,io) - energies0 = calc%etmp - - write(atmp,'("Energy = ",f25.15," Eh")') energy - call smallhead(trim(atmp)) - write(stdout,'(a)') repeat(":",80) - write(stdout,*) - - - deallocate(grad0) - + allocate (grad0(3,mol%nat),source=0.0_wp) + allocate (energies0(calc%ncalculations),source=0.0_wp) + + call engrad(mol,calc,energy,grad0,io) + energies0 = calc%etmp + + write (atmp,'("Energy = ",f25.15," Eh")') energy + call smallhead(trim(atmp)) + write (stdout,'(a)') repeat(":",80) + write (stdout,*) + + deallocate (grad0) + !========================================================================================! nat3 = mol%nat*3 @@ -178,7 +177,7 @@ subroutine crest_numhess(env,tim) else - write(atmp,*) i + write (atmp,*) i !>-- Prints Hessian call print_hessian(hess(:,:,i),nat3,'','numhess'//trim(adjustl(atmp))) @@ -204,7 +203,7 @@ subroutine crest_numhess(env,tim) call print_g98_fake(mol%nat,mol%at,nat3,mol%xyz,freq(:,i),hess(:,:,i), & & calc%calcs(i)%calcspace,'g98.out') - write(atmp,*) i + write (atmp,*) i call smallhead("Thermo contributions for [[calculation.level]] "//trim(adjustl(atmp))) call numhess_thermostat(env,mol,nat3,hess(:,:,i),freq(:,i),energies0(i)) @@ -250,9 +249,6 @@ subroutine crest_numhess(env,tim) end if !========================================================================================! - - - !========================================================================================! if (allocated(hess)) deallocate (hess) if (allocated(freq)) deallocate (freq) @@ -308,25 +304,25 @@ subroutine numhess_thermostat(env,mol,nat3,hess,freq,etot) !write(*,*) temps nrt = minloc(temps(:),1) !write(*,*) nrt - temps = env%thermo%temps + temps = env%thermo%temps !> calcthermo wants input in Angstroem call calcthermo(mol%nat,mol%at,mol%xyz*autoaa,freq,.true., & & ithr,fscal,sthr,nt,temps,et,ht,gt,stot) - !> printout + !> printoutgeometr zpve = et(nrt)-ht(nrt) - write(stdout,*) - write(stdout,'(10x,a)') repeat(':',50) - write(stdout,'(10x,"::",7x,a,f12.2,1x,a,8x,"::")') "THERMODYNAMICS at",temps(nrt),'K' - write(stdout,'(10x,a)') repeat(':',50) - write(stdout,outfmt) 'TOTAL FREE ENERGY',etot+gt(nrt),'Eh' - write(stdout,'(10x,a)') '::'//repeat('-',46)//'::' - write(stdout,outfmt) 'total energy ',etot,'Eh' - write(stdout,outfmt) 'ZPVE ',zpve,'Eh' - write(stdout,outfmt) 'G(RRHO) w/o ZPVE ',gt(nrt)-zpve,'Eh' - write(stdout,outfmt) 'G(RRHO) total ',gt(nrt),'Eh' - write(stdout,'(10x,a)') repeat(':',50) + write (stdout,*) + write (stdout,'(10x,a)') repeat(':',50) + write (stdout,'(10x,"::",7x,a,f12.2,1x,a,8x,"::")') "THERMODYNAMICS at",temps(nrt),'K' + write (stdout,'(10x,a)') repeat(':',50) + write (stdout,outfmt) 'TOTAL FREE ENERGY',etot+gt(nrt),'Eh' + write (stdout,'(10x,a)') '::'//repeat('-',46)//'::' + write (stdout,outfmt) 'total energy ',etot,'Eh' + write (stdout,outfmt) 'ZPVE ',zpve,'Eh' + write (stdout,outfmt) 'G(RRHO) w/o ZPVE ',gt(nrt)-zpve,'Eh' + write (stdout,outfmt) 'G(RRHO) total ',gt(nrt),'Eh' + write (stdout,'(10x,a)') repeat(':',50) deallocate (stot,gt,ht,et,temps) end subroutine numhess_thermostat @@ -360,41 +356,41 @@ subroutine thermo_standalone(env) & '(10x,"::",1x,a,f24.12,1x,a,1x,"::")' !> header - write(stdout,*) " _ _ " - write(stdout,*) "| |_| |__ ___ _ __ _ __ ___ ___ " - write(stdout,*) "| __| '_ \ / _ \ '__| '_ ` _ \ / _ \ " - write(stdout,*) "| |_| | | | __/ | | | | | | | (_) |" - write(stdout,*) " \__|_| |_|\___|_| |_| |_| |_|\___/ " - write(stdout,*) " " - write(stdout,*) "Molecular thermodynamics from the modified and scaled" - write(stdout,*) "rigid-rotor harmonic-oscillator approximation (msRRHO)" - write(stdout,*) "See:" - write(stdout,*) " • S.Grimme, Chem. Eur. J. 2012, 18, 9955–9964." - write(stdout,*) " • P.Pracht, S.Grimme, Chem. Sci., 2021, 12, 6551-6568." - write(stdout,*) - + write (stdout,*) " _ _ " + write (stdout,*) "| |_| |__ ___ _ __ _ __ ___ ___ " + write (stdout,*) "| __| '_ \ / _ \ '__| '_ ` _ \ / _ \ " + write (stdout,*) "| |_| | | | __/ | | | | | | | (_) |" + write (stdout,*) " \__|_| |_|\___|_| |_| |_| |_|\___/ " + write (stdout,*) " " + write (stdout,*) "Molecular thermodynamics from the modified and scaled" + write (stdout,*) "rigid-rotor harmonic-oscillator approximation (msRRHO)" + write (stdout,*) "See:" + write (stdout,*) " • S.Grimme, Chem. Eur. J. 2012, 18, 9955–9964." + write (stdout,*) " • P.Pracht, S.Grimme, Chem. Sci., 2021, 12, 6551-6568." + write (stdout,*) + !> input coords - write(stdout,'(1x,a)',advance='no') 'Reading input coords: ' - if(allocated(env%thermo%coords))then + write (stdout,'(1x,a)',advance='no') 'Reading input coords: ' + if (allocated(env%thermo%coords)) then call mol%open(env%thermo%coords) - write(stdout,'(1x,a)') trim(env%thermo%coords) + write (stdout,'(1x,a)') trim(env%thermo%coords) else call mol%open(env%inputcoords) - write(stdout,'(1x,a)') trim(env%inputcoords) - endif - nat3 = mol%nat * 3 - allocate(hess(nat3,nat3),freq(nat3), source=0.0_wp) + write (stdout,'(1x,a)') trim(env%inputcoords) + end if + nat3 = mol%nat*3 + allocate (hess(nat3,nat3),freq(nat3),source=0.0_wp) !> input frequencies or hessian - if(allocated(env%thermo%vibfile))then - write(stdout,'(1x,a,a)') 'Reading frequencies from: ',trim(env%thermo%vibfile) + if (allocated(env%thermo%vibfile)) then + write (stdout,'(1x,a,a)') 'Reading frequencies from: ',trim(env%thermo%vibfile) call rdfreq(env%thermo%vibfile,nat3,freq) else - write(stdout,'(1x,a)') 'No Hessian or vibspectrum file allocated for thermo routine!' + write (stdout,'(1x,a)') 'No Hessian or vibspectrum file allocated for thermo routine!' call creststop(status_input) - endif - write(stdout,*) - + end if + write (stdout,*) + !> energy (maybe read from comment line of xyz) etot = mol%energy !> inversion threshold @@ -413,7 +409,7 @@ subroutine thermo_standalone(env) !write(*,*) temps nrt = minloc(temps(:),1) !write(*,*) nrt - temps = env%thermo%temps + temps = env%thermo%temps !> calcthermo wants input in Angstroem call calcthermo(mol%nat,mol%at,mol%xyz*autoaa,freq,.true., & @@ -421,30 +417,27 @@ subroutine thermo_standalone(env) !> printout zpve = et(nrt)-ht(nrt) - write(stdout,*) - write(stdout,'(10x,a)') repeat(':',50) - write(stdout,'(10x,"::",7x,a,f12.2,1x,a,8x,"::")') "THERMODYNAMICS at",temps(nrt),'K' - write(stdout,'(10x,a)') repeat(':',50) - write(stdout,outfmt) 'TOTAL FREE ENERGY',etot+gt(nrt),'Eh' - write(stdout,'(10x,a)') '::'//repeat('-',46)//'::' - write(stdout,outfmt) 'total energy ',etot,'Eh' - write(stdout,outfmt) 'ZPVE ',zpve,'Eh' - write(stdout,outfmt) 'G(RRHO) w/o ZPVE ',gt(nrt)-zpve,'Eh' - write(stdout,outfmt) 'G(RRHO) total ',gt(nrt),'Eh' - write(stdout,'(10x,a)') repeat(':',50) + write (stdout,*) + write (stdout,'(10x,a)') repeat(':',50) + write (stdout,'(10x,"::",7x,a,f12.2,1x,a,8x,"::")') "THERMODYNAMICS at",temps(nrt),'K' + write (stdout,'(10x,a)') repeat(':',50) + write (stdout,outfmt) 'TOTAL FREE ENERGY',etot+gt(nrt),'Eh' + write (stdout,'(10x,a)') '::'//repeat('-',46)//'::' + write (stdout,outfmt) 'total energy ',etot,'Eh' + write (stdout,outfmt) 'ZPVE ',zpve,'Eh' + write (stdout,outfmt) 'G(RRHO) w/o ZPVE ',gt(nrt)-zpve,'Eh' + write (stdout,outfmt) 'G(RRHO) total ',gt(nrt),'Eh' + write (stdout,'(10x,a)') repeat(':',50) !> for plotting temperature dependencies etc. - write(stdout,*) - write(stdout,*) 'Some output will be written to thermo.dump' - open(newunit=ich, file='thermo.dump') - do i=1,nt - write(ich,'(f12.4,4F20.10)') temps(i),gt(i)+etot,gt(i),ht(i),stot(i) - enddo - close(ich) + write (stdout,*) + write (stdout,*) 'Some output will be written to thermo.dump' + open (newunit=ich,file='thermo.dump') + do i = 1,nt + write (ich,'(f12.4,4F20.10)') temps(i),gt(i)+etot,gt(i),ht(i),stot(i) + end do + close (ich) deallocate (stot,gt,ht,et,temps) end subroutine thermo_standalone - - - diff --git a/src/parsing/confparse2.f90 b/src/parsing/confparse2.f90 index 5bb313da..5bd8a409 100644 --- a/src/parsing/confparse2.f90 +++ b/src/parsing/confparse2.f90 @@ -223,6 +223,8 @@ subroutine env_calcdat_specialcases(env) end do end if + + end subroutine env_calcdat_specialcases !========================================================================================! diff --git a/src/qcg/qcg_main.f90 b/src/qcg/qcg_main.f90 index b429d584..4098331a 100644 --- a/src/qcg/qcg_main.f90 +++ b/src/qcg/qcg_main.f90 @@ -129,6 +129,8 @@ subroutine crest_solvtool(env,tim) progress = progress+1 end if + STOP !TODO TODO TODO TODO + !------------------------------------------------------------------------------ ! Frequency computation and evaluation !------------------------------------------------------------------------------ @@ -1179,10 +1181,9 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) write (stdout,'(2x,"List of full ensemble full_ensemble.xyz")') write (stdout,'(2x,"List of used ensemble final_ensemble.xyz")') write (stdout,'(2x,"Ensemble thermodyn data thermo_data")') - write (stdout,'(2x,"Population of selected population.dat")') + write (stdout,'(2x,"Population of selected population.dat")') write (stdout,'(2x,"Population of full ensemble full_population.dat")') - !>--- restore settings env%gfnver = gfnver_tmp env%optlev = optlev_tmp @@ -1304,6 +1305,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) call chdirdbug(tmppath2) !--- SP of each cluster +! (works with legacy and calculator version since xtb_sp_qcg switches automatically) call ens%write('ensemble.xyz') do i = 1,env%nqcgclust call rdxmolselec('ensemble.xyz',i,clus%nat,clus%at,clus%xyz) @@ -1410,8 +1412,11 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) conv(k+1:env%nqcgclust) = 0 !--- Parallel optimization------------------------------------------------------------------- - call cff_opt(.false.,env,'solvent_cluster.coord',n_ini,conv(env%nqcgclust+1)& - &,'TMPCFF',conv,nothing_added) + if (env%legacy) then + ! from my understanding this doesn't actually return any useful at this point??? + call cff_opt(.false.,env,'solvent_cluster.coord',n_ini,conv(env%nqcgclust+1)& + &,'TMPCFF',conv,nothing_added) + end if !---------------------------------------------------------------------------------------------- do i = 1,env%nqcgclust @@ -1560,15 +1565,15 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) !--- Boltz. average------------------------------------------------------------------------- write (stdout,*) - write (stdout,'(2x,''70("-")'')') - write (stdout,'(2x,''70("-")'')') + write (stdout,'(2x,70("-"))') + write (stdout,'(2x,70("-"))') write (stdout,'(2x,''Boltz. averaged energy of final cluster:'')') e_cluster = solv_ens%er*autokcal e_norm = e_norm*autokcal call sort_min(env%nqcgclust,1,1,e_norm) call aver(.true.,env,solv_ens%nall,e_norm(1:env%nqcgclust),S,H,G,sasa,.false.) - write (stdout,'(7x,''G /Eh :'',F14.8)') G/autokcal - write (stdout,'(7x,''T*S /kcal :'',f8.3)') S + write (stdout,'(7x,''G /Eh :'',f15.8)') G/autokcal + write (stdout,'(7x,''T*S /kcal :'',f15.8)') S solv_ens%er = e_norm/autokcal !normalized energy needed for final evaluation solv_ens%g = G @@ -1585,11 +1590,12 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) !--- Printouts write (stdout,*) - write (stdout,'(2x,''Solvent cluster generation finished.'')') - write (stdout,'(2x,''Results can be found in solvent_cluster directory'')') - write (stdout,'(2x,''Structures in file '')') - write (stdout,'(2x,''Energies in file '')') - write (stdout,'(2x,''Population in file '')') + write (stdout,'(2x,"Solvent cluster generation finished.")') + write (stdout,'(2x,"Results can be found in [solvent_cluster] directory")') + write (stdout,'(2x,"--> What? --> Where?")') + write (stdout,'(2x,"Structures crest_ensemble.xyz")') + write (stdout,'(2x,"Energies cluster_energy.dat")') + write (stdout,'(2x,"Population population.dat")') env%gfnver = gfnver_tmp env%optlev = optlev_tmp diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index a8864dfe..0c63006b 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -609,7 +609,7 @@ end subroutine ensemble_dock ! xTB CFF optimization performed in parallel !___________________________________________________________________________________ -subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) +subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added) use crest_parameters use iomod use crest_data @@ -621,7 +621,7 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) character(len=*),intent(in) :: TMPdir !directory name integer,intent(inout) :: NTMP !number of structures to be optimized integer,intent(inout) :: conv(env%nqcgclust+1) - logical,intent(in) :: postopt + logical,intent(in) :: pr logical,intent(in) :: nothing_added(env%nqcgclust) integer :: i,k,n12 integer :: vz,T,Tn @@ -635,13 +635,13 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) ! setting the threads for correct parallelization call new_ompautoset(env,'auto',NTMP,T,Tn) - if (postopt) then + if (pr) then write (stdout,'(2x,''Starting optimizations + SP of structures'')') write (stdout,'(2x,i0,'' jobs to do.'')') NTMP end if -! postopt eq true => post opt run, which has to be performed in every directory !!! - if (postopt) then +! pr eq true => post opt run, which has to be performed in every directory !!! + if (pr) then k = 0 NTMP = env%nqcgclust do i = 1,env%nqcgclust @@ -663,7 +663,7 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) write (funit,'(3x,"atoms: 1-",i0)') n12 !Initial number of atoms (starting solvent shell) end if close (funit) - if (postopt.and.nothing_added(i)) call remove('xcontrol') + if (pr.and.nothing_added(i)) call remove('xcontrol') call chdirdbug(trim(thispath)) end do @@ -677,7 +677,7 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) end if k = 0 !counting the finished jobs - if (postopt) call printprogbar(0.0_wp) + if (pr) call printprogbar(0.0_wp) !___________________________________________________________________________________ !$omp parallel & @@ -691,7 +691,7 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) !$omp critical k = k+1 percent = float(k)/float(NTMP)*100 - if (postopt) then + if (pr) then call printprogbar(percent) end if !$omp end critical @@ -720,7 +720,7 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) end if k = 0 !counting the finished jobs - if (postopt) call printprogbar(0.0_wp) + if (pr) call printprogbar(0.0_wp) !___________________________________________________________________________________ !$omp parallel & @@ -734,7 +734,7 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) !$omp critical k = k+1 percent = float(k)/float(NTMP)*100 - if (postopt) then + if (pr) then call printprogbar(percent) end if !$omp end critical @@ -754,13 +754,162 @@ subroutine cff_opt(postopt,env,fname,n12,NTMP,TMPdir,conv,nothing_added) call chdirdbug(trim(thispath)) end do - if (postopt) then + if (pr) then write (stdout,*) '' write (stdout,'(2x,"done.")') end if end subroutine cff_opt +subroutine cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added) + use crest_parameters + use iomod + use crest_data + use strucrd + implicit none + + type(systemdata) :: env + character(len=*),intent(in) :: fname !file base name + character(len=*),intent(in) :: TMPdir !directory name + integer,intent(inout) :: NTMP !number of structures to be optimized + integer,intent(inout) :: conv(env%nqcgclust+1) + logical,intent(in) :: pr + logical,intent(in) :: nothing_added(env%nqcgclust) + integer :: i,k,n12 + integer :: vz,T,Tn + integer :: funit + character(len=20) :: pipe + character(len=512) :: thispath,tmppath + character(len=1024) :: jobcall + character(len=2) :: flag + real(wp) :: percent + + if (pr) then + write (stdout,'(2x,"Starting optimizations + SP of structures")') + write (stdout,'(2x,i0,'' jobs to do.'')') NTMP + end if + +! pr eq true => post opt run, which has to be performed in every directory !!! + if (pr) then + k = 0 + NTMP = env%nqcgclust + do i = 1,env%nqcgclust + k = k+1 + conv(k) = i + conv(env%nqcgclust+1) = k + end do + end if + pipe = '2>/dev/null' + + call getcwd(thispath) + do i = 1,NTMP + write (tmppath,'(a,i0)') trim(TMPdir),conv(i) + call chdirdbug(trim(tmppath)) + open (newunit=funit,file='xcontrol') + if (n12 .ne. 0) then + flag = '$' + write (funit,'(a,"fix")') trim(flag) + write (funit,'(3x,"atoms: 1-",i0)') n12 !Initial number of atoms (starting solvent shell) + end if + close (funit) + if (pr.and.nothing_added(i)) call remove('xcontrol') + call chdirdbug(trim(thispath)) + end do + +!--- Jobcall WITHOUT GBSA + write (jobcall,'(a,1x,a,1x,a,'' --input xcontrol --opt '',i0,1x,a,'' >xtb.out'')') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),nint(env%optlev),trim(pipe) + + if (NTMP .lt. 1) then + write (stdout,'(2x,"No structures to be optimized")') + return + end if + + k = 0 !counting the finished jobs + if (pr) call printprogbar(0.0_wp) +!___________________________________________________________________________________ + +!$omp parallel & +!$omp shared( vz,jobcall,NTMP,percent,k,TMPdir,conv ) +!$omp single + do i = 1,NTMP + vz = i + !$omp task firstprivate( vz ) private( tmppath ) + write (tmppath,'(a,i0)') trim(TMPdir),conv(vz) + call command('cd '//trim(tmppath)//' && '//trim(jobcall)) + !$omp critical + k = k+1 + percent = float(k)/float(NTMP)*100 + if (pr) then + call printprogbar(percent) + end if + !$omp end critical + !$omp end task + end do +!$omp taskwait +!$omp end single +!$omp end parallel + +!__________________________________________________________________________________ + + do i = 1,NTMP + write (tmppath,'(a,i0)') trim(TMPdir),conv(i) + call chdirdbug(trim(tmppath)) + call remove('xtbrestart') + call chdirdbug(trim(thispath)) + end do + + !create the system call for sp (needed for gbsa model) + write (jobcall,'(a,1x,a,1x,a,'' --sp '',a,1x,a,'' >xtb_sp.out'')') & + & trim(env%ProgName),'xtbopt.coord',trim(env%gfnver),trim(env%solv),trim(pipe) + + if (NTMP .lt. 1) then + write (stdout,'(2x,"Nothing to do")') + return + end if + + k = 0 !counting the finished jobs + if (pr) call printprogbar(0.0_wp) +!___________________________________________________________________________________ + +!$omp parallel & +!$omp shared( vz,jobcall,NTMP,percent,k,TMPdir,conv ) +!$omp single + do i = 1,NTMP + vz = i + !$omp task firstprivate( vz ) private( tmppath ) + write (tmppath,'(a,i0)') trim(TMPdir),conv(vz) + call command('cd '//trim(tmppath)//' && '//trim(jobcall)) + !$omp critical + k = k+1 + percent = float(k)/float(NTMP)*100 + if (pr) then + call printprogbar(percent) + end if + !$omp end critical + !$omp end task + end do +!$omp taskwait +!$omp end single +!$omp end parallel + +!___________________________________________________________________________________ + + do i = 1,NTMP + write (tmppath,'(a,i0)') trim(TMPdir),conv(i) + call chdirdbug(trim(tmppath)) + call remove('xtbrestart') + !call remove('xcontrol') + call chdirdbug(trim(thispath)) + end do + + if (pr) then + write (stdout,*) '' + write (stdout,'(2x,"done.")') + end if + +end subroutine cff_opt_calculator + !___________________________________________________________________________________ ! ! xTB SP performed in parallel @@ -864,7 +1013,7 @@ subroutine ens_sp(env,fname,NTMP,TMPdir) write (stdout,'(2x,''---------------------------------------------'')') write (stdout,'(2x,''Single point computation with GBSA/ALPB model'')') - write (stdout,'(2x,''---------------------------------------------'')') + write (stdout,'(2x,''---------------------------------------------'')') write (stdout,'(2x,i0,'' jobs to do.'')') NTMP pipe = '2>/dev/null' @@ -1021,7 +1170,6 @@ end subroutine ens_freq subroutine wr_cluster_cut(fname_cluster,n1,n2,iter,fname_solu_cut,fname_solv_cut) use crest_parameters use strucrd - implicit none integer,intent(in) :: n1,n2,iter real(wp) :: xyz1(3,n1) @@ -1032,8 +1180,8 @@ subroutine wr_cluster_cut(fname_cluster,n1,n2,iter,fname_solu_cut,fname_solv_cut character(len=2) :: a2 integer :: ich,i,k,stat,io,io2 - ich = 142 - open (unit=ich,file=fname_cluster,iostat=stat) + !ich = 142 + open (newunit=ich,file=fname_cluster,iostat=stat) read (ich,'(a)') atmp k = 1 do i = 1,n1 From 3fb7812dfb9c1e1bd378bd5cf5b9639ca5337401 Mon Sep 17 00:00:00 2001 From: Lukas Rindt Date: Tue, 9 Dec 2025 14:30:57 +0100 Subject: [PATCH 102/374] direct bfgs implemented --- src/algos/hessian_tools.f90 | 199 ++++----- src/calculator/calc_type.f90 | 6 +- src/calculator/hessian_reconstruct.f90 | 142 ++++++- src/entropy/thermochem_module.f90 | 533 +++++++++++++------------ src/legacy_wrappers.f90 | 13 + src/optimize/ancopt.f90 | 42 +- src/optimize/optimize_maths.f90 | 22 + src/optimize/optimize_module.f90 | 86 ++-- src/optimize/rfo.f90 | 79 +++- src/parsing/confparse2.f90 | 46 ++- src/parsing/parse_calcdata.f90 | 16 +- 11 files changed, 706 insertions(+), 478 deletions(-) diff --git a/src/algos/hessian_tools.f90 b/src/algos/hessian_tools.f90 index aa713508..b8ad197f 100644 --- a/src/algos/hessian_tools.f90 +++ b/src/algos/hessian_tools.f90 @@ -28,7 +28,7 @@ !========================================================================================! module hessian_tools - use crest_parameters, only:wp,stdout + use crest_parameters,only:wp,stdout use crest_data use crest_calculator use strucrd @@ -44,7 +44,6 @@ module hessian_tools !=========================================================================================! !=========================================================================================! - subroutine frequencies(nat,at,xyz,nat3,prj_mw_hess,freq,io) !************************************************* !* Returns the Frequencies from a Hessian in cm-1 @@ -95,7 +94,6 @@ subroutine frequencies(nat,at,xyz,nat3,prj_mw_hess,freq,io) end subroutine frequencies - subroutine mass_weight_hess(nat,at,nat3,hess) use atmasses implicit none @@ -130,53 +128,11 @@ subroutine mass_weight_hess(nat,at,nat3,hess) return end subroutine mass_weight_hess - subroutine dsqtoh(n,a,b) -!**************************************************** -!* converts upper triangle of a matrix into a vector -!**************************************************** - implicit none - integer,intent(in) :: n - real(wp),intent(in) :: a(n,n) - real(wp),intent(out) :: b(n*(n+1)/2) - integer :: i,j,k - - k = 0 - do i = 1,n - do j = 1,i - k = k+1 - b(k) = a(i,j) - end do - end do - - end subroutine dsqtoh - - subroutine dhtosq(n,a,b) -!********************************************************* -!* converts upper triangle vector into a symmetric matrix -!********************************************************* - implicit none - integer,intent(in) :: n - real(wp),intent(out) :: a(n,n) - real(wp),intent(in) :: b(n*(n+1)/2) - integer :: i,j,k - - k = 0 - do i = 1,n - do j = 1,i - k = k+1 - a(j,i) = b(k) - a(i,j) = b(k) - end do - end do - - return - end subroutine dhtosq - !=========================================================================================! subroutine prj_mw_hess(nat,at,nat3,xyz,hess) !*************************************************************** -!* Projection of the translational and rotational DOF out of +!* Projection of the translational and rotational DOF out of !* the numerical Hessian plus the mass-weighting of the Hessian !*************************************************************** implicit none @@ -187,9 +143,14 @@ subroutine prj_mw_hess(nat,at,nat3,xyz,hess) real(wp) :: xyz(3,nat) !real(wp) :: hess_ut(nat3*(nat3+1)/2),pmode(nat3,1) real(wp),allocatable :: hess_ut(:),pmode(:,:) + integer :: i - allocate(hess_ut(nat3*(nat3+1)/2), source=0.0_wp) - allocate(pmode(nat3,1), source=0.0_wp) + allocate (hess_ut(nat3*(nat3+1)/2),source=0.0_wp) + allocate (pmode(nat3,1),source=0.0_wp) + + do i = 1,size(hess,dim=1) + print*,hess(1,i) + end do !> Transforms matrix of the upper triangle vector call dsqtoh(nat3,hess,hess_ut) @@ -203,14 +164,14 @@ subroutine prj_mw_hess(nat,at,nat3,xyz,hess) !> Mass weighting call mass_weight_hess(nat,at,nat3,hess) - deallocate(pmode,hess_ut) + deallocate (pmode,hess_ut) end subroutine prj_mw_hess !=========================================================================================! subroutine print_vib_spectrum(nat,at,nat3,xyz,freq,dir,fname) !********************************************************************* -!* Prints the frequencies in Turbomoles "vibspectrum" format +!* Prints the frequencies in Turbomoles "vibspectrum" format !* The intensity is only artficially set to 1000 for every vibration!! !********************************************************************** integer,intent(in) :: nat,nat3 @@ -224,14 +185,13 @@ subroutine print_vib_spectrum(nat,at,nat3,xyz,freq,dir,fname) if (len_trim(dir) .eq. 0) then open (newunit=ich,file=fname) else - if(directory_exist(dir))then - open (newunit=ich,file=dir//'/'//fname) + if (directory_exist(dir)) then + open (newunit=ich,file=dir//'/'//fname) else - open (newunit=ich,file=fname) - endif + open (newunit=ich,file=fname) + end if end if - write (ich,'("$vibrational spectrum")') write (ich,'("# mode symmetry wave number IR intensity selection rules")') write (ich,'("# 1/cm km/mol IR RAMAN")') @@ -291,11 +251,11 @@ subroutine print_g98_fake(nat,at,nat3,xyz,freq,hess,dir,fname) if (len_trim(dir) .eq. 0) then open (newunit=gu,file=fname) else - if(directory_exist(dir))then - open (newunit=gu,file=dir//'/'//fname) + if (directory_exist(dir)) then + open (newunit=gu,file=dir//'/'//fname) else - open (newunit=gu,file=fname) - endif + open (newunit=gu,file=fname) + end if end if write (gu,'('' Entering Gaussian System'')') @@ -371,7 +331,6 @@ end subroutine print_g98_fake !=========================================================================================! - subroutine print_hessian(hess,nat3,dir,fname) !******************************* !* Prints the numerical hessian @@ -385,15 +344,15 @@ subroutine print_hessian(hess,nat3,dir,fname) open (newunit=ich,file=fname) write (stdout,'(1x,a)',advance='no') 'Will be written to file "'//fname//'" ...' else - if(directory_exist(dir))then - open (newunit=ich,file=dir//'/'//fname) - write (stdout,'(1x,a)',advance='no') 'Will be written to file "'//dir//'/'//fname//'" ...' + if (directory_exist(dir)) then + open (newunit=ich,file=dir//'/'//fname) + write (stdout,'(1x,a)',advance='no') 'Will be written to file "'//dir//'/'//fname//'" ...' else - open (newunit=ich,file=fname) - write (stdout,'(1x,a)',advance='no') 'Will be written to file "'//fname//'" ...' - endif + open (newunit=ich,file=fname) + write (stdout,'(1x,a)',advance='no') 'Will be written to file "'//fname//'" ...' + end if end if - flush(stdout) + flush (stdout) write (ich,'(1x,a)') '$hessian' do i = 1,nat3 @@ -423,7 +382,7 @@ end subroutine print_hessian subroutine effective_hessian(nat,nat3,grad1_i,grad2_i,hess1,hess2,heff) !****************************************************************** -!* Effective Hessian at an MECP is computed via Eq. 27 and Eq. 28 +!* Effective Hessian at an MECP is computed via Eq. 27 and Eq. 28 !* in https://doi.org/10.1002/qua.25124 !****************************************************************** implicit none @@ -513,67 +472,67 @@ end subroutine effective_hessian !=========================================================================================! - subroutine calculate_frequencies(calc,nat,at,xyz,freq,io,constraints) + subroutine calculate_frequencies(calc,nat,at,xyz,freq,io,constraints) !******************************************************* !* Bundels several routines from this module to !* calculate the vib. frequencies for a given structure -!* The output frequencies are in cm-1 +!* The output frequencies are in cm-1 !******************************************************* - implicit none - !> INPUT - type(calcdata),intent(inout) :: calc - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - real(wp),intent(in) :: xyz(3,nat) - logical,intent(in),optional :: constraints - !> OUTPUT - integer,intent(out) :: io - real(wp),intent(out) :: freq(3*nat) - !> LOCAL - real(wp),allocatable :: hessian(:,:) - real(wp),allocatable :: chess(:,:) - type(calcdata) :: dummycalc - integer :: nat3,ncalc,i - - io = 0 - freq = 0.0_wp - nat3 = nat*3 - ncalc = calc%ncalculations - - allocate(hessian(nat3,nat3), source = 0.0_wp) - - !>--- Hessian from combined energy and gradient - call numhess1(nat,at,xyz, calc,hessian,io) - if( io /= 0 ) return - - !>--- do we consider contributions from the constraints? - !> (yes, by default, they are in the hessian from numhess1, - !> if we DO NOT want them, we need to take them out again) - if(present(constraints))then - if(.not.constraints)then - dummycalc = calc !> new dummy calculation - dummycalc%id = 0 !> set to zero so that ONLY constraints are considered - dummycalc%ncalculations = 0 - dummycalc%pr_energies = .false. - allocate (chess(nat3,nat3),source=0.0_wp) - call numhess1(nat,at,xyz,dummycalc,chess,io) - hessian(:,:) = hessian(:,:) - chess(:,:) - deallocate( chess ) - endif - endif - - do i = 1,calc%ncalculations + implicit none + !> INPUT + type(calcdata),intent(inout) :: calc + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(in) :: xyz(3,nat) + logical,intent(in),optional :: constraints + !> OUTPUT + integer,intent(out) :: io + real(wp),intent(out) :: freq(3*nat) + !> LOCAL + real(wp),allocatable :: hessian(:,:) + real(wp),allocatable :: chess(:,:) + type(calcdata) :: dummycalc + integer :: nat3,ncalc,i + + io = 0 + freq = 0.0_wp + nat3 = nat*3 + ncalc = calc%ncalculations + + allocate (hessian(nat3,nat3),source=0.0_wp) + + !>--- Hessian from combined energy and gradient + call numhess1(nat,at,xyz,calc,hessian,io) + if (io /= 0) return + + !>--- do we consider contributions from the constraints? + !> (yes, by default, they are in the hessian from numhess1, + !> if we DO NOT want them, we need to take them out again) + if (present(constraints)) then + if (.not.constraints) then + dummycalc = calc !> new dummy calculation + dummycalc%id = 0 !> set to zero so that ONLY constraints are considered + dummycalc%ncalculations = 0 + dummycalc%pr_energies = .false. + allocate (chess(nat3,nat3),source=0.0_wp) + call numhess1(nat,at,xyz,dummycalc,chess,io) + hessian(:,:) = hessian(:,:)-chess(:,:) + deallocate (chess) + end if + end if + + do i = 1,calc%ncalculations !>-- Projects and mass-weights the Hessian - call prj_mw_hess(nat,at,nat3,xyz, hessian(:,:)) + call prj_mw_hess(nat,at,nat3,xyz,hessian(:,:)) !>-- Computes the Frequencies - call frequencies(nat,at,xyz,nat3, hessian(:,:), freq(:),io) - end do + call frequencies(nat,at,xyz,nat3,hessian(:,:),freq(:),io) + end do - deallocate( hessian ) - return - end subroutine calculate_frequencies + deallocate (hessian) + return + end subroutine calculate_frequencies !=========================================================================================! end module hessian_tools diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index a664b7b0..e77760b8 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -269,8 +269,12 @@ module calc_type !>--- Hessian Reconstructor type(cashed_hessian),allocatable :: chess - logical :: do_HU = .true. + logical :: do_HU = .false. integer :: hu_steps = 10 + integer :: nt + real(wp),allocatable :: temperatures(:) + real(wp),allocatable :: et(:),ht(:),gt(:),stot(:) + real(wp) :: ithr,fscal,sthr !>--- Type procedures contains diff --git a/src/calculator/hessian_reconstruct.f90 b/src/calculator/hessian_reconstruct.f90 index c6c14c54..6fab7599 100644 --- a/src/calculator/hessian_reconstruct.f90 +++ b/src/calculator/hessian_reconstruct.f90 @@ -1,10 +1,11 @@ module hessian_reconstruct use iso_fortran_env,only:wp => real64 - !use hessian_tools, only:frequencies + use hessupdate_module + use optimize_maths implicit none private - public cashed_hessian + public cashed_hessian,invert_matrix type :: cashed_hessian @@ -12,9 +13,11 @@ module hessian_reconstruct real(wp),allocatable :: gradient(:,:,:) real(wp),allocatable :: coords(:,:,:) real(wp),allocatable :: energy(:) - real(wp),allocatable :: s(:,:),y(:,:),B(:,:),H(:,:),p(:),rho(:),V(:,:,:),I(:,:) + real(wp),allocatable :: s(:,:),y(:,:),B(:,:),H(:,:),Hinv(:,:),p(:),rho(:),V(:,:,:),I(:,:) integer,allocatable :: order(:),natm integer :: stepcount = 0 + real(wp) :: hguess = 0.02_wp + real(wp),allocatable ::hguess_mat(:,:) contains @@ -23,16 +26,19 @@ module hessian_reconstruct procedure :: update => update_cashed_hessian procedure :: construct_hessian_lbfgs procedure :: compute_intermediates + procedure :: construct_hessian_bfgs end type cashed_hessian contains - subroutine cashed_hessian_allocate(self,N,steps) + subroutine cashed_hessian_allocate(self,N,steps,hguess) !> maybe make keywords optional later integer,intent(in) :: N,steps class(cashed_hessian),intent(inout) :: self + real(wp),intent(in) :: hguess self%steps = steps + self%hguess = hguess self%natm = N allocate (self%gradient(steps,3,N)) allocate (self%coords(steps,3,N)) @@ -44,7 +50,10 @@ subroutine cashed_hessian_allocate(self,N,steps) allocate (self%rho(self%steps-1)) allocate (self%V(self%steps-1,3*N,3*N)) allocate (self%I(3*N,3*N)) - + allocate (self%hguess_mat(3*N,3*N)) + allocate (self%H(3*N,3*N)) + allocate (self%Hinv(3*N,3*N)) + allocate (self%B(3*N,3*N)) self%order(:) = 0 @@ -69,39 +78,108 @@ end subroutine cashed_hessian_deallocate subroutine update_cashed_hessian(self,gradient,energy,coords) class(cashed_hessian),intent(inout) :: self real(wp),intent(in) :: gradient(:,:),energy,coords(:,:) - integer :: idx - + integer :: idx,i + !print*, coords self%stepcount = self%stepcount+1 + !print*, self%order + !print*, coords(:,:) idx = minloc(self%order,1) self%order(idx) = self%stepcount self%gradient(idx,:,:) = gradient self%energy(idx) = energy self%coords(idx,:,:) = coords + !if (idx==1) then + ! print*, self%coords(1,:,:) + ! print*, self%coords(2,:,:) + ! print*, self%coords(3,:,:) + !endif + !PRINT*, self%order + !print*, self%coords(1,:,:) + !print*, self%coords(2,:,:) + print*,size(self%coords,dim=1) end subroutine update_cashed_hessian - recursive subroutine construct_hessian_lbfgs(self,n) + subroutine construct_hessian_bfgs(self) class(cashed_hessian),intent(inout) :: self + integer :: i,j,k,nat3 + real(wp),allocatable :: tmp(:),tmp_coords(:,:),tmp_grads(:,:),hess(:),dx(:) + real(wp) :: gnorm + + nat3 = 3*self%natm + + allocate (tmp_coords(self%steps,nat3)) + allocate (tmp_grads(self%steps,nat3)) + allocate (tmp(self%steps)) + allocate (hess(nat3*(nat3+1)/2)) + allocate (dx(nat3)) + + tmp = self%order + + tmp_coords = reshape(self%coords, [self%steps,nat3]) + tmp_grads = reshape(self%gradient, [self%steps,nat3]) + + if (minval(tmp) == 0) then + print*,"ERROR: Number of recursive steps for hessian reconstruction larger than number of geoemtry optimization steps!" + else + do i = 1,self%steps + if (i == 1) then + j = minloc(tmp,1) + tmp(j) = HUGE(tmp(j)) + do k = 1,nat3 + self%hguess_mat(k,k) = self%hguess + end do + call dsqtoh(nat3,self%hguess_mat,hess) + else + j = minloc(tmp,1) + if (j == 1) then + dx = tmp_coords(j,:)-tmp_coords(self%steps,:) + call bfgs(nat3,gnorm,tmp_grads(j,:),tmp_grads(self%steps,:),dx,hess) + else + dx = tmp_coords(j,:)-tmp_coords(j-1,:) + call bfgs(nat3,gnorm,tmp_grads(j,:),tmp_grads(j-1,:),dx,hess) + end if + tmp(j) = HUGE(tmp(j)) + end if + end do + end if + + call dhtosq(nat3,self%B,hess) + + end subroutine construct_hessian_bfgs + + recursive subroutine construct_hessian_lbfgs(self,n) !> refactor this to reduce memory by + class(cashed_hessian),intent(inout) :: self !> computing intermediates within this routine integer,intent(in) :: n real(wp),allocatable :: temp(:,:) + !real(wp), allocatable :: test_mat(:,:) + + !allocate (test_mat(3*self%natm,3*self%natm)) allocate (temp(3*self%natm,3*self%natm)) if (n == 0) then call self%compute_intermediates() allocate (self%B(3*self%natm,3*self%natm)) - self%B = self%I + self%B = self%hguess else call self%construct_hessian_lbfgs(n-1) temp = matmul(matmul(TRANSPOSE(self%V(n,:,:)),self%B),self%V(n,:,:))+self%p(n)*(matmul(reshape(self%s(n,:), [3*self%natm,1]),reshape(self%s(n,:), [1,3*self%natm]))) self%B = temp + print* + print*,"updated Hessian number",N + print* + print*,temp(1,:) end if end subroutine construct_hessian_lbfgs subroutine compute_intermediates(self) class(cashed_hessian),intent(inout) :: self - integer :: i,j,k + integer :: i,j,k,l real(wp),allocatable :: tmp(:),tmp_coords(:,:),tmp_grads(:,:) + real(wp),allocatable :: temp_mat(:,:) + + allocate (temp_mat(3*self%natm,3*self%natm)) allocate (tmp_coords(self%steps,3*self%natm)) allocate (tmp_grads(self%steps,3*self%natm)) @@ -114,6 +192,12 @@ subroutine compute_intermediates(self) self%I(k,k) = 1.0_wp end do + self%hguess_mat = 0.0_wp + + do l = 1,3*self%natm + self%hguess_mat = self%hguess + end do + tmp_coords = reshape(self%coords, [self%steps,3*self%natm]) tmp_grads = reshape(self%gradient, [self%steps,3*self%natm]) @@ -134,12 +218,48 @@ subroutine compute_intermediates(self) self%y(i-1,:) = tmp_grads(j,:)-tmp_grads(j-1,:) end if self%p(i-1) = 1/(dot_product(self%y(i-1,:),self%s(i-1,:))) - self%V(i-1,:,:) = self%I-self%p(i-1)*(matmul(reshape(self%y(i-1,:), [3*self%natm,1]),reshape(self%s(i-1,:), [1,3*self%natm]))) + self%V(i-1,:,:) = (self%I(:,:))-(self%p(i-1)*(matmul(reshape(self%y(i-1,:), [3*self%natm,1]),reshape(self%s(i-1,:), [1,3*self%natm])))) tmp(j) = HUGE(tmp(j)) + !temp_mat = self%p(i-1)*(matmul(reshape(self%y(i-1,:), [3*self%natm,1]),reshape(self%s(i-1,:), [1,3*self%natm]))) end if end do end if end subroutine compute_intermediates + ! Returns the inverse of a matrix calculated by finding the LU +! decomposition. Depends on LAPACK. + function invert_matrix(A) result(Ainv) + real(wp),dimension(:,:),intent(in) :: A + real(wp),dimension(size(A,1),size(A,2)) :: Ainv + + real(wp),dimension(size(A,1)) :: work ! work array for LAPACK + integer,dimension(size(A,1)) :: ipiv ! pivot indices + integer :: n,info + + ! External procedures defined in LAPACK + external DGETRF + external DGETRI + + ! Store A in Ainv to prevent it from being overwritten by LAPACK + Ainv = A + n = size(A,1) + + ! DGETRF computes an LU factorization of a general M-by-N matrix A + ! using partial pivoting with row interchanges. + call DGETRF(n,n,Ainv,n,ipiv,info) + + if (info /= 0) then + stop 'Matrix is numerically singular!' + end if + + ! DGETRI computes the inverse of a matrix using the LU factorization + ! computed by DGETRF. + call DGETRI(n,Ainv,n,ipiv,work,n,info) + + if (info /= 0) then + stop 'Matrix inversion failed!' + end if + end function invert_matrix + end module hessian_reconstruct diff --git a/src/entropy/thermochem_module.f90 b/src/entropy/thermochem_module.f90 index f3304dac..e9e3a6a9 100644 --- a/src/entropy/thermochem_module.f90 +++ b/src/entropy/thermochem_module.f90 @@ -1,296 +1,303 @@ module thermochem_module - !use iso_fortran_env,only:wp => real64 use crest_parameters use getsymmetry use hessian_tools - !use hessian_tools, only:frequencies + use atmasses,only:molweight + use iomod,only:to_lower + use axis_module implicit none private - public calcthermo + public calcthermo,calc_thermo_from_hess - contains +contains subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar) !*********************************************************************** !* Prepare the calculation of thermodynamic properties of a structure !* In particular, determine rotational constants and check the symmetry !*********************************************************************** - !use crest_parameters,only:wp,bohr,stdout, aatoau, autoaa - use atmasses,only:molweight - use iomod,only:to_lower - use axis_module - implicit none - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) !> in Angstroem - logical,intent(in) :: pr - real(wp),intent(out) :: molmass - real(wp),intent(inout) :: rabc(3) - real(wp),intent(out) :: avmom - real(wp),intent(out) :: symnum - - real(wp) :: a,b,c - character(len=4) :: sfsym - character(len=3) :: sym,symchar - real(wp),parameter :: desy = 0.1_wp - integer,parameter :: maxat = 200 - - !>--- molecular mass in amu - molmass = molweight(nat,at) - - if (pr) then - write (stdout,'(1x,a,f15.2)') 'Mol. weight /amu : ',molmass - end if - - !>--- rotational constants in cm-1 - rabc = 0.0d0 - call axis(nat,at,xyz,rabc(1:3),avmom) - a = rabc(3) - b = rabc(2) - c = rabc(1) - rabc(1) = a - rabc(3) = c - if (pr) then - write (stdout,'(1x,a,3f15.2)') 'Rot. const. /MHz : ',rabc(1:3) - end if - rabc = rabc/2.99792458d+4 ! MHz to cm-1 - if (pr) then - write (stdout,'(1x,a,3f15.2)') 'Rot. const. /cm-1 : ',rabc(1:3) - end if - - !>--- symmetry number from rotational symmetry - xyz = xyz/bohr - call getsymmetry2(.false.,6,nat,at,xyz,desy,maxat,sfsym) - xyz = xyz*bohr - sym = sfsym(1:3) - symchar = sym - symnum = 1.0d0 - if (a .lt. 1.d-9.or.b .lt. 1.d-9.or.c .lt. 1.d-9) then - if (index(sym,'d') .ne. 0) symnum = 2.0d0 - else - call to_lower(sym) - if (index(sym,'c2') .ne. 0) symnum = 2.0d0 - if (index(sym,'s4') .ne. 0) symnum = 2.0d0 - if (index(sym,'c3') .ne. 0) symnum = 3.0d0 - if (index(sym,'s6') .ne. 0) symnum = 3.0d0 - if (index(sym,'c4') .ne. 0) symnum = 4.0d0 - if (index(sym,'s8') .ne. 0) symnum = 4.0d0 - if (index(sym,'c5') .ne. 0) symnum = 5.0d0 - if (index(sym,'c6') .ne. 0) symnum = 6.0d0 - if (index(sym,'c7') .ne. 0) symnum = 7.0d0 - if (index(sym,'c8') .ne. 0) symnum = 8.0d0 - if (index(sym,'c9') .ne. 0) symnum = 9.0d0 - if (index(sym,'d2') .ne. 0) symnum = 4.0d0 - if (index(sym,'d3') .ne. 0) symnum = 6.0d0 - if (index(sym,'d4') .ne. 0) symnum = 8.0d0 - if (index(sym,'d5') .ne. 0) symnum = 10.0d0 - if (index(sym,'d6') .ne. 0) symnum = 12.0d0 - if (index(sym,'d7') .ne. 0) symnum = 14.0d0 - if (index(sym,'d8') .ne. 0) symnum = 16.0d0 - if (index(sym,'d9') .ne. 0) symnum = 18.0d0 - if (index(sym,'t') .ne. 0) symnum = 12.0d0 - if (index(sym,'td') .ne. 0) symnum = 12.0d0 - if (index(sym,'th') .ne. 0) symnum = 12.0d0 - if (index(sym,'o') .ne. 0) symnum = 24.0d0 - if (index(sym,'oh') .ne. 0) symnum = 24.0d0 - if (index(sym,'ih') .ne. 0) symnum = 60.0d0 - end if - - if (pr) then - write (stdout,'(1x,a,4x,a)') 'Symmetry:',sym - end if - return -end subroutine prepthermo - -subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & - & et,ht,gt,stot) + implicit none + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) !> in Angstroem + logical,intent(in) :: pr + real(wp),intent(out) :: molmass + real(wp),intent(inout) :: rabc(3) + real(wp),intent(out) :: avmom + real(wp),intent(out) :: symnum + + real(wp) :: a,b,c + character(len=4) :: sfsym + character(len=3) :: sym,symchar + real(wp),parameter :: desy = 0.1_wp + integer,parameter :: maxat = 200 + + !>--- molecular mass in amu + molmass = molweight(nat,at) + + if (pr) then + write (stdout,'(1x,a,f15.2)') 'Mol. weight /amu : ',molmass + end if + + !>--- rotational constants in cm-1 + rabc = 0.0d0 + call axis(nat,at,xyz,rabc(1:3),avmom) + a = rabc(3) + b = rabc(2) + c = rabc(1) + rabc(1) = a + rabc(3) = c + if (pr) then + write (stdout,'(1x,a,3f15.2)') 'Rot. const. /MHz : ',rabc(1:3) + end if + rabc = rabc/2.99792458d+4 ! MHz to cm-1 + if (pr) then + write (stdout,'(1x,a,3f15.2)') 'Rot. const. /cm-1 : ',rabc(1:3) + end if + + !>--- symmetry number from rotational symmetry + xyz = xyz/bohr + call getsymmetry2(.false.,6,nat,at,xyz,desy,maxat,sfsym) + xyz = xyz*bohr + sym = sfsym(1:3) + symchar = sym + symnum = 1.0d0 + if (a .lt. 1.d-9.or.b .lt. 1.d-9.or.c .lt. 1.d-9) then + if (index(sym,'d') .ne. 0) symnum = 2.0d0 + else + call to_lower(sym) + if (index(sym,'c2') .ne. 0) symnum = 2.0d0 + if (index(sym,'s4') .ne. 0) symnum = 2.0d0 + if (index(sym,'c3') .ne. 0) symnum = 3.0d0 + if (index(sym,'s6') .ne. 0) symnum = 3.0d0 + if (index(sym,'c4') .ne. 0) symnum = 4.0d0 + if (index(sym,'s8') .ne. 0) symnum = 4.0d0 + if (index(sym,'c5') .ne. 0) symnum = 5.0d0 + if (index(sym,'c6') .ne. 0) symnum = 6.0d0 + if (index(sym,'c7') .ne. 0) symnum = 7.0d0 + if (index(sym,'c8') .ne. 0) symnum = 8.0d0 + if (index(sym,'c9') .ne. 0) symnum = 9.0d0 + if (index(sym,'d2') .ne. 0) symnum = 4.0d0 + if (index(sym,'d3') .ne. 0) symnum = 6.0d0 + if (index(sym,'d4') .ne. 0) symnum = 8.0d0 + if (index(sym,'d5') .ne. 0) symnum = 10.0d0 + if (index(sym,'d6') .ne. 0) symnum = 12.0d0 + if (index(sym,'d7') .ne. 0) symnum = 14.0d0 + if (index(sym,'d8') .ne. 0) symnum = 16.0d0 + if (index(sym,'d9') .ne. 0) symnum = 18.0d0 + if (index(sym,'t') .ne. 0) symnum = 12.0d0 + if (index(sym,'td') .ne. 0) symnum = 12.0d0 + if (index(sym,'th') .ne. 0) symnum = 12.0d0 + if (index(sym,'o') .ne. 0) symnum = 24.0d0 + if (index(sym,'oh') .ne. 0) symnum = 24.0d0 + if (index(sym,'ih') .ne. 0) symnum = 60.0d0 + end if + + if (pr) then + write (stdout,'(1x,a,4x,a)') 'Symmetry:',sym + end if + return + end subroutine prepthermo + + subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & + & et,ht,gt,stot) !************************************************************** !* Calculate thermodynamic contributions for a given structure !* from it's frequencies (from second derivatives/the Hessian) !* Based on xtb's "print_thermo" routine !************************************************************** - use crest_parameters,only:wp,bohr,stdout - use crest_thermo - use atmasses,only:molweight - use iomod,only:to_lower - implicit none - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) !in Bohr - real(wp),intent(inout) :: freq(3*nat) !in cm-1 - logical,intent(in) :: pr - real(wp),intent(in) :: ithr !imag. inv. in cm-1 - real(wp),intent(in) :: fscal !freq scaling - real(wp),intent(in) :: sthr !rotor cut - integer,intent(in) :: nt - real(wp),intent(in) :: temps(nt) - real(wp) :: et(nt) !< enthalpy in Eh - real(wp) :: ht(nt) !< enthalpy in Eh - real(wp) :: gt(nt) !< free energy in Eh - real(wp) :: stot(nt) !< entropy in cal/molK - real(wp) :: ts(nt) !< entropy*T in Eh - real(wp) :: rabc(3),a,b,c - real(wp) :: avmom - real(wp) :: molmass - real(wp) :: sym - real(wp) :: zp - character(len=3) :: symchar - logical :: pr2 - logical :: linear = .false. - logical :: atom = .false. - integer :: nvib_theo - integer :: nvib,nimag - real(wp) :: vibthr - real(wp),allocatable :: vibs(:) - - integer :: i,j - integer :: n3,rt - real(wp) :: adum(nt) - character(len=64) :: atmp - - character(len=*),parameter :: outfmt = & - & '(9x,"::",1x,a,f24.12,1x,a,1x,"::")' - character(len=*),parameter :: dblfmt = & - & '(10x,":",2x,a,f24.7,1x,a,1x,":")' - character(len=*),parameter :: intfmt = & - & '(10x,":",2x,a,i24, 6x,":")' - character(len=*),parameter :: chrfmt = & - & '(10x,":",2x,a,a24, 6x,":")' - - real(wp),parameter :: autorcm = 219474.63067_wp - real(wp),parameter :: rcmtoau = 1.0_wp/autorcm - real(wp),parameter :: autocal = 627.50947428_wp*1000.0_wp - - xyz =xyz*autoaa - - call prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,sym,symchar) - - n3 = 3*nat - allocate (vibs(n3)) - vibthr = 1.0 - a = rabc(1) - b = rabc(2) - c = rabc(3) - - nvib_theo = 3*nat-6 - if (c .lt. 1.d-10 .or. (symchar=='din')) linear = .true. - if (linear) nvib_theo = 3*nat-5 - - if (a+b+c .lt. 1.d-6) then - atom = .true. - nvib = 0 - nvib_theo = 0 - end if - - nvib = 0 - vibs = 0.0 - do i = 1,n3 - if (abs(freq(i)) .gt. vibthr) then - nvib = nvib+1 - vibs(nvib) = freq(i) - end if - end do - !> scale - vibs(1:nvib) = vibs(1:nvib)*fscal - - !> invert imaginary modes - nimag = 0 - do i = 1,nvib - if (vibs(i) .lt. 0.and.vibs(i) .gt. ithr) then - vibs(i) = -vibs(i) - if (pr) write (stdout,'(a,i5," :",f10.2)') 'Inverting frequency',i,vibs(i) - end if - if (vibs(i) < 0.0) then - nimag = nimag+1 - end if - end do - - if (pr) then - write (stdout,'(a)') - write (stdout,'(10x,51("."))') - write (stdout,'(10x,":",22x,a,22x,":")') "SETUP" - write (stdout,'(10x,":",49("."),":")') - write (stdout,intfmt) "# frequencies ",nvib - write (stdout,intfmt) "# imaginary freq.",nimag - write (atmp,*) linear - write (stdout,chrfmt) "linear? ",trim(atmp) - write (stdout,chrfmt) "symmetry ",adjustr(symchar) - write (stdout,intfmt) "rotational number",nint(sym) - write (stdout,dblfmt) "scaling factor ",fscal," " - write (stdout,dblfmt) "rotor cutoff ",sthr,"cm⁻¹" - write (stdout,dblfmt) "imag. cutoff ",ithr,"cm⁻¹" - write (stdout,'(10x,":",49("."),":")') - end if - - vibs = vibs*rcmtoau ! thermodyn needs vibs and zp in Eh - - zp = 0.5_wp*sum(vibs(1:nvib)) - adum = abs(temps-298.15d0) - rt = minloc(adum,1) !temperature closest to 298.15 is the ref. - do j = 1,nt - if ((j == rt).and.pr) then - pr2 = .true. - else - pr2 = .false. + use crest_parameters,only:wp,bohr,stdout + use crest_thermo + use atmasses,only:molweight + use iomod,only:to_lower + implicit none + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) !in Bohr + real(wp),intent(inout) :: freq(3*nat) !in cm-1 + logical,intent(in) :: pr + real(wp),intent(in) :: ithr !imag. inv. in cm-1 + real(wp),intent(in) :: fscal !freq scaling + real(wp),intent(in) :: sthr !rotor cut + integer,intent(in) :: nt + real(wp),intent(in) :: temps(nt) + real(wp) :: et(nt) !< enthalpy in Eh + real(wp) :: ht(nt) !< enthalpy in Eh + real(wp) :: gt(nt) !< free energy in Eh + real(wp) :: stot(nt) !< entropy in cal/molK + real(wp) :: ts(nt) !< entropy*T in Eh + real(wp) :: rabc(3),a,b,c + real(wp) :: avmom + real(wp) :: molmass + real(wp) :: sym + real(wp) :: zp + character(len=3) :: symchar + logical :: pr2 + logical :: linear = .false. + logical :: atom = .false. + integer :: nvib_theo + integer :: nvib,nimag + real(wp) :: vibthr + real(wp),allocatable :: vibs(:) + + integer :: i,j + integer :: n3,rt + real(wp) :: adum(nt) + character(len=64) :: atmp + + character(len=*),parameter :: outfmt = & + & '(9x,"::",1x,a,f24.12,1x,a,1x,"::")' + character(len=*),parameter :: dblfmt = & + & '(10x,":",2x,a,f24.7,1x,a,1x,":")' + character(len=*),parameter :: intfmt = & + & '(10x,":",2x,a,i24, 6x,":")' + character(len=*),parameter :: chrfmt = & + & '(10x,":",2x,a,a24, 6x,":")' + + real(wp),parameter :: autorcm = 219474.63067_wp + real(wp),parameter :: rcmtoau = 1.0_wp/autorcm + real(wp),parameter :: autocal = 627.50947428_wp*1000.0_wp + + xyz = xyz*autoaa + + call prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,sym,symchar) + + print*,freq + + n3 = 3*nat + allocate (vibs(n3)) + vibthr = 1.0 + a = rabc(1) + b = rabc(2) + c = rabc(3) + + nvib_theo = 3*nat-6 + if (c .lt. 1.d-10.or.(symchar == 'din')) linear = .true. + if (linear) nvib_theo = 3*nat-5 + + if (a+b+c .lt. 1.d-6) then + atom = .true. + nvib = 0 + nvib_theo = 0 end if - if (pr2) then - call print_thermo_sthr_ts(stdout,nvib,vibs,avmom,sthr,temps(j)) + + nvib = 0 + vibs = 0.0 + do i = 1,n3 + if (abs(freq(i)) .gt. vibthr) then + nvib = nvib+1 + vibs(nvib) = freq(i) + end if + end do + !> scale + vibs(1:nvib) = vibs(1:nvib)*fscal + + !> invert imaginary modes + nimag = 0 + do i = 1,nvib + if (vibs(i) .lt. 0.and.vibs(i) .gt. ithr) then + vibs(i) = -vibs(i) + if (pr) write (stdout,'(a,i5," :",f10.2)') 'Inverting frequency',i,vibs(i) + end if + if (vibs(i) < 0.0) then + nimag = nimag+1 + end if + end do + + if (pr) then + write (stdout,'(a)') + write (stdout,'(10x,51("."))') + write (stdout,'(10x,":",22x,a,22x,":")') "SETUP" + write (stdout,'(10x,":",49("."),":")') + write (stdout,intfmt) "# frequencies ",nvib + write (stdout,intfmt) "# imaginary freq.",nimag + write (atmp,*) linear + write (stdout,chrfmt) "linear? ",trim(atmp) + write (stdout,chrfmt) "symmetry ",adjustr(symchar) + write (stdout,intfmt) "rotational number",nint(sym) + write (stdout,dblfmt) "scaling factor ",fscal," " + write (stdout,dblfmt) "rotor cutoff ",sthr,"cm⁻¹" + write (stdout,dblfmt) "imag. cutoff ",ithr,"cm⁻¹" + write (stdout,'(10x,":",49("."),":")') end if - call thermodyn(stdout,a,b,c,avmom,linear,atom,sym,molmass,vibs,nvib, & - & temps(j),sthr,et(j),ht(j),gt(j),ts(j),zp,pr2) - stot(j) = (ts(j)/temps(j))*autocal - end do - - if ((nt > 1).and.pr) then - write (stdout,'(a)') - write (stdout,'(a10)',advance='no') "T/K" - write (stdout,'(a16)',advance='no') "H(0)-H(T)+PV" - write (stdout,'(a16)',advance='no') "H(T)/Eh" - write (stdout,'(a16)',advance='no') "T*S/Eh" - write (stdout,'(a16)',advance='no') "G(T)/Eh" - write (stdout,'(a)') - write (stdout,'(3x,72("-"))') - do i = 1,nt - write (stdout,'(3f10.2)',advance='no') temps(i) - write (stdout,'(3e16.6)',advance='no') ht(i) - write (stdout,'(3e16.6)',advance='no') et(i) - write (stdout,'(3e16.6)',advance='no') ts(i) - write (stdout,'(3e16.6)',advance='no') gt(i) - if (i == rt) then - write (stdout,'(1x,"(used)")') + + vibs = vibs*rcmtoau ! thermodyn needs vibs and zp in Eh + + zp = 0.5_wp*sum(vibs(1:nvib)) + adum = abs(temps-298.15d0) + rt = minloc(adum,1) !temperature closest to 298.15 is the ref. + do j = 1,nt + if ((j == rt).and.pr) then + pr2 = .true. else - write (stdout,'(a)') + pr2 = .false. + end if + if (pr2) then + call print_thermo_sthr_ts(stdout,nvib,vibs,avmom,sthr,temps(j)) end if + call thermodyn(stdout,a,b,c,avmom,linear,atom,sym,molmass,vibs,nvib, & + & temps(j),sthr,et(j),ht(j),gt(j),ts(j),zp,pr2) + stot(j) = (ts(j)/temps(j))*autocal end do - write (stdout,'(3x,72("-"))') - end if - xyz =xyz*aatoau + if ((nt > 1).and.pr) then + write (stdout,'(a)') + write (stdout,'(a10)',advance='no') "T/K" + write (stdout,'(a16)',advance='no') "H(0)-H(T)+PV" + write (stdout,'(a16)',advance='no') "H(T)/Eh" + write (stdout,'(a16)',advance='no') "T*S/Eh" + write (stdout,'(a16)',advance='no') "G(T)/Eh" + write (stdout,'(a)') + write (stdout,'(3x,72("-"))') + do i = 1,nt + write (stdout,'(3f10.2)',advance='no') temps(i) + write (stdout,'(3e16.6)',advance='no') ht(i) + write (stdout,'(3e16.6)',advance='no') et(i) + write (stdout,'(3e16.6)',advance='no') ts(i) + write (stdout,'(3e16.6)',advance='no') gt(i) + if (i == rt) then + write (stdout,'(1x,"(used)")') + else + write (stdout,'(a)') + end if + end do + write (stdout,'(3x,72("-"))') + end if + + xyz = xyz*aatoau - deallocate (vibs) - return -end subroutine calcthermo + deallocate (vibs) + return + end subroutine calcthermo -subroutine calc_thermo_from_hess(mol, hess, pr, nt) -type(coord), intent(inout) :: mol -integer :: nat3 -integer :: io -logical :: pr -real(wp) :: ithr, fscal, sthr, temps(nt) -integer, intent(in) :: nt -real(wp) :: et(nt),ht(nt),gt(nt),stot(nt) -real(wp), intent(inout) :: hess(:,:) -real(wp), allocatable :: freq(:) + subroutine calc_thermo_from_hess(mol,hess,pr,nt,temps,ithr,& + & fscal,sthr,et,ht,gt,stot) + type(coord),intent(inout) :: mol + integer :: nat3 + integer :: io + logical :: pr + real(wp) :: ithr,fscal,sthr + real(wp),intent(in) :: temps(nt) + integer,intent(in) :: nt + real(wp),allocatable,intent(out) :: et(:),ht(:),gt(:),stot(:) + real(wp),intent(inout) :: hess(:,:) + real(wp),allocatable :: freq(:) -call prj_mw_hess(mol%nat,mol%at,nat3,mol%xyz,hess) + nat3 = 3*mol%nat + allocate (freq(nat3)) + allocate (et(nt)) + allocate (ht(nt)) + allocate (gt(nt)) + allocate (stot(nt)) -call frequencies(mol%nat,mol%at,mol%xyz,nat3,hess,freq,io) + call prj_mw_hess(mol%nat,mol%at,nat3,mol%xyz,hess) -call calcthermo(mol%nat,mol%at,mol%xyz,freq,pr,ithr,fscal,sthr,nt,temps, & - & et,ht,gt,stot) + call frequencies(mol%nat,mol%at,mol%xyz,nat3,hess,freq,io) -end subroutine calc_thermo_from_hess + call calcthermo(mol%nat,mol%at,mol%xyz,freq,pr,ithr,fscal,sthr,nt,temps, & + & et,ht,gt,stot) + end subroutine calc_thermo_from_hess -end module thermochem_module \ No newline at end of file +end module thermochem_module diff --git a/src/legacy_wrappers.f90 b/src/legacy_wrappers.f90 index e32cd2cd..bc7bf69d 100644 --- a/src/legacy_wrappers.f90 +++ b/src/legacy_wrappers.f90 @@ -97,6 +97,19 @@ subroutine env2calc(env,calc,molin) call env%addrefine(refine%singlepoint) end if + if (.not.allocated(env%calc%temperatures)) then + if (.not.allocated(env%thermo%temps)) then + call env%thermo%get_temps() + end if + env%calc%nt = env%thermo%ntemps + allocate (env%calc%temperatures(env%calc%nt),source=0.0_wp) + + env%calc%temperatures = env%thermo%temps + env%calc%ithr = env%thermo%ithr + env%calc%sthr = env%thermo%sthr + env%calc%fscal = env%thermo%fscal + end if + return end subroutine env2calc diff --git a/src/optimize/ancopt.f90 b/src/optimize/ancopt.f90 index 287f46b5..96f5af92 100644 --- a/src/optimize/ancopt.f90 +++ b/src/optimize/ancopt.f90 @@ -23,7 +23,7 @@ !> This module implements the ANCOPT algorithm module ancopt_module - use iso_fortran_env, only: wp=>real64, sp=>real32 + use iso_fortran_env,only:wp => real64,sp => real32 !use crest_parameters use crest_calculator use axis_module @@ -35,6 +35,7 @@ module ancopt_module use modelhessian_module use hessupdate_module use optimize_utils + use hessian_reconstruct implicit none private @@ -88,7 +89,7 @@ subroutine ancopt(mol,calc,etot,grd,pr,wr,iostatus) real(wp) :: step,amu2au,au2cm,dumi,dumj,damp,hlow,edum,s6,thr real(wp) :: maxdispl,gthr,ethr,hmax,energy,rij(3),t1,t0,w1,w0 real(wp) :: rot(3),gnorm - integer :: n3,i,j,k,l,jjj,ic,jc,ia,ja,ii,jj,info,nat3 + integer :: n3,i,j,k,l,jjj,ic,jc,ia,ja,ii,jj,info,nat3,info2 integer :: nvar,iter,nread,maxcycle,maxmicro,itry,maxopt,iupdat,iii integer :: id,ihess,error integer :: ilog @@ -119,7 +120,7 @@ subroutine ancopt(mol,calc,etot,grd,pr,wr,iostatus) iupdat = calc%iupdat hlow = calc%hlow_opt !> 0.01 in ancopt, 0.002 too small hmax = calc%hmax_opt - maxdispl = calc%maxdispl_opt + maxdispl = calc%maxdispl_opt s6 = mhset%s6 !> slightly better than 30 for various proteins !> initial number of steps in relax() routine before @@ -154,7 +155,6 @@ subroutine ancopt(mol,calc,etot,grd,pr,wr,iostatus) & ethr,gthr,linear,wr) end if - !>--- initialize OPT object !$omp critical allocate (h(nat3,nat3),hess(nat3*(nat3+1)/2),eig(nat3)) @@ -221,7 +221,7 @@ subroutine ancopt(mol,calc,etot,grd,pr,wr,iostatus) esave = etot !> save energy before relaxation !>--- call the actual relaxation routine !> this routine will perform [maxmicro] relaxation steps - if(iter+maxmicro >= maxcycle) maxmicro = maxcycle - iter + if (iter+maxmicro >= maxcycle) maxmicro = maxcycle-iter !> [maxmicro] need to be adapted to not overshoot maxcycle call relax(molopt,calc,OPT,iter,maxmicro,etot,grd, & & ethr,gthr,converged, & @@ -354,6 +354,8 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & !> LAPACK & BLAS external :: dgemv real(sp),external :: sdot + integer :: q,r,s,nat3 !> ONLY for testing! + nat3 = 3*mol%nat iostatus = 0 @@ -375,7 +377,7 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & nvar1 = OPT%nvar+1 !> dimension of RF calculation npvar = OPT%nvar*(nvar1)/2 !> packed size of Hessian (note the abuse of nvar1!) npvar1 = nvar1*(nvar1+1)/2 !> packed size of augmented Hessian - allocate (Uaug(nvar1,1),eaug(nvar1),Aaug(npvar1), source=0.0_sp) + allocate (Uaug(nvar1,1),eaug(nvar1),Aaug(npvar1),source=0.0_sp) !$omp end critical !! ======================================================================== @@ -457,13 +459,13 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & end if end if - alp = 1.0d0 + alp = 1.0d0 if (gnorm .lt. 0.002) then ! 0.002 alp = 1.5d0 ! 1.5 - endif + end if if (gnorm .lt. 0.0006) then alp = 2.0d0 ! 2 - endif + end if if (gnorm .lt. 0.0003) then alp = 3.0d0 ! 3 end if @@ -490,6 +492,28 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & end select end if + if (calc%do_HU) then + q = 1 + do r = 1,nat3 + do s = 1,r + calc%chess%Hinv(s,r) = OPT%hess(q) + calc%chess%Hinv(r,s) = OPT%hess(q) + q = q+1 + end do + end do + end if + + !calc%chess%H(:,:) = invert_matrix(calc%chess%Hinv) + + !print*, "HESSIAN FROM RFO:" + !print* + !print*, OPT%hess(:) + + !print* + !print*,"Symmetrized RFO Hessian Matrix" + !print* + !print*,calc%chess%Hinv(:,:) + !>------------------------------------------------------------------------ !> rational function (RF) method !>------------------------------------------------------------------------ diff --git a/src/optimize/optimize_maths.f90 b/src/optimize/optimize_maths.f90 index b46a223c..2a7a0741 100644 --- a/src/optimize/optimize_maths.f90 +++ b/src/optimize/optimize_maths.f90 @@ -35,6 +35,8 @@ module optimize_maths public :: solver_sdavidson public :: solver_sspevx public :: solver_ssyevx + public :: dsqtoh + public :: dhtosq !========================================================================================! !========================================================================================! @@ -881,6 +883,26 @@ subroutine solver_sspevx(n,thr,A,U,e,fail) deallocate (iwork,work,ifail) end subroutine solver_sspevx + subroutine dsqtoh(n,a,b) +!**************************************************** +!* converts upper triangle of a matrix into a vector +!**************************************************** + implicit none + integer,intent(in) :: n + real(wp),intent(in) :: a(n,n) + real(wp),intent(out) :: b(n*(n+1)/2) + integer :: i,j,k + + k = 0 + do i = 1,n + do j = 1,i + k = k+1 + b(k) = a(i,j) + end do + end do + + end subroutine dsqtoh + !========================================================================================! !========================================================================================! end module optimize_maths diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index bc93540f..e0bbb6f8 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -20,7 +20,7 @@ ! under the Open-source software LGPL-3.0 Licencse. !================================================================================! -!> This module wrapps the different optimization algorithms, +!> This module wrapps the different optimization algorithms, !> i.e., this is what can be called for geometry opt. module optimize_module @@ -32,6 +32,8 @@ module optimize_module use gradientdescent_module use rfo_module use optimize_utils + use thermochem_module + use hessian_reconstruct implicit none private @@ -56,6 +58,7 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) integer,intent(out) :: iostatus real(wp),intent(inout) :: etot real(wp),intent(inout) :: grd(3,mol%nat) + real(wp),allocatable :: H_inv(:,:) iostatus = -1 !> do NOT overwrite original geometry @@ -66,52 +69,75 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) !$omp end critical !> Check for optimization-individual calculation setup - if(calc%optnewinit)then + if (calc%optnewinit) then !$omp critical call calc%dealloc_params() !$omp end critical - endif + end if !> Check if Hessian Reconstruct is called if (calc%do_HU) then - allocate(calc%chess) - call calc%chess%alloc(mol%nat,calc%hu_steps) - endif + allocate (calc%chess) + call calc%chess%alloc(mol%nat,calc%hu_steps,calc%hguess) + end if !> initial singlepoint call engrad(molnew,calc,etot,grd,iostatus) !> optimization select case (calc%opt_engine) - case ( 0) - call ancopt(molnew,calc,etot,grd,pr,wr,iostatus) - case ( 1) - !> l-bfgs goes here - write(stdout,'(a)') 'L-BFGS currently not implemented' + case (0) + call ancopt(molnew,calc,etot,grd,pr,wr,iostatus) + case (1) + !> l-bfgs goes here + write (stdout,'(a)') 'L-BFGS currently not implemented' stop - case ( 2) - !> rfo goes here - call rfopt(molnew,calc,etot,grd,pr,wr,iostatus) + case (2) + !> rfo goes here + call rfopt(molnew,calc,etot,grd,pr,wr,iostatus) case (-1) call gradientdescent(molnew,calc,etot,grd,pr,wr,iostatus) case default - write(stdout,'(a)') 'Unknown optimization engine!' + write (stdout,'(a)') 'Unknown optimization engine!' stop end select molnew%energy = etot - if (calc%do_HU) then - print*, "Energies", calc%chess%energy - print*, "Gradients", calc%chess%gradient - print*, "Coords", calc%chess%coords - print*, "Order", calc%chess%order - endif + if (calc%do_HU) then !> Hessian construction and post-processing happen here + !print*, "Energies", calc%chess%energy + !print*, "Gradients", calc%chess%gradient + !print*, "Coords", calc%chess%coords + !print*, "Order", calc%chess%order - if (calc%do_HU) then - call calc%chess%dealloc() - deallocate(calc%chess) - endif + call calc%chess%construct_hessian_bfgs() + + !allocate(H_inv(size(calc%chess%B,1),size(calc%chess%B,2))) + !H_inv(:,:) = invert_matrix(calc%chess%B) + + print* + print*,"THERMO FROM MY OWN SHITTY HESSIAN" + print* + call calc_thermo_from_hess(molnew,calc%chess%B,pr, & + & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & + & calc%ht,calc%gt,calc%stot) + + print* + print*,"THERMO FROM BFGS" + print* + + call calc_thermo_from_hess(molnew,calc%chess%H,pr, & + & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & + & calc%ht,calc%gt,calc%stot) + + !write(stdout,*) "et:", calc%et + !write(stdout,*) "ht:", calc%ht + !write(stdout,*) "gt:", calc%gt + !write(stdout,*) "stot:", calc%stot + + call calc%chess%dealloc() + deallocate (calc%chess) + end if return end subroutine optimize_geometry @@ -127,16 +153,16 @@ subroutine print_opt_data(calc,ich) write (ich,'(1x,a)',advance='no') 'Optimization engine: ' select case (calc%opt_engine) - case ( 0) + case (0) write (ich,'(a)') 'ANCOPT' - case ( 1) + case (1) write (ich,'(a)') 'L-BFGS' - case ( 2) + case (2) write (ich,'(a)') 'RFO' case (-1) write (ich,'(a)') 'Gradient Descent' case default - write(ich,'(a)') 'Unknown' + write (ich,'(a)') 'Unknown' end select if (calc%opt_engine >= 0) then write (ich,'(1x,a)',advance='no') 'Hessian update type: ' @@ -160,7 +186,7 @@ subroutine print_opt_data(calc,ich) & ethr,' Eh,',gthr,' Eh/a0' write (ich,'(1x,a,i0)') 'maximum optimization steps: ',calc%maxcycle - + end subroutine print_opt_data !========================================================================================! diff --git a/src/optimize/rfo.f90 b/src/optimize/rfo.f90 index fc97b5c6..78a1aaa5 100644 --- a/src/optimize/rfo.f90 +++ b/src/optimize/rfo.f90 @@ -23,7 +23,7 @@ !> This module implements a standard RFO algorithm (in Cart. coords) module rfo_module - use iso_fortran_env, only: wp=>real64, sp=>real32 + use iso_fortran_env,only:wp => real64,sp => real32 use crest_calculator use axis_module use strucrd @@ -34,6 +34,7 @@ module rfo_module use modelhessian_module use hessupdate_module use optimize_utils + use hessian_reconstruct implicit none private @@ -67,7 +68,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) implicit none !> INPUT/OUTPUT type(coord),intent(inout) :: mol - type(calcdata),intent(in) :: calc + type(calcdata),intent(inout) :: calc real(wp),intent(inout) :: etot real(wp),intent(inout) :: grd(3,mol%nat) logical,intent(in) :: pr @@ -120,7 +121,8 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) external :: dgemv real(wp),external :: ddot real(sp),external :: sdot - + real(wp),allocatable :: test_hess(:) !> only for testing + integer :: q,r,s !>only for testing iostatus = 0 fail = .false. @@ -133,7 +135,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) iupdat = calc%iupdat hlow = calc%hlow_opt !> 0.01 in ancopt, 0.002 too small hmax = calc%hmax_opt - maxdispl = calc%maxdispl_opt + maxdispl = calc%maxdispl_opt gnorm = 0.0_wp depred = 0.0_wp echng = 0.0_wp @@ -181,23 +183,23 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) npvar = OPT%nvar*(nvar1)/2 !> packed size of Hessian (note the abuse of nvar1!) npvar1 = nvar1*(nvar1+1)/2 !> packed size of augmented Hessian allocate (Uaug(nvar1,1),eaug(nvar1),Aaug(npvar1)) - allocate ( gold(OPT%nvar),displ(OPT%nvar),grd1(OPT%nvar),source=0.0_wp) + allocate (gold(OPT%nvar),displ(OPT%nvar),grd1(OPT%nvar),source=0.0_wp) !$omp end critical !>------------------------------------------------------------------------ !>--- put the Hessian guess into the type !>------------------------------------------------------------------------ - k = 0 - do i = 1,nat3 - do j = 1,i - k = k+1 - if( i /= j )then - OPT%hess(k) = 0.0_wp - else - OPT%hess(k) = calc%hguess - endif - end do - end do + k = 0 + do i = 1,nat3 + do j = 1,i + k = k+1 + if (i /= j) then + OPT%hess(k) = 0.0_wp + else + OPT%hess(k) = calc%hguess + end if + end do + end do !>--- backup coordinates, and starting energy molopt%nat = mol%nat @@ -302,13 +304,13 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) alp = 1.0d-1 if (gnorm .lt. 0.002) then ! 0.002 alp = 1.5d-1 ! 1.5 - endif + end if if (gnorm .lt. 0.0006) then alp = 2.0d-1 ! 2 - endif + end if if (gnorm .lt. 0.0003) then alp = 3.0d-1 ! 3 - endif + end if !>------------------------------------------------------------------------ !> Update the Hessian @@ -332,6 +334,39 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) end select end if + !allocate(calc%chess%H(nat3,nat3)) + if (calc%do_HU) then + call dhtosq(nat3,calc%chess%H(:,:),OPT%hess(:)) + !q = 1 + !do r = 1, nat3 + ! do s = 1, r + ! calc%chess%H(s,r) = OPT%hess(q) + ! calc%chess%H(r,s) = OPT%hess(q) + ! q = q + 1 + ! end do + !end do + end if + + !calc%chess%H(:,:) = invert_matrix(calc%chess%Hinv) + + !print*, "HESSIAN FROM RFO:" + !print* + !print*, OPT%hess(:) + + !print* + !print*,"Symmetrized RFO Hessian Matrix" + !print* + !print*,calc%chess%H(:,:) + + !allocate(test_hess(nat3*nat3)) + !print*, size(test_hess) + + !test_hess = OPT%hess + !print*, size(test_hess) + !print*, nat3*nat3 + !print*, size(OPT%hess) + + !calc%chess%H(:,:) = reshape(test_hess, [nat3,nat3]) !>------------------------------------------------------------------------ !> rational function (RF) method !>------------------------------------------------------------------------ @@ -460,9 +495,9 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !> deallocate data !$omp critical - if (allocated(gold)) deallocate(gold) - if (allocated(displ)) deallocate(displ) - if (allocated(grd1)) deallocate(grd1) + if (allocated(gold)) deallocate (gold) + if (allocated(displ)) deallocate (displ) + if (allocated(grd1)) deallocate (grd1) if (allocated(Uaug)) deallocate (Uaug) if (allocated(eaug)) deallocate (eaug) if (allocated(Aaug)) deallocate (Aaug) diff --git a/src/parsing/confparse2.f90 b/src/parsing/confparse2.f90 index 9eb8a4e7..80f88417 100644 --- a/src/parsing/confparse2.f90 +++ b/src/parsing/confparse2.f90 @@ -78,7 +78,7 @@ subroutine parseinputfile(env,fname) call dict%print2() !>--- sanity check for input files - readstatus = 0 !> has to remain 0, or something went wrong + readstatus = 0 !> has to remain 0, or something went wrong !>--- parse all root-level key-value pairs do i = 1,dict%nkv @@ -113,10 +113,10 @@ subroutine parseinputfile(env,fname) end if !>--- terminate if there were any unrecognized keywords - if(readstatus /= 0)then - write(stdout, '(i0,a)') readstatus,' error(s) while reading input file' + if (readstatus /= 0) then + write (stdout,'(i0,a)') readstatus,' error(s) while reading input file' call creststop(status_config) - endif + end if !>--- check for lwONIOM setup (will be read at end of confparse) do i = 1,dict%nblk @@ -193,8 +193,7 @@ subroutine env_calcdat_specialcases(env) integer :: refine_lvl !> if this return is triggered, the program will fall back to GFN2 at some point - if(env%calc%ncalculations .lt. 1) return - + if (env%calc%ncalculations .lt. 1) return !> special case for GFN-FF calculations if (any(env%calc%calcs(:)%id == jobtype%gfnff)) then @@ -209,13 +208,26 @@ subroutine env_calcdat_specialcases(env) do i = 1,env%calc%ncalculations refine_lvl = env%calc%calcs(i)%refine_lvl if (refine_lvl <= 0) cycle - if(allocated(env%refine_queue))then + if (allocated(env%refine_queue)) then if (any(env%refine_queue(:) == refine_lvl)) cycle - endif + end if call env%addrefine(refine_lvl) end do end if + if (.not.allocated(env%calc%temperatures)) then + if (.not.allocated(env%thermo%temps)) then + call env%thermo%get_temps() + end if + env%calc%nt = env%thermo%ntemps + allocate (env%calc%temperatures(env%calc%nt),source=0.0_wp) + + env%calc%temperatures = env%thermo%temps + env%calc%ithr = env%thermo%ithr + env%calc%sthr = env%thermo%sthr + env%calc%fscal = env%thermo%fscal + end if + end subroutine env_calcdat_specialcases !========================================================================================! @@ -235,15 +247,15 @@ subroutine env_mddat_specialcases(env) integer :: nac,ii,iac !>--- Check for MD-active only levels - if(allocated(env%mddat%active_potentials))then + if (allocated(env%mddat%active_potentials)) then nac = size(env%mddat%active_potentials) - do ii=1,nac - !>--- deactivate by default (the MD routine will set them to active automatically) - iac = env%mddat%active_potentials(ii) - if(iac <= env%calc%ncalculations)then - env%calc%calcs(iac)%active = .false. - endif - enddo - endif + do ii = 1,nac + !>--- deactivate by default (the MD routine will set them to active automatically) + iac = env%mddat%active_potentials(ii) + if (iac <= env%calc%ncalculations) then + env%calc%calcs(iac)%active = .false. + end if + end do + end if end subroutine env_mddat_specialcases diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 00768671..951cd63a 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -241,11 +241,11 @@ subroutine parse_setting_auto(env,job,kv,rd) job%id = jobtype%gfnff case ('pvol','libpvol','pv') job%id = jobtype%libpvol - case ('gxtb_dev') - job%id = jobtype%turbomole - job%rdgrad = .true. - job%binary = 'gxtb' - job%other ='-grad' + case ('gxtb_dev') + job%id = jobtype%turbomole + job%rdgrad = .true. + job%binary = 'gxtb' + job%other = '-grad' case ('none') job%id = jobtype%unknown case ('lj','lennard-jones') @@ -514,6 +514,9 @@ subroutine parse_calc_auto(env,calc,kv,rd) case ('maxcycle') calc%maxcycle = kv%value_i !> optimization max cycles + case ('chess_steps') + calc%hu_steps = kv%value_i + !>--- strings case ('id','type') !> (OLD setting) calculation type @@ -579,6 +582,9 @@ subroutine parse_calc_auto(env,calc,kv,rd) case ('exact_rf') calc%exact_rf = kv%value_b + case ('chess') + calc%do_HU = kv%value_b + case default rd = .false. end select From 555c3a9c5b6f40707fda0c4b05ffb1ac25420dc9 Mon Sep 17 00:00:00 2001 From: Lukas Rindt Date: Thu, 11 Dec 2025 15:31:31 +0100 Subject: [PATCH 103/374] parameters for alp added --- CMakeLists.txt | 5 +++ src/calculator/calc_type.f90 | 5 +++ src/calculator/calculator.F90 | 4 ++ src/calculator/hessian_reconstruct.f90 | 13 +----- src/crest_pars.f90 | 1 + src/optimize/ancopt.f90 | 58 ++++++++++++-------------- src/optimize/rfo.f90 | 47 +++++---------------- src/parsing/parse_calcdata.f90 | 9 ++++ 8 files changed, 63 insertions(+), 79 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 72d773cc..90ca4989 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -31,6 +31,11 @@ project( DESCRIPTION "A tool for the exploration of low-energy chemical space" ) +# Apply debug flags when building in Debug mode +set(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG} \ + -g -O0 -fcheck=all -fbacktrace -finit-real=snan -finit-integer=-999 \ + -Wall -Wextra -Wuninitialized -Wmaybe-uninitialized") + # Follow GNU conventions for installing directories include(GNUInstallDirs) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index e77760b8..822418b2 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -276,6 +276,11 @@ module calc_type real(wp),allocatable :: et(:),ht(:),gt(:),stot(:) real(wp) :: ithr,fscal,sthr +!>--- Parameters for smooth function within optimizer + real(wp) :: L = 1.50_wp + real(wp) :: k = 5000.0_wp + real(wp) :: shift = 0.0006_wp + !>--- Type procedures contains procedure :: reset => calculation_reset diff --git a/src/calculator/calculator.F90 b/src/calculator/calculator.F90 index b80e2a96..2d5ff8c3 100644 --- a/src/calculator/calculator.F90 +++ b/src/calculator/calculator.F90 @@ -297,6 +297,10 @@ subroutine engrad_mol(mol,calc,energy,gradient,iostatus) !********************************************** call calc%freezegrad(gradient) +!********************************************** +!>--- Hessian Reconstruct +!********************************************** + if (calc%do_HU .and. allocated(calc%chess)) then call calc%chess%update(gradient,energy,mol%xyz) end if diff --git a/src/calculator/hessian_reconstruct.f90 b/src/calculator/hessian_reconstruct.f90 index 6fab7599..eaf07524 100644 --- a/src/calculator/hessian_reconstruct.f90 +++ b/src/calculator/hessian_reconstruct.f90 @@ -79,24 +79,13 @@ subroutine update_cashed_hessian(self,gradient,energy,coords) class(cashed_hessian),intent(inout) :: self real(wp),intent(in) :: gradient(:,:),energy,coords(:,:) integer :: idx,i - !print*, coords + self%stepcount = self%stepcount+1 - !print*, self%order - !print*, coords(:,:) idx = minloc(self%order,1) self%order(idx) = self%stepcount self%gradient(idx,:,:) = gradient self%energy(idx) = energy self%coords(idx,:,:) = coords - !if (idx==1) then - ! print*, self%coords(1,:,:) - ! print*, self%coords(2,:,:) - ! print*, self%coords(3,:,:) - !endif - !PRINT*, self%order - !print*, self%coords(1,:,:) - !print*, self%coords(2,:,:) - print*,size(self%coords,dim=1) end subroutine update_cashed_hessian diff --git a/src/crest_pars.f90 b/src/crest_pars.f90 index c18ebbe7..9ed05897 100644 --- a/src/crest_pars.f90 +++ b/src/crest_pars.f90 @@ -16,6 +16,7 @@ module crest_parameters real(wp),parameter,public :: pi = acos(0.0_wp)*2.0_wp real(wp),parameter,public :: radtodeg = 180.0_wp / pi + real(wp),parameter :: euler = 2.718281828459045_wp real(wp),parameter,public :: degtorad = 1.0_wp / radtodeg real(wp),parameter,public :: amutokg = 1.660539040e-27_wp diff --git a/src/optimize/ancopt.f90 b/src/optimize/ancopt.f90 index 96f5af92..040e075e 100644 --- a/src/optimize/ancopt.f90 +++ b/src/optimize/ancopt.f90 @@ -24,7 +24,7 @@ module ancopt_module use iso_fortran_env,only:wp => real64,sp => real32 - !use crest_parameters + !use crest_parameters, only use crest_calculator use axis_module use strucrd @@ -344,7 +344,7 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & integer :: i,j,ii,jj,jjj,iii,k,lwork,info,m,idum,imax(3) real(wp) :: energy,dsnrm,maxdispl,t0,w0,t1,w1 real(wp) :: lambda,gnorm,dnorm,ddot,eold,xdum,estart,acc,e_in - real(wp) :: depred,echng,dummy,maxd,alp,gchng,gnold + real(wp) :: depred,echng,dummy,maxd,alp,alpold,gchng,gnold real(wp),allocatable :: gold(:) real(wp),allocatable :: displ(:),gint(:) real(sp),allocatable :: eaug(:) @@ -370,6 +370,7 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & energy = etot e_in = etot alp = 1.0_wp + alpold = 1.0_wp converged = .false. exact = calc%exact_rf iupdat = calc%iupdat @@ -389,8 +390,10 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & gnold = gnorm eold = energy !>--- calc predicted energy change based on E = E0 + delta * G + delta^2 * H + alpold = alp + if (ii > 1) then - call prdechng(OPT%nvar,gold,displ,OPT%hess,depred) + call prdechng(OPT%nvar,gold,displ*alpold,OPT%hess,depred) end if !>------------------------------------------------------------------------ @@ -466,10 +469,11 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & if (gnorm .lt. 0.0006) then alp = 2.0d0 ! 2 end if - if (gnorm .lt. 0.0003) then + if (gnorm .lt. 0.0003 .and. calc%optlev .le. 1) then alp = 3.0d0 ! 3 end if + alp = alp_generate(gnorm, calc) !>------------------------------------------------------------------------ !> Update the Hessian !>------------------------------------------------------------------------ @@ -477,43 +481,21 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & !>--- Hessian update, but only after first iteration (ii > 1) select case (iupdat) case (0) - call bfgs(OPT%nvar,gnorm,gint,gold,displ,OPT%hess) + call bfgs(OPT%nvar,gnorm,gint,gold,displ*alpold,OPT%hess) case (1) - call powell(OPT%nvar,gnorm,gint,gold,displ,OPT%hess) + call powell(OPT%nvar,gnorm,gint,gold,displ*alpold,OPT%hess) case (2) - call sr1(OPT%nvar,gnorm,gint,gold,displ,OPT%hess) + call sr1(OPT%nvar,gnorm,gint,gold,displ*alpold,OPT%hess) case (3) - call bofill(OPT%nvar,gnorm,gint,gold,displ,OPT%hess) + call bofill(OPT%nvar,gnorm,gint,gold,displ*alpold,OPT%hess) case (4) - call schlegel(OPT%nvar,gnorm,gint,gold,displ,OPT%hess) + call schlegel(OPT%nvar,gnorm,gint,gold,displ*alpold,OPT%hess) case default write (*,*) 'invalid hessian update selection' stop end select end if - if (calc%do_HU) then - q = 1 - do r = 1,nat3 - do s = 1,r - calc%chess%Hinv(s,r) = OPT%hess(q) - calc%chess%Hinv(r,s) = OPT%hess(q) - q = q+1 - end do - end do - end if - - !calc%chess%H(:,:) = invert_matrix(calc%chess%Hinv) - - !print*, "HESSIAN FROM RFO:" - !print* - !print*, OPT%hess(:) - - !print* - !print*,"Symmetrized RFO Hessian Matrix" - !print* - !print*,calc%chess%Hinv(:,:) - !>------------------------------------------------------------------------ !> rational function (RF) method !>------------------------------------------------------------------------ @@ -651,6 +633,20 @@ subroutine trfp2xyz(nvar,nat3,p,xyz0,h,dspl) return end subroutine trfp2xyz + function alp_generate(gnorm,calc) result(alp) + type(calcdata),intent(in) :: calc + real(wp), intent(in) :: gnorm + real(wp) :: alp, shift, l, k + + L = calc%L + k = calc%k + shift = calc%shift + + alp = L/(1+euler**(k*(gnorm-shift)))+1 + + end function alp_generate + + !========================================================================================! !========================================================================================! end module ancopt_module diff --git a/src/optimize/rfo.f90 b/src/optimize/rfo.f90 index 78a1aaa5..748cbd5d 100644 --- a/src/optimize/rfo.f90 +++ b/src/optimize/rfo.f90 @@ -92,7 +92,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) integer :: nvar,iter,nread,maxcycle,maxmicro,itry,maxopt,iupdat,iii integer :: id,ihess,error integer :: ilog,imax(3) - real(wp) :: depred,echng,alp,gnold,eold,gchng,dummy,dsnrm,maxd + real(wp) :: depred,echng,alp,alpold,gnold,eold,gchng,dummy,dsnrm,maxd real(wp),allocatable :: h(:,:) real(wp),allocatable :: b(:,:) real(wp),allocatable :: fc(:) @@ -140,6 +140,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) depred = 0.0_wp echng = 0.0_wp alp = 1.0_wp + alpold = 1.0_wp exact = calc%exact_rf !> initial number of steps in relax() routine before @@ -206,6 +207,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) molopt%at = mol%at molopt%xyz = mol%xyz estart = etot + !energy = etot !>--- initialize .log file, if desired ilog = 942 @@ -301,6 +303,8 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !>--- dynamic scaling in dependence of grad norm !>--- if we are close to convergence we can take larger steps + alpold = alp + alp = 1.0d-1 if (gnorm .lt. 0.002) then ! 0.002 alp = 1.5d-1 ! 1.5 @@ -319,15 +323,15 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !>--- Hessian update, but only after first iteration (iter > 1) select case (iupdat) case (0) - call bfgs(OPT%nvar,gnorm,grd1,gold,displ,OPT%hess) + call bfgs(OPT%nvar,gnorm,grd1,gold,displ*alpold,OPT%hess) case (1) - call powell(OPT%nvar,gnorm,grd1,gold,displ,OPT%hess) + call powell(OPT%nvar,gnorm,grd1,gold,displ*alpold,OPT%hess) case (2) - call sr1(OPT%nvar,gnorm,grd1,gold,displ,OPT%hess) + call sr1(OPT%nvar,gnorm,grd1,gold,displ*alpold,OPT%hess) case (3) - call bofill(OPT%nvar,gnorm,grd1,gold,displ,OPT%hess) + call bofill(OPT%nvar,gnorm,grd1,gold,displ*alpold,OPT%hess) case (4) - call schlegel(OPT%nvar,gnorm,grd1,gold,displ,OPT%hess) + call schlegel(OPT%nvar,gnorm,grd1,gold,displ*alpold,OPT%hess) case default write (*,*) 'invalid hessian update selection' stop @@ -337,36 +341,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !allocate(calc%chess%H(nat3,nat3)) if (calc%do_HU) then call dhtosq(nat3,calc%chess%H(:,:),OPT%hess(:)) - !q = 1 - !do r = 1, nat3 - ! do s = 1, r - ! calc%chess%H(s,r) = OPT%hess(q) - ! calc%chess%H(r,s) = OPT%hess(q) - ! q = q + 1 - ! end do - !end do end if - - !calc%chess%H(:,:) = invert_matrix(calc%chess%Hinv) - - !print*, "HESSIAN FROM RFO:" - !print* - !print*, OPT%hess(:) - - !print* - !print*,"Symmetrized RFO Hessian Matrix" - !print* - !print*,calc%chess%H(:,:) - - !allocate(test_hess(nat3*nat3)) - !print*, size(test_hess) - - !test_hess = OPT%hess - !print*, size(test_hess) - !print*, nat3*nat3 - !print*, size(OPT%hess) - - !calc%chess%H(:,:) = reshape(test_hess, [nat3,nat3]) !>------------------------------------------------------------------------ !> rational function (RF) method !>------------------------------------------------------------------------ @@ -407,7 +382,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) end if displ(1:OPT%nvar) = Uaug(1:OPT%nvar,1)/Uaug(nvar1,1) -!>--- rescale displacementaif necessary +!>--- rescale displacement if necessary maxd = alp*sqrt(ddot(OPT%nvar,displ,1,displ,1)) if (maxd > maxdispl) then if (pr) write (*,'(" * rescaling step by",f14.7)') maxdispl/maxd diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 951cd63a..9ca9943f 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -509,6 +509,15 @@ subroutine parse_calc_auto(env,calc,kv,rd) case ('hguess') calc%hguess = kv%value_f !> guess for the initial hessian + + case ('opt_lval') + calc%L = kv%value_f !> Parameters for smooth function for stepsize control within optimizer + + case('opt_k') + calc%k = kv%value_f + + case('opt_shift') + calc%shift = kv%value_f !>--- integers case ('maxcycle') From c879313a5af18a496d40fe664d8d58b50b7a61e3 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 14 Dec 2025 00:24:49 +0100 Subject: [PATCH 104/374] finally repaired version of qcg-cff. Need to check failure in enermble reading still --- src/algos/parallel.f90 | 3 +- src/calculator/calc_type.f90 | 214 +++++++++++++++++++++------------ src/parsing/parse_xtbinput.f90 | 2 +- src/qcg/qcg_main.f90 | 75 ++++++------ src/qcg/qcg_misc.f90 | 196 ++++++++++++++++++------------ 5 files changed, 301 insertions(+), 189 deletions(-) diff --git a/src/algos/parallel.f90 b/src/algos/parallel.f90 index 8590fe70..68b89ff9 100644 --- a/src/algos/parallel.f90 +++ b/src/algos/parallel.f90 @@ -245,6 +245,7 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) !* dump - decides on whether to dump an ensemble file !* WARNING: the ensemble file will NOT be in the same order !* as the input xyz array. However, the overwritten xyz will be! +!* !* customcalc - customized (optional) calculation level data !* !* IMPORTANT: xyz should be in Bohr(!) for this routine @@ -388,7 +389,7 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) c = c+1 if (dump) then gnorm = norm2(grads(:,:,job)) - write (atmp,'(1x,"Etot=",f16.10,1x,"g norm=",f12.8)') energy,gnorm + write (atmp,'(1x,"energy=",f16.10,1x,"g norm=",f12.8)') energy,gnorm molsnew(job)%comment = trim(atmp) call molsnew(job)%append(ich) call calc_eprint(calculations(job),energy,calculations(job)%etmp,gnorm,ich2) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 56e91ebf..839ee25e 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -126,10 +126,10 @@ module calc_type real(wp),allocatable :: dipgrad(:,:) !> other properties - logical,allocatable :: getsasa(:) + logical,allocatable :: getsasa(:) logical :: getlmocent = .false. integer :: nprot = 0 - real(wp),allocatable :: protxyz(:,:) + real(wp),allocatable :: protxyz(:,:) real(wp),allocatable :: efield(:) !> in V/Å !>--- API constructs @@ -284,6 +284,8 @@ module calc_type procedure :: ONIOMexpand => calculation_ONIOMexpand procedure :: active => calc_set_active procedure :: active_restore => calc_set_active_restore + generic,public :: set_freeze => calculation_set_freeze_range,calculation_set_freeze_bools + procedure,private :: calculation_set_freeze_range,calculation_set_freeze_bools procedure :: freezegrad => calculation_freezegrad procedure :: increase_charge => calculation_increase_charge procedure :: decrease_charge => calculation_decrease_charge @@ -356,10 +358,10 @@ subroutine calculation_deallocate_params(self) integer :: i,j,k if (self%ncalculations > 0) then do i = 1,self%ncalculations - if(allocated(self%calcs(i)%tblite)) deallocate(self%calcs(i)%tblite) - if(allocated(self%calcs(i)%g0calc)) deallocate(self%calcs(i)%g0calc) - if(allocated(self%calcs(i)%ff_dat)) deallocate(self%calcs(i)%ff_dat) - if(allocated(self%calcs(i)%libpvol)) deallocate(self%calcs(i)%libpvol) + if (allocated(self%calcs(i)%tblite)) deallocate (self%calcs(i)%tblite) + if (allocated(self%calcs(i)%g0calc)) deallocate (self%calcs(i)%g0calc) + if (allocated(self%calcs(i)%ff_dat)) deallocate (self%calcs(i)%ff_dat) + if (allocated(self%calcs(i)%libpvol)) deallocate (self%calcs(i)%libpvol) end do end if end subroutine calculation_deallocate_params @@ -576,6 +578,33 @@ subroutine calculation_copy(self,src) end subroutine calculation_copy !=========================================================================================! + subroutine calculation_set_freeze_range(self,nat,start,finish) + class(calcdata) :: self + integer,intent(in) :: nat,start,finish + integer :: i,k + if (allocated(self%freezelist)) deallocate (self%freezelist) + allocate (self%freezelist(nat),source=.false.) + k = 0 + do i = 1,nat + + if (i >= start.and.i <= finish) then + k = k+1 + self%freezelist(i) = .true. + end if + end do + self%nfreeze = k + end subroutine calculation_set_freeze_range + + subroutine calculation_set_freeze_bools(self,freezetmp) + class(calcdata) :: self + logical,intent(in) :: freezetmp(:) + integer :: nat + if (allocated(self%freezelist)) deallocate (self%freezelist) + nat = size(freezetmp,1) + allocate (self%freezelist(nat),source=.false.) + self%nfreeze = count(freezetmp) + self%freezelist(:) = freezetmp(:) + end subroutine calculation_set_freeze_bools subroutine calculation_freezegrad(self,grad) class(calcdata) :: self @@ -598,21 +627,21 @@ subroutine calculation_increase_charge(self,dchrg) !****************************************************************** !* increase the charge of all calculation_settings objects by one !* or the specified dchrg -!****************************************************************** +!****************************************************************** implicit none class(calcdata) :: self integer,intent(in),optional :: dchrg integer :: i,j - if(self%ncalculations > 0)then - if(present(dchrg))then - j = dchrg - else - j = 1 - endif - do i=1,self%ncalculations - self%calcs(i)%chrg = self%calcs(i)%chrg + j - enddo - endif + if (self%ncalculations > 0) then + if (present(dchrg)) then + j = dchrg + else + j = 1 + end if + do i = 1,self%ncalculations + self%calcs(i)%chrg = self%calcs(i)%chrg+j + end do + end if return end subroutine calculation_increase_charge @@ -622,21 +651,21 @@ subroutine calculation_decrease_charge(self,dchrg) !****************************************************************** !* decrease the charge of all calculation_settings objects by one !* or the specified dchrg -!****************************************************************** +!****************************************************************** implicit none class(calcdata) :: self integer,intent(in),optional :: dchrg integer :: i,j - if(self%ncalculations > 0)then - if(present(dchrg))then - j = dchrg - else - j = 1 - endif - do i=1,self%ncalculations - self%calcs(i)%chrg = self%calcs(i)%chrg - j - enddo - endif + if (self%ncalculations > 0) then + if (present(dchrg)) then + j = dchrg + else + j = 1 + end if + do i = 1,self%ncalculations + self%calcs(i)%chrg = self%calcs(i)%chrg-j + end do + end if return end subroutine calculation_decrease_charge @@ -662,9 +691,9 @@ subroutine calc_set_active(self,ids) self%calcs(i)%active = .false. else !>--- and all other to active - if(self%calcs(i)%weight == 0.0_wp)then - self%calcs(i)%weight = 1.0_wp - endif + if (self%calcs(i)%weight == 0.0_wp) then + self%calcs(i)%weight = 1.0_wp + end if self%calcs(i)%active = .true. end if end do @@ -891,8 +920,6 @@ subroutine calculation_info(self,iunit) return end subroutine calculation_info - - !=========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< CALCULATION_SETTINGS associated routines @@ -1003,29 +1030,29 @@ subroutine calculation_settings_autocomplete(self,id) self%calcspace = 'calculation.level.'//trim(nmbr) end if - if (self%pr .and. self%prch.ne.stdout) then + if (self%pr.and.self%prch .ne. stdout) then self%prch = self%prch+id end if end subroutine calculation_settings_autocomplete !>--- create a short calculation info flag - subroutine calculation_settings_shortflag(self) + subroutine calculation_settings_shortflag(self) implicit none class(calculation_settings) :: self integer :: i,j - select case( self%id ) - case( jobtype%xtbsys ) + select case (self%id) + case (jobtype%xtbsys) self%shortflag = 'xtb subprocess' - case( jobtype%generic ) - self%shortflag = 'generic subprocess' - case( jobtype%turbomole ) + case (jobtype%generic) + self%shortflag = 'generic subprocess' + case (jobtype%turbomole) self%shortflag = 'TURBOMOLE subprocess' - case( jobtype%orca ) + case (jobtype%orca) self%shortflag = 'ORCA subprocess' - case( jobtype%terachem ) + case (jobtype%terachem) self%shortflag = 'TeraChem subprocess' - case( jobtype%tblite ) + case (jobtype%tblite) select case (self%tblitelvl) case (xtblvl%gfn2) self%shortflag = 'GFN2-xTB' @@ -1040,23 +1067,23 @@ subroutine calculation_settings_shortflag(self) case (xtblvl%param) self%shortflag = 'parameter file: '//trim(self%tbliteparam) end select - case( jobtype%gfn0 ) - self%shortflag = 'GFN0-xTB' - case( jobtype%gfn0occ ) - self%shortflag = 'GFN0-xTB*' - case( jobtype%gfnff ) - self%shortflag = 'GFN-FF' - case( jobtype%libpvol ) - self%shortflag = 'LIVPVOL' - case( jobtype%lj ) - self%shortflag = 'LJ' + case (jobtype%gfn0) + self%shortflag = 'GFN0-xTB' + case (jobtype%gfn0occ) + self%shortflag = 'GFN0-xTB*' + case (jobtype%gfnff) + self%shortflag = 'GFN-FF' + case (jobtype%libpvol) + self%shortflag = 'LIVPVOL' + case (jobtype%lj) + self%shortflag = 'LJ' case default self%shortflag = 'undefined' end select - if(allocated(self%solvmodel).and.allocated(self%solvent))then + if (allocated(self%solvmodel).and.allocated(self%solvent)) then self%shortflag = self%shortflag//'/'//trim(self%solvmodel) - self%shortflag = self%shortflag//'('//trim(self%solvent)//')' - endif + self%shortflag = self%shortflag//'('//trim(self%solvent)//')' + end if end subroutine calculation_settings_shortflag !>-- generate a unique print id for the calculation @@ -1098,7 +1125,7 @@ subroutine calculation_settings_info(self,iunit) character(len=20) :: atmp logical :: gxtbwarn - gxtbwarn=.false. + gxtbwarn = .false. if (allocated(self%description)) then write (iunit,'(" :",1x,a)') trim(self%description) @@ -1119,12 +1146,12 @@ subroutine calculation_settings_info(self,iunit) end if if (any((/jobtype%orca,jobtype%xtbsys,jobtype%turbomole, & & jobtype%generic,jobtype%terachem/) == self%id)) then - if(index(self%binary,'gxtb').ne.0)then - write(iunit,fmt4) 'g-xTB (development version)' + if (index(self%binary,'gxtb') .ne. 0) then + write (iunit,fmt4) 'g-xTB (development version)' gxtbwarn = .true. - else + else write (iunit,'(" :",3x,a,a)') 'selected binary : ',trim(self%binary) - endif + end if end if if (self%refine_lvl > 0) then write (atmp,*) 'refinement stage' @@ -1144,7 +1171,7 @@ subroutine calculation_settings_info(self,iunit) write (iunit,fmt3) atmp,trim(self%solvmodel) end if if (allocated(self%solvent)) then - write (atmp,*) 'Solvent' + write (atmp,*) 'Solvent' write (iunit,fmt3) atmp,trim(self%solvent) end if @@ -1176,31 +1203,45 @@ subroutine calculation_settings_info(self,iunit) end select write (iunit,fmt1) trim(atmp),self%ONIOM_id else - if(self%weight .ne. 1.0_wp)then + if (self%weight .ne. 1.0_wp) then write (atmp,*) 'Weight' write (iunit,fmt2) atmp,self%weight - endif + end if end if - if(gxtbwarn)then - write(iunit,fmt4) 'WARNING: This currently is the development version of g-xTB.' - write(iunit,fmt4) 'WARNING: Gradients are NUMERICAL (i.e., expensive and noisy!)' - endif + if (gxtbwarn) then + write (iunit,fmt4) 'WARNING: This currently is the development version of g-xTB.' + write (iunit,fmt4) 'WARNING: Gradients are NUMERICAL (i.e., expensive and noisy!)' + end if end subroutine calculation_settings_info !=========================================================================================! - subroutine create_calclevel_shortcut(self,levelstring) + subroutine create_calclevel_shortcut(self,levelstring, & + & chrg,uhf,solvmodel,solvent) !********************************************************************* !* subroutine create_calclevel_shortcut called with %create(...) !* Set up a calculation_settings object for a given level of theory !* More shortcuts can be added as required. +!* +!* Optional settings are for: +!* - molecular charge (integer) +!* - uhf parameter (integer) +!* - solvent/solventmodel (either none or BOTH must be present to work) +!* !* Be careful about the intent(out) setting! +!* Also, the routine is "dumb" and does not check if the user-provided +!* settings actually make sense for a create_calclevel_shortcutation. It very much +!* exists as an internal code shortcut only. !********************************************************************* implicit none class(calculation_settings),intent(out) :: self - character(len=*) :: levelstring + character(len=*),intent(in) :: levelstring + integer,intent(in),optional :: chrg + integer,intent(in),optional :: uhf + character(len=*),intent(in),optional :: solvmodel + character(len=*),intent(in),optional :: solvent call self%deallocate() select case (trim(levelstring)) case ('gfnff','--gff','--gfnff') @@ -1218,14 +1259,14 @@ subroutine create_calclevel_shortcut(self,levelstring) self%rdgrad = .false. self%binary = 'gp3' case ('gxtb','gxtb_dev') - self%id = jobtype%turbomole - self%rdgrad = .false. + self%id = jobtype%turbomole + self%rdgrad = .false. self%binary = 'gxtb' self%rdwbo = .false. - if(index(levelstring,'_dev').ne.0)then + if (index(levelstring,'_dev') .ne. 0) then self%other = '-grad' - self%rdgrad=.true. - endif + self%rdgrad = .true. + end if case ('orca') self%id = jobtype%orca @@ -1233,6 +1274,29 @@ subroutine create_calclevel_shortcut(self,levelstring) self%id = jobtype%generic end select + + if (present(chrg)) then + self%chrg = chrg + end if + + if (present(uhf)) then + self%uhf = uhf + end if + + !> both must be present to work + if (present(solvmodel).and.present(solvent)) then + !> the first two if-cases exist to convert cli args + !> into sensible keywords (required for legacy compatibility) + if (index(solvmodel,'gbsa') .ne. 0) then + self%solvmodel = 'gbsa' + else if (index(solvmodel,'alpb') .ne. 0) then + self%solvmodel = 'alpb' + else + self%solvmodel = trim(solvmodel) + end if + self%solvent = trim(solvent) + end if + call self%autocomplete(self%id) end subroutine create_calclevel_shortcut diff --git a/src/parsing/parse_xtbinput.f90 b/src/parsing/parse_xtbinput.f90 index 8f794196..dfac4b60 100644 --- a/src/parsing/parse_xtbinput.f90 +++ b/src/parsing/parse_xtbinput.f90 @@ -932,7 +932,7 @@ subroutine parse_constraints_from_cts(calc,mol,cts) call parse_cts_internal(cts,dict) !call dict%print() - write (stdout,'(a,a,a)') 'Parsing xtb-type constraints from internal backup to set up calculators ...' + !write (stdout,'(a,a,a)') 'Parsing xtb-type constraints from internal backup to set up calculators ...' !> iterate through the blocks and save the necessary information do i = 1,dict%nblk blk => dict%blk_list(i) diff --git a/src/qcg/qcg_main.f90 b/src/qcg/qcg_main.f90 index 4098331a..ab5a34a3 100644 --- a/src/qcg/qcg_main.f90 +++ b/src/qcg/qcg_main.f90 @@ -129,8 +129,7 @@ subroutine crest_solvtool(env,tim) progress = progress+1 end if - STOP !TODO TODO TODO TODO - + stop 'Failsafe' !------------------------------------------------------------------------------ ! Frequency computation and evaluation !------------------------------------------------------------------------------ @@ -654,7 +653,7 @@ subroutine qcg_grow(env,solu,solv,clus,tim) e_each_cycle(iter) = clus%energy !--- Calclulate fix energy + diff. energy - efix = clus%energy/sqrt(float(clus%nat)) + efix = clus%energy/sqrt(real(clus%nat)) dum = solu%energy if (iter .gt. 1) dum = e_each_cycle(iter-1) e_diff = e_diff+autokcal*(e_each_cycle(iter)-solv%energy-dum) @@ -881,11 +880,12 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) & 'solute_cut.coord','solvent_shell.coord') call remove('crest_input') call copy('solvent_shell.coord','crest_input') - deallocate (clus%at) - deallocate (clus%xyz) - call rdnat('solvent_shell.coord',clus%nat) - allocate (clus%at(clus%nat),clus%xyz(3,clus%nat)) - call rdcoord('solvent_shell.coord',clus%nat,clus%at,clus%xyz) + !deallocate (clus%at) + !deallocate (clus%xyz) + !call rdnat('solvent_shell.coord',clus%nat) + !allocate (clus%at(clus%nat),clus%xyz(3,clus%nat)) + !call rdcoord('solvent_shell.coord',clus%nat,clus%at,clus%xyz) + call clus%open('solvent_shell.coord') end if !For newcregen: If env%crestver .eq. crest_solv .and. .not. env%QCG then conffile .eq. .true. @@ -1308,16 +1308,20 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) ! (works with legacy and calculator version since xtb_sp_qcg switches automatically) call ens%write('ensemble.xyz') do i = 1,env%nqcgclust - call rdxmolselec('ensemble.xyz',i,clus%nat,clus%at,clus%xyz) + call ens%get_mol(i,clus) clus%nmol = clus%nat/solv%nat + write (to,'("TMPCFF",i0)') i io = makedir(trim(to)) call copysub('solvent',to) call chdirdbug(to) + call clus%write('cluster.coord') call wr_cluster_cut('cluster.coord',solu%nat,solv%nat,env%nsolv,'solute_cut.coord','solvent_shell.coord') call xtb_sp_qcg(env,'solvent_shell.coord',ex,e_empty(i)) - call grepval('xtb.out','| TOTAL ENERGY',ex,e_empty(i)) + if (env%legacy) then + call grepval('xtb.out','| TOTAL ENERGY',ex,e_empty(i)) + end if call copy('solvent_shell.coord','solvent_cluster.coord') call copy('solvent_cluster.coord','filled_cluster.coord') call get_ellipsoid(env,solu,solv,clus,.false.) !solu, to have same cavity to fill solvent in @@ -1387,8 +1391,9 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) call fill_take(env,solv%nat,clus%nat,inner_ell_abc(i,1:3),ipos) if (ipos .eq. 0) then converged(i) = .true. - write (stdout,'(2x,''no more solvents can be placed inside cavity of cluster: '',i0)') i - write (stdout,'(2x,''previous cluster taken...'')') + write(stdout,'(2x,a,i0,a)') & + & "no more solvents can be placed inside cavity of cluster: ",i, & + & ", taking previous." if (iter .eq. 1) nothing_added(i) = .true. end if call chdirdbug(tmppath2) @@ -1412,26 +1417,26 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) conv(k+1:env%nqcgclust) = 0 !--- Parallel optimization------------------------------------------------------------------- - if (env%legacy) then - ! from my understanding this doesn't actually return any useful at this point??? - call cff_opt(.false.,env,'solvent_cluster.coord',n_ini,conv(env%nqcgclust+1)& - &,'TMPCFF',conv,nothing_added) - end if + ! for some reason pre-processing with constraint is coupled to the pr flag + ! also, I don't think this call does anything useful... + ! I implemented e_cur readout, this makes sense to me at least + call cff_opt(.false.,env,'solvent_cluster.coord',n_ini,conv(env%nqcgclust+1)& + &,'TMPCFF',conv,nothing_added,e_cur(iter,:)) !---------------------------------------------------------------------------------------------- - + de_tot(:) = 0.0_wp do i = 1,env%nqcgclust if (.not.converged(i)) then write (to,'("TMPCFF",i0)') i call chdirdbug(to) dum_e = e_empty(i) - if (iter-nsolv .gt. 1) dum_e = e_cur(iter-1,i) + if (iter .gt. 1) dum_e = e_cur(iter-1,i) de = autokcal*(e_cur(iter,i)-solv%energy-dum_e) de_tot(i) = de_tot(i)+de !---- Check if solvent added is repulsive if (de .gt. 0) then converged(i) = .true. - write (stdout,'(2x,''adding solvent is repulsive for cluster: '',i0)') i - write (stdout,'(2x,''previous cluster taken...'')') + write (stdout,'(2x,"adding solvent is repulsive for cluster: ",i0,a)') i, & + & ", taking previous one instead." if (iter .eq. 1) nothing_added(i) = .true. else !Only if the addition was not repulsive call copy('solvent_cluster.coord','filled_cluster.coord') @@ -1480,12 +1485,12 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) if (.not.skip) then call cff_opt(.true.,env,'filled_cluster.coord',n_ini,conv(env%nqcgclust+1),& - & 'TMPCFF',conv,nothing_added) + & 'TMPCFF',conv,nothing_added,e_cluster) else n_ini = 0 !If this is 0, no constraining will be done (optimization of total system) nothing_added = .true. call cff_opt(.true.,env,'filled_cluster.coord',n_ini,env%nqcgclust,'TMPCFF',& - & conv,nothing_added) + & conv,nothing_added,e_cluster) end if env%optlev = tmp_optlev @@ -1505,15 +1510,14 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) call copy('xtbopt.coord','final_cluster.coord') !--- Reading structure - call clus%deallocate() - call rdnat('final_cluster.coord',clus%nat) - allocate (clus%at(clus%nat),clus%xyz(3,clus%nat)) - call rdcoord('final_cluster.coord',clus%nat,clus%at,clus%xyz) + call clus%open('final_cluster.coord') !--- Getting energy and calculating properties - call grepval('xtb_sp.out','| TOTAL ENERGY',e_there,e_cluster(i)) - call grepval('xtb_sp.out',' :: add. restraining',e_there,e_fix(i)) - e_fix(i) = e_fix(i)*autokcal/sqrt(float(clus%nat)) + if (env%legacy) then + call grepval('xtb_sp.out','| TOTAL ENERGY',e_there,e_cluster(i)) + call grepval('xtb_sp.out',' :: add. restraining',e_there,e_fix(i)) + end if + e_fix(i) = e_fix(i)*autokcal/sqrt(real(clus%nat)) call get_sphere(.false.,clus,.false.) if (clus%nat .gt. n_ini) then solv_added = (clus%nat-(n_ini))/solv%nat @@ -1554,10 +1558,8 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) minpos = minloc(solv_ens%er,dim=1) write (to,'("TMPCFF",i0)') minpos call chdirdbug(to) - call clus%deallocate - call rdnat('final_cluster.coord',clus%nat) - allocate (clus%at(clus%nat),clus%xyz(3,clus%nat)) - call rdcoord('final_cluster.coord',clus%nat,clus%at,clus%xyz) + call clus%open('final_cluster.coord') + clus%xyz = clus%xyz*bohr call chdirdbug(tmppath2) write (comment,'(F20.8)') solv_ens%er(minpos) @@ -2057,9 +2059,8 @@ subroutine qcg_restart(env,progress,solu,solv,clus,solu_ens,solv_ens,clus_backup if (grow) then env%qcg_restart = .true. call chdirdbug('grow') - call rdnat('cluster.coord',clus%nat) - allocate (clus%at(clus%nat),clus%xyz(3,clus%nat)) - call rdcoord('cluster.coord',clus%nat,clus%at,clus%xyz) + call clus%open('cluster.coord') + clus%nmol = (clus%nat-solu%nat)/solv%nat+1 allocate (xyz(3,clus%nat)) xyz = clus%xyz diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index 0c63006b..1e40bec1 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -590,7 +590,7 @@ subroutine ensemble_dock(env,outer_ell_abc,nfrag1,frag1_file,frag2_file,n_shell& call command('cd '//trim(tmppath)//' && '//trim(jobcall)) !$omp critical k = k+1 - percent = float(k)/float(NTMP)*100 + percent = real(k)/real(NTMP)*100 !$omp end critical !$omp end task end do @@ -609,7 +609,7 @@ end subroutine ensemble_dock ! xTB CFF optimization performed in parallel !___________________________________________________________________________________ -subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added) +subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added,eread) use crest_parameters use iomod use crest_data @@ -623,14 +623,23 @@ subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added) integer,intent(inout) :: conv(env%nqcgclust+1) logical,intent(in) :: pr logical,intent(in) :: nothing_added(env%nqcgclust) - integer :: i,k,n12 + integer,intent(in) :: n12 + real(wp),intent(out) :: eread(env%nqcgclust) + integer :: i,k integer :: vz,T,Tn integer :: funit - character(len=20) :: pipe character(len=512) :: thispath,tmppath character(len=1024) :: jobcall character(len=2) :: flag real(wp) :: percent + logical :: ex,e_there + character(len=*),parameter :: pipe = '2>/dev/null' + + !> redirect to calculator version in new implementation + if (.not.env%legacy) then + call cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added,eread) + return + end if ! setting the threads for correct parallelization call new_ompautoset(env,'auto',NTMP,T,Tn) @@ -650,7 +659,6 @@ subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added) conv(env%nqcgclust+1) = k end do end if - pipe = '2>/dev/null' call getcwd(thispath) do i = 1,NTMP @@ -690,7 +698,7 @@ subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added) call command('cd '//trim(tmppath)//' && '//trim(jobcall)) !$omp critical k = k+1 - percent = float(k)/float(NTMP)*100 + percent = real(k)/real(NTMP)*100 if (pr) then call printprogbar(percent) end if @@ -733,7 +741,7 @@ subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added) call command('cd '//trim(tmppath)//' && '//trim(jobcall)) !$omp critical k = k+1 - percent = float(k)/float(NTMP)*100 + percent = real(k)/real(NTMP)*100 if (pr) then call printprogbar(percent) end if @@ -749,6 +757,9 @@ subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added) do i = 1,NTMP write (tmppath,'(a,i0)') trim(TMPdir),conv(i) call chdirdbug(trim(tmppath)) + + call grepval('xtb_sp.out','| TOTAL ENERGY',e_there,eread(i)) + call remove('xtbrestart') !call remove('xcontrol') call chdirdbug(trim(thispath)) @@ -761,11 +772,14 @@ subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added) end subroutine cff_opt -subroutine cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added) +subroutine cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir, & + & conv,nothing_added,eread) use crest_parameters use iomod use crest_data use strucrd + use crest_calculator + use optimize_module implicit none type(systemdata) :: env @@ -775,19 +789,37 @@ subroutine cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added) integer,intent(inout) :: conv(env%nqcgclust+1) logical,intent(in) :: pr logical,intent(in) :: nothing_added(env%nqcgclust) - integer :: i,k,n12 + integer,intent(in) :: n12 + real(wp),intent(out) :: eread(env%nqcgclust) + integer :: i,k integer :: vz,T,Tn integer :: funit - character(len=20) :: pipe character(len=512) :: thispath,tmppath character(len=1024) :: jobcall character(len=2) :: flag real(wp) :: percent + logical :: gbsa_tmp,opt_nofreeze + integer :: io,nconstraints_tmp + character(len=40) :: solv_tmp + real(wp) :: etot + type(calcdata),allocatable :: newcalcs(:) + type(calculation_settings) :: clevel + type(coord) :: mol,molopt + type(coord),allocatable :: structures(:) + real(wp),allocatable :: grd(:,:) + character(len=*),parameter :: pipe = '2>/dev/null' + + !> setting the threads to accelerate individual energy calculations + call new_ompautoset(env,'max',NTMP,T,Tn) if (pr) then write (stdout,'(2x,"Starting optimizations + SP of structures")') write (stdout,'(2x,i0,'' jobs to do.'')') NTMP end if + if (NTMP .lt. 1) then + write (stdout,'(2x,"No structures to be optimized")') + return + end if ! pr eq true => post opt run, which has to be performed in every directory !!! if (pr) then @@ -799,115 +831,126 @@ subroutine cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added) conv(env%nqcgclust+1) = k end do end if - pipe = '2>/dev/null' + + !> Local storage for structures. + allocate (structures(NTMP)) call getcwd(thispath) do i = 1,NTMP write (tmppath,'(a,i0)') trim(TMPdir),conv(i) call chdirdbug(trim(tmppath)) - open (newunit=funit,file='xcontrol') - if (n12 .ne. 0) then - flag = '$' - write (funit,'(a,"fix")') trim(flag) - write (funit,'(3x,"atoms: 1-",i0)') n12 !Initial number of atoms (starting solvent shell) - end if - close (funit) - if (pr.and.nothing_added(i)) call remove('xcontrol') + call structures(i)%open(fname) call chdirdbug(trim(thispath)) end do -!--- Jobcall WITHOUT GBSA - write (jobcall,'(a,1x,a,1x,a,'' --input xcontrol --opt '',i0,1x,a,'' >xtb.out'')') & - & trim(env%ProgName),trim(fname),trim(env%gfnver),nint(env%optlev),trim(pipe) - if (NTMP .lt. 1) then write (stdout,'(2x,"No structures to be optimized")') return end if +!--- Jobcall WITHOUT GBSA, back up data + solv_tmp = env%solv + gbsa_tmp = env%gbsa + env%solv = '' + env%gbsa = .false. + + !> keep everything nice and separate, we have different molecules after all... + !> also, this will be gas-phase + call clevel%create(env%gfnver,chrg=env%chrg,uhf=env%uhf) + allocate (newcalcs(NTMP)) + do i = 1,NTMP + call newcalcs(i)%add(clevel) + !> other important settings from env + newcalcs(i)%optlev = int(env%optlev) + end do + + !> ------------------------------------------------- + !> OPTIMIZATIONS + !> ------------------------------------------------- + !> The structures may have different numbers + !> and it should not not be many structures anyways. + !> therefore, just optimize them serially. + k = 0 !counting the finished jobs if (pr) call printprogbar(0.0_wp) !___________________________________________________________________________________ -!$omp parallel & -!$omp shared( vz,jobcall,NTMP,percent,k,TMPdir,conv ) -!$omp single do i = 1,NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath ) - write (tmppath,'(a,i0)') trim(TMPdir),conv(vz) - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical + mol = structures(i) + allocate (grd(3,mol%nat)) + opt_nofreeze = (pr.and.nothing_added(i)) + if (.not.opt_nofreeze.and.n12 > 0) then + call newcalcs(i)%set_freeze(mol%nat,1,n12) + if (n12 == mol%nat) cycle !> safeguard against freezing all + end if + + call optimize_geometry(mol,molopt,newcalcs(i),etot,grd, & + & .false.,.false.,io) + structures(i) = molopt + structures(i)%energy = etot + k = k+1 - percent = float(k)/float(NTMP)*100 + percent = real(k)/real(NTMP)*100.0_wp if (pr) then call printprogbar(percent) end if - !$omp end critical - !$omp end task - end do -!$omp taskwait -!$omp end single -!$omp end parallel + deallocate (grd) + end do + !> clear up space + deallocate (newcalcs) !__________________________________________________________________________________ +!> ------------------------------------------------- +!> SINGLEPOINTS +!> ------------------------------------------------- +!> same as for optimizations, turn on impl. solv again + env%solv = solv_tmp + env%gbsa = gbsa_tmp + + !> again, keep everything nice and separate (now with impl. solv) + call clevel%create(env%gfnver,chrg=env%chrg,uhf=env%uhf,& + & solvmodel=env%solv,solvent=env%solvent & + ) + allocate (newcalcs(NTMP)) do i = 1,NTMP - write (tmppath,'(a,i0)') trim(TMPdir),conv(i) - call chdirdbug(trim(tmppath)) - call remove('xtbrestart') - call chdirdbug(trim(thispath)) + call newcalcs(i)%add(clevel) end do - !create the system call for sp (needed for gbsa model) - write (jobcall,'(a,1x,a,1x,a,'' --sp '',a,1x,a,'' >xtb_sp.out'')') & - & trim(env%ProgName),'xtbopt.coord',trim(env%gfnver),trim(env%solv),trim(pipe) - - if (NTMP .lt. 1) then - write (stdout,'(2x,"Nothing to do")') - return - end if - k = 0 !counting the finished jobs if (pr) call printprogbar(0.0_wp) !___________________________________________________________________________________ -!$omp parallel & -!$omp shared( vz,jobcall,NTMP,percent,k,TMPdir,conv ) -!$omp single do i = 1,NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath ) - write (tmppath,'(a,i0)') trim(TMPdir),conv(vz) - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical + mol = structures(i) + allocate (grd(3,mol%nat)) + + call engrad(mol,newcalcs(i),etot,grd,io) + structures(i)%energy = etot + k = k+1 - percent = float(k)/float(NTMP)*100 + percent = real(k)/real(NTMP)*100.0_wp if (pr) then call printprogbar(percent) end if - !$omp end critical - !$omp end task - end do -!$omp taskwait -!$omp end single -!$omp end parallel + deallocate (grd) + end do !___________________________________________________________________________________ + !> for compatibility reasons, let's write the optimized geometries + !> and pass on energies + call getcwd(thispath) do i = 1,NTMP + eread(i) = structures(i)%energy write (tmppath,'(a,i0)') trim(TMPdir),conv(i) call chdirdbug(trim(tmppath)) - call remove('xtbrestart') - !call remove('xcontrol') + call structures(i)%write('xtbopt.coord') call chdirdbug(trim(thispath)) end do - if (pr) then - write (stdout,*) '' - write (stdout,'(2x,"done.")') - end if - + if (allocated(newcalcs)) deallocate(newcalcs) + if (allocated(structures)) deallocate (structures) end subroutine cff_opt_calculator !___________________________________________________________________________________ @@ -1046,7 +1089,7 @@ subroutine ens_sp(env,fname,NTMP,TMPdir) call command('cd '//trim(tmppath)//' && '//trim(jobcall)) !$omp critical k = k+1 - percent = float(k)/float(NTMP)*100 + percent = real(k)/real(NTMP)*100 call printprogbar(percent) !$omp end critical !$omp end task @@ -1132,7 +1175,7 @@ subroutine ens_freq(env,fname,NTMP,TMPdir,opt) call command('cd '//trim(tmppath)//' && '//trim(jobcall)) !$omp critical k = k+1 - percent = float(k)/float(NTMP)*100 + percent = real(k)/real(NTMP)*100 call printprogbar(percent) !$omp end critical !$omp end task @@ -1362,6 +1405,9 @@ subroutine qcg_envcalc_reinit(env,mol,addconstraints,printinfo) if (addconstraints) then if (allocated(env%calc%cons)) deallocate (env%calc%cons) env%calc%nconstraints = 0 + if (printinfo) then + write (stdout,'(a,a,a)') 'Parsing xtb-type constraints from internal backup to set up calculators ...' + end if call parse_constraints_from_cts(env%calc,mol,env%cts) end if From a073163541a8f511e65e04c941f8add05aa25a52 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 14 Dec 2025 15:32:59 +0100 Subject: [PATCH 105/374] Starting final part of QCG refactor: frequencies --- src/algos/playground.f90 | 39 +++++-------- src/algos/refine.f90 | 22 ++++---- src/qcg/qcg_main.f90 | 30 +++++----- src/qcg/qcg_misc.f90 | 31 ++++++----- src/strucreader.f90 | 117 ++++++++++++++++++++++++++------------- 5 files changed, 134 insertions(+), 105 deletions(-) diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index 9b2b68e0..533dfe63 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -30,18 +30,18 @@ subroutine crest_playground(env,tim) use crest_parameters use crest_data use crest_calculator - use strucrd + use strucrd use canonical_mod implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim type(coord) :: mol,molnew - integer :: i,j,k,l,io,ich + integer :: i,j,k,l,io,ich logical :: pr,wr !========================================================================================! type(calcdata) :: calc real(wp) :: accuracy,etemp - + integer :: V,maxgen integer,allocatable :: A(:,:) logical,allocatable :: rings(:,:) @@ -53,39 +53,30 @@ subroutine crest_playground(env,tim) type(canonical_sorter) :: can !========================================================================================! - call tim%start(14,'Test implementation') + call tim%start(14,'Test implementation') !========================================================================================! !call system('figlet welcome') - write(*,*) " _ " - write(*,*) "__ _____| | ___ ___ _ __ ___ ___ " - write(*,*) "\ \ /\ / / _ \ |/ __/ _ \| '_ ` _ \ / _ \" - write(*,*) " \ V V / __/ | (_| (_) | | | | | | __/" - write(*,*) " \_/\_/ \___|_|\___\___/|_| |_| |_|\___|" - write(*,*) + write (*,*) " _ " + write (*,*) "__ _____| | ___ ___ _ __ ___ ___ " + write (*,*) "\ \ /\ / / _ \ |/ __/ _ \| '_ ` _ \ / _ \" + write (*,*) " \ V V / __/ | (_| (_) | | | | | | __/" + write (*,*) " \_/\_/ \___|_|\___\___/|_| |_| |_|\___|" + write (*,*) !========================================================================================! call env%ref%to(mol) - write(*,*) - write(*,*) 'Input structure:' + write (*,*) + write (*,*) 'Input structure:' call mol%append(stdout) - write(*,*) + write (*,*) !========================================================================================! - allocate(grad(3,mol%nat), source=0.0_wp) + allocate (grad(3,mol%nat),source=0.0_wp) call env2calc(env,calc,mol) - calc%calcs(1)%rdwbo=.true. + calc%calcs(1)%rdwbo = .true. call calc%info(stdout) call engrad(mol,calc,energy,grad,io) call calculation_summary(calc,mol,energy,grad) - - block - use tblite_api - use iomod, only: dump_array_to_tmp - call tblite_quick_ceh_q(mol,q,env%chrg,pr=.true.) - write(*,*) 'q:' - write(*,*) q - write(*,*) dump_array_to_tmp(q) - end block !========================================================================================! call tim%stop(14) diff --git a/src/algos/refine.f90 b/src/algos/refine.f90 index 71a96b28..9295a35f 100644 --- a/src/algos/refine.f90 +++ b/src/algos/refine.f90 @@ -56,19 +56,19 @@ subroutine crest_refine(env,input,output) else outname = input !> overwrite end if - + !>--- presorting step, if necessary - if(env%refine_presort)then + if (env%refine_presort) then call newcregen(env,0,input) call rename('crest_ensemble.xyz',input) - endif + end if !>--- read in call rdensemble(input,nat,nall,at,xyz,eread) allocate (etmp(nall),source=0.0_wp) !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: crest_sploop requires coordinates in Bohrs - xyz = xyz / bohr + xyz = xyz/bohr !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<< Geometry optimization of ",i0," structures")') nall call crest_oloop(env,nat,nall,at,xyz,eread,.false.) - case(refine%confsolv) + case (refine%confsolv) call new_ompautoset(env,'subprocess',1,t1,t2) write (stdout,'("> ConfSolv: ΔΔGsoln estimation from 3D directed message passing neural networks (D-MPNN)")') - call confsolv_request( input, nall, t2, etmp, io) - if(io == 0)then - eread(:) = etmp(:)*kcaltoau !> since CREGEN deals with Eh energies - endif + call confsolv_request(input,nall,t2,etmp,io) + if (io == 0) then + eread(:) = etmp(:)*kcaltoau !> since CREGEN deals with Eh energies + end if end select - write(stdout,*) + write (stdout,*) end do !> reset the refinement stage of the calculator @@ -118,7 +118,7 @@ subroutine crest_refine(env,input,output) !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: ensemble file must be written in AA - xyz = xyz / angstrom + xyz = xyz/angstrom !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- write output ensemble call wrensemble(outname,nat,nall,at,xyz,eread) diff --git a/src/qcg/qcg_main.f90 b/src/qcg/qcg_main.f90 index ab5a34a3..9eb4a495 100644 --- a/src/qcg/qcg_main.f90 +++ b/src/qcg/qcg_main.f90 @@ -129,7 +129,6 @@ subroutine crest_solvtool(env,tim) progress = progress+1 end if - stop 'Failsafe' !------------------------------------------------------------------------------ ! Frequency computation and evaluation !------------------------------------------------------------------------------ @@ -880,11 +879,6 @@ subroutine qcg_ensemble(env,solu,solv,clus,ens,tim,fname_results) & 'solute_cut.coord','solvent_shell.coord') call remove('crest_input') call copy('solvent_shell.coord','crest_input') - !deallocate (clus%at) - !deallocate (clus%xyz) - !call rdnat('solvent_shell.coord',clus%nat) - !allocate (clus%at(clus%nat),clus%xyz(3,clus%nat)) - !call rdcoord('solvent_shell.coord',clus%nat,clus%at,clus%xyz) call clus%open('solvent_shell.coord') end if @@ -1219,8 +1213,8 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) type(systemdata) :: env type(timer) :: tim type(coord_qcg) :: solu,solv,clus - type(ensemble) :: solv_ens - type(ensemble),intent(in) :: ens + type(ensemble),intent(inout) :: solv_ens + type(ensemble),intent(in) :: ens integer :: i,j,k,iter integer :: io,r @@ -1531,7 +1525,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) !--- Writing outputfiles write (ich31,'(2x,i0)') clus%nat - write (ich31,'(2x,f18.8,2x,a)') e_cluster(i) + write (ich31,'(2x,a,f18.8,2x,a)') 'energy=', e_cluster(i) do j = 1,clus%nat write (ich31,'(1x,a2,1x,3f20.10)') i2e(clus%at(j),'nc'),clus%xyz(1:3,j)*bohr end do @@ -1562,7 +1556,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) clus%xyz = clus%xyz*bohr call chdirdbug(tmppath2) - write (comment,'(F20.8)') solv_ens%er(minpos) + write (comment,'(a,F20.8)') 'energy=',solv_ens%er(minpos) call wrxyz('crest_best.xyz',clus%nat,clus%at,clus%xyz,comment) !--- Boltz. average------------------------------------------------------------------------- @@ -1676,7 +1670,7 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) call copysub('.UHF','tmp_gas1') !--- Frequencies solute molecule - write (stdout,*) ' SOLUTE MOLECULE' + write (stdout,'(1x,a)') 'processing SOLUTE MOLECULE' call chdirdbug('tmp_gas1') call solu%write('solute.coord') call chdirdbug(tmppath2) @@ -1705,7 +1699,8 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) clus%nmol = env%nsolv+1 !clus%nat/clus%at do i = 1,solu_ens%nall - call rdxmolselec('solute_ensemble.xyz',i,clus%nat,clus%at,clus%xyz) + !call rdxmolselec('solute_ensemble.xyz',i,clus%nat,clus%at,clus%xyz) + call solu_ens%get_mol(i,clus) !--- Solute cluster write (to,'("TMPFREQ",i0)') i @@ -1713,9 +1708,10 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) call copysub('.UHF',to) call copysub('.CHRG',to) call chdirdbug(to) - open (newunit=ich65,file='cluster.xyz') - call wrxyz(ich65,clus%nat,clus%at,clus%xyz*bohr) - close (ich65) + !open (newunit=ich65,file='cluster.xyz') + !call wrxyz(ich65,clus%nat,clus%at,clus%xyz*bohr) + !close (ich65) + call clus%write("cluster.xyz") call chdirdbug(tmppath2) @@ -1735,14 +1731,14 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) end do - write (stdout,*) ' SOLUTE CLUSTER' + write (stdout,'(/,1x,a)') 'processing SOLUTE CLUSTER' !> Frequency calculation opt = .true. call ens_freq(env,'cluster.xyz',solu_ens%nall,'TMPFREQ',opt) call chdirdbug(tmppath2) - write (stdout,*) ' SOLVENT CLUSTER' + write (stdout,'(/,1x,a)') 'processing SOLVENT CLUSTER' if (env%cff) then call chdirdbug('tmp_solv') call ens_freq(env,'solvent_cut.coord',solu_ens%nall,'TMPFREQ',opt) diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index 1e40bec1..3c7d2af8 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -685,11 +685,11 @@ subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added,eread) end if k = 0 !counting the finished jobs - if (pr) call printprogbar(0.0_wp) + if (pr) call crest_oloop_pr_progress(env,NTMP,k) !___________________________________________________________________________________ !$omp parallel & -!$omp shared( vz,jobcall,NTMP,percent,k,TMPdir,conv ) +!$omp shared( env, vz,jobcall,NTMP,percent,k,TMPdir,conv ) !$omp single do i = 1,NTMP vz = i @@ -700,7 +700,7 @@ subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added,eread) k = k+1 percent = real(k)/real(NTMP)*100 if (pr) then - call printprogbar(percent) + call crest_oloop_pr_progress(env,NTMP,k) end if !$omp end critical !$omp end task @@ -728,7 +728,7 @@ subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added,eread) end if k = 0 !counting the finished jobs - if (pr) call printprogbar(0.0_wp) + if (pr) call crest_oloop_pr_progress(env,NTMP,k) !___________________________________________________________________________________ !$omp parallel & @@ -743,7 +743,7 @@ subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added,eread) k = k+1 percent = real(k)/real(NTMP)*100 if (pr) then - call printprogbar(percent) + call crest_oloop_pr_progress(env,NTMP,k) end if !$omp end critical !$omp end task @@ -872,7 +872,7 @@ subroutine cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir, & !> therefore, just optimize them serially. k = 0 !counting the finished jobs - if (pr) call printprogbar(0.0_wp) + if (pr) call crest_oloop_pr_progress(env,NTMP,k) !___________________________________________________________________________________ do i = 1,NTMP @@ -892,7 +892,7 @@ subroutine cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir, & k = k+1 percent = real(k)/real(NTMP)*100.0_wp if (pr) then - call printprogbar(percent) + call crest_oloop_pr_progress(env,NTMP,k) end if deallocate (grd) @@ -918,7 +918,7 @@ subroutine cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir, & end do k = 0 !counting the finished jobs - if (pr) call printprogbar(0.0_wp) + if (pr) call crest_oloop_pr_progress(env,NTMP,k) !___________________________________________________________________________________ do i = 1,NTMP @@ -931,7 +931,7 @@ subroutine cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir, & k = k+1 percent = real(k)/real(NTMP)*100.0_wp if (pr) then - call printprogbar(percent) + call crest_oloop_pr_progress(env,NTMP,k) end if deallocate (grd) @@ -1073,11 +1073,12 @@ subroutine ens_sp(env,fname,NTMP,TMPdir) & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) k = 0 !counting the finished jobs - call printprogbar(0.0_wp) + call crest_oloop_pr_progress(env,NTMP,k) + !___________________________________________________________________________________ !$omp parallel & -!$omp shared( vz,NTMP,percent,k,TMPdir,jobcall ) +!$omp shared( env,vz,NTMP,percent,k,TMPdir,jobcall ) !$omp single do i = 1,NTMP vz = i @@ -1090,7 +1091,7 @@ subroutine ens_sp(env,fname,NTMP,TMPdir) !$omp critical k = k+1 percent = real(k)/real(NTMP)*100 - call printprogbar(percent) + call crest_oloop_pr_progress(env,NTMP,k) !$omp end critical !$omp end task end do @@ -1152,7 +1153,7 @@ subroutine ens_freq(env,fname,NTMP,TMPdir,opt) end if k = 0 !counting the finished jobs - call printprogbar(0.0_wp) + call crest_oloop_pr_progress(env,NTMP,k) !--- Jobcall if (.not.opt) then @@ -1166,7 +1167,7 @@ subroutine ens_freq(env,fname,NTMP,TMPdir,opt) !___________________________________________________________________________________ !$omp parallel & -!$omp shared( vz,NTMP,percent,k,TMPdir,jobcall ) +!$omp shared( env,vz,NTMP,percent,k,TMPdir,jobcall ) !$omp single do i = 1,NTMP vz = i @@ -1176,7 +1177,7 @@ subroutine ens_freq(env,fname,NTMP,TMPdir,opt) !$omp critical k = k+1 percent = real(k)/real(NTMP)*100 - call printprogbar(percent) + call crest_oloop_pr_progress(env,NTMP,k) !$omp end critical !$omp end task end do diff --git a/src/strucreader.f90 b/src/strucreader.f90 index 3189b1c8..ee88c821 100644 --- a/src/strucreader.f90 +++ b/src/strucreader.f90 @@ -218,18 +218,25 @@ module strucrd procedure :: swap => atswp !> swap two atoms coordinates and their at() entries end type coord !=========================================================================================! - !ensemble class. contains all structures of an ensemble - !by convention coordinates are in Angström for an ensemble! + !> ensemble class. contains all structures of an ensemble + !> by convention coordinates are in Angström for an ensemble! type :: ensemble - !--- data - integer :: nat = 0 !number of total atoms - integer :: nall = 0 !number of structures - integer,allocatable :: vnat(:) !used instead of nat if not all structures have the same number of atoms, in which case nat will be =maxval(vnat,1) + logical :: mixed = .false. !> if all molecules were the same == .false. + + !> data + integer :: nat = 0 !> (max) number of total atoms + integer :: nall = 0 !> number of structures + + !> if all structures were the same molecule these are filled + !> mixed==.false. + integer,allocatable :: at(:) !> atom types as integer, dimension will be at(nat) + real(wp),allocatable :: xyz(:,:,:) !> coordinates, dimension will be xyz(3,nat,nall) + real(wp),allocatable :: er(:) !> energy of each structure, dimension will be eread(nall) - integer,allocatable :: at(:) !atom types as integer, dimension will be at(nat) - real(wp),allocatable :: xyz(:,:,:) !coordinates, dimension will be xyz(3,nat,nall) - real(wp),allocatable :: er(:) !energy of each structure, dimension will be eread(nall) + !> otherwise this is filled + !> mixed == .true. + type(coord),allocatable :: structures(:) real(wp) :: g !gibbs free energy real(wp) :: s !entropy @@ -682,7 +689,12 @@ subroutine write_ensemble(self,fname) implicit none class(ensemble) :: self character(len=*),intent(in) :: fname - call wrensemble_conf_energy(fname,self%nat,self%nall,self%at,self%xyz,self%er) + if (.not.self%mixed) then + call wrensemble_conf_energy(fname,self%nat,self%nall,self%at,self%xyz,self%er) + else + self%structures(:)%energy = self%er(:) + call wrensemble_coord_name(fname,self%nall,self%structures) + end if return end subroutine write_ensemble @@ -719,18 +731,21 @@ end subroutine wrensemble_coord_channel subroutine deallocate_ensembletype(self) implicit none class(ensemble) :: self + + self%mixed = .false. self%nat = 0 self%nall = 0 - if (allocated(self%vnat)) deallocate (self%vnat) if (allocated(self%at)) deallocate (self%at) if (allocated(self%xyz)) deallocate (self%xyz) if (allocated(self%er)) deallocate (self%er) + + if (allocated(self%structures)) deallocate (self%structures) + if (allocated(self%gt)) deallocate (self%gt) if (allocated(self%ht)) deallocate (self%ht) if (allocated(self%svib)) deallocate (self%svib) if (allocated(self%srot)) deallocate (self%srot) if (allocated(self%stra)) deallocate (self%stra) - return end subroutine deallocate_ensembletype @@ -749,27 +764,38 @@ subroutine openensemble(self,fname) real(wp),allocatable :: eread(:) integer :: nall integer :: i,j,k,ich,io - logical :: ex + logical :: ex,conform + type(coord),allocatable :: structures(:) inquire (file=fname,exist=ex) if (.not.ex) then error stop 'ensemble file does not exist.' end if - call rdensembleparam(fname,nat,nall) - - if (nat > 0.and.nall > 0) then - call self%deallocate() - allocate (at(nat),xyz(3,nat,nall),eread(nall)) - call rdensemble(fname,nat,nall,at,xyz,eread) - - self%nat = nat - self%nall = nall - call move_alloc(at,self%at) - call move_alloc(xyz,self%xyz) - call move_alloc(eread,self%er) + !> we check if all the structures in the file + !> are actually the same length (nat), if not we need to + !> take care of this and read into self%structures instead + call rdensembleparam(fname,nat,nall,conform) + self%mixed = .not.conform + + if (conform) then + if (nat > 0.and.nall > 0) then + call self%deallocate() + allocate (at(nat),xyz(3,nat,nall),eread(nall)) + call rdensemble(fname,nat,nall,at,xyz,eread) + + self%nat = nat + self%nall = nall + call move_alloc(at,self%at) + call move_alloc(xyz,self%xyz) + call move_alloc(eread,self%er) + else + error stop 'format error while reading ensemble file.' + end if else - error stop 'format error while reading ensemble file.' + call rdensemble_coord_type(fname,self%nall,self%structures) + allocate(self%er(nall),source=0.0_wp) + self%er(:) = self%structures(:)%energy end if return @@ -783,19 +809,34 @@ subroutine ensemble_get_mol(self,i,mol) logical :: reinitialize if (i > self%nall) error stop 'can´t get molecule from ensemble. i>nall' if (i < 1) error stop 'can´t get molecule from ensemble. i<1' - n = self%nat - reinitialize = (mol%nat == n) - if (reinitialize) then - mol%nat = n - if (allocated(mol%at)) deallocate (mol%at) - allocate (mol%at(n),source=0) - if (allocated(mol%xyz)) deallocate (mol%xyz) - allocate (mol%xyz(3,n),source=0.0_wp) + if (.not.self%mixed) then + n = self%nat + reinitialize = .not. (mol%nat == n) + if (reinitialize) then + mol%nat = n + if (allocated(mol%at)) deallocate (mol%at) + allocate (mol%at(n),source=0) + if (allocated(mol%xyz)) deallocate (mol%xyz) + allocate (mol%xyz(3,n),source=0.0_wp) + end if + mol%energy = self%er(i) + mol%at(:) = self%at(:) + !> Important, ens is in Angström, mol is in Bohrs + mol%xyz(1:3,1:n) = self%xyz(1:3,1:n,i)*aatoau + else !> self%mixed == .true. + n = self%structures(i)%nat + reinitialize = .not. (mol%nat == n) + if (reinitialize) then + if (allocated(mol%at)) deallocate (mol%at) + allocate (mol%at(n),source=0) + if (allocated(mol%xyz)) deallocate (mol%xyz) + allocate (mol%xyz(3,n),source=0.0_wp) + end if + mol%nat = self%structures(i)%nat + mol%at(:) = self%structures(i)%at(:) + mol%xyz(:,:) = self%structures(i)%xyz(:,:) + mol%energy = self%structures(i)%energy end if - mol%energy = self%er(i) - mol%at(:) = self%at(:) - !> Important, ens is in Angström, mol is in Bohrs - mol%xyz(1:3,1:n) = self%xyz(1:3,1:n,i)*aatoau end subroutine ensemble_get_mol !=========================================================================================! From 657635e19ad6c8717c5221721be1a4c08ab10b32 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 14 Dec 2025 18:44:29 +0100 Subject: [PATCH 106/374] Working implementation --- src/algos/numhess.f90 | 4 +- src/entropy/thermocalc.f90 | 89 ++++++++++++----------- src/qcg/qcg_main.f90 | 30 ++++---- src/qcg/qcg_misc.f90 | 141 +++++++++++++++++++++++++++++++++++-- 4 files changed, 203 insertions(+), 61 deletions(-) diff --git a/src/algos/numhess.f90 b/src/algos/numhess.f90 index 9d817e68..3579b014 100644 --- a/src/algos/numhess.f90 +++ b/src/algos/numhess.f90 @@ -308,7 +308,7 @@ subroutine numhess_thermostat(env,mol,nat3,hess,freq,etot) !> calcthermo wants input in Angstroem call calcthermo(mol%nat,mol%at,mol%xyz*autoaa,freq,.true., & - & ithr,fscal,sthr,nt,temps,et,ht,gt,stot) + & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,stdout) !> printoutgeometr zpve = et(nrt)-ht(nrt) @@ -413,7 +413,7 @@ subroutine thermo_standalone(env) !> calcthermo wants input in Angstroem call calcthermo(mol%nat,mol%at,mol%xyz*autoaa,freq,.true., & - & ithr,fscal,sthr,nt,temps,et,ht,gt,stot) + & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,stdout) !> printout zpve = et(nrt)-ht(nrt) diff --git a/src/entropy/thermocalc.f90 b/src/entropy/thermocalc.f90 index 2aa2e64f..f250b0e2 100644 --- a/src/entropy/thermocalc.f90 +++ b/src/entropy/thermocalc.f90 @@ -21,7 +21,7 @@ !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC! !=========================================================================================! -subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar) +subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar,iunit) !*********************************************************************** !* Prepare the calculation of thermodynamic properties of a structure !* In particular, determine rotational constants and check the symmetry @@ -39,6 +39,7 @@ subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar) real(wp),intent(inout) :: rabc(3) real(wp),intent(out) :: avmom real(wp),intent(out) :: symnum + integer,intent(in) :: iunit real(wp) :: a,b,c character(len=4) :: sfsym @@ -50,7 +51,7 @@ subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar) molmass = molweight(nat,at) if (pr) then - write (stdout,'(1x,a,f15.2)') 'Mol. weight /amu : ',molmass + write (iunit,'(1x,a,f15.2)') 'Mol. weight /amu : ',molmass end if !>--- rotational constants in cm-1 @@ -62,11 +63,11 @@ subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar) rabc(1) = a rabc(3) = c if (pr) then - write (stdout,'(1x,a,3f15.2)') 'Rot. const. /MHz : ',rabc(1:3) + write (iunit,'(1x,a,3f15.2)') 'Rot. const. /MHz : ',rabc(1:3) end if rabc = rabc/2.99792458d+4 ! MHz to cm-1 if (pr) then - write (stdout,'(1x,a,3f15.2)') 'Rot. const. /cm-1 : ',rabc(1:3) + write (iunit,'(1x,a,3f15.2)') 'Rot. const. /cm-1 : ',rabc(1:3) end if !>--- symmetry number from rotational symmetry @@ -108,14 +109,14 @@ subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar) end if if (pr) then - write (stdout,'(1x,a,4x,a)') 'Symmetry:',sym + write (iunit,'(1x,a,4x,a)') 'Symmetry:',sym end if return end subroutine prepthermo !=========================================================================================! subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & - & et,ht,gt,stot) + & et,ht,gt,stot,iunit) !************************************************************** !* Calculate thermodynamic contributions for a given structure !* from it's frequencies (from second derivatives/the Hessian) @@ -136,6 +137,7 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & real(wp),intent(in) :: sthr !rotor cut integer,intent(in) :: nt real(wp),intent(in) :: temps(nt) + integer,intent(in) :: iunit real(wp) :: et(nt) !< enthalpy in Eh real(wp) :: ht(nt) !< enthalpy in Eh real(wp) :: gt(nt) !< free energy in Eh @@ -173,7 +175,7 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & real(wp),parameter :: rcmtoau = 1.0_wp/autorcm real(wp),parameter :: autocal = 627.50947428_wp*1000.0_wp - call prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,sym,symchar) + call prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,sym,symchar,iunit) n3 = 3*nat allocate (vibs(n3)) @@ -208,7 +210,7 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & do i = 1,nvib if (vibs(i) .lt. 0.and.vibs(i) .gt. ithr) then vibs(i) = -vibs(i) - if (pr) write (stdout,'(a,i5," :",f10.2)') 'Inverting frequency',i,vibs(i) + if (pr) write (iunit,'(a,i5," :",f10.2)') 'Inverting frequency',i,vibs(i) end if if (vibs(i) < 0.0) then nimag = nimag+1 @@ -216,20 +218,20 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & end do if (pr) then - write (stdout,'(a)') - write (stdout,'(10x,51("."))') - write (stdout,'(10x,":",22x,a,22x,":")') "SETUP" - write (stdout,'(10x,":",49("."),":")') - write (stdout,intfmt) "# frequencies ",nvib - write (stdout,intfmt) "# imaginary freq.",nimag + write (iunit,'(a)') + write (iunit,'(10x,51("."))') + write (iunit,'(10x,":",22x,a,22x,":")') "SETUP" + write (iunit,'(10x,":",49("."),":")') + write (iunit,intfmt) "# frequencies ",nvib + write (iunit,intfmt) "# imaginary freq.",nimag write (atmp,*) linear - write (stdout,chrfmt) "linear? ",trim(atmp) - write (stdout,chrfmt) "symmetry ",adjustr(symchar) - write (stdout,intfmt) "rotational number",nint(sym) - write (stdout,dblfmt) "scaling factor ",fscal," " - write (stdout,dblfmt) "rotor cutoff ",sthr,"cm⁻¹" - write (stdout,dblfmt) "imag. cutoff ",ithr,"cm⁻¹" - write (stdout,'(10x,":",49("."),":")') + write (iunit,chrfmt) "linear? ",trim(atmp) + write (iunit,chrfmt) "symmetry ",adjustr(symchar) + write (iunit,intfmt) "rotational number",nint(sym) + write (iunit,dblfmt) "scaling factor ",fscal," " + write (iunit,dblfmt) "rotor cutoff ",sthr,"cm⁻¹" + write (iunit,dblfmt) "imag. cutoff ",ithr,"cm⁻¹" + write (iunit,'(10x,":",49("."),":")') end if vibs = vibs*rcmtoau ! thermodyn needs vibs and zp in Eh @@ -244,35 +246,36 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & pr2 = .false. end if if (pr2) then - call print_thermo_sthr_ts(stdout,nvib,vibs,avmom,sthr,temps(j)) + call print_thermo_sthr_ts(iunit,nvib,vibs,avmom,sthr,temps(j)) end if - call thermodyn(stdout,a,b,c,avmom,linear,atom,sym,molmass,vibs,nvib, & + call thermodyn(iunit,a,b,c,avmom,linear,atom,sym,molmass,vibs,nvib, & & temps(j),sthr,et(j),ht(j),gt(j),ts(j),zp,pr2) stot(j) = (ts(j)/temps(j))*autocal end do - if ((nt > 1).and.pr) then - write (stdout,'(a)') - write (stdout,'(a10)',advance='no') "T/K" - write (stdout,'(a16)',advance='no') "H(0)-H(T)+PV" - write (stdout,'(a16)',advance='no') "H(T)/Eh" - write (stdout,'(a16)',advance='no') "T*S/Eh" - write (stdout,'(a16)',advance='no') "G(T)/Eh" - write (stdout,'(a)') - write (stdout,'(3x,72("-"))') + !if ((nt > 1).and.pr) then + if ( pr )then + write (iunit,'(a)') + write (iunit,'(a10)',advance='no') "T/K" + write (iunit,'(a16)',advance='no') "H(0)-H(T)+PV" + write (iunit,'(a16)',advance='no') "H(T)/Eh" + write (iunit,'(a16)',advance='no') "T*S/Eh" + write (iunit,'(a16)',advance='no') "G(T)/Eh" + write (iunit,'(a)') + write (iunit,'(3x,72("-"))') do i = 1,nt - write (stdout,'(3f10.2)',advance='no') temps(i) - write (stdout,'(3e16.6)',advance='no') ht(i) - write (stdout,'(3e16.6)',advance='no') et(i) - write (stdout,'(3e16.6)',advance='no') ts(i) - write (stdout,'(3e16.6)',advance='no') gt(i) - if (i == rt) then - write (stdout,'(1x,"(used)")') + write (iunit,'(3f10.2)',advance='no') temps(i) + write (iunit,'(3e16.6)',advance='no') ht(i) + write (iunit,'(3e16.6)',advance='no') et(i) + write (iunit,'(3e16.6)',advance='no') ts(i) + write (iunit,'(3e16.6)',advance='no') gt(i) + if (i == rt .and. nt > 1) then + write (iunit,'(1x,"(used)")') else - write (stdout,'(a)') + write (iunit,'(a)') end if end do - write (stdout,'(3x,72("-"))') + write (iunit,'(3x,72("-"))') end if deallocate (vibs) @@ -413,7 +416,7 @@ subroutine thermo_wrap_legacy(env,pr,nat,at,xyz,dirname, & fscal = env%thermo%fscal sthr = env%thermo%sthr call calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr, & - & nt,temps,et,ht,gt,stot) + & nt,temps,et,ht,gt,stot,stdout) deallocate (freq) !$omp end critical call initsignal() @@ -581,7 +584,7 @@ subroutine thermo_wrap_new(env,pr,nat,at,xyz,dirname, & fscal = env%thermo%fscal sthr = env%thermo%sthr call calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr, & - & nt,temps,et,ht,gt,stot) + & nt,temps,et,ht,gt,stot,stdout) deallocate (hess,freq) !$omp end critical call initsignal() diff --git a/src/qcg/qcg_main.f90 b/src/qcg/qcg_main.f90 index 9eb4a495..02dcd9ed 100644 --- a/src/qcg/qcg_main.f90 +++ b/src/qcg/qcg_main.f90 @@ -1385,7 +1385,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) call fill_take(env,solv%nat,clus%nat,inner_ell_abc(i,1:3),ipos) if (ipos .eq. 0) then converged(i) = .true. - write(stdout,'(2x,a,i0,a)') & + write (stdout,'(2x,a,i0,a)') & & "no more solvents can be placed inside cavity of cluster: ",i, & & ", taking previous." if (iter .eq. 1) nothing_added(i) = .true. @@ -1525,7 +1525,7 @@ subroutine qcg_cff(env,solu,solv,clus,ens,solv_ens,tim) !--- Writing outputfiles write (ich31,'(2x,i0)') clus%nat - write (ich31,'(2x,a,f18.8,2x,a)') 'energy=', e_cluster(i) + write (ich31,'(2x,a,f18.8,2x,a)') 'energy=',e_cluster(i) do j = 1,clus%nat write (ich31,'(1x,a2,1x,3f20.10)') i2e(clus%at(j),'nc'),clus%xyz(1:3,j)*bohr end do @@ -1637,6 +1637,7 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) real(wp) :: stra(3) integer :: ich65,ich56,ich33,ich81 logical :: opt + type(coord_qcg) :: tmpmol call tim%start(9,'QCG Frequencies') @@ -1669,8 +1670,10 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) call copysub('.CHRG','tmp_gas1') call copysub('.UHF','tmp_gas1') -!--- Frequencies solute molecule - write (stdout,'(1x,a)') 'processing SOLUTE MOLECULE' +!---------------------------------------------------------------------------- +! frequencies for solute molecule +!---------------------------------------------------------------------------- + write (stdout,'(1x,a)') 'processing SOLUTE MOLECULE' call chdirdbug('tmp_gas1') call solu%write('solute.coord') call chdirdbug(tmppath2) @@ -1686,6 +1689,11 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) call chdirdbug(tmppath2) +!---------------------------------------------------------------------------- +! frequencies for solute cluster +!---------------------------------------------------------------------------- + write (stdout,'(/,1x,a)') 'processing SOLUTE CLUSTER' + !--- Folder setup for cluster call chdirdbug('tmp_solu') call solu_ens%write('solute_ensemble.xyz') @@ -1708,9 +1716,6 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) call copysub('.UHF',to) call copysub('.CHRG',to) call chdirdbug(to) - !open (newunit=ich65,file='cluster.xyz') - !call wrxyz(ich65,clus%nat,clus%at,clus%xyz*bohr) - !close (ich65) call clus%write("cluster.xyz") call chdirdbug(tmppath2) @@ -1731,13 +1736,14 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) end do - write (stdout,'(/,1x,a)') 'processing SOLUTE CLUSTER' - !> Frequency calculation opt = .true. call ens_freq(env,'cluster.xyz',solu_ens%nall,'TMPFREQ',opt) call chdirdbug(tmppath2) +!---------------------------------------------------------------------------- +! frequencies for solvent cluster +!---------------------------------------------------------------------------- write (stdout,'(/,1x,a)') 'processing SOLVENT CLUSTER' if (env%cff) then call chdirdbug('tmp_solv') @@ -1753,14 +1759,14 @@ subroutine qcg_freq(env,tim,solu,solv,solu_ens,solv_ens) call solv_ens%write('solvent_ensemble.xyz') do i = 1,solv_ens%nall + call solv_ens%get_mol(i,tmpmol) write (to,'("TMPFREQ",i0)') i io = makedir(trim(to)) call copysub('.UHF',to) call copysub('.CHRG',to) call chdirdbug(to) - open (newunit=ich65,file='solv_cluster.xyz') - call wrxyz(ich65,solv_ens%nat,solv_ens%at,solv_ens%xyz(:,:,i)) - close (ich65) + call tmpmol%write("solv_cluster.xyz") + call chdirdbug(tmppath2) call chdirdbug('tmp_solv') end do diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index 3c7d2af8..7e2a0fa7 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -949,7 +949,7 @@ subroutine cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir, & call chdirdbug(trim(thispath)) end do - if (allocated(newcalcs)) deallocate(newcalcs) + if (allocated(newcalcs)) deallocate (newcalcs) if (allocated(structures)) deallocate (structures) end subroutine cff_opt_calculator @@ -1131,11 +1131,17 @@ subroutine ens_freq(env,fname,NTMP,TMPdir,opt) integer :: i,k integer :: vz,T,Tn - character(len=20) :: pipe character(len=512) :: thispath,tmppath character(len=1024) :: jobcall real(wp) :: percent logical :: opt + character(len=*),parameter :: pipe = '2>/dev/null' + + !> redirect to new calculator version if available + if (.not.env%legacy) then + call ens_freq_calculator(env,fname,NTMP,TMPdir,opt) + return + end if ! setting the threads for correct parallelization call new_ompautoset(env,'auto',NTMP,T,Tn) @@ -1143,8 +1149,6 @@ subroutine ens_freq(env,fname,NTMP,TMPdir,opt) write (stdout,'(2x,''Starting reoptimizations + Frequency computation of ensemble'')') write (stdout,'(2x,i0,'' jobs to do.'')') NTMP - pipe = '2>/dev/null' - call getcwd(thispath) if (NTMP .lt. 1) then @@ -1198,6 +1202,135 @@ subroutine ens_freq(env,fname,NTMP,TMPdir,opt) end subroutine ens_freq +subroutine ens_freq_calculator(env,fname,NTMP,TMPdir,opt) + use crest_parameters + use iomod + use crest_data + use strucrd + use crest_calculator + use hessian_tools + implicit none + + type(systemdata) :: env + character(len=*),intent(in) :: fname !file base name + character(len=*),intent(in) :: TMPdir !directory name + integer,intent(inout) :: NTMP !number of structures to be optimized + + integer :: i,k + integer :: vz,T,Tn + character(len=*),parameter :: pipe = '2>/dev/null' + character(len=512) :: thispath,tmppath + character(len=1024) :: jobcall + real(wp) :: percent + logical :: opt + + !> local calculation setup + type(coord) :: tmpmol,mol + type(calculation_settings) :: clevel + type(calcdata),allocatable :: newcalcs(:) + real(wp),allocatable :: tmpgrd(:,:),hess(:,:),freq(:) + real(wp) :: etmp + integer :: n3,io,ich + + real(wp) :: ithr,fscal,sthr + integer :: nt,nfreq,nrt + real(wp),allocatable :: temps(:),et(:),ht(:),stot(:),gt(:) + real(wp) :: zpve + +! setting the threads for correct parallelization + call new_ompautoset(env,'max',NTMP,T,Tn) + + write (stdout,'(2x,''Starting reoptimizations + Frequency computation of ensemble'')') + write (stdout,'(2x,i0,'' jobs to do.'')') NTMP + + call getcwd(thispath) + + if (NTMP .lt. 1) then + write (stdout,'(2x,"No structures to be optimized")') + return + end if + + k = 0 !counting the finished jobs + call crest_oloop_pr_progress(env,NTMP,k) + +!--- Jobcall + if (.not.opt) then + write (jobcall,'(a,1x,a,1x,a,'' --hess '',a,'' >xtb_freq.out'')') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(pipe) + else + write (jobcall,'(a,1x,a,1x,a,'' --ohess '',a,'' >xtb_freq.out'')') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(pipe) + end if + +!--- prepare calcs + call clevel%create(env%gfnver,chrg=env%chrg,uhf=env%uhf) + allocate (newcalcs(NTMP)) + do i = 1,NTMP + call newcalcs(i)%add(clevel) + newcalcs(i)%optlev = int(env%optlev) + !call newcalcs(i)%info(stdout) + end do + +!--- prepare thermo + !> inversion threshold + ithr = env%thermo%ithr + !> frequency scaling factor + fscal = env%thermo%fscal + !> RR-HO interpolation + sthr = env%thermo%sthr + + !> we just need one temperature + nt = 1 + allocate (temps(nt),et(nt),ht(nt),gt(nt),stot(nt),source=0.0_wp) + temps(:) = 298.15_wp + +!___________________________________________________________________________________ +!> serial runtype + do i = 1,NTMP + write (tmppath,'(a,i0)') trim(TMPdir),i + call chdirdbug(trim(tmppath)) + call tmpmol%open(fname) + + allocate (tmpgrd(3,tmpmol%nat),source=0.0_wp) + if (opt) then + call optimize_geometry(tmpmol,mol,newcalcs(i),etmp,tmpgrd, & + & .false.,.false.,io) + else + mol = tmpmol + end if + + n3 = mol%nat*3 + allocate (hess(n3,n3),source=0.0_wp) + allocate (freq(n3),source=0.0_wp) + + !>-- compute Hessian + call numhess2(mol%nat,mol%at,mol%xyz,newcalcs(i),hess,io) + + !>-- Projects and mass-weights the Hessian + call prj_mw_hess(mol%nat,mol%at,n3,mol%xyz,hess(:,:)) + + !>-- Computes the Frequencies + call frequencies(mol%nat,mol%at,mol%xyz,n3,newcalcs(i),hess(:,:),freq(:),io) + + !> write dummy "xtb_freq.out" + open (newunit=ich,file="xtb_freq.out") + !> calcthermo wants input in Angstroem + call calcthermo(mol%nat,mol%at,mol%xyz*autoaa,freq,.true., & + & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,ich) + close (ich) + + deallocate (freq,hess,tmpgrd) + k = k+1 + call crest_oloop_pr_progress(env,NTMP,k) + call chdirdbug(trim(thispath)) + end do + +!__________________________________________________________________________________ + + write (stdout,*) + write (stdout,'(2x,"done.")') +end subroutine ens_freq_calculator + !============================================================! ! subroutine wr_cluster_cut ! Cuts a cluster file and and writes the parts From b3ce2621d7fd94b6c392ac7180fad5a1bbe17d9a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 14 Dec 2025 19:05:40 +0100 Subject: [PATCH 107/374] printout formatting --- src/qcg/qcg_main.f90 | 5 +++-- src/qcg/qcg_printouts.f90 | 23 ++++++++++++----------- 2 files changed, 15 insertions(+), 13 deletions(-) diff --git a/src/qcg/qcg_main.f90 b/src/qcg/qcg_main.f90 index 02dcd9ed..c5bf4486 100644 --- a/src/qcg/qcg_main.f90 +++ b/src/qcg/qcg_main.f90 @@ -61,8 +61,9 @@ subroutine crest_solvtool(env,tim) call xtbiff_print_deprecated() else write (stdout,*) - write (stdout,*) ' The use of the aISS algorithm is the current standard implementation.' - write (stdout,*) ' This requires xtb version 6.6.0 or newer.' + write (stdout,*) ' This program uses the the aISS algorithm as implemnted in xtb.' + write (stdout,*) ' The aISS method requires xtb version 6.6.0 or newer.' + write (stdout,*) ' Tested with xtb version 6.7.1 (902b313)' !write (stdout,*) ' xTB-IFF can still be used with the --xtbiff flag.' write (stdout,*) end if diff --git a/src/qcg/qcg_printouts.f90 b/src/qcg/qcg_printouts.f90 index 23894119..e13dbf71 100644 --- a/src/qcg/qcg_printouts.f90 +++ b/src/qcg/qcg_printouts.f90 @@ -30,17 +30,18 @@ module qcg_printouts subroutine qcg_head() implicit none write (stdout,*) - write (stdout,'(2x,''========================================'')') - write (stdout,'(2x,''| ---------------- |'')') - write (stdout,'(2x,''| Q C G |'')') - write (stdout,'(2x,''| ---------------- |'')') - write (stdout,'(2x,''| Quantum Cluster Growth |'')') - write (stdout,'(2x,''| University of Bonn, MCTC |'')') - write (stdout,'(2x,''========================================'')') - write (stdout,'(2x,'' S. Grimme, S. Spicher, C. Plett.'')') - write (stdout,*) - write (stdout,'(3x,''Cite work conducted with this code as'')') - write (stdout,'(/,3x,''S. Spicher, C. Plett, P. Pracht, A. Hansen, S. Grimme, JCTC, 2022, 18, 3174-3189.'')') + write (stdout,'(10x,''========================================'')') + write (stdout,'(10x,''| ---------------- |'')') + write (stdout,'(10x,''| Q C G |'')') + write (stdout,'(10x,''| ---------------- |'')') + write (stdout,'(10x,''| Quantum Cluster Growth |'')') + write (stdout,'(10x,''| University of Bonn, MCTC |'')') + write (stdout,'(10x,''========================================'')') + write (stdout,'(10x,'' S. Grimme, S. Spicher, C. Plett.'')') + write (stdout,*) + write (stdout,'(10x,''Cite work conducted with this code as:'')') + write (stdout,'(/,9x,''S. Spicher, C. Plett, P. Pracht, A. Hansen,'')') + write (stdout,'(9x,''S. Grimme, JCTC, 2022, 18, 3174-3189.'')') write (stdout,*) end subroutine qcg_head From 4be836caba1dad40402c5471bdf1a89f8bed2ab0 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 14 Dec 2025 19:59:34 +0100 Subject: [PATCH 108/374] fallback for faulty potscal --- src/confparse.f90 | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/confparse.f90 b/src/confparse.f90 index 81effe30..9e06eb8d 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -1947,7 +1947,7 @@ subroutine parseflags(env,arg,nra) ctmp = arg(i+1) env%user_enslvl = .true. env%qcg_flag = .true. - if (arg(i+1) == 'gfn') then + if (arg(i+1) == '-gfn') then dtmp = trim(arg(i+2)) ctmp = trim(ctmp)//dtmp end if @@ -1969,7 +1969,7 @@ subroutine parseflags(env,arg,nra) case ('-freqlvl') ctmp = arg(i+1) env%qcg_flag = .true. - if (arg(i+1) == 'gfn') then + if (arg(i+1) == '-gfn') then dtmp = trim(arg(i+2)) ctmp = trim(ctmp)//dtmp end if @@ -2160,6 +2160,9 @@ subroutine parseflags(env,arg,nra) error stop 'Z sorting of the input is unavailable for -qcg runtyp.' end if +!>--- avoid 0 potscal + if(env%potscal < 1.0d-5) env%potscal = 1.0_wp + !>--- automatic wall potential for the LEGACY version if ((env%NCI.or.env%wallsetup).and.env%legacy) then call wallpot(env) From 4c8ec85417582811f313f247b9b22802a3d8beab Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 14 Dec 2025 22:28:58 +0100 Subject: [PATCH 109/374] final change for now, md-sampling mode uses internal calculator --- src/dynamics/dynamics_module.f90 | 2 +- src/qcg/qcg_misc.f90 | 311 ++++++++++++++++++------------- 2 files changed, 187 insertions(+), 126 deletions(-) diff --git a/src/dynamics/dynamics_module.f90 b/src/dynamics/dynamics_module.f90 index b17bb7dd..d825d640 100644 --- a/src/dynamics/dynamics_module.f90 +++ b/src/dynamics/dynamics_module.f90 @@ -354,7 +354,7 @@ subroutine dynamics(mol,dat,calc,pr,term) dat%dumped = dat%dumped+1 !$omp critical xyz_angstrom = mol%xyz*bohr - write (commentline,'(a,f22.12,1x,a)') 'Epot =',epot,'' + write (commentline,'(a,f22.12,1x,a)') 'energy =',epot,'' call wrxyz(trj,mol%nat,mol%at,xyz_angstrom,commentline) !$omp end critical end if diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index 7e2a0fa7..82e61672 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -173,6 +173,8 @@ subroutine xtb_md_ensemble_qcg(env,solu,solv,clus,resultspath) use strucrd use iomod use qcg_printouts + use crest_calculator + use dynamics_module implicit none !> IN/OUTPUTS type(systemdata),intent(inout) :: env @@ -189,7 +191,15 @@ subroutine xtb_md_ensemble_qcg(env,solu,solv,clus,resultspath) character(len=1024) :: jobcall logical :: ex,mdfail type(ensemble) :: dum + type(calcdata),target :: calc + type(mddata) :: mddat + type(coord) :: mol + type(mtdpot) :: mtd + real(wp),allocatable :: cn(:),fakewbo(:,:) character(len=*),parameter :: pipe = ' > xtb.out 2>/dev/null' + + call getcwd(tmppath2) + !---- Setting threads call new_ompautoset(env,'auto',1,T,Tn) @@ -201,12 +211,14 @@ subroutine xtb_md_ensemble_qcg(env,solu,solv,clus,resultspath) else newtemp = env%mdtemp end if + env%mdtemp = newtemp if (.not.env%user_mdtime) then newmdtime = 100.0 !100.0 else newmdtime = env%mdtime end if + env%mdtime = newmdtime if (.not.env%user_dumxyz) then env%mddumpxyz = 1000 @@ -221,17 +233,19 @@ subroutine xtb_md_ensemble_qcg(env,solu,solv,clus,resultspath) else newmdstep = env%mdstep end if + env%mdstep = newmdstep if (env%ensemble_opt .ne. '--gff') then newhmass = 4.0 else newhmass = 5.0 end if + env%hmass = newhmass if (.not.allocated(env%metadfac)) then - allocate (env%metadfac(1)) - allocate (env%metadexp(1)) - allocate (env%metadlist(1)) + allocate (env%metadfac(1),source=0.02_wp) + allocate (env%metadexp(1),source=0.1_wp) + allocate (env%metadlist(1),source=10) end if newmetadfac = 0.02_wp newmetadexp = 0.1_wp @@ -239,156 +253,203 @@ subroutine xtb_md_ensemble_qcg(env,solu,solv,clus,resultspath) fname = 'coord' - !--- Writing constraining file xcontrol - !--- Providing xcontrol overwrites constraints in coord file +!> -------------------------------------------------------------------- +!> Internal calculator version +!> -------------------------------------------------------------------- + if (.not.env%legacy) then + call mol%open(fname) - open (newunit=ich,file='xcontrol') - if (env%cts%NCI) then - do i = 1,10 - if (trim(env%cts%pots(i)) .ne. '') then - write (ich,'(a)') trim(env%cts%pots(i)) - end if - end do - end if + call env_to_mddat(env) + mddat = env%mddat + calc = env%calc + if (.not.env%solv_md) then + call calc%set_freeze(mol%nat,1,solu%nat) + end if - if (.not.env%solv_md) then - write (ich,'(a)') '$constrain' - write (ich,'(2x,a,i0)') 'atoms: 1-',solu%nat - write (ich,'(2x,a)') 'force constant=0.5' - write (ich,'(2x,a,a)') 'reference=ref.coord' - end if + if (env%shake .ne. 0) then + call mol%cn_to_bond(cn,fakewbo) + call move_alloc(fakewbo,mddat%shk%wbo) + if (calc%nfreeze > 0) then + mddat%shk%freezeptr => calc%freezelist + end if + end if - write (ich,'(a)') '$md' - write (ich,'(2x,a,f10.2)') 'hmass=',newhmass - write (ich,'(2x,a,f10.2)') 'time=',newmdtime - write (ich,'(2x,a,f10.2)') 'temp=',newtemp - write (ich,'(2x,a,f10.2)') 'step=',newmdstep - write (ich,'(2x,a,i0)') 'shake=',env%shake - write (ich,'(2x,a,i0)') 'dump=',env%mddumpxyz - write (ich,'(2x,a)') 'dumpxyz=500.0' - - if (env%ensemble_method .EQ. 2) then - write (ich,'(a)') '$metadyn' - write (ich,'(2x,a,i0,a,i0)') 'atoms: ',solu%nat+1,'-',clus%nat - write (ich,'(2x,a,f10.2)') 'save=',newmetadlist - write (ich,'(2x,a,f10.2)') 'kpush=',newmetadfac - write (ich,'(2x,a,f10.2)') 'alp=',newmetadexp - end if + !> for MTD runtype add the corresponding potential + if (env%ensemble_method .EQ. 2) then + mtd%kpush = newmetadfac + mtd%alpha = newmetadexp + mtd%cvdump_fs = real(env%mddump) + mtd%mtdtype = cv_rmsd + allocate (mtd%atinclude(mol%nat),source=.true.) + mtd%atinclude(1:clus%nat) = .false. !> only include solvent + call mddat%add(mtd) + end if - if (env%cts%cbonds_md) call write_cts_CBONDS(ich,env%cts) + !> set output file and run + mddat%trajectoryfile = 'xtb.trj.xyz' + call dynamics(mol,mddat,calc,.true.,io) - close (ich) + if (io .ne. 0) then + write (stdout,*) 'WARNING: MD run terminated ABNORMALLY' + call creststop(status_failed) + end if -!--- Writing jobcall - write (jobcall,'(a,1x,a,1x,a,'' --md --input xcontrol '',a,1x,a,a)') & - & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),pipe -!--- slightly different jobcall for QMDFF usage - if (env%useqmdff) then - write (jobcall,'(a,1x,a,1x,a,'' --md --input xcontrol --qmdff'',a,1x,a,a)') & - & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),pipe - end if + call rename(mddat%trajectoryfile,'crest_rotamers_0.xyz') -!--- MD - if (env%ensemble_method .EQ. 1) then - call normalMD(fname,env,1,newtemp,newmdtime) - write (stdout,*) 'Starting MD with the settings:' - write (stdout,'('' MD time /ps :'',f8.1)') newmdtime - write (stdout,'('' MD Temperature /K :'',f8.1)') newtemp - write (stdout,'('' dt /fs :'',f8.1)') newmdstep - write (tmppath,'(a,i0)') 'NORMMD1' - - r = makedir(tmppath) - call copysub('xcontrol',tmppath) - call chdirdbug(tmppath) - call copy('coord','ref.coord') - call chdirdbug(tmppath2) +!> -------------------------------------------------------------------- +!> xtb-syscall version +!> -------------------------------------------------------------------- + else - call command('cd '//trim(tmppath)//' && '//trim(jobcall),io) + !--- Writing constraining file xcontrol + !--- Providing xcontrol overwrites constraints in coord file - inquire (file=trim(tmppath)//'/'//'xtb.trj',exist=ex) - if (.not.ex.or.io .ne. 0) then - write (stdout,'(a,i0,a)') '*Warning: MD seemingly failed (no xtb.trj)*' - else - write (stdout,*) '*MD finished*' + open (newunit=ich,file='xcontrol') + if (env%cts%NCI) then + do i = 1,10 + if (trim(env%cts%pots(i)) .ne. '') then + write (ich,'(a)') trim(env%cts%pots(i)) + end if + end do end if - if (env%trackorigin) then - call set_trj_origins('NORMMD','md') + if (.not.env%solv_md) then + write (ich,'(a)') '$constrain' + write (ich,'(2x,a,i0)') 'atoms: 1-',solu%nat + write (ich,'(2x,a)') 'force constant=0.5' + write (ich,'(2x,a,a)') 'reference=ref.coord' end if - call chdirdbug('NORMMD1') - end if -!--- MTD - - if (env%ensemble_method .EQ. 2) then - call MetaMD(env,1,newmdtime,env%metadfac(1),env%metadexp(1), & - & env%metadlist(1)) - write (stdout,'(a,i4,a)') 'Starting Meta-MD with the settings:' - write (stdout,'('' MTD time /ps :'',f8.1)') newmdtime - write (stdout,'('' dt /fs :'',f8.1)') newmdstep - write (stdout,'('' MTD Temperature /K :'',f8.1)') newtemp - write (stdout,'('' dumpstep(trj) /fs :'',i8)') env%mddumpxyz - write (stdout,'('' Vbias factor k /Eh :'',f8.4)') newmetadfac - write (stdout,'('' Vbias exp α /bohr⁻²:'',f8.2)') newmetadexp - - write (tmppath,'(a,i0)') 'METADYN1' - r = makedir(tmppath) - call copysub('xcontrol',tmppath) - call chdirdbug(tmppath) - call copy('coord','ref.coord') + write (ich,'(a)') '$md' + write (ich,'(2x,a,f10.2)') 'hmass=',newhmass + write (ich,'(2x,a,f10.2)') 'time=',newmdtime + write (ich,'(2x,a,f10.2)') 'temp=',newtemp + write (ich,'(2x,a,f10.2)') 'step=',newmdstep + write (ich,'(2x,a,i0)') 'shake=',env%shake + write (ich,'(2x,a,i0)') 'dump=',env%mddumpxyz + write (ich,'(2x,a)') 'dumpxyz=500.0' + + if (env%ensemble_method .EQ. 2) then + write (ich,'(a)') '$metadyn' + write (ich,'(2x,a,i0,a,i0)') 'atoms: ',solu%nat+1,'-',clus%nat + write (ich,'(2x,a,f10.2)') 'save=',newmetadlist + write (ich,'(2x,a,f10.2)') 'kpush=',newmetadfac + write (ich,'(2x,a,f10.2)') 'alp=',newmetadexp + end if - call chdirdbug(tmppath2) + if (env%cts%cbonds_md) call write_cts_CBONDS(ich,env%cts) - call command('cd '//trim(tmppath)//' && '//trim(jobcall),io) + close (ich) - inquire (file=trim(tmppath)//'/'//'xtb.trj',exist=ex) - if (.not.ex.or.io .ne. 0) then - write (stdout,'(a,i0,a)') '*Warning: Meta-MTD seemingly failed (no xtb.trj)*' - else - write (stdout,*) '*MTD finished*' +!--- Writing jobcall + write (jobcall,'(a,1x,a,1x,a,'' --md --input xcontrol '',a,1x,a,a)') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),pipe +!--- slightly different jobcall for QMDFF usage + if (env%useqmdff) then + write (jobcall,'(a,1x,a,1x,a,'' --md --input xcontrol --qmdff'',a,1x,a,a)') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),pipe end if +!--- MD + if (env%ensemble_method .EQ. 1) then + call normalMD(fname,env,1,newtemp,newmdtime) + write (stdout,*) 'Starting MD with the settings:' + write (stdout,'('' MD time /ps :'',f8.1)') newmdtime + write (stdout,'('' MD Temperature /K :'',f8.1)') newtemp + write (stdout,'('' dt /fs :'',f8.1)') newmdstep + write (tmppath,'(a,i0)') 'NORMMD1' + + r = makedir(tmppath) + call copysub('xcontrol',tmppath) + call chdirdbug(tmppath) + call copy('coord','ref.coord') + call chdirdbug(tmppath2) + + call command('cd '//trim(tmppath)//' && '//trim(jobcall),io) + + inquire (file=trim(tmppath)//'/'//'xtb.trj',exist=ex) + if (.not.ex.or.io .ne. 0) then + write (stdout,'(a,i0,a)') '*Warning: MD seemingly failed (no xtb.trj)*' + else + write (stdout,*) '*MD finished*' + end if - if (env%trackorigin) then - call set_trj_origins('METADYN','mtd') + if (env%trackorigin) then + call set_trj_origins('NORMMD','md') + end if + call chdirdbug('NORMMD1') end if - call chdirdbug('METADYN1') +!--- MTD - end if + if (env%ensemble_method .EQ. 2) then + call MetaMD(env,1,newmdtime,env%metadfac(1),env%metadexp(1), & + & env%metadlist(1)) + write (stdout,'(a,i4,a)') 'Starting Meta-MD with the settings:' + write (stdout,'('' MTD time /ps :'',f8.1)') newmdtime + write (stdout,'('' dt /fs :'',f8.1)') newmdstep + write (stdout,'('' MTD Temperature /K :'',f8.1)') newtemp + write (stdout,'('' dumpstep(trj) /fs :'',i8)') env%mddumpxyz + write (stdout,'('' Vbias factor k /Eh :'',f8.4)') newmetadfac + write (stdout,'('' Vbias exp α /bohr⁻²:'',f8.2)') newmetadexp + + write (tmppath,'(a,i0)') 'METADYN1' + r = makedir(tmppath) + call copysub('xcontrol',tmppath) + call chdirdbug(tmppath) + call copy('coord','ref.coord') + + call chdirdbug(tmppath2) + + call command('cd '//trim(tmppath)//' && '//trim(jobcall),io) + + inquire (file=trim(tmppath)//'/'//'xtb.trj',exist=ex) + if (.not.ex.or.io .ne. 0) then + write (stdout,'(a,i0,a)') '*Warning: Meta-MTD seemingly failed (no xtb.trj)*' + else + write (stdout,*) '*MTD finished*' + end if + + if (env%trackorigin) then + call set_trj_origins('METADYN','mtd') + end if - call rename('xtb.trj','crest_rotamers_0.xyz') - call copysub('crest_rotamers_0.xyz',tmppath2) - call dum%open('crest_rotamers_0.xyz') + call chdirdbug('METADYN1') + + end if + + call rename('xtb.trj','crest_rotamers_0.xyz') + call copysub('crest_rotamers_0.xyz',tmppath2) + call dum%open('crest_rotamers_0.xyz') !--- M(T)D stability check - call minigrep('xtb.out','M(T)D is unstable, emergency exit',mdfail) - if (dum%nall .eq. 1) then - call copysub('xtb.out',resultspath) - write (stdout,*) 'ERROR : M(T)D results only in one structure' + call minigrep('xtb.out','M(T)D is unstable, emergency exit',mdfail) + if (dum%nall .eq. 1) then + call copysub('xtb.out',resultspath) + write (stdout,*) 'ERROR : M(T)D results only in one structure' + if (mdfail) then + write (stdout,*) ' It was unstable' + else + write (stdout,*) ' The M(T)D time step might be too large or the M(T)D time too short.' + end if + call copysub('xtb.out',resultspath) + error stop ' Please check the xtb.out file in the ensemble folder' + end if if (mdfail) then - write (stdout,*) ' It was unstable' - else - write (stdout,*) ' The M(T)D time step might be too large or the M(T)D time too short.' + write (stdout,*) + write (stdout,*) ' WARNING: The M(T)D was unstable.' + write (stdout,*) ' Please check the xtb.out file in the ensemble folder.' + write (stdout,*) + call copysub('xtb.out',resultspath) end if - call copysub('xtb.out',resultspath) - error stop ' Please check the xtb.out file in the ensemble folder' - end if - if (mdfail) then - write (stdout,*) - write (stdout,*) ' WARNING: The M(T)D was unstable.' - write (stdout,*) ' Please check the xtb.out file in the ensemble folder.' - write (stdout,*) - call copysub('xtb.out',resultspath) - end if - call dum%deallocate - call chdirdbug(tmppath2) - call clus%write('coord') - call inputcoords(env,'coord') !Necessary + call dum%deallocate + call chdirdbug(tmppath2) + call clus%write('coord') + call inputcoords(env,'coord') !Necessary !--- Optimization - call print_qcg_opt - !if (env%gfnver .eq. '--gfn2') - call multilevel_opt(env,99) + call print_qcg_opt + call multilevel_opt(env,99) + end if end subroutine xtb_md_ensemble_qcg From 2a42481658d651c1b0ea42dcdf6a6b6c64ee8315 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 15 Dec 2025 14:07:53 +0100 Subject: [PATCH 110/374] Add meson build options --- src/basinhopping/meson.build | 23 +++++------------------ src/meson.build | 1 + src/optimize/meson.build | 2 ++ src/qcg/meson.build | 9 ++++++--- 4 files changed, 14 insertions(+), 21 deletions(-) diff --git a/src/basinhopping/meson.build b/src/basinhopping/meson.build index f312602f..0b83855d 100644 --- a/src/basinhopping/meson.build +++ b/src/basinhopping/meson.build @@ -1,23 +1,10 @@ # This file is part of crest. # SPDX-Identifier: LGPL-3.0-or-later -# -# crest is free software: you can redistribute it and/or modify it under -# the terms of the GNU Lesser General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. -# -# crest is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public License -# along with crest. If not, see . srcs += files( - 'algo.90', - 'basinhopping.f90', - 'class.f90', - 'mc.f90', - 'takestep.f90', +'algo.f90', +'basinhopping.f90', +'class.f90', +'mc.f90', +'takestep.f90', ) diff --git a/src/meson.build b/src/meson.build index c55eb919..c758a99e 100644 --- a/src/meson.build +++ b/src/meson.build @@ -28,6 +28,7 @@ subdir('entropy') subdir('legacy_algos') subdir('msreact') subdir('sorting') +subdir('basinhopping') srcs += files( 'atmasses.f90', diff --git a/src/optimize/meson.build b/src/optimize/meson.build index ad786316..1a4241a5 100644 --- a/src/optimize/meson.build +++ b/src/optimize/meson.build @@ -18,6 +18,8 @@ srcs += files( 'ancopt.f90', 'gd.f90', 'rfo.f90', + 'lbfgs.f90', + 'coordtrafo.f90', 'hessupdate.f90', 'modelhessian.f90', 'optimize_maths.f90', diff --git a/src/qcg/meson.build b/src/qcg/meson.build index 4e6cacbc..52c3cecf 100644 --- a/src/qcg/meson.build +++ b/src/qcg/meson.build @@ -15,7 +15,10 @@ # along with crest. If not, see . srcs += files( - 'solvtool.f90', - 'solvtool_misc.f90', - 'volume.f90', +'qcg_coord_type.f90', +'qcg_main.f90', +'qcg_misc.f90', +'qcg_printouts.f90', +'qcg_utils.f90', +'volume.f90', ) From 171e96562ca979def4d3d45ffed0822449fbf386 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 15 Dec 2025 14:20:06 +0100 Subject: [PATCH 111/374] .gitignore update --- .gitignore | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.gitignore b/.gitignore index 631e65ab..cfeeb127 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ *.mod *.tgz *.i90 +*.bak *__genmod.f90 github_bin/ build_majestix @@ -10,3 +11,5 @@ _build* _dist* src/crest bin/ +subprojects/.wraplock +subprojects/test-drive.wrap From 45b50fd1e99e7ac08a77a97a864fa8dbe4eb5420 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 15 Dec 2025 14:36:04 +0100 Subject: [PATCH 112/374] add logic to run on GH workflow --- .github/workflows/build-CI.yml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/.github/workflows/build-CI.yml b/.github/workflows/build-CI.yml index b40f62b0..f86fd599 100644 --- a/.github/workflows/build-CI.yml +++ b/.github/workflows/build-CI.yml @@ -2,7 +2,14 @@ name: CI on: push: + branches: + - master + - '*-maintenance' pull_request: + branches: + - master + - '*-maintenance' + workflow_dispatch: env: BUILD_DIR: _build From 3dac9a5403f5527dd3e6daa02803090fdf5ad693 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 15 Dec 2025 23:02:28 +0100 Subject: [PATCH 113/374] MD qol improvements and basic tests for testsuite --- src/dynamics/dynamics_module.f90 | 180 ++++++++++++++------------- test/CMakeLists.txt | 1 + test/main.f90 | 4 +- test/test_molecular_dynamics.F90 | 204 +++++++++++++++++++++++++++++++ 4 files changed, 304 insertions(+), 85 deletions(-) create mode 100644 test/test_molecular_dynamics.F90 diff --git a/src/dynamics/dynamics_module.f90 b/src/dynamics/dynamics_module.f90 index d825d640..1669ccc2 100644 --- a/src/dynamics/dynamics_module.f90 +++ b/src/dynamics/dynamics_module.f90 @@ -60,6 +60,7 @@ module dynamics_module integer :: simtype = type_md !> type of the molecular dynamics simulation logical :: restart = .false. character(len=:),allocatable :: restartfile + logical :: wrtrj = .true. character(len=:),allocatable :: trajectoryfile !>--- data real(wp) :: length_ps = 0.0_wp !20.0_wp !> total simulation length in ps @@ -118,7 +119,7 @@ subroutine dynamics(mol,dat,calc,pr,term) !************************************************************* !* subroutine dynamics !* perform a molecular dynamics simulation -!* the coordinate propagation is made with an +!* the coordinate propagation is made with an !* Leap-Frog algorithm (Velert-type algo) !************************************************************* implicit none @@ -142,17 +143,17 @@ subroutine dynamics(mol,dat,calc,pr,term) real(wp),allocatable :: veln(:,:) real(wp),allocatable :: acc(:,:) real(wp),allocatable :: mass(:) - real(wp),allocatable :: xyz_angstrom(:,:) real(wp),allocatable :: backupweights(:) type(coord) :: molo real(wp) :: f,rt,rtshift real(wp) :: molmass,tmass + real(wp),allocatable :: cn(:) character(len=:),allocatable :: trajectory integer :: trj character(len=256) :: commentline integer :: i,j,k,l,ich,och,io integer :: dcount,printcount - logical :: ex,fail,bdump + logical :: ex,fail,bdump,shakefallback call initsignal() @@ -162,15 +163,22 @@ subroutine dynamics(mol,dat,calc,pr,term) term = 0 tstep_au = dat%tstep*fstoau nfreedom = 3*mol%nat - if(calc%nfreeze > 0)then - nfreedom = nfreedom - 3*calc%nfreeze - endif + shakefallback = .false. + if (calc%nfreeze > 0) then + nfreedom = nfreedom-3*calc%nfreeze + end if if (dat%shake) then - if(calc%nfreeze > 0)then + if (calc%nfreeze > 0) then dat%shk%freezeptr => calc%freezelist else - nullify(dat%shk%freezeptr) - endif + nullify (dat%shk%freezeptr) + end if + if (.not.allocated(dat%shk%wbo)) then + !> fake bondorder fallback for shake + shakefallback = .true. + call mol%cn_to_bond(cn,dat%shk%wbo) + deallocate (cn) + end if call init_shake(mol%nat,mol%at,mol%xyz,dat%shk,pr) dat%nshake = dat%shk%ncons nfreedom = nfreedom-dat%nshake @@ -183,12 +191,11 @@ subroutine dynamics(mol,dat,calc,pr,term) temp = 0.0_wp !>--- on-the-fly multiscale definition - if(allocated(dat%active_potentials))then + if (allocated(dat%active_potentials)) then call calc%active(dat%active_potentials) - endif + end if !>--- allocate data fields - allocate (xyz_angstrom(3,mol%nat)) allocate (molo%at(mol%nat),molo%xyz(3,mol%nat)) allocate (grd(3,mol%nat),vel(3,mol%nat),velo(3,mol%nat),source=0.0_wp) allocate (veln(3,mol%nat),acc(3,mol%nat),mass(mol%nat),source=0.0_wp) @@ -207,12 +214,15 @@ subroutine dynamics(mol,dat,calc,pr,term) write (stdout,'(" block length (av.)",t25,":",i10 )') dat%blockl write (stdout,'(" dumpstep(trj) /fs",t25, ":",f10.2,1x,"(",i0,")")') dat%dumpstep,dat%sdump write (stdout,'(" # deg. of freedom",t25, ":",i10 )') nfreedom - if(calc%nfreeze > 0)then - write (stdout,'(" # frozen atoms",t25, ":",i10 )') calc%nfreeze - endif + if (calc%nfreeze > 0) then + write (stdout,'(" # frozen atoms",t25, ":",i10 )') calc%nfreeze + end if call thermostatprint(dat,pr) write (stdout,'(" SHAKE constraint",t25, ":",9x,l)') dat%shake if (dat%shake) then + if (shakefallback) then + write (stdout,'(" SHAKE using CN fallback",t25,":",9x,l)') shakefallback + end if if (dat%shk%shake_mode == 2) then write (stdout,'(" # SHAKE bonds",t25,":",i10,a)') dat%nshake,' (all bonds)' elseif (dat%shk%shake_mode == 1) then @@ -220,9 +230,9 @@ subroutine dynamics(mol,dat,calc,pr,term) end if end if write (stdout,'(" hydrogen mass /u",t25,":",f10.5 )') dat%md_hmass - if(allocated(dat%active_potentials))then - write (stdout,'(" active potentials",t25,":",i10)') size(dat%active_potentials,1) - endif + if (allocated(dat%active_potentials)) then + write (stdout,'(" active potentials",t25,":",i10)') size(dat%active_potentials,1) + end if end if !>--- set atom masses @@ -249,28 +259,28 @@ subroutine dynamics(mol,dat,calc,pr,term) end if edum = f*dat%tsoll*0.5_wp*kB*float(nfreedom) rtshift = 0.0_wp - if(.not.dat%restart .or. .not.allocated(dat%restartfile))then - call mdinitu(mol,dat,velo,mass,edum,pr) + if (.not.dat%restart.or..not.allocated(dat%restartfile)) then + call mdinitu(mol,dat,velo,mass,edum,pr) else - call rdmdrestart(mol,dat,velo,fail,rtshift) - if(fail)then + call rdmdrestart(mol,dat,velo,fail,rtshift,pr) + if (fail) then call mdinitu(mol,dat,velo,mass,edum,pr) - else - call ekinet(mol%nat,velo,mass,ekin) - temp = 2.0_wp*ekin/float(nfreedom)/kB - tav = temp - endif - endif + else + call ekinet(mol%nat,velo,mass,ekin) + temp = 2.0_wp*ekin/float(nfreedom)/kB + tav = temp + end if + end if call ekinet(mol%nat,velo,mass,ekin) - if(calc%nfreeze > 0)then - do i = 1,mol%nat - if(calc%freezelist(i))then - acc(:,i) = 0.0_wp - grd(:,i) = 0.0_wp - velo(:,i) = 0.0_wp - endif - end do - endif + if (calc%nfreeze > 0) then + do i = 1,mol%nat + if (calc%freezelist(i)) then + acc(:,i) = 0.0_wp + grd(:,i) = 0.0_wp + velo(:,i) = 0.0_wp + end if + end do + end if !>--- initialize MTDs (if required) !$omp critical @@ -287,7 +297,7 @@ subroutine dynamics(mol,dat,calc,pr,term) trajectory = trim(commentline) end if !$omp critical - open (newunit=trj,file=trajectory) + if (dat%wrtrj) open (newunit=trj,file=trajectory) !$omp end critical !>--- begin printout @@ -315,6 +325,7 @@ subroutine dynamics(mol,dat,calc,pr,term) epot = 0.0_wp grd = 0.0_wp call engrad(mol,calc,epot,grd,io) + mol%energy = epot if (io /= 0) then if (dat%dumped > 0) then @@ -340,12 +351,12 @@ subroutine dynamics(mol,dat,calc,pr,term) !>--- block data printouts call u_block(mol,dat,epot,temp,pr,bdump) !>--- MD restart files written for each block rather than at each timestep to reduce I/O - if(bdump)then - rt = float(t)*dat%tstep + rtshift + if (bdump) then + rt = float(t)*dat%tstep+rtshift !$omp critical - call wrmdrestart(mol,dat,velo,rt) + call wrmdrestart(mol,dat,velo,rt) !$omp end critical - endif + end if !===========================================! !>>-- write to trajectory and printout @@ -353,15 +364,13 @@ subroutine dynamics(mol,dat,calc,pr,term) dcount = 0 dat%dumped = dat%dumped+1 !$omp critical - xyz_angstrom = mol%xyz*bohr - write (commentline,'(a,f22.12,1x,a)') 'energy =',epot,'' - call wrxyz(trj,mol%nat,mol%at,xyz_angstrom,commentline) + if (dat%wrtrj) call mol%append(trj) !$omp end critical end if if ((printcount == dat%printstep).or.(t == 1)) then if (t > 1) printcount = 0 if (pr) then - rt = float(t)*dat%tstep + rtshift + rt = float(t)*dat%tstep+rtshift if (.not.dat%thermostat) then write (stdout,'(i7,f10.2,F16.5,F12.4,2F8.1,F16.5,4F10.4)') & & t,0.001_wp*rt, (Epav+Epot)/float(t), & @@ -381,14 +390,14 @@ subroutine dynamics(mol,dat,calc,pr,term) end do !>--- special setup for frozen atoms - if(calc%nfreeze > 0)then - do i = 1,mol%nat - if(calc%freezelist(i))then - acc(:,i) = 0.0_wp - grd(:,i) = 0.0_wp - endif - end do - endif + if (calc%nfreeze > 0) then + do i = 1,mol%nat + if (calc%freezelist(i)) then + acc(:,i) = 0.0_wp + grd(:,i) = 0.0_wp + end if + end do + end if !>--- store positions (at t); velocities are at t-1/2dt !$omp critical @@ -410,20 +419,22 @@ subroutine dynamics(mol,dat,calc,pr,term) !>>-- STEP 3: velocity and position update !>--- update velocities to t - vel = thermoscal*(velo + acc*tstep_au) - - !>--- update positions to t+dt, except for frozen atoms - if(calc%nfreeze > 0)then - do i = 1,mol%nat - if(.not.calc%freezelist(i))then - mol%xyz(:,i) = molo%xyz(:,i)+vel(:,i)*tstep_au - else - vel(:,i) = 0.0_wp - endif - end do - else - mol%xyz = molo%xyz+vel*tstep_au - endif + vel = thermoscal*(velo+acc*tstep_au) + + !>--- update positions to t+dt, except for frozen atoms, and not at the final step + if (t < dat%length_steps) then + if (calc%nfreeze > 0) then + do i = 1,mol%nat + if (.not.calc%freezelist(i)) then + mol%xyz(:,i) = molo%xyz(:,i)+vel(:,i)*tstep_au + else + vel(:,i) = 0.0_wp + end if + end do + else + mol%xyz = molo%xyz+vel*tstep_au + end if + end if !>--- estimate new velocities at t veln = 0.5_wp*(velo+vel) @@ -466,7 +477,7 @@ subroutine dynamics(mol,dat,calc,pr,term) !===============================================================! !>--- close trajectory file !$omp critical - close (trj) + if (dat%wrtrj) close (trj) !$omp end critical !>--- averages printout @@ -481,7 +492,7 @@ subroutine dynamics(mol,dat,calc,pr,term) end if !>--- write restart file - rt = float(dat%length_steps)*dat%tstep + rtshift + rt = float(dat%length_steps)*dat%tstep+rtshift call wrmdrestart(mol,dat,velo,rt) !>--- termination printout @@ -501,12 +512,11 @@ subroutine dynamics(mol,dat,calc,pr,term) deallocate (mass,acc,veln) deallocate (vel,velo,grd) deallocate (molo%xyz,molo%at) - deallocate (xyz_angstrom) !>--- restore weights if necessary - if(allocated(dat%active_potentials))then + if (allocated(dat%active_potentials)) then call calc%active_restore() - endif + end if return end subroutine dynamics @@ -669,8 +679,8 @@ subroutine wrmdrestart(mol,dat,velo,realtime_fs) integer :: i,j,k,l,ich,och,io logical :: ex character(len=256) :: atmp - if (.not.allocated(dat%restartfile) .or. dat%restart) then - !>--- we must not overwrite the user-provided restart file! + if (.not.allocated(dat%restartfile).or.dat%restart) then + !>--- we must not overwrite the user-provided restart file! write (atmp,'(a,i0,a)') 'crest_',dat%md_index,'.mdrestart' else atmp = dat%restartfile @@ -684,13 +694,14 @@ subroutine wrmdrestart(mol,dat,velo,realtime_fs) return end subroutine wrmdrestart - subroutine rdmdrestart(mol,dat,velo,fail,rtshift) + subroutine rdmdrestart(mol,dat,velo,fail,rtshift,pr) implicit none type(coord) :: mol type(mddata) :: dat real(wp),intent(inout) :: velo(3,mol%nat) logical,intent(out) :: fail real(wp),intent(out) :: rtshift + logical,intent(in) :: pr real(wp) :: dum character(len=256) :: atmp integer :: i,j,k,l,ich,och,io @@ -706,7 +717,7 @@ subroutine rdmdrestart(mol,dat,velo,fail,rtshift) do read (ich,*,iostat=io) dum if (io < 0) exit - if(dum > 0.0_wp) rtshift = dum + if (dum > 0.0_wp) rtshift = dum do i = 1,mol%nat read (ich,'(a)',iostat=io) atmp if (io < 0) exit @@ -723,9 +734,10 @@ subroutine rdmdrestart(mol,dat,velo,fail,rtshift) else fail = .true. end if - if(.not.fail)then - write (stdout,'(1x,a,8x,l)') 'read restart file :',.not.fail - endif + if (.not.fail.and.pr) then + write (stdout,'(" read RESTART file",t25,":",9x,l)').not.fail + write (stdout,'(" restart file",t25,":",1x,a)') dat%restartfile + end if return end subroutine rdmdrestart @@ -803,8 +815,8 @@ subroutine thermostating(mol,dat,t,scal) case ('berendsen') scal = dsqrt(1.0d0+(dat%tstep/dat%thermo_damp) & & *(dat%tsoll/t-1.0_wp)) - case default - !>-- (no scaling, other thermostats require special implementation) + case default + !>-- (no scaling, other thermostats require special implementation) scal = 1.0_wp end select @@ -1202,9 +1214,9 @@ subroutine md_defaults_fallback(self) end if !> block length (for average analysis and restart dump) - if(self%blockl <= 0 )then + if (self%blockl <= 0) then self%blockl = min(5000,idint(5000.0_wp/self%tstep)) - endif + end if self%maxblock = nint(self%length_steps/float(self%blockl)) end subroutine md_defaults_fallback diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index f1e0acc6..f3e418e3 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -7,6 +7,7 @@ set( "gfn0occ" "CN" "optimization" + "molecular_dynamics" ) set( test-srcs diff --git a/test/main.f90 b/test/main.f90 index 900cf20a..84ae3418 100644 --- a/test/main.f90 +++ b/test/main.f90 @@ -9,6 +9,7 @@ program tester use test_gfn0occ, only: collect_gfn0occ use test_cn, only: collect_cn use test_optimization, only: collect_optimization + use test_molecular_dynamics, only: collect_mol_dynamics implicit none integer :: stat, is character(len=:), allocatable :: suite_name, test_name @@ -30,7 +31,8 @@ program tester new_testsuite("gfn0", collect_gfn0), & new_testsuite("gfn0occ", collect_gfn0occ), & new_testsuite("CN",collect_CN), & - new_testsuite("optimization", collect_optimization) & + new_testsuite("optimization", collect_optimization), & + new_testsuite("molecular_dynamics", collect_mol_dynamics) & ] !&> diff --git a/test/test_molecular_dynamics.F90 b/test/test_molecular_dynamics.F90 new file mode 100644 index 00000000..00d0f284 --- /dev/null +++ b/test/test_molecular_dynamics.F90 @@ -0,0 +1,204 @@ +module test_molecular_dynamics + use testdrive,only:new_unittest,unittest_type,error_type,check,test_failed + use crest_parameters + use crest_calculator + use strucrd + use crest_testmol + use dynamics_module + use iomod,only:remove + implicit none + private + + public :: collect_mol_dynamics + + real(wp),parameter :: thr = 5e+6_wp*epsilon(1.0_wp) + +!========================================================================================! +!========================================================================================! +contains !> Unit tests for using molecular dynamics routines in CREST +!========================================================================================! +!========================================================================================! + +!> Collect all exported unit tests + subroutine collect_mol_dynamics(testsuite) + !> Collection of tests + type(unittest_type),allocatable,intent(out) :: testsuite(:) + +!&< + testsuite = [ & +#ifdef WITH_GFNFF + new_unittest("Compiled gfnff subproject ",test_compiled_gfnff), & + new_unittest("molecular dynamics (SHAKE off)",test_md_shake_off), & + new_unittest("molecular dynamics (SHAKE on) ",test_md_shake_on), & + new_unittest("molecular dynamics (SHAKE H) ",test_md_shake_honly) & +#else + new_unittest("Compiled gfnff subproject",test_compiled_gfnff,should_fail=.true.) & +#endif + ] +!&> + + end subroutine collect_mol_dynamics + +!========================================================================================! + + subroutine test_compiled_gfnff(error) + type(error_type),allocatable,intent(out) :: error +#ifndef WITH_GFNFF + write (*,'(" ...")') 'gfnff not compiled, expecting fail.' + allocate (error) +#endif + end subroutine test_compiled_gfnff + +!========================================================================================! +! The three MD tests below intentionally only set up the shared infrastructure (calcdata +! and a test molecule) and provide placeholders for the MD-specific calls/checks. +! Fill the marked sections with your MD driver + assertions. +!========================================================================================! + + subroutine test_md_shake_off(error) + type(error_type),allocatable,intent(out) :: error + type(calcdata) :: calc + type(calculation_settings) :: sett + type(coord) :: mol + type(mddata) :: mdyn + integer :: io + logical :: pr + + real(wp),parameter :: e_ref = -0.6272508_wp + + !> setup calculator backend + call sett%create('gfnff') + call calc%add(sett) + + !> test molecule + call get_testmol('methane',mol) + + !> MD setup + pr = .false. + io = 0 + call mdyn%defaults() + mdyn%shake = .false. + mdyn%restart = .true. !> turn on restart reading (for determinic results) + mdyn%wrtrj = .false. !> turn off trajectory dump + call write_fake_restart(mol,mdyn%restartfile) + + !> run + call dynamics(mol,mdyn,calc,pr,io) + + !> cleanup + call remove(mdyn%restartfile) + call remove('crest_0.mdrestart') + + !> checks + call check(error,io,0) + if (allocated(error)) return + call check(error,mol%energy,e_ref,thr=1e-6_wp) + if (allocated(error)) return + end subroutine test_md_shake_off + +!========================================================================================! + + subroutine test_md_shake_on(error) + type(error_type),allocatable,intent(out) :: error + type(calcdata) :: calc + type(calculation_settings) :: sett + type(coord) :: mol + type(mddata) :: mdyn + integer :: io + logical :: wr,pr + + real(wp),parameter :: e_ref = -0.57741556160488028_wp + + !> setup calculator backend + call sett%create('gfnff') + call calc%add(sett) + + !> get test molecule + call get_testmol('methane',mol) + + !> MD setup + pr = .false. + io = 0 + call mdyn%defaults() + mdyn%shake = .true. + mdyn%restart = .true. !> turn on restart reading (for determinic results) + mdyn%wrtrj = .false. !> turn off trajectory dump + call write_fake_restart(mol,mdyn%restartfile) + + !> run + call dynamics(mol,mdyn,calc,pr,io) + + !> cleanup + call remove(mdyn%restartfile) + call remove('crest_0.mdrestart') + + !> checks + call check(error,io,0) + if (allocated(error)) return + call check(error,mol%energy,e_ref,thr=1e-6_wp) + if (allocated(error)) return + end subroutine test_md_shake_on + +!========================================================================================! + + subroutine test_md_shake_honly(error) + type(error_type),allocatable,intent(out) :: error + type(calcdata) :: calc + type(calculation_settings) :: sett + type(coord) :: mol + + type(mddata) :: mdyn + integer :: io + logical :: wr,pr + + real(wp),parameter :: e_ref = -4.6456536819174667_wp + + !> setup calculator backend + call sett%create('gfnff') + call calc%add(sett) + + !> get test molecule + call get_testmol('caffeine',mol) + + !> MD setup + pr = .false. + io = 0 + mdyn%length_ps=5.0_wp !> shorter runtime because the mol is larger + call mdyn%defaults() + mdyn%shake = .true. + mdyn%shk%shake_mode=1 + mdyn%restart = .true. !> turn on restart reading (for determinic results)_wp !> shorter runtime because the mol is larger + mdyn%wrtrj = .false. !> turn off trajectory dump + call write_fake_restart(mol,mdyn%restartfile) + + !> run + call dynamics(mol,mdyn,calc,pr,io) + + !> cleanup + call remove(mdyn%restartfile) + call remove('crest_0.mdrestart') + + !> checks + call check(error,io,0) + if (allocated(error)) return + call check(error,mol%energy,e_ref,thr=1e-6_wp) + if (allocated(error)) return + end subroutine test_md_shake_honly + + subroutine write_fake_restart(mol,restartfile) + implicit none + type(coord),intent(in) :: mol + character(len=:),allocatable,intent(out) :: restartfile + integer :: ich,ii + restartfile = 'crest_test.mdrestart' + open (newunit=ich,file=restartfile) + write (ich,*) 500.0_wp + do ii = 1,mol%nat + write (ich,'(6D22.14)') mol%xyz(1:3,ii),mol%xyz(1:3,ii)*0.0001_wp + end do + close (ich) + end subroutine write_fake_restart + +!========================================================================================! +!========================================================================================! +end module test_molecular_dynamics From 9eea101748b975ed90d505639d2c09e83c4e8510 Mon Sep 17 00:00:00 2001 From: Lukas Rindt Date: Wed, 17 Dec 2025 13:48:46 +0100 Subject: [PATCH 114/374] debugging --- src/calculator/calc_type.f90 | 1 + src/calculator/hessian_reconstruct.f90 | 16 +- src/optimize/ancopt.f90 | 26 ++- src/optimize/hessupdate.f90 | 1 + src/optimize/optimize_maths.f90 | 244 +++++++++++++++++++++++++ src/optimize/optimize_module.f90 | 22 ++- src/optimize/rfo.f90 | 72 ++++++-- src/parsing/parse_calcdata.f90 | 3 + 8 files changed, 357 insertions(+), 28 deletions(-) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 822418b2..4a4ac077 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -280,6 +280,7 @@ module calc_type real(wp) :: L = 1.50_wp real(wp) :: k = 5000.0_wp real(wp) :: shift = 0.0006_wp + real(wp) :: scaling = 0.1_wp !>--- Type procedures contains diff --git a/src/calculator/hessian_reconstruct.f90 b/src/calculator/hessian_reconstruct.f90 index eaf07524..40e83231 100644 --- a/src/calculator/hessian_reconstruct.f90 +++ b/src/calculator/hessian_reconstruct.f90 @@ -94,6 +94,7 @@ subroutine construct_hessian_bfgs(self) integer :: i,j,k,nat3 real(wp),allocatable :: tmp(:),tmp_coords(:,:),tmp_grads(:,:),hess(:),dx(:) real(wp) :: gnorm + integer :: unit nat3 = 3*self%natm @@ -108,6 +109,11 @@ subroutine construct_hessian_bfgs(self) tmp_coords = reshape(self%coords, [self%steps,nat3]) tmp_grads = reshape(self%gradient, [self%steps,nat3]) + do k = 1,nat3 + self%hguess_mat(k,k) = self%hguess + end do + call dsqtoh(nat3,self%hguess_mat,hess) + if (minval(tmp) == 0) then print*,"ERROR: Number of recursive steps for hessian reconstruction larger than number of geoemtry optimization steps!" else @@ -115,10 +121,6 @@ subroutine construct_hessian_bfgs(self) if (i == 1) then j = minloc(tmp,1) tmp(j) = HUGE(tmp(j)) - do k = 1,nat3 - self%hguess_mat(k,k) = self%hguess - end do - call dsqtoh(nat3,self%hguess_mat,hess) else j = minloc(tmp,1) if (j == 1) then @@ -130,6 +132,12 @@ subroutine construct_hessian_bfgs(self) end if tmp(j) = HUGE(tmp(j)) end if + open(newunit=unit, file="reconstruct_bfgs.txt", status="unknown", position="append") + write(unit,*) "cycle:", i + do k = 1, 5 + write(unit,*) hess(k) + enddo + close(unit) end do end if diff --git a/src/optimize/ancopt.f90 b/src/optimize/ancopt.f90 index 040e075e..66af8308 100644 --- a/src/optimize/ancopt.f90 +++ b/src/optimize/ancopt.f90 @@ -351,11 +351,13 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & real(sp),allocatable :: Uaug(:,:) real(sp),allocatable :: Aaug(:) real(sp),parameter :: r4dum = 1.e-8 + real(wp), allocatable :: test_hess(:,:) !> LAPACK & BLAS external :: dgemv real(sp),external :: sdot integer :: q,r,s,nat3 !> ONLY for testing! nat3 = 3*mol%nat + allocate(test_hess(nat3,nat3)) iostatus = 0 @@ -469,11 +471,13 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & if (gnorm .lt. 0.0006) then alp = 2.0d0 ! 2 end if - if (gnorm .lt. 0.0003 .and. calc%optlev .le. 1) then + if (gnorm .lt. 0.0003) then alp = 3.0d0 ! 3 end if - alp = alp_generate(gnorm, calc) + if (calc%optlev>0) then + alp = alp_generate(gnorm, calc) + endif !>------------------------------------------------------------------------ !> Update the Hessian !>------------------------------------------------------------------------ @@ -496,6 +500,12 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & end select end if + !> Transform hessian to cartesian coordinate basis (still wrong) + if (calc%do_HU) then + call dhtosq(nat3,test_hess(:,:),OPT%hess(:)) + calc%chess%H(:,:) = matmul(matmul(Transpose(OPT%B(:,:)), test_hess(:,:)), OPT%B(:,:)) + end if + !>------------------------------------------------------------------------ !> rational function (RF) method !>------------------------------------------------------------------------ @@ -638,9 +648,15 @@ function alp_generate(gnorm,calc) result(alp) real(wp), intent(in) :: gnorm real(wp) :: alp, shift, l, k - L = calc%L - k = calc%k - shift = calc%shift + if (calc%optlev == 1) then + L = 2 + k = 2000 + shift = 0.0005 + else + L = calc%L + k = calc%k + shift = calc%shift + endif alp = L/(1+euler**(k*(gnorm-shift)))+1 diff --git a/src/optimize/hessupdate.f90 b/src/optimize/hessupdate.f90 index 5d9fcefe..57b55549 100644 --- a/src/optimize/hessupdate.f90 +++ b/src/optimize/hessupdate.f90 @@ -72,6 +72,7 @@ subroutine bfgs(nat3,gnorm,grad,grado,dx,hess) real(wp) :: dgdx,idgdx,dgdgdx real(wp),parameter :: thrs = 1.d-12 real(wp),parameter :: thr = 1d-2 + integer :: unit !> BLAS: external :: dspmv real(wp),external :: ddot diff --git a/src/optimize/optimize_maths.f90 b/src/optimize/optimize_maths.f90 index 2a7a0741..3be196e3 100644 --- a/src/optimize/optimize_maths.f90 +++ b/src/optimize/optimize_maths.f90 @@ -33,7 +33,9 @@ module optimize_maths end interface public :: detrotra8 public :: solver_sdavidson + public :: solver_ddavidson public :: solver_sspevx + public :: solver_dspevx public :: solver_ssyevx public :: dsqtoh public :: dhtosq @@ -816,6 +818,217 @@ subroutine smread(n,iwo,v,irec) end subroutine smread end subroutine solver_sdavidson +!========================================================================================! + + subroutine solver_ddavidson(n,crite,Hp,C,e,fail,pr) !> This one now in double precision!! +!***************************************************************** +!* subroutine solver_sdavidson +!* +!* Davidson method to iteratively diagonalize +!* a subspace of a matrix to provide its first +!* few lowest (or highest) eigenvalues. +!* In this version it is hard-coded to the lowest eigenvalue. +!* +!* Input: +!* n - dimension of the matrix to be diagonalized +!* crite - eigenvalue convergence threshold +!* Hp - the matrix to be diagonalized in packed form +!* C - eigenvevtor(s) +!* pr - print statement +!* Output: +!* e - eigenvalues +!* fail - exit status boolean +!* +!* Note the DOUBLE PRECISION! +!***************************************************************** + implicit none + logical,intent(in) :: pr + logical,parameter :: ini = .false. + integer :: n ! dimension + integer,parameter :: nr = 1 + real(wp) :: crite ! eigenvalue convergence threshold + real(wp) :: Hp(n*(n+1)/2) ! matrix to be diagonalized + real(wp) :: C(n,nr) ! eigenvectors + real(wp) :: e(nr) ! eigenvalues + logical,intent(out) :: fail + !> Local + integer,parameter :: maxiter = 100 ! maximum # of iterations + integer :: iter,ineue(1),janf!,lun1,lun2 + integer :: iideks(maxiter),idum,j,jalt,ilauf,jneu + integer :: l1,l2,k,LWORK,LIWORK,INFO,i,ien,ialt,memlun2 + integer,allocatable :: iwork(:) + logical :: lconf + real(wp),allocatable :: lun1(:,:),lun2(:,:) + integer,parameter :: initial_dyn_array_size = 10 + real(wp) :: valn(1),uim,s,denerg + real(wp),allocatable :: adiag(:),vecf1(:),vecf2(:),w(:) + real(wp),allocatable :: Uaug(:,:),d(:),aux(:) + real(wp),allocatable :: AB(:,:),av(:),tmpav(:,:) + !> LAPACK & BLAS + external :: dspmv + real(wp),external :: ddot + external :: dsyevd + external :: daxpy + + fail = .true. + + if (pr) then + write (*,'(/,10x,''******************************************'')') + write (*,'(10x,''* multi-root davidson (R4) *'')') + write (*,'(10x,''******************************************'',/)') + write (*,*) 'dim ',n,' # roots ',1 + end if + + allocate (adiag(n),vecf1(n),vecf2(n),w(n),av(maxiter*(maxiter+1)/2)) + + allocate (lun1(n,initial_dyn_array_size),lun2(n,initial_dyn_array_size), & + & source=0.0_wp) + + !> H * C for initialization + call dmwrite(n,lun1,C(:,1),1) + call dspmv('u',n,1.0_wp,Hp,C(:,1),1,0.0_wp,vecf2,1) + call dmwrite(n,lun2,vecf2,1) + + !> make array iideks + iideks(1) = 1 + do idum = 2,maxiter + iideks(idum) = iideks(idum-1)+idum + end do + valn = 0 + lconf = .false. + e = 0 + do i = 1,n + adiag(i) = HP(i*(i+1)/2) + end do + av(1) = ddot(n,C(:,1),1,vecf2,1) + +!>-------------------------------- +!> Davidson algo loop +!>-------------------------------- + j = 1 + DAVIDSON: do iter = 1,maxiter-1 + lwork = 1+6*j+2*j**2 + liwork = 8*j + allocate (Uaug(j,j),d(j),iwork(liwork),aux(lwork)) + k = 0 + do l1 = 1,j + do l2 = 1,l1 + k = k+1 + Uaug(l2,l1) = av(k) + Uaug(l1,l2) = av(k) + end do + end do + call dsyevd('V','U',j,Uaug,j,d,aux,LWORK,IWORK,LIWORK,INFO) + valn(1:1) = d(1:1) + + !> create and save vectors on vecf1 + vecf1 = 0.0_wp + do i = 1,j + call dmread(n,lun1,w,i) + uim = Uaug(i,1) + call daxpy(n,uim,w,1,vecf1,1) + end do + + !> calculate E*bi + vecf2 = -valn(1)*vecf1 + !> calculate h*bi-e*bi (overwrites vecf2) + do i = 1,j + call dmread(n,lun2,w,i) + memlun2 = i + uim = Uaug(i,1) + call daxpy(n,uim,w,1,vecf2,1) + end do + deallocate (aux,iwork,d,Uaug) + C(1:n,1) = vecf1 + + !> calculate (h*bi - e*bi)/(e - haa); (saved as vecf2) + vecf1 = vecf2/(valn(1)-adiag) + + !> check for convergence of Davidson algo + denerg = abs(valn(1)-e(1)) + lconf = denerg .lt. crite + if (pr) write (*,*) iter,lconf,denerg,valn(1:1) + if (lconf) then + if (pr) write (*,*) 'all roots converged' + fail = .false. + exit DAVIDSON + end if + + if (j .gt. 0) then + ialt = j + !> orthogonalize + do jalt = 1,ialt + call dmread(n,lun1,w,jalt) + s = -ddot(n,w,1,vecf1,1) + call daxpy(n,s,w,1,vecf1,1) + end do + !> normalize remaining + s = ddot(n,vecf1,1,vecf1,1) + if (s .gt. 0.00000001) then + s = 1.0_wp/sqrt(s) + vecf1 = vecf1*s + ialt = ialt+1 + call dmwrite(n,lun1,vecf1,jalt) + else + fail = .false. + exit DAVIDSON + end if + end if + + !> H * C + call dspmv('u',n,1.0_wp,Hp,vecf1,1,0.0_wp,vecf2,1) + call dmwrite(n,lun2,vecf2,memlun2+1) + + !> calculate matrix elements for next iteration + do jalt = 1,j + call dmread(n,lun1,w,jalt) + ilauf = iideks(j)+jalt + av(ilauf) = ddot(n,w,1,vecf2,1) + ilauf = ilauf+1+j + end do + av(iideks(j+1)) = ddot(n,vecf2,1,vecf1,1) + !> increase expansion space and iterate further + e = valn + j = j+1 + end do DAVIDSON +!>-------------------------------- +!> end algo loop +!>-------------------------------- + if (pr.and.fail) write (*,*) 'Warning: davidson not properly converged' + + deallocate (adiag,vecf1,vecf2,w,av,lun1,lun2) + return + contains + !> write array v onto iwo + subroutine dmwrite(n,iwo,v,irec) + implicit none + real(wp),intent(inout),allocatable :: iwo(:,:) + real(wp),intent(in) :: v(n) + integer,intent(in) :: n,irec + real(wp),allocatable :: tmp(:,:) + integer :: d2,dn + d2 = size(iwo,2) + if (irec > d2) then + dn = d2+d2/2+1 + allocate (tmp(n,dn)) + tmp(:,:d2) = iwo + deallocate (iwo) + call move_alloc(tmp,iwo) + end if + iwo(:,irec) = v + return + end subroutine dmwrite + !> read array v from iwo + subroutine dmread(n,iwo,v,irec) + implicit none + real(wp),intent(out) :: v(n) + real(wp),intent(in) :: iwo(:,:) + integer,intent(in) :: n,irec + v = iwo(:,irec) + return + end subroutine dmread + end subroutine solver_ddavidson + !========================================================================================! subroutine solver_ssyevx(n,thr,A,U,e,fail) @@ -883,6 +1096,37 @@ subroutine solver_sspevx(n,thr,A,U,e,fail) deallocate (iwork,work,ifail) end subroutine solver_sspevx + subroutine solver_dspevx(n,thr,A,U,e,fail) +!********************************************************* +!* subroutine solver_dspevx +!* wrapper for LAPACK's dspevx routine: +!* DSPEVX computes all eigenvalues and eigenvectors of a +!* real symmetric matrix A in packed storage using a +!* divide and conquer algorithm. +!********************************************************* + implicit none + integer,intent(in) :: n + real(wp),intent(in) :: thr + real(wp),intent(inout) :: A(:) + real(wp),intent(inout) :: U(:,:) + real(wp),intent(inout) :: e(:) + logical,intent(out) :: fail + integer :: i,j,k + integer :: info + real(wp),allocatable :: work(:) + integer,allocatable :: iwork(:) + integer,allocatable :: ifail(:) + real(wp) :: dum + !> LAPACK + external :: dspevx + fail = .false. + allocate (iwork(5*n),work(8*n),ifail(n)) + j = 1 + call dspevx('V','I','U',n,A,dum,dum,j,j,thr,i,e,U,n,work,iwork,ifail,info) + if (info .ne. 0) fail = .true. + deallocate (iwork,work,ifail) + end subroutine solver_dspevx + subroutine dsqtoh(n,a,b) !**************************************************** !* converts upper triangle of a matrix into a vector diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index e0bbb6f8..a1e24d2a 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -34,6 +34,7 @@ module optimize_module use optimize_utils use thermochem_module use hessian_reconstruct + use hessian_tools implicit none private @@ -58,7 +59,9 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) integer,intent(out) :: iostatus real(wp),intent(inout) :: etot real(wp),intent(inout) :: grd(3,mol%nat) - real(wp),allocatable :: H_inv(:,:) + real(wp),allocatable :: H_inv(:,:), freq(:) + integer :: nat3 + integer :: io iostatus = -1 !> do NOT overwrite original geometry @@ -67,6 +70,7 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) molnew%xyz = mol%xyz molnew%nat = mol%nat !$omp end critical + nat3 = 3*mol%nat !> Check for optimization-individual calculation setup if (calc%optnewinit) then @@ -126,9 +130,19 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) print*,"THERMO FROM BFGS" print* - call calc_thermo_from_hess(molnew,calc%chess%H,pr, & - & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & - & calc%ht,calc%gt,calc%stot) + !call calc_thermo_from_hess(molnew,calc%chess%H,pr, & + !& calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & + !& calc%ht,calc%gt,calc%stot) + + call mass_weight_hess(molnew%nat,molnew%at,nat3,calc%chess%H(:,:)) + + allocate(freq(nat3)) + + call frequencies(molnew%nat,molnew%at,molnew%xyz,nat3,calc%chess%H(:,:),freq,io) + + call calcthermo(molnew%nat,molnew%at,mol%xyz,freq,pr,calc%ithr,calc%fscal,calc%sthr, & + & calc%nt,calc%temperatures, & + & calc%et,calc%ht,calc%gt,calc%stot) !write(stdout,*) "et:", calc%et !write(stdout,*) "ht:", calc%ht diff --git a/src/optimize/rfo.f90 b/src/optimize/rfo.f90 index 748cbd5d..9a8854ff 100644 --- a/src/optimize/rfo.f90 +++ b/src/optimize/rfo.f90 @@ -107,20 +107,22 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) real(wp),allocatable :: gold(:) real(wp),allocatable :: displ(:) integer :: nvar1,npvar,npvar1 - real(sp),allocatable :: eaug(:) - real(sp),allocatable :: Uaug(:,:) - real(sp),allocatable :: Aaug(:) + real(wp),allocatable :: eaug(:) + real(wp),allocatable :: Uaug(:,:) + real(wp),allocatable :: Aaug(:) type(convergence_log),allocatable :: avconv real(wp) :: U(3,3),x_center(3),y_center(3),rmsdval integer :: modef logical :: ex,converged,linear,exact logical :: econverged,gconverged,lowered real(wp) :: estart,esave - real(sp),parameter :: r4dum = 1.e-8 + real(wp),parameter :: r4dum = 1.e-8 + integer :: unit + real(wp), allocatable :: dx_test(:) !> LAPACK & BLAS external :: dgemv real(wp),external :: ddot - real(sp),external :: sdot + !real(sp),external :: sdot real(wp),allocatable :: test_hess(:) !> only for testing integer :: q,r,s !>only for testing @@ -141,7 +143,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) echng = 0.0_wp alp = 1.0_wp alpold = 1.0_wp - exact = calc%exact_rf + exact = calc%exact_rf .or. tight>0 !> initial number of steps in relax() routine before !> new ANC are made by model Hessian @@ -316,6 +318,10 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) alp = 3.0d-1 ! 3 end if + !if (calc%optlev>0) then + alp = alp_generate(gnorm, calc) + !endif + !>------------------------------------------------------------------------ !> Update the Hessian !>------------------------------------------------------------------------ @@ -338,10 +344,20 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) end select end if + !allocate(dx_test(size(displ))) + dx_test = displ*alpold + !allocate(calc%chess%H(nat3,nat3)) if (calc%do_HU) then call dhtosq(nat3,calc%chess%H(:,:),OPT%hess(:)) end if + + open(newunit=unit, file="opt_bfgs.txt", status="unknown", position="append") + write(unit,*) "cycle:", iter + do i = 1, 5 + write(unit,*) OPT%hess(i) + enddo + close(unit) !>------------------------------------------------------------------------ !> rational function (RF) method !>------------------------------------------------------------------------ @@ -353,24 +369,24 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !> Aaug Uaug Uaug !>--- first, augment Hessian by gradient, everything packed, no blowup - Aaug(1:npvar) = real(OPT%hess(1:npvar),sp) - Aaug(npvar+1:npvar1-1) = real(grd1(1:OPT%nvar),sp) - Aaug(npvar1) = 0.0_sp + Aaug(1:npvar) = OPT%hess(1:npvar) + Aaug(npvar+1:npvar1-1) = grd1(1:OPT%nvar) + Aaug(npvar1) = 0.0_wp !>--- choose solver for the RF eigenvalue problem if (exact.or.nvar1 .lt. 50) then - call solver_sspevx(nvar1,r4dum,Aaug,Uaug,eaug,fail) + call solver_dspevx(nvar1,r4dum,Aaug,Uaug,eaug,fail) else !>--- steepest decent guess for displacement if (iter .eq. 1) then - Uaug(:,1) = [-real(grd1(1:OPT%nvar),sp),1.0_sp] - dsnrm = sqrt(sdot(nvar1,Uaug,1,Uaug,1)) - Uaug = Uaug/real(dsnrm,sp) + Uaug(:,1) = [-grd1(1:OPT%nvar),1.0_wp] + dsnrm = sqrt(ddot(nvar1,Uaug,1,Uaug,1)) + Uaug = Uaug/dsnrm end if - call solver_sdavidson(nvar1,r4dum,Aaug,Uaug,eaug,fail,.false.) + call solver_ddavidson(nvar1,r4dum,Aaug,Uaug,eaug,fail,.false.) !>--- if that failed, retry with better solver if (fail) then - call solver_sspevx(nvar1,r4dum,Aaug,Uaug,eaug,fail) + call solver_dspevx(nvar1,r4dum,Aaug,Uaug,eaug,fail) end if end if @@ -488,6 +504,32 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) return end subroutine rfopt + function alp_generate(gnorm,calc) result(alp) + type(calcdata),intent(in) :: calc + real(wp), intent(in) :: gnorm + real(wp) :: alp, shift, l, k, scaling + + if (calc%optlev == 1) then + L = 2.0_wp + k = 2000.0_wp + shift = 0.0005_wp + scaling = 0.12_wp + else if (calc%optlev == 2) then + L = 1.0_wp + k = 8000.0_wp + shift = 0.0009_wp + scaling = 0.12_wp + else + L = calc%L + k = calc%k + shift = calc%shift + scaling = calc%scaling + endif + + alp = scaling*(L/(1+euler**(k*(gnorm-shift)))+1) + + end function alp_generate + !========================================================================================! !========================================================================================! end module rfo_module diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 9ca9943f..53a6f843 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -519,6 +519,9 @@ subroutine parse_calc_auto(env,calc,kv,rd) case('opt_shift') calc%shift = kv%value_f + case('scaling') + calc%scaling = kv%value_f + !>--- integers case ('maxcycle') calc%maxcycle = kv%value_i !> optimization max cycles From 6fd3baf908fdf12ef984d3df14eac313ec9dc6ea Mon Sep 17 00:00:00 2001 From: "lukas.rindt" Date: Wed, 17 Dec 2025 14:47:07 +0100 Subject: [PATCH 115/374] attempting debugging --- .github/workflows/build-CI.yml | 223 ++ .github/workflows/build-upload.yml | 267 ++ .github/workflows/build.yml | 321 --- .gitignore | 3 + CMakeLists.txt | 2 +- README.md | 2 +- meson.build | 2 +- src/CMakeLists.txt | 14 +- src/algos/CMakeLists.txt | 1 + src/algos/dynamics.f90 | 2 +- src/algos/meson.build | 1 + src/algos/numhess.f90 | 161 +- src/algos/optimization.f90 | 2 +- src/algos/parallel.f90 | 21 +- src/algos/playground.f90 | 39 +- src/algos/protonate.f90 | 12 +- src/algos/refine.f90 | 22 +- src/algos/scan.f90 | 2 +- src/algos/search_1.f90 | 4 +- src/algos/search_conformers.f90 | 10 +- src/algos/search_entropy.f90 | 8 +- src/algos/search_mecp.f90 | 4 +- src/algos/search_newnci.f90 | 4 +- src/algos/setuptest.f90 | 12 +- src/algos/sorting.f90 | 219 ++ src/axis_module.f90 | 176 +- src/basinhopping/CMakeLists.txt | 35 + src/basinhopping/algo.f90 | 272 ++ src/basinhopping/basinhopping.f90 | 47 + src/basinhopping/class.f90 | 199 ++ src/basinhopping/mc.f90 | 403 +++ src/basinhopping/meson.build | 10 + src/basinhopping/takestep.f90 | 98 + src/calculator/CMakeLists.txt | 1 + src/calculator/api_engrad.f90 | 48 +- src/calculator/api_helpers.F90 | 4 +- src/calculator/calc_type.f90 | 73 +- src/calculator/rmsdpot.f90 | 75 + src/calculator/tblite_api.F90 | 235 +- src/choose_settings.f90 | 152 +- src/classes.f90 | 193 +- src/confparse.f90 | 188 +- src/crest_main.f90 | 41 +- src/crest_pars.f90 | 37 +- src/dynamics/dynamics_module.f90 | 74 +- src/dynamics/metadynamics_module.f90 | 37 +- src/entropy/thermocalc.f90 | 9 +- src/entropy/thermochem_module.f90 | 94 +- src/eval_timer.f90 | 5 +- src/filemod.f90 | 4 - src/iomod.F90 | 117 +- src/legacy_algos/confscript2_misc.f90 | 2 +- src/legacy_wrappers.f90 | 64 +- src/mempeak.c | 48 + src/meson.build | 14 +- src/minitools.f90 | 218 +- src/miscdata.f90 | 24 + src/optimize/CMakeLists.txt | 2 + src/optimize/ancopt.f90 | 4 +- src/optimize/coordtrafo.f90 | 232 ++ src/optimize/gd.f90 | 4 +- src/optimize/lbfgs.f90 | 311 +++ src/optimize/meson.build | 2 + src/optimize/optimize_maths.f90 | 4 +- src/optimize/optimize_module.f90 | 51 +- src/optimize/optimize_type.f90 | 684 ++--- src/optimize/optutils.f90 | 5 +- src/optimize/rfo.f90 | 4 +- src/parsing/confparse2.f90 | 10 +- src/parsing/constraining.f90 | 18 +- src/parsing/parse_calcdata.f90 | 163 +- src/parsing/parse_inputfile.F90 | 61 +- src/parsing/parse_maindata.f90 | 44 +- src/parsing/parse_xtbinput.f90 | 350 ++- src/printouts.f90 | 226 +- src/qcg/CMakeLists.txt | 7 +- src/qcg/meson.build | 9 +- src/qcg/qcg_coord_type.f90 | 91 + src/qcg/qcg_main.f90 | 2178 ++++++++++++++++ src/qcg/qcg_misc.f90 | 1615 ++++++++++++ src/qcg/qcg_printouts.f90 | 298 +++ src/qcg/qcg_utils.f90 | 774 ++++++ src/qcg/solvtool.f90 | 3389 ------------------------- src/qcg/solvtool_misc.f90 | 1063 -------- src/qcg/volume.f90 | 1077 ++++---- src/quicksort.f90 | 291 --- src/restartlog.f90 | 1 + src/sorting/CMakeLists.txt | 41 + src/{ => sorting}/canonical.f90 | 166 +- src/{ => sorting}/ccegen.f90 | 0 src/{ => sorting}/cregen.f90 | 458 +++- src/{ => sorting}/ensemblecomp.f90 | 0 src/sorting/hungarian.f90 | 592 +++++ src/sorting/irmsd_module.f90 | 987 +++++++ src/{ => sorting}/ls_rmsd.f90 | 7 +- src/sorting/meson.build | 31 + src/sorting/quicksort.f90 | 367 +++ src/{ => sorting}/rotcompare.f90 | 0 src/{ => sorting}/sortens.f90 | 0 src/sorting/unionize.f90 | 178 ++ src/{ => sorting}/zdata.f90 | 16 - src/{ => sorting}/ztopology.f90 | 0 src/strucreader.f90 | 186 +- src/utilmod.f90 | 188 +- subprojects/tblite | 2 +- 105 files changed, 13470 insertions(+), 7072 deletions(-) create mode 100644 .github/workflows/build-CI.yml create mode 100644 .github/workflows/build-upload.yml delete mode 100644 .github/workflows/build.yml create mode 100644 src/algos/sorting.f90 create mode 100644 src/basinhopping/CMakeLists.txt create mode 100644 src/basinhopping/algo.f90 create mode 100644 src/basinhopping/basinhopping.f90 create mode 100644 src/basinhopping/class.f90 create mode 100644 src/basinhopping/mc.f90 create mode 100644 src/basinhopping/meson.build create mode 100644 src/basinhopping/takestep.f90 create mode 100644 src/calculator/rmsdpot.f90 create mode 100644 src/mempeak.c create mode 100644 src/optimize/coordtrafo.f90 create mode 100644 src/optimize/lbfgs.f90 create mode 100644 src/qcg/qcg_coord_type.f90 create mode 100644 src/qcg/qcg_main.f90 create mode 100644 src/qcg/qcg_misc.f90 create mode 100644 src/qcg/qcg_printouts.f90 create mode 100644 src/qcg/qcg_utils.f90 delete mode 100644 src/qcg/solvtool.f90 delete mode 100644 src/qcg/solvtool_misc.f90 delete mode 100644 src/quicksort.f90 create mode 100644 src/sorting/CMakeLists.txt rename src/{ => sorting}/canonical.f90 (84%) rename src/{ => sorting}/ccegen.f90 (100%) rename src/{ => sorting}/cregen.f90 (85%) rename src/{ => sorting}/ensemblecomp.f90 (100%) create mode 100644 src/sorting/hungarian.f90 create mode 100644 src/sorting/irmsd_module.f90 rename src/{ => sorting}/ls_rmsd.f90 (99%) create mode 100644 src/sorting/meson.build create mode 100644 src/sorting/quicksort.f90 rename src/{ => sorting}/rotcompare.f90 (100%) rename src/{ => sorting}/sortens.f90 (100%) create mode 100644 src/sorting/unionize.f90 rename src/{ => sorting}/zdata.f90 (97%) rename src/{ => sorting}/ztopology.f90 (100%) diff --git a/.github/workflows/build-CI.yml b/.github/workflows/build-CI.yml new file mode 100644 index 00000000..f86fd599 --- /dev/null +++ b/.github/workflows/build-CI.yml @@ -0,0 +1,223 @@ +name: CI + +on: + push: + branches: + - master + - '*-maintenance' + pull_request: + branches: + - master + - '*-maintenance' + workflow_dispatch: + +env: + BUILD_DIR: _build + PIP_PACKAGES: >- + meson!=1.8.0 + cmake + ninja + PIP_EXTRAS: >- + pkgconfig + numpy + ase + matplotlib + LINUX_INTEL_COMPONENTS: >- + intel-oneapi-compiler-fortran-2023.1.0 + intel-oneapi-compiler-dpcpp-cpp-and-cpp-classic-2023.1.0 + intel-oneapi-mkl-2023.1.0 + intel-oneapi-mkl-devel-2023.1.0 + +jobs: + build: + runs-on: ${{ matrix.os }} + + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest] + build-type: [debug] + toolchain: + - { compiler: gcc, version: '11', build: cmake } + - { compiler: gcc, version: '12', build: cmake } + - { compiler: gcc, version: '14', build: cmake } + - { compiler: intel, version: '2023.1.0', build: cmake } + + include: + # ---- Linux GCC CMake debugoptimized build ------------------------ + - { os: ubuntu-latest, build-type: debugoptimized, + toolchain: { compiler: gcc, version: '14', build: cmake } } + + # ---- Linux static builds ----------------------------------------- + - { os: ubuntu-latest, build-type: static, + toolchain: { compiler: gcc, version: '12', build: cmake } } + - { os: ubuntu-latest, build-type: static, + toolchain: { compiler: intel, version: '2023.1.0', build: meson } } + + # ---- macOS GCC CMake debug builds -------------------------------- + - { os: macos-latest, build-type: debug, + toolchain: { compiler: gcc, version: '12', build: cmake } } + - { os: macos-latest, build-type: debug, + toolchain: { compiler: gcc, version: '14', build: cmake } } + + defaults: + run: + shell: bash + + steps: + # ---------------------------------------------------------------------- + # Setup + # ---------------------------------------------------------------------- + - name: Checkout code + uses: actions/checkout@v4 + + - name: Setup Python + uses: actions/setup-python@v5 + with: + python-version: "3.9" + + # ---------------------------------------------------------------------- + # Compiler setup (GCC via setup-fortran, Intel via oneAPI on Linux) + # ---------------------------------------------------------------------- + + - name: Install GCC using setup-fortran + if: ${{ contains(matrix.toolchain.compiler, 'gcc') }} + uses: fortran-lang/setup-fortran@v1 + with: + compiler: ${{ matrix.toolchain.compiler }} # "gcc" + version: ${{ matrix.toolchain.version }} # e.g. "12" + + - name: Install libopenblas (Linux GNU builds only) + if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.toolchain.compiler, 'gcc') }} + run: | + sudo apt-get update + sudo apt-get install -y libopenblas-dev + + - name: Install OpenBLAS (macOS) + if: ${{ contains(matrix.os, 'macos') }} + run: | + brew update + brew install openblas + echo "PKG_CONFIG_PATH=/usr/local/opt/openblas/lib/pkgconfig:/opt/homebrew/opt/openblas/lib/pkgconfig" >> $GITHUB_ENV + echo "LDFLAGS=-L/usr/local/opt/openblas/lib -L/opt/homebrew/opt/openblas/lib" >> $GITHUB_ENV + echo "CPPFLAGS=-I/usr/local/opt/openblas/include -I/opt/homebrew/opt/openblas/include" >> $GITHUB_ENV + + - name: Prepare for Intel cache restore + if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.toolchain.compiler, 'intel') }} + run: | + sudo mkdir -p /opt/intel + sudo chown "$USER" /opt/intel + + - name: Cache Intel oneAPI install + if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.toolchain.compiler, 'intel') }} + id: cache-install + uses: actions/cache@v4 + with: + path: /opt/intel/oneapi + key: install-${{ matrix.toolchain.compiler }}-${{ matrix.toolchain.version }}-${{ matrix.os }} + + - name: Install Intel oneAPI (compiler + MKL) + if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.toolchain.compiler, 'intel') && steps.cache-install.outputs.cache-hit != 'true' }} + run: | + KEY=GPG-PUB-KEY-INTEL-SW-PRODUCTS-2023.PUB + wget https://apt.repos.intel.com/intel-gpg-keys/$KEY + sudo apt-key add $KEY + rm $KEY + + echo "deb https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list + sudo apt-get update + sudo apt-get install -y $PKG + env: + PKG: ${{ env.LINUX_INTEL_COMPONENTS }} + + - name: Setup Intel oneAPI environment + if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.toolchain.compiler, 'intel') }} + run: | + source /opt/intel/oneapi/setvars.sh + printenv >> $GITHUB_ENV + + - name: Set compiler environment variables + run: | + if [ "${{ matrix.toolchain.compiler }}" = "gcc" ]; then + echo "FC=gfortran" >> $GITHUB_ENV + echo "CC=gcc" >> $GITHUB_ENV + elif [ "${{ matrix.toolchain.compiler }}" = "intel" ]; then + # adjust to ifx/ifort if we want to change it in the future + echo "FC=ifort" >> $GITHUB_ENV + echo "CC=icx" >> $GITHUB_ENV + fi + echo "COMPILER_VERSION=${{ matrix.toolchain.version }}" >> $GITHUB_ENV + + # ---------------------------------------------------------------------- + # Dependencies & submodules + # ---------------------------------------------------------------------- + + - name: Git submodules checkout + run: git submodule update --init + + - name: Install build and test dependencies + run: | + pip3 install ${{ env.PIP_PACKAGES }} ${{ env.PIP_EXTRAS }} + + # ---------------------------------------------------------------------- + # Configure + # ---------------------------------------------------------------------- + + - name: Configure build (Meson) + if: ${{ matrix.toolchain.build == 'meson' }} + run: > + meson setup ${{ env.BUILD_DIR }} + --buildtype=debugoptimized + --prefix=$PWD/_dist + --libdir=lib + --warnlevel=0 + + - name: Configure build (CMake, debug) + if: ${{ matrix.toolchain.build == 'cmake' && matrix.build-type == 'debug' }} + run: > + cmake -B${{ env.BUILD_DIR }} + -GNinja + -DCMAKE_BUILD_TYPE=Debug + -DCMAKE_INSTALL_PREFIX=$PWD/_dist + -DCMAKE_INSTALL_LIBDIR=lib + + - name: Configure build (CMake, debugoptimized) + if: ${{ matrix.toolchain.build == 'cmake' && matrix.build-type == 'debugoptimized' }} + run: > + cmake -B${{ env.BUILD_DIR }} + -GNinja + -DCMAKE_BUILD_TYPE=RelWithDebInfo + -DCMAKE_INSTALL_PREFIX=$PWD/_dist + -DCMAKE_INSTALL_LIBDIR=lib + + - name: Configure build (CMake, static) + if: ${{ matrix.toolchain.build == 'cmake' && matrix.build-type == 'static' }} + run: > + cmake -B${{ env.BUILD_DIR }} + -GNinja + -DCMAKE_BUILD_TYPE=RelWithDebInfo + -DCMAKE_INSTALL_PREFIX=$PWD/_dist + -DCMAKE_INSTALL_LIBDIR=lib + -DWITH_TESTS=OFF + -DSTATICBUILD=ON + + # ---------------------------------------------------------------------- + # Build / test / install + # ---------------------------------------------------------------------- + + - name: Build project + run: ninja -C ${{ env.BUILD_DIR }} + + - name: Run unit tests (ctest) + if: ${{ matrix.toolchain.build == 'cmake' && contains(matrix.toolchain.compiler, 'gcc') }} + run: | + ctest --output-on-failure --parallel 2 -R '^crest/' + working-directory: ${{ env.BUILD_DIR }} + env: + OMP_NUM_THREADS: 1,2,1 + + - name: Install project + run: | + ninja -C ${{ env.BUILD_DIR }} install + echo "CREST_PREFIX=$PWD/_dist" >> $GITHUB_ENV + diff --git a/.github/workflows/build-upload.yml b/.github/workflows/build-upload.yml new file mode 100644 index 00000000..344072d5 --- /dev/null +++ b/.github/workflows/build-upload.yml @@ -0,0 +1,267 @@ +name: Continuous release (static Linux) + +on: + push: + branches: + - master # ONLY upload on master branch + +env: + BUILD_DIR: _build + PIP_PACKAGES: >- + meson!=1.8.0 + cmake + ninja + PIP_EXTRAS: >- + pkgconfig + numpy + ase + matplotlib + LINUX_INTEL_COMPONENTS: >- + intel-oneapi-compiler-fortran-2023.1.0 + intel-oneapi-compiler-dpcpp-cpp-and-cpp-classic-2023.1.0 + intel-oneapi-mkl-2023.1.0 + intel-oneapi-mkl-devel-2023.1.0 + +jobs: + build-static: + runs-on: ${{ matrix.os }} + + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest] + build-type: [static] + toolchain: + # GNU static CMake build + - { compiler: gcc, version: '12', build: cmake } + # Intel static Meson build + - { compiler: intel, version: '2023.1.0', build: meson } + + defaults: + run: + shell: bash + + steps: + - name: Checkout code + uses: actions/checkout@v4 + + - name: Setup Python + uses: actions/setup-python@v5 + with: + python-version: "3.9" + + # --- Compiler setup ---------------------------------------------------- + + - name: Install GCC (Linux) using setup-fortran + if: ${{ contains(matrix.toolchain.compiler, 'gcc') }} + uses: fortran-lang/setup-fortran@v1 + with: + compiler: ${{ matrix.toolchain.compiler }} + version: ${{ matrix.toolchain.version }} + + - name: Install libopenblas (Linux GNU builds only) + if: ${{ contains(matrix.toolchain.compiler, 'gcc') }} + run: | + sudo apt-get update + sudo apt-get install -y libopenblas-dev + + - name: Prepare for Intel cache restore + if: ${{ contains(matrix.toolchain.compiler, 'intel') }} + run: | + sudo mkdir -p /opt/intel + sudo chown "$USER" /opt/intel + + - name: Cache Intel oneAPI install + if: ${{ contains(matrix.toolchain.compiler, 'intel') }} + id: cache-install + uses: actions/cache@v4 + with: + path: /opt/intel/oneapi + key: install-${{ matrix.toolchain.compiler }}-${{ matrix.toolchain.version }}-${{ matrix.os }} + + - name: Install Intel oneAPI (compiler + MKL) + if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.toolchain.compiler, 'intel') && steps.cache-install.outputs.cache-hit != 'true' }} + run: | + KEY=GPG-PUB-KEY-INTEL-SW-PRODUCTS-2023.PUB + wget https://apt.repos.intel.com/intel-gpg-keys/$KEY + sudo apt-key add $KEY + rm $KEY + + echo "deb https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list + sudo apt-get update + sudo apt-get install -y $PKG + env: + PKG: ${{ env.LINUX_INTEL_COMPONENTS }} + + - name: Setup Intel oneAPI environment + if: ${{ contains(matrix.toolchain.compiler, 'intel') }} + run: | + source /opt/intel/oneapi/setvars.sh + printenv >> $GITHUB_ENV + + - name: Set compiler environment variables + run: | + if [ "${{ matrix.toolchain.compiler }}" = "gcc" ]; then + echo "FC=gfortran" >> $GITHUB_ENV + echo "CC=gcc" >> $GITHUB_ENV + elif [ "${{ matrix.toolchain.compiler }}" = "intel" ]; then + echo "FC=ifort" >> $GITHUB_ENV + echo "CC=icx" >> $GITHUB_ENV + fi + echo "COMPILER_VERSION=${{ matrix.toolchain.version }}" >> $GITHUB_ENV + + # --- Dependencies & submodules --------------------------------------- + + - name: Git submodules checkout + run: git submodule update --init + + - name: Install build dependencies + run: | + pip3 install ${{ env.PIP_PACKAGES }} ${{ env.PIP_EXTRAS }} + + # --- Configure -------------------------------------------------------- + + - name: Configure build (Meson, static-ish) + if: ${{ matrix.toolchain.build == 'meson' }} + run: > + meson setup ${{ env.BUILD_DIR }} + --buildtype=debugoptimized + --prefix=$PWD/_dist + --libdir=lib + --warnlevel=0 + + - name: Configure build (CMake, static) + if: ${{ matrix.toolchain.build == 'cmake' && matrix.build-type == 'static' }} + run: > + cmake -B${{ env.BUILD_DIR }} + -GNinja + -DCMAKE_BUILD_TYPE=RelWithDebInfo + -DCMAKE_INSTALL_PREFIX=$PWD/_dist + -DCMAKE_INSTALL_LIBDIR=lib + -DWITH_TESTS=OFF + -DSTATICBUILD=ON + + # --- Build / (optional) test / install -------------------------------- + + - name: Build project + run: ninja -C ${{ env.BUILD_DIR }} + + - name: Install project + run: | + ninja -C ${{ env.BUILD_DIR }} install + echo "CREST_PREFIX=$PWD/_dist" >> $GITHUB_ENV + + - name: Create package + run: | + mkdir crest + cp COPYING crest/LICENSE + cp COPYING.LESSER crest/LICENSE.LESSER + cp _dist/bin/crest crest/ + COMPILER_NAME="${{ matrix.toolchain.compiler }}" + # Map GCC → gnu for backwards-compatible file names + if [ "$COMPILER_NAME" = "gcc" ]; then + COMPILER_NAME="gnu" + fi + OUTPUT="crest-${COMPILER_NAME}-${{ matrix.toolchain.version }}-${{ matrix.os }}.tar" + tar cvf "$OUTPUT" crest + xz -T0 "$OUTPUT" + echo "CREST_OUTPUT=${OUTPUT}.xz" >> $GITHUB_ENV + + + - name: Upload package + uses: actions/upload-artifact@v4 + with: + name: ${{ env.CREST_OUTPUT }} + path: ${{ env.CREST_OUTPUT }} + + continuous-delivery: + if: github.event_name == 'push' + runs-on: ubuntu-latest + needs: + - build-static + + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + RELEASE_TAG: latest + + steps: + - name: Checkout + uses: actions/checkout@v4 + + - name: Install github-release + run: | + go install github.com/github-release/github-release@latest + echo "GOPATH=$(go env GOPATH)" >> $GITHUB_ENV + echo "$(go env GOPATH)/bin" >> $GITHUB_PATH + + - name: Set GitHub user/repo + run: | + echo "GITHUB_USER=$( echo ${{ github.repository }} | cut -d/ -f1 )" >> $GITHUB_ENV + echo "GITHUB_REPO=$( echo ${{ github.repository }} | cut -d/ -f2 )" >> $GITHUB_ENV + + - name: Move/Create continuous tag + run: | + git tag --force ${{ env.RELEASE_TAG }} ${{ github.sha }} + git push --tags --force + + - name: Get Time + run: echo "TIME=$(date -u '+%Y/%m/%d, %H:%M')" >> $GITHUB_ENV + + - name: Check continuous release status + run: | + if ! github-release info -t ${{ env.RELEASE_TAG }} > /dev/null 2>&1; then + echo "RELEASE_COMMAND=release" >> $GITHUB_ENV + else + echo "RELEASE_COMMAND=edit" >> $GITHUB_ENV + fi + + - name: Setup continuous release + run: > + github-release ${{ env.RELEASE_COMMAND }} + --tag ${{ env.RELEASE_TAG }} + --name "Continuous release version" + --description "$DESCRIPTION" + --pre-release + env: + DESCRIPTION: | + Created on ${{ env.TIME }} UTC by @${{ github.actor }} with commit ${{ github.sha }}. + This is an automated distribution of the latest CREST version. + This version is only minimally tested and may be unstable or even crash. + Use with caution! + https://github.com/${{ github.repository }}/actions/runs/${{ github.run_id }} + + - name: Download artifacts + uses: actions/download-artifact@v4 + with: + path: artifacts + merge-multiple: true + + - name: Create SHA256 checksums + run: | + cd artifacts + for f in crest-*.tar.xz; do + sha256sum "$f" > "$f.sha256.txt" + done + + - name: Upload CREST tarballs to release + run: | + cd artifacts + for f in crest-*.tar.xz; do + github-release upload \ + --tag ${{ env.RELEASE_TAG }} \ + --replace \ + --name "$f" \ + --file "$f" + done + + - name: Upload SHA256 checksums to release + run: | + cd artifacts + for f in crest-*.tar.xz.sha256.txt; do + github-release upload \ + --tag ${{ env.RELEASE_TAG }} \ + --replace \ + --name "$f" \ + --file "$f" + done + diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml deleted file mode 100644 index a59c5dd1..00000000 --- a/.github/workflows/build.yml +++ /dev/null @@ -1,321 +0,0 @@ -name: CI - -on: [push, pull_request] - -env: - BUILD_DIR: _build - PIP_PACKAGES: >- - meson!=1.8.0 - cmake - ninja - PIP_EXTRAS: >- - pkgconfig - numpy - ase - matplotlib - LINUX_INTEL_COMPONENTS: >- - intel-oneapi-compiler-fortran-2023.1.0 - intel-oneapi-compiler-dpcpp-cpp-and-cpp-classic-2023.1.0 - intel-oneapi-mkl-2023.1.0 - intel-oneapi-mkl-devel-2023.1.0 - -jobs: - build: - runs-on: ${{ matrix.os }} - strategy: - fail-fast: false - matrix: - os: [ubuntu-latest] - build: [cmake] - build-type: [debug] - compiler: [gnu] - version: [11,12,14] - - include: - - os: ubuntu-latest - build: cmake - build-type: debug - compiler: intel - version: 2023.1.0 - - - os: macos-latest - build: cmake - build-type: debug - compiler: gnu - version: 12 - - - os: ubuntu-latest - build: cmake - build-type: debugoptimized - compiler: gnu - version: 14 - - - os: ubuntu-latest - build: cmake - build-type: static - compiler: gnu - version: 12 - - - os: ubuntu-latest - build: meson - build-type: static - compiler: intel - version: 2023.1.0 - - defaults: - run: - shell: ${{ matrix.shell || 'bash' }} - - env: - FC: ${{ matrix.compiler == 'intel' && 'ifort' || 'gfortran' }} - CC: ${{ matrix.compiler == 'intel' && 'icx' || 'gcc' }} - GCC_V: ${{ matrix.version }} - PYTHON_V: 3.9 - - steps: - - name: Checkout code - uses: actions/checkout@v4 - - - uses: actions/setup-python@v5 - with: - python-version: ${{ env.PYTHON_V }} - - - name: Link pre-installed GCC and FC (macOS) - if: ${{ contains(matrix.os, 'macos') && matrix.compiler == 'gnu' }} - run: | - brew install openblas - gfortran_path=$( which gfortran-${{ env.GCC_V }} ) - gcc_path=$( which gcc-${{ env.GCC_V }} ) - gplusplus_path=$( which g++-${{ env.GCC_V }} ) - export FC=$gfortran_path - export CC=$gcc_path - export CXX=$gplusplus_path - ln -s $gfortran_path /usr/local/bin/gfortran - ln -s $gcc_path /usr/local/bin/gcc - ln -s $gplusplus_path /usr/local/bin/g++ - echo "PKG_CONFIG_PATH=/usr/local/opt/openblas/lib/pkgconfig" >> $GITHUB_ENV - echo "LDFLAGS=-L/opt/homebrew/opt/openblas/lib" >> $GITHUB_ENV - echo "CPPFLAGS=-I/opt/homebrew/opt/openblas/include" >> $GITHUB_ENV - - - name: Install GCC (Linux) - if: ${{ contains(matrix.os, 'ubuntu') && matrix.compiler == 'gnu' }} - run: | - sudo add-apt-repository ppa:ubuntu-toolchain-r/test - sudo apt-get update - sudo apt-get install -y gcc-${{ env.GCC_V}} gfortran-${{ env.GCC_V }} - sudo update-alternatives \ - --install /usr/bin/gcc gcc /usr/bin/gcc-${{ env.GCC_V }} 100 \ - --slave /usr/bin/gfortran gfortran /usr/bin/gfortran-${{ env.GCC_V }} \ - --slave /usr/bin/gcov gcov /usr/bin/gcov-${{ env.GCC_V }} - - - name: Install libopenblas (Linux GNU build only) - if: ${{ matrix.compiler == 'gnu' && contains(matrix.os, 'ubuntu') }} - run: sudo apt-get update && sudo apt-get install -y libopenblas-dev - - - name: Prepare for cache restore - if: ${{ matrix.compiler == 'intel' }} - run: | - sudo mkdir -p /opt/intel - sudo chown $USER /opt/intel - - - name: Cache Intel install - if: ${{ matrix.compiler == 'intel' }} - id: cache-install - uses: actions/cache@v4 - with: - path: /opt/intel/oneapi - key: install-${{ matrix.compiler }}-${{ matrix.version }}-${{ matrix.os }} - - - name: Install Intel (Linux) - if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.compiler, 'intel') && steps.cache-install.outputs.cache-hit != 'true' }} - run: | - wget https://apt.repos.intel.com/intel-gpg-keys/${{ env.KEY }} - sudo apt-key add ${{ env.KEY }} - rm ${{ env.KEY }} - echo "deb https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list - sudo apt-get update - sudo apt-get install ${{ env.PKG }} - env: - KEY: GPG-PUB-KEY-INTEL-SW-PRODUCTS-2023.PUB - PKG: ${{ env.LINUX_INTEL_COMPONENTS }} - - - name: Setup Intel oneAPI environment - if: ${{ matrix.compiler == 'intel' }} - run: | - source /opt/intel/oneapi/setvars.sh - printenv >> $GITHUB_ENV - - - name: Git Sumbodules checkout - run: | - git submodule update --init - - - name: Install build and test dependencies - if: ${{ ! contains(matrix.os, 'windows') }} - run: pip3 install ${{ env.PIP_PACKAGES }} ${{ env.PIP_EXTRAS }} - - - name: Configure build (meson) - if: ${{ matrix.build == 'meson' }} - run: >- - meson setup ${{ env.BUILD_DIR }} - --buildtype=debugoptimized - --prefix=$PWD/_dist - --libdir=lib - --warnlevel=0 - - - name: Configure build (CMake, debug) - if: ${{ matrix.build == 'cmake' && matrix.build-type == 'debug' }} - run: >- - cmake -B${{ env.BUILD_DIR }} - -GNinja - -DCMAKE_BUILD_TYPE=Debug - -DCMAKE_INSTALL_PREFIX=$PWD/_dist - -DCMAKE_INSTALL_LIBDIR=lib - - - name: Configure build (CMake, static) - if: ${{ matrix.build == 'cmake' && matrix.build-type == 'debugoptimized' }} - run: >- - cmake -B${{ env.BUILD_DIR }} - -GNinja - -DCMAKE_BUILD_TYPE=RelWithDebInfo - -DCMAKE_INSTALL_PREFIX=$PWD/_dist - -DCMAKE_INSTALL_LIBDIR=lib - - - name: Configure build (CMake, static) - if: ${{ matrix.build == 'cmake' && matrix.build-type == 'static' }} - run: >- - cmake -B${{ env.BUILD_DIR }} - -GNinja - -DCMAKE_BUILD_TYPE=RelWithDebInfo - -DCMAKE_INSTALL_PREFIX=$PWD/_dist - -DCMAKE_INSTALL_LIBDIR=lib - -DWITH_TESTS=OFF - -DSTATICBUILD=ON - - - name: Build project - run: ninja -C ${{ env.BUILD_DIR }} - - - name: Run unit tests (ctest) - if: ${{ matrix.build == 'cmake' && matrix.compiler == 'gnu' }} - run: | - ctest --output-on-failure --parallel 2 -R '^crest/' - working-directory: ${{ env.BUILD_DIR }} - env: - OMP_NUM_THREADS: 1,2,1 - - - name: Install project - run: | - ninja -C ${{ env.BUILD_DIR }} install - echo "CREST_PREFIX=$PWD/_dist" >> $GITHUB_ENV - - - name: Create package - if: ${{ matrix.build-type == 'static' }} - run: | - mkdir crest - cp COPYING crest/LICENSE - cp COPYING.LESSER crest/LICENSE.LESSER - cp _dist/bin/crest crest/ - tar cvf ${{ env.OUTPUT }} crest - xz -T0 ${{ env.OUTPUT }} - echo "CREST_OUTPUT=${{ env.OUTPUT }}.xz" >> $GITHUB_ENV - env: - OUTPUT: crest-${{ matrix.compiler }}-${{ matrix.version }}-${{ matrix.os }}.tar - - - name: Upload package - if: ${{ matrix.build-type == 'static' }} - uses: actions/upload-artifact@v4 - with: - name: ${{ env.CREST_OUTPUT }} - path: ${{ env.CREST_OUTPUT }} - - - continuous-delivery: - if: github.event_name == 'push' - runs-on: ubuntu-latest - needs: - - build - - env: - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - RELEASE_TAG: latest - - steps: - - uses: actions/checkout@v4 - - - name: Install github-release - run: | - go install github.com/github-release/github-release@latest - echo "GOPATH=$(go env GOPATH)" >> $GITHUB_ENV - echo "$(go env GOPATH)/bin" >> $GITHUB_PATH - - - name: Set environment variables - run: | - echo "GITHUB_USER=$( echo ${{ github.repository }} | cut -d/ -f1 )" >> $GITHUB_ENV - echo "GITHUB_REPO=$( echo ${{ github.repository }} | cut -d/ -f2 )" >> $GITHUB_ENV - - - name: Move/Create continuous tag - run: | - git tag --force ${{ env.RELEASE_TAG }} ${{ github.sha }} - git push --tags --force - - - name: Get Time - run: echo "TIME=$(date -u '+%Y/%m/%d, %H:%M')" >> $GITHUB_ENV - - - name: Check continuous release status - run: | - if ! github-release info -t ${{ env.RELEASE_TAG }} > /dev/null 2>&1; then - echo "RELEASE_COMMAND=release" >> $GITHUB_ENV - else - echo "RELEASE_COMMAND=edit" >> $GITHUB_ENV - fi - - - name: Setup continuous release - run: >- - github-release ${{ env.RELEASE_COMMAND }} - --tag ${{ env.RELEASE_TAG }} - --name "Continuous release version" - --description "$DESCRIPTION" - --pre-release - env: - DESCRIPTION: | - Created on ${{ env.TIME }} UTC by @${{ github.actor }} with commit ${{ github.sha }}. - This is an automated distribution of the latest CREST version. - This version is only minimally tested and may be unstable or even crash. - Use with caution! - https://github.com/${{ github.repository }}/actions/runs/${{ github.run_id }} - - - name: Download Artifacts - uses: actions/download-artifact@v4 - with: - path: ${{ github.workspace }} # This will download all files - - - name: Create SHA256 checksums - run: | - for dir in crest-*.tar.xz; do - if [ -d "$dir" ]; then - sha256sum "$dir/$dir" > "$dir.sha256.txt" - fi - done - - - name: Upload CREST tarballs to release - run: | - for dir in crest-*.tar.xz; do - if [ -d "$dir" ]; then - github-release upload \ - --tag ${{ env.RELEASE_TAG }} \ - --replace \ - --name "${dir}" \ - --file "$dir/$dir" - fi - done - - - name: Upload SHA256 checksums to release - run: | - for file in crest-*.tar.xz.sha256.txt; do - github-release upload \ - --tag ${{ env.RELEASE_TAG }} \ - --replace \ - --name "$file" \ - --file "$file" - done - - diff --git a/.gitignore b/.gitignore index 631e65ab..cfeeb127 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ *.mod *.tgz *.i90 +*.bak *__genmod.f90 github_bin/ build_majestix @@ -10,3 +11,5 @@ _build* _dist* src/crest bin/ +subprojects/.wraplock +subprojects/test-drive.wrap diff --git a/CMakeLists.txt b/CMakeLists.txt index 90ca4989..199254e7 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -27,7 +27,7 @@ endif() project( crest LANGUAGES "C" "Fortran" - VERSION 3.0.2 + VERSION 3.0.3 DESCRIPTION "A tool for the exploration of low-energy chemical space" ) diff --git a/README.md b/README.md index 83ef71d8..86b2065c 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ [![Conda Version](https://img.shields.io/conda/vn/conda-forge/crest?color=khaki)](https://anaconda.org/conda-forge/crest) [![DOI](https://img.shields.io/badge/DOI-10.1039%2Fc9cp06869d%20-blue)](http://dx.doi.org/10.1039/c9cp06869d) [![DOI](https://img.shields.io/badge/DOI-10.1063%2F5.0197592-blue)](https://doi.org/10.1063/5.0197592) -![CI workflow](https://github.com/crest-lab/crest/actions/workflows/build.yml/badge.svg) +[![CI workflow](https://github.com/crest-lab/crest/actions/workflows/build-CI.yml/badge.svg)](https://github.com/crest-lab/crest/actions/workflows/build-CI.yml) [![License: LGPL v3](https://img.shields.io/badge/license-LGPL_v3-coral.svg)](https://www.gnu.org/licenses/lgpl-3.0) [![Documentation](https://img.shields.io/badge/documentation-crest--lab.github.io%2Fcrest--docs%2F-gold)](https://crest-lab.github.io/crest-docs/) diff --git a/meson.build b/meson.build index 22a016de..bb04ea32 100644 --- a/meson.build +++ b/meson.build @@ -17,7 +17,7 @@ project( 'crest', 'fortran', 'c', - version: '3.0.2', + version: '3.0.3', license: 'LGPL-3.0-or-later', meson_version: '>=0.63', default_options: [ diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 49c591a2..2b5d882a 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -28,7 +28,8 @@ add_subdirectory("discretize") add_subdirectory("entropy") add_subdirectory("legacy_algos") add_subdirectory("msreact") - +add_subdirectory("sorting") +add_subdirectory("basinhopping") set(dir "${CMAKE_CURRENT_SOURCE_DIR}") @@ -37,17 +38,13 @@ list(APPEND srcs "${dir}/axis_module.f90" "${dir}/biasmerge.f90" "${dir}/bondconstraint.f90" - "${dir}/canonical.f90" - "${dir}/ccegen.f90" "${dir}/choose_settings.f90" "${dir}/classes.f90" "${dir}/cleanup.f90" "${dir}/cn.f90" "${dir}/compress.f90" "${dir}/confparse.f90" - "${dir}/cregen.f90" "${dir}/crest_pars.f90" - "${dir}/ensemblecomp.f90" "${dir}/eval_timer.f90" "${dir}/filemod.f90" "${dir}/flexi.F90" @@ -58,25 +55,22 @@ list(APPEND srcs "${dir}/internals2.f90" "${dir}/iomod.F90" "${dir}/legacy_wrappers.f90" - "${dir}/ls_rmsd.f90" "${dir}/marqfit.f90" "${dir}/minitools.f90" "${dir}/miscdata.f90" + "${dir}/mempeak.c" "${dir}/ncigeo.f90" "${dir}/ompmklset.F90" "${dir}/printouts.f90" "${dir}/prmat.f90" "${dir}/propcalc.f90" - "${dir}/quicksort.f90" "${dir}/readl.f90" "${dir}/restartlog.f90" - "${dir}/rotcompare.f90" "${dir}/scratch.f90" "${dir}/sdfio.f90" "${dir}/select.f90" "${dir}/signal.c" "${dir}/sigterm.f90" - "${dir}/sortens.f90" "${dir}/strucreader.f90" "${dir}/symmetry2.f90" "${dir}/symmetry_i.c" @@ -84,8 +78,6 @@ list(APPEND srcs "${dir}/trackorigin.f90" "${dir}/utilmod.f90" "${dir}/wallsetup.f90" - "${dir}/zdata.f90" - "${dir}/ztopology.f90" ) list(APPEND prog diff --git a/src/algos/CMakeLists.txt b/src/algos/CMakeLists.txt index 3df8c266..40277f7f 100644 --- a/src/algos/CMakeLists.txt +++ b/src/algos/CMakeLists.txt @@ -28,6 +28,7 @@ list(APPEND srcs "${dir}/search_1.f90" "${dir}/search_mecp.f90" "${dir}/setuptest.f90" + "${dir}/sorting.f90" "${dir}/protonate.f90" "${dir}/hessian_tools.f90" "${dir}/ConfSolv.F90" diff --git a/src/algos/dynamics.f90 b/src/algos/dynamics.f90 index ff351e92..f315e5bc 100644 --- a/src/algos/dynamics.f90 +++ b/src/algos/dynamics.f90 @@ -39,7 +39,7 @@ subroutine crest_moleculardynamics(env,tim) real(wp),allocatable :: grad(:,:) character(len=80) :: atmp - character(len=*),parameter :: trjf='crest_dynamics.trj' + character(len=*),parameter :: trjf='crest_dynamics.trj.xyz' !========================================================================================! write(stdout,*) !call system('figlet dynamics') diff --git a/src/algos/meson.build b/src/algos/meson.build index 43977333..cebe5f85 100644 --- a/src/algos/meson.build +++ b/src/algos/meson.build @@ -26,6 +26,7 @@ srcs += files( 'search_1.f90', 'search_mecp.f90', 'setuptest.f90', + 'sorting.f90', 'protonate.f90', 'hessian_tools.f90', 'ConfSolv.F90', diff --git a/src/algos/numhess.f90 b/src/algos/numhess.f90 index af706f3b..bd6063ad 100644 --- a/src/algos/numhess.f90 +++ b/src/algos/numhess.f90 @@ -76,22 +76,21 @@ subroutine crest_numhess(env,tim) !========================================================================================! !>--- start with an initial single point - write(stdout,'(a)') repeat(":",80) + write (stdout,'(a)') repeat(":",80) write (stdout,'(1x,a)') 'Initial singlepoint calculation ...' - allocate(grad0(3,mol%nat),source=0.0_wp) - allocate(energies0( calc%ncalculations ), source=0.0_wp) - - call engrad(mol,calc,energy,grad0,io) - energies0 = calc%etmp - - write(atmp,'("Energy = ",f25.15," Eh")') energy - call smallhead(trim(atmp)) - write(stdout,'(a)') repeat(":",80) - write(stdout,*) - - - deallocate(grad0) - + allocate (grad0(3,mol%nat),source=0.0_wp) + allocate (energies0(calc%ncalculations),source=0.0_wp) + + call engrad(mol,calc,energy,grad0,io) + energies0 = calc%etmp + + write (atmp,'("Energy = ",f25.15," Eh")') energy + call smallhead(trim(atmp)) + write (stdout,'(a)') repeat(":",80) + write (stdout,*) + + deallocate (grad0) + !========================================================================================! nat3 = mol%nat*3 @@ -178,7 +177,7 @@ subroutine crest_numhess(env,tim) else - write(atmp,*) i + write (atmp,*) i !>-- Prints Hessian call print_hessian(hess(:,:,i),nat3,'','numhess'//trim(adjustl(atmp))) @@ -204,7 +203,7 @@ subroutine crest_numhess(env,tim) call print_g98_fake(mol%nat,mol%at,nat3,mol%xyz,freq(:,i),hess(:,:,i), & & calc%calcs(i)%calcspace,'g98.out') - write(atmp,*) i + write (atmp,*) i call smallhead("Thermo contributions for [[calculation.level]] "//trim(adjustl(atmp))) call numhess_thermostat(env,mol,nat3,hess(:,:,i),freq(:,i),energies0(i)) @@ -250,9 +249,6 @@ subroutine crest_numhess(env,tim) end if !========================================================================================! - - - !========================================================================================! if (allocated(hess)) deallocate (hess) if (allocated(freq)) deallocate (freq) @@ -309,25 +305,25 @@ subroutine numhess_thermostat(env,mol,nat3,hess,freq,etot) !write(*,*) temps nrt = minloc(temps(:),1) !write(*,*) nrt - temps = env%thermo%temps + temps = env%thermo%temps !> calcthermo wants input in Bohr call calcthermo(mol%nat,mol%at,mol%xyz,freq,.true., & & ithr,fscal,sthr,nt,temps,et,ht,gt,stot) - !> printout + !> printoutgeometr zpve = et(nrt)-ht(nrt) - write(stdout,*) - write(stdout,'(10x,a)') repeat(':',50) - write(stdout,'(10x,"::",7x,a,f12.2,1x,a,8x,"::")') "THERMODYNAMICS at",temps(nrt),'K' - write(stdout,'(10x,a)') repeat(':',50) - write(stdout,outfmt) 'TOTAL FREE ENERGY',etot+gt(nrt),'Eh' - write(stdout,'(10x,a)') '::'//repeat('-',46)//'::' - write(stdout,outfmt) 'total energy ',etot,'Eh' - write(stdout,outfmt) 'ZPVE ',zpve,'Eh' - write(stdout,outfmt) 'G(RRHO) w/o ZPVE ',gt(nrt)-zpve,'Eh' - write(stdout,outfmt) 'G(RRHO) total ',gt(nrt),'Eh' - write(stdout,'(10x,a)') repeat(':',50) + write (stdout,*) + write (stdout,'(10x,a)') repeat(':',50) + write (stdout,'(10x,"::",7x,a,f12.2,1x,a,8x,"::")') "THERMODYNAMICS at",temps(nrt),'K' + write (stdout,'(10x,a)') repeat(':',50) + write (stdout,outfmt) 'TOTAL FREE ENERGY',etot+gt(nrt),'Eh' + write (stdout,'(10x,a)') '::'//repeat('-',46)//'::' + write (stdout,outfmt) 'total energy ',etot,'Eh' + write (stdout,outfmt) 'ZPVE ',zpve,'Eh' + write (stdout,outfmt) 'G(RRHO) w/o ZPVE ',gt(nrt)-zpve,'Eh' + write (stdout,outfmt) 'G(RRHO) total ',gt(nrt),'Eh' + write (stdout,'(10x,a)') repeat(':',50) deallocate (stot,gt,ht,et,temps) end subroutine numhess_thermostat @@ -362,41 +358,41 @@ subroutine thermo_standalone(env) & '(10x,"::",1x,a,f24.12,1x,a,1x,"::")' !> header - write(stdout,*) " _ _ " - write(stdout,*) "| |_| |__ ___ _ __ _ __ ___ ___ " - write(stdout,*) "| __| '_ \ / _ \ '__| '_ ` _ \ / _ \ " - write(stdout,*) "| |_| | | | __/ | | | | | | | (_) |" - write(stdout,*) " \__|_| |_|\___|_| |_| |_| |_|\___/ " - write(stdout,*) " " - write(stdout,*) "Molecular thermodynamics from the modified and scaled" - write(stdout,*) "rigid-rotor harmonic-oscillator approximation (msRRHO)" - write(stdout,*) "See:" - write(stdout,*) " • S.Grimme, Chem. Eur. J. 2012, 18, 9955–9964." - write(stdout,*) " • P.Pracht, S.Grimme, Chem. Sci., 2021, 12, 6551-6568." - write(stdout,*) - + write (stdout,*) " _ _ " + write (stdout,*) "| |_| |__ ___ _ __ _ __ ___ ___ " + write (stdout,*) "| __| '_ \ / _ \ '__| '_ ` _ \ / _ \ " + write (stdout,*) "| |_| | | | __/ | | | | | | | (_) |" + write (stdout,*) " \__|_| |_|\___|_| |_| |_| |_|\___/ " + write (stdout,*) " " + write (stdout,*) "Molecular thermodynamics from the modified and scaled" + write (stdout,*) "rigid-rotor harmonic-oscillator approximation (msRRHO)" + write (stdout,*) "See:" + write (stdout,*) " • S.Grimme, Chem. Eur. J. 2012, 18, 9955–9964." + write (stdout,*) " • P.Pracht, S.Grimme, Chem. Sci., 2021, 12, 6551-6568." + write (stdout,*) + !> input coords - write(stdout,'(1x,a)',advance='no') 'Reading input coords: ' - if(allocated(env%thermo%coords))then + write (stdout,'(1x,a)',advance='no') 'Reading input coords: ' + if (allocated(env%thermo%coords)) then call mol%open(env%thermo%coords) - write(stdout,'(1x,a)') trim(env%thermo%coords) + write (stdout,'(1x,a)') trim(env%thermo%coords) else call mol%open(env%inputcoords) - write(stdout,'(1x,a)') trim(env%inputcoords) - endif - nat3 = mol%nat * 3 - allocate(hess(nat3,nat3),freq(nat3), source=0.0_wp) + write (stdout,'(1x,a)') trim(env%inputcoords) + end if + nat3 = mol%nat*3 + allocate (hess(nat3,nat3),freq(nat3),source=0.0_wp) !> input frequencies or hessian - if(allocated(env%thermo%vibfile))then - write(stdout,'(1x,a,a)') 'Reading frequencies from: ',trim(env%thermo%vibfile) + if (allocated(env%thermo%vibfile)) then + write (stdout,'(1x,a,a)') 'Reading frequencies from: ',trim(env%thermo%vibfile) call rdfreq(env%thermo%vibfile,nat3,freq) else - write(stdout,'(1x,a)') 'No Hessian or vibspectrum file allocated for thermo routine!' + write (stdout,'(1x,a)') 'No Hessian or vibspectrum file allocated for thermo routine!' call creststop(status_input) - endif - write(stdout,*) - + end if + write (stdout,*) + !> energy (maybe read from comment line of xyz) etot = mol%energy !> inversion threshold @@ -415,38 +411,41 @@ subroutine thermo_standalone(env) !write(*,*) temps nrt = minloc(temps(:),1) !write(*,*) nrt - temps = env%thermo%temps + temps = env%thermo%temps +<<<<<<< HEAD !> calcthermo wants input in Bohr call calcthermo(mol%nat,mol%at,mol%xyz,freq,.true., & & ithr,fscal,sthr,nt,temps,et,ht,gt,stot) +======= + !> calcthermo wants input in Angstroem + call calcthermo(mol%nat,mol%at,mol%xyz*autoaa,freq,.true., & + & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,stdout) +>>>>>>> pprcht/3.0.3-maintenance !> printout zpve = et(nrt)-ht(nrt) - write(stdout,*) - write(stdout,'(10x,a)') repeat(':',50) - write(stdout,'(10x,"::",7x,a,f12.2,1x,a,8x,"::")') "THERMODYNAMICS at",temps(nrt),'K' - write(stdout,'(10x,a)') repeat(':',50) - write(stdout,outfmt) 'TOTAL FREE ENERGY',etot+gt(nrt),'Eh' - write(stdout,'(10x,a)') '::'//repeat('-',46)//'::' - write(stdout,outfmt) 'total energy ',etot,'Eh' - write(stdout,outfmt) 'ZPVE ',zpve,'Eh' - write(stdout,outfmt) 'G(RRHO) w/o ZPVE ',gt(nrt)-zpve,'Eh' - write(stdout,outfmt) 'G(RRHO) total ',gt(nrt),'Eh' - write(stdout,'(10x,a)') repeat(':',50) + write (stdout,*) + write (stdout,'(10x,a)') repeat(':',50) + write (stdout,'(10x,"::",7x,a,f12.2,1x,a,8x,"::")') "THERMODYNAMICS at",temps(nrt),'K' + write (stdout,'(10x,a)') repeat(':',50) + write (stdout,outfmt) 'TOTAL FREE ENERGY',etot+gt(nrt),'Eh' + write (stdout,'(10x,a)') '::'//repeat('-',46)//'::' + write (stdout,outfmt) 'total energy ',etot,'Eh' + write (stdout,outfmt) 'ZPVE ',zpve,'Eh' + write (stdout,outfmt) 'G(RRHO) w/o ZPVE ',gt(nrt)-zpve,'Eh' + write (stdout,outfmt) 'G(RRHO) total ',gt(nrt),'Eh' + write (stdout,'(10x,a)') repeat(':',50) !> for plotting temperature dependencies etc. - write(stdout,*) - write(stdout,*) 'Some output will be written to thermo.dump' - open(newunit=ich, file='thermo.dump') - do i=1,nt - write(ich,'(f12.4,4F20.10)') temps(i),gt(i)+etot,gt(i),ht(i),stot(i) - enddo - close(ich) + write (stdout,*) + write (stdout,*) 'Some output will be written to thermo.dump' + open (newunit=ich,file='thermo.dump') + do i = 1,nt + write (ich,'(f12.4,4F20.10)') temps(i),gt(i)+etot,gt(i),ht(i),stot(i) + end do + close (ich) deallocate (stot,gt,ht,et,temps) end subroutine thermo_standalone - - - diff --git a/src/algos/optimization.f90 b/src/algos/optimization.f90 index 775c0414..161804fd 100644 --- a/src/algos/optimization.f90 +++ b/src/algos/optimization.f90 @@ -69,7 +69,7 @@ subroutine crest_optimization(env,tim) !>-- geometry optimization pr = .true. !> stdout printout - wr = .true. !> write crestopt.log + wr = .true. !> write crestopt.log.xyz !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<--- printout directions and timer initialization pr = .false. !> stdout printout - wr = .false. !> write crestopt.log + wr = .false. !> write crestopt.log.xyz call profiler%init(1) call profiler%start(1) @@ -244,6 +245,7 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) !* dump - decides on whether to dump an ensemble file !* WARNING: the ensemble file will NOT be in the same order !* as the input xyz array. However, the overwritten xyz will be! +!* !* customcalc - customized (optional) calculation level data !* !* IMPORTANT: xyz should be in Bohr(!) for this routine @@ -330,7 +332,7 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) !>--- printout directions and timer initialization pr = .false. !> stdout printout - wr = .false. !> write crestopt.log + wr = .false. !> write crestopt.log.xyz if (dump) then open (newunit=ich,file=ensemblefile) open (newunit=ich2,file=ensembleelog) @@ -387,7 +389,7 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) c = c+1 if (dump) then gnorm = norm2(grads(:,:,job)) - write (atmp,'(1x,"Etot=",f16.10,1x,"g norm=",f12.8)') energy,gnorm + write (atmp,'(1x,"energy=",f16.10,1x,"g norm=",f12.8)') energy,gnorm molsnew(job)%comment = trim(atmp) call molsnew(job)%append(ich) call calc_eprint(calculations(job),energy,calculations(job)%etmp,gnorm,ich2) @@ -542,7 +544,7 @@ subroutine crest_search_multimd(env,mol,mddats,nsim) !===========================================================! !>--- decide wether to skip this call if (trackrestart(env)) then - call restart_write_dummy('crest_dynamics.trj') + call restart_write_dummy('crest_dynamics.trj.xyz') return end if @@ -643,7 +645,7 @@ subroutine collect(n,mddats) integer :: i,io,ich,ich2 character(len=:),allocatable :: atmp character(len=256) :: btmp - open (newunit=ich,file='crest_dynamics.trj') + open (newunit=ich,file='crest_dynamics.trj.xyz') do i = 1,n atmp = mddats(i)%trajectoryfile inquire (file=atmp,exist=ex) @@ -850,7 +852,7 @@ subroutine crest_search_multimd2(env,mols,mddats,nsim) !===========================================================! !>--- decide wether to skip this call if (trackrestart(env)) then - call restart_write_dummy('crest_dynamics.trj') + call restart_write_dummy('crest_dynamics.trj.xyz') return end if @@ -944,7 +946,7 @@ subroutine collect(n,mddats) integer :: i,io,ich,ich2 character(len=:),allocatable :: atmp character(len=256) :: btmp - open (newunit=ich,file='crest_dynamics.trj') + open (newunit=ich,file='crest_dynamics.trj.xyz') do i = 1,n atmp = mddats(i)%trajectoryfile inquire (file=atmp,exist=ex) @@ -1006,7 +1008,7 @@ subroutine parallel_md_block_printout(MD,vz) if (MD%shk%shake_mode == 2) then write (stdout,'(2x,"| SHAKE algorithm :",a5," (all bonds) |")') to_str(MD%shake) else - write (stdout,'(2x,"| SHAKE algorithm :",a5," (H only) |")') to_str(MD%shake) + write (stdout,'(2x,"| SHAKE algorithm :",a5," (H only) |")') to_str(MD%shake) end if end if if (allocated(MD%active_potentials)) then @@ -1024,6 +1026,9 @@ subroutine parallel_md_block_printout(MD,vz) else write (stdout,'(2x,"| Vbias exponent (α) :",f8.4," |")') MD%mtd(1)%alpha end if + if (allocated(MD%mtd(1)%atinclude))then + write (stdout,'(2x,"| # active atoms :",i9," atoms |")') count(MD%mtd(1)%atinclude,1) + endif end if !$omp end critical diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index bffbf199..533dfe63 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -30,18 +30,18 @@ subroutine crest_playground(env,tim) use crest_parameters use crest_data use crest_calculator - use strucrd + use strucrd use canonical_mod implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim type(coord) :: mol,molnew - integer :: i,j,k,l,io,ich + integer :: i,j,k,l,io,ich logical :: pr,wr !========================================================================================! type(calcdata) :: calc real(wp) :: accuracy,etemp - + integer :: V,maxgen integer,allocatable :: A(:,:) logical,allocatable :: rings(:,:) @@ -49,41 +49,34 @@ subroutine crest_playground(env,tim) logical :: connected,fail real(wp) :: energy - real(wp),allocatable :: grad(:,:),geo(:,:),csv(:,:) + real(wp),allocatable :: grad(:,:),geo(:,:),csv(:,:),q(:) type(canonical_sorter) :: can !========================================================================================! - call tim%start(14,'Test implementation') + call tim%start(14,'Test implementation') !========================================================================================! !call system('figlet welcome') - write(*,*) " _ " - write(*,*) "__ _____| | ___ ___ _ __ ___ ___ " - write(*,*) "\ \ /\ / / _ \ |/ __/ _ \| '_ ` _ \ / _ \" - write(*,*) " \ V V / __/ | (_| (_) | | | | | | __/" - write(*,*) " \_/\_/ \___|_|\___\___/|_| |_| |_|\___|" - write(*,*) + write (*,*) " _ " + write (*,*) "__ _____| | ___ ___ _ __ ___ ___ " + write (*,*) "\ \ /\ / / _ \ |/ __/ _ \| '_ ` _ \ / _ \" + write (*,*) " \ V V / __/ | (_| (_) | | | | | | __/" + write (*,*) " \_/\_/ \___|_|\___\___/|_| |_| |_|\___|" + write (*,*) !========================================================================================! call env%ref%to(mol) - write(*,*) - write(*,*) 'Input structure:' + write (*,*) + write (*,*) 'Input structure:' call mol%append(stdout) - write(*,*) + write (*,*) !========================================================================================! - allocate(grad(3,mol%nat), source=0.0_wp) + allocate (grad(3,mol%nat),source=0.0_wp) call env2calc(env,calc,mol) - calc%calcs(1)%rdwbo=.true. + calc%calcs(1)%rdwbo = .true. call calc%info(stdout) call engrad(mol,calc,energy,grad,io) call calculation_summary(calc,mol,energy,grad) - - - write(stdout,*) - write(stdout,*) 'CANGEN algorithm' - call can%init(mol,calc%calcs(1)%wbo,'apsp+') - call can%stereo(mol) - call can%rankprint(mol) !========================================================================================! call tim%stop(14) diff --git a/src/algos/protonate.f90 b/src/algos/protonate.f90 index a058bddf..0edd80bf 100644 --- a/src/algos/protonate.f90 +++ b/src/algos/protonate.f90 @@ -211,7 +211,7 @@ subroutine crest_new_protonate(env,tim) !>--- Run optimizations call tim%start(15,'Ensemble optimization (FF)') - call print_opt_data(tmpcalc_ff,stdout) + call print_opt_data(tmpcalc_ff,stdout,natoms=natp) write (stdout,'(a,i0,a)') '> ',npnew,' structures to optimize ...' call crest_oloop(env,natp,npnew,atp,xyzp(:,:,1:npnew),ep(1:npnew),.false.,tmpcalc_ff) call tim%stop(15) @@ -301,7 +301,7 @@ subroutine crest_new_protonate(env,tim) call tmpcalc%info(stdout) tmpcalc%optnewinit = .true. call tim%start(20,'Ensemble optimization') - call print_opt_data(env%calc,stdout) + call print_opt_data(env%calc,stdout,natoms=natp) write (stdout,'(a,i0,a)') '> ',npnew,' structures to optimize ...' call crest_oloop(env,natp,npnew,atp,xyzp(:,:,1:npnew),ep,.false.,tmpcalc) call tim%stop(20) @@ -695,7 +695,7 @@ subroutine crest_new_deprotonate(env,tim) !>--- Run optimizations call tim%start(15,'Ensemble optimization (FF)') - call print_opt_data(tmpcalc_ff,stdout) + call print_opt_data(tmpcalc_ff,stdout,natoms=natp) write (stdout,'(a,i0,a)') '> ',npnew,' structures to optimize ...' call crest_oloop(env,natp,npnew,atp,xyzp(:,:,1:npnew),ep(1:npnew),.false.,tmpcalc_ff) call tim%stop(15) @@ -784,7 +784,7 @@ subroutine crest_new_deprotonate(env,tim) call tmpcalc%info(stdout) tmpcalc%optnewinit = .true. call tim%start(20,'Ensemble optimization') - call print_opt_data(env%calc,stdout) + call print_opt_data(env%calc,stdout,natoms=natp) write (stdout,'(a,i0,a)') '> ',npnew,' structures to optimize ...' call crest_oloop(env,natp,npnew,atp,xyzp(:,:,1:npnew),ep(1:npnew),.false.,tmpcalc) call tim%stop(20) @@ -1178,7 +1178,7 @@ subroutine crest_new_tautomerize(env,tim) !>--- Run optimizations call tim%start(15,'Ensemble optimization (FF)') - call print_opt_data(tmpcalc_ff,stdout) + call print_opt_data(tmpcalc_ff,stdout,natoms=natp) write (stdout,'(a,i0,a)') '> ',npnew,' structures to optimize ...' call crest_oloop(env,natp,npnew,atp,xyzp(:,:,1:npnew),ep(1:npnew),.false.,tmpcalc_ff) call tim%stop(15) @@ -1271,7 +1271,7 @@ subroutine crest_new_tautomerize(env,tim) call tmpcalc%info(stdout) tmpcalc%optnewinit = .true. call tim%start(20,'Ensemble optimization') - call print_opt_data(env%calc,stdout) + call print_opt_data(env%calc,stdout,natoms=natp) write (stdout,'(a,i0,a)') '> ',npnew,' structures to optimize ...' call crest_oloop(env,natp,npnew,atp,xyzp(:,:,1:npnew),ep,.false.,tmpcalc) call tim%stop(20) diff --git a/src/algos/refine.f90 b/src/algos/refine.f90 index 71a96b28..9295a35f 100644 --- a/src/algos/refine.f90 +++ b/src/algos/refine.f90 @@ -56,19 +56,19 @@ subroutine crest_refine(env,input,output) else outname = input !> overwrite end if - + !>--- presorting step, if necessary - if(env%refine_presort)then + if (env%refine_presort) then call newcregen(env,0,input) call rename('crest_ensemble.xyz',input) - endif + end if !>--- read in call rdensemble(input,nat,nall,at,xyz,eread) allocate (etmp(nall),source=0.0_wp) !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: crest_sploop requires coordinates in Bohrs - xyz = xyz / bohr + xyz = xyz/bohr !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<< Geometry optimization of ",i0," structures")') nall call crest_oloop(env,nat,nall,at,xyz,eread,.false.) - case(refine%confsolv) + case (refine%confsolv) call new_ompautoset(env,'subprocess',1,t1,t2) write (stdout,'("> ConfSolv: ΔΔGsoln estimation from 3D directed message passing neural networks (D-MPNN)")') - call confsolv_request( input, nall, t2, etmp, io) - if(io == 0)then - eread(:) = etmp(:)*kcaltoau !> since CREGEN deals with Eh energies - endif + call confsolv_request(input,nall,t2,etmp,io) + if (io == 0) then + eread(:) = etmp(:)*kcaltoau !> since CREGEN deals with Eh energies + end if end select - write(stdout,*) + write (stdout,*) end do !> reset the refinement stage of the calculator @@ -118,7 +118,7 @@ subroutine crest_refine(env,input,output) !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: ensemble file must be written in AA - xyz = xyz / angstrom + xyz = xyz/angstrom !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- write output ensemble call wrensemble(outname,nat,nall,at,xyz,eread) diff --git a/src/algos/scan.f90 b/src/algos/scan.f90 index 0a40d94d..abf20a48 100644 --- a/src/algos/scan.f90 +++ b/src/algos/scan.f90 @@ -287,7 +287,7 @@ recursive subroutine runscan(mol,calc,calcclean,current) allocate (grad(3,mol%nat),source=0.0_wp) !>-- geometry optimization pr = .false. !> stdout printout - wr = .true. !> write crestopt.log + wr = .true. !> write crestopt.log.xyz molbackup = mol do j=1,calc%scans(current)%steps !write(*,*) current, calc%scans(current)%steps, j diff --git a/src/algos/search_1.f90 b/src/algos/search_1.f90 index 8b4d9ae9..14613288 100644 --- a/src/algos/search_1.f90 +++ b/src/algos/search_1.f90 @@ -82,8 +82,8 @@ subroutine crest_search_1(env,tim) call tim%start(2,'Molecular dynamics (MD)') call crest_search_multimd(env,mol,mddats,nsim) call tim%stop(2) -!>--- a file called crest_dynamics.trj should have been written - ensnam = 'crest_dynamics.trj' +!>--- a file called crest_dynamics.trj.xyz should have been written + ensnam = 'crest_dynamics.trj.xyz' !==========================================================! !>--- Reoptimization of trajectories diff --git a/src/algos/search_conformers.f90 b/src/algos/search_conformers.f90 index abf606d5..46842502 100644 --- a/src/algos/search_conformers.f90 +++ b/src/algos/search_conformers.f90 @@ -80,6 +80,8 @@ subroutine crest_search_imtdgc(env,tim) return endif + !call env%calc%info(stdout) + !>--- sets the MD length according to a flexibility measure call md_length_setup(env) !>--- create the MD calculator saved to env @@ -124,8 +126,8 @@ subroutine crest_search_imtdgc(env,tim) call tim%start(2,'Metadynamics (MTD)') call crest_search_multimd(env,mol,mddats,nsim) call tim%stop(2) -!>--- a file called crest_dynamics.trj should have been written - ensnam = 'crest_dynamics.trj' +!>--- a file called crest_dynamics.trj.xyz should have been written + ensnam = 'crest_dynamics.trj.xyz' !>--- deallocate for next iteration if(allocated(mddats))deallocate(mddats) @@ -193,7 +195,7 @@ subroutine crest_search_imtdgc(env,tim) !>--- Reoptimization of trajectories call checkname_xyz(crefile,atmp,btmp) write(stdout,'('' Appending file '',a,'' with new structures'')')trim(atmp) - ensnam = 'crest_dynamics.trj' + ensnam = 'crest_dynamics.trj.xyz' call appendto(ensnam,trim(atmp)) call tim%start(3,'Geometry optimization') call crest_multilevel_wrap(env,trim(atmp),-1) @@ -480,7 +482,7 @@ subroutine set_multilevel_options(env,i,pr) env%calc%optlev = 0 end select - call print_opt_data(env%calc, stdout) + call print_opt_data(env%calc, stdout, natoms=env%ref%nat) end subroutine set_multilevel_options end subroutine crest_multilevel_oloop diff --git a/src/algos/search_entropy.f90 b/src/algos/search_entropy.f90 index 9c1b8c77..c273cdca 100644 --- a/src/algos/search_entropy.f90 +++ b/src/algos/search_entropy.f90 @@ -130,8 +130,8 @@ subroutine crest_search_entropy(env,tim) call tim%start(2,'Metadynamics (MTD)') call crest_search_multimd(env,mol,mddats,nsim) call tim%stop(2) -!>--- a file called crest_dynamics.trj should have been written - ensnam = 'crest_dynamics.trj' +!>--- a file called crest_dynamics.trj.xyz should have been written + ensnam = 'crest_dynamics.trj.xyz' !>--- deallocate for next iteration if (allocated(mddats)) deallocate (mddats) @@ -373,10 +373,10 @@ subroutine crest_smtd_mds(env,ensnam) !===================================================================! !>--- and finally, run the sMTDs on the different starting structures call crest_search_multimd2(env,mols,mddats,nsim) -!>--- output will be collected in crest_dynamics.trj +!>--- output will be collected in crest_dynamics.trj.xyz !>--- but the entropy routines look for the crest_rotamers_ files call checkname_xyz(crefile,atmp,btmp) - call rename('crest_dynamics.trj',atmp) + call rename('crest_dynamics.trj.xyz',atmp) !===================================================================! !>--- by default, clean up the directory if (.not.env%keepModef) call cleanMTD diff --git a/src/algos/search_mecp.f90 b/src/algos/search_mecp.f90 index b480fbfe..c0f8ae45 100644 --- a/src/algos/search_mecp.f90 +++ b/src/algos/search_mecp.f90 @@ -72,8 +72,8 @@ subroutine crest_search_mecp(env,tim) call tim%start(2,'Molecular dynamics (MD)') call crest_search_multimd(env,mol,mddats,nsim) call tim%stop(2) - !>--- a file called crest_dynamics.trj should have been written - ensnam = 'crest_dynamics.trj' + !>--- a file called crest_dynamics.trj.xyz should have been written + ensnam = 'crest_dynamics.trj.xyz' !==========================================================! !>--- Reoptimization of trajectories diff --git a/src/algos/search_newnci.f90 b/src/algos/search_newnci.f90 index 2472b28c..f5323e1e 100644 --- a/src/algos/search_newnci.f90 +++ b/src/algos/search_newnci.f90 @@ -121,8 +121,8 @@ subroutine crest_search_newnci(env,tim) call tim%start(2,'Metadynamics (MTD)') call crest_search_multimd(env,mol,mddats,nsim) call tim%stop(2) -!>--- a file called crest_dynamics.trj should have been written - ensnam = 'crest_dynamics.trj' +!>--- a file called crest_dynamics.trj.xyz should have been written + ensnam = 'crest_dynamics.trj.xyz' !>--- deallocate for next iteration if (allocated(mddats)) deallocate (mddats) diff --git a/src/algos/setuptest.f90 b/src/algos/setuptest.f90 index c118957d..7d12b8e2 100644 --- a/src/algos/setuptest.f90 +++ b/src/algos/setuptest.f90 @@ -60,6 +60,7 @@ subroutine trialMD_calculator(env) type(timer) :: profiler type(calcdata) :: tmpcalc + type(calcdata) :: calcstart real(wp) :: energy real(wp),allocatable :: grd(:,:) integer :: T,Tn @@ -104,6 +105,7 @@ subroutine trialMD_calculator(env) MTD%mtdtype = cv_rmsd MTD%cvdump_fs = 550.0_wp call MDSTART%add(MTD) + calcstart = env%calc !> Save clean state before loop pr = .false. !> supress stdout printout of MD @@ -121,6 +123,8 @@ subroutine trialMD_calculator(env) !>--- Restore initial starting geometry mol = molstart +!>--- Restore clean calculation state + env%calc = calcstart !>--- Modify MD output trajectory MD = MDSTART MD%tstep = tstep @@ -304,9 +308,9 @@ subroutine trialOPT_calculator(env) !>--- perform geometry optimization pr = .false. !> stdout printout - wr = .true. !> write crestopt.log + wr = .true. !> write crestopt.log.xyz if(wr)then - call remove('crestopt.log') + call remove('crestopt.log.xyz') endif call optimize_geometry(mol,molopt,tmpcalc,energy,grd,pr,wr,io) @@ -348,7 +352,7 @@ subroutine trialOPT_warning(env,mol,success) if (.not.success) then write (stdout,*) write (stdout,*) ' Initial geometry optimization failed!' - write (stdout,*) ' Please check your input and, if present, crestopt.log.' + write (stdout,*) ' Please check your input and, if present, crestopt.log.xyz.' call creststop(status_failed) end if write (stdout,*) 'Geometry successfully optimized.' @@ -392,7 +396,7 @@ subroutine trialOPT_warning(env,mol,success) if (env%legacy) then write (stdout,'(1x,a)') 'You can check the optimization trajectory in the "xtbopt.log" file.' else - write (stdout,'(1x,a)') 'You can check the optimization trajectory in the "crestopt.log" file.' + write (stdout,'(1x,a)') 'You can check the optimization trajectory in the "crestopt.log.xyz" file.' end if write (stdout,'(1x,a)') 'Try either of these options:' write (stdout,'(/,4x,a)') 'A) Pre-optimize your input seperately and use the optimized' diff --git a/src/algos/sorting.f90 b/src/algos/sorting.f90 new file mode 100644 index 00000000..9e05cbd1 --- /dev/null +++ b/src/algos/sorting.f90 @@ -0,0 +1,219 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2024 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +!========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>! +!> Implementation for standalone sorting +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>! +!========================================================================================! +!> Input/Output: +!> env - crest's systemdata object +!> tim - timer object +!>----------------------------------------------- +subroutine crest_sort(env,tim) + use crest_parameters + use crest_data + use crest_calculator + use strucrd + use cregen_interface + use iomod,only:catdel + implicit none + type(systemdata),intent(inout) :: env + type(timer),intent(inout) :: tim + type(coord) :: mol,molnew + integer :: i,j,k,l,io,ich + logical :: pr,wr +!========================================================================================! + integer :: nall + type(coord),allocatable :: structures(:) + integer,allocatable :: groups(:) + +!========================================================================================! + select case (env%sortmode) + case default + write (stdout,'(a,a,a)',advance='no') '> Read ensemble ',trim(env%ensemblename),' ... ' + flush (stdout) + call rdensemble(env%ensemblename,nall,structures) + allocate (groups(nall),source=0) + write (stdout,'(i0,a)') nall,' structures!' + case ('irmsd','rmsd','hrmsd') + write (stdout,'(a,a)',advance='no') '> Reading files ',trim(env%ensemblename) + flush (stdout) + write (stdout,'(a,a)') ' and ',trim(env%ensemblename2) + end select + write (stdout,*) + +!========================================================================================! + call tim%start(11,'Sorting') + + select case (env%sortmode) + + case ('rmsd') + call quick_rmsd_tool(trim(env%ensemblename),trim(env%ensemblename2),.false.) + stop + + case ('hrmsd') + call quick_rmsd_tool(trim(env%ensemblename),trim(env%ensemblename2),.true.) + stop + + case ('irmsd') + call irmsd_tool(trim(env%ensemblename),trim(env%ensemblename2),env%iinversion) + stop + + case ('isort') +!>--- Assigning structures to conformers based on RTHR,with canonical atom IDs + call underline('Assigning conformers based on iRMSD and RTHR') + call cregen_irmsd_sort(env,nall,structures,groups,allcanon=.true.,printlvl=2) + + case ('isort_noid') +!>--- Assigning structures to conformers based on RTHR, WITHOUT canonical atom IDs + call underline('Assigning conformers based on iRMSD and RTHR') + call cregen_irmsd_sort(env,nall,structures,groups,allcanon=.false.,printlvl=2) + + case ('all','allpair') +!>--- all unique pairs of the ensemble (only suitable for small ensembles) + call underline('Running all unique pair RMSDs incl. atom permutation') + call cregen_irmsd_all(nall,structures,printlvl=2,iinversion=env%iinversion) + + case ('cregen') +!>--- the original CREGEN procedure (fallback, needs nicer implementations) + if (allocated(structures)) deallocate (structures) + call newcregen(env,infile=env%ensemblename) + call catdel('cregen.out.tmp') + + case default +!>--- all unique pairs of the ensemble (only suitable for small ensembles) + call cregen_irmsd_all(nall,structures,printlvl=2,iinversion=env%iinversion) + end select + +!========================================================================================! + call tim%stop(11) + if (allocated(structures)) deallocate (structures) + return +end subroutine crest_sort + +!=========================================================================================! + +subroutine irmsd_tool(fname1,fname2,iinversion) +!******************************************************* +!* irmsd_tool +!* Standalone implementation to compare two structures +!* with the iRMSD method. +!* This implementation should be called only on its own, +!* for ensemble-based processing see the CREGEN file +!******************************************************* + use crest_parameters + use strucrd + use axis_module + use irmsd_module + use canonical_mod + implicit none + character(len=*),intent(in) :: fname1 + character(len=*),intent(in) :: fname2 + integer,intent(in) :: iinversion + type(coord) :: mol,ref + real(wp) :: rmsdval,tmpd(3),tmpdist + integer :: i,ich + type(rmsd_cache) :: rcache + type(canonical_sorter) :: canmol + type(canonical_sorter) :: canref + logical :: mirror + logical,parameter :: debug = .false. + + write (stdout,*) 'iRMSD algorithm' + write (stdout,*) 'reference: ',trim(fname1) + write (stdout,*) 'processed: ',trim(fname2) + write (stdout,*) + + !> read the geometries + call ref%open(trim(fname1)) + call mol%open(trim(fname2)) + + !> move ref to CMA and align rotational axes + call axis(ref%nat,ref%at,ref%xyz) + + !> allocate memory + call rcache%allocate(ref%nat) + + !> canonical atom ranks + call canref%init(ref,invtype='apsp+',heavy=.false.) + !call canref%add_h_ranks(ref) + rcache%stereocheck = .not. (canref%hasstereo(ref)) + call canref%shrink() + write (stdout,*) 'false enantiomers possible?: ',rcache%stereocheck + select case (iinversion) + case (0) + mirror = .true. + case (1) + mirror = .true. + rcache%stereocheck = .true. + case (2) + mirror = .false. + rcache%stereocheck = .false. + end select + write (stdout,*) 'allow inversion?: ',mirror + + call canmol%init(mol,invtype='apsp+',heavy=.false.) + !call canmol%add_h_ranks(mol) + call canmol%shrink() + + !> check if we can work with the determined ranks + if (checkranks(ref%nat,canref%rank,canmol%rank)) then + write (stdout,*) 'using canonical atom identities as rank backend' + rcache%rank(:,1) = canref%rank(:) + rcache%rank(:,2) = canmol%rank(:) + if (debug) then + write (*,*) 'iRMSD ranks:' + write (*,*) 'atom',' rank('//fname1//')',' rank('//fname2//')' + do i = 1,ref%nat + write (*,*) i,rcache%rank(i,1),rcache%rank(i,2) + end do + write (*,*) + end if + else + !> if not, fall back to atom types + write (stdout,*) 'using atom types as rank backend' + call fallbackranks(ref,mol,ref%nat,rcache%rank) + end if + + call min_rmsd(ref,mol,rcache=rcache,rmsdout=rmsdval,align=.true.) + + !> write the rotated and shifted coordinates to one file + open (newunit=ich,file='irmsd.xyz') + call ref%append(ich) + call mol%append(ich) + close (ich) + write (stdout,*) + write (stdout,*) 'aligned structures written to irmsd.xyz' + write (stdout,*) + + do i = 1,mol%nat + tmpd(:) = (mol%xyz(:,i)-ref%xyz(:,i))**2 + tmpdist = sqrt(sum(tmpd(:)))*autoaa + if (tmpdist > 0.01_wp) then + write (*,*) i,mol%at(i),tmpdist + end if + end do + + rmsdval = rmsdval*autoaa + write (*,'(1x,a,f16.8)') 'Calculated iRMSD (Å):',rmsdval + + return +end subroutine irmsd_tool + diff --git a/src/axis_module.f90 b/src/axis_module.f90 index f6e7379a..e03952dd 100644 --- a/src/axis_module.f90 +++ b/src/axis_module.f90 @@ -75,6 +75,8 @@ module axis_module end interface cma public :: CMAtrf + public :: uniqueax + !========================================================================================! !========================================================================================! contains !> MODULE PROCEDURES START HERE @@ -95,15 +97,15 @@ module axis_module !========================================================================================! subroutine axis_0(nat,at,coord,rot,avmom,evec) implicit none - integer :: nat - integer :: at(nat) - real(wp) :: coord(3,nat) - real(wp) :: rot(3),avmom,evec(3,3) + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(in) :: coord(3,nat) + real(wp),intent(out) :: rot(3),avmom,evec(3,3) real(wp) :: a(3,3) real(wp) :: t(6),xyzmom(3),eig(3) !real(wp) :: x(nat),y(nat),z(nat) - real(wp),allocatable :: x(:),y(:),z(:) - real(wp) :: atmass + !real(wp),allocatable :: x(:),y(:),z(:) + real(wp) :: atmass,shift(3) integer :: i,j !************************************************************************ !* const1 = 10**40/(n*a*a) @@ -116,8 +118,9 @@ subroutine axis_0(nat,at,coord,rot,avmom,evec) !> first we move the molecule to the CMA !> this depends on the isotopic masses, and the cartesian geometry. !> - allocate (x(nat),y(nat),z(nat),source=0.0_wp) - call CMA(nat,at,coord,x,y,z) +! allocate (x(nat),y(nat),z(nat),source=0.0_wp) +! call CMA(nat,at,coord,x,y,z) + call CMAshift(nat,at,coord,shift) !************************************************************************ !* matrix for moments of inertia is of form @@ -133,12 +136,18 @@ subroutine axis_0(nat,at,coord,rot,avmom,evec) end do do i = 1,nat atmass = ams(at(i)) - t(1) = t(1) + atmass * (y(i)**2 + z(i)**2) - t(2) = t(2) - atmass * x(i) * y(i) - t(3) = t(3) + atmass * (z(i)**2 + x(i)**2) - t(4) = t(4) - atmass * z(i) * x(i) - t(5) = t(5) - atmass * y(i) * z(i) - t(6) = t(6) + atmass * (x(i)**2 + y(i)**2) +! t(1) = t(1) + atmass * (y(i)**2 + z(i)**2) +! t(2) = t(2) - atmass * x(i) * y(i) +! t(3) = t(3) + atmass * (z(i)**2 + x(i)**2) +! t(4) = t(4) - atmass * z(i) * x(i) +! t(5) = t(5) - atmass * y(i) * z(i) +! t(6) = t(6) + atmass * (x(i)**2 + y(i)**2) + t(1) = t(1) + atmass * ((coord(2,i)-shift(2))**2 + (coord(3,i)-shift(3))**2) + t(2) = t(2) - atmass * (coord(1,i)-shift(1)) * (coord(2,i)-shift(2)) + t(3) = t(3) + atmass * ((coord(3,i)-shift(3))**2 + (coord(1,i)-shift(1))**2) + t(4) = t(4) - atmass * (coord(3,i)-shift(3)) * (coord(1,i)-shift(1)) + t(5) = t(5) - atmass * (coord(2,i)-shift(2)) * (coord(3,i)-shift(3)) + t(6) = t(6) + atmass * ((coord(1,i)-shift(1))**2 + (coord(2,i)-shift(2))**2) a(1,1) = t(1) a(2,1) = t(2) a(1,2) = t(2) @@ -149,7 +158,7 @@ subroutine axis_0(nat,at,coord,rot,avmom,evec) a(2,3) = t(5) a(3,3) = t(6) end do - deallocate (z,y,x) +! deallocate (z,y,x) evec = 0.0_wp eig = 0.0_wp @@ -241,12 +250,14 @@ subroutine axis_2(pr,nat,at,coord,eax) end subroutine axis_2 !========================================================================================! -!> subroutine axis_3 -!> axis routine that orients the molecule along the -!> calculated principle axes and shifts it to CMA. -!> new geometry is written to coordout. -!>--------------------------------------------- + subroutine axis_3(nat,at,coord,coordout,rot) +!**************************************************** +!* subroutine axis_3 +!* axis routine that orients the molecule along the +!* calculated principle axes and shifts it to CMA. +!* new geometry is written to coordout. +!**************************************************** implicit none integer,intent(in) :: nat integer,intent(in) :: at(nat) @@ -293,24 +304,50 @@ subroutine axis_3(nat,at,coord,coordout,rot) end subroutine axis_3 !========================================================================================! -!> subroutine axis_4 -!> axis routine that orients the molecule along the -!> calculated principle axes and shifts it to CMA. -!> new geometry OVERWRITES input. -!>-------------------------------- - subroutine axis_4(nat,at,coord) + + subroutine axis_4(nat,at,coord,rotconst) +!**************************************************** +!* subroutine axis_4 +!* axis routine that orients the molecule along the +!* calculated principle axes and shifts it to CMA. +!* new geometry OVERWRITES input. +!* Optimized for minimal allocation overhead. +!**************************************************** implicit none integer,intent(in) :: nat integer,intent(in) :: at(nat) real(wp),intent(inout) :: coord(3,nat) - real(wp) :: rot(3) - real(wp),allocatable :: coordtmp(:,:) + real(wp),intent(out),optional :: rotconst(3) + real(wp) :: coordtmp(3),shift(3) + real(wp) :: rot(3),avmom,evec(3,3) + integer :: i,j,k + real(wp) :: xsum + call axis_0(nat,at,coord,rot,avmom,evec) + call CMAshift(nat,at,coord,shift) + do i=1,nat + coord(:,i) = coord(:,i) - shift(:) + enddo + !> do the trafo (chirality is preserved) + xsum = calcxsum(evec) + if (xsum .lt. 0.0_wp) then + do j = 1,3 + evec(j,1) = -evec(j,1) + end do + end if - allocate (coordtmp(3,nat)) - !> call axis routine - call axis_3(nat,at,coord,coordtmp,rot) - coord = coordtmp - deallocate (coordtmp) + do i = 1,nat + coordtmp(:) = coord(:,i) + do j = 1,3 + xsum = 0.0_wp + do k = 1,3 + xsum = xsum + coordtmp(k) * evec(k,j) + end do + coord(j,i) = xsum + end do + end do + if(present(rotconst))then + rotconst(:) = rot(:) + endif return end subroutine axis_4 @@ -378,10 +415,43 @@ real(wp) function calcxsum(evec) end function calcxsum !========================================================================================! -!> subroutine CMA -!> calculate CMA-shifted coordinates x y z -!>-------------------------------------- + + subroutine uniqueax(rot,unique,thr) +!************************************************** +!* check if a given rotational constant is unique +!************************************************** + implicit none + real(wp),intent(in) :: rot(3) + logical,intent(out) :: unique(3) + real(wp),intent(in),optional :: thr + real(wp) :: thrtmp + real(wp) :: diff(3) + + unique(:) = .false. + + if(present(thr))then + thrtmp = thr + else + thrtmp = 0.01_wp + endif + + diff(1) = abs(rot(2)/rot(1) - 1.0_wp) + diff(2) = abs(rot(3)/rot(1) - 1.0_wp) + diff(3) = abs(rot(3)/rot(2) - 1.0_wp) + + if(diff(1) .gt. thrtmp .and. diff(2) .gt. thrtmp) unique(1) = .true. + if(diff(1) .gt. thrtmp .and. diff(3) .gt. thrtmp) unique(2) = .true. + if(diff(2) .gt. thrtmp .and. diff(3) .gt. thrtmp) unique(3) = .true. + + end subroutine uniqueax + +!========================================================================================! + subroutine CMAxyz(nat,at,coord,x,y,z) +!******************************************** +!* subroutine CMA +!* calculate CMA-shifted coordinates x y z +!******************************************** implicit none integer,intent(in) :: nat integer,intent(in) :: at(nat) @@ -411,6 +481,40 @@ subroutine CMAxyz(nat,at,coord,x,y,z) return end subroutine CMAxyz +!========================================================================================! + + subroutine CMAshift(nat,at,coord,shift) +!********************************************************* +!* subroutine CMAshift +!* calculate the shift vector to shift a molecule to CMA +!********************************************************* + implicit none + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(in) :: coord(3,nat) + real(wp),intent(out) :: shift(3) + integer :: i + real(wp) :: sumw,sumwx,sumwy,sumwz,atmass + sumw = 1.d-20 + sumwx = 0.d0 + sumwy = 0.d0 + sumwz = 0.d0 + do i = 1,nat + atmass = ams(at(i)) + sumw = sumw + atmass + sumwx = sumwx + atmass * coord(1,i) + sumwy = sumwy + atmass * coord(2,i) + sumwz = sumwz + atmass * coord(3,i) + end do + sumwx = sumwx / sumw + sumwy = sumwy / sumw + sumwz = sumwz / sumw + shift(1) = sumwx + shift(2) = sumwy + shift(3) = sumwz + return + end subroutine CMAshift + !========================================================================================! !> subroutine CMAtrf !> calculate a shift to the first nat0 atoms' CMA diff --git a/src/basinhopping/CMakeLists.txt b/src/basinhopping/CMakeLists.txt new file mode 100644 index 00000000..6a29ef85 --- /dev/null +++ b/src/basinhopping/CMakeLists.txt @@ -0,0 +1,35 @@ +# This file is part of crest. +# SPDX-Identifier: LGPL-3.0-or-later +# +# crest is free software: you can redistribute it and/or modify it under +# the terms of the GNU Lesser General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# crest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public License +# along with crest. If not, see . + +set(dir "${CMAKE_CURRENT_SOURCE_DIR}") + +list(APPEND srcs + "${dir}/algo.f90" + "${dir}/basinhopping.f90" + "${dir}/class.f90" + "${dir}/mc.f90" + "${dir}/takestep.f90" +) + +set(srcs ${srcs} PARENT_SCOPE) + + + + + + + + diff --git a/src/basinhopping/algo.f90 b/src/basinhopping/algo.f90 new file mode 100644 index 00000000..96edf67b --- /dev/null +++ b/src/basinhopping/algo.f90 @@ -0,0 +1,272 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2024 Philipp Pracht, David Wales +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module bh_algo_interface + implicit none + interface + subroutine single_basinhopping_core(env,mol,calc,structuredump) + use crest_data + use crest_calculator + use strucrd + implicit none + type(systemdata),intent(inout) :: env + type(coord),intent(inout) :: mol + type(coord),allocatable,intent(inout) :: structuredump(:) + type(calcdata),intent(inout) :: calc + end subroutine single_basinhopping_core + subroutine parallel_basinhopping_core(env,mol,calc,structuredump) + use crest_data + use crest_calculator + use strucrd + implicit none + !> INPUT/OUTPUT + type(systemdata),intent(inout) :: env + type(coord),intent(inout) :: mol + type(coord),allocatable,intent(inout) :: structuredump(:) + type(calcdata),intent(in) :: calc + end subroutine parallel_basinhopping_core + end interface +end module bh_algo_interface + +!================================================================================! +!================================================================================! +!================================================================================! + +subroutine crest_basinhopping(env,tim) + use crest_parameters + use crest_data + use crest_calculator + use strucrd + use cregen_interface,only:unionizeEnsembles + use optimize_module + use bh_module + use bh_algo_interface + implicit none + type(systemdata),intent(inout) :: env + type(timer),intent(inout) :: tim + type(coord) :: mol,molnew + integer :: i,j,k,l,io,ich,T,Tn,mciter + logical :: pr,wr +!========================================================================================! + type(calcdata) :: calc + + real(wp) :: energy,gnorm + real(wp),allocatable :: grad(:,:) + integer :: nall + type(coord),allocatable :: structuredump(:) + logical :: parallel + character(len=80) :: atmp + character(len=*),parameter :: trjf = 'crest_quenched.xyz' +!========================================================================================! + write (stdout,*) + write (stdout,*) " ____ _ _ _ _ " + write (stdout,*) "| __ ) __ _ ___(_)_ __ | | | | ___ _ __ _ __ (_)_ __ __ _ " + write (stdout,*) "| _ \ / _` / __| | '_ \| |_| |/ _ \| '_ \| '_ \| | '_ \ / _` |" + write (stdout,*) "| |_) | (_| \__ \ | | | | _ | (_) | |_) | |_) | | | | | (_| |" + write (stdout,*) "|____/ \__,_|___/_|_| |_|_| |_|\___/| .__/| .__/|_|_| |_|\__, |" + write (stdout,*) " |_| |_| |___/ " + write (stdout,*) "" + call new_ompautoset(env,'max',0,T,Tn) + call ompprint_intern() + + calc = env%calc + call env%ref%to(mol) + write (stdout,*) + write (stdout,*) 'Input structure:' + call mol%append(stdout) + write (stdout,*) +!========================================================================================! +!>--- print calculation info + call calc%info(stdout) + write (stdout,'(a)') '> Geometry optimization settings:' + call print_opt_data(calc,stdout,natoms=mol%nat,tag=' : ') + write (stdout,*) + +!>--- singlepoint of input structure + allocate (grad(3,mol%nat),source=0.0_wp) + call engrad(mol,calc,energy,grad,io) + mol%energy = energy !> we need this to start the Markov-chain + +!==========================================================================================! + parallel = .false. + if (allocated(env%bh_ref)) then + parallel = env%bh_ref%parallel + end if + +!=========================================================================================! + call tim%start(14,'Basin-Hopping (BH)') + + if (parallel) then + call parallel_basinhopping_core(env,mol,calc,structuredump) + else + call single_basinhopping_core(env,mol,calc,structuredump) + end if +!>--- dump saved minima + nall = size(structuredump,1) + open (newunit=ich,file=trjf) + call wrensemble(ich,nall,structuredump) + close (ich) + + if (io == 0) then + write (stdout,*) + write (stdout,*) 'BH run completed successfully' + write (stdout,*) 'Successfull quenches written to ',trjf + else + write (stdout,*) 'WARNING: BH run terminated ABNORMALLY' + env%iostatus_meta = status_failed + end if + + call tim%stop(14) + + if (allocated(structuredump)) deallocate (structuredump) + return +end subroutine crest_basinhopping + +subroutine single_basinhopping_core(env,mol,calc,structuredump) + use crest_parameters + use crest_data + use crest_calculator + use strucrd + use cregen_interface,only:unionizeEnsembles + use optimize_module + use bh_module + implicit none + type(systemdata),intent(inout) :: env + type(coord),intent(inout) :: mol + type(coord),allocatable,intent(inout) :: structuredump(:) + type(calcdata),intent(inout) :: calc +!========================================================================================! + integer :: i,j,k,l,io,ich,T,Tn,mciter + logical :: pr,wr + type(bh_class) :: bh + integer :: nall +!========================================================================================! + call new_ompautoset(env,'max',0,T,Tn) +!========================================================================================! +!>--- actual basin hopping + if (allocated(env%bh_ref)) then + bh = env%bh_ref + call bh%init() + else + call bh%init(300.0_wp,200,20) + bh%stepsize(1) = 1.0_wp + end if + + nall = 0 + do mciter = 1,bh%maxiter + if (bh%maxiter > 1) call printiter2(mciter) + call bh%newiter() + call mc(calc,mol,bh,verbosity=2) + + write (stdout,'(a)') 'New structures will be appended to memory ...' + call unionizeEnsembles(nall,structuredump,bh%saved,bh%structures, & + & ethr=bh%ethr,rthr=bh%rthr) + write (stdout,'(a,i0,a)') 'Currently ',nall,' structures saved!' + end do + return +end subroutine single_basinhopping_core + +subroutine parallel_basinhopping_core(env,mol,calc,structuredump) +!************************************************************************** +!* subroutine parallel_basinhopping_core +!* Perform multiple independent BH runs from a single given starting point +!* Ensembles are unified at the end and returned via structuedump +!************************************************************************** + use crest_parameters + use crest_data + use crest_calculator + use strucrd + use cregen_interface,only:unionizeEnsembles + use optimize_module + use bh_module + implicit none + !> INPUT/OUTPUT + type(systemdata),intent(inout) :: env + type(coord),intent(inout) :: mol + type(coord),allocatable,intent(inout) :: structuredump(:) + type(calcdata),intent(in) :: calc +!========================================================================================! + !> LOCAL + integer :: i,j,k,l,io,ich,T,Tn,mciter + logical :: pr,wr + type(calcdata),allocatable :: calcp(:) + type(bh_class),allocatable :: bhp(:) + type(coord),allocatable :: mols(:) + real(wp) :: energy + integer :: nall + type(mollist),allocatable :: dumplist(:) + + call new_ompautoset(env,'auto',0,T,Tn) + !======================================================================================! + !> THIS IS THE PARALLEL IMPORTANT BIT + !======================================================================================! +!>--- allocate temporary spaces for parallel usage + allocate (mols(T),source=mol) + allocate (bhp(T)) + allocate (calcp(T),source=calc) + allocate (dumplist(T)) + if (allocated(env%bh_ref)) then + do K = 1,T + bhp(K) = env%bh_ref + call bhp(K)%init() + end do + else + do K = 1,T + call bhp(K)%init(300.0_wp,200,20) + bhp(K)%stepsize(1) = 1.0_wp + end do + end if + do K = 1,T + bhp(K)%id = K-1 + end do + + !$omp parallel do default(shared) private(K, mciter) schedule(dynamic) + do K = 1,T + do mciter = 1,bhp(K)%maxiter + !$omp critical + if (bhp(K)%maxiter > 1) call printiter2(mciter) + !$omp end critical + call bhp(K)%newiter() + call mc(calcp(K),mols(K),bhp(K),verbosity=2) + + write (stdout,'(a)') 'New structures will be appended to memory ...' + call unionizeEnsembles(dumplist(K)%nall,dumplist(K)%structure, & + & bhp(K)%saved,bhp(K)%structures, & + & ethr=bhp(K)%ethr,rthr=bhp(K)%rthr) + write (stdout,'(a,i0,a,i0,a)') 'Currently ',dumplist(K)%nall, & + & ' structures saved (BH[',bhp(K)%id,'])!' + end do + end do + !$omp end parallel do + + write (stdout,*) + write (stdout,'(a)') 'Parallel BH runs done!' + write (stdout,'(a)') 'Collecting structures in one ensemble ...' + nall = 0 + do K = 1,T + call unionizeEnsembles(nall,structuredump, & + & dumplist(K)%nall,dumplist(K)%structure, & + & ethr=bhp(K)%ethr,rthr=bhp(K)%rthr) + end do + write (stdout,'(a,i0,a)') 'Total of ',nall,' structures remain.' +!=======================================================================================! +!> PARALLEL BIT END +!=======================================================================================! + return +end subroutine parallel_basinhopping_core diff --git a/src/basinhopping/basinhopping.f90 b/src/basinhopping/basinhopping.f90 new file mode 100644 index 00000000..ddbc62e3 --- /dev/null +++ b/src/basinhopping/basinhopping.f90 @@ -0,0 +1,47 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2024 Philipp Pracht, David Wales +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module bh_module + use crest_parameters + use strucrd,only:coord + use crest_calculator + use optimize_module + use bh_class_module + use bh_step_module + use bh_mc_module + implicit none + private + + logical,parameter :: debug = .true. +! logical,parameter :: debug = .false. + +!>-- RE-EXPORTS + public :: mc + public :: bh_class + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + +!=========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<. +!================================================================================! + +module bh_class_module + use crest_parameters + use strucrd,only:coord + use canonical_mod + use irmsd_module + implicit none + +!=========================================================================================! + + public :: bh_class + type :: bh_class +!************************************************************************ +!* data object that contains the data for a *SINGLE* basin-hopping chain +!************************************************************************ + integer :: id = 0 !> Run/Thread ID + integer,allocatable :: seed !> RNG seed, only used when allocated +!>--- settings + logical :: parallel = .false. !> runtype definition + integer :: quenchmode = 0 !> selection of how to quench structures + integer :: duplicatemode = 0 !> selection of how to prune duplicates + +!>--- counters + integer :: iteration = 0 !> current iteration + integer :: saved = 0 !> number of saved quenches + +!>--- paramters + integer :: maxiter = 1 !> maximum repetitions of the whole BH run + integer :: maxsteps = 100 !> maximum steps to take + real(wp) :: temp = 300.0_wp !> MC acceptance temperature + real(wp) :: scalefac = 1.0_wp !> temperature increase factor + real(wp) :: rthr = 0.125_wp !> RMSD threshold (\AA) + real(wp) :: ethr = 0.05_wp !> minima/conformer energy distinction (kcal/mol) + integer :: steptype = 0 !> step type selection + real(wp) :: stepsize(3) = & !> step sizes e.g. for lengths, angles, dihedrals + & (/0.2_wp,0.2_wp,0.2_wp/) + integer :: maxsave = 100 !> maximum number of quenches saved + real(wp),allocatable :: etarget !> target energy to be hit (useful in benchmarks) + + +!>--- results/properties + real(wp) :: emin = 0.0_wp !> current ref energy of markov chain + integer :: whichmin = 0 !> mapping to which structure emin refers + real(wp) :: emax = 0.0_wp !> highest energy structure among saved quenches + integer :: whichmax = 0 !> mapping of highest energy structure + type(coord),allocatable :: structures(:) !> list of structures from succesfull quenches + +!>--- temporary storage + integer,allocatable :: amat(:,:) !> adjacency matrix + real(wp),allocatable :: zmat(:,:) !> internal coordinates (to cache the memory) + type(rmsd_cache),allocatable :: rcache !> similarity check cache (iRMSD) + logical :: stereocheck = .false. !> check for false-rotamers? + type(canonical_sorter),allocatable :: sorters(:) !> canonical atom ID storage + logical :: topocheck = .true. !> check for correct connectivity + type(canonical_sorter),allocatable :: refsort !> use same reference connectivity for all + +!>--- Type procedures + contains + procedure :: init => bh_class_allocate + procedure :: deallocate => bh_class_deallocate + procedure :: add => bh_class_add + procedure :: newiter => bh_class_newiter + end type bh_class + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + subroutine bh_class_allocate(self,temp,maxsteps,maxsave) + implicit none + class(bh_class) :: self + real(wp),intent(in),optional :: temp + integer,intent(in),optional :: maxsteps + integer,intent(in),optional :: maxsave + real(wp) :: rand + + call self%deallocate() + if (present(temp)) then + self%temp = temp + end if + if (present(maxsteps)) then + self%maxsteps = maxsteps + end if + if (present(maxsave)) then + self%maxsave = maxsave + end if + self%maxsave = min(self%maxsave,self%maxsteps) + + self%iteration = 0 + self%saved = 0 + allocate (self%structures(self%maxsave)) + allocate (self%sorters(self%maxsave)) + +!>--- generate a random seed, if the object doesn't have one already + if (.not.allocated(self%seed)) then + !> Generate a real in [0,1) + call random_number(rand) + !> Scale and shift to produce an integer in [1,10mil] + allocate (self%seed) + self%seed = (int(rand*100000000.0)+1) + end if + end subroutine bh_class_allocate + +!=========================================================================================! + + subroutine bh_class_deallocate(self) + implicit none + class(bh_class) :: self + if (allocated(self%structures)) deallocate (self%structures) + if (allocated(self%amat)) deallocate (self%amat) + if (allocated(self%zmat)) deallocate (self%zmat) + if (allocated(self%sorters)) deallocate (self%sorters) + if (allocated(self%rcache)) deallocate (self%rcache) + if (allocated(self%refsort)) deallocate (self%refsort) + end subroutine bh_class_deallocate + +!========================================================================================! + + subroutine bh_class_newiter(self) + implicit none + class(bh_class) :: self + integer :: i + self%iteration = self%iteration + 1 + !$omp critical + do i = 1,self%saved + call self%sorters(i)%deallocate() + enddo + !$omp end critical + self%saved=0 + end subroutine bh_class_newiter + +!=========================================================================================! + + subroutine bh_class_add(self,mol) + implicit none + class(bh_class) :: self + type(coord) :: mol + integer :: i,j + real(wp) :: mintmp,maxtmp + if (self%saved < self%maxsave) then + self%saved = self%saved+1 + i = self%saved + self%structures(i) = mol + !$omp critical + call self%sorters(i)%init(mol,invtype='apsp+',heavy=.false.) + if (i == 1) then + self%stereocheck = .not. (self%sorters(i)%hasstereo(mol)) + end if + !$omp end critical + else + i = self%whichmax + self%structures(i) = mol + !$omp critical + call self%sorters(i)%deallocate() + call self%sorters(i)%init(mol,invtype='apsp+',heavy=.false.) + call self%sorters(i)%shrink() + !$omp end critical + end if + + mintmp = huge(mintmp) + maxtmp = -huge(maxtmp) + do i = 1,self%saved + if (self%structures(i)%energy < mintmp) then + mintmp = self%structures(i)%energy + self%whichmin = i + end if + if (self%structures(i)%energy > maxtmp) then + maxtmp = self%structures(i)%energy + self%whichmax = i + end if + end do + self%emin = mintmp + self%emax = maxtmp + end subroutine bh_class_add + +!=========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<. +!================================================================================! + +module bh_mc_module + use crest_parameters + use iomod + use strucrd,only:coord + use crest_calculator + use optimize_module + use axis_module + use irmsd_module + use canonical_mod + use quicksort_interface,only:ensemble_qsort + use bh_class_module + use bh_step_module + implicit none + private + +! logical,parameter :: debug = .true. + logical,parameter :: debug = .false. + + public :: mc + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + subroutine mc(calc,mol,bh,verbosity) +!******************************************************************** +!* A thread-safe single basin-hopping MC run +!* Parameters and quenched structures are saved within the bh object +!******************************************************************** + implicit none + !> IN/OUTPUT + type(calcdata),intent(inout) :: calc !> potential settings + type(coord),intent(inout) :: mol !> molecular system + type(bh_class),intent(inout) :: bh !> BH settings + integer,intent(in),optional :: verbosity !> printout parameter + !> LOCAL + type(coord) :: tmpmol !> copy to take steps + type(coord) :: optmol !> quenched structure + integer :: iter,iostatus,accepted,discarded,broke + real(wp) :: etot,ratio + real(wp),allocatable :: grd(:,:) + logical :: accept,dupe,broken + integer :: printlvl,first,last,dynamicseed + character(len=10) :: tag + + write (tag,'("BH[",i0,"]>")') bh%id + + if (present(verbosity)) then + printlvl = verbosity + else + printlvl = 0 + end if + +!>--- Add input energy to Markov chain + bh%emin = mol%energy + call bh%add(mol) + +!>--- print information about the run? + if (printlvl > 0) then + !$omp critical + call mcheader(bh) + !$omp end critical + end if + +!>--- seed the RNG? + if (allocated(bh%seed)) then + dynamicseed = bh%seed+(bh%iteration-1)+bh%id*1000 + if (printlvl > 1) then + write (stdout,'(a,1x,2(a,i0),a)') trim(tag), & + & 'Seeding current RNG instance with: ',bh%seed,' (',dynamicseed,')' + end if + call RNG_seed(bh%seed) + end if + + !$omp critical + allocate (grd(3,mol%nat),source=0.0_wp) + !$omp end critical +!=======================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Take the step (mol --> tmpmol) + call takestep(mol,calc,bh,tmpmol) + +!>--- Quench it (tmpmol --> optmol) + call optimize_geometry(tmpmol,optmol,calc,etot,grd, & + & .false.,.false.,iostatus) + +!>--- Accept/reject + if (iostatus == 0) then !> successfull optimization + + if (printlvl > 1) then + !$omp critical + write (stdout,'(a,1x,a,es17.8,a,es17.8,a)') trim(tag),'Quench E=',etot, & + & ' Eh, Markov E=',bh%emin,' Eh' + !$omp end critical + end if + + accept = mcaccept(optmol,bh) + if (accept) then + accepted = accepted+1 + + call axis(optmol%nat,optmol%at,optmol%xyz) + + if (printlvl > 1) then + write (stdout,'(a)',advance='no') repeat(' ',len_trim(tag)+1)// & + & "Quench "//colorify('ACCEPTED','green') + end if + + !> check duplicates here + call mcduplicate(mol,bh,dupe,broken) + if (broken) then + broke = broke+1 + if (printlvl > 1) write (stdout,'(a)',advance='no') & + & ', but REJECTED due to topology mismatch!' + else if (dupe) then + discarded = discarded+1 + if (printlvl > 1) write (stdout,'(a)',advance='no') & + & ', but '//colorify('NOT SAVED','yellow')//' due to duplicate detection!' + end if + + if (printlvl > 1) write (stdout,'(/)') + else + if (printlvl > 1) write (stdout,'(a,a,/)') repeat(' ',len_trim(tag)+1), & + & 'Quench '//colorify('REJECTED','red')//', does not fulfill MC criterion' + cycle MonteCarlo + end if + else + if (printlvl > 1) write (stdout,'(a,1x,a,/)') trim(tag),"Quench "//colorify("FAILED","red") + cycle MonteCarlo + end if + +!>--- Update structures + if (.not.broken) then + !> continue Markov chain + mol = optmol + + if (.not.dupe) then + !> Save new unique structures + call bh%add(mol) + end if + end if + + end do MonteCarlo +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Post-processing + first = 1 + last = bh%saved + call ensemble_qsort(bh%maxsave,bh%structures,first,last) + +!>--- Stats + if (printlvl > 0) then + !$omp critical + call mcstats(bh,accepted,discarded,broke) + !$omp end critical + end if + + deallocate (grd) + end subroutine mc + +!=========================================================================================! + + subroutine mcheader(bh) + implicit none + type(bh_class),intent(in) :: bh + character(len=80) :: atmp + integer :: n + + write (stdout,'(a)') '+'//repeat('-',63)//'+' + write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(a,3x)',advance='no') 'Starting Basin-Hopping Global Optimization' + write (stdout,'(a,i3,a)',advance='no') '[Thread/ID ',bh%id,']' + write (stdout,'(2x,"|")') + + write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(a,f20.10,a)',advance='no') 'Initial energy:',bh%emin,' Eh' + write (stdout,'(24x,"|")') + + write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(a,es9.3,3x)',advance='no') 'T/K: ',bh%temp + write (stdout,'(a,i5,3x)',advance='no') 'steps: ',bh%maxsteps + write (stdout,'(a,i5,3x)',advance='no') 'max save: ',bh%maxsave + write (stdout,'(12x,"|")') + + if (allocated(bh%seed)) then + write (stdout,'(a,1x)',advance='no') '|' + write (atmp,'(a,i0)') 'Random number generation (reference) seed: ',bh%seed + write (stdout,'(a,1x)',advance='no') trim(atmp) + n = 61-len_trim(atmp) + write (stdout,'(a)',advance='no') repeat(' ',n) + write (stdout,'("|")') + end if + + + write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(a,a,2x)',advance='no') 'step type: ',steptypestr(bh%steptype) + write (stdout,'(a,3f9.5)',advance='no') 'step size:',bh%stepsize(1:3) + write (stdout,'(3x,"|")') + + write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(a,f9.5,a)',advance='no') 'Thresholds ΔRMSD:',bh%rthr,' Å, ' + write (stdout,'(a,es10.4,a)',advance='no') 'ΔE: ',bh%ethr,' kcal/mol' + write (stdout,'(6x,"|")') + + write (stdout,'(a)') '+'//repeat('-',63)//'+' + end subroutine mcheader + + subroutine mcstats(bh,accepted,discarded,broke) + implicit none + type(bh_class),intent(in) :: bh + integer,intent(in) :: accepted,discarded,broke + real(wp) :: ratio + + write (stdout,'(a)') '+'//repeat('~',63)//'+' + write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(a,21x)',advance='no') 'Basin-Hopping Statistics' + write (stdout,'(a,i3,a)',advance='no') '[Thread/ID ',bh%id,']' + write (stdout,'(2x,"|")') + + write (stdout,'(a,1x)',advance='no') '|' + ratio = real(accepted,wp)/real(bh%maxsteps,wp) + write (stdout,'(a,f6.2,a)',advance='no') 'MC acceptance ratio ',ratio*100.0_wp,' %, ' + ratio = real(discarded,wp)/real(accepted,wp) + write (stdout,'(a,f6.2,a)',advance='no') 'similarity rejection ',ratio*100.0_wp,' %' + write (stdout,'(2x,"|")') + + write (stdout,'(a,1x)',advance='no') '|' + ratio = real(broke,wp)/real(accepted,wp) + write (stdout,'(a,f6.2,a)',advance='no') 'topology rejection ',ratio*100.0_wp,' %, ' + ratio = real(accepted-discarded-broke,wp)/real(bh%maxsteps,wp) + write (stdout,'(a,f6.2,a)',advance='no') 'TOTAL ACCEPT ratio ',ratio*100.0_wp,' %' + write (stdout,'(2x,"|")') + write (stdout,'(a)') '+'//repeat('~',63)//'+' + end subroutine mcstats + +!=========================================================================================! + + subroutine RNG_seed(iseed) +!************************************* +!* seed the RNG to get a reproducible +!* sequence of random numbers +!************************************* + integer,intent(in) :: iseed + integer :: n + integer,allocatable :: seedArray(:) + !> 1) Query how many integers are needed to set the seed (compiler dependent!) + call random_seed(size=n) + !> 2) Allocate and assign a known pattern + allocate (seedArray(n)) + seedArray(:) = iseed + !> 3) Set the seed explicitly + call random_seed(put=seedArray) + deallocate (seedArray) + end subroutine RNG_seed + +!=========================================================================================! + + function mcaccept(mol,bh) result(accept) +!************************************** +!* The regular MC acceptance condition +!************************************** + implicit none + logical :: accept + type(coord),intent(in) :: mol + type(bh_class),intent(in) :: bh + real(wp) :: eold,enew,temp + real(wp) :: random,fact + accept = .false. + eold = bh%emin + enew = mol%energy + temp = bh%temp*kB !> Kelvin to a.u. + + if (enew .lt. eold) then + accept = .true. + else + call random_number(random) + fact = exp(-(enew-eold)/temp) + if (fact .gt. random) accept = .true. + end if + + end function mcaccept + +!=========================================================================================! + + subroutine mcduplicate(mol,bh,dupe,broken) +!***************************************************** +!* Check if a new structure (mol) is already in the +!* list of saved structures (bh%structures) +!***************************************************** + implicit none + type(coord),intent(in) :: mol + type(bh_class),intent(inout) :: bh + real(wp) :: rthr,ethr + logical,intent(out) :: dupe,broken + !> LOCAL + integer :: i,j,k,l,nat + type(canonical_sorter) :: newsort + real(wp) :: rmsdval,deltaE + logical :: topocheck + + dupe = .false. + broken = .false. + ethr = bh%ethr + rthr = bh%rthr + nat = mol%nat + topocheck = .true. + + if (debug) write (*,*) + + if (.not.allocated(bh%rcache)) then + if (debug) write (*,*) "allocating RCACHE" + !$omp critical + allocate (bh%rcache) + call bh%rcache%allocate(nat) + !$omp end critical + end if + + !$omp critical + call newsort%init(mol,invtype='apsp+',heavy=.false.) + !$omp end critical + + COMPARE: do i = 1,bh%saved + + !> Energy difference + deltaE = (mol%energy-bh%structures(i)%energy)*autokcal + + !> Geometry difference (permutation-invariant RMSD) + if (topocheck) then + bh%rcache%rank(1:nat,1) = newsort%rank(1:nat) + bh%rcache%rank(1:nat,2) = bh%sorters(i)%rank(1:nat) + end if + call min_rmsd(mol,bh%structures(i), & + & rcache=bh%rcache,rmsdout=rmsdval) + + if (debug) write (*,'(a,es15.4,a,es15.4,a)') 'RMSD=',rmsdval*autoaa, & + & ' Å, delta E=',deltaE,' kcal/mol' + + !> Check + if (abs(deltaE) .lt. ethr.and.rmsdval*autoaa .lt. rthr) then + dupe = .true. + if (deltaE < 0.0_wp) then + !> if the energy is lower, we replace the molecule (better conformation) + bh%structures(i) = mol + end if + exit COMPARE + end if + end do COMPARE + + !$omp critical + call newsort%deallocate() + !$omp end critical + end subroutine mcduplicate + + !========================================================================================! + + subroutine mcquench(calc,bh,tmpmol,optmol,iostat) + implicit none + !> Input + type(calcdata),intent(inout) :: calc !> potential settings + type(bh_class),intent(inout) :: bh !> BH settings + type(coord),intent(in) :: tmpmol !> molecular system + !> Output + type(coord),intent(out) :: optmol !> molecular system output + integer,intent(out) :: iostat + + iostat = 1 + + + end subroutine mcquench + + +!=========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<. +!================================================================================! + +module bh_step_module + use crest_parameters + use strucrd,only:coord + use crest_calculator + use bh_class_module + implicit none + private + + logical,parameter :: debug = .true. +! logical,parameter :: debug = .false. + + public :: takestep,steptypestr + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + function steptypestr(steptype) result(str) + implicit none + integer,intent(in) :: steptype + character(len=:),allocatable :: str + select case (steptype) + case default !> Cartesian + str = 'Cartesian' + case (1) !> natural internals + str = 'internal ' + case (2) !> dihedral only + str = 'dihedral ' + case (3) !> intermolecular (CMA,tilt) only + str = 'intermol ' + end select + end function steptypestr + +!=========================================================================================! + + subroutine takestep(mol,calc,bh,newmol) + implicit none + !> IN/OUTPUT + type(coord),intent(in) :: mol !> molecular system + type(calcdata),intent(inout) :: calc + type(bh_class),intent(inout) :: bh !> BH settings + type(coord),intent(out) :: newmol + !> LOCAL + + select case (bh%steptype) + case(0) !> Cartesian + newmol = mol + call takestep_cart(newmol,bh%stepsize(1),calc) + case default + error stop 'Steptype not implemented yet' + end select + + end subroutine takestep + +!=========================================================================================! + + subroutine takestep_cart(newmol,stepsize,calc) + implicit none + type(coord),intent(inout) :: newmol + real(wp),intent(in) :: stepsize + type(calcdata),intent(inout) :: calc + real(wp) :: r(3) + integer :: i + do i = 1,newmol%nat + if (calc%nfreeze > 0) then + if (calc%freezelist(i)) cycle + end if + call random_number(r) + r(:) = (r(:)-0.5_wp)*2.0_wp + newmol%xyz(:,i) = newmol%xyz(:,i)+r(:)*stepsize + end do + end subroutine takestep_cart + +!=========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< real64,stdout => output_unit use strucrd use calc_type - use iomod,only:makedir,directory_exist,remove + use iomod,only:makedir,directory_exist,remove,dump_array_to_tmp !> API modules use api_helpers use tblite_api @@ -63,7 +63,6 @@ subroutine tblite_engrad(mol,calc,energy,grad,iostatus) real(wp),intent(inout) :: grad(3,mol%nat) integer,intent(out) :: iostatus - character(len=:),allocatable :: cpath logical :: loadnew,pr integer :: i,j,k,l,ich,och,io @@ -76,25 +75,27 @@ subroutine tblite_engrad(mol,calc,energy,grad,iostatus) call tblite_init(calc,loadnew) !>--- tblite printout handling call api_handle_output(calc,'tblite.out',mol,pr) - if (pr .or. calc%prstdout) then + if (pr.or.calc%prstdout) then !> tblite uses its context (ctx) type, rather than calc%prch calc%tblite%ctx%unit = calc%prch calc%tblite%ctx%verbosity = 1 - if(calc%prstdout)then + if (calc%prstdout) then !> special case, fwd to stdout (be carefule with this!) calc%tblite%ctx%unit = stdout calc%tblite%ctx%verbosity = 2 - endif + end if else calc%tblite%ctx%verbosity = 0 end if !>-- populate parameters and wavefunction if (loadnew) then - call tblite_setup(mol,calc%chrg,calc%uhf,calc%tblitelvl,calc%etemp,calc%tblite) + call tblite_setup(mol,calc%chrg,calc%uhf,calc%tblitelvl,calc%etemp,calc%tblite,calc%ceh_guess) call tblite_addsettings(calc%tblite,calc%maxscc,calc%rdwbo,calc%saveint,calc%accuracy) + call tblite_add_efield(calc%tblite,calc%efield) + call tblite_add_solv(mol,calc%chrg,calc%uhf,calc%tblite, & & calc%solvmodel,calc%solvent) end if @@ -105,7 +106,7 @@ subroutine tblite_engrad(mol,calc,energy,grad,iostatus) call tblite_singlepoint(mol,calc%chrg,calc%uhf,calc%tblite, & & energy,grad,iostatus) if (iostatus /= 0) return - if(.not.calc%prstdout) & + if (.not.calc%prstdout) & & call api_print_e_grd(pr,calc%prch,mol,energy,grad) !>--- postprocessing, getting other data @@ -134,7 +135,6 @@ subroutine gfn0_engrad(mol,calc,g0calc,energy,grad,iostatus) integer,intent(out) :: iostatus !> LOCAL type(gfn0_results) :: res - character(len=:),allocatable :: cpath logical :: loadnew logical :: pr @@ -161,7 +161,7 @@ subroutine gfn0_engrad(mol,calc,g0calc,energy,grad,iostatus) if (iostatus /= 0) return if (pr) then call gfn0_print(calc%prch,g0calc,res) - if(.not.calc%prstdout) & + if (.not.calc%prstdout) & & call api_print_e_grd(pr,calc%prch,mol,energy,grad) end if @@ -191,7 +191,6 @@ subroutine gfn0occ_engrad(mol,calc,g0calc,energy,grad,iostatus) integer,intent(out) :: iostatus !> LOCAL type(gfn0_results) :: res - character(len=:),allocatable :: cpath logical :: loadnew,pr integer :: i,j,k,l,ich,och,io logical :: ex @@ -217,7 +216,7 @@ subroutine gfn0occ_engrad(mol,calc,g0calc,energy,grad,iostatus) if (iostatus /= 0) return if (pr) then call gfn0_print(calc%prch,g0calc,res) - if(.not.calc%prstdout) & + if (.not.calc%prstdout) & & call api_print_e_grd(pr,calc%prch,mol,energy,grad) end if @@ -243,13 +242,14 @@ subroutine gfnff_engrad(mol,calc,energy,grad,iostatus) real(wp),intent(inout) :: grad(3,mol%nat) integer,intent(out) :: iostatus - character(len=:),allocatable :: cpath logical :: loadnew,pr integer :: i,j,k,l,ich,och,io logical :: ex + character(len=:),allocatable :: tmpchrgs + real(wp),allocatable :: q(:) iostatus = 0 pr = .false. -!>--- setup system call information +!>--- setup calculation data !$omp critical call gfnff_init(calc,loadnew) !>--- printout handling @@ -257,7 +257,22 @@ subroutine gfnff_engrad(mol,calc,energy,grad,iostatus) !>--- populate parameters and neighbourlists if (loadnew) then + if (calc%ceh_guess) then + if(pr)then + write(calc%prch,'(/,a)') 'Initializing (fragement) charges from CEH model' + endif + !> A bit hacky and additional I/O, but would need adjusting submodule code otherwise + call tblite_quick_ceh_q(mol,q,calc%chrg,pr=pr,prch=calc%prch) + tmpchrgs = dump_array_to_tmp(q) + calc%ff_dat%refcharges = tmpchrgs + end if + call gfnff_api_setup(mol,calc%chrg,calc%ff_dat,iostatus,pr,calc%prch) + + if (calc%ceh_guess) then + call remove(tmpchrgs) + deallocate (q) + end if end if !$omp end critical if (iostatus /= 0) return @@ -270,7 +285,7 @@ subroutine gfnff_engrad(mol,calc,energy,grad,iostatus) !>--- printout if (pr) then call gfnff_printout(calc%prch,calc%ff_dat) - if(.not.calc%prstdout) & + if (.not.calc%prstdout) & & call api_print_e_grd(pr,calc%prch,mol,energy,grad) end if @@ -296,7 +311,6 @@ subroutine libpvol_engrad(mol,calc,energy,grad,iostatus) real(wp),intent(inout) :: grad(3,mol%nat) integer,intent(out) :: iostatus - character(len=:),allocatable :: cpath logical :: loadnew,pr integer :: i,j,k,l,ich,och,io logical :: ex @@ -324,7 +338,7 @@ subroutine libpvol_engrad(mol,calc,energy,grad,iostatus) !>--- printout if (pr) then !> the libpvol_sp call includes the printout within libpvol-lib - if(.not.calc%prstdout) & + if (.not.calc%prstdout) & & call api_print_e_grd(pr,calc%prch,mol,energy,grad) end if diff --git a/src/calculator/api_helpers.F90 b/src/calculator/api_helpers.F90 index 81ee45e0..0b1eccc7 100644 --- a/src/calculator/api_helpers.F90 +++ b/src/calculator/api_helpers.F90 @@ -21,7 +21,7 @@ module api_helpers use iso_fortran_env,only:wp => real64,stdout => output_unit use strucrd use calc_type - use iomod,only:makedir,directory_exist,remove + use iomod,only:makedir,directory_exist,remove,random_tmp_name !> APIs use tblite_api use gfn0_api @@ -390,6 +390,8 @@ subroutine libpvol_initcheck(calc,loadnew) #endif end subroutine libpvol_initcheck + + !========================================================================================! !========================================================================================! end module api_helpers diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 4a4ac077..01fdcddc 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -131,6 +131,7 @@ module calc_type logical :: getlmocent = .false. integer :: nprot = 0 real(wp),allocatable :: protxyz(:,:) + real(wp),allocatable :: efield(:) !> in V/Å !>--- API constructs integer :: tblitelvl = 2 @@ -151,6 +152,7 @@ module calc_type !>--- tblite data type(tblite_data),allocatable :: tblite character(len=:),allocatable :: tbliteparam + logical :: ceh_guess = .false. !>--- GFN0-xTB data type(gfn0_data),allocatable :: g0calc @@ -252,6 +254,7 @@ module calc_type logical :: tsopt = .false. integer :: iupdat = 0 !> 0=BFGS, 1=Powell, 2=SR1, 3=Bofill, 4=Schlegel integer :: opt_engine = 0 !> default: ANCOPT + integer :: lbfgs_histsize = 20 !> L-BFGS history size !>--- GFN0* data, needed for special MECP application type(gfn0_data),allocatable :: g0calc @@ -297,6 +300,8 @@ module calc_type procedure :: ONIOMexpand => calculation_ONIOMexpand procedure :: active => calc_set_active procedure :: active_restore => calc_set_active_restore + generic,public :: set_freeze => calculation_set_freeze_range,calculation_set_freeze_bools + procedure,private :: calculation_set_freeze_range,calculation_set_freeze_bools procedure :: freezegrad => calculation_freezegrad procedure :: increase_charge => calculation_increase_charge procedure :: decrease_charge => calculation_decrease_charge @@ -589,6 +594,33 @@ subroutine calculation_copy(self,src) end subroutine calculation_copy !=========================================================================================! + subroutine calculation_set_freeze_range(self,nat,start,finish) + class(calcdata) :: self + integer,intent(in) :: nat,start,finish + integer :: i,k + if (allocated(self%freezelist)) deallocate (self%freezelist) + allocate (self%freezelist(nat),source=.false.) + k = 0 + do i = 1,nat + + if (i >= start.and.i <= finish) then + k = k+1 + self%freezelist(i) = .true. + end if + end do + self%nfreeze = k + end subroutine calculation_set_freeze_range + + subroutine calculation_set_freeze_bools(self,freezetmp) + class(calcdata) :: self + logical,intent(in) :: freezetmp(:) + integer :: nat + if (allocated(self%freezelist)) deallocate (self%freezelist) + nat = size(freezetmp,1) + allocate (self%freezelist(nat),source=.false.) + self%nfreeze = count(freezetmp) + self%freezelist(:) = freezetmp(:) + end subroutine calculation_set_freeze_bools subroutine calculation_freezegrad(self,grad) class(calcdata) :: self @@ -1202,16 +1234,30 @@ end subroutine calculation_settings_info !=========================================================================================! - subroutine create_calclevel_shortcut(self,levelstring) + subroutine create_calclevel_shortcut(self,levelstring, & + & chrg,uhf,solvmodel,solvent) !********************************************************************* !* subroutine create_calclevel_shortcut called with %create(...) !* Set up a calculation_settings object for a given level of theory !* More shortcuts can be added as required. +!* +!* Optional settings are for: +!* - molecular charge (integer) +!* - uhf parameter (integer) +!* - solvent/solventmodel (either none or BOTH must be present to work) +!* !* Be careful about the intent(out) setting! +!* Also, the routine is "dumb" and does not check if the user-provided +!* settings actually make sense for a create_calclevel_shortcutation. It very much +!* exists as an internal code shortcut only. !********************************************************************* implicit none class(calculation_settings),intent(out) :: self - character(len=*) :: levelstring + character(len=*),intent(in) :: levelstring + integer,intent(in),optional :: chrg + integer,intent(in),optional :: uhf + character(len=*),intent(in),optional :: solvmodel + character(len=*),intent(in),optional :: solvent call self%deallocate() select case (trim(levelstring)) case ('gfnff','--gff','--gfnff') @@ -1244,6 +1290,29 @@ subroutine create_calclevel_shortcut(self,levelstring) self%id = jobtype%generic end select + + if (present(chrg)) then + self%chrg = chrg + end if + + if (present(uhf)) then + self%uhf = uhf + end if + + !> both must be present to work + if (present(solvmodel).and.present(solvent)) then + !> the first two if-cases exist to convert cli args + !> into sensible keywords (required for legacy compatibility) + if (index(solvmodel,'gbsa') .ne. 0) then + self%solvmodel = 'gbsa' + else if (index(solvmodel,'alpb') .ne. 0) then + self%solvmodel = 'alpb' + else + self%solvmodel = trim(solvmodel) + end if + self%solvent = trim(solvent) + end if + call self%autocomplete(self%id) end subroutine create_calclevel_shortcut diff --git a/src/calculator/rmsdpot.f90 b/src/calculator/rmsdpot.f90 new file mode 100644 index 00000000..e6996ef9 --- /dev/null +++ b/src/calculator/rmsdpot.f90 @@ -0,0 +1,75 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2025 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module rmsdpot + use strucrd + use iso_fortran_env,only:wp => real64 + + implicit none + private + + type :: rmsdbias + integer :: nbias = 0 + real(wp),allocatable :: alpha(:) + real(wp),allocatable :: kpush(:) + integer,allocatable :: mult(:) + type(coord),pointer :: ptr_structures(:) + end type rmsdbias + + public :: rmsdbias + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + subroutine rmsd_push_engrad(mol,rbias,energy,grad) +!************************************************************************* +!* Compute a repulsive energy and corresponding forces for +!* the similarity match between the currnt mol and a list of references +!************************************************************************* + implicit none + type(coord),intent(in) :: mol + type(rmsdbias) :: rbias + + real(wp),intent(inout) :: energy + real(wp),intent(inout) :: grad(3,mol%nat) + integer :: i,j,k,l + + real(wp) :: tmpe,ktot,rmssq + real(wp),allocatable :: tmpgrad(:,:) + + energy = 0.0_wp + grad = 0.0_wp + + do i=1,rbias%nbias + rmssq = 0.0_wp ** 2 + ktot = real(rbias%mult(i))*rbias%kpush(i)*real(mol%nat) + tmpe = ktot*exp(-rbias%alpha(i)*rmssq ) + + + enddo + + return + end subroutine rmsd_push_engrad + +!========================================================================================! +!========================================================================================! +end module rmsdpot diff --git a/src/calculator/tblite_api.F90 b/src/calculator/tblite_api.F90 index 34e72df4..a3a35697 100644 --- a/src/calculator/tblite_api.F90 +++ b/src/calculator/tblite_api.F90 @@ -23,14 +23,15 @@ !====================================================! module tblite_api - use iso_fortran_env,only:wp => real64,stdout => output_unit +! use iso_fortran_env,only:wp => real64,stdout => output_unit + use crest_parameters use strucrd #ifdef WITH_TBLITE use mctc_env,only:error_type use mctc_io,only:structure_type,new use tblite_context_type,only:tblite_ctx => context_type use tblite_wavefunction_type,only:wavefunction_type,new_wavefunction - use tblite_wavefunction,only:sad_guess,eeq_guess + use tblite_wavefunction,only:sad_guess,eeq_guess,shell_partition use tblite_xtb,xtb_calculator => xtb_calculator use tblite_xtb_calculator,only:new_xtb_calculator use tblite_param,only:param_record @@ -96,8 +97,10 @@ module tblite_api public :: tblite_setup,tblite_singlepoint,tblite_addsettings public :: tblite_getwbos public :: tblite_add_solv + public :: tblite_add_efield public :: tblite_getcharges public :: tblite_getdipole + public :: tblite_quick_ceh_q !========================================================================================! !========================================================================================! @@ -105,7 +108,7 @@ module tblite_api !========================================================================================! !========================================================================================! - subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite) + subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite,ceh_guess) !***************************************************************** !* subroutine tblite_setup initializes the tblite object which is !* passed between the CREST calculators and this module @@ -117,6 +120,7 @@ subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite) type(tblite_data),intent(inout) :: tblite integer,intent(in) :: lvl real(wp),intent(in) :: etemp + logical,intent(in),optional :: ceh_guess #ifdef WITH_TBLITE type(structure_type) :: mctcmol type(error_type),allocatable :: error @@ -136,22 +140,22 @@ subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite) tblite%lvl = lvl select case (tblite%lvl) case (xtblvl%gfn1) - if (pr) call tblite%ctx%message("tblite> setting up GFN1-xTB calculation") + if (pr) call tblite%ctx%message("tblite> Setting up GFN1-xTB calculation") call new_gfn1_calculator(tblite%calc,mctcmol,error) case (xtblvl%gfn2) - if (pr) call tblite%ctx%message("tblite> setting up GFN2-xTB calculation") + if (pr) call tblite%ctx%message("tblite> Setting up GFN2-xTB calculation") call new_gfn2_calculator(tblite%calc,mctcmol,error) case (xtblvl%ipea1) - if (pr) call tblite%ctx%message("tblite> setting up IPEA1-xTB calculation") + if (pr) call tblite%ctx%message("tblite> Setting up IPEA1-xTB calculation") call new_ipea1_calculator(tblite%calc,mctcmol,error) case (xtblvl%ceh) - if (pr) call tblite%ctx%message("tblite> setting up CEH calculation") + if (pr) call tblite%ctx%message("tblite> Setting up CEH calculation") call new_ceh_calculator(tblite%calc,mctcmol,error) case (xtblvl%eeq) - if (pr) call tblite%ctx%message("tblite> setting up D4 EEQ charges calculation") + if (pr) call tblite%ctx%message("tblite> Setting up D4 EEQ charges calculation") call new_ceh_calculator(tblite%calc,mctcmol,error) !> doesn't matter but needs initialization case (xtblvl%param) - if (pr) call tblite%ctx%message("tblite> setting up xtb calculator from parameter file") + if (pr) call tblite%ctx%message("tblite> Setting up xtb calculator from parameter file") if (allocated(tblite%paramfile)) then call tblite_read_param_record(tblite%paramfile,param,io) call new_xtb_calculator(tblite%calc,mctcmol,param,error) @@ -167,11 +171,15 @@ subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite) call tblite%ctx%message("Error: Unknown method in tblite!") error stop end select + if (pr) call tblite%ctx%message('') !>-- setup wavefunction object etemp_au = etemp*ktoau call new_wavefunction(tblite%wfn,mol%nat,tblite%calc%bas%nsh, & & tblite%calc%bas%nao,1,etemp_au) + if (ceh_guess) then + call tblite_internal_ceh_guess(mctcmol,tblite) + end if #else /* WITH_TBLITE */ write (stdout,*) 'Error: Compiled without tblite support!' @@ -226,7 +234,7 @@ subroutine tblite_add_solv(mol,chrg,uhf,tblite,smodel,solvent) end if select case (tblite%lvl) case (xtblvl%gfn1) - method ='gfn1' + method = 'gfn1' case (xtblvl%gfn2) method = 'gfn2' end select @@ -251,19 +259,19 @@ subroutine tblite_add_solv(mol,chrg,uhf,tblite,smodel,solvent) case ('gbsa') if (pr) call tblite%ctx%message("tblite> using GBSA/"//solvdum) alpb_tmp%dielectric_const = solv_data%eps - alpb_tmp%alpb=.false. + alpb_tmp%alpb = .false. !alpb_tmp%method=method - alpb_tmp%solvent=solv_data%solvent + alpb_tmp%solvent = solv_data%solvent !alpb_tmp%xtb=.true. - allocate (solv_inp%alpb, source=alpb_tmp) - cds_tmp%alpb=.false. - cds_tmp%solvent=solv_data%solvent - !cds_tmp%method=method - allocate (solv_inp%cds, source=cds_tmp) - shift_tmp%alpb=.false. - shift_tmp%solvent=solv_data%solvent + allocate (solv_inp%alpb,source=alpb_tmp) + cds_tmp%alpb = .false. + cds_tmp%solvent = solv_data%solvent + !cds_tmp%method=method + allocate (solv_inp%cds,source=cds_tmp) + shift_tmp%alpb = .false. + shift_tmp%solvent = solv_data%solvent !shift_tmp%method=method - allocate (solv_inp%shift, source=shift_tmp) + allocate (solv_inp%shift,source=shift_tmp) case ('cpcm') if (pr) call tblite%ctx%message("tblite> using CPCM/"//solvdum) allocate (solv_inp%cpcm) @@ -271,27 +279,27 @@ subroutine tblite_add_solv(mol,chrg,uhf,tblite,smodel,solvent) case ('alpb') if (pr) call tblite%ctx%message("tblite> using ALPB/"//solvdum) alpb_tmp%dielectric_const = solv_data%eps - alpb_tmp%alpb=.true. + alpb_tmp%alpb = .true. !alpb_tmp%method=method - alpb_tmp%solvent=solv_data%solvent + alpb_tmp%solvent = solv_data%solvent !alpb_tmp%xtb=.true. - allocate (solv_inp%alpb, source=alpb_tmp) - cds_tmp%alpb=.true. - cds_tmp%solvent=solv_data%solvent - !cds_tmp%method=method - allocate (solv_inp%cds, source=cds_tmp) - shift_tmp%alpb=.true. - shift_tmp%solvent=solv_data%solvent + allocate (solv_inp%alpb,source=alpb_tmp) + cds_tmp%alpb = .true. + cds_tmp%solvent = solv_data%solvent + !cds_tmp%method=method + allocate (solv_inp%cds,source=cds_tmp) + shift_tmp%alpb = .true. + shift_tmp%solvent = solv_data%solvent !shift_tmp%method=method - allocate (solv_inp%shift, source=shift_tmp) + allocate (solv_inp%shift,source=shift_tmp) case default if (pr) call tblite%ctx%message("tblite> Unknown tblite implicit solvation model!") return end select - str = 'tblite> WARNING: implicit solvation energies are not entirely '// & - &'consistent with the xtb implementation.' - if (pr) call tblite%ctx%message(str) + !str = 'tblite> WARNING: implicit solvation energies are not entirely '// & + !&'consistent with the xtb implementation.' + !if (pr) call tblite%ctx%message(str) !>--- add electrostatic (Born part) to calculator call new_solvation(solv,mctcmol,solv_inp,error,method) @@ -444,6 +452,37 @@ subroutine tblite_addsettings(tblite,maxscc,rdwbo,saveint,accuracy) #endif end subroutine tblite_addsettings + subroutine tblite_add_efield(tblite,efield) +!********************************************************** +!* tblite_add_efield +!* if efield is allocated, add it to the tblite calculator +!********************************************************** +#ifdef WITH_TBLITE + use tblite_container,only:container_type + use tblite_external_field,only:electric_field +#endif + implicit none + type(tblite_data),intent(inout) :: tblite + real(wp),intent(in),allocatable :: efield(:) + class(container_type),allocatable :: cont + logical :: pr + character(len=90) :: str +#ifdef WITH_TBLITE + pr = (tblite%ctx%verbosity > 0) + if (allocated(efield)) then + if (pr) then + write (str,'(a,3(es10.3),a)') "tblite> Calculation includes the following electric field:" + call tblite%ctx%message(trim(str)) + write (str,'(8x, a,3(es15.5,1x),a)') "[",efield,"] V/Å" + call tblite%ctx%message(trim(str)) + call tblite%ctx%message('') + end if + cont = electric_field(efield*vatoau) + call tblite%calc%push_back(cont) + end if +#endif + end subroutine tblite_add_efield + !========================================================================================! subroutine tblite_getwbos(tblite,nat,wbo) @@ -565,6 +604,136 @@ subroutine tblite_read_param_record(paramfile,param,io) end subroutine tblite_read_param_record #endif +!========================================================================================! + +#ifdef WITH_TBLITE + subroutine tblite_internal_ceh_guess(mctcmol,tblite) + !********************************************************* + !* Init the tblite calculator with a set of CEH charges + !********************************************************* + implicit none + type(tblite_data),intent(inout) :: tblite + type(structure_type),intent(in) :: mctcmol + !> LOCAL + type(wavefunction_type) :: wfn_ceh + type(xtb_calculator) :: calc_ceh + type(error_type),allocatable :: error + integer :: verbosity + logical :: pr + real(wp),parameter :: etemp_guess_au = 4000.0_wp*ktoau + + !> if we only do a eeq or ceh calc, we don't need this, so return + select case (tblite%lvl) + case default + continue + case (xtblvl%ceh,xtblvl%eeq) + return + end select + + pr = (tblite%ctx%verbosity > 0) + if (tblite%ctx%verbosity > 1) then + verbosity = tblite%ctx%verbosity + else + verbosity = 0 + end if + + !> ceh guess calculator and wavefunction + call new_ceh_calculator(calc_ceh,mctcmol,error) + if (allocated(error)) return + call new_wavefunction(wfn_ceh,mctcmol%nat,calc_ceh%bas%nsh, & + & calc_ceh%bas%nao,1,etemp_guess_au) + + !> TODO ceh guess efield + + call ceh_singlepoint(tblite%ctx,calc_ceh,mctcmol,wfn_ceh, & + & tblite%accuracy,verbosity) + + if (tblite%ctx%failed()) then + if (pr) then + call tblite%ctx%get_error(error) + call tblite%ctx%message("CEH singlepoint calculation failed") + call tblite%ctx%message("-> "//error%message) + end if + return + end if + + !> pass on to actual calculator + tblite%wfn%qat(:,1) = wfn_ceh%qat(:,1) + call shell_partition(mctcmol,tblite%calc,tblite%wfn) + + end subroutine tblite_internal_ceh_guess +#endif + +!========================================================================================! + + subroutine tblite_quick_ceh_q(mol,q,chrg,uhf,pr,prch) + !********************************************************* + !* Calculate CEH charges + !********************************************************* + implicit none + type(coord),intent(in) :: mol + integer,intent(in) :: chrg + real(wp),intent(out),allocatable :: q(:) + integer,intent(in),optional :: uhf + logical,intent(in),optional :: pr + integer,intent(in),optional :: prch +#ifdef WITH_TBLITE + type(structure_type) :: mctcmol + !> LOCAL + type(wavefunction_type) :: wfn_ceh + type(xtb_calculator) :: calc_ceh + type(tblite_ctx) :: ctx + type(error_type),allocatable :: error +#endif + integer :: verbosity,uhf_loc + logical :: pr_loc + real(wp),parameter :: etemp_guess_au = 4000.0_wp*ktoau + real(wp),parameter :: accuracy=1.0_wp + + pr_loc = .false. + if(present(pr)) pr_loc = pr + verbosity = 0 + if(pr_loc) verbosity = 2 + + allocate(q(mol%nat), source=0.0_wp) + +#ifdef WITH_TBLITE + uhf_loc = 0 + if (present(uhf)) uhf_loc = uhf + if(present(prch)) ctx%unit=prch + + !>--- make an mctcmol object from mol + call tblite_mol2mol(mol,chrg,uhf_loc,mctcmol) + + !> ceh guess calculator and wavefunction + call new_ceh_calculator(calc_ceh,mctcmol,error) + if (allocated(error)) return + call new_wavefunction(wfn_ceh,mctcmol%nat,calc_ceh%bas%nsh, & + & calc_ceh%bas%nao,1,etemp_guess_au) + + !> TODO ceh guess efield + + call ceh_singlepoint(ctx,calc_ceh,mctcmol,wfn_ceh, & + & accuracy,verbosity) + + if (ctx%failed()) then + if (pr_loc) then + call ctx%get_error(error) + call ctx%message("CEH singlepoint calculation failed") + call ctx%message("-> "//error%message) + end if + return + end if + + !> pass on the charges + q(:) = wfn_ceh%qat(:,1) +#else /* WITH_TBLITE */ + write (stdout,*) 'Error: Compiled without tblite support!' + write (stdout,*) 'Use -DWITH_TBLITE=true in the setup to enable this function' + error stop +#endif + end subroutine tblite_quick_ceh_q + !========================================================================================! !========================================================================================! end module tblite_api diff --git a/src/choose_settings.f90 b/src/choose_settings.f90 index 901d5d7d..13c38b29 100644 --- a/src/choose_settings.f90 +++ b/src/choose_settings.f90 @@ -30,17 +30,17 @@ subroutine md_length_setup(env) use crest_parameters use crest_data use strucrd - use zdata, only:readwbo + use zdata,only:readwbo implicit none !> IN/OUTPUT type(systemdata) :: env !> MAIN STORAGE OS SYSTEM DATA !> LOCAL real(wp) :: total,minimum,lenthr real(wp) :: flex,av1,rfac,nciflex - type(coord) :: mol + type(coord) :: mol logical :: ex -!> get reference geometry - call env%ref%to( mol ) +!> get reference geometry + call env%ref%to(mol) !> at least 5ps per MTD minimum = 5.0d0 @@ -50,19 +50,19 @@ subroutine md_length_setup(env) call smallhead('Generating MTD length from a flexibility measure') if ((env%crestver .ne. crest_solv).and..not.env%NCI) then - write(stdout,'(1x,a)',advance='no') 'Calculating GFN0-xTB WBOs ...' + write (stdout,'(1x,a)',advance='no') 'Calculating GFN0-xTB WBOs ...' !>-- xtb singlepoint to get WBOs (always GFN0) call xtbsp(env,0) write (stdout,'(1x,a)') 'done.' !>-- save those WBOs to the reference - inquire(file='wbo',exist = ex) - if(ex)then - if(.not.allocated(env%ref%wbo)) allocate(env%ref%wbo( mol%nat, mol%nat), source=0.0_wp) - call readwbo('wbo',mol%nat, env%ref%wbo) - endif + inquire (file='wbo',exist=ex) + if (ex) then + if (.not.allocated(env%ref%wbo)) allocate (env%ref%wbo(mol%nat,mol%nat),source=0.0_wp) + call readwbo('wbo',mol%nat,env%ref%wbo) + end if !>-- covalent flexibility measure based on WBO and structure only - call flexi( mol, env%rednat, env%includeRMSD, flex) + call flexi(mol,env%rednat,env%includeRMSD,flex) !>-- NCI flexi based on E(HB)/Nat and E(disp)/Nat call nciflexi(env,nciflex) write (stdout,'(1x,'' covalent flexibility measure :'',f8.3)') flex @@ -118,9 +118,9 @@ subroutine md_length_setup(env) !>-- ONLY use generated MD length if not already set by the user if (env%mdtime .le. 0.0d0) then - if(env%mddat%length_ps > 0.0_wp)then + if (env%mddat%length_ps > 0.0_wp) then total = env%mddat%length_ps - write(stdout,'(1x,"t(MTD) / ps set via calculator :", f8.1)') total + write (stdout,'(1x,"t(MTD) / ps set via calculator :", f8.1)') total else if (total .gt. lenthr) then total = lenthr call mtdwarning(lenthr*rfac) @@ -135,9 +135,9 @@ subroutine md_length_setup(env) & env%mdtime*float(env%nmetadyn),env%nmetadyn !> A MTD Vbias snapshot is taken every 1 ps - if(allocated(env%metadlist))then + if (allocated(env%metadlist)) then env%metadlist(:) = ceiling(env%mdtime) - endif + end if return end subroutine md_length_setup @@ -149,7 +149,7 @@ subroutine defaultGF(env) !* Setmetadynamics default Guiding Force Parameter !* There are different combinations depending on the runtype !************************************************************ - use crest_parameters + use crest_parameters use crest_data use filemod implicit none @@ -200,7 +200,7 @@ subroutine defaultGF(env) !+++++++++++++++++++++++++++++++++++++++++++++++++++++++! select case (env%runver) !---------- "-quick","-squick" - case (2,5) + case (2,5) na = 3 nk = 2 nmtdyn = na*nk @@ -209,7 +209,7 @@ subroutine defaultGF(env) alpinc = 2.0 ! increment kinc = 2.0 ! increment !---------- "-mquick" - case (6) + case (6) na = 3 nk = 2 nmtdyn = na*nk @@ -218,7 +218,7 @@ subroutine defaultGF(env) alpinc = 2.0 ! increment kinc = 2.0 ! increment !---------- "-qcg" - case (3) + case (3) na = 4 nk = 3 nmtdyn = na*nk @@ -227,7 +227,7 @@ subroutine defaultGF(env) alpinc = (3./2.) ! increment kinc = (3./2.) ! increment !---------- "-nci" - case (4) + case (4) na = 3 nk = 2 nmtdyn = na*nk @@ -236,7 +236,7 @@ subroutine defaultGF(env) alpinc = 2.0 ! increment kinc = 2.0 ! increment !---------- "-singlerun" - case (45) + case (45) na = 1 nk = 1 nmtdyn = na*nk @@ -254,7 +254,7 @@ subroutine defaultGF(env) alpinc = 2.0 ! increment kinc = 2.0 ! increment !---------- "-compress" - case (77) + case (77) na = 3 nk = 3 nmtdyn = na*nk @@ -263,7 +263,7 @@ subroutine defaultGF(env) alpinc = 1.61803 ! increment kinc = 2.0 ! increment !--------- "search_1" - case (crest_s1,crest_mecp) + case (crest_s1,crest_mecp) na = 3 nk = 3 nmtdyn = (na*nk) @@ -280,7 +280,7 @@ subroutine defaultGF(env) alpinc = (5./3.) ! increment kinc = 1.5d0 ! increment !---------- "-entropy" - case (111) + case (111) na = 6 nk = 4 nmtdyn = (na*nk) @@ -395,13 +395,13 @@ subroutine adjustnormmd(env) !>--- first the number of normMDs on low conformers if (env%nrotammds .le. 0) then !> if no user input was set !> multiple short MDs, which has a better parallel efficiency - !> default is 4 - env%nrotammds = max(1,nint(float(env%nmetadyn)/4.0d0)) + !> default is 4 + env%nrotammds = max(1,nint(float(env%nmetadyn)/4.0d0)) end if !>--- then the temperature range if (env%temps .le. 0) then - !> at how many different temperatures? + !> at how many different temperatures? !> starting at 400k and increasing 100K for each (200 K for -entropy mode) env%temps = 2 if (env%entropic) then @@ -414,7 +414,7 @@ subroutine adjustnormmd(env) !==============================================! !>--- settings for static MTDS in entropy mode !==============================================! - if (env%entropymd) then + if (env%entropymd) then env%emtd%iter = 20 !> max number of iterations env%emtd%nbias = min(150,nint(env%tmtd/4)) !> max number of bias structures env%emtd%nbiasgrow = min(1.4d0,1.2d0+env%tmtd*1.d-3) !> increase of nBias in each cycle @@ -476,55 +476,71 @@ subroutine env_to_mddat(env) implicit none type(systemdata) :: env real(wp) :: dum + integer :: i,j,nat !!>--- dont override user-defined settings ! if(env%mddat%requested) return !> we will check if any default settings were already set individually, instead !> the if-statements in the following take care of that !>--- necessary transfer global settings into mddat object - if(env%mddat%length_ps <= 0.0_wp)then - !> total runtime in ps - env%mddat%length_ps = env%mdtime - else - env%mdtime = env%mddat%length_ps - endif - if(env%mddat%tstep <= 0.0_wp)then - !> time step in fs - env%mddat%tstep = env%mdstep - endif - !> simulation steps (would be recovered automatically later, but just to make sure) - env%mddat%length_steps = nint(env%mddat%length_ps*1000.0_wp / env%mddat%tstep) - if(env%mddat%tsoll <= 0.0_wp)then - !> target temperature - env%mddat%tsoll = env%mdtemp - endif - - if( env%mddat%dumpstep <= 0.0_wp ) then - !> dump frequency in fs - env%mddat%dumpstep = float(env%mddumpxyz) - endif - if(env%mddat%sdump <= 0)then - !> trajectory structure dump every x steps - dum = max(1.0_wp, (env%mddat%dumpstep / env%mddat%tstep)) - env%mddat%sdump = nint(dum) - endif - - !> The SHAKE setup (special condition referring to the default) - env%mddat%shake = env%mddat%shake .and.(env%shake > 0) !> SHAKE algorithm? - if( env%mddat%shake .and. env%mddat%shk%shake_mode == 0)then - env%mddat%shk%shake_mode = env%shake !> H-only shake =1, all atom =2 - endif - - if(env%mddat%md_hmass <= 0.0_wp)then - !> hydrogen mass (to enable longer timesteps) - env%mddat%md_hmass = env%hmass - endif - - ! TODO: WBO reader if shake is applied and wbo file is present + if (env%mddat%length_ps <= 0.0_wp) then + !> total runtime in ps + env%mddat%length_ps = env%mdtime + else + env%mdtime = env%mddat%length_ps + end if + if (env%mddat%tstep <= 0.0_wp) then + !> time step in fs + env%mddat%tstep = env%mdstep + end if + !> simulation steps (would be recovered automatically later, but just to make sure) + env%mddat%length_steps = nint(env%mddat%length_ps*1000.0_wp/env%mddat%tstep) + if (env%mddat%tsoll <= 0.0_wp) then + !> target temperature + env%mddat%tsoll = env%mdtemp + end if + + if (env%mddat%dumpstep <= 0.0_wp) then + !> dump frequency in fs + env%mddat%dumpstep = real(env%mddumpxyz,wp) + end if + if (env%mddat%sdump <= 0) then + !> trajectory structure dump every x steps + dum = max(1.0_wp, (env%mddat%dumpstep/env%mddat%tstep)) + env%mddat%sdump = nint(dum) + end if + + !> The SHAKE setup (special condition referring to the default) + env%mddat%shake = env%mddat%shake.and.(env%shake > 0) !> SHAKE algorithm? + if (env%mddat%shake.and.env%mddat%shk%shake_mode == 0) then + env%mddat%shk%shake_mode = env%shake !> H-only shake =1, all atom =2 + end if + + if (env%mddat%md_hmass <= 0.0_wp) then + !> hydrogen mass (to enable longer timesteps) + env%mddat%md_hmass = env%hmass + end if + + if (allocated(env%mddat%mtd)) then + nat = env%ref%nat + if (sum(env%includeRMSD) < nat) then + do i = 1,env%mddat%npot + if (.not.allocated(env%mddat%mtd(i)%atinclude)) then + allocate (env%mddat%mtd(i)%atinclude(nat),source=.false.) + else + env%mddat%mtd(i)%atinclude = .false. + end if + do j = 1,nat + if (env%includeRMSD(j) == 1) env%mddat%mtd(i)%atinclude(j) = .true. + end do + end do + end if + end if + + ! TODO: WBO reader if shake is applied and wbo file is present !>--- set flag to signal present settings env%mddat%requested = .true. end subroutine env_to_mddat - diff --git a/src/classes.f90 b/src/classes.f90 index 53050cb2..93bcd63e 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -25,15 +25,16 @@ module crest_data use iso_fortran_env,wp => real64,dp => int64 use crest_calculator,only:calcdata use dynamics_module,only:mddata + use bh_module,only:bh_class use strucrd,only:coord use crest_type_timer,only:timer - use lwoniom_module, only: lwoniom_input + use lwoniom_module,only:lwoniom_input implicit none public :: systemdata public :: timer !> RE-EXPORT from crest_type_timer public :: protobj - public :: constra + public :: legacy_constraints public :: optlevflag,optlevnum,optlevmap_alt public :: optlev_to_multilev @@ -74,6 +75,7 @@ module crest_data integer,parameter,public :: crest_protonate = 16 integer,parameter,public :: crest_deprotonate = 17 integer,parameter,public :: crest_tautomerize = 18 + integer,parameter,public :: crest_sorting = 19 !>> runtypes with IDs between use non-legacy routines <> < success integer,parameter,public :: status_error = 1 !> general error integer,parameter,public :: status_ioerr = 2 !> general I/O error - integer,parameter,public :: status_args = 4 !> invalid subroutine arguments + integer,parameter,public :: status_args = 4 !> invalid subroutine arguments integer,parameter,public :: status_input = 10 !> Input file read error integer,parameter,public :: status_config = 20 !> invalid configuration integer,parameter,public :: status_failed = 155 !> general calculation failure @@ -139,7 +143,7 @@ module crest_data !========================================================================================! !========================================================================================! - type :: constra + type :: legacy_constraints !**************************************************** !* separate settings for LEGACY constraint handling !**************************************************** @@ -169,9 +173,10 @@ module crest_data logical :: usermsdpot = .false. logical :: gesc_heavy = .false. contains - procedure :: allocate => allocate_constraints - procedure :: deallocate => deallocate_constraints - end type constra + procedure :: allocate => allocate_legacy_constraints + procedure :: deallocate => deallocate_legacy_constraints + procedure :: info => legacy_constraints_info + end type legacy_constraints !========================================================================================! @@ -179,7 +184,7 @@ module crest_data !************************************************************ !* separate settings for protonation and related procedures !************************************************************ - integer :: nfrag = 0 + integer :: nfrag = 0 integer :: newchrg = 0 integer :: iter = 1 real(wp) :: ewin = 30.0_wp !> separate EWIN threshold @@ -285,7 +290,7 @@ module crest_data integer :: pcap = 50000 !> limit number of structures logical :: avbhess = .false. !> use bhess in the msRRHO average calc. for all structures (expensive!) logical :: constrhess = .false. !> apply constraints in rrhoav? - logical :: printpop = .false. !> print a file with populations at different T + logical :: printpop = .false. !> print a file with populations at different T contains procedure :: get_temps => thermo_get_temps procedure :: read_temps => thermo_read_temps @@ -307,7 +312,9 @@ module crest_data integer,allocatable :: topo(:) real(wp),allocatable :: charges(:) real(wp),allocatable :: wbo(:,:) + real(wp),allocatable :: efield(:) contains + procedure :: init => ref_init procedure :: rdcharges => read_charges procedure :: to => ref_to_mol procedure :: load => ref_load_mol @@ -343,6 +350,7 @@ module crest_data real(wp) :: pthrsum real(wp) :: tboltz logical :: cgf(6) !> collection of CREGEN options + integer :: iinversion = 0 !> 0=auto,1=on, 2=off real(wp) :: mdtemps(10) !> different temperatures for the QMDFF-MDs in V1 real(wp) :: mdtime !> MD length (V1&2) @@ -378,24 +386,25 @@ module crest_data logical :: omp_allow_nested = .true. !> allow nested OpenMP threadding !>--- various names and flags - character(len=128) :: ensemblename !> ensemble input name for SCREEN,MDOPT and CREGEN - character(len=128) :: ensemblename2 !> another ensemble input name - character(len=128) :: fixfile - character(len=512) :: constraints !> name of the constraint file - character(len=20) :: solvent !> the solvent + character(len=128) :: ensemblename = '' !> ensemble input name for SCREEN,MDOPT and CREGEN + character(len=128) :: ensemblename2 = '' !> another ensemble input name + character(len=128) :: fixfile = '' + character(len=512) :: constraints = '' !> name of the constraint file + character(len=20) :: solvent = '' !> the solvent character(len=:),allocatable :: solv !> the entrie gbsa flag including solvent - character(len=20) :: gfnver !> GFN version - character(len=20) :: gfnver2 !> GFN version (multilevel) - character(len=20) :: lmover !> GFN version for LMO computation in xtb_lmo subroutine - character(len=512) :: ProgName !> name of the xtb executable (+ path) - character(len=512) :: ProgIFF !> name of xtbiff for QCG-mode - character(len=512) :: homedir !> original directory from which calculation was started - character(len=512) :: scratchdir !> path to the scratch directory + character(len=20) :: gfnver = '' !> GFN version + character(len=20) :: gfnver2 = '' !> GFN version (multilevel) + character(len=20) :: lmover = '' !> GFN version for LMO computation in xtb_lmo subroutine + character(len=512) :: ProgName = '' !> name of the xtb executable (+ path) + character(len=512) :: ProgIFF = '' !> name of xtbiff for QCG-mode + character(len=512) :: homedir = '' !> original directory from which calculation was started + character(len=512) :: scratchdir = '' !> path to the scratch directory character(len=:),allocatable :: cmd character(len=:),allocatable :: inputcoords character(len=:),allocatable :: wbofile character(len=:),allocatable :: atlist character(len=:),allocatable :: chargesfilename + character(len=:),allocatable :: sortmode !>--- METADYN data real(wp) :: hmass @@ -430,11 +439,11 @@ module crest_data type(protobj) :: protb !>--- saved constraints - type(constra) :: cts + type(legacy_constraints) :: cts !>--- NCI mode data real(wp) :: potscal = 1.0_wp - real(wp) :: potpad = 0.0_wp + real(wp) :: potpad = 0.0_wp character(len=:),allocatable :: potatlist !>--- Nanoreactor data @@ -458,11 +467,11 @@ module crest_data integer :: nqcgclust = 0 !> Number of cluster to be taken integer :: max_solv = 0 !> Maximal number of solvents added, if none is given integer :: ensemble_method = -1 !> Default -1 for qcgmtd, 0= crest, 1= standard MD, 2= MTD - character(len=:), allocatable :: directed_file !name of the directed list - character(len=64), allocatable :: directed_list(:,:) !How many solvents at which atom to add - integer, allocatable :: directed_number(:) !Numbers of solvents added per defined atom - character(len=20) :: ensemble_opt !> Method for ensemble optimization in qcg mode - character(len=20) :: freqver !> Method for frequency computation in qcg mode + character(len=:),allocatable :: directed_file !name of the directed list + character(len=64),allocatable :: directed_list(:,:) !How many solvents at which atom to add + integer,allocatable :: directed_number(:) !Numbers of solvents added per defined atom + character(len=20) :: ensemble_opt = '' !> Method for ensemble optimization in qcg mode + character(len=20) :: freqver = '' !> Method for frequency computation in qcg mode real(wp) :: freq_scal !> Frequency scaling factor character(len=:),allocatable :: solu_file,solv_file !> solute and solvent input file character(len=5) :: docking_qcg_flag = '--qcg' @@ -498,6 +507,7 @@ module crest_data !>--- Calculation settings for newer implementations (version >= 3.0) type(calcdata) :: calc type(mddata) :: mddat + type(bh_class),allocatable :: bh_ref !>--- rigidconf data integer :: rigidconf_algo = 0 integer :: rigidconf_toposource = 0 @@ -510,14 +520,14 @@ module crest_data !================================================! !>--- msreact mode settings - logical :: msei =.true. ! use the ei mode as default - logical :: mscid =.false. ! use the cid mode - logical :: msnoiso =.false. ! print only dissociated structures in msreact - logical :: msiso =.false. ! only print non-dissociated structures in msreact - logical :: msmolbar =.false. ! sort out duplicates by molbar - logical :: msinchi =.false. ! sort out duplicates by inchi - logical :: mslargeprint=.false. ! dont remove temporary files - logical :: msattrh=.true. ! add attractive potential for H-atoms + logical :: msei = .true. ! use the ei mode as default + logical :: mscid = .false. ! use the cid mode + logical :: msnoiso = .false. ! print only dissociated structures in msreact + logical :: msiso = .false. ! only print non-dissociated structures in msreact + logical :: msmolbar = .false. ! sort out duplicates by molbar + logical :: msinchi = .false. ! sort out duplicates by inchi + logical :: mslargeprint = .false. ! dont remove temporary files + logical :: msattrh = .true. ! add attractive potential for H-atoms integer :: msnbonds = 3 ! distance of bonds up to nonds are stretched integer :: msnshifts = 0 ! number of random shifts applied to whole mol integer :: msnshifts2 = 0 ! number of random shifts applied to whole mol @@ -531,6 +541,7 @@ module crest_data logical :: autozsort !> do the ZSORT in the beginning ? logical :: allowrestart = .true. !> allow restart in crest algos? logical :: better !> found a better conformer and restart in V1 + logical :: ceh_guess = .false. !> use CEH guess in tblite or gfnff, if available logical :: cff !> CFF used in QCG-energy calculation logical :: cluster = .false. !> perform a clustering analysis logical :: checktopo = .true. !> perform topolgy check in CREGEN @@ -553,6 +564,7 @@ module crest_data logical :: fullcre = .false. !> calculate exact rotamer degeneracies logical :: gbsa !> use gbsa logical :: gcmultiopt !> 2 level optimization for GC in V2 + logical :: gradsp = .true. !> turn on/off gradient calculation in singlepoint logical :: heavyrmsd = .false. !> use only heavy atoms for RMSD in CREGEN? logical :: inplaceMode = .true. !> in-place mode: optimization dirs are created "on-the-fly" logical :: iterativeV2 !> iterative version of V2 (= V3) @@ -562,7 +574,7 @@ module crest_data logical :: legacy = .false. !> switch between the original system call routines of crest and newer, e.g. tblite implementations logical :: metadynset !> is the number of MTDs already set (V2) ? logical :: methautocorr !> try to automatically include Methyl equivalencies in CREGEN ? - logical :: multilevelopt =.true. !> perform the multileveloptimization + logical :: multilevelopt = .true. !> perform the multileveloptimization logical :: newcregen = .false. !> use the CREGEN rewrite logical :: NCI !> NCI special usage logical :: niceprint !> make a nice progress-bar printout @@ -594,7 +606,7 @@ module crest_data logical :: riso = .false. !> take only isomers in reactor mode logical :: rotamermds !> do additional MDs after second multilevel OPT step in V2 ? logical :: refine_presort = .false. !> run CREGEN at the beginning of crest_refine? - logical :: refine_esort = .false. !> if CREGEN is run after crest_refine, only sort energy? + logical :: refine_esort = .false. !> if CREGEN is run after crest_refine, only sort energy? logical :: sameRandomNumber = .false. !> QCG related, choose same random number for iff logical :: scallen !> scale the automatically determined MD length by some factor? logical :: scratch !> use scratch directory @@ -652,7 +664,6 @@ subroutine allocate_metadyn(self,n) end if return end subroutine allocate_metadyn -!========================================================================================! subroutine deallocate_metadyn(self) implicit none class(systemdata) :: self @@ -661,23 +672,56 @@ subroutine deallocate_metadyn(self) if (allocated(self%metadlist)) deallocate (self%metadlist) end subroutine deallocate_metadyn !========================================================================================! - subroutine allocate_constraints(self,n) + subroutine allocate_legacy_constraints(self,n) implicit none - class(constra) :: self + class(legacy_constraints) :: self integer,intent(in) :: n self%ndim = n allocate (self%sett(n)) allocate (self%buff(n)) self%sett = '' self%buff = '' - end subroutine allocate_constraints -!========================================================================================! - subroutine deallocate_constraints(self) + end subroutine allocate_legacy_constraints + + subroutine deallocate_legacy_constraints(self) implicit none - class(constra) :: self + class(legacy_constraints) :: self if (allocated(self%sett)) deallocate (self%sett) if (allocated(self%buff)) deallocate (self%buff) - end subroutine deallocate_constraints + end subroutine deallocate_legacy_constraints + + subroutine legacy_constraints_info(self) + implicit none + class(legacy_constraints) :: self + integer :: i + write (*,*) "legacy constraints set?",self%used + if (self%used) then + do i = 1,self%ndim + if (trim(self%sett(i)) .ne. '') then + write (*,'(a)') trim(self%sett(i)) + end if + end do + end if + + write (*,*) 'legacy constraints NCI?',self%NCI + if (self%NCI.and.allocated(self%pots)) then + do i = 1,10 + if (trim(self%pots(i)) .ne. '') then + write (*,'(a)') trim(self%pots(i)) + end if + end do + end if + + write (*,*) 'legacy constraints CBONDS?',allocated(self%cbonds) + if (allocated(self%cbonds)) then + do i = 1,min(10,self%n_cbonds) + if (trim(self%cbonds(i)) .ne. '') then + write (*,'(a)') trim(self%cbonds(i)) + end if + end do + if(self%n_cbonds>10) write(*,*) '... and some more' + end if + end subroutine legacy_constraints_info !========================================================================================! !========================================================================================! @@ -751,14 +795,13 @@ subroutine pqueue_removehybrid(self) return end subroutine pqueue_removehybrid - subroutine add_to_refinequeue(self,refinetype) implicit none class(systemdata) :: self integer :: refinetype integer :: idum integer,allocatable :: qdum(:) - if( refinetype <= 0 ) return + if (refinetype <= 0) return if (.not.allocated(self%refine_queue)) then allocate (self%refine_queue(1)) self%refine_queue(1) = refinetype @@ -826,6 +869,15 @@ subroutine wrtCHRG(self,dir) end subroutine wrtCHRG !========================================================================================! + subroutine ref_init(self,nat) + class(refdata) :: self + integer,intent(in) :: nat + if (allocated(self%at)) deallocate (self%at) + if (allocated(self%xyz)) deallocate (self%xyz) + allocate (self%at(nat),source=0) + allocate (self%xyz(3,nat),source=0.0_wp) + end subroutine ref_init + !> read atomic charges from a file (one line per atom) subroutine read_charges(self,chargesfilename,totchrg) implicit none @@ -857,10 +909,10 @@ end subroutine read_charges subroutine ref_to_mol(self,mol) implicit none class(refdata) :: self - type(coord) :: mol + class(coord) :: mol mol%nat = self%nat - if(allocated(self%at)) mol%at = self%at - if(allocated(self%xyz)) mol%xyz = self%xyz + if (allocated(self%at)) mol%at = self%at + if (allocated(self%xyz)) mol%xyz = self%xyz mol%chrg = self%ichrg mol%uhf = self%uhf return @@ -869,12 +921,13 @@ end subroutine ref_to_mol subroutine ref_load_mol(self,mol) implicit none class(refdata) :: self - type(coord) :: mol - self%nat = mol%nat - self%at = mol%at - self%xyz = mol%xyz - self%ichrg = mol%chrg - self%uhf = mol%uhf + class(coord) :: mol + call self%init(mol%nat) + self%nat = mol%nat + self%at = mol%at + self%xyz = mol%xyz + self%ichrg = mol%chrg + self%uhf = mol%uhf return end subroutine ref_load_mol @@ -910,7 +963,7 @@ function optlevnum(flag) result(optlev) if (index(flag,'tight') .ne. 0) optlev = 1.0d0 if (index(flag,'verytight') .ne. 0) optlev = 2.0d0 if (index(flag,'vtight') .ne. 0) optlev = 2.0d0 - if (index(flag,'extreme') .ne. 0) optlev = 3.0d0 + if (index(flag,'extreme') .ne. 0) optlev = 3.0d0 if (index(flag,'3') .ne. 0) optlev = 3.0d0 if (index(flag,'2') .ne. 0) optlev = 2.0d0 if (index(flag,'1') .ne. 0) optlev = 1.0d0 @@ -938,23 +991,23 @@ subroutine optlev_to_multilev(optlev,multilev) real(wp),intent(in) :: optlev logical,intent(out) :: multilev(6) integer :: j - if (optlev <= 3.0d0)then !> "extreme" thresholds + if (optlev <= 3.0d0) then !> "extreme" thresholds multilev(:) = .false. multilev(6) = .true. multilev(4) = .true. multilev(1) = .true. - endif + end if j = optlevmap_alt(optlev) - j = max(j-1, 1) !> j is reduced by one - if (optlev <= 2.0d0)then !> "normal" to "vtight" - multilev(:) = .false. - multilev(1) = .true. - multilev(j) = .true. - endif - if (optlev <= -1.0d0)then !> "loose" to "crude" - multilev(:) = .false. - multilev(j) = .true. - endif + j = max(j-1,1) !> j is reduced by one + if (optlev <= 2.0d0) then !> "normal" to "vtight" + multilev(:) = .false. + multilev(1) = .true. + multilev(j) = .true. + end if + if (optlev <= -1.0d0) then !> "loose" to "crude" + multilev(:) = .false. + multilev(j) = .true. + end if end subroutine optlev_to_multilev !========================================================================================! diff --git a/src/confparse.f90 b/src/confparse.f90 index f06d639d..9e06eb8d 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -46,7 +46,7 @@ subroutine parseflags(env,arg,nra) use optimize_module use parse_inputfile use crest_restartlog - use lwoniom_module + implicit none type(systemdata),intent(inout) :: env integer,intent(in) :: nra @@ -330,18 +330,12 @@ subroutine parseflags(env,arg,nra) env%properties2 = p_none !> backup for env%properties env%iterativeV2 = .true. !> iterative crest V2 version env%preopt = .true. -!>--- check for input file - do i = 1,nra - argument = trim(arg(i)) - if (argument == '--input'.or.argument == '-i') then - call parseinputfile(env,trim(arg(i+1))) - exit - end if - if (i == 1.and.index(argument,'.toml') .ne. 0) then - call parseinputfile(env,trim(arg(1))) - exit - end if - end do +!>--- check for (TOML) input file + call find_input_file(arg,nra,idum) + if (idum .ne. 0) then + call parseinputfile(env,trim(arg(idum))) + end if + !>--- first arg loop do i = 1,nra argument = trim(arg(i)) @@ -586,6 +580,14 @@ subroutine parseflags(env,arg,nra) end if stop + case ('-rotalign') + ctmp = trim(arg(i+1)) + inquire (file=ctmp,exist=ex) + if (ex) then + call rotalign_tool(ctmp) + end if + stop + case ('-printboltz') if (nra >= i+2) then ctmp = trim(arg(i+1)) @@ -639,12 +641,52 @@ subroutine parseflags(env,arg,nra) end if case ('-rmsd','-rmsdheavy','-hrmsd') + if ((argument == '-rmsdheavy').or.(argument == '-hrmsd')) then + env%sortmode = 'hrmsd' + else + env%sortmode = 'rmsd' + end if ctmp = trim(arg(i+1)) dtmp = trim(arg(i+2)) - if ((argument == '-rmsdheavy').or.(argument == '-hrmsd')) then - call quick_rmsd_tool(ctmp,dtmp,.true.) + env%preopt = .false. + env%crestver = crest_sorting + inquire (file=ctmp,exist=ex) + if (ex) then + env%inputcoords = ctmp + env%ensemblename = ctmp + end if + inquire (file=dtmp,exist=ex) + if (ex) then + env%ensemblename2 = dtmp + end if + + case ('-irmsd','-irmsd_noinv') + ctmp = trim(arg(i+1)) + dtmp = trim(arg(i+2)) + env%preopt = .false. + env%crestver = crest_sorting + env%sortmode = 'irmsd' + inquire (file=ctmp,exist=ex) + if (ex) then + env%inputcoords = ctmp + env%ensemblename = ctmp + end if + inquire (file=dtmp,exist=ex) + if (ex) then + env%ensemblename2 = dtmp + end if + if (index(argument,'_noinv') .ne. 0) then + env%iinversion = 2 + end if + + case ('-hungarian','-hungarianheavy','-hhungarian','-lsap','-hlsap','-lsapheavy') + ctmp = trim(arg(i+1)) + dtmp = trim(arg(i+2)) + if ((argument == '-hungarianheavy').or.(argument == '-hhungarian').or. & + &(argument == '-lsapheavy').or.(argument == '-hlsap')) then + call quick_hungarian_match(ctmp,dtmp,.true.) else - call quick_rmsd_tool(ctmp,dtmp,.false.) + call quick_hungarian_match(ctmp,dtmp,.false.) end if stop @@ -733,6 +775,24 @@ subroutine parseflags(env,arg,nra) env%legacy = .false. exit + case ('-sort') + env%preopt = .false. + env%crestver = crest_sorting + ctmp = trim(arg(i+1)) + inquire (file=ctmp,exist=ex) + if (ex) then + env%inputcoords = ctmp + env%ensemblename = ctmp + end if + if (nra >= i+2) then + ctmp = trim(arg(i+2)) + if (ctmp(1:1) .ne. '-') env%sortmode = trim(ctmp) + end if + + case ('-bh','-GMIN') + env%crestver = crest_bh + exit + case ('-SANDBOX') !>--- IMPLEMENT HERE WHATEVER YOU LIKE, FOR TESTING !>----- @@ -787,11 +847,6 @@ subroutine parseflags(env,arg,nra) else call inputcoords(env,trim(arg(1))) end if -!========================================================================================! -!> after this point there should always be a "coord" file present -!========================================================================================! - allocate (env%includeRMSD(env%nat)) - env%includeRMSD = 1 !========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>! @@ -1202,6 +1257,24 @@ subroutine parseflags(env,arg,nra) env%ref%ichrg = idum end if end if + + case ('-efield') !> electric field in V/Ang, only compatibe with tblite + if (.not.allocated(env%ref%efield)) allocate (env%ref%efield(3),source=0.0_wp) + if (nra >= i+3) then + ctmp = trim(arg(i+1)) + read (ctmp,*,iostat=io) env%ref%efield(1) + ctmp = trim(arg(i+2)) + read (ctmp,*,iostat=io) env%ref%efield(2) + ctmp = trim(arg(i+3)) + read (ctmp,*,iostat=io) env%ref%efield(3) + write (stdout,'(" --efield: ",3(1x,es10.3)," V/Å")') env%ref%efield(1:3) + else + write (stdout,'(a)') + end if + + case ('-ceh_guess') + env%ceh_guess = .true. + case ('-dscal','-dispscal','-dscal_global','-dispscal_global') env%cts%dispscal_md = .true. if (index(argument,'_global') .ne. 0) then @@ -1261,6 +1334,11 @@ subroutine parseflags(env,arg,nra) close (ich) write (*,'(2x,a,1x,a)') trim(arg(i)),trim(arg(i+1)) + case ('-grad') + env%gradsp = .true. + case ('-nograd') + env%gradsp = .false. + case ('-len','-mdlen','-mdtime') !> set md length in ps atmp = arg(i+1) call to_lower(atmp) @@ -1362,11 +1440,11 @@ subroutine parseflags(env,arg,nra) env%cts%cbonds_md = .true. env%cts%cbonds_global = .false. end if - case ('-cfile','-cinp') !> specify the constrain file + case ('-cfile','-cinp','-C','-c') !> specify the constrain file ctmp = trim(arg(i+1)) if (ctmp(1:1) .ne. '-') then env%constraints = trim(ctmp) - write (*,'(2x,a,1x,a)') '--cinp :',trim(ctmp) + write (*,'(2x,a,1x,a)') argument//' :',trim(ctmp) end if case ('-fc','-forceconstant') ctmp = trim(arg(i+1)) @@ -1579,7 +1657,7 @@ subroutine parseflags(env,arg,nra) env%preopt = .false. case ('-topo','-topocheck') env%checktopo = .true. - case ('-notopo','-notopocheck') + case ('-notopo','-notopocheck','-noreftopo') env%checktopo = .false. ctmp = trim(arg(i+1)) if (ctmp(1:1) .ne. '-') then @@ -1588,12 +1666,24 @@ subroutine parseflags(env,arg,nra) env%checktopo = .true. end if end if - case ('-noreftopo') env%reftopo = .false. case ('-ezcheck','-checkez') env%checkiso = .true. case ('-noezcheck','-nocheckez') env%checkiso = .false. + case ('-inversion') + ctmp = lowercase(trim(arg(i+1))) + select case (ctmp) + case ('auto') + env%iinversion = 0 + case ('on') + env%iinversion = 1 + case ('off') + env%iinversion = 2 + case default + write (stdout,'(a,a,a,a)') 'invalid argument for ',argument,': ',trim(ctmp) + stop + end select !========================================================================================! !-------- PROPERTY CALCULATION related flags !========================================================================================! @@ -1857,7 +1947,7 @@ subroutine parseflags(env,arg,nra) ctmp = arg(i+1) env%user_enslvl = .true. env%qcg_flag = .true. - if (arg(i+1) == 'gfn') then + if (arg(i+1) == '-gfn') then dtmp = trim(arg(i+2)) ctmp = trim(ctmp)//dtmp end if @@ -1879,7 +1969,7 @@ subroutine parseflags(env,arg,nra) case ('-freqlvl') ctmp = arg(i+1) env%qcg_flag = .true. - if (arg(i+1) == 'gfn') then + if (arg(i+1) == '-gfn') then dtmp = trim(arg(i+2)) ctmp = trim(ctmp)//dtmp end if @@ -2070,8 +2160,11 @@ subroutine parseflags(env,arg,nra) error stop 'Z sorting of the input is unavailable for -qcg runtyp.' end if +!>--- avoid 0 potscal + if(env%potscal < 1.0d-5) env%potscal = 1.0_wp + !>--- automatic wall potential for the LEGACY version - if (env%NCI.or.env%wallsetup.and.env%legacy) then + if ((env%NCI.or.env%wallsetup).and.env%legacy) then call wallpot(env) if (env%wallsetup) then write (*,'(2x,a)') 'Automatically generated ellipsoide potential:' @@ -2212,22 +2305,20 @@ subroutine parseflags(env,arg,nra) flush (stdout) call env2calc_setup(env) write (stdout,*) 'done.' - call env%calc%info(stdout) - end if -!>--- pass on opt-level to new calculator - if (.not.env%legacy) then - env%calc%optlev = nint(env%optlev) end if -!>--- ONIOM setup from toml file - if (allocated(env%ONIOM_toml)) then - allocate (env%calc%ONIOM) - call ONIOM_read_toml(env%ONIOM_toml,env%nat,env%ref%at,env%ref%xyz,env%calc%ONIOM) - call env%calc%ONIOMexpand() +!>--- pass on other settings (from cli) to new calculator + if (.not.env%legacy) then + call env2calc_modify(env) end if !>--- important printouts if (.not.env%legacy) then + + if (env%crestver .ne. crest_sorting) then + call env%calc%info(stdout) + end if + call print_frozen(env) end if @@ -2422,7 +2513,8 @@ subroutine inputcoords(env,arg) character(len=:),allocatable :: arg2 type(coord) :: mol type(zmolecule) :: zmol - integer :: i + integer :: i,idiff + integer,allocatable :: tmpinclude(:) !>--- Redirect for QCG input reading if (env%QCG) then @@ -2507,6 +2599,24 @@ subroutine inputcoords(env,arg) env%protb%nfrag = zmol%nfrag call zmol%deallocate() +!>--- Repair logic of includeRMSD array (especially for something like QCG) + if (.not.allocated(env%includeRMSD)) then + allocate (env%includeRMSD(env%ref%nat)) + env%includeRMSD(:) = 1 + else + !> assuming if the current includeRMSD is smaller than the + !> current system we have *appended* some atoms + idiff = size(env%includeRMSD,1) + if (idiff < env%ref%nat) then + allocate (tmpinclude(env%ref%nat),source=1) + do i = 1,idiff + tmpinclude(i) = env%includeRMSD(i) + end do + !deallocate(env%includeRMSD) + call move_alloc(tmpinclude,env%includeRMSD) + end if + end if + return end subroutine inputcoords diff --git a/src/crest_main.f90 b/src/crest_main.f90 index e9809d4c..7d8a2ded 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -24,8 +24,8 @@ program CREST ! use iso_fortran_env,wp => real64 use crest_parameters !> Datatypes and constants use crest_data !> module for the main data storage (imports systemdata and timer) - use crest_restartlog - USE, INTRINSIC :: IEEE_EXCEPTIONS + use crest_restartlog + USE,INTRINSIC :: IEEE_EXCEPTIONS implicit none type(systemdata) :: env !> MAIN STORAGE OF SYSTEM DATA type(timer) :: tim !> timer object @@ -39,7 +39,7 @@ program CREST logical :: ex,ex1,ex2 intrinsic :: iargc,getarg - LOGICAL :: overflow, division_by_zero, invalid_operation + LOGICAL :: overflow,division_by_zero,invalid_operation call initsignal() !SIGTERM catcher @@ -50,8 +50,7 @@ program CREST !=========================================================================================! !> set defaults and pars flags args = iargc() - l = len_trim(cmd) - allocate (arg(args),source=repeat(' ',l)) + allocate (arg(args),source=repeat(' ',1024)) do i = 1,args call getarg(i,arg(i)) end do @@ -113,8 +112,8 @@ program CREST end if if (env%newcregen) then block - use cregen_interface - call newcregen(env,0) + use cregen_interface + call newcregen(env,0) end block else call cregen2(env) @@ -129,7 +128,7 @@ program CREST call tim%stop(1) call propquit(tim) !>--- zsort routine - case(p_zsort) + case (p_zsort) call zsort write (*,*) write (*,*) 'The z-matrix of the input coord file has been sorted.' @@ -140,7 +139,7 @@ program CREST !>--- only ensemble comparison case (p_compare) - call compare_ensembles(env) + call compare_ensembles(env) call propquit(tim) ! !>--- protonation tool ! case (p_protonate) @@ -241,7 +240,7 @@ program CREST case (crest_imtd,crest_imtd2) !> MTD-GC algo call confscript2i(env,tim) - case (crest_mdopt, crest_mdopt2) + case (crest_mdopt,crest_mdopt2) call mdopt(env,tim) !> MDOPT case (crest_screen) @@ -290,16 +289,22 @@ program CREST call trialOPT(env) case (crest_ensemblesp) !> singlepoints along ensemble - call crest_ensemble_singlepoints(env,tim) + call crest_ensemble_singlepoints(env,tim) - case(crest_protonate) + case (crest_protonate) call protonate(env,tim) - - case(crest_deprotonate) + + case (crest_deprotonate) call deprotonate(env,tim) - case(crest_tautomerize) - call tautomerize(env,tim) + case (crest_tautomerize) + call tautomerize(env,tim) + + case (crest_sorting) !> interface to standalone ensemble sorting + call crest_sort(env,tim) + + case (crest_bh) !> Standard basin-hopping + call crest_basinhopping(env,tim) case (crest_test) call crest_playground(env,tim) @@ -354,8 +359,8 @@ program CREST !=========================================================================================! !> shout down hosted subprocesses block - use ConfSolv_module - call cs_shutdown(io) + use ConfSolv_module + call cs_shutdown(io) end block !=========================================================================================! diff --git a/src/crest_pars.f90 b/src/crest_pars.f90 index 9ed05897..3511db60 100644 --- a/src/crest_pars.f90 +++ b/src/crest_pars.f90 @@ -1,16 +1,16 @@ module crest_parameters - use iso_fortran_env, only: wp => real64, sp => real32 - use iso_fortran_env, only: ap => real64 - use iso_fortran_env, only: dp => int64 - use iso_fortran_env, only: int8,int16,int32,int64,real64,real32 - use iso_fortran_env, only: stdout => output_unit - use iso_fortran_env, only: stderr => error_unit + use iso_fortran_env,only:wp => real64,sp => real32 + use iso_fortran_env,only:ap => real64 + use iso_fortran_env,only:dp => int64 + use iso_fortran_env,only:int8,int16,int32,int64,real64,real32 + use iso_fortran_env,only:stdout => output_unit + use iso_fortran_env,only:stderr => error_unit public :: wp,sp,ap,dp,stdout,stderr public :: int8,int16,int32,int64,real64,real32 real(wp),parameter,public :: bohr = 0.52917726_wp - real(wp),parameter,public :: angstrom = 1.0_wp / bohr + real(wp),parameter,public :: angstrom = 1.0_wp/bohr real(wp),parameter,public :: autoaa = bohr real(wp),parameter,public :: aatoau = angstrom @@ -27,8 +27,16 @@ module crest_parameters real(wp),parameter,public :: kcaltokj = autokj/autokcal real(wp),parameter,public :: autorcm = 219474.63067_wp real(wp),parameter,public :: rcmtoau = 1.0_wp/autorcm - real(wp),parameter,public :: metokg = 9.10938356e-31_wp - real(wp),parameter,public :: kgtome = 1.0_wp/metokg + real(wp),parameter,public :: metokg = 9.10938356e-31_wp + real(wp),parameter,public :: kgtome = 1.0_wp/metokg + + real(wp),parameter,public :: c_vacuum = 299792458e0_wp + !> Coulomb to atomic charge units (electrons) + real(wp),public,parameter :: autoc = 1.6021766208e-19_wp + real(wp),parameter,public :: ctoau = 1.0_wp/autoc + real(wp),parameter,private :: fine_structure_constant = 7.2973525693e-3_wp + real(wp),parameter,public :: jtoau = 1.0_wp/(metokg*c_vacuum**2*fine_structure_constant**2) + real(wp),parameter,public :: vatoau = jtoau/(ctoau*aatoau) real(wp),parameter,public :: Rcal = 8.31446261815324_wp/kcaltokj real(wp),parameter,public :: kB = 3.166808578545117e-06_wp @@ -36,14 +44,13 @@ module crest_parameters real(wp),parameter,public :: planck = 6.62606957e-34_wp ! J*s real(wp),parameter,public :: hbar = planck/(2.0_wp*pi) - real(wp),public,parameter :: lightspeed = 137.0359990740_wp + real(wp),public,parameter :: lightspeed = 137.0359990740_wp !> femtosectons to atomic time units - real(wp), public, parameter :: fstoau = 41.3413733365614_wp - !> Coulomb to atomic charge units (electrons) - real(wp), public, parameter :: autoc = 1.6021766208e-19_wp + real(wp),public,parameter :: fstoau = 41.3413733365614_wp + !> Debye to atomic units - real(wp), public, parameter :: autod = autoc * lightspeed * autoaa**2 * fstoau * 1.0e+16_wp - real(wp), public, parameter :: dtoau = 1.0_wp / autod + real(wp),public,parameter :: autod = autoc*lightspeed*autoaa**2*fstoau*1.0e+16_wp + real(wp),public,parameter :: dtoau = 1.0_wp/autod character(len=1),public,parameter :: sep = '/' character(len=12),public,parameter :: dev0 = ' 2>/dev/null' diff --git a/src/dynamics/dynamics_module.f90 b/src/dynamics/dynamics_module.f90 index e71d63f1..d825d640 100644 --- a/src/dynamics/dynamics_module.f90 +++ b/src/dynamics/dynamics_module.f90 @@ -198,30 +198,30 @@ subroutine dynamics(mol,dat,calc,pr,term) !>--- settings printout if (pr) then - write (*,*) - write (*,'("> ",a)') 'Molecular dynamics settings' - write (*,'('' MD time /ps :'',f10.2)') dat%length_ps - write (*,'('' dt /fs :'',f10.2)') dat%tstep - write (*,'('' temperature /K :'',f10.2)') dat%tsoll - write (*,'('' max steps :'',i10 )') dat%length_steps - write (*,'('' block length (av.) :'',i10 )') dat%blockl - write (*,'('' dumpstep(trj) /fs :'',f10.2,i6)') dat%dumpstep,dat%sdump - write (*,'('' # deg. of freedom :'',i10 )') nfreedom + write (stdout,*) + write (stdout,'(1x,15("─"),1x,a,1x,14("─"))') 'Molecular Dynamics Settings' + write (stdout,'(" MD time /ps",t25, ":",f10.2)') dat%length_ps + write (stdout,'(" dt /fs",t25, ":",f10.2)') dat%tstep + write (stdout,'(" temperature /K",t25, ":",f10.2)') dat%tsoll + write (stdout,'(" max steps",t25, ":",i10 )') dat%length_steps + write (stdout,'(" block length (av.)",t25,":",i10 )') dat%blockl + write (stdout,'(" dumpstep(trj) /fs",t25, ":",f10.2,1x,"(",i0,")")') dat%dumpstep,dat%sdump + write (stdout,'(" # deg. of freedom",t25, ":",i10 )') nfreedom if(calc%nfreeze > 0)then - write (*,'('' # frozen atoms :'',i10 )') calc%nfreeze + write (stdout,'(" # frozen atoms",t25, ":",i10 )') calc%nfreeze endif call thermostatprint(dat,pr) - write (*,'('' SHAKE constraint :'',8x,l)') dat%shake + write (stdout,'(" SHAKE constraint",t25, ":",9x,l)') dat%shake if (dat%shake) then if (dat%shk%shake_mode == 2) then - write (*,'('' # SHAKE bonds :'',i10,a)') dat%nshake,' (all bonds)' + write (stdout,'(" # SHAKE bonds",t25,":",i10,a)') dat%nshake,' (all bonds)' elseif (dat%shk%shake_mode == 1) then - write (*,'('' # SHAKE bonds :'',i10,a)') dat%nshake,' (H only)' + write (stdout,'(" # SHAKE bonds",t25,":",i10,a)') dat%nshake,' (H only)' end if end if - write (*,'('' hydrogen mass /u :'',f10.5 )') dat%md_hmass + write (stdout,'(" hydrogen mass /u",t25,":",f10.5 )') dat%md_hmass if(allocated(dat%active_potentials))then - write (*,'('' active potentials :'',i10)') size(dat%active_potentials,1) + write (stdout,'(" active potentials",t25,":",i10)') size(dat%active_potentials,1) endif end if @@ -292,12 +292,12 @@ subroutine dynamics(mol,dat,calc,pr,term) !>--- begin printout if (pr) then - write (*,'(/,"> ",a)') 'Starting simulation' + write (stdout,'(/,"> ",a)') 'Starting simulation' if (.not.dat%thermostat) then - write (*,'(/,11x,"time (ps)",7x,"",8x,"Ekin",5x,"",7x,"T",12x, & + write (stdout,'(/,11x,"time (ps)",7x,"",8x,"Ekin",5x,"",7x,"T",12x, & & "Etot",7x,"error")') else - write (*,'(/,11x,"time (ps)",7x,"",8x,"Ekin",5x,"",7x,"T",12x, & + write (stdout,'(/,11x,"time (ps)",7x,"",8x,"Ekin",5x,"",7x,"T",12x, & & "Etot")') end if end if @@ -354,7 +354,7 @@ subroutine dynamics(mol,dat,calc,pr,term) dat%dumped = dat%dumped+1 !$omp critical xyz_angstrom = mol%xyz*bohr - write (commentline,'(a,f22.12,1x,a)') 'Epot =',epot,'' + write (commentline,'(a,f22.12,1x,a)') 'energy =',epot,'' call wrxyz(trj,mol%nat,mol%at,xyz_angstrom,commentline) !$omp end critical end if @@ -363,12 +363,12 @@ subroutine dynamics(mol,dat,calc,pr,term) if (pr) then rt = float(t)*dat%tstep + rtshift if (.not.dat%thermostat) then - write (*,'(i7,f10.2,F16.5,F12.4,2F8.1,F16.5,4F10.4)') & + write (stdout,'(i7,f10.2,F16.5,F12.4,2F8.1,F16.5,4F10.4)') & & t,0.001_wp*rt, (Epav+Epot)/float(t), & & Ekin,Tav/float(t),temp,Epot+Ekin, & & Edum/float(t)-Epot-Ekin else - write (*,'(i7,f10.2,F16.5,F12.4,2F8.1,F16.5)') & + write (stdout,'(i7,f10.2,F16.5,F12.4,2F8.1,F16.5)') & & t,0.001_wp*rt, (Epav+epot)/float(t), & & Ekin,Tav/float(t),temp,Epot+Ekin end if @@ -471,13 +471,13 @@ subroutine dynamics(mol,dat,calc,pr,term) !>--- averages printout if (pr) then - write (*,*) - write (*,*) 'average properties ' - write (*,*) '----------------------' - write (*,*) ' / Eh :',Epav/float(t) - write (*,*) ' / Eh :',Ekav/float(t) - write (*,*) ' / Eh :', (Ekav+Epav)/float(t) - write (*,*) ' / K :',Tav/float(t) + write (stdout,*) + write (stdout,*) 'average properties ' + write (stdout,*) '----------------------' + write (stdout,*) ' / Eh :',Epav/float(t) + write (stdout,*) ' / Eh :',Ekav/float(t) + write (stdout,*) ' / Eh :', (Ekav+Epav)/float(t) + write (stdout,*) ' / K :',Tav/float(t) end if !>--- write restart file @@ -488,11 +488,11 @@ subroutine dynamics(mol,dat,calc,pr,term) if (pr) then select case (term) case (0) - write (*,*) 'normal MD termination' + write (stdout,*) 'normal MD termination' case (1) write (stderr,*) 'error in MD calculation' case (2) - write (*,*) 'MD terminated, but still taking as converged.' + write (stdout,*) 'MD terminated, but still taking as converged.' end select end if @@ -595,8 +595,8 @@ subroutine u_block(mol,dat,epot,temp,pr,bdump) slope = 99.0_wp end if if (pr) then - write (*,'(''block / :'',f14.5,f7.1,4x, & - & ''drift:'',d10.2,3x,''Tbath :'',f6.1)') & + write (stdout,'("block / :",f14.5,f7.1,4x, & + & "drift:",d10.2,3x,"Tbath :",f6.1)') & & bave,bavt,slope,dat%tsoll end if else @@ -610,7 +610,7 @@ subroutine u_block(mol,dat,epot,temp,pr,bdump) contains subroutine regress(n1,n2,rege,slope) implicit none - real(wp) :: rege(*),slope + real(wp) :: rege(stdout),slope integer :: n1,n2,n real(wp) :: sx,sy,sxx,sxy,x integer :: i,j,k,l,ich,och,io @@ -724,7 +724,7 @@ subroutine rdmdrestart(mol,dat,velo,fail,rtshift) fail = .true. end if if(.not.fail)then - write (*,'(1x,a,8x,l)') 'read restart file :',.not.fail + write (stdout,'(1x,a,8x,l)') 'read restart file :',.not.fail endif return @@ -821,12 +821,12 @@ subroutine thermostatprint(dat,pr) if (dat%thermostat) then select case (trim(dat%thermotype)) case ('berendsen') - write (*,'('' thermostat :'',1x,a )') trim(dat%thermotype) + write (stdout,'(" thermostat",t25,":",1x,a )') trim(dat%thermotype) case default !>-- (also berendsen thermostat) - write (*,'('' thermostat :'',1x,a )') 'berendsen' + write (stdout,'(" thermostat",t25,":",1x,a )') 'berendsen' end select else - write (*,'('' thermostat :'',1x,a )') 'OFF' + write (stdout,'(" thermostat",t25,":",1x,a )') 'OFF' end if return diff --git a/src/dynamics/metadynamics_module.f90 b/src/dynamics/metadynamics_module.f90 index 587028e3..f4cd42d5 100644 --- a/src/dynamics/metadynamics_module.f90 +++ b/src/dynamics/metadynamics_module.f90 @@ -101,7 +101,9 @@ subroutine mtd_ini(mol,pot,tstep,mdlength,pr) integer,allocatable :: at(:) if (pr) then - write (stdout,'(">--- metadynamics parameter ---")') + write (stdout,'(1X,17("─"))', advance='no') + write (stdout,'(1X,"Metadynamics Parameters")', advance='no') + write (stdout,'(1X,17("─"))') end if dum1 = anint((mdlength*1000.0_wp)/tstep) @@ -158,7 +160,7 @@ subroutine mtd_ini(mol,pot,tstep,mdlength,pr) if (nat .ne. mol%nat) then !> can't do that! something is wrong if (allocated(pot%cvxyz)) deallocate (pot%cvxyz) pot%mtdtype = 0 - write (*,'(1x,a)') '*WARNING* static metadynamics setup failed! Mismatch of #atoms' + write (stdout,'(1x,a)') '*WARNING* static metadynamics setup failed! Mismatch of #atoms' !return error stop end if @@ -180,9 +182,9 @@ subroutine mtd_ini(mol,pot,tstep,mdlength,pr) !>--- printout if (pr) then call pot%info(stdout) + write (stdout,'(1X,59("─"))') end if - return end subroutine mtd_ini @@ -226,25 +228,30 @@ subroutine mtd_info(self,iunit) !write (iunit,'(" --- metadynamics parameter ---")') select case (self%mtdtype) case (cv_std_mtd) - write (iunit,'(" MTD/CV type :",1x,a)') 'standard' + write (iunit,'(" MTD/CV type",t25,":",1x,a)') 'standard' case (cv_rmsd) - write (*,'(" MTD/CV type :",1x,a)') 'RMSD bias' + write (stdout,'(" MTD/CV type",t25,":",1x,a)') 'RMSD bias' case (cv_rmsd_static) - write (iunit,'(" MTD/CV type :",1x,a)') 'RMSD bias (static)' + write (iunit,'(" MTD/CV type",t25,":",1x,a)') 'RMSD bias (static)' end select - write (iunit,'(" kpush /Eh :",f10.4)') self%kpush - write (iunit,'(" alpha /bohr⁻² :",f10.4)') self%alpha + write (iunit,'(" kpush /Eh",t25,":",f10.4)') self%kpush + write (iunit,'(" alpha /Bohr⁻²",t28,":",f10.4)') self%alpha select case (self%mtdtype) case (cv_rmsd) - write (iunit,'(" ramp :",f10.4,1x,i0)') self%ramp,check_dump_steps_rmsd(self) - write (iunit,'(" dump/fs :",f10.4,1x,i0 )') self%cvdump_fs,self%cvdumpstep - write (iunit,'(" # CVs (max) :",i10 )') self%maxsave + write (iunit,'(" ramp rate",t25,":",f10.4,1x,"(",i0,")")') self%ramp,check_dump_steps_rmsd(self) + write (iunit,'(" dump/fs",t25,":",f10.4,1x,"(",i0,")")') self%cvdump_fs,self%cvdumpstep + write (iunit,'(" # CVs (max)",t25,":",i10 )') self%maxsave case (cv_rmsd_static) - if (allocated(self%biasfile)) write (iunit,'(" reading from :",1x,a)') self%biasfile - write (iunit,'(" ramp (adjust.):",f10.4,1x,i0)') self%ramp,check_dump_steps_rmsd(self) - write (iunit,'(" # CVs (loaded):",i10 )') self%maxsave + if (allocated(self%biasfile)) write (iunit,'(" reading from",t25,":",1x,a)') self%biasfile + write (iunit,'(" ramp (adjust.)",t25,":",f10.4,1x,i0)') self%ramp,check_dump_steps_rmsd(self) + write (iunit,'(" # CVs (loaded)",t25,":",i10 )') self%maxsave end select + if (self%mtdtype == cv_rmsd.or.self%mtdtype == cv_rmsd_static) then + if (allocated(self%atinclude)) then + write (iunit,'(" # of atoms affected",t25,":",i10)') count(self%atinclude,1) + end if + end if return end subroutine mtd_info @@ -278,7 +285,7 @@ subroutine cv_dump(mol,pot,cv,pr) call rmsdcv_perturb(mol%nat,pot%cvxyz(:,:,pot%ncur)) end if if (pr) then - write (*,'(2x,"adding snapshot to metadynamics bias, now at ",i0," CVs")') pot%ncur + write (stdout,'(2x,"adding snapshot to metadynamics bias, now at ",i0," CVs")') pot%ncur end if end if diff --git a/src/entropy/thermocalc.f90 b/src/entropy/thermocalc.f90 index e63af984..72133d14 100644 --- a/src/entropy/thermocalc.f90 +++ b/src/entropy/thermocalc.f90 @@ -16,11 +16,6 @@ ! You should have received a copy of the GNU Lesser General Public License ! along with crest. If not, see . !================================================================================! - -!=========================================================================================! -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -!=========================================================================================! - subroutine thermo_wrap_legacy(env,pr,nat,at,xyz,dirname, & & nt,temps,et,ht,gt,stot,bhess) !********************************************** @@ -152,7 +147,7 @@ subroutine thermo_wrap_legacy(env,pr,nat,at,xyz,dirname, & fscal = env%thermo%fscal sthr = env%thermo%sthr call calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr, & - & nt,temps,et,ht,gt,stot) + & nt,temps,et,ht,gt,stot,stdout) deallocate (freq) !$omp end critical call initsignal() @@ -321,7 +316,7 @@ subroutine thermo_wrap_new(env,pr,nat,at,xyz,dirname, & fscal = env%thermo%fscal sthr = env%thermo%sthr call calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr, & - & nt,temps,et,ht,gt,stot) + & nt,temps,et,ht,gt,stot,stdout) deallocate (hess,freq) !$omp end critical call initsignal() diff --git a/src/entropy/thermochem_module.f90 b/src/entropy/thermochem_module.f90 index e9e3a6a9..6d2a29aa 100644 --- a/src/entropy/thermochem_module.f90 +++ b/src/entropy/thermochem_module.f90 @@ -12,7 +12,7 @@ module thermochem_module contains - subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar) + subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar,iunit) !*********************************************************************** !* Prepare the calculation of thermodynamic properties of a structure !* In particular, determine rotational constants and check the symmetry @@ -26,6 +26,7 @@ subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar) real(wp),intent(inout) :: rabc(3) real(wp),intent(out) :: avmom real(wp),intent(out) :: symnum + integer,intent(in) :: iunit real(wp) :: a,b,c character(len=4) :: sfsym @@ -37,7 +38,7 @@ subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar) molmass = molweight(nat,at) if (pr) then - write (stdout,'(1x,a,f15.2)') 'Mol. weight /amu : ',molmass + write (iunit,'(1x,a,f15.2)') 'Mol. weight /amu : ',molmass end if !>--- rotational constants in cm-1 @@ -49,11 +50,11 @@ subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar) rabc(1) = a rabc(3) = c if (pr) then - write (stdout,'(1x,a,3f15.2)') 'Rot. const. /MHz : ',rabc(1:3) + write (iunit,'(1x,a,3f15.2)') 'Rot. const. /MHz : ',rabc(1:3) end if rabc = rabc/2.99792458d+4 ! MHz to cm-1 if (pr) then - write (stdout,'(1x,a,3f15.2)') 'Rot. const. /cm-1 : ',rabc(1:3) + write (iunit,'(1x,a,3f15.2)') 'Rot. const. /cm-1 : ',rabc(1:3) end if !>--- symmetry number from rotational symmetry @@ -95,13 +96,13 @@ subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar) end if if (pr) then - write (stdout,'(1x,a,4x,a)') 'Symmetry:',sym + write (iunit,'(1x,a,4x,a)') 'Symmetry:',sym end if return end subroutine prepthermo subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & - & et,ht,gt,stot) + & et,ht,gt,stot,iunit) !************************************************************** !* Calculate thermodynamic contributions for a given structure !* from it's frequencies (from second derivatives/the Hessian) @@ -122,6 +123,7 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & real(wp),intent(in) :: sthr !rotor cut integer,intent(in) :: nt real(wp),intent(in) :: temps(nt) + integer,intent(in) :: iunit real(wp) :: et(nt) !< enthalpy in Eh real(wp) :: ht(nt) !< enthalpy in Eh real(wp) :: gt(nt) !< free energy in Eh @@ -161,7 +163,7 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & xyz = xyz*autoaa - call prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,sym,symchar) + call prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,sym,symchar,iunit) print*,freq @@ -206,21 +208,21 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & end do if (pr) then - write (stdout,'(a)') - write (stdout,'(10x,51("."))') - write (stdout,'(10x,":",22x,a,22x,":")') "SETUP" - write (stdout,'(10x,":",49("."),":")') - write (stdout,intfmt) "# frequencies ",nvib - write (stdout,intfmt) "# imaginary freq.",nimag + write (iunit,'(a)') + write (iunit,'(10x,51("."))') + write (iunit,'(10x,":",22x,a,22x,":")') "SETUP" + write (iunit,'(10x,":",49("."),":")') + write (iunit,intfmt) "# frequencies ",nvib + write (iunit,intfmt) "# imaginary freq.",nimag write (atmp,*) linear - write (stdout,chrfmt) "linear? ",trim(atmp) - write (stdout,chrfmt) "symmetry ",adjustr(symchar) - write (stdout,intfmt) "rotational number",nint(sym) - write (stdout,dblfmt) "scaling factor ",fscal," " - write (stdout,dblfmt) "rotor cutoff ",sthr,"cm⁻¹" - write (stdout,dblfmt) "imag. cutoff ",ithr,"cm⁻¹" - write (stdout,'(10x,":",49("."),":")') - end if + write (iunit,chrfmt) "linear? ",trim(atmp) + write (iunit,chrfmt) "symmetry ",adjustr(symchar) + write (iunit,intfmt) "rotational number",nint(sym) + write (iunit,dblfmt) "scaling factor ",fscal," " + write (iunit,dblfmt) "rotor cutoff ",sthr,"cm⁻¹" + write (iunit,dblfmt) "imag. cutoff ",ithr,"cm⁻¹" + write (iunit,'(10x,":",49("."),":")') + end if vibs = vibs*rcmtoau ! thermodyn needs vibs and zp in Eh @@ -234,36 +236,36 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & pr2 = .false. end if if (pr2) then - call print_thermo_sthr_ts(stdout,nvib,vibs,avmom,sthr,temps(j)) + call print_thermo_sthr_ts(iunit,nvib,vibs,avmom,sthr,temps(j)) end if - call thermodyn(stdout,a,b,c,avmom,linear,atom,sym,molmass,vibs,nvib, & + call thermodyn(iunit,a,b,c,avmom,linear,atom,sym,molmass,vibs,nvib, & & temps(j),sthr,et(j),ht(j),gt(j),ts(j),zp,pr2) stot(j) = (ts(j)/temps(j))*autocal end do - if ((nt > 1).and.pr) then - write (stdout,'(a)') - write (stdout,'(a10)',advance='no') "T/K" - write (stdout,'(a16)',advance='no') "H(0)-H(T)+PV" - write (stdout,'(a16)',advance='no') "H(T)/Eh" - write (stdout,'(a16)',advance='no') "T*S/Eh" - write (stdout,'(a16)',advance='no') "G(T)/Eh" - write (stdout,'(a)') - write (stdout,'(3x,72("-"))') - do i = 1,nt - write (stdout,'(3f10.2)',advance='no') temps(i) - write (stdout,'(3e16.6)',advance='no') ht(i) - write (stdout,'(3e16.6)',advance='no') et(i) - write (stdout,'(3e16.6)',advance='no') ts(i) - write (stdout,'(3e16.6)',advance='no') gt(i) - if (i == rt) then - write (stdout,'(1x,"(used)")') - else - write (stdout,'(a)') - end if - end do - write (stdout,'(3x,72("-"))') - end if + if ( pr )then + write (iunit,'(a)') + write (iunit,'(a10)',advance='no') "T/K" + write (iunit,'(a16)',advance='no') "H(0)-H(T)+PV" + write (iunit,'(a16)',advance='no') "H(T)/Eh" + write (iunit,'(a16)',advance='no') "T*S/Eh" + write (iunit,'(a16)',advance='no') "G(T)/Eh" + write (iunit,'(a)') + write (iunit,'(3x,72("-"))') + do i = 1,nt + write (iunit,'(3f10.2)',advance='no') temps(i) + write (iunit,'(3e16.6)',advance='no') ht(i) + write (iunit,'(3e16.6)',advance='no') et(i) + write (iunit,'(3e16.6)',advance='no') ts(i) + write (iunit,'(3e16.6)',advance='no') gt(i) + if (i == rt .and. nt > 1) then + write (iunit,'(1x,"(used)")') + else + write (iunit,'(a)') + end if + end do + write (iunit,'(3x,72("-"))') + end if xyz = xyz*aatoau diff --git a/src/eval_timer.f90 b/src/eval_timer.f90 index 4d4b570e..80d0f883 100644 --- a/src/eval_timer.f90 +++ b/src/eval_timer.f90 @@ -25,15 +25,18 @@ subroutine eval_timer(tim) use crest_data use crest_calculator,only: engrad_total use crest_restartlog + use iomod, only: get_peak_rss_kb implicit none type(timer) :: tim - real(wp) :: time_total,time_avg + real(wp) :: time_total,time_avg,mem character(len=40) :: atmp write (stdout,*) call smallhead('Wall Time Summary') call tim%write(stdout,'CREST runtime',verbose=.true.) time_total = tim%get() call tim%clear + mem = real(get_peak_rss_kb(),wp) + write(stdout,'(" * Peak RSS: ",f8.2, " MiB")') mem/1024.0_wp if(engrad_total > 0)then write(atmp,'(f30.3)') time_total/real(engrad_total,wp) write(stdout,'(" * Total number of energy+grad calls: ",i0)') & !,a,1x,a,a)') & diff --git a/src/filemod.f90 b/src/filemod.f90 index 15e437d3..5e36f8d3 100644 --- a/src/filemod.f90 +++ b/src/filemod.f90 @@ -17,12 +17,9 @@ ! along with crest. If not, see . !================================================================================! - !> fortran module for simple plain-text file handling module filemod - use iso_fortran_env,wp => real64 - implicit none public :: filetype @@ -426,7 +423,6 @@ function lwidth(fname) close (ich) end function lwidth - !========================================================================================! !get n-th element of a line (seperated by blanks) function getlarg(line,n) diff --git a/src/iomod.F90 b/src/iomod.F90 index 50c9bc12..e2bddd67 100644 --- a/src/iomod.F90 +++ b/src/iomod.F90 @@ -55,6 +55,20 @@ integer(kind=c_int) function c_symlink(c_from,c_to) bind(c,name="symlink") end function end interface + interface + integer(c_int) function c_isatty(fd) bind(c,name="isatty") + use iso_c_binding + integer(c_int),value :: fd + end function c_isatty + end interface + + interface + function get_peak_rss_kb() bind(C,name="get_peak_rss_kb") result(kb) + import :: c_long_long + integer(c_long_long) :: kb + end function + end interface + interface wrshort module procedure wrshort_real module procedure wrshort_int @@ -772,10 +786,12 @@ end function directory_exist !=========================================================================================! !=========================================================================================! -!> a wrapper for the intrinsic isatty function. -!> ifort only seems to work if isatty is declard as external -!> while gfortran does not want that... function myisatty(channel) result(term) +!************************************************************ +!* a wrapper for the intrinsic isatty function. +!* ifort only seems to work if isatty is declard as external +!* while gfortran does not want that... +!************************************************************ implicit none integer,intent(in) :: channel logical :: term @@ -785,6 +801,60 @@ function myisatty(channel) result(term) term = isatty(channel) end function myisatty + logical function is_terminal() +!***************************************************************************** +!* Helper function to check if stdout (fd=1) is a TTY +!* This version runs via the iso_c interface rather than the isatty function +!* Also, it doesn't need an output channel +!***************************************************************************** + use iso_c_binding + implicit none + is_terminal = (c_isatty(1_c_int) /= 0) + end function is_terminal + +!=========================================================================================! +!=========================================================================================! +!=========================================================================================! + + function colorify(text,color) result(colored_text) +!****************************************************************************** +!* colorify(text, color) returns a string that wraps `text` in +!* ANSI color codes if stdout is a TTY, or returns `text` as-is otherwise. +!****************************************************************************** + implicit none + !> INPUT + character(len=*),intent(in) :: text + character(len=*),intent(in) :: color + !> We will build the returned string with a deferred-length character + character(len=:),allocatable :: colored_text + !> Escape sequence for ANSI codes + character(len=*),parameter :: ESC = char(27)//"[" + !> Decide if we want color (only if stdout is a terminal) + if (is_terminal()) then + select case (trim(adjustl(color))) + case ("red") + colored_text = ESC//"31m"//trim(text)//ESC//"0m" + case ("green") + colored_text = ESC//"32m"//trim(text)//ESC//"0m" + case ("blue") + colored_text = ESC//"34m"//trim(text)//ESC//"0m" + case ("yellow") + colored_text = ESC//"33m"//trim(text)//ESC//"0m" + case ("gold") + !> 256-color code for a “gold-ish” color + colored_text = ESC//"38;5;214m"//trim(text)//ESC//"0m" + case default + !> If color not recognized (or empty), return text unmodified + colored_text = text + end select + + else + ! Not a terminal => no color codes + colored_text = text + end if + + end function colorify + !=========================================================================================! !=========================================================================================! !=========================================================================================! @@ -1161,6 +1231,47 @@ subroutine split_path(fullpath,dir_part,base_part,has_slash) end subroutine split_path +!=========================================================================================! + + function random_tmp_name() result(fname) + implicit none + character(len=20) :: fname + character(len=16) :: core + integer :: i,idx + real(wp) :: idxr + character(len=*),parameter :: letters = & + & "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + integer,parameter :: lenletters = len(letters) + + do i = 1,len(core) + call random_number(idxr) + idx = int(idxr*lenletters)+1 + core(i:i) = letters(idx:idx) + end do + + fname = trim(core)//".tmp" + end function random_tmp_name + +!==========================================================================================! +! + function dump_array_to_tmp(arr) result(fname) + implicit none + real(wp),intent(in) :: arr(:) + character(len=:),allocatable :: fname + integer :: unit,i + + fname = trim(random_tmp_name()) + + open (newunit=unit,file=fname,status="replace",action="write",iostat=i) + if (i /= 0) stop "Could not open temp file." + + do i = 1,size(arr) + write (unit,'(f25.15)') arr(i) + end do + + close (unit) + end function dump_array_to_tmp + !========================================================================================! !========================================================================================! !========================================================================================! diff --git a/src/legacy_algos/confscript2_misc.f90 b/src/legacy_algos/confscript2_misc.f90 index 11be311e..b954896b 100644 --- a/src/legacy_algos/confscript2_misc.f90 +++ b/src/legacy_algos/confscript2_misc.f90 @@ -685,7 +685,7 @@ subroutine setMDrun2(fname,hmass,mdtime,mdtemp,mdstep,shake,mddumpxyz, & use crest_data use utilities implicit none - type(constra) :: cts + type(legacy_constraints) :: cts character(len=*) :: fname real(wp) :: hmass real(wp) :: mdtime diff --git a/src/legacy_wrappers.f90 b/src/legacy_wrappers.f90 index bc7bf69d..003306c7 100644 --- a/src/legacy_wrappers.f90 +++ b/src/legacy_wrappers.f90 @@ -52,11 +52,17 @@ subroutine env2calc(env,calc,molin) cal%rdwbo = .false. cal%rddip = .false. !> except for SP runtype (from command line!) - if (env%crestver == crest_sp.and. & - & cal%id .ne. jobtype%turbomole) then - cal%rdwbo = .true. - cal%rddip = .true. - cal%rdqat = .true. + if (env%crestver == crest_sp) then + cal%rdgrad = env%gradsp + if (cal%id .ne. jobtype%turbomole) then + cal%rdwbo = .true. + cal%rddip = .true. + cal%rdqat = .true. + else + if (.not.env%gradsp) then + cal%other = '' + end if + end if end if !> implicit solvation @@ -148,6 +154,51 @@ end subroutine env2calc ! env%calc = calc end subroutine env2calc_setup +subroutine env2calc_modify(env) +!****************************************** +!* Modify the calc object within env with +!* additional settings +!****************************************** + use crest_parameters + use crest_data + use crest_calculator + use strucrd + use lwoniom_module + implicit none + !> INOUT + type(systemdata),intent(inout) :: env + !> LOCAL + integer :: i,j + +!>--- pass on opt-level to new calculator + env%calc%optlev = nint(env%optlev) + +!>--- pass electric field to tblite + if (allocated(env%ref%efield)) then + do i = 1,env%calc%ncalculations + if (env%calc%calcs(i)%id == jobtype%tblite) then + if (.not.allocated(env%calc%calcs(i)%efield)) allocate (env%calc%calcs(i)%efield(3),source=0.0_wp) + env%calc%calcs(i)%efield(1:3) = env%ref%efield(1:3) + end if + end do + end if + + !>--- pass on CEH guess flag + if (env%ceh_guess) then + do i = 1,env%calc%ncalculations + env%calc%calcs(i)%ceh_guess = env%ceh_guess + end do + end if + +!>--- ONIOM setup from toml file + if (allocated(env%ONIOM_toml)) then + if (.not.allocated(env%calc%ONIOM)) allocate (env%calc%ONIOM) + call ONIOM_read_toml(env%ONIOM_toml,env%nat,env%ref%at,env%ref%xyz,env%calc%ONIOM) + call env%calc%ONIOMexpand() + end if + +end subroutine env2calc_modify + !================================================================================! subroutine confscript2i(env,tim) use iso_fortran_env,only:wp => real64 @@ -358,7 +409,8 @@ subroutine trialOPT(env) if (env%crestver == crest_trialopt) then !>-- if we reach this point in the standalone trialopt the geometry is ok! write (stdout,*) - stop 'Geometry ok!' + write (stdout,*) 'Geometry ok!' + stop end if end subroutine trialOPT diff --git a/src/mempeak.c b/src/mempeak.c new file mode 100644 index 00000000..b3d98555 --- /dev/null +++ b/src/mempeak.c @@ -0,0 +1,48 @@ +/* +! This file is part of crest. +! +! Copyright (C) 2025 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . + +*/ +#ifdef _WIN32 +#define WIN32_LEAN_AND_MEAN +#include +#include +__declspec(dllexport) long long get_peak_rss_kb(void) { + PROCESS_MEMORY_COUNTERS pmc; + if (GetProcessMemoryInfo(GetCurrentProcess(), &pmc, sizeof(pmc))) { + // bytes -> kilobytes + return (long long)(pmc.PeakWorkingSetSize / 1024); + } + return -1; +} +#else +#include +#include +long long get_peak_rss_kb(void) { + struct rusage ru; + if (getrusage(RUSAGE_SELF, &ru) == 0) { +// On Linux: ru_maxrss is in kilobytes +// On macOS/BSD: ru_maxrss is in bytes — convert to KB +#ifdef __APPLE__ + return (long long)(ru.ru_maxrss / 1024); +#else + return (long long)ru.ru_maxrss; +#endif + } + return -1; +} +#endif diff --git a/src/meson.build b/src/meson.build index 1fd7359b..c758a99e 100644 --- a/src/meson.build +++ b/src/meson.build @@ -27,24 +27,21 @@ subdir('discretize') subdir('entropy') subdir('legacy_algos') subdir('msreact') - +subdir('sorting') +subdir('basinhopping') srcs += files( 'atmasses.f90', 'axis_module.f90', 'biasmerge.f90', 'bondconstraint.f90', - 'canonical.f90', - 'ccegen.f90', 'choose_settings.f90', 'classes.f90', 'cleanup.f90', 'cn.f90', 'compress.f90', 'confparse.f90', - 'cregen.f90', 'crest_pars.f90', - 'ensemblecomp.f90', 'eval_timer.f90', 'filemod.f90', 'flexi.F90', @@ -55,25 +52,22 @@ srcs += files( 'internals2.f90', 'iomod.F90', 'legacy_wrappers.f90', - 'ls_rmsd.f90', 'marqfit.f90', 'minitools.f90', 'miscdata.f90', + 'mempeak.c', 'ncigeo.f90', 'ompmklset.F90', 'printouts.f90', 'prmat.f90', 'propcalc.f90', - 'quicksort.f90', 'readl.f90', 'restartlog.f90', - 'rotcompare.f90', 'scratch.f90', 'sdfio.f90', 'select.f90', 'signal.c', 'sigterm.f90', - 'sortens.f90', 'strucreader.f90', 'symmetry2.f90', 'symmetry_i.c', @@ -81,8 +75,6 @@ srcs += files( 'trackorigin.f90', 'utilmod.f90', 'wallsetup.f90', - 'zdata.f90', - 'ztopology.f90', ) prog += files( diff --git a/src/minitools.f90 b/src/minitools.f90 index fdd5c49b..756f1311 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -25,7 +25,7 @@ subroutine splitfile(fname,up,low) !******************************************************** use crest_parameters use iomod - use strucrd,only: rdensemble,coord + use strucrd,only:rdensemble,coord implicit none character(len=*) :: fname integer :: up,low @@ -48,9 +48,6 @@ subroutine splitfile(fname,up,low) call getcwd(thispath) !current dir= thispath - !call rdensembleparam(fname,nat,nall) - !allocate (xyz(3,nat,nall),at(nat)) - !call rdensemble(fname,nat,nall,at,xyz) call rdensemble(fname,nall,structures) r = makedir("SPLIT") !create new directory @@ -75,12 +72,17 @@ subroutine splitfile(fname,up,low) write (tmppath2,'(a,i0)') "STRUC",i r = makedir(trim(tmppath2)) call chdir(tmppath2) - !call wrxyz("struc.xyz",nat,at,xyz(:,:,i)) call structures(i)%write("struc.xyz") call chdir(tmppath1) end do call chdir(thispath) + write (stdout,*) + write (stdout,'(a,i0,a,i0,a)') '> Created subdirectories SPLIT/STRUC{',low,'-',nc,'}/' + write (stdout,'(a)') '> All directories contain a "struc.xyz" with molecular coordinates' + write (stdout,'(a)') '> The order of SPLIT/STRUC*/ is the same as in '//trim(fname) + write (stdout,*) + write (stdout,'(a)') 'exit.' return end subroutine splitfile @@ -96,7 +98,7 @@ subroutine printaniso(fname,bmin,bmax,bshift) use axis_module implicit none character(len=*) :: fname - type(ensemble) :: ens + type(coord),allocatable :: structures(:) integer :: nat integer :: nall @@ -106,6 +108,7 @@ subroutine printaniso(fname,bmin,bmax,bshift) real(wp),allocatable :: rot(:,:) real(wp) :: rotaniso !function real(wp),allocatable :: anis(:) + real(wp) :: evec(3,3),evecavg(3,3) real(wp) :: bthrerf real(wp) :: bmin,bmax,bshift @@ -113,19 +116,25 @@ subroutine printaniso(fname,bmin,bmax,bshift) real(wp) :: dum integer :: i - call ens%open(fname) - nat = ens%nat - nall = ens%nall + call rdensemble(fname,nall,structures) + nat = structures(1)%nat allocate (c1(3,nat),at(nat)) allocate (rot(3,nall)) allocate (anis(nall)) - at = ens%at + at(:) = structures(1)%at(:) + evecavg(:,:) = 0.0_wp + do i = 1,nall + c1(1:3,:) = structures(i)%xyz(1:3,:)*autoaa + call axis(nat,at,c1,rot(1:3,i),dum,evec) + evecavg(:,:) = evecavg(:,:)+evec(:,:) + end do + evecavg(:,:) = evecavg(:,:)/real(nall) do i = 1,nall - c1(1:3,:) = ens%xyz(1:3,:,i) - call axis(nat,at,c1,rot(1:3,i),dum) + c1(1:3,:) = structures(i)%xyz(1:3,:)*autoaa + call axis(nat,at,c1,rot(1:3,i),dum,evec) anis(i) = rotaniso(i,nall,rot) thr = bthrerf(bmin,anis(i),bmax,bshift) write (*,'(3f10.2,2x,f8.4,2x,f8.4)') rot(1:3,i),anis(i),thr @@ -139,6 +148,66 @@ end subroutine printaniso !=========================================================================================! +subroutine rotalign_tool(fname) +!**************************************************** +!* print the anisotropy of the rotational constants +!* for all structures in a given ensemble file +!**************************************************** + use crest_parameters + use strucrd + use axis_module + implicit none + character(len=*) :: fname + type(coord),allocatable :: structures(:) + + integer :: nat + integer :: nall + real(wp),allocatable :: c1(:,:),c2(:,:) + integer,allocatable :: at(:) + + real(wp),allocatable :: rot(:,:) + real(wp) :: rotaniso !function + real(wp),allocatable :: anis(:) + real(wp) :: evec(3,3),evecavg(3,3) + + real(wp) :: bthrerf + real(wp) :: bmin,bmax,bshift + real(wp) :: thr + real(wp) :: dum + integer :: i + + real(wp),parameter :: Ry90(3,3) = reshape([ & + & 0.0_wp,0.0_wp,-1.0_wp, & + & 0.0_wp,1.0_wp,0.0_wp, & + & 1.0_wp,0.0_wp,0.0_wp & + & ], [3,3]) + + call rdensemble(fname,nall,structures) + nat = structures(1)%nat + + allocate (c1(3,nat),c2(3,nat),at(nat)) + allocate (rot(3,nall)) + + at(:) = structures(1)%at(:) + write (*,'(3a10)') 'A/MHz','B/MHz','C/MHz' + do i = 1,nall + c1(1:3,:) = structures(i)%xyz(1:3,:)*autoaa + call axis(nat,at,c1,rot(1:3,i)) + c2 = c1 + structures(i)%xyz = c2*aatoau + write (*,'(3f10.2)') rot(1:3,i) + end do + + deallocate (rot,at,c2,c1) + + call wrensemble('rotalign.xyz',nall,structures) + + stop + return +end subroutine rotalign_tool + +!=========================================================================================! + subroutine prbweight(fname,Targ) !***************************************************** !* read in a file with 1 to 2 columns @@ -414,7 +483,6 @@ subroutine testtopo(fname,env,tmode) case ('methyl') do i = 1,zmol%nat l1 = zmol%methyl(i) - !write(*,*) l1 if (l1) write (*,'(a,i0,a)') 'Atom ',i,' is methyl (or similar)' end do @@ -586,20 +654,32 @@ end function quick_rmsd subroutine quick_rmsd_tool(fname1,fname2,heavy) use crest_parameters use strucrd + use irmsd_module implicit none - character(len=*) :: fname1 - character(len=*) :: fname2 - logical :: heavy - type(coord) :: mol1 + character(len=*),intent(in) :: fname1 + character(len=*),intent(in) :: fname2 + logical,intent(in) :: heavy + type(coord) :: mol,ref real(wp) :: rmsdval - real(wp) :: quick_rmsd - - call mol1%open(fname1) + integer :: i + logical,allocatable :: mask(:) - mol1%xyz = mol1%xyz*bohr !to Angstroem + call ref%open(fname1) + call mol%open(fname2) - rmsdval = quick_rmsd(fname2,mol1%nat,mol1%at,mol1%xyz,heavy) + if (heavy) then + allocate (mask(ref%nat),source=.false.) + do i = 1,ref%nat + if (ref%at(i) > 1) then + mask(i) = .true. + end if + end do + rmsdval = rmsd(ref,mol,mask=mask) + else + rmsdval = rmsd(ref,mol) + end if + rmsdval = rmsdval*autoaa if (heavy) then write (*,'(1x,a,f16.8)') 'Calculated heavy atom RMSD (Å):',rmsdval else @@ -652,6 +732,100 @@ end function quick_rmsd2 !=========================================================================================! +subroutine quick_hungarian_match(fname1,fname2,heavy) + use crest_parameters + use strucrd + use hungarian_module + use axis_module,only:axis + implicit none + character(len=*),intent(in) :: fname1 + character(len=*),intent(in) :: fname2 + logical,intent(in) :: heavy + type(coord) :: mol,ref + real(wp) :: rmsdval + integer :: i,ii,jj,nat,io,ich + logical,allocatable :: mask(:) + real(wp),allocatable :: C(:,:) + real(wp),allocatable :: answers(:) + integer,allocatable :: mapping(:) + integer,allocatable :: hmap(:),rhmap(:) + integer,allocatable :: a(:),b(:) + real(wp) :: dists(3) + + call ref%open(fname1) + call mol%open(fname2) + + !> align to rotational axes and shift to center of mass + call axis(ref%nat,ref%at,ref%xyz) + call axis(mol%nat,mol%at,mol%xyz) + + if (heavy) then + allocate (mask(ref%nat),source=.false.) + allocate (hmap(ref%nat),rhmap(ref%nat),source=0) + nat = count((ref%at(:) > 1)) + ii = 0 + do i = 1,ref%nat + if (ref%at(i) > 1) then + mask(i) = .true. + ii = ii+1 + hmap(i) = ii + rhmap(ii) = i + end if + end do + else + allocate (mask(ref%nat),source=.true.) + nat = ref%nat + end if + + allocate (C(nat,nat),answers(nat)) + allocate (mapping(nat+1)) + do ii = 1,nat + if (.not.mask(ii)) cycle + do jj = 1,nat + if (.not.mask(jj)) cycle + dists(:) = (ref%xyz(:,ii)-mol%xyz(:,jj))**2 + if (heavy) then + C(hmap(jj),hmap(ii)) = sqrt(sum(dists)) + else + C(jj,ii) = sqrt(sum(dists)) + end if + end do + end do + allocate (a(nat),b(nat)) + call lsap(C,nat,nat,a,b) + + write (*,'(a,3(1x,a))') 'Assignment:',fname2,'-->',fname1 + do i = 1,nat + if (heavy) then + write (*,'(i6," --> ",i6)') rhmap(a(i)),rhmap(b(i)) + else + write (*,'(i6," --> ",i6)') a(i),b(i) + end if + end do + write (*,*) + !> write the rotated and shifted coordinates to one file + open (newunit=ich,file='lsap.xyz') + call ref%append(ich) + call mol%append(ich) + close (ich) + + !> reconstruct RMSD from assignment (since our costs are already distances!) + rmsdval = 0.0_wp + do i = 1,nat + rmsdval = rmsdval+C(a(i),b(i))/real(nat,wp) + end do + rmsdval = sqrt(abs(rmsdval))*autoaa + if (heavy) then + write (*,'(1x,a,f16.8)') 'Calculated heavy atom RMSD (Å):',rmsdval + else + write (*,'(1x,a,f16.8)') 'Calculated RMSD (Å):',rmsdval + end if + + return +end subroutine quick_hungarian_match + +!=========================================================================================! + subroutine resort_ensemble(fname) !************************************************ !* resort all structures of a given ensemblefile diff --git a/src/miscdata.f90 b/src/miscdata.f90 index 79dc3a7f..d2359ae2 100644 --- a/src/miscdata.f90 +++ b/src/miscdata.f90 @@ -99,6 +99,30 @@ module miscdata & 1.36_wp,1.43_wp,1.46_wp,1.58_wp,1.48_wp,1.57_wp ] ! Nh-Og !&> +!&< + !> Colvlent Radii as used in QCG. No idea where they originate from; Legacy. + real(wp),parameter :: rcov_qcg(1:94) = [ & + & 2.18230009,1.73469996,3.49559999,3.09820008,3.21600008, & + & 2.91030002,2.62249994,2.48169994,2.29959989,2.13739991, & + & 3.70819998,3.48390007,4.01060009,3.79169989,3.50169992, & + & 3.31069994,3.10459995,2.91479993,4.24109983,4.10349989, & + & 3.89030004,3.76419997,3.72110009,3.44140005,3.54620004, & + & 3.44210005,3.43269992,3.34619999,3.30080009,3.23090005, & + & 3.95790005,3.86190009,3.66249990,3.52679992,3.36619997, & + & 3.20959997,4.61759996,4.47639990,4.21960020,4.05970001, & + & 3.85960007,3.75430012,3.56900001,3.46230006,3.39750004, & + & 3.35249996,3.33080006,3.46199989,4.26230001,4.18739986, & + & 4.01499987,3.89010000,3.73799992,3.58890009,5.05670023, & + & 5.18139982,4.62610006,4.62010002,4.57019997,4.52710009, & + & 4.48960018,4.45149994,4.42339993,4.12430000,4.24270010, & + & 4.15409994,4.27939987,4.24499989,4.22079992,4.19859982, & + & 4.01300001,4.24499989,4.09800005,3.98550010,3.89549994, & + & 3.74900007,3.44560003,3.35249996,3.25640011,3.35990000, & + & 4.31269979,4.27640009,4.11749983,4.00540018,3.86439991, & + & 3.72160006,5.07959986,4.92939997,4.70429993,4.42519999, & + & 4.45940018,4.39569998,4.35389996,4.43410015] +!&> + !&< !> D3 pairwise van-der-Waals radii (only homoatomic pairs present here) diff --git a/src/optimize/CMakeLists.txt b/src/optimize/CMakeLists.txt index 1fd034a2..3b953469 100644 --- a/src/optimize/CMakeLists.txt +++ b/src/optimize/CMakeLists.txt @@ -20,8 +20,10 @@ list(APPEND srcs "${dir}/ancopt.f90" "${dir}/gd.f90" "${dir}/rfo.f90" + "${dir}/lbfgs.f90" "${dir}/hessupdate.f90" "${dir}/modelhessian.f90" + "${dir}/coordtrafo.f90" "${dir}/optimize_maths.f90" "${dir}/optimize_module.f90" "${dir}/optimize_type.f90" diff --git a/src/optimize/ancopt.f90 b/src/optimize/ancopt.f90 index 66af8308..7496caef 100644 --- a/src/optimize/ancopt.f90 +++ b/src/optimize/ancopt.f90 @@ -62,7 +62,7 @@ subroutine ancopt(mol,calc,etot,grd,pr,wr,iostatus) !> on output final energy !> grd - Cartesian gradient !> pr - printout bool -!> wr - logfile (crestopt.log) bool +!> wr - logfile (crestopt.log.xyz) bool !> iostatus - return status of the routine !> (success=0, error<0, not converged>0) !!*********************************************************************** @@ -171,7 +171,7 @@ subroutine ancopt(mol,calc,etot,grd,pr,wr,iostatus) !>--- initialize .log file, if desired ilog = 942 if (wr) then - open (newunit=ilog,file='crestopt.log') + open (newunit=ilog,file='crestopt.log.xyz') end if !>--- The ANCOPT iteration loop. "iter" is updated in relax() subroutine diff --git a/src/optimize/coordtrafo.f90 b/src/optimize/coordtrafo.f90 new file mode 100644 index 00000000..7c778dc6 --- /dev/null +++ b/src/optimize/coordtrafo.f90 @@ -0,0 +1,232 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2025 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module coordinate_transform_module +!*********************************************************************** +!* Module: coordinate_transform_module +!* +!* This module provides transformation routines for converting between +!* different coordinate representations. In particular, it includes routines +!* to transform 3D Cartesian coordinates (stored in a 'coord' type from the +!* strucrd module) into a 1D vector representation and vice versa. It also +!* provides routines to transform gradients between a 3D representation (as a +!* 2D array with dimensions 3 x nat) and a 1D vector. These routines are useful +!* in optimization contexts where a flattened variable representation is required. +!*********************************************************************** + use crest_parameters + use strucrd + implicit none + private + + public :: compute_nvar,transform_mol,transform_grd + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + function compute_nvar(mol) result(nvar) + !*********************************************************************** + !* Function compute_nvar + !* Computes the number of variables for a system with nat atoms. + !* nvar is defined as 3 * nat. + !*********************************************************************** + implicit none + type(coord),intent(in) :: mol + integer :: nvar + + nvar = 3*mol%nat + end function compute_nvar + +!========================================================================================! + + subroutine transform_mol(transformation_type,mol,nvar,vec) + !*********************************************************************** + !* Subroutine transform_mol + !* Wrapper routine for coordinate transformations on a molecule. + !* Supported transformation types: + !* "cart2v" - Transforms mol%xyz (3D Cartesian coordinates) into a 1D vector. + !* "v2cart" - Transforms a 1D vector into mol%xyz. + !* + !* @param transformation_type Character string specifying the transformation. + !* @param mol Type(coord) variable containing Cartesian coordinates. + !* @param vec 1D real(wp) vector (input for "v2cart", output for "cart2v"). + !* @param nvar Integer, number of variables (nvar = 3*mol%nat). + !*********************************************************************** + implicit none + character(len=*),intent(in) :: transformation_type + type(coord),intent(inout) :: mol + real(wp),intent(inout) :: vec(nvar) + integer,intent(in) :: nvar + + select case (trim(transformation_type)) + case ("cart2v") + call cartesian_to_vector(mol,vec,nvar) + case ("v2cart") + call vector_to_cartesian(vec,nvar,mol) + case default + write(*,*)"Error: Transformation type not recognized in transform_mol." + stop + end select + end subroutine transform_mol + +!========================================================================================! + + subroutine transform_grd(transformation_type,mol,grd,nvar,vec) + !*********************************************************************** + !* Subroutine transform_grd + !* Wrapper routine for gradient transformations. + !* Supported transformation types: + !* "grd2v" - Transforms a 3D gradient array grd(3, nat) into a 1D vector. + !* "v2grd" - Transforms a 1D gradient vector into a 3D array grd(3, nat). + !* + !* @param transformation_type Character string specifying the transformation. + !* @param grd 3D gradient array (3 x nat); input for "grd2v" + !* and output for "v2grd". + !* @param vec 1D real(wp) vector (output for "grd2v", input for "v2grd"). + !* @param nvar Integer, number of variables (nvar = 3*nat). + !*********************************************************************** + implicit none + character(len=*),intent(in) :: transformation_type + type(coord),intent(inout) :: mol + real(wp),intent(inout) :: grd(3,mol%nat) + real(wp),intent(inout) :: vec(nvar) + integer,intent(inout) :: nvar + integer :: nat + + nat = mol%nat + select case (trim(transformation_type)) + case ("cart2v") + call gradient_to_vector(grd,nat,vec,nvar) + case ("v2cart") + call vector_to_gradient(vec,nvar,grd,nat) + case default + write(*,*)"Error: Transformation type not recognized in transform_grd." + stop + end select + end subroutine transform_grd + +!========================================================================================! + + subroutine cartesian_to_vector(mol,x,nvar) + !*********************************************************************** + ! Subroutine cartesian_to_vector + ! Transforms 3D Cartesian coordinates from mol%xyz into a 1D vector x. + ! The number of variables is computed as nvar = 3 * mol%nat. + !*********************************************************************** + implicit none + type(coord),intent(in) :: mol + real(wp),intent(out) :: x(nvar) + integer,intent(in) :: nvar + integer :: i,j,idx + + x = reshape(mol%xyz, [nvar]) + !idx = 0 + !do j = 1,mol%nat + ! do i = 1,3 + ! idx = idx+1 + ! x(idx) = mol%xyz(i,j) + ! end do + !end do + end subroutine cartesian_to_vector + + subroutine vector_to_cartesian(x,nvar,mol) + !*********************************************************************** + ! Subroutine vector_to_cartesian + ! Transforms a 1D vector x into 3D Cartesian coordinates stored in mol%xyz. + ! It computes the number of atoms as nat = nvar / 3 and allocates mol%xyz. + !*********************************************************************** + implicit none + integer,intent(in) :: nvar + real(wp),intent(in) :: x(nvar) + type(coord),intent(inout) :: mol + integer :: nat,i,j,idx + + if (mod(nvar,3) /= 0) then + write(*,*)"Error: nvar must be a multiple of 3." + stop + end if + + mol%xyz = reshape(x,[3,mol%nat]) +! nat = mol%nat +! idx = 0 +! do j = 1,nat +! do i = 1,3 +! idx = idx+1 +! mol%xyz(i,j) = x(idx) +! end do +! end do + end subroutine vector_to_cartesian + +!========================================================================================! + + subroutine gradient_to_vector(grd,nat,g,nvar) + !*********************************************************************** + !* Subroutine gradient_to_vector + !* Transforms a 3D gradient array grd(3, nat) into a 1D vector g. + !* The number of variables is computed as nvar = 3 * nat. + !*********************************************************************** + implicit none + integer,intent(in) :: nat,nvar + real(wp),intent(in) :: grd(3,nat) + real(wp),intent(out) :: g(nvar) + integer :: i,j,idx + + g = reshape(grd, [nvar]) + !idx = 0 + !do j = 1,nat + ! do i = 1,3 + ! idx = idx+1 + ! g(idx) = grd(i,j) + ! end do + !end do + end subroutine gradient_to_vector + + subroutine vector_to_gradient(g,nvar,grd,nat) + !*********************************************************************** + !* Subroutine vector_to_gradient + !* Transforms a 1D gradient vector g into a 3D gradient array grd(3, nat). + !* It computes the number of atoms as nat = nvar / 3 and allocates grd. + !*********************************************************************** + implicit none + integer,intent(in) :: nvar,nat + real(wp),intent(in) :: g(nvar) + real(wp),intent(out) :: grd(3,nat) + integer :: i,j,idx + + if (mod(nvar,3) /= 0) then + write(*,*)"Error: nvar must be a multiple of 3." + stop + end if + + grd = reshape(g, [3,nat]) + !idx = 0 + !do j = 1,nat + ! do i = 1,3 + ! idx = idx+1 + ! grd(i,j) = g(idx) + ! end do + !end do + end subroutine vector_to_gradient + +!========================================================================================! +!========================================================================================! +end module coordinate_transform_module + diff --git a/src/optimize/gd.f90 b/src/optimize/gd.f90 index 00c57bfe..7de349f5 100644 --- a/src/optimize/gd.f90 +++ b/src/optimize/gd.f90 @@ -57,7 +57,7 @@ subroutine gradientdescent(mol,calc,etot,grd,pr,wr,iostatus) !> on output final energy !> grd - Cartesian gradient !> pr - printout bool -!> wr - logfile (crestopt.log) bool +!> wr - logfile (crestopt.log.xyz) bool !> iostatus - return status of the routine !> (success=0, error<0, not converged>0) !!*********************************************************************** @@ -164,7 +164,7 @@ subroutine gradientdescent(mol,calc,etot,grd,pr,wr,iostatus) !>--- initialize .log file, if desired ilog = 942 if (wr) then - open (newunit=ilog,file='crestopt.log') + open (newunit=ilog,file='crestopt.log.xyz') end if !>--- The gradient descent iteration loop. "iter" diff --git a/src/optimize/lbfgs.f90 b/src/optimize/lbfgs.f90 new file mode 100644 index 00000000..2fea6756 --- /dev/null +++ b/src/optimize/lbfgs.f90 @@ -0,0 +1,311 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2025 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +!> This module implemnts a simple L-BFGS with different coordinate choices + +module lbfgs_module + use,intrinsic :: iso_fortran_env,only:wp => real64 + use crest_calculator + use strucrd + use optimize_type !> This module provides the 'optimizer' type. + use optimize_utils + use coordinate_transform_module + implicit none + private + + public :: lbfgs_optimize + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + function lbfgs_direction(nvar,g,k,OPT,gamm) result(d) + !******************************************************************************* + !* Two-loop recursion routine to compute the search direction. + !* + !* This function uses the stored correction pairs (S and Y) and + !* corresponding scaling factors (rho) to approximate the product + !* H*g, where H is the inverse Hessian approximation. + !* + !* The algorithm proceeds in two loops: + !* 1. The first (backward) loop computes the coefficients "alpha" and + !* subtracts corrections from the gradient. + !* 2. The second (forward) loop applies the corrections in the reverse order. + !* Finally, the result is negated to obtain the descent direction. + !* Note, this routine is NOT called for the very first iteration (k == 0) + !* + !* @param nvar Dimension of the variable space. + !* @param k Number of stored correction pairs (k ≤ m). + !* @param g Current gradient vector. + !* @param OPT optimizer type that stores the following variables + !* => S Matrix containing the s-vectors (x_{k+1} - x_k), + !* of size(nvar, m). + !* => Y Matrix containing the y-vectors (g_{k+1} - g_k), + !* of size(nvar, m). + !* => rho Array of stored values 1/(y^T*s) for each correction. + !* => alpha coefficients (get computed in this function) + !* => q temporary workspace + !* @param gamm Scaling factor for the initial Hessian approximation. + !* + !* @return d Computed search direction (negative approximate inverse + !* Hessian times g). + !******************************************************************************** + !> INPUT + integer,intent(in) :: nvar,k + type(optimizer),intent(inout) :: OPT + real(wp),intent(in) :: g(nvar) + real(wp),intent(in) :: gamm + !> OUTPUT + real(wp) :: d(nvar) + !> LOCAL + integer :: i + + associate (S => OPT%S,Y => OPT%Y,alpha => OPT%alpha,rho => OPT%rho,q => OPT%q) + + !write(*,*) k + !write(*,*) S(:,k) + !write(*,*) Y(:,k) + !> Initialize q with the current gradient. + q = g + + !--------------------------------------------------------- + !> First loop (backward pass): for i = k downto 1, + !> compute the coefficient alpha(i) and update q. + !--------------------------------------------------------- + do i = k,1,-1 + alpha(i) = rho(i)*dot_product(S(1:nvar,i),q) + q = q-alpha(i)*Y(1:nvar,i) + end do + + !--------------------------------------------------------- + !> Apply the initial Hessian approximation. + !> We use a scaled identity matrix H0 = gamm * I. + !--------------------------------------------------------- + d = gamm*q + + !--------------------------------------------------------- + !> Second loop (forward pass): for i = 1 to k, + !> compute the correction and update d. + !--------------------------------------------------------- + do i = 1,k + d = d+S(1:nvar,i)*(alpha(i)-rho(i)*dot_product(Y(1:nvar,i),d)) + end do + + !> The final search direction is the negative of d. + d = -d + + end associate + end function lbfgs_direction + +!========================================================================================! + + subroutine lbfgs_optimize(mol,calc,etot,grd,pr,io) + !************************************************************************** + !* L-BFGS Optimization Routine + !* + !* Performs optimization using the Limited-memory BFGS (L-BFGS) algorithm. + !* The routine updates the coordinate vector x to approach a local minimum of the + !* objective function. It integrates with an optimizer type (OPT) to manage the + !* correction pairs (s and y) and related internal data using associate constructs. + !* + !* The main steps include: + !* 1. Evaluating the objective function and gradient at the current x. + !* 2. Computing the search direction via the two-loop recursion (lbfgs_direction). + !* 3. Updating x using a fixed step (with the option to incorporate a line search). + !* 4. Updating the correction pairs: s = x_new - x and y = g_new - g, while managing + !* the history using a shifting strategy when full. + !* + !* @param io Integer. Output status variable (0 indicates success). + !************************************************************************** + implicit none + !> INPUT + type(coord),intent(inout) :: mol + type(calcdata),intent(in) :: calc + real(wp),intent(inout) :: etot + real(wp),intent(inout) :: grd(3,mol%nat) + logical,intent(in) :: pr + !> OUTPUT + integer,intent(out) :: io + !> LOCAL + type(optimizer) :: OPT + integer :: iter,k,nvar,m + integer :: tight,max_iter + real(wp) :: gnorm,deltaE,energy + real(wp) :: ethr,gthr,maxerise + logical :: econverged,gconverged,converged,Erise + real(wp),allocatable :: x(:),g(:),d(:),g_new(:),x_new(:),gtmp(:,:) + real(wp) :: f,f_new,gamm,step + integer :: ilog + + !> Prepare settings + io = 0 + nvar = compute_nvar(mol) + m = calc%lbfgs_histsize + gnorm = norm2(grd) + deltaE = huge(deltaE) + tight = calc%optlev + call get_optthr(mol%nat,tight,calc,ethr,gthr) + max_iter = calc%maxcycle !> automatic setting in get_optthr or by user + maxerise = calc%maxerise + econverged = .false. + gconverged = .false. + converged = .false. + + open (newunit=ilog,file='crestopt.log.xyz') + call mol%appendlog(ilog,etot) + + !$omp critical + !> Allocate the vectors for position, gradient, and search direction. + allocate (x(nvar),g(nvar),d(nvar),g_new(nvar),x_new(nvar),gtmp(3,mol%nat)) + !> Allocate matrices to store up to m correction pairs (columns correspond to each stored pair). + call OPT%allocatelbfgs(nvar,m) + !$omp end critical + + associate (S => OPT%S,Y => OPT%Y,rho => OPT%rho,alpha => OPT%alpha) + S = 0.0_wp + Y = 0.0_wp + rho = 0.0_wp + k = 0 ! Initially, no correction pairs are stored. + + !> First trafo + call transform_mol('cart2v',mol,nvar,x) + call transform_grd('cart2v',mol,grd,nvar,g) + + iter = 0 + if (pr) then + call print_optiter(iter) + write (*,'(" * total energy :",f14.7,1x,"Eh")',advance='no') etot + write (*,'(5x,"change ΔE",e18.7,1x,"Eh")') 0.0_wp + write (*,'(3x,"gradient norm :",f14.7,1x,"Eh/a0")') gnorm + end if + + LBFGS_iter: do while (.not.converged.and.iter < max_iter) + iter = iter+1 + if (pr) call print_optiter(iter) + + if (iter == 1) then + !> First iteration: use the steepest descent direction. + d = -g + else + !--------------------------------------------------------- + !> Determine the scaling factor gamm for the initial Hessian. + ! Here we use the most recent correction pair. + !--------------------------------------------------------- + if (k > 0) then + gamm = dot_product(S(1:nvar,k),Y(1:nvar,k))/ & + dot_product(Y(1:nvar,k),Y(1:nvar,k)) + else + gamm = 1.0_wp + end if + + !> Compute the search direction using the two-loop recursion. + d = lbfgs_direction(nvar,g,k,OPT,gamm) + end if + + !--------------------------------------------------------- + !> A fixed step size could be used here for simplicity. + ! In a full implementation, a line search could be used. + ! If the energy rises, we reduce the stepsize iteratively + !--------------------------------------------------------- + step = 0.2_wp + + Erise = .true. + do while (Erise) + !> Update the position: x_new = x + step * d. + x_new = x+step*d + + !====================================================================! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Evaluate the objective and gradient at the new position. + call transform_mol('v2cart',mol,nvar,x_new) + grd = 0.0_wp + call engrad(mol,calc,energy,gtmp,io) + call mol%appendlog(ilog,energy) + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< maxerise) + if (Erise) then + step = step*0.25_wp + if (pr) then + write (*,'(" * energy rise detected, decreasing stepsize")') + end if + end if + end do + econverged = abs(deltaE) .lt. ethr + gconverged = gnorm .lt. gthr + + !--------------------------------------------------------- + !> Compute the correction pair: + ! s = x_new - x and y = g_new - g. + !--------------------------------------------------------- + if (k < m) then + !> If there is still room in the history, simply add the new pair. + k = k+1 + S(1:nvar,k) = x_new-x + Y(1:nvar,k) = g_new-g + else + !> When the history is full, shift the stored corrections and + !> insert the new pair at the end. + S(1:nvar,1:m-1) = S(1:nvar,2:m) + Y(1:nvar,1:m-1) = Y(1:nvar,2:m) + S(1:nvar,m) = x_new-x + Y(1:nvar,m) = g_new-g + end if + + !> Update the scaling factor for the new correction pair. + rho(k) = 1.0_wp/dot_product(Y(1:nvar,k),S(1:nvar,k)) + + !> Update the current position, gradient, and function value. + x = x_new + g = g_new + etot = energy + + !> Optional: print iteration information. + if (pr) then + write (*,'(" * total energy :",f14.7,1x,"Eh")',advance='no') etot + write (*,'(5x,"change ΔE",e18.7,1x,"Eh")') deltaE + write (*,'(3x,"gradient norm :",f14.7,1x,"Eh/a0")',advance='no') gnorm + call print_convd(econverged,gconverged) + end if + converged = econverged.and.gconverged + end do LBFGS_iter + + !> stop associating + end associate + + !> Final trafo + call transform_mol('v2cart',mol,nvar,x_new) + call transform_grd('v2cart',mol,grd,nvar,g_new) + + !> Deallocate all temporary arrays. + deallocate (x_new,g_new,d,g,x) + end subroutine lbfgs_optimize + +!========================================================================================! +!========================================================================================! +end module lbfgs_module + diff --git a/src/optimize/meson.build b/src/optimize/meson.build index ad786316..1a4241a5 100644 --- a/src/optimize/meson.build +++ b/src/optimize/meson.build @@ -18,6 +18,8 @@ srcs += files( 'ancopt.f90', 'gd.f90', 'rfo.f90', + 'lbfgs.f90', + 'coordtrafo.f90', 'hessupdate.f90', 'modelhessian.f90', 'optimize_maths.f90', diff --git a/src/optimize/optimize_maths.f90 b/src/optimize/optimize_maths.f90 index 3be196e3..51284577 100644 --- a/src/optimize/optimize_maths.f90 +++ b/src/optimize/optimize_maths.f90 @@ -117,8 +117,8 @@ recursive subroutine detrotra_qsort(a,first,last,ind) i = i+1 j = j-1 end do - if (first < i-1) call qsort(a,first,i-1,ind) - if (j+1 < last) call qsort(a,j+1,last,ind) + if (first < i-1) call detrotra_qsort(a,first,i-1,ind) + if (j+1 < last) call detrotra_qsort(a,j+1,last,ind) end subroutine detrotra_qsort end subroutine detrotra8 diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index a1e24d2a..a942a85a 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -31,6 +31,7 @@ module optimize_module use ancopt_module use gradientdescent_module use rfo_module + use lbfgs_module use optimize_utils use thermochem_module use hessian_reconstruct @@ -90,15 +91,16 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) !> optimization select case (calc%opt_engine) - case (0) - call ancopt(molnew,calc,etot,grd,pr,wr,iostatus) - case (1) - !> l-bfgs goes here - write (stdout,'(a)') 'L-BFGS currently not implemented' - stop - case (2) - !> rfo goes here - call rfopt(molnew,calc,etot,grd,pr,wr,iostatus) + case ( 0) + call ancopt(molnew,calc,etot,grd,pr,wr,iostatus) + case ( 1) + !> l-bfgs goes here + !write(stdout,'(a)') 'L-BFGS currently not implemented' + !stop + call lbfgs_optimize(molnew,calc,etot,grd,pr,iostatus) + case ( 2) + !> rfo goes here + call rfopt(molnew,calc,etot,grd,pr,wr,iostatus) case (-1) call gradientdescent(molnew,calc,etot,grd,pr,wr,iostatus) case default @@ -158,14 +160,27 @@ end subroutine optimize_geometry !========================================================================================! - subroutine print_opt_data(calc,ich) + subroutine print_opt_data(calc,ich,natoms,tag) implicit none type(calcdata) :: calc integer,intent(in) :: ich - integer :: tight + integer,intent(in),optional :: natoms + character(len=*),intent(in),optional :: tag + integer :: tight,nat real(wp) :: ethr,gthr - - write (ich,'(1x,a)',advance='no') 'Optimization engine: ' + character(len=:),allocatable :: ttag + if(present(tag))then + ttag=tag + else + ttag=' ' + endif + if(present(natoms))then + nat=natoms + else + nat=0 + endif + + write (ich,'(a,a)',advance='no') ttag,'Optimization engine: ' select case (calc%opt_engine) case (0) write (ich,'(a)') 'ANCOPT' @@ -179,7 +194,7 @@ subroutine print_opt_data(calc,ich) write (ich,'(a)') 'Unknown' end select if (calc%opt_engine >= 0) then - write (ich,'(1x,a)',advance='no') 'Hessian update type: ' + write (ich,'(a,a)',advance='no') ttag,'Hessian update type: ' select case (calc%iupdat) case (0) write (ich,'(a)') 'BFGS' @@ -195,12 +210,12 @@ subroutine print_opt_data(calc,ich) end if tight = calc%optlev - call get_optthr(0,tight,calc,ethr,gthr) - write (ich,'(1x,a,e10.3,a,e10.3,a)') 'E/G convergence criteria: ',& + call get_optthr(nat,tight,calc,ethr,gthr) + write (ich,'(a,a,e10.3,a,e10.3,a)') ttag,'E/G convergence criteria: ',& & ethr,' Eh,',gthr,' Eh/a0' - write (ich,'(1x,a,i0)') 'maximum optimization steps: ',calc%maxcycle - + write (ich,'(a,a,i0)') ttag,'maximum optimization steps: ',calc%maxcycle + end subroutine print_opt_data !========================================================================================! diff --git a/src/optimize/optimize_type.f90 b/src/optimize/optimize_type.f90 index 1ced8342..6a659773 100644 --- a/src/optimize/optimize_type.f90 +++ b/src/optimize/optimize_type.f90 @@ -21,34 +21,46 @@ ! under the Open-source software LGPL-3.0 Licencse. !================================================================================! module optimize_type - use iso_fortran_env, only: wp=>real64 - use optimize_maths, only: detrotra8 - implicit none - - public :: optimizer - public :: convergence_log - private - - type optimizer - integer :: n !< number of atoms - integer :: n3 !< dimension of hessian - integer :: nvar !< actual dimension - real(wp) :: hlow - real(wp) :: hmax - real(wp),allocatable :: hess(:) - real(wp),allocatable :: B(:,:) - real(wp),allocatable :: eigv(:) - real(wp),allocatable :: coord(:) - real(wp),allocatable :: xyz(:,:) - contains - procedure :: allocate => allocate_anc - procedure :: allocate2 => allocate_opt - procedure :: deallocate => deallocate_anc - procedure :: write => write_anc - procedure :: new => generate_anc_blowup - procedure :: get_cartesian - end type optimizer - + use iso_fortran_env,only:wp => real64 + use optimize_maths,only:detrotra8 + implicit none + + public :: optimizer + public :: convergence_log + private + + type optimizer + !****************************************************** + !* Storage type for optimizations + !* + !* Depending on the chosen optimization algorithm + !* different variables in this will be used/allocated + !****************************************************** + integer :: n !< number of atoms + integer :: n3 !< dimension of hessian + integer :: nvar !< actual dimension + real(wp) :: hlow + real(wp) :: hmax + real(wp),allocatable :: hess(:) + real(wp),allocatable :: B(:,:) + real(wp),allocatable :: eigv(:) + real(wp),allocatable :: coord(:) + real(wp),allocatable :: xyz(:,:) + !> L-BFGS block + integer :: m !> history size + real(wp),allocatable :: S(:,:),Y(:,:) + real(wp),allocatable :: rho(:) + real(wp),allocatable :: alpha(:) + real(wp),allocatable :: q(:) + contains + procedure :: allocate => allocate_anc + procedure :: allocate2 => allocate_opt + procedure :: allocatelbfgs => allocate_lbfgs + procedure :: deallocate => deallocate_anc + procedure :: write => write_anc + procedure :: new => generate_anc_blowup + procedure :: get_cartesian + end type optimizer type :: convergence_log integer :: nlog @@ -62,7 +74,6 @@ module optimize_type interface convergence_log module procedure new_convergence_log end interface convergence_log - !========================================================================================! !========================================================================================! @@ -70,362 +81,372 @@ module optimize_type !========================================================================================! !========================================================================================! -subroutine allocate_anc(self,n,nvar,hlow,hmax) - implicit none - class(optimizer),intent(inout) :: self - integer, intent(in) :: n - integer, intent(in) :: nvar - integer :: n3 - real(wp),intent(in),optional :: hlow - real(wp),intent(in),optional :: hmax - n3 = 3*n - call self%deallocate - self%n = n - self%n3 = 3*n - self%nvar = nvar - if (present(hlow)) self%hlow = hlow - if (present(hmax)) self%hmax = hmax - allocate( self%hess(nvar*(nvar+1)/2), source = 0.0_wp ) - allocate( self%B(n3,n3), source = 0.0_wp ) - allocate( self%eigv(n3), source = 0.0_wp ) - allocate( self%coord(nvar), source = 0.0_wp ) - allocate( self%xyz(3,n), source = 0.0_wp ) -end subroutine allocate_anc - - -subroutine allocate_opt(self,n)!,nvar) - implicit none - class(optimizer),intent(inout) :: self - integer, intent(in) :: n - !integer, intent(in) :: nvar - integer :: nvar - integer :: n3 - !real(wp),intent(in),optional :: hlow - !real(wp),intent(in),optional :: hmax - n3 = 3*n - call self%deallocate - self%n = n - self%n3 = 3*n - nvar = 3*n - self%nvar = nvar - allocate( self%hess(nvar*(nvar+1)/2), source = 0.0_wp ) - !allocate( self%B(n3,n3), source = 0.0_wp ) - allocate( self%eigv(n3), source = 0.0_wp ) - !allocate( self%coord(nvar), source = 0.0_wp ) - !allocate( self%xyz(3,n), source = 0.0_wp ) -end subroutine allocate_opt - - + subroutine allocate_anc(self,n,nvar,hlow,hmax) + implicit none + class(optimizer),intent(inout) :: self + integer,intent(in) :: n + integer,intent(in) :: nvar + integer :: n3 + real(wp),intent(in),optional :: hlow + real(wp),intent(in),optional :: hmax + n3 = 3*n + call self%deallocate + self%n = n + self%n3 = 3*n + self%nvar = nvar + if (present(hlow)) self%hlow = hlow + if (present(hmax)) self%hmax = hmax + allocate (self%hess(nvar*(nvar+1)/2),source=0.0_wp) + allocate (self%B(n3,n3),source=0.0_wp) + allocate (self%eigv(n3),source=0.0_wp) + allocate (self%coord(nvar),source=0.0_wp) + allocate (self%xyz(3,n),source=0.0_wp) + end subroutine allocate_anc + + subroutine allocate_opt(self,n) + implicit none + class(optimizer),intent(inout) :: self + integer,intent(in) :: n + integer :: nvar + integer :: n3 + n3 = 3*n + call self%deallocate + self%n = n + self%n3 = 3*n + nvar = 3*n + self%nvar = nvar + allocate (self%hess(nvar*(nvar+1)/2),source=0.0_wp) + allocate (self%eigv(n3),source=0.0_wp) + end subroutine allocate_opt + + subroutine allocate_lbfgs(self,nvar,mem) + implicit none + class(optimizer),intent(inout) :: self + integer,intent(in) :: nvar,mem + call self%deallocate + self%m = mem + self%nvar = nvar + allocate(self%S(nvar,mem)) + allocate(self%Y(nvar,mem)) + allocate(self%rho(mem)) + allocate(self%alpha(mem)) + allocate(self%q(nvar)) + end subroutine allocate_lbfgs !========================================================================================! -subroutine deallocate_anc(self) - implicit none - class(optimizer),intent(inout) :: self - self%n = 0 - self%n3 = 0 - self%nvar = 0 - if (allocated(self%hess )) deallocate( self%hess ) - if (allocated(self%B )) deallocate( self%B ) - if (allocated(self%eigv )) deallocate( self%eigv ) - if (allocated(self%coord)) deallocate( self%coord ) - if (allocated(self%xyz )) deallocate( self%xyz ) -end subroutine deallocate_anc + subroutine deallocate_anc(self) + implicit none + class(optimizer),intent(inout) :: self + self%n = 0 + self%n3 = 0 + self%nvar = 0 + if (allocated(self%hess)) deallocate (self%hess) + if (allocated(self%B)) deallocate (self%B) + if (allocated(self%eigv)) deallocate (self%eigv) + if (allocated(self%coord)) deallocate (self%coord) + if (allocated(self%xyz)) deallocate (self%xyz) + if (allocated(self%S)) deallocate (self%S) + if (allocated(self%Y)) deallocate (self%Y) + if (allocated(self%rho)) deallocate (self%rho) + if (allocated(self%alpha)) deallocate (self%alpha) + if (allocated(self%q)) deallocate(self%q) + end subroutine deallocate_anc !========================================================================================! !> @brief print information about current approximate normal coordinates to unit -subroutine write_anc(self,iunit,comment) - implicit none - class(optimizer), intent(in) :: self !< approximate normal coordinates - integer, intent(in) :: iunit !< file handle - character(len=*),intent(in) :: comment !< name of the variable - character(len=*),parameter :: dfmt = '(1x,a,1x,"=",1x,g0)' - - write(iunit,'(72(">"))') - write(iunit,'(1x,"*",1x,a)') "Writing 'optimizer' class" - write(iunit,'( "->",1x,a)') comment - write(iunit,'(72("-"))') - write(iunit,'(1x,"*",1x,a)') "status of the fields" - write(iunit,dfmt) "integer :: n ",self%n - write(iunit,dfmt) "integer :: n3 ",self%n3 - write(iunit,dfmt) "integer :: nvar ",self%nvar - write(iunit,dfmt) "real :: hlow ",self%hlow - write(iunit,dfmt) "real :: hmax ",self%hmax - write(iunit,'(72("-"))') - write(iunit,'(1x,"*",1x,a)') "allocation status" - write(iunit,dfmt) "allocated? hess(:) ",allocated(self%hess) - write(iunit,dfmt) "allocated? B(:) ",allocated(self%B) - write(iunit,dfmt) "allocated? eigv(:) ",allocated(self%eigv) - write(iunit,dfmt) "allocated? coord(:) ",allocated(self%coord) - write(iunit,dfmt) "allocated? xyz(:,:) ",allocated(self%xyz) - write(iunit,'(72("-"))') - write(iunit,'(1x,"*",1x,a)') "size of memory allocation" - if (allocated(self%hess)) then - write(iunit,dfmt) "size(1) :: hess(*) ",size(self%hess,1) - endif - if (allocated(self%B)) then - write(iunit,dfmt) "size(1) :: B(*,:) ",size(self%B,1) - write(iunit,dfmt) "size(2) :: B(:,*) ",size(self%B,2) - endif - if (allocated(self%eigv)) then - write(iunit,dfmt) "size(1) :: eigv(*) ",size(self%eigv,1) - endif - if (allocated(self%coord)) then - write(iunit,dfmt) "size(1) :: coord(*) ",size(self%coord,1) - endif - if (allocated(self%xyz)) then - write(iunit,dfmt) "size(1) :: xyz(*,:) ",size(self%xyz,1) - write(iunit,dfmt) "size(2) :: xyz(:,*) ",size(self%xyz,2) - endif - write(iunit,'(72("<"))') -end subroutine write_anc + subroutine write_anc(self,iunit,comment) + implicit none + class(optimizer),intent(in) :: self !< approximate normal coordinates + integer,intent(in) :: iunit !< file handle + character(len=*),intent(in) :: comment !< name of the variable + character(len=*),parameter :: dfmt = '(1x,a,1x,"=",1x,g0)' + + write (iunit,'(72(">"))') + write (iunit,'(1x,"*",1x,a)') "Writing 'optimizer' class" + write (iunit,'( "->",1x,a)') comment + write (iunit,'(72("-"))') + write (iunit,'(1x,"*",1x,a)') "status of the fields" + write (iunit,dfmt) "integer :: n ",self%n + write (iunit,dfmt) "integer :: n3 ",self%n3 + write (iunit,dfmt) "integer :: nvar ",self%nvar + write (iunit,dfmt) "real :: hlow ",self%hlow + write (iunit,dfmt) "real :: hmax ",self%hmax + write (iunit,'(72("-"))') + write (iunit,'(1x,"*",1x,a)') "allocation status" + write (iunit,dfmt) "allocated? hess(:) ",allocated(self%hess) + write (iunit,dfmt) "allocated? B(:) ",allocated(self%B) + write (iunit,dfmt) "allocated? eigv(:) ",allocated(self%eigv) + write (iunit,dfmt) "allocated? coord(:) ",allocated(self%coord) + write (iunit,dfmt) "allocated? xyz(:,:) ",allocated(self%xyz) + write (iunit,'(72("-"))') + write (iunit,'(1x,"*",1x,a)') "size of memory allocation" + if (allocated(self%hess)) then + write (iunit,dfmt) "size(1) :: hess(*) ",size(self%hess,1) + end if + if (allocated(self%B)) then + write (iunit,dfmt) "size(1) :: B(*,:) ",size(self%B,1) + write (iunit,dfmt) "size(2) :: B(:,*) ",size(self%B,2) + end if + if (allocated(self%eigv)) then + write (iunit,dfmt) "size(1) :: eigv(*) ",size(self%eigv,1) + end if + if (allocated(self%coord)) then + write (iunit,dfmt) "size(1) :: coord(*) ",size(self%coord,1) + end if + if (allocated(self%xyz)) then + write (iunit,dfmt) "size(1) :: xyz(*,:) ",size(self%xyz,1) + write (iunit,dfmt) "size(2) :: xyz(:,*) ",size(self%xyz,2) + end if + write (iunit,'(72("<"))') + end subroutine write_anc !========================================================================================! -subroutine generate_anc_blowup(self,xyz,hess,pr,linear,fail) - implicit none - class(optimizer),intent(inout) :: self - real(wp), intent(in) :: xyz(3,self%n) - real(wp), intent(inout) :: hess(self%n3,self%n3) - logical, intent(in) :: pr - logical, intent(in) :: linear - logical, intent(out) :: fail + subroutine generate_anc_blowup(self,xyz,hess,pr,linear,fail) + implicit none + class(optimizer),intent(inout) :: self + real(wp),intent(in) :: xyz(3,self%n) + real(wp),intent(inout) :: hess(self%n3,self%n3) + logical,intent(in) :: pr + logical,intent(in) :: linear + logical,intent(out) :: fail - real(wp),parameter :: thr1 = 1.0e-10_wp - real(wp),parameter :: thr2 = 1.0e-11_wp - integer, parameter :: maxtry = 4 - integer :: i,itry - integer :: nvar - integer :: info - integer :: lwork - integer :: liwork - integer, allocatable :: iwork(:) - real(wp) :: elow,damp,thr - real(wp),allocatable :: aux(:) + real(wp),parameter :: thr1 = 1.0e-10_wp + real(wp),parameter :: thr2 = 1.0e-11_wp + integer,parameter :: maxtry = 4 + integer :: i,itry + integer :: nvar + integer :: info + integer :: lwork + integer :: liwork + integer,allocatable :: iwork(:) + real(wp) :: elow,damp,thr + real(wp),allocatable :: aux(:) - !> LAPACK - external :: dsyevd + !> LAPACK + external :: dsyevd - fail = .false. - self%xyz = xyz + fail = .false. + self%xyz = xyz - thr = thr2 - lwork = 1 + 6*self%n3 + 2*self%n3**2 - liwork = 8 * self%n3 + thr = thr2 + lwork = 1+6*self%n3+2*self%n3**2 + liwork = 8*self%n3 - allocate(iwork(liwork), source = 0 ) - allocate(aux(lwork), source = 0.0_wp ) + allocate (iwork(liwork),source=0) + allocate (aux(lwork),source=0.0_wp) - call dsyevd('V','U',self%n3,hess,self%n3,self%eigv, & - & aux,lwork,iwork,liwork,info) + call dsyevd('V','U',self%n3,hess,self%n3,self%eigv, & + & aux,lwork,iwork,liwork,info) - deallocate(aux,iwork) + deallocate (aux,iwork) - call detrotra8(linear,self%n,self%xyz,hess,self%eigv) + call detrotra8(linear,self%n,self%xyz,hess,self%eigv) - elow = minval(self%eigv,mask=(abs(self%eigv) > thr1)) + elow = minval(self%eigv,mask=(abs(self%eigv) > thr1)) - damp = max(self%hlow - elow,0.0_wp) - where(abs(self%eigv) > thr2) self%eigv = self%eigv + damp + damp = max(self%hlow-elow,0.0_wp) + where (abs(self%eigv) > thr2) self%eigv = self%eigv+damp ! do i = 1, self%n3 ! if (abs(self%eigv(i)) > thr2 ) self%eigv(i) = self%eigv(i) + damp ! enddo - if(pr)then - write(*,*) 'Shifting diagonal of input Hessian by ', damp - write(*,*) 'Lowest eigenvalues of input Hessian' - write(*,'(6F12.6)')(self%eigv(i),i=1,min(18,self%n3)) - write(*,*) 'Highest eigenvalues' - write(*,'(6F12.6)')(self%eigv(i),i=self%n3-5,self%n3) - write(*,*) - endif - - fail = .true. - get_anc: do itry = 1, maxtry + if (pr) then + write (*,*) 'Shifting diagonal of input Hessian by ',damp + write (*,*) 'Lowest eigenvalues of input Hessian' + write (*,'(6F12.6)') (self%eigv(i),i=1,min(18,self%n3)) + write (*,*) 'Highest eigenvalues' + write (*,'(6F12.6)') (self%eigv(i),i=self%n3-5,self%n3) + write (*,*) + end if + + fail = .true. + get_anc: do itry = 1,maxtry self%B = 0.0_wp self%hess = 0.0_wp nvar = 0 ! take largest (positive) first - do i = self%n3, 1, -1 - if (abs(self%eigv(i)) > thr .and. nvar < self%nvar) then - nvar = nvar+1 - self%B(:,nvar) = hess(:,i) - self%hess(nvar+nvar*(nvar-1)/2) = & - min(max(self%eigv(i),self%hlow),self%hmax) - endif - enddo - - if (nvar.ne.self%nvar) then - thr = thr * 0.1_wp - cycle get_anc - endif + do i = self%n3,1,-1 + if (abs(self%eigv(i)) > thr.and.nvar < self%nvar) then + nvar = nvar+1 + self%B(:,nvar) = hess(:,i) + self%hess(nvar+nvar*(nvar-1)/2) = & + min(max(self%eigv(i),self%hlow),self%hmax) + end if + end do + + if (nvar .ne. self%nvar) then + thr = thr*0.1_wp + cycle get_anc + end if fail = .false. exit get_anc - enddo get_anc + end do get_anc - if (fail) then - if(pr) write(*,*) 'nvar, self%nvar',nvar,self%nvar + if (fail) then + if (pr) write (*,*) 'nvar, self%nvar',nvar,self%nvar return - end if + end if - call sort(self%n3,self%nvar,self%hess,self%B) + call sort(self%n3,self%nvar,self%hess,self%B) - self%coord = 0.0_wp - return -end subroutine generate_anc_blowup + self%coord = 0.0_wp + return + end subroutine generate_anc_blowup !========================================================================================! -subroutine generate_anc_packed(self,xyz,hess,pr,fail) - implicit none - class(optimizer),intent(inout) :: self - real(wp), intent(in) :: xyz(3,self%n) - real(wp), intent(inout) :: hess(self%n3*(self%n3+1)/2) - logical, intent(in) :: pr - logical, intent(out) :: fail - - real(wp),parameter :: thr1 = 1.0e-10_wp - real(wp),parameter :: thr2 = 1.0e-11_wp - integer, parameter :: maxtry = 4 - integer :: i,itry - integer :: nvar - integer :: info - integer :: lwork - integer :: liwork - integer, allocatable :: iwork(:) - real(wp) :: elow,damp,thr - real(wp),allocatable :: aux(:) - real(wp),allocatable :: u(:,:) - - !> LAPACK - external :: dspevd - - self%xyz = xyz - - thr = thr2 - lwork = 1 + 6*self%n3 + 2*self%n3**2 - liwork = 8 * self%n3 - - allocate(iwork(liwork), source = 0 ) - allocate(aux(lwork), source = 0.0_wp ) - allocate(u(self%n3,self%n3), source = 0.0_wp ) - - call dspevd('V','U',self%n3,hess,self%eigv,u,self%n3, & - & aux,lwork,iwork,liwork,info) - - !elow = 1.0e+99_wp - elow = minval(self%eigv,mask=(abs(self%eigv) > thr1)) - !do i = 1, self%n3 - ! if (abs(self%eigv(i)) > thr1 ) elow = min(elow,self%eigv(i)) - !enddo - - damp = max(self%hlow - elow,0.0_wp) - where(abs(self%eigv) > thr2) self%eigv = self%eigv + damp + subroutine generate_anc_packed(self,xyz,hess,pr,fail) + implicit none + class(optimizer),intent(inout) :: self + real(wp),intent(in) :: xyz(3,self%n) + real(wp),intent(inout) :: hess(self%n3*(self%n3+1)/2) + logical,intent(in) :: pr + logical,intent(out) :: fail + + real(wp),parameter :: thr1 = 1.0e-10_wp + real(wp),parameter :: thr2 = 1.0e-11_wp + integer,parameter :: maxtry = 4 + integer :: i,itry + integer :: nvar + integer :: info + integer :: lwork + integer :: liwork + integer,allocatable :: iwork(:) + real(wp) :: elow,damp,thr + real(wp),allocatable :: aux(:) + real(wp),allocatable :: u(:,:) + + !> LAPACK + external :: dspevd + + self%xyz = xyz + + thr = thr2 + lwork = 1+6*self%n3+2*self%n3**2 + liwork = 8*self%n3 + + allocate (iwork(liwork),source=0) + allocate (aux(lwork),source=0.0_wp) + allocate (u(self%n3,self%n3),source=0.0_wp) + + call dspevd('V','U',self%n3,hess,self%eigv,u,self%n3, & + & aux,lwork,iwork,liwork,info) + + !elow = 1.0e+99_wp + elow = minval(self%eigv,mask=(abs(self%eigv) > thr1)) + !do i = 1, self%n3 + ! if (abs(self%eigv(i)) > thr1 ) elow = min(elow,self%eigv(i)) + !enddo + + damp = max(self%hlow-elow,0.0_wp) + where (abs(self%eigv) > thr2) self%eigv = self%eigv+damp ! do i = 1, self%n3 ! if (abs(self%eigv(i)) > thr2 ) self%eigv(i) = self%eigv(i) + damp ! enddo - if(pr)then - write(*,*) 'Shifting diagonal of input Hessian by ', damp - write(*,*) 'Lowest eigenvalues of input Hessian' - write(*,'(6F12.6)')(self%eigv(i),i=1,min(18,self%n3)) - write(*,*) 'Highest eigenvalues' - write(*,'(6F12.6)')(self%eigv(i),i=self%n3-5,self%n3) - write(*,*) - endif - - fail = .true. - get_anc: do itry = 1, maxtry + if (pr) then + write (*,*) 'Shifting diagonal of input Hessian by ',damp + write (*,*) 'Lowest eigenvalues of input Hessian' + write (*,'(6F12.6)') (self%eigv(i),i=1,min(18,self%n3)) + write (*,*) 'Highest eigenvalues' + write (*,'(6F12.6)') (self%eigv(i),i=self%n3-5,self%n3) + write (*,*) + end if + + fail = .true. + get_anc: do itry = 1,maxtry self%B = 0.0_wp self%hess = 0.0_wp nvar = 0 ! take largest (positive) first - do i = self%n3, 1, -1 - if (abs(self%eigv(i)) > thr .and. nvar < self%nvar) then - nvar = nvar+1 - self%B(:,nvar) = u(:,i) - self%hess(nvar+nvar*(nvar-1)/2) = & - min(max(self%eigv(i),self%hlow),self%hmax) - endif - enddo - - if (nvar.ne.self%nvar) then - thr = thr * 0.1_wp - cycle get_anc - endif + do i = self%n3,1,-1 + if (abs(self%eigv(i)) > thr.and.nvar < self%nvar) then + nvar = nvar+1 + self%B(:,nvar) = u(:,i) + self%hess(nvar+nvar*(nvar-1)/2) = & + min(max(self%eigv(i),self%hlow),self%hmax) + end if + end do + + if (nvar .ne. self%nvar) then + thr = thr*0.1_wp + cycle get_anc + end if fail = .false. exit get_anc - enddo get_anc + end do get_anc - if (fail) then - if(pr) write(*,*) 'nvar, selv%nvar',nvar,self%nvar + if (fail) then + if (pr) write (*,*) 'nvar, selv%nvar',nvar,self%nvar return - end if + end if - call sort(self%n3,self%nvar,self%hess,self%B) + call sort(self%n3,self%nvar,self%hess,self%B) - self%coord = 0.0_wp - return -end subroutine generate_anc_packed + self%coord = 0.0_wp + return + end subroutine generate_anc_packed !========================================================================================! -pure subroutine sort(nat3,nvar,hess,b) - implicit none - integer :: ii,k,j,m,i - integer, intent(in) :: nat3,nvar - real(wp),intent(inout) :: hess(nvar*(nvar+1)/2) - real(wp),intent(inout) :: b(nat3,nat3) - real(wp) :: pp,sc1 - real(wp),allocatable :: edum(:) - allocate( edum(nvar), source = 0.0_wp ) - - do k=1,nvar - edum(k)=hess(k+k*(k-1)/2) - enddo + pure subroutine sort(nat3,nvar,hess,b) + implicit none + integer :: ii,k,j,m,i + integer,intent(in) :: nat3,nvar + real(wp),intent(inout) :: hess(nvar*(nvar+1)/2) + real(wp),intent(inout) :: b(nat3,nat3) + real(wp) :: pp,sc1 + real(wp),allocatable :: edum(:) + allocate (edum(nvar),source=0.0_wp) + + do k = 1,nvar + edum(k) = hess(k+k*(k-1)/2) + end do ! sort - do ii = 2, nvar - i = ii - 1 + do ii = 2,nvar + i = ii-1 k = i - pp= edum(i) - do j = ii, nvar - if (edum(j) .gt. pp) cycle - k = j - pp= edum(j) - enddo + pp = edum(i) + do j = ii,nvar + if (edum(j) .gt. pp) cycle + k = j + pp = edum(j) + end do if (k .eq. i) cycle edum(k) = edum(i) edum(i) = pp - do m=1,nat3 - sc1=b(m,i) - b(m,i)=b(m,k) - b(m,k)=sc1 - enddo - enddo - - do k=1,nvar - hess(k+k*(k-1)/2)=edum(k) - enddo - return -end subroutine sort + do m = 1,nat3 + sc1 = b(m,i) + b(m,i) = b(m,k) + b(m,k) = sc1 + end do + end do + + do k = 1,nvar + hess(k+k*(k-1)/2) = edum(k) + end do + return + end subroutine sort !========================================================================================! -subroutine get_cartesian(self,xyz) - implicit none - class(optimizer),intent(in) :: self - integer :: m,i,j,k - real(wp),intent(out) :: xyz (3,self%n) - real(wp) :: dum + subroutine get_cartesian(self,xyz) + implicit none + class(optimizer),intent(in) :: self + integer :: m,i,j,k + real(wp),intent(out) :: xyz(3,self%n) + real(wp) :: dum external :: dgemv !> generate cartesian displacement vector - xyz = self%xyz - call dgemv('n',self%n3,self%nvar,1.0_wp,self%B,self%n3,self%coord,1,1.0_wp,xyz,1) - return -end subroutine get_cartesian + xyz = self%xyz + call dgemv('n',self%n3,self%nvar,1.0_wp,self%B,self%n3,self%coord,1,1.0_wp,xyz,1) + return + end subroutine get_cartesian !========================================================================================! @@ -445,17 +466,17 @@ pure function get_averaged_energy(self) result(val) ! only apply it if sufficient number of points i.e. a "tail" can exist ! with the censo blockl = 8 default, this can first be effective in the second - if (self%nlog .lt. 3 * nav) then + if (self%nlog .lt. 3*nav) then val = self%elog(self%nlog) else - low = max(1,self%nlog - nav + 1) + low = max(1,self%nlog-nav+1) j = 0 eav = 0 do i = self%nlog,low,-1 - j = j + 1 - eav = eav + self%elog(i) + j = j+1 + eav = eav+self%elog(i) end do - val = eav / float(j) + val = eav/float(j) end if end function get_averaged_energy @@ -468,20 +489,20 @@ pure function get_averaged_gradient(self) result(deriv) ! only apply it if sufficient number of points i.e. a "tail" can exist ! with the censo blockl = 8 default, this can first be effective in the second - if (self%nlog .lt. 3 * nav) then + if (self%nlog .lt. 3*nav) then deriv = self%glog(self%nlog) else - low = max(1,self%nlog - nav + 1) + low = max(1,self%nlog-nav+1) j = 0 gav = 0 do i = self%nlog,low,-1 - j = j + 1 - gav = gav + self%glog(i) + j = j+1 + gav = gav+self%glog(i) end do ! adjust the gradient norm to xtb "conventions" because e.g. a noisy ! DCOSMO-RS gradient for large cases can never (even on average) ! become lower than the "-opt normal" thresholds - deriv = gav / float(j) / 2.d0 + deriv = gav/float(j)/2.d0 end if end function get_averaged_gradient @@ -493,7 +514,7 @@ pure subroutine set_eg_log(self,e,g) integer :: k,k2 k = size(self%elog) if (self%nlog >= k) then - k2 = k + 1 + k2 = k+1 allocate (dum(k2)) dum(1:k) = self%elog(1:k) call move_alloc(dum,self%elog) @@ -501,12 +522,11 @@ pure subroutine set_eg_log(self,e,g) dum(1:k) = self%glog(1:k) call move_alloc(dum,self%glog) end if - self%nlog = self%nlog + 1 + self%nlog = self%nlog+1 self%elog(self%nlog) = e self%glog(self%nlog) = g end subroutine set_eg_log - !========================================================================================! !========================================================================================! end module optimize_type diff --git a/src/optimize/optutils.f90 b/src/optimize/optutils.f90 index ee943152..148cd121 100644 --- a/src/optimize/optutils.f90 +++ b/src/optimize/optutils.f90 @@ -334,7 +334,8 @@ subroutine print_optsummary(calc,tight,nvar,maxcycle,maxmicro, & '(10x,"│",3x,a,i18, 10x,"│")' character(len=*),parameter :: chrfmt = & '(10x,"│",3x,a,a18, 10x,"│")' - + character(len=*),parameter :: chrfmt2 = & + '(10x,"│",3x,a,a14, t63,"│")' !>--- set params engine = calc%opt_engine iupdat = calc%iupdat @@ -410,7 +411,7 @@ subroutine print_optsummary(calc,tight,nvar,maxcycle,maxmicro, & write (*,chrfmt) "Hessian update ","schlegel" end select end if - write (*,chrfmt) "write crestopt.log",bool2string(wr) + write (*,chrfmt2) "write crestopt.log.xyz",bool2string(wr) if (linear) then write (*,chrfmt) "linear (good luck)",bool2string(linear) else diff --git a/src/optimize/rfo.f90 b/src/optimize/rfo.f90 index 9a8854ff..1d6b1425 100644 --- a/src/optimize/rfo.f90 +++ b/src/optimize/rfo.f90 @@ -61,7 +61,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !> on output final energy !> grd - Cartesian gradient !> pr - printout bool -!> wr - logfile (crestopt.log) bool +!> wr - logfile (crestopt.log.xyz) bool !> iostatus - return status of the routine !> (success=0, error<0, not converged>0) !!*********************************************************************** @@ -214,7 +214,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !>--- initialize .log file, if desired ilog = 942 if (wr) then - open (newunit=ilog,file='crestopt.log') + open (newunit=ilog,file='crestopt.log.xyz') end if !>--- The ANCOPT iteration loop. "iter" is updated in relax() subroutine diff --git a/src/parsing/confparse2.f90 b/src/parsing/confparse2.f90 index 80f88417..96cfaeea 100644 --- a/src/parsing/confparse2.f90 +++ b/src/parsing/confparse2.f90 @@ -42,6 +42,7 @@ subroutine parseinputfile(env,fname) use crest_data use crest_calculator,only:calcdata use dynamics_module,only:mddata + use bh_module,only:bh_class !> modules used for parsing the root_object use parse_keyvalue,only:keyvalue @@ -50,7 +51,7 @@ subroutine parseinputfile(env,fname) use parse_maindata use parse_inputfile,only:parse_input use parse_calcdata,only:parse_calculation_data, & - & parse_dynamics_data + & parse_dynamics_data,parse_basinhopping_data !> Declarations implicit none type(systemdata),intent(inout) :: env @@ -60,6 +61,7 @@ subroutine parseinputfile(env,fname) type(datablock) :: blk type(calcdata) :: newcalc type(mddata) :: mddat + type(bh_class) :: bh logical :: ex,l1,l2 integer :: i,j,k,l integer :: readstatus @@ -112,6 +114,12 @@ subroutine parseinputfile(env,fname) call env_mddat_specialcases(env) end if +!>--- check for any basinhopping/MC setup + call parse_basinhopping_data(env,bh,dict,l1,readstatus) + if (l1) then + env%bh_ref = bh + end if + !>--- terminate if there were any unrecognized keywords if (readstatus /= 0) then write (stdout,'(i0,a)') readstatus,' error(s) while reading input file' diff --git a/src/parsing/constraining.f90 b/src/parsing/constraining.f90 index 43c62ce7..278fb835 100644 --- a/src/parsing/constraining.f90 +++ b/src/parsing/constraining.f90 @@ -326,7 +326,7 @@ end subroutine rdcoord_reduced subroutine sort_constraints(cts) use crest_data implicit none - type(constra) :: cts + type(legacy_constraints) :: cts character(len=128) :: atmp,btmp integer :: i,j @@ -376,7 +376,7 @@ end subroutine sort_constraints subroutine read_constrainbuffer(fname,cts) use crest_data implicit none - type(constra) :: cts + type(legacy_constraints) :: cts character(len=*) :: fname character(len=128) :: atmp @@ -418,7 +418,7 @@ end subroutine read_constrainbuffer subroutine write_cts(ich,cts) use crest_data implicit none - type(constra) :: cts + type(legacy_constraints) :: cts integer :: ich integer :: i !--- not really a "constraint", but convenient for the implementation: @@ -455,7 +455,7 @@ end subroutine write_cts subroutine write_cts_NCI(ich,cts) use crest_data implicit none - type(constra) :: cts + type(legacy_constraints) :: cts integer :: ich integer :: i !---- do it only if constaints are given @@ -476,7 +476,7 @@ end subroutine write_cts_NCI subroutine write_cts_NCI_pr(ich,cts) use crest_data implicit none - type(constra) :: cts + type(legacy_constraints) :: cts integer :: ich integer :: i !---- do it only if constaints are given @@ -497,7 +497,7 @@ subroutine write_cts_biasext(ich,cts) use crest_data use iomod implicit none - type(constra) :: cts + type(legacy_constraints) :: cts integer :: ich !---- do it only if constaints are given if (cts%usermsdpot) then @@ -758,7 +758,7 @@ end subroutine rdrcontrol subroutine write_cts_rcontrol(ich,cts) use crest_data implicit none - type(constra) :: cts + type(legacy_constraints) :: cts integer :: ich,i if (cts%ureactor) then do i = 1,cts%nrctrl @@ -806,7 +806,7 @@ end subroutine rd_cbonds subroutine write_cts_CBONDS(ich,cts) use crest_data implicit none - type(constra) :: cts + type(legacy_constraints) :: cts integer :: ich integer :: i !---- do it only if constaints are given @@ -826,7 +826,7 @@ end subroutine write_cts_CBONDS subroutine write_cts_DISP(ich,cts) use crest_data implicit none - type(constra) :: cts + type(legacy_constraints) :: cts integer :: ich character(len=40) :: dum !---- apply dispersion scaling factor (> xtb 6.4.0) diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 53a6f843..72e110cc 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -28,6 +28,7 @@ module parse_calcdata use crest_data use crest_calculator,only:calcdata,calculation_settings,jobtype,constraint,scantype use dynamics_module + use bh_module use gradreader_module,only:gradtype,conv2gradfmt use tblite_api,only:xtblvl use strucrd,only:get_atlist,coord @@ -62,6 +63,7 @@ module parse_calcdata public :: parse_calculation_data public :: parse_dynamics_data + public :: parse_basinhopping_data character(len=*),parameter,private :: fmturk = '("unrecognized KEYWORD in ",a," : ",a)' character(len=*),parameter,private :: fmtura = '("unrecognized ARGUMENT : ",a)' @@ -173,6 +175,7 @@ subroutine parse_setting_auto(env,job,kv,rd) type(keyvalue) :: kv logical,intent(out) :: rd logical :: ex + integer :: n rd = .true. select case (kv%key) @@ -189,6 +192,15 @@ subroutine parse_setting_auto(env,job,kv,rd) job%proberad = kv%value_f case ('radscal','pvol_radscal') job%pvradscal = kv%value_f + case ('efield') + n = size(kv%value_fa,1) + if (n .ne. 3) then + !>--- keyword was recognized, but invalid argument supplied + write (stdout,fmtura) trim(kv%rawvalue) + call creststop(status_config) + end if + allocate (job%efield(3),source=0.0_wp) + job%efield(:) = kv%value_fa(:) !>--- integers case ('uhf','multiplicity') @@ -450,6 +462,8 @@ subroutine parse_setting_auto(env,job,kv,rd) job%apiclean = kv%value_b case ('lmo','lmocent') job%getlmocent = kv%value_b + case ('ceh_guess') + job%ceh_guess = kv%value_b case default !>--- keyword not correctly read/found @@ -1001,7 +1015,7 @@ subroutine parse_dynamics_data(env,mddat,dict,included,istat) included = .true. call parse_mddat(env,blk,mddat,istat) else if (blk%header == 'dynamics.meta') then - call parse_metadyn(blk,mddat,istat) + call parse_metadyn(env,blk,mddat,istat) included = .true. end if end do @@ -1049,13 +1063,15 @@ subroutine parse_md_auto(env,mddat,kv,rd) mddat%active_potentials = kv%value_ia case ('includermsd','atlist+') + nat = env%ref%nat call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) - if (.not.allocated(env%includeRMSD)) allocate (env%includeRMSD(nat),source=1) + if (.not.allocated(env%includeRMSD)) allocate (env%includeRMSD(nat),source=0) do j = 1,nat if (atlist(j)) env%includeRMSD(j) = 1 end do case ('excludermsd','atlist-') + nat = env%ref%nat call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) if (.not.allocated(env%includeRMSD)) allocate (env%includeRMSD(nat),source=1) do j = 1,nat @@ -1108,13 +1124,14 @@ end subroutine parse_md_auto !========================================================================================! - subroutine parse_metadyn(blk,mddat,istat) + subroutine parse_metadyn(env,blk,mddat,istat) !************************************************** !* The following routines are used to !* read information into the "metadynamics" object !* and add it to a mol.dynamics data object !*************************************************** implicit none + type(systemdata),intent(inout) :: env type(datablock),intent(in) :: blk type(mddata),intent(inout) :: mddat integer,intent(inout) :: istat @@ -1126,7 +1143,7 @@ subroutine parse_metadyn(blk,mddat,istat) success = .false. if (blk%header .ne. 'dynamics.meta') return do i = 1,blk%nkv - call parse_metadyn_auto(mtd,blk%kv_list(i),success,rd) + call parse_metadyn_auto(env,mtd,blk%kv_list(i),success,rd) if (.not.rd) then istat = istat+1 write (stdout,fmturk) '[['//blk%header//']]-block',blk%kv_list(i)%key @@ -1135,12 +1152,15 @@ subroutine parse_metadyn(blk,mddat,istat) if (success) call mddat%add(mtd) return end subroutine parse_metadyn - subroutine parse_metadyn_auto(mtd,kv,success,rd) + subroutine parse_metadyn_auto(env,mtd,kv,success,rd) implicit none + type(systemdata),intent(inout) :: env type(keyvalue) :: kv type(mtdpot) :: mtd logical,intent(inout) :: success logical,intent(out) :: rd + integer :: j,nat + logical,allocatable :: atlist(:) rd = .true. select case (kv%key) @@ -1174,6 +1194,22 @@ subroutine parse_metadyn_auto(mtd,kv,success,rd) mtd%mtdtype = cv_rmsd_static mtd%biasfile = kv%value_c + case ('includermsd','atlist+') + nat = env%ref%nat + call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) + if (.not.allocated(mtd%atinclude)) allocate (mtd%atinclude(nat),source=.false.) + do j = 1,nat + if (atlist(j)) mtd%atinclude(j) = .true. + end do + + case ('excludermsd','atlist-') + nat = env%ref%nat + call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) + if (.not.allocated(mtd%atinclude)) allocate (mtd%atinclude(nat),source=.true.) + do j = 1,nat + if (atlist(j)) mtd%atinclude(j) = .false. + end do + case default rd = .false. return @@ -1181,6 +1217,123 @@ subroutine parse_metadyn_auto(mtd,kv,success,rd) end subroutine parse_metadyn_auto +!========================================================================================! + + subroutine parse_basinhopping_data(env,bh,dict,included,istat) +!********************************************** +!* The following routines are used to +!* read information into the "bh_class" object +!********************************************** + implicit none + type(systemdata) :: env + type(bh_class) :: bh + type(root_object) :: dict + type(datablock) :: blk + type(calculation_settings) :: newjob + type(constraint) :: newcstr + integer :: i,j,k,l + logical,intent(out) :: included + integer,intent(inout) :: istat + + included = .false. + + do i = 1,dict%nblk + call blk%deallocate() + blk = dict%blk_list(i) + if (blk%header == 'basinhopping') then + included = .true. + call parse_bh_class(env,blk,bh,istat) + end if + end do + return + end subroutine parse_basinhopping_data + subroutine parse_bh_class(env,blk,bh,istat) + implicit none + type(systemdata),intent(inout) :: env + type(datablock),intent(in) :: blk + type(bh_class),intent(inout) :: bh + integer,intent(inout) :: istat + integer :: i,j,nat + logical :: rd + if (blk%header .ne. 'basinhopping') return + + do i = 1,blk%nkv + call parse_bh_auto(env,bh,blk%kv_list(i),rd) + if (.not.rd) then + istat = istat+1 + write (stdout,fmturk) '['//blk%header//']-block',blk%kv_list(i)%key + end if + end do + return + end subroutine parse_bh_class + subroutine parse_bh_auto(env,bh,kv,rd) + implicit none + type(systemdata),intent(inout) :: env + type(bh_class) :: bh + type(keyvalue) :: kv + logical,intent(out) :: rd + logical,allocatable :: atlist(:) + integer :: n,j + logical :: ex + rd = .true. + + select case (kv%key) + case ('maxiter') !> these are NOT the BH steps! + bh%maxiter = max(1,kv%value_i) + + case ('maxsave') + bh%maxsave = kv%value_i + + case ('seed') + if (.not.allocated(bh%seed)) allocate (bh%seed) + bh%seed = kv%value_i + + case ('step','stepsize') + select case (kv%id) + case (valuetypes%int) + bh%stepsize(1) = real(kv%value_i) + case (valuetypes%float) + bh%stepsize(1) = kv%value_f + case (valuetypes%float_array) + n = min(size(kv%value_fa,1),3) + bh%stepsize(1:n) = kv%value_fa(1:n) + case default + !>--- keyword was recognized, but invalid argument supplied + write (stdout,fmtura) kv%rawvalue + call creststop(status_config) + end select + + case ('steps','maxsteps') !> these are the BH steps + bh%maxsteps = kv%value_i + + case ('steptype') + select case (kv%value_c) + case ('cartesian') + bh%steptype = 0 + case ('internal') + bh%steptype = 1 + case ('dihedral') + bh%steptype = 2 + case ('intermol') + bh%steptype = 3 + case default + write (stdout,fmtura) trim(kv%value_c) + call creststop(status_config) + end select + + case ('temp','T') + bh%temp = kv%value_f + + case ('parallel') + bh%parallel = kv%value_b + + case default + rd = .false. + return + end select + + end subroutine parse_bh_auto + !========================================================================================! !========================================================================================! end module parse_calcdata diff --git a/src/parsing/parse_inputfile.F90 b/src/parsing/parse_inputfile.F90 index 4497c873..7f7bb201 100644 --- a/src/parsing/parse_inputfile.F90 +++ b/src/parsing/parse_inputfile.F90 @@ -27,9 +27,13 @@ module parse_inputfile public :: parse_test public :: parse_input + public :: find_input_file external creststop + integer,parameter :: nf = 2 + character(len=*),parameter :: ftypes(nf) = [& + & '.toml','.TOML'] !========================================================================================! !========================================================================================! contains !> MODULE PROCEDURES START HERE @@ -76,7 +80,7 @@ subroutine parse_input(fname,dict) case default write (stdout,'(a,a)') 'Unknown file format of input file ',trim(fname) call creststop(status_input) - case ('.toml') + case ('.toml','.TOML') #ifdef WITH_TOMLF !>--- parse .toml file via the toml-f library (the DEFAULT setting) call parse_tomlf(fname,dict) @@ -88,5 +92,60 @@ subroutine parse_input(fname,dict) end subroutine parse_input +!========================================================================================! + + subroutine find_input_file(args,nra,pos) + !******************************************* + !* A routine to look up an input file from + !* the list of command line arguments + !******************************************* + implicit none + integer,intent(in) :: nra + character(len=*) :: args(nra) + integer,intent(out) :: pos + + character(len=:),allocatable :: argument + logical,allocatable :: isinputfile(:) + logical,allocatable :: inputprio(:) + integer :: i,j,k,l + logical :: ex + + pos = 0 + allocate (isinputfile(nra),source=.false.) + allocate (inputprio(nra),source=.false.) + + do i = 1,nra + argument = args(i) + inquire (file=argument,exist=ex) + if (ex) then + do j = 1,nf + if (index(argument,ftypes(j)) .ne. 0) then + isinputfile(i) = .true. + if (i > 1) then + if (args(i-1) == '--input'.or.args(i-1) == '-i') then + inputprio(i) = .true. + end if + end if + end if + end do + end if + end do + + !> if there are multiple inputs given, we select the last one, + !> except if it was provided with --input/-i + !> (same logic applies for multiple --input/-i) + if (any(inputprio(:))) then + do i = 1,nra + if (inputprio(i)) pos = i + end do + elseif (any(isinputfile(:))) then + do i = 1,nra + if (isinputfile(i)) pos = i + end do + else + pos = 0 + end if + + end subroutine find_input_file !========================================================================================! end module parse_inputfile diff --git a/src/parsing/parse_maindata.f90 b/src/parsing/parse_maindata.f90 index 33fa9734..deb971aa 100644 --- a/src/parsing/parse_maindata.f90 +++ b/src/parsing/parse_maindata.f90 @@ -168,24 +168,54 @@ subroutine parse_main_c(env,key,val,rd) env%preopt = .false. env%crestver = crest_scanning case ('search_1') - env%preopt = .false. + env%preopt = .true. env%crestver = crest_s1 env%runver = crest_s1 case ('mecp','mecp_search') env%preopt = .false. env%crestver = crest_mecp env%runver = crest_mecp - case ('imtd-gc') - env%preopt = .false. + case ('imtd-gc','mtd_search') + env%preopt = .true. env%crestver = crest_imtd env%runver = 1 - case ('nci-mtd','nci') + case ('mtd_search_quick') + env%preopt = .true. + env%crestver = crest_imtd + env%quick = .true. + env%runver = 2 + env%ewin = 5.0d0 + env%optlev = 1.0d0 !> optlev tight for quick run + case ('mtd_search_mquick') + env%preopt = .true. + env%crestver = crest_imtd + env%rotamermds = .false. !> no NORMMD + env%performCross = .false. !> no GC + env%quick = .true. !> MTD settings from the quick-mode + env%superquick = .true. !> use user-set opt level in Multilevel opt. + env%Maxrestart = 1 !> only one MTD iteration + env%runver = 6 + env%optlev = 0.0d0 !> user-set opt level + env%ewin = 2.5d0 !> smaller energy window + case ('mtd_search_squick') + env%preopt = .true. + env%crestver = crest_imtd + env%rotamermds = .false. !> no NORMMD + env%performCross = .false. !> no GC + env%quick = .true. !> MTD settings from the quick-mode + env%superquick = .true. !> use user-set opt level in Multilevel opt. + env%runver = 5 + env%optlev = 0.0d0 !> user-set opt level + env%ewin = 5.0d0 !> smaller energy window + case ('nci-mtd','nci','nci_search') env%NCI = .true. env%runver = 4 env%autozsort = .false. env%performCross = .false. env%rotamermds = .false. - case ('entropy','imtd-smtd') + case ('bh','gmin') + env%crestver = crest_bh + case ('entropy','imtd-smtd','entropy_search') env%crestver = crest_imtd !> the entropy mode acts as subtype of the crest_imtd algo env%properties = abs(p_CREentropy) env%autozsort = .false. !> turn off zsort (since we are not going to GC anyways) @@ -203,7 +233,7 @@ subroutine parse_main_c(env,key,val,rd) env%crestver = crest_numhessian env%runver = crest_numhessian case ('rigidconf') - env%preopt = .false. + env%preopt = .true. env%crestver = crest_rigcon env%runver = crest_rigcon @@ -228,7 +258,7 @@ subroutine parse_main_c(env,key,val,rd) case ('ensemble_input','ensemble','input_ensemble') env%ensemblename = val env%inputcoords = val - case ('input','structure') + case ('input','structure','coord','coords') env%inputcoords = val call mol%open(val) call env%ref%load(mol) diff --git a/src/parsing/parse_xtbinput.f90 b/src/parsing/parse_xtbinput.f90 index 197dafef..dfac4b60 100644 --- a/src/parsing/parse_xtbinput.f90 +++ b/src/parsing/parse_xtbinput.f90 @@ -1,7 +1,7 @@ !================================================================================! ! This file is part of crest. ! -! Copyright (C) 2023 Philipp Pracht +! Copyright (C) 2023-2025 Philipp Pracht ! ! crest is free software: you can redistribute it and/or modify it under ! the terms of the GNU Lesser General Public License as published by @@ -27,6 +27,7 @@ module parse_xtbinput use crest_parameters use crest_data + use crest_calculator,only:calcdata use parse_datastruct use parse_keyvalue use parse_block @@ -47,6 +48,8 @@ module parse_xtbinput module procedure :: parse_xtb_input_fallback end interface parse_xtbinputfile + public :: parse_constraints_from_cts + !========================================================================================! !========================================================================================! contains !> MODULE PROCEDURES START HERE @@ -59,22 +62,26 @@ subroutine parse_xtb_inputfile(env,fname) !* and storing information in env !********************************************* implicit none - type(systemdata) :: env - character(len=*) :: fname + type(systemdata),intent(inout) :: env + character(len=*),intent(in) :: fname type(root_object),allocatable,target :: dict type(datablock),pointer :: blk logical :: ex character(len=:),allocatable :: hdr integer :: i,j,k,l + type(coord) :: mol inquire (file=fname,exist=ex) if (.not.ex) return - allocate(dict) + allocate (dict) call parse_xtb_input_fallback(fname,dict) !call dict%print() + !> get the ref structure + call env%ref%to(mol) + write (stdout,'(a,a,a)') 'Parsing xtb-type input file ',trim(fname), & & ' to set up calculators ...' !> iterate through the blocks and save the necessary information @@ -83,13 +90,14 @@ subroutine parse_xtb_inputfile(env,fname) hdr = trim(blk%header) select case (hdr) case ('constrain') - call get_xtb_constraint_block(env,blk) + call get_xtb_constraint_block(env%calc,mol,blk) case ('wall') - call get_xtb_wall_block(env,blk) + call get_xtb_wall_block(env%calc,mol,env%potscal,blk) case ('fix') - call get_xtb_fix_block(env,blk) + call get_xtb_fix_block(env%calc,mol,blk) case ('metadyn') - call get_xtb_metadyn_block(env,blk) + call get_xtb_metadyn_block(env%calc,mol,env%mtd_kscal, & + & env%includeRMSD,env%rednat,blk) case default write (stdout,'(a,a,a)') 'xtb-style input block: "$',trim(hdr),'" not defined for CREST' end select @@ -100,19 +108,20 @@ end subroutine parse_xtb_inputfile !========================================================================================! - subroutine get_xtb_constraint_block(env,blk) + subroutine get_xtb_constraint_block(calc,mol,blk) !******************************************************************** !* This is the fallback reader for xtb input files to set up a dict !******************************************************************** implicit none - type(systemdata),intent(inout) :: env - type(filetype) :: file + !> IN/OUTPUT + type(calcdata),intent(inout) :: calc + type(coord),intent(in) :: mol + type(datablock),intent(in),target :: blk + !> LOCAL integer :: i,j,k,io type(keyvalue),pointer :: kv - type(datablock),intent(in),target :: blk real(wp) :: force_constant,dist,angl real(wp) :: rdum - type(coord) :: mol type(coord) :: molref logical :: useref logical,allocatable :: pairwise(:) @@ -138,7 +147,6 @@ subroutine get_xtb_constraint_block(env,blk) case ('reference') !> a reference geometry (must be the same molecule as the input) - call env%ref%to(mol) call molref%open(kv%rawvalue) if (any(mol%at(:) .ne. molref%at(:))) then write (stdout,'(a,/,a)') '**ERROR** while reading xtb-style input:',& @@ -151,9 +159,6 @@ subroutine get_xtb_constraint_block(env,blk) end select end do -!>--- get reference input geometry - call env%ref%to(mol) - !>--- then the common constraints: distance, angle, dihedral do i = 1,blk%nkv kv => blk%kv_list(i) @@ -163,7 +168,7 @@ subroutine get_xtb_constraint_block(env,blk) !> already read above case ('distance','bond') - if (kv%na .eq. 3 .or. kv%na .eq. 4) then + if (kv%na .eq. 3.or.kv%na .eq. 4) then read (kv%value_rawa(1),*,iostat=io) i1 if (io == 0) read (kv%value_rawa(2),*,iostat=io) i2 if (io == 0) then @@ -180,12 +185,12 @@ subroutine get_xtb_constraint_block(env,blk) !if(io == 0 .and. kv%na == 4)then ! read (kv%value_rawa(3),*,iostat=io) rdum !endif - if(io == 0)then + if (io == 0) then call cons%deallocate() call cons%bondconstraint(i1,i2,dist,force_constant) if (debug) call cons%print(stdout) - call env%calc%add(cons) - endif + call calc%add(cons) + end if end if end if @@ -207,7 +212,7 @@ subroutine get_xtb_constraint_block(env,blk) call cons%deallocate() call cons%angleconstraint(i1,i2,i3,angl,force_constant) if (debug) call cons%print(stdout) - call env%calc%add(cons) + call calc%add(cons) end if end if @@ -230,7 +235,7 @@ subroutine get_xtb_constraint_block(env,blk) call cons%deallocate() call cons%dihedralconstraint(i1,i2,i3,i4,angl,force_constant) if (debug) call cons%print(stdout) - call env%calc%add(cons) + call calc%add(cons) end if end if @@ -238,29 +243,30 @@ subroutine get_xtb_constraint_block(env,blk) read (kv%value_rawa(1),*,iostat=io) atm1 if (io == 0) read (kv%value_rawa(2),*,iostat=io) atm2 if (io == 0) read (kv%value_rawa(3),*,iostat=io) dum1 - if(io==0)then - dum1 = dum1*aatoau - dum1 = max(0.0_wp,dum1) !> can't be negative - select case (kv%na) - case (3) - dum2 = huge(dum2)/3.0_wp !> some huge value - call cons%bondrangeconstraint(atm1,atm2,dum1,dum2) - case (4) - if (io == 0) read (kv%value_rawa(4),*,iostat=io) dum2 - dum2 = dum2*aatoau - call cons%bondrangeconstraint(atm1,atm2,dum1,dum2) - case (5) - if (io == 0) read (kv%value_rawa(5),*,iostat=io) dum3 - call cons%bondrangeconstraint(atm1,atm2,dum1,dum2,beta=dum3) - case (6) - if (io == 0) read (kv%value_rawa(6),*,iostat=io) dum4 - call cons%bondrangeconstraint(atm1,atm2,dum1,dum2,beta=dum3,T=dum4) - case default - error stop '**ERROR** wrong number of arguments in bondrange constraint' - end select - call env%calc%add(cons) - if (debug) call cons%print(stdout) - endif + if (io == 0) then + dum1 = dum1*aatoau + dum1 = max(0.0_wp,dum1) !> can't be negative + select case (kv%na) + case (3) + dum2 = huge(dum2)/3.0_wp !> some huge value + call cons%bondrangeconstraint(atm1,atm2,dum1,dum2) + case (4) + if (io == 0) read (kv%value_rawa(4),*,iostat=io) dum2 + dum2 = dum2*aatoau + call cons%bondrangeconstraint(atm1,atm2,dum1,dum2) + case (5) + if (io == 0) read (kv%value_rawa(5),*,iostat=io) dum3 + call cons%bondrangeconstraint(atm1,atm2,dum1,dum2,beta=dum3) + case (6) + if (io == 0) read (kv%value_rawa(6),*,iostat=io) dum4 + call cons%bondrangeconstraint(atm1,atm2,dum1,dum2,beta=dum3,T=dum4) + case default + error stop '**ERROR** wrong number of arguments in bondrange constraint' + end select + call calc%add(cons) + if (debug) call cons%print(stdout) + end if + case ('atoms') if (.not.allocated(pairwise)) allocate (pairwise(mol%nat),source=.false.) call get_atlist(mol%nat,atlist,kv%rawvalue,mol%at) @@ -296,10 +302,10 @@ subroutine get_xtb_constraint_block(env,blk) k = 0 do i = 1,mol%nat do j = 1,i-1 - if (pairwise(i).and.pairwise(j)) k = k +1 - enddo - enddo - allocate(conslist(k)) + if (pairwise(i).and.pairwise(j)) k = k+1 + end do + end do + allocate (conslist(k)) k = 0 do i = 1,mol%nat do j = 1,i-1 @@ -309,42 +315,41 @@ subroutine get_xtb_constraint_block(env,blk) else dist = mol%dist(j,i) end if - k = k + 1 + k = k+1 !call cons%deallocate() call conslist(k)%bondconstraint(j,i,dist,force_constant) if (debug) call conslist(k)%print(stdout) - !call env%calc%add(cons) end if end do end do - call env%calc%add(k,conslist) - deallocate (conslist) + call calc%add(k,conslist) + deallocate (conslist) deallocate (pairwise) end if - end subroutine get_xtb_constraint_block - subroutine get_xtb_wall_block(env,blk) + subroutine get_xtb_wall_block(calc,mol,potscal,blk) !************************************** !* This is a reader for the $wall block !*************************************** implicit none - type(systemdata),intent(inout) :: env - type(filetype) :: file + !> IN/OUTPUT + type(calcdata),intent(inout) :: calc + type(coord),intent(in) :: mol + real(wp),intent(inout) :: potscal + type(datablock),intent(in),target :: blk + !> LOCAL integer :: i,j,k,io type(keyvalue),pointer :: kv - type(datablock),intent(in),target :: blk real(wp) :: force_constant,dist,angl real(wp) :: T,alpha,beta real(wp) :: rdum,rabc(3),r1,r2,r3 - type(coord) :: mol - logical,allocatable :: pairwise(:) logical,allocatable :: atlist(:) integer :: i1,i2,i3,i4 integer :: pot type(constraint) :: cons - if(debug) write(*,*) 'parsing $wall block' + if (debug) write (*,*) 'parsing $wall block' !>--- asome defaults force_constant = 1.0_wp @@ -353,9 +358,6 @@ subroutine get_xtb_wall_block(env,blk) T = 300.0_wp pot = 1 !> 1= polynomial, 2= logfermi -!>--- get reference input geometry - call env%ref%to(mol) - !>--- get the parameters first do i = 1,blk%nkv kv => blk%kv_list(i) @@ -401,7 +403,7 @@ subroutine get_xtb_wall_block(env,blk) if (kv%na > 0) then if (trim(kv%value_rawa(1)) .eq. 'auto') then !> determine sphere - call wallpot_core(mol,rabc,potscal=env%potscal) + call wallpot_core(mol,rabc,potscal=potscal) rdum = maxval(rabc(:)) rabc(:) = rdum else @@ -417,15 +419,15 @@ subroutine get_xtb_wall_block(env,blk) call cons%ellipsoid(mol%nat,atlist,rabc,T,beta,.true.) end select if (debug) call cons%print(stdout) - call env%calc%add(cons) + call calc%add(cons) end if case ('ellipsoid') - if(debug) write(*,*) 'parsing ellipsoid',kv%na + if (debug) write (*,*) 'parsing ellipsoid',kv%na if (kv%na > 0) then if (trim(kv%value_rawa(1)) .eq. 'auto') then !> determine ellipsoid - call wallpot_core(mol,rabc,potscal=env%potscal) + call wallpot_core(mol,rabc,potscal=potscal) else read (kv%value_rawa(1),*,iostat=io) r1 if (io == 0) read (kv%value_rawa(2),*,iostat=io) r2 @@ -445,7 +447,7 @@ subroutine get_xtb_wall_block(env,blk) call cons%ellipsoid(mol%nat,atlist,rabc,T,beta,.true.) end select if (debug) call cons%print(stdout) - call env%calc%add(cons) + call calc%add(cons) end if case default @@ -453,31 +455,28 @@ subroutine get_xtb_wall_block(env,blk) end select end do - end subroutine get_xtb_wall_block - subroutine get_xtb_fix_block(env,blk) + subroutine get_xtb_fix_block(calc,mol,blk) !************************************** !* This is a reader for the $fix block !*************************************** implicit none - type(systemdata),intent(inout) :: env - type(filetype) :: file + !> IN/OUTPUT + type(calcdata),intent(inout) :: calc + type(coord),intent(in) :: mol + type(datablock),intent(in),target :: blk + !> LOCAL integer :: i,j,k,io type(keyvalue),pointer :: kv - type(datablock),intent(in),target :: blk real(wp) :: force_constant,dist,angl real(wp) :: T,alpha,beta real(wp) :: rdum,rabc(3),r1,r2,r3 - type(coord) :: mol logical,allocatable :: pairwise(:) logical,allocatable :: atlist(:) integer :: i1,i2,i3,i4 integer :: pot -!>--- get reference input geometry - call env%ref%to(mol) - !>--- get the parameters first do i = 1,blk%nkv kv => blk%kv_list(i) @@ -517,7 +516,7 @@ subroutine get_xtb_fix_block(env,blk) if (allocated(pairwise)) then i1 = count(pairwise) - env%calc%nfreeze = i1 + calc%nfreeze = i1 if (debug) then write (stdout,'("> ",a)') 'Frozen atoms:' do i = 1,mol%nat @@ -525,35 +524,33 @@ subroutine get_xtb_fix_block(env,blk) end do write (stdout,*) end if - call move_alloc(pairwise,env%calc%freezelist) + call move_alloc(pairwise,calc%freezelist) end if - end subroutine get_xtb_fix_block - - - subroutine get_xtb_metadyn_block(env,blk) + subroutine get_xtb_metadyn_block(calc,mol,mtd_kscal,includeRMSD,rednat,blk) !************************************** !* This is a reader for the $metadyn block !*************************************** implicit none - type(systemdata),intent(inout) :: env - type(filetype) :: file + !> IN/OUTPUT + type(calcdata),intent(inout) :: calc + type(coord),intent(in) :: mol + real(wp),intent(inout) :: mtd_kscal + integer,allocatable,intent(inout) :: includeRMSD(:) + integer,intent(inout) :: rednat + type(datablock),intent(in),target :: blk + !> LOCAL integer :: i,j,k,io type(keyvalue),pointer :: kv - type(datablock),intent(in),target :: blk real(wp) :: force_constant,dist,angl real(wp) :: T,alpha,beta real(wp) :: rdum,rabc(3),r1,r2,r3 - type(coord) :: mol logical,allocatable :: pairwise(:) logical,allocatable :: atlist(:) integer :: i1,i2,i3,i4 integer :: pot -!>--- get reference input geometry - call env%ref%to(mol) - !>--- get the parameters first do i = 1,blk%nkv kv => blk%kv_list(i) @@ -584,12 +581,11 @@ subroutine get_xtb_metadyn_block(env,blk) if (i1 == mol%at(j)) pairwise(j) = .true. end do end if - + case ('kscal') !> define a global metadynamics k-push scaling factor - read(kv%rawvalue,*) r1 - env%mtd_kscal = r1 - + read (kv%rawvalue,*) r1 + mtd_kscal = r1 case default write (stdout,'(a,a,a)') 'xtb-style input key: "',kv%key,'" not defined for CREST' @@ -606,17 +602,16 @@ subroutine get_xtb_metadyn_block(env,blk) end do write (stdout,*) end if - if(.not.allocated(env%includeRMSD)) allocate(env%includeRMSD(mol%nat), source=0) - do i=1,mol%nat - if(pairwise(i)) env%includeRMSD(i) = 1 - enddo - env%rednat = i1 + if (.not.allocated(includeRMSD)) allocate (includeRMSD(mol%nat),source=0) + do i = 1,mol%nat + if (pairwise(i)) includeRMSD(i) = 1 + end do + rednat = i1 end if call mol%deallocate() end subroutine get_xtb_metadyn_block - !========================================================================================! subroutine parse_xtb_input_fallback(fname,dict) @@ -737,7 +732,7 @@ subroutine get_xtb_keyvalue(kv,str,io) call kv%deallocate() io = 0 tmpstr = adjustl(lowercase(str)) - tmpstr_rc=adjustl(trim(str)) + tmpstr_rc = adjustl(trim(str)) !> key-value conditions l(1) = index(tmpstr,'=') @@ -792,7 +787,6 @@ subroutine get_xtb_keyvalue(kv,str,io) end if end subroutine get_xtb_keyvalue - subroutine get_xtb_rawa(kv,str,io) implicit none class(keyvalue),intent(inout) :: kv @@ -803,7 +797,7 @@ subroutine get_xtb_rawa(kv,str,io) integer :: i,j,k,na,plast integer :: l(3) - if(allocated(kv%value_rawa)) deallocate(kv%value_rawa) + if (allocated(kv%value_rawa)) deallocate (kv%value_rawa) vtmp = trim(adjustl(str)) @@ -910,5 +904,151 @@ subroutine clearxtbheader(hdr) return end subroutine clearxtbheader +!============================================================================! + + subroutine parse_constraints_from_cts(calc,mol,cts) +!********************************************* +!* Routine for parsing cts objects into calcdata +!********************************************* + implicit none + !> IN/OUTPUT + type(calcdata),intent(inout) :: calc + class(coord),intent(inout) :: mol !> polymorphic class(!) to use in qcg + type(legacy_constraints),intent(in) :: cts + !> LOCAL + type(root_object),allocatable,target :: dict + type(datablock),pointer :: blk + logical :: ex + character(len=:),allocatable :: hdr + integer :: i,j,k,l + !> some defaults/fallbacks + real(wp) :: potscal = 1.0_wp + integer :: rednat + integer,allocatable :: includeRMSD(:) + real(wp) :: mtd_kscal + + allocate (dict) + !call parse_xtb_input_fallback(fname,dict) + call parse_cts_internal(cts,dict) + !call dict%print() + + !write (stdout,'(a,a,a)') 'Parsing xtb-type constraints from internal backup to set up calculators ...' + !> iterate through the blocks and save the necessary information + do i = 1,dict%nblk + blk => dict%blk_list(i) + hdr = trim(blk%header) + select case (hdr) + case ('constrain') + call get_xtb_constraint_block(calc,mol,blk) + case ('wall') + call get_xtb_wall_block(calc,mol,potscal,blk) + case ('fix') + call get_xtb_fix_block(calc,mol,blk) + case ('metadyn') + call get_xtb_metadyn_block(calc,mol,mtd_kscal, & + & includeRMSD,rednat,blk) + case default + write (stdout,'(a,a,a)') 'xtb-style input block: "$',trim(hdr),'" not defined for CREST' + end select + end do + + if (debug) stop + end subroutine parse_constraints_from_cts + + subroutine parse_cts_internal(cts,dict) +!******************************************************************** +!* This is the fallback reader for xtb constraints from cts to set up a dict +!******************************************************************** + implicit none + !> IN/OUTPUT + type(legacy_constraints),intent(in) :: cts + type(root_object),intent(out) :: dict + !> LOCAL + type(filetype) :: file + integer :: i,j,k,io,b + logical :: get_root_kv + type(keyvalue) :: kvdum + type(datablock) :: blkdum + character(len=:),allocatable :: dummy + + call dict%new() +!>--- parse cts into a "file" --> internal storage + k = 0 + if (cts%used) then + do i = 1,cts%ndim + if (trim(cts%sett(i)) .ne. '') k = k+1 + end do + end if + if (cts%NCI.and.allocated(cts%pots)) then + do i = 1,10 + if (trim(cts%pots(i)) .ne. '') k = k+1 + end do + end if + if (allocated(cts%cbonds)) then + do i = 1,cts%n_cbonds + if (trim(cts%cbonds(i)) .ne. '') k = k+1 + end do + end if + b = 128 + file%lwidth = b + dummy = repeat(' ',b+5) + file%nlines = k + file%current_line = 1 + allocate (file%f(k),source=dummy) + k=0 + if (cts%used) then + do i = 1,cts%ndim + if (trim(cts%sett(i)) .ne. '')then + k = k+1 + file%f(k) = trim(cts%sett(i)) + endif + end do + end if + if (cts%NCI.and.allocated(cts%pots)) then + do i = 1,10 + if (trim(cts%pots(i)) .ne. '')then + k = k+1 + file%f(k) = trim(cts%pots(i)) + endif + end do + end if + if (allocated(cts%cbonds)) then + do i = 1,cts%n_cbonds + if (trim(cts%cbonds(i)) .ne. '')then + k = k+1 + file%f(k) = trim(cts%cbonds(i)) + endif + end do + end if + + dict%filename = "internal cts" + call remove_comments(file) + +!>--- all valid key-values must be in $-blocks, no root-level ones + get_root_kv = .false. +!>--- the loop where the input file is read + do i = 1,file%nlines + if (file%current_line > i) cycle + !> key-value pairs of the root dict (ignored for xtb) + if (get_root_kv) then + call get_keyvalue(kvdum,file%line(i),io) + if (io == 0) then + call dict%addkv(kvdum) !> add to dict + end if + end if + + !> the $-blocks + if (isxtbheader(file%line(i))) then + get_root_kv = .false. + call read_xtbdatablock(file,i,blkdum) + call dict%addblk(blkdum) !> add to dict + end if + end do + + call file%close() + + return + end subroutine parse_cts_internal + !========================================================================================! end module parse_xtbinput diff --git a/src/printouts.f90 b/src/printouts.f90 index f34ceada..bf4b3a62 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -95,30 +95,30 @@ subroutine box3(version,date,commit,author) !write (logo(8),'(''║ based on the xTB methods ║'')') !write (logo(9),'(''║ ║'')') !write (logo(10),'("╚════════════════════════════════════════════╝")') - - write (logo(1),'(''╔════════════════════════════════════════════════╗'')') - write (logo(2),'(''║ ║'')') - write (logo(3),'(''║ ██████╗██████╗ ███████╗███████╗████████╗ ║'')') - write (logo(4),'(''║ ██╔════╝██╔══██╗██╔════╝██╔════╝╚══██╔══╝ ║'')') - write (logo(5),'(''║ ██║ ██████╔╝█████╗ ███████╗ ██║ ║'')') - write (logo(6),'(''║ ██║ ██╔══██╗██╔══╝ ╚════██║ ██║ ║'')') - write (logo(7),'(''║ ╚██████╗██║ ██║███████╗███████║ ██║ ║'')') - write (logo(8),'(''║ ╚═════╝╚═╝ ╚═╝╚══════╝╚══════╝ ╚═╝ ║'')') - write (logo(9),'(''║ ║'')') - write (logo(10),'(''║ Conformer-Rotamer Ensemble Sampling Tool ║'')') - write (logo(11),'(''║ based on the xTB methods ║'')') - write (logo(12),'(''║ ║'')') - write (logo(13),'(''╚════════════════════════════════════════════════╝'')') + + write (logo(1), '(''╔════════════════════════════════════════════════╗'')') + write (logo(2), '(''║ ║'')') + write (logo(3), '(''║ ██████╗██████╗ ███████╗███████╗████████╗ ║'')') + write (logo(4), '(''║ ██╔════╝██╔══██╗██╔════╝██╔════╝╚══██╔══╝ ║'')') + write (logo(5), '(''║ ██║ ██████╔╝█████╗ ███████╗ ██║ ║'')') + write (logo(6), '(''║ ██║ ██╔══██╗██╔══╝ ╚════██║ ██║ ║'')') + write (logo(7), '(''║ ╚██████╗██║ ██║███████╗███████║ ██║ ║'')') + write (logo(8), '(''║ ╚═════╝╚═╝ ╚═╝╚══════╝╚══════╝ ╚═╝ ║'')') + write (logo(9), '(''║ ║'')') + write (logo(10),'(''║ Conformer-Rotamer Ensemble Sampling Tool ║'')') + write (logo(11),'(''║ based on the xTB methods ║'')') + write (logo(12),'(''║ ║'')') + write (logo(13),'(''╚════════════════════════════════════════════════╝'')') do i = 1,13 - write (*,'(a,a)') repeat(" ",pad_left),trim(logo(i)) + write (*,'(a,a)') repeat(" ",pad_left),trim(logo(i)) end do write (*,'(a,'' Version '',a,'', '',a)') repeat(" ",pad_left),trim(version),trim(date) - if (author(1:2) .eq. "'@") then - write (*,'(a," commit (",a,") compiled by ",a)') repeat(" ",pad_left),commit,"'usr"//author(2:) + if(author(1:2).eq."'@")then + write (*,'(a," commit (",a,") compiled by ",a)') repeat(" ",pad_left),commit,"'usr"//author(2:) else - write (*,'(a," commit (",a,") compiled by ",a)') repeat(" ",pad_left),commit,author - end if + write (*,'(a," commit (",a,") compiled by ",a)') repeat(" ",pad_left),commit,author + endif end subroutine box3 subroutine disclaimer @@ -540,24 +540,6 @@ end subroutine zsortwarning2 !========================================================================================! -subroutine qcg_head() - implicit none - write (*,*) - write (*,'(2x,''========================================'')') - write (*,'(2x,''| ---------------- |'')') - write (*,'(2x,''| Q C G |'')') - write (*,'(2x,''| ---------------- |'')') - write (*,'(2x,''| Quantum Cluster Growth |'')') - write (*,'(2x,''| University of Bonn, MCTC |'')') - write (*,'(2x,''========================================'')') - write (*,'(2x,'' S. Grimme, S. Spicher, C. Plett.'')') - write (*,*) - write (*,'(3x,''Cite work conducted with this code as'')') - write (*,'(/,3x,''S. Spicher, C. Plett, P. Pracht, A. Hansen, S. Grimme, JCTC, 2022, 18, 3174-3189.'')') - write (*,*) -end subroutine qcg_head - -!========================================================================================! subroutine msreact_head() implicit none @@ -1001,176 +983,6 @@ subroutine checkbinary(env) return end subroutine checkbinary -!========================================================================================! -!========================================================================================! -!> QCG-printouts -!==============================================================================! -!========================================================================================! - -subroutine print_qcg_grow() - implicit none - write (*,*) - write (*,'(2x,''========================================='')') - write (*,'(2x,''| quantum cluster growth: GROW |'')') - write (*,'(2x,''========================================='')') - write (*,*) -end subroutine print_qcg_grow -subroutine pr_qcg_fastgrow() - implicit none - write (*,*) - write (*,'(2x,''========================================='')') - write (*,'(2x,''| quantum cluster growth: FASTGROW |'')') - write (*,'(2x,''========================================='')') - write (*,*) -end subroutine pr_qcg_fastgrow -subroutine print_qcg_ensemble() - implicit none - write (*,*) - write (*,'(2x,''========================================='')') - write (*,'(2x,''| quantum cluster growth: ENSEMBLE |'')') - write (*,'(2x,''========================================='')') - write (*,*) -end subroutine print_qcg_ensemble -subroutine print_qcg_opt() - implicit none - write (*,*) - write (*,'(2x,''========================================='')') - write (*,'(2x,''| quantum cluster growth: OPT |'')') - write (*,'(2x,''========================================='')') - write (*,*) - write (*,'(2x,''Very tight post optimization of lowest cluster'')') -end subroutine print_qcg_opt -subroutine pr_qcg_fill() - implicit none - write (*,*) - write (*,'(2x,''========================================='')') - write (*,'(2x,''| quantum cluster growth: CFF |'')') - write (*,'(2x,''========================================='')') - write (*,*) - write (*,'(2x,''CUT-FREEZE-FILL Algorithm to generate reference solvent cluster'')') -end subroutine pr_qcg_fill -subroutine pr_qcg_freq() - implicit none - write (*,*) - write (*,'(2x,''========================================='')') - write (*,'(2x,''| Frequency evaluation |'')') - write (*,'(2x,''========================================='')') - write (*,*) -end subroutine pr_qcg_freq -subroutine pr_eval_solute() - implicit none - write (*,*) - write (*,'(2x,''________________________________________________________________________'')') - write (*,*) - write (*,'(2x,''__________________ Solute Cluster Generation _____________________'')') - write (*,*) - write (*,'(2x,''________________________________________________________________________'')') - write (*,*) -end subroutine pr_eval_solute -subroutine pr_eval_solvent() - implicit none - write (*,*) - write (*,*) - write (*,'(2x,''________________________________________________________________________'')') - write (*,*) - write (*,'(2x,''_________________ Solvent Cluster Generation _____________________'')') - write (*,*) - write (*,'(2x,''________________________________________________________________________'')') - write (*,*) -end subroutine pr_eval_solvent -subroutine pr_eval_eval() - implicit none - write (*,*) - write (*,*) - write (*,'(2x,''________________________________________________________________________'')') - write (*,*) - write (*,'(2x,''_________________________ Evaluation ____________________________'')') - write (*,*) - write (*,'(2x,''________________________________________________________________________'')') - write (*,*) - write (*,*) -end subroutine pr_eval_eval -subroutine pr_freq_energy() - implicit none - write (*,'(2x,"# H(T) SVIB SROT STRA G(T)")') - write (*,'(2x," [kcal/mol] [ cal/mol/K ] [kcal/mol]")') - write (*,'(2x,"--------------------------------------------------------")') -end subroutine pr_freq_energy -subroutine pr_eval_1(G,H) - use iso_fortran_env,only:wp => real64 - implicit none - real(wp),intent(in) :: G,H - write (*,'(2x,"-----------------------------------------------------")') - write (*,'(2x,"Gsolv and Hsolv ref. state: [1 M gas/solution] ")') - write (*,'(2x,"G_solv (incl.RRHO) =",F8.2," kcal/mol")') G - write (*,'(2x,"H_solv (incl.RRHO) =",F8.2," kcal/mol")') H - write (*,'(2x,"-----------------------------------------------------")') - write (*,*) -end subroutine pr_eval_1 -subroutine pr_eval_2(srange,G,scal) - use iso_fortran_env,only:wp => real64 - implicit none -! Dummy - integer,intent(in) :: srange - real(wp),intent(in) :: G(srange) - real(wp),intent(in) :: scal(srange) -! Stack - integer :: i - write (*,'(2x,"-----------------------------------------------------")') - write (*,'(2x,"Solvation free energies with scaled translational")') - write (*,'(2x,"and rotational degrees of freedom: Gsolv (scaling)")') - do i = 1,srange - write (*,'(10x,">>",2x,f8.2," (",f4.2,")",4x,"<<")') G(i),scal(i) - end do - write (*,'(2x,"-----------------------------------------------------")') -end subroutine pr_eval_2 -subroutine pr_eval_3(srange,freqscal,scal,G) - use iso_fortran_env,only:wp => real64 - implicit none -! Dummy - integer,intent(in) :: srange - integer,intent(in) :: freqscal - real(wp),intent(in) :: scal - real(wp),intent(in) :: G(srange) - write (*,*) - write (*,'(2x,"==================================================")') - write (*,'(2x,"| Gsolv with SCALED RRHO contributions: ",f4.2,4x"|")') scal - write (*,'(2x,"| [1 bar gas/ 1 M solution] |")') - write (*,'(2x,"| |")') - write (*,'(2x,"| G_solv (incl.RRHO)+dV(T)=",F8.2," kcal/mol |")') G(freqscal) - write (*,'(2x,"==================================================")') - write (*,*) -end subroutine pr_eval_3 -subroutine pr_fill_energy() - implicit none - write (*,'(x,'' Size'',2x,''Cluster '',2x,''E /Eh '',7x,''De/kcal'',3x,& - &''Detot/kcal'',2x,''Opt'',4x)') -end subroutine pr_fill_energy -subroutine pr_ensemble_energy() - implicit none - write (*,*) - write (*,'(x,'' Cluster'',3x,''E /Eh '',7x,& - &''Density'',2x,''Efix'',7x,''R av/act.'',1x,& - &''Surface'',3x,''Opt'',4x)') -end subroutine pr_ensemble_energy -subroutine pr_qcg_esolv() - implicit none - write (*,*) - write (*,'(2x,''========================================='')') - write (*,'(2x,''| quantum cluster growth: ESOLV |'')') - write (*,'(2x,''| |'')') -end subroutine pr_qcg_esolv -subroutine pr_grow_energy() - implicit none - write (*,'(x,'' Size'',7x,''E'',8x,''De'',7x,''Detot'',6x,& - &''Density'',5x,''Eatom'',4x,''av. R'', 1x,'' Rlast'',3x,& - &''Volume'',4x,''Opt'')') - write (*,'(12x,''[Eh]'',4x,''[kcal]'',5x,''[kcal]'',5x,& - &''[u/Å^3]'',5x,''[kcal]'',3x,''[bohr]'', 1x,''[bohr]'',1x,& - &''[bohr^3]'')') - -end subroutine pr_grow_energy - !========================================================================================! !========================================================================================! diff --git a/src/qcg/CMakeLists.txt b/src/qcg/CMakeLists.txt index 785a6c22..034766bc 100644 --- a/src/qcg/CMakeLists.txt +++ b/src/qcg/CMakeLists.txt @@ -18,8 +18,11 @@ set(dir "${CMAKE_CURRENT_SOURCE_DIR}") list(APPEND srcs "${dir}/volume.f90" - "${dir}/solvtool_misc.f90" - "${dir}/solvtool.f90" + "${dir}/qcg_coord_type.f90" + "${dir}/qcg_misc.f90" + "${dir}/qcg_main.f90" + "${dir}/qcg_printouts.f90" + "${dir}/qcg_utils.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/qcg/meson.build b/src/qcg/meson.build index 4e6cacbc..52c3cecf 100644 --- a/src/qcg/meson.build +++ b/src/qcg/meson.build @@ -15,7 +15,10 @@ # along with crest. If not, see . srcs += files( - 'solvtool.f90', - 'solvtool_misc.f90', - 'volume.f90', +'qcg_coord_type.f90', +'qcg_main.f90', +'qcg_misc.f90', +'qcg_printouts.f90', +'qcg_utils.f90', +'volume.f90', ) diff --git a/src/qcg/qcg_coord_type.f90 b/src/qcg/qcg_coord_type.f90 new file mode 100644 index 00000000..9e732865 --- /dev/null +++ b/src/qcg/qcg_coord_type.f90 @@ -0,0 +1,91 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2025 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! +! +module qcg_coord_type + use crest_parameters,only:wp + use strucrd,only:coord + implicit none + public + + type,extends(coord) :: coord_qcg + !> new components that are added to the coord type: + integer :: nmol !> number of molecules + real(wp) :: cma(3) !> center of mass + real(wp) :: aniso !> anisotropy factor + real(wp) :: ell_abc(3) !> ellipsoid axis + real(wp) :: atot !> surface area + real(wp) :: vtot !> volume + real(wp) :: rtot !> radius + real(wp) :: mass !> mass + real(wp) :: gt !> gibbs free energy + real(wp) :: ht !> enthalpy + real(wp) :: svib !> vibrational entropy + real(wp) :: srot !> rotational entropy + real(wp) :: stra !> translational entropy + real(wp) :: eax(3) !> molecular axis + contains + procedure :: as_coord + procedure :: from_coord + end type coord_qcg + +!==============================================================================! +contains !> MODULE PROCEDURES START HERE +!==============================================================================! + + function as_coord(this) result(mol) + class(coord_qcg),intent(in) :: this + type(coord) :: mol + + mol%nat = this%nat + if (allocated(this%at)) mol%at = this%at + if (allocated(this%xyz)) mol%xyz = this%xyz + + mol%energy = this%energy + if (allocated(this%comment)) mol%comment = this%comment + mol%chrg = this%chrg + mol%uhf = this%uhf + mol%nbd = this%nbd + if (allocated(this%bond)) mol%bond = this%bond + if (allocated(this%lat)) mol%lat = this%lat + if (allocated(this%qat)) mol%qat = this%qat + mol%pdb = this%pdb + + end function as_coord + + subroutine from_coord(this,mol) + class(coord_qcg),intent(inout) :: this + type(coord),intent(in) :: mol + + this%nat = mol%nat + if (allocated(mol%at)) this%at = mol%at + if (allocated(mol%xyz)) this%xyz = mol%xyz + + this%energy = mol%energy + if (allocated(mol%comment)) this%comment = mol%comment + this%chrg = mol%chrg + this%uhf = mol%uhf + this%nbd = mol%nbd + if (allocated(mol%bond)) this%bond = mol%bond + if (allocated(mol%lat)) this%lat = mol%lat + if (allocated(mol%qat)) this%qat = mol%qat + this%pdb = mol%pdb + end subroutine from_coord + +end module qcg_coord_type + diff --git a/src/qcg/qcg_main.f90 b/src/qcg/qcg_main.f90 new file mode 100644 index 00000000..c5bf4486 --- /dev/null +++ b/src/qcg/qcg_main.f90 @@ -0,0 +1,2178 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2023 Christoph Plett, Sebastian Spicher, Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +!> This file contains routines related to QCG and microsolvation + +subroutine crest_solvtool(env,tim) +!*********************************************** +!* Main driver for all QCG runtypes +!*********************************************** + use crest_parameters,only:wp,autokcal + use qcg_printouts + use crest_data + use iomod + use qcg_coord_type + use strucrd + implicit none + + type(systemdata):: env ! MAIN STORAGE OS SYSTEM DATA + type(timer):: tim + !> Information about solvent, solute and cluster + type(coord_qcg) :: solute,solvent,cluster,cluster_backup + type(ensemble) :: full_ensemble,solvent_ensemble + + integer :: progress,io + character(len=512) :: thispath + +!--- Molecule settings + solute%nmol = 1 + solvent%nmol = 1 + cluster%nmol = 1 + + progress = 0 + call getcwd(thispath) + + !>----------------------------------- + call qcg_head() + !>----------------------------------- + +!> Check, if xtb is present + call checkprog_silent(env%ProgName,.true.,iostat=io) + if (io /= 0) error stop 'No xtb found' + +!> Check, if xtbiff is present (if it is required) + if (env%use_xtbiff) then + call xtbiff_print_deprecated() + else + write (stdout,*) + write (stdout,*) ' This program uses the the aISS algorithm as implemnted in xtb.' + write (stdout,*) ' The aISS method requires xtb version 6.6.0 or newer.' + write (stdout,*) ' Tested with xtb version 6.7.1 (902b313)' + !write (stdout,*) ' xTB-IFF can still be used with the --xtbiff flag.' + write (stdout,*) + end if + +!------------------------------------------------------------------------------ +! Setup +!------------------------------------------------------------------------------ + call write_qcg_setup(env) !Just an outprint of setup + call read_qcg_input(env,solute,solvent) !Reading mol. data and determining r,V,A + call qcg_setup(env,solute,solvent) + call qcg_restart(env,progress,solute,solvent,cluster,full_ensemble,& + & solvent_ensemble,cluster_backup) + +!----------------------------------------------------------------------------- +! Grow +!----------------------------------------------------------------------------- + if (progress .le. env%qcg_runtype.and.progress .eq. 0) then + cluster = solute + call qcg_grow(env,solute,solvent,cluster,tim) + if (.not.env%cff) then + allocate (cluster_backup%at(cluster%nat)) + allocate (cluster_backup%xyz(3,cluster%nat)) + cluster_backup = cluster + end if + progress = progress+1 + call chdirdbug(thispath) + end if + +!------------------------------------------------------------------------------ +! Ensemble search +!------------------------------------------------------------------------------ + if (progress .le. env%qcg_runtype.and.progress .eq. 1) then + call print_qcg_ensemble() + call qcg_ensemble(env,solute,solvent,cluster,full_ensemble,tim,'ensemble') + progress = progress+1 + call chdirdbug(thispath) + end if + +!------------------------------------------------------------------------------ +! Solvent cluster generation +!------------------------------------------------------------------------------ + if (progress .le. env%qcg_runtype.and.progress .eq. 2) then !esolv + call pr_eval_solvent() + if (env%cff) then !CFF + call qcg_cff(env,solute,solvent,cluster,full_ensemble,& + & solvent_ensemble,tim) + else !Normal ensemble generation + call print_qcg_ensemble() + call cluster%deallocate + allocate (cluster%at(cluster_backup%nat)) + allocate (cluster%xyz(3,cluster_backup%nat)) + cluster = cluster_backup + deallocate (cluster_backup%at) + deallocate (cluster_backup%xyz) + env%solv_md = .true. + call qcg_ensemble(env,solute,solvent,cluster,solvent_ensemble,& + & tim,'solvent_ensemble') + end if + call pr_qcg_esolv() + write (stdout,'(2x,"|",9x,F8.2," kcal/mol ",12x,"|")') & + & full_ensemble%g-solvent_ensemble%g-(solute%energy*autokcal) + write (stdout,'(2x,''========================================='')') + call chdirdbug(thispath) + progress = progress+1 + end if + +!------------------------------------------------------------------------------ +! Frequency computation and evaluation +!------------------------------------------------------------------------------ + if (progress .le. env%qcg_runtype.and.progress .eq. 3) then !gsolv + call qcg_freq(env,tim,solute,solvent,full_ensemble,solvent_ensemble) + call qcg_eval(env,solute,full_ensemble,solvent_ensemble) + progress = progress+1 + end if + +!------------------------------------------------------------------------------ +! Cleanup and deallocation +!------------------------------------------------------------------------------ + if (env%scratchdir .ne. 'qcg_tmp') call qcg_cleanup(env) + if (.not.env%keepModef) call rmrf('qcg_tmp') + call solute%deallocate + call solvent%deallocate + call cluster%deallocate + call full_ensemble%deallocate + call solvent_ensemble%deallocate + return +end subroutine crest_solvtool + +!==============================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< real64 + use crest_data + use iomod + use qcg_coord_type + use strucrd + use axis_module + implicit none + + type(systemdata):: env + type(coord_qcg) :: solv,solu + + integer :: io,f,r + integer :: num_O,num_H,i + character(len=*),parameter :: outfmt = '(1x,1x,a,1x,f14.7,a,1x)' + logical :: e_there,tmp,used_tmp,gbsa_tmp + character(len=512) :: thispath,tmp_grow + character(len=40) :: solv_tmp + character(len=80) :: atmp + character(len=20) :: gfnver_tmp + + call getcwd(thispath) + + ! Remove scratch dir, if present + inquire (file='./qcg_tmp/solute_properties/solute',exist=tmp) + if (tmp) call rmrf('qcg_tmp') !User given scratch dir will be removed anyway after run + + ! Make scratch directories + if (env%scratchdir .eq. '') then !check if scratch was not set + env%scratchdir = 'qcg_tmp' + io = makedir('qcg_tmp') + end if + if (env%fixfile /= 'none selected') then + call copysub(env%fixfile,env%scratchdir) + end if + call chdirdbug(env%scratchdir) + + f = makedir('solute_properties') + if (env%fixfile /= 'none selected') then + call copysub(env%fixfile,env%scratchdir) + end if + r = makedir('solvent_properties') + + if (.not.env%nopreopt) then + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| Preoptimization |'')') + write (stdout,'(2x,''========================================='')') + end if + + solv_tmp = env%solv + gbsa_tmp = env%gbsa + env%solv = '' + env%gbsa = .false. + +!---- Properties solute + call chdirdbug('solute_properties') + call env%wrtCHRG('') !Write three lines in QCG mode, but xtb anyway only reads first one + +!---- Geometry preoptimization solute + if (env%final_gfn2_opt) then !If GFN2 final opt, solute also GFN2 optimized + gfnver_tmp = env%gfnver + env%gfnver = '--gfn2' + end if + + if ((.not.env%nopreopt).and.(solu%nat /= 1)) then + call xtb_opt_qcg(env,solu,.true.) + end if + +!--- Axistrf + call axistrf(solu%nat,solu%nat,solu%at,solu%xyz) + call solu%write('solute') + +!---- SP-Computation solute + call xtb_sp_qcg(env,'solute',e_there,solu%energy) + + if (.not.e_there) then + write (stdout,*) 'Total Energy of solute not found' + else + write (stdout,outfmt) 'Total Energy of solute: ',solu%energy,' Eh' + end if + + if (env%final_gfn2_opt) then !If GFN2 final opt, solute also GFN2 optimized + env%gfnver = gfnver_tmp + end if + + call chdirdbug(thispath) + +! No constraints for solvent possible + used_tmp = env%cts%used + env%cts%used = .false. + +!---- Properties solvent + call chdirdbug(env%scratchdir) + call chdirdbug('solvent_properties') + !No charges for solvent written. This is currently not possible + +!---- Geometry preoptimization solvent + if ((.not.env%nopreopt).and.(solv%nat /= 1)) then + call xtb_opt_qcg(env,solv,.false.) + end if + call solv%write('solvent') + +!---- SP-Computation solvent + call xtb_sp_qcg(env,'solvent',e_there,solv%energy) + + if (.not.e_there) then + write (stdout,'(1x,a)') 'Total Energy of solvent not found' + else + write (stdout,outfmt) 'Total energy of solvent:',solv%energy,' Eh' + end if + + call chdirdbug(thispath) + +!---- Overwriting solute and solvent in original folder + call solu%write('solute') + call solv%write('solvent') + + num_O = 0 + num_H = 0 +!--- Check, if water is solvent + if (solv%nat .eq. 3) then + do i = 1,solv%nat + if (solv%at(i) .eq. 8) num_O = num_O+1 + if (solv%at(i) .eq. 1) num_H = num_H+1 + end do + end if + if (num_O .eq. 1.AND.num_H .eq. 2) then + env%water = .true. + if (.not.env%noconst) env%constrain_solu = .true. + end if + + env%solv = solv_tmp + env%gbsa = gbsa_tmp + env%cts%used = used_tmp + +end subroutine qcg_setup + +!==============================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Read input for directed docking +subroutine read_directed_input(env) + use crest_parameters + use crest_data + implicit none + + type(systemdata) :: env + + integer :: nlines + integer :: io,ich,i,i_check + integer :: index + character(len=512) :: dum + character(len=1),parameter :: delim_space = ' ',delim_tab = achar(9) + + open (newunit=ich,file=env%directed_file) + !First check number of lines + nlines = 0 + do + read (ich,*,iostat=io) + if (io /= 0) exit + nlines = nlines+1 + end do + !Allocate directed list + !First entry is the atom number, Second how many solvents to add to this atom + allocate (env%directed_list(nlines,2)) + allocate (env%directed_number(nlines),source=0) + !Now read lines into directed_list + rewind (ich) + do i = 1,nlines + read (ich,'(A)') dum + !> Remove leading tab and spaces first + dum = adjustl(dum) !Leading spaces are removed + index = SCAN(trim(dum),delim_tab) + if (index == 1) then !Leading tab -> remove it + dum = dum(2:) + end if + index = SCAN(trim(dum),delim_space) + if (index == 0) then !No space = check for tab + index = SCAN(trim(dum),delim_tab) + end if + if (index == 0) then !Second value is missing + write (stdout,'(a,1x,i0)') "No second value found in directed list on line",i + error stop + end if + env%directed_list(i,1) = dum(1:index-1) + env%directed_list(i,2) = dum(index+1:) + !Remove multiple spaces + env%directed_list(i,2) = adjustl(env%directed_list(i,2)) + !Check, if spaces are still in second argument (e.g. a third number is giveb) + index = SCAN(trim(env%directed_list(i,2)),delim_space) + if (index == 0) index = SCAN(trim(dum),delim_tab) + if (index /= 0) then + write (stdout,'(a,1x,i0)') "Too many values at line",i + error stop + end if + !> Make array with which solvent molecule at which atom to add + read (env%directed_list(i,2),*,iostat=io) env%directed_number(i) + env%directed_number(i) = sum(env%directed_number) + if (io /= 0) then + write (stdout,'(a,1x,i0)') "Second value is no number in line",i + error stop + end if + end do + close (ich) + write (stdout,*) 'Performing directed docking' + do i = 1,nlines + write (stdout,'(a,1x,a,1x,a,1x,a)') 'Docking',trim(env%directed_list(i,2)),& + & 'solvent molecules at',trim(env%directed_list(i,1)) + end do + +end subroutine read_directed_input + +!==============================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< backup original level of theory + do while (.not.success) +!--- Cluster optimization + if (env%cts%used) then + call write_reference(env,solu,clus) !new fixed file + end if + +!--- Interaction energy + !gfnver_tmp = env%gfnver + env%gfnver = env%lmover + gbsa_tmp = env%gbsa + solv_tmp = env%solv + env%gbsa = .false. + env%solv = '' + call get_interaction_E(env,solu,solv,clus,iter,E_inter) + env%gbsa = gbsa_tmp + env%solv = solv_tmp + if (E_inter(iter) .lt. 0) then + success = .true. + else + if (env%potscal .lt. 1.0_wp) then + write (stdout,*) ' Interaction Energy positiv, increasing outer wall pot by 5 %' + clus%ell_abc = clus%ell_abc*1.05_wp + env%potscal = env%potscal*1.05_wp + if (env%potscal .gt. 1.0_wp) env%potscal = 1.0_wp + write (stdout,'('' New scaling factor '',F4.2)') env%potscal + else + success = .true. + end if + end if + end do + env%gfnver = gfnver_tmp + +!--- For output + !Energy already read from xyz file + e_each_cycle(iter) = clus%energy + +!--- Calclulate fix energy + diff. energy + efix = clus%energy/sqrt(real(clus%nat)) + dum = solu%energy + if (iter .gt. 1) dum = e_each_cycle(iter-1) + e_diff = e_diff+autokcal*(e_each_cycle(iter)-solv%energy-dum) + call ellipsout('cluster_cavity.coord',clus%nat,clus%at,clus%xyz,clus%ell_abc) + call both_ellipsout('twopot_cavity.coord',clus%nat,clus%at,clus%xyz,& + & clus%ell_abc,solu%ell_abc) + +!--- Density calculations + call get_sphere(.false.,clus,.false.) !V, A of new cluster + dens = 0.001*(solu%mass+iter*solv%mass)/(1.0d-30*clus%vtot*bohr**3) + +!--- Movie file + write (ich15,*) clus%nat + write (ich15,'('' SCF done '',2F16.8)') autokcal*(e_each_cycle(iter)-solv%energy-dum) + do j = 1,clus%nat + write (ich15,'(a,1x,3F24.10)') i2e(clus%at(j)),clus%xyz(1:3,j)*bohr + end do + +!--- Output + ! dist of new mol from solute for output + call analyze_cluster(iter,clus%nat,solu%nat,solv%nat,clus%xyz,clus%at,shr_av,shr) + + write (stdout,'(x,i4,F13.6,1x,f7.2,3x,es9.2,5x,f6.3,3x,f8.3,3x,2f6.1,2x,f8.1,3x,a,x)') & + & iter,e_each_cycle(iter),autokcal*(e_each_cycle(iter)-solv%energy-dum),& + & e_diff,dens,efix,shr_av,shr,clus%vtot,trim(optlevflag(env%optlev)) + write (ich99,'(i4,F20.10,3x,f8.1)') iter,e_each_cycle(iter),clus%vtot + +!--- Calculate moving average + mean_old = mean + do i = 0,iter-1 + mean = mean+E_inter(iter-i) + end do + mean = mean/iter + mean_diff = mean-mean_old + write (ich88,'(i5,1x,3F13.8)') iter,E_inter(iter)*autokcal,mean,mean_diff + +!--- Check if converged when no nsolv was given + if (env%nsolv .eq. 0) then + if (abs(mean_diff) .lt. 1.0d-4.and.iter .gt. 5) then + env%nsolv = iter + exit + end if + if (iter .eq. env%max_solv) then + write (stdout,'(1x,''No convergence could be reached upon adding'',1x,i4,1x,& + & ''solvent molecules.'')') env%max_solv + write (stdout,*) ' Proceeding.' + env%nsolv = env%max_solv + exit + end if + end if +!----------------------------------------------- +! End loop +!----------------------------------------------- + end do GROW_LOOP + + if (env%nsolv .eq. 0) env%nsolv = iter !if no env%solv was given + + if (env%gfnver .ne. '--gfn2'.and.env%final_gfn2_opt) then + gfnver_tmp = env%gfnver + env%gfnver = '--gfn2' + write (stdout,'(2x,''Final gfn2 optimization'')') + call opt_cluster(env,solu,clus,'cluster.coord',.false.) + call rdcoord('xtbopt.coord',clus%nat,clus%at,clus%xyz) + call clus%write('cluster.coord') + call grepval('xtb_sp.out','| TOTAL ENERGY',e_there,clus%energy) + if (.not.e_there) then + write (stdout,'(1x,a)') 'Total Energy of cluster not found.' + else + write (stdout,'(2x,''Total gfn2-energy of cluster/Eh:'',f20.6)') clus%energy + end if + env%gfnver = gfnver_tmp + end if + + call wrxyz('cluster.xyz',clus%nat,clus%at,clus%xyz*bohr) + +!--- One optimization without Wall Potential and with implicit model + gfnver_tmp = env%gfnver + if (env%final_gfn2_opt) env%gfnver = '--gfn2' + call opt_cluster(env,solu,clus,'cluster.xyz',.true.) + env%gfnver = gfnver_tmp + call rename('xtbopt.xyz','cluster_optimized.xyz') + call copysub('cluster_optimized.xyz',resultspath) + +!--- output and files + write (stdout,*) + write (stdout,'(2x,''Growth finished after '',i0,'' solvents added'')') env%nsolv + write (stdout,'(2x,''Results can be found in grow directory'')') + write (stdout,'(2x,''Energy list in file '')') + write (stdout,'(2x,''Interaction energy in file '')') + write (stdout,'(2x,''Growing process in '')') + write (stdout,'(2x,''Final geometry after grow in and '')') + write (stdout,'(2x,''Final geometry optimized without wall potential in '')') + write (stdout,'(2x,''Potentials and geometry written in and '')') + + close (ich99) + close (ich88) + close (ich15) + +!--- Saving results and cleanup + call copysub('cluster.coord',resultspath) + call copysub('cluster.xyz',resultspath) + call copysub('twopot_cavity.coord',resultspath) + call copysub('cluster_cavity.coord',resultspath) + call copysub('solute_cavity.coord',resultspath) +! call rename('xcontrol','wall_potential') + env%constrain_solu = .false. + call write_wall(env,solu%nat,solu%ell_abc,clus%ell_abc,'wall_potential') + call copysub('wall_potential',resultspath) + + call chdirdbug(thispath) + call chdirdbug(env%scratchdir) + if (.not.env%keepModef) call rmrf('tmp_grow') + + deallocate (e_each_cycle,E_inter) + + call tim%stop(5) + +end subroutine qcg_grow + +!==============================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Parse contraints (wall potentials etc.) into new calculator + !> if we are using it. + if (.not.env%legacy) then + calc_tmp = env%calc + call qcg_envcalc_reinit(env,clus,.true.,.true.) + end if + + ENSEMBLEGEN:select case(env%ensemble_method) + case (-1:0) !qcgmtd/Crest runtype + + !> Some custom Defaults for running the standard search + !General settings: + if (.not.env%user_mdstep) then + if (env%ensemble_opt .EQ. '--gff') then + env%mdstep = 1.5d0 + else + env%mdstep = 5.0d0 + end if + end if + !Runtype specific settings: + if (env%ensemble_method == 0) then + if (.not.env%user_dumxyz) then + env%mddumpxyz = 200 + end if + if (.not.env%user_mdtime) then + env%mdtime = 10.0 + end if + else if (env%ensemble_method == -1) then + if (.not.env%user_dumxyz) then + env%mddumpxyz = 50 + end if + if (.not.env%user_mdtime) then + env%mdtime = 5.0 + end if + env%nmdtemp = 100 + env%MaxRestart = 6 + end if + + env%iterativeV2 = .true. !Safeguards more precise ensemble search + write (stdout,*) 'Starting ensemble cluster generation by CREST routine' + call confscript2i(env,tim_dum) !Calling ensemble search + call copy('crest_rotamers.xyz','crest_rotamers_0.xyz') + + case (1:2) ! Single MD or MTD + call xtb_md_ensemble_qcg(env,solu,solv,clus,resultspath) + + end select ENSEMBLEGEN + + env%QCG = .true. + +!--- Optimization with gfn2 if necessary + if (env%final_gfn2_opt.and.env%gfnver .ne. '--gfn2') then + gfnver_tmp = env%gfnver + write (stdout,'(2x,a)') 'GFN2-xTB optimization' + env%gfnver = '--gfn2' + + if (.not.env%legacy) then + !> reinit calculator with GFN2 + call qcg_envcalc_reinit(env,clus,.true.,.true.) + call checkname_xyz(crefile,inpnam,outnam) + call crest_multilevel_wrap(env,trim(inpnam),0) + else + call rmrf('OPTIM') + call multilevel_opt(env,99) + end if + write (stdout,*) + end if + +!--- Final optimization without wall potentials + env%optlev = 1.0d0 !Higher precision for less scattering + env%cts%NCI = .false. !Dactivating the wall pot. + env%cts%pots = '' + deallocate (env%cts%pots) + + if (.not.env%legacy) then + !> wall potential was turned off, add any other constraint back in + call qcg_envcalc_reinit(env,clus,.true.,.true.) + call checkname_xyz(crefile,inpnam,outnam) + call crest_multilevel_wrap(env,trim(inpnam),0) + else + call rmrf('OPTIM') + call multilevel_opt(env,99) + end if + +!--- Clustering to exclude similar structures if requested with -cluster + if (env%properties == 70) then + write (stdout,'(3x,''Clustering the remaining structures'')') + call checkname_xyz(crefile,inpnam,outnam) + call ccegen(env,.false.,inpnam) + call move(trim(clusterfile),trim(outnam)) + end if + +!--- Energy sorting and removal of dublicates + env%gbsa = gbsa_tmp + env%solv = solv_tmp + call newcregen(env,0) + call checkname_xyz(crefile,inpnam,outnam) + call copy(inpnam,'ensemble.xyz') + call ens%open('ensemble.xyz') !Read in ensemble + call clus%deallocate() + clus%nat = ens%nat + allocate (clus%at(clus%nat)) + allocate (clus%xyz(3,clus%nat)) + write (stdout,'(1x,i0,a)') ens%nall,' structures remaining.' + write (stdout,*) + +!------------------------------------------------------------- +! SP with Implicit solvation model and without wall potentials +!------------------------------------------------------------- + if (env%legacy) then + !> old, I/O-heavy version + call ens_sp_with_io(env,ens,clus,resultspath) + else + !> use internal parallel loop, but remember to convert to Bohrs for that + clus%at(:) = ens%at(:) + clus%xyz(1:3,1:clus%nat) = ens%xyz(1:3,1:ens%nat,1)*aatoau + call qcg_envcalc_reinit(env,clus,.true.,.true.) + + ens%xyz = ens%xyz*aatoau + call crest_sploop(env,ens%nat,ens%nall,ens%at,ens%xyz,ens%er) + ens%xyz = ens%xyz*autoaa + end if + +!------------------------------------------------------------- +! Processing results +!------------------------------------------------------------- + env%gfnver = gfnver_tmp + allocate (e_fix(ens%nall),source=0.0_wp) + allocate (e_clus(ens%nall),source=0.0_wp) + + call pr_ensemble_energy() + + open (newunit=ich98,file='cluster_energy.dat') + write (ich98,'(3x,''#'',9x,''Energy [Eh]'',6x,''SASA'')') + +!--- Fixation energy of optimization + do i = 1,ens%nall + if (env%legacy) then + !> old I/O-heady version + call chdirdbug('OPTIM') + write (to,'("TMPCONF",i0)') i + call chdirdbug(to) + call grepval('xtb.out',' :: add. restraining',e_there,e_fix(i)) + call chdirdbug(tmppath2) + call rdxmolselec('full_ensemble.xyz',i,clus%nat,clus%at,clus%xyz) + else + !> quicker version, simply load from 'ens' + call ens%get_mol(i,clus) + end if + + call get_sphere(.false.,clus,.false.) + dens = 0.001*(solu%mass+env%nsolv*solv%mass)/(1.0d-30*clus%vtot*bohr**3) + if (env%solv_md) then + call analyze_cluster(env%nsolv-1,clus%nat,solv%nat,solv%nat,clus%xyz,clus%at,shr_av,shr) + else + call analyze_cluster(env%nsolv,clus%nat,solu%nat,solv%nat,clus%xyz,clus%at,shr_av,shr) + end if + write (ich98,'(i4,F20.10,3x,f8.1)') env%nsolv,ens%er(i),clus%atot + write (stdout,'(x,i4,4x,F13.6,2x,f6.3,1x,f8.3,2x,2f6.1,3x,f8.1,3x,a)') & + & i,ens%er(i),dens,e_fix(i),shr_av,shr,clus%atot,trim(optlevflag(env%optlev)) + e_fix(i) = e_fix(i)*autokcal/sqrt(real(clus%nat,wp)) + end do + close (ich98) + call copysub('cluster_energy.dat',resultspath) + +!--- Checking Boltzmann weighting + write (stdout,*) + call remove('full_ensemble.xyz') + call qcg_dump_sorted_ensemble(ens,ens%er,'full_ensemble.xyz') + e_clus = ens%er*autokcal + call sort_min(ens%nall,1,1,e_clus) + ens%er = e_clus/autokcal !Overwrite ensemble energy with sorted one + allocate (de(ens%nall),source=0.0d0) + allocate (p(ens%nall),source=0.0d0) + e0 = e_clus(1) + de(1:ens%nall) = (e_clus(1:ens%nall)-e0) + call qcg_boltz(env,ens%nall,de,p) + k = 0 + if (.not.env%user_nclust) env%nqcgclust = 0 !Needed for solvent ensemble + if (env%nqcgclust .eq. 0) then + do i = 1,ens%nall !Count how many are above 10% + if ((p(i)) .gt. 0.1) then + k = k+1 + end if + end do + if ((k .eq. 0).or.(k .gt. 10)) then + k = 10 !If too many structures are relevant, set it 10 + else if ((k .lt. 4).and.(ens%nall .ge. 4)) then + k = 4 !If too less structures are relevant, set it 4 + else if (ens%nall .gt. 0) then + k = ens%nall + else + error stop 'No structure left. Something went wrong.' + end if + write (stdout,'(2x,a,1x,i0)') 'Conformers taken:',k + env%nqcgclust = k + else + if (env%nqcgclust .gt. ens%nall) then + k = ens%nall !Input larger than remaining structures + write (stdout,'(''Less than '',1x,i0,1x,''structures remain'')') env%nqcgclust + write (stdout,'(''Only '',1x,i0,1x,''structures are taken'')') ens%nall + if (env%cff) env%nqcgclust = ens%nall !Only for CFF, else a second qcg_ensemble run starts for solvent + else + write (stdout,'(''Taking '',1x,i0,1x,''structures'')') env%nqcgclust + k = env%nqcgclust !user input + end if + end if + + open (newunit=ich65,file='final_ensemble.xyz') + do i = 1,k + open (newunit=ich48,file='full_population.dat') + write (ich48,'(2x, ''cluster'',2x,''E_norm [Eh]'',2x, ''De [kcal]'', 4x, ''p'')') + do j = 1,ens%nall + if (j .lt. 10) then + write (ich48,'(5x,i0,3x,f11.6,5x,f6.4,3x,f6.4)') j,e_clus(j)/autokcal,de(j),p(j) + else + write (ich48,'(5x,i0,2x,f11.6,5x,f6.4,3x,f6.4)') j,e_clus(j)/autokcal,de(j),p(j) + end if + end do + close (ich48) + +!--- Take k energetic least structures (written at beginning of file) + call rdxmolselec('full_ensemble.xyz',i,clus%nat,clus%at,clus%xyz) + call wrxyz(ich65,clus%nat,clus%at,clus%xyz*bohr,ens%er(i)) + end do + close (ich65) + + call ens%deallocate() + call ens%open('final_ensemble.xyz') + ens%er = e_clus(1:k)/autokcal + +!--- Getting G,S,H + write (stdout,*) + write (stdout,'(2x,70("-"))') + write (stdout,'(2x,70("-"))') + write (stdout,'(2x,''Boltz. averaged energy of final cluster:'')') + call aver(.true.,env,ens%nall,e_clus(1:ens%nall),S,H,G,sasa,.false.) + write (stdout,'(7x,''G /Eh :'',f15.8)') G/autokcal + write (stdout,'(7x,''T*S /kcal :'',f15.8)') S + + ens%g = G + ens%s = S + + deallocate (e_fix) + deallocate (e_clus) + +!---Folder management + call rename('cregen.out.tmp','thermo_data') + call copysub('thermo_data',resultspath) + call copysub('crest_best.xyz',resultspath) + call copysub('cre_members.out',resultspath) + call copysub('full_ensemble.xyz',resultspath) + call copysub('final_ensemble.xyz',resultspath) + call copysub('population.dat',resultspath) + call copysub('full_population.dat',resultspath) + +!---Deleting ensemble tmp + call chdirdbug(thispath) + call chdirdbug(env%scratchdir) + if (.not.env%keepModef) call rmrf(tmppath2) +!----Outprint + write (stdout,*) + write (stdout,'(2x,"Ensemble generation finished.")') + write (stdout,'(2x,"Results can be found in the [ensemble] directory:")') + write (stdout,'(2x,"--> What? --> Where?")') + write (stdout,'(2x,"Lowest energy conformer crest_best.xyz")') + write (stdout,'(2x,"List of full ensemble full_ensemble.xyz")') + write (stdout,'(2x,"List of used ensemble final_ensemble.xyz")') + write (stdout,'(2x,"Ensemble thermodyn data thermo_data")') + write (stdout,'(2x,"Population of selected population.dat")') + write (stdout,'(2x,"Population of full ensemble full_population.dat")') + + !>--- restore settings + env%gfnver = gfnver_tmp + env%optlev = optlev_tmp + if (env%ensemble_opt .eq. '--gff') then + env%cts%cbonds_md = cbonds_tmp + env%checkiso = checkiso_tmp + end if + + call tim_dum%clear + + if (.not.env%solv_md) then + call tim%stop(6) + else + call tim%stop(7) + end if + +end subroutine qcg_ensemble + +!==============================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< What? --> Where?")') + write (stdout,'(2x,"Structures crest_ensemble.xyz")') + write (stdout,'(2x,"Energies cluster_energy.dat")') + write (stdout,'(2x,"Population population.dat")') + + env%gfnver = gfnver_tmp + env%optlev = optlev_tmp + + deallocate (e_empty) + deallocate (converged) + deallocate (outer_ell_abc) + deallocate (inner_ell_abc) + + call tim%stop(8) + +end subroutine qcg_cff + +!==============================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Frequency calculation + opt = .true. + call ens_freq(env,'cluster.xyz',solu_ens%nall,'TMPFREQ',opt) + call chdirdbug(tmppath2) + +!---------------------------------------------------------------------------- +! frequencies for solvent cluster +!---------------------------------------------------------------------------- + write (stdout,'(/,1x,a)') 'processing SOLVENT CLUSTER' + if (env%cff) then + call chdirdbug('tmp_solv') + call ens_freq(env,'solvent_cut.coord',solu_ens%nall,'TMPFREQ',opt) + call chdirdbug(tmppath2) + end if + + call clus%deallocate() + + !--- Frequencies solvent cluster (only, if not cff was used) + if (.not.env%cff) then + call chdirdbug('tmp_solv') + call solv_ens%write('solvent_ensemble.xyz') + + do i = 1,solv_ens%nall + call solv_ens%get_mol(i,tmpmol) + write (to,'("TMPFREQ",i0)') i + io = makedir(trim(to)) + call copysub('.UHF',to) + call copysub('.CHRG',to) + call chdirdbug(to) + call tmpmol%write("solv_cluster.xyz") + + call chdirdbug(tmppath2) + call chdirdbug('tmp_solv') + end do +!> Frequency calculation + call ens_freq(env,'solv_cluster.xyz',solv_ens%nall,'TMPFREQ',opt) + call chdirdbug(tmppath2) + end if + +!---------------------------------------------------------------------------- +! Data read out +!---------------------------------------------------------------------------- + +!--- Solute in gas phase + write (stdout,*) + write (stdout,*) ' Solute Gas properties' + call pr_freq_energy() + open (newunit=ich56,file='solute.dat') + call pr_freq_file(ich56) + write (stdout,'(2x,5f10.2)') ht(3),svib(3),srot(3),stra(3),gt(3) + write (ich56,'(2x,5f10.2)') ht(3),svib(3),srot(3),stra(3),gt(3) + close (ich56) + +!--- Solute cluster + write (stdout,*) + write (stdout,*) ' Solute cluster properties' + open (newunit=ich33,file='solute_cluster.dat') + + call chdirdbug('tmp_solu') + + allocate (solu_ens%gt(solu_ens%nall)) + allocate (solu_ens%ht(solu_ens%nall)) + allocate (solu_ens%svib(solu_ens%nall)) + allocate (solu_ens%srot(solu_ens%nall)) + allocate (solu_ens%stra(solu_ens%nall)) + + call pr_freq_energy() + call pr_freq_file(ich33) + + do i = 1,solu_ens%nall + write (to,'("TMPFREQ",i0)') i + call chdirdbug(to) + call rdtherm('xtb_freq.out',ht(1),svib(1),srot(1),stra(1),gt(1)) + write (stdout,'(2x,i0,2x,5f10.2)') i,ht(1),svib(1),srot(1),stra(1),gt(1) + write (ich33,'(2x,i0,2x,5f10.2)') i,ht(1),svib(1),srot(1),stra(1),gt(1) + solu_ens%gt(i) = gt(1) + solu_ens%ht(i) = ht(1) + solu_ens%svib(i) = svib(1) + solu_ens%srot(i) = srot(1) + solu_ens%stra(i) = stra(1) + + call chdirdbug(tmppath2) + call chdirdbug('tmp_solu') + end do + close (ich33) + +!--- Solvent cluster + write (stdout,*) + write (stdout,*) ' Solvent cluster properties' + call chdirdbug(tmppath2) + open (newunit=ich81,file='solvent_cluster.dat') + + call chdirdbug('tmp_solv') + + allocate (solv_ens%gt(solv_ens%nall)) + allocate (solv_ens%ht(solv_ens%nall)) + allocate (solv_ens%svib(solv_ens%nall)) + allocate (solv_ens%srot(solv_ens%nall)) + allocate (solv_ens%stra(solv_ens%nall)) + + call pr_freq_energy() + call pr_freq_file(ich81) + + do i = 1,solv_ens%nall + write (to,'("TMPFREQ",i0)') i + call chdirdbug(to) + call rdtherm('xtb_freq.out',ht(2),svib(2),srot(2),stra(2),gt(2)) + write (stdout,'(2x,i0,2x,5f10.2)') i,ht(2),svib(2),srot(2),stra(2),gt(2) + write (ich81,'(2x,i0,2x,5f10.2)') i,ht(2),svib(2),srot(2),stra(2),gt(2) + solv_ens%gt(i) = gt(2) + solv_ens%ht(i) = ht(2) + solv_ens%svib(i) = svib(2) + solv_ens%srot(i) = srot(2) + solv_ens%stra(i) = stra(2) + call chdirdbug(tmppath2) + call chdirdbug('tmp_solv') + end do + close (ich81) + +!--- Saving results + call chdirdbug(tmppath2) + call copysub('solute.dat',resultspath) + call copysub('solute_cluster.dat',resultspath) + call copysub('solvent_cluster.dat',resultspath) + +!--- Deleting tmp directory + call chdirdbug(tmppath) + if (.not.env%keepModef) call rmrf(tmppath2) + call chdirdbug(thispath) + + env%gfnver = gfnver_tmp + env%optlev = optlev_tmp + + call tim%stop(9) + +end subroutine qcg_freq + +!==============================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<. +!================================================================================! + +subroutine xtb_sp_qcg(env,fname,success,eout) +!******************************************************** +!* xtb_sp_qcg +!* A quick single point xtb calculation without wbo +!******************************************************** + use crest_parameters + use iomod + use crest_data + use crest_calculator + use strucrd + implicit none + type(systemdata) :: env + character(len=*),intent(in) :: fname + logical,intent(out) :: success + real(wp),intent(out) :: eout + + character(len=512) :: jobcall + character(len=*),parameter :: pipe = ' > xtb.out 2> /dev/null' + logical,parameter :: debug = .false. + integer :: io,T,Tn + + success = .false. + eout = 0.0_wp + + if (env%legacy) then +!>---------------------------------------------- +!> The original implementation with systemcall + call remove('gfnff_topo') + call remove('energy') + call remove('charges') + call remove('xtbrestart') + +!---- setting threads + call new_ompautoset(env,'auto',1,T,Tn) + +!---- jobcall + write (jobcall,'(a,1x,a,1x,a,'' --sp '',a,1x,a)') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) + + if (debug) write (stdout,*) trim(jobcall) + call command(trim(jobcall),io) + call grepval('xtb.out','| TOTAL ENERGY',success,eout) +!---- cleanup + call remove('energy') + call remove('charges') + call remove('xtbrestart') + call remove('xtbtopo.mol') + call remove('gfnff_topo') + else +!>--------------------------------------------- +!> New implementation with calculator and api + block + type(calcdata) :: calc + type(coord) :: mol + real(wp),allocatable :: gradtmp(:,:) + + call mol%open(fname) + allocate (gradtmp(3,mol%nat)) + call env2calc(env,calc,mol) + if (debug) call calc%info(stdout) + call engrad(mol,calc,eout,gradtmp,io) + success = (io == 0) + end block + end if +end subroutine xtb_sp_qcg + +!-------------------------------------------------------------------------------------------- +! A quick single xtb optimization gets mol and overwrites it with optimized stuff +!-------------------------------------------------------------------------------------------- +subroutine xtb_opt_qcg(env,mol,constrain) + use crest_parameters + use iomod + use crest_data + use qcg_coord_type + use strucrd + + implicit none + type(systemdata),intent(in) :: env + type(coord_qcg),intent(inout) :: mol + + character(:),allocatable :: fname + character(len=512) :: jobcall + logical :: constrain,const + real(wp) :: energy + integer :: io,T,Tn + character(stdout),parameter :: pipe = ' > xtb_opt.out 2> /dev/null' + logical,parameter :: debug = .false. + + if (env%legacy) then + !> LEGACY version with syscall + + !--- Write coordinated + fname = 'coord' + call mol%write(fname) + + !---- setting threads + call new_ompautoset(env,'auto',1,T,Tn) + + !---- jobcall & Handling constraints + if (constrain.AND.env%cts%used) then + call write_constraint(env,fname,'xcontrol') + call mol%write('coord.ref') + write (jobcall,'(a,1x,a,1x,a,'' --opt --input xcontrol '',a,1x,a)') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) + else + write (jobcall,'(a,1x,a,1x,a,'' --opt '',a,1x,a)') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) + end if + + call command(trim(jobcall),io) + !---- cleanup + call rdcoord('xtbopt.coord',mol%nat,mol%at,mol%xyz) + call remove('energy') + call remove('charges') + call remove('xtbrestart') + call remove('xtbtopo.mol') + call remove('gfnff_topo') + + else + + !> NEW version with calculator + call new_ompautoset(env,'max',1,T,Tn) + block + use crest_calculator + use optimize_module + type(calcdata) :: calc + type(coord) :: molin,molout + real(wp),allocatable :: gradtmp(:,:) + + allocate (gradtmp(3,mol%nat)) + molin = mol%as_coord() + call env2calc(env,calc,molin) + if (debug) call calc%info(stdout) + + call optimize_geometry(molin,molout,calc,energy,gradtmp,debug,.false.,io) + + deallocate (gradtmp) + if (io == 0) then + call mol%from_coord(molout) + else + write (stdout,*) 'FAILURE in QCG optimization!' + write (stdout,*) 'Stopping run to avoid unecessary compuations' + call creststop(status_safety) + end if + end block + + end if +end subroutine xtb_opt_qcg + +subroutine xtb_md_ensemble_qcg(env,solu,solv,clus,resultspath) + use crest_parameters + use crest_data + use qcg_coord_type + use strucrd + use iomod + use qcg_printouts + use crest_calculator + use dynamics_module + implicit none + !> IN/OUTPUTS + type(systemdata),intent(inout) :: env + type(coord_qcg),intent(inout) :: solu + type(coord_qcg),intent(inout) :: solv + type(coord_qcg),intent(inout) :: clus + character(len=*),intent(in) :: resultspath + !> LOCAL + integer :: T,Tn,i,j,k,l,ich,r,io + real(wp) :: newtemp,newmdtime,newmdstep,newhmass + real(wp) :: newmetadfac,newmetadexp,newmetadlist + character(len=:),allocatable :: fname + character(len=512) :: tmppath,tmppath2 + character(len=1024) :: jobcall + logical :: ex,mdfail + type(ensemble) :: dum + type(calcdata),target :: calc + type(mddata) :: mddat + type(coord) :: mol + type(mtdpot) :: mtd + real(wp),allocatable :: cn(:),fakewbo(:,:) + character(len=*),parameter :: pipe = ' > xtb.out 2>/dev/null' + + call getcwd(tmppath2) + + !---- Setting threads + call new_ompautoset(env,'auto',1,T,Tn) + + !--- Setting new defaults for MD/MTD in qcg + if (env%mdtemp .lt. 0.0d0) then + newtemp = 400.00d0 + else if (.not.env%user_temp) then + newtemp = 298.0 + else + newtemp = env%mdtemp + end if + env%mdtemp = newtemp + + if (.not.env%user_mdtime) then + newmdtime = 100.0 !100.0 + else + newmdtime = env%mdtime + end if + env%mdtime = newmdtime + + if (.not.env%user_dumxyz) then + env%mddumpxyz = 1000 + end if + + if (.not.env%user_mdstep) then + if (env%ensemble_opt .ne. '--gff') then + newmdstep = 4.0d0 + else + newmdstep = 1.5d0 + end if + else + newmdstep = env%mdstep + end if + env%mdstep = newmdstep + + if (env%ensemble_opt .ne. '--gff') then + newhmass = 4.0 + else + newhmass = 5.0 + end if + env%hmass = newhmass + + if (.not.allocated(env%metadfac)) then + allocate (env%metadfac(1),source=0.02_wp) + allocate (env%metadexp(1),source=0.1_wp) + allocate (env%metadlist(1),source=10) + end if + newmetadfac = 0.02_wp + newmetadexp = 0.1_wp + newmetadlist = 10.0_wp + + fname = 'coord' + +!> -------------------------------------------------------------------- +!> Internal calculator version +!> -------------------------------------------------------------------- + if (.not.env%legacy) then + call mol%open(fname) + + call env_to_mddat(env) + mddat = env%mddat + calc = env%calc + if (.not.env%solv_md) then + call calc%set_freeze(mol%nat,1,solu%nat) + end if + + if (env%shake .ne. 0) then + call mol%cn_to_bond(cn,fakewbo) + call move_alloc(fakewbo,mddat%shk%wbo) + if (calc%nfreeze > 0) then + mddat%shk%freezeptr => calc%freezelist + end if + end if + + !> for MTD runtype add the corresponding potential + if (env%ensemble_method .EQ. 2) then + mtd%kpush = newmetadfac + mtd%alpha = newmetadexp + mtd%cvdump_fs = real(env%mddump) + mtd%mtdtype = cv_rmsd + allocate (mtd%atinclude(mol%nat),source=.true.) + mtd%atinclude(1:clus%nat) = .false. !> only include solvent + call mddat%add(mtd) + end if + + !> set output file and run + mddat%trajectoryfile = 'xtb.trj.xyz' + call dynamics(mol,mddat,calc,.true.,io) + + if (io .ne. 0) then + write (stdout,*) 'WARNING: MD run terminated ABNORMALLY' + call creststop(status_failed) + end if + + call rename(mddat%trajectoryfile,'crest_rotamers_0.xyz') + +!> -------------------------------------------------------------------- +!> xtb-syscall version +!> -------------------------------------------------------------------- + else + + !--- Writing constraining file xcontrol + !--- Providing xcontrol overwrites constraints in coord file + + open (newunit=ich,file='xcontrol') + if (env%cts%NCI) then + do i = 1,10 + if (trim(env%cts%pots(i)) .ne. '') then + write (ich,'(a)') trim(env%cts%pots(i)) + end if + end do + end if + + if (.not.env%solv_md) then + write (ich,'(a)') '$constrain' + write (ich,'(2x,a,i0)') 'atoms: 1-',solu%nat + write (ich,'(2x,a)') 'force constant=0.5' + write (ich,'(2x,a,a)') 'reference=ref.coord' + end if + + write (ich,'(a)') '$md' + write (ich,'(2x,a,f10.2)') 'hmass=',newhmass + write (ich,'(2x,a,f10.2)') 'time=',newmdtime + write (ich,'(2x,a,f10.2)') 'temp=',newtemp + write (ich,'(2x,a,f10.2)') 'step=',newmdstep + write (ich,'(2x,a,i0)') 'shake=',env%shake + write (ich,'(2x,a,i0)') 'dump=',env%mddumpxyz + write (ich,'(2x,a)') 'dumpxyz=500.0' + + if (env%ensemble_method .EQ. 2) then + write (ich,'(a)') '$metadyn' + write (ich,'(2x,a,i0,a,i0)') 'atoms: ',solu%nat+1,'-',clus%nat + write (ich,'(2x,a,f10.2)') 'save=',newmetadlist + write (ich,'(2x,a,f10.2)') 'kpush=',newmetadfac + write (ich,'(2x,a,f10.2)') 'alp=',newmetadexp + end if + + if (env%cts%cbonds_md) call write_cts_CBONDS(ich,env%cts) + + close (ich) + +!--- Writing jobcall + write (jobcall,'(a,1x,a,1x,a,'' --md --input xcontrol '',a,1x,a,a)') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),pipe +!--- slightly different jobcall for QMDFF usage + if (env%useqmdff) then + write (jobcall,'(a,1x,a,1x,a,'' --md --input xcontrol --qmdff'',a,1x,a,a)') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),pipe + end if +!--- MD + if (env%ensemble_method .EQ. 1) then + call normalMD(fname,env,1,newtemp,newmdtime) + write (stdout,*) 'Starting MD with the settings:' + write (stdout,'('' MD time /ps :'',f8.1)') newmdtime + write (stdout,'('' MD Temperature /K :'',f8.1)') newtemp + write (stdout,'('' dt /fs :'',f8.1)') newmdstep + write (tmppath,'(a,i0)') 'NORMMD1' + + r = makedir(tmppath) + call copysub('xcontrol',tmppath) + call chdirdbug(tmppath) + call copy('coord','ref.coord') + call chdirdbug(tmppath2) + + call command('cd '//trim(tmppath)//' && '//trim(jobcall),io) + + inquire (file=trim(tmppath)//'/'//'xtb.trj',exist=ex) + if (.not.ex.or.io .ne. 0) then + write (stdout,'(a,i0,a)') '*Warning: MD seemingly failed (no xtb.trj)*' + else + write (stdout,*) '*MD finished*' + end if + + if (env%trackorigin) then + call set_trj_origins('NORMMD','md') + end if + call chdirdbug('NORMMD1') + end if + +!--- MTD + + if (env%ensemble_method .EQ. 2) then + call MetaMD(env,1,newmdtime,env%metadfac(1),env%metadexp(1), & + & env%metadlist(1)) + write (stdout,'(a,i4,a)') 'Starting Meta-MD with the settings:' + write (stdout,'('' MTD time /ps :'',f8.1)') newmdtime + write (stdout,'('' dt /fs :'',f8.1)') newmdstep + write (stdout,'('' MTD Temperature /K :'',f8.1)') newtemp + write (stdout,'('' dumpstep(trj) /fs :'',i8)') env%mddumpxyz + write (stdout,'('' Vbias factor k /Eh :'',f8.4)') newmetadfac + write (stdout,'('' Vbias exp α /bohr⁻²:'',f8.2)') newmetadexp + + write (tmppath,'(a,i0)') 'METADYN1' + r = makedir(tmppath) + call copysub('xcontrol',tmppath) + call chdirdbug(tmppath) + call copy('coord','ref.coord') + + call chdirdbug(tmppath2) + + call command('cd '//trim(tmppath)//' && '//trim(jobcall),io) + + inquire (file=trim(tmppath)//'/'//'xtb.trj',exist=ex) + if (.not.ex.or.io .ne. 0) then + write (stdout,'(a,i0,a)') '*Warning: Meta-MTD seemingly failed (no xtb.trj)*' + else + write (stdout,*) '*MTD finished*' + end if + + if (env%trackorigin) then + call set_trj_origins('METADYN','mtd') + end if + + call chdirdbug('METADYN1') + + end if + + call rename('xtb.trj','crest_rotamers_0.xyz') + call copysub('crest_rotamers_0.xyz',tmppath2) + call dum%open('crest_rotamers_0.xyz') + +!--- M(T)D stability check + call minigrep('xtb.out','M(T)D is unstable, emergency exit',mdfail) + if (dum%nall .eq. 1) then + call copysub('xtb.out',resultspath) + write (stdout,*) 'ERROR : M(T)D results only in one structure' + if (mdfail) then + write (stdout,*) ' It was unstable' + else + write (stdout,*) ' The M(T)D time step might be too large or the M(T)D time too short.' + end if + call copysub('xtb.out',resultspath) + error stop ' Please check the xtb.out file in the ensemble folder' + end if + if (mdfail) then + write (stdout,*) + write (stdout,*) ' WARNING: The M(T)D was unstable.' + write (stdout,*) ' Please check the xtb.out file in the ensemble folder.' + write (stdout,*) + call copysub('xtb.out',resultspath) + end if + call dum%deallocate + call chdirdbug(tmppath2) + call clus%write('coord') + call inputcoords(env,'coord') !Necessary + +!--- Optimization + call print_qcg_opt + call multilevel_opt(env,99) + end if + +end subroutine xtb_md_ensemble_qcg + +!___________________________________________________________________________________ +! +! An xTB docking on all available threads +!___________________________________________________________________________________ + +subroutine xtb_dock(env,fnameA,fnameB,solu,clus) + use crest_parameters + use iomod + use crest_data + use qcg_coord_type + implicit none + + type(systemdata) :: env + type(coord_qcg),intent(in) :: solu,clus + character(len=*),intent(in) :: fnameA,fnameB + character(len=80) :: pipe + character(len=512) :: jobcall + integer :: i,ich,T,Tn + + call remove('xtb_dock.out') + call remove('xcontrol') + + pipe = ' 2>/dev/null' + +!---- writing wall pot in xcontrol + call write_wall(env,solu%nat,solu%ell_abc,clus%ell_abc,'xcontrol') + +!---- Write directed stuff, if requested + if (allocated(env%directed_file)) then + do i = 1,size(env%directed_number) + if & + & ((i == 1.and.env%directed_number(i) >= clus%nmol).OR. & + & (env%directed_number(i) >= clus%nmol.and.env%directed_number(i-1) < clus%nmol)) & + & then + open (newunit=ich,file='xcontrol',status='old',position='append',action='write') + write (ich,'("$directed")') + write (ich,'(a,1x,a)') 'atoms:',trim(env%directed_list(i,1)) + write (ich,'("$end")') + end if + end do + end if + +!--- Setting threads + call new_ompautoset(env,'auto',1,T,Tn) + +!--- Jobcall docking + write (jobcall,'(a,1x,''dock'',1x,a,1x,a,1x,a,1x,f4.2,1x,''--nfrag1'',1x,i0,1x,a,1x, & + & ''--input xcontrol > xtb_dock.out'',a)') & + & trim(env%ProgName),trim(fnameA),trim(fnameB),trim(env%gfnver),& + & env%optlev,solu%nat,trim(env%docking_qcg_flag),trim(pipe) + call command(trim(jobcall)) + +! cleanup + call remove('wbo') + call remove('charges') + call remove('xtbrestart') + +end subroutine xtb_dock + +!___________________________________________________________________________________ +! +! An xTB optimization on all available threads +!___________________________________________________________________________________ + +subroutine opt_cluster(env,solu,clus,fname,without_pot) + use crest_parameters + use iomod + use crest_data + use qcg_coord_type + + implicit none + + type(systemdata) :: env + type(coord_qcg),intent(in) :: solu,clus + character(len=*),intent(in) :: fname + logical,optional,intent(in) :: without_pot + character(len=*),parameter :: pipe = ' 2>/dev/null' + character(len=:),allocatable :: jobcall + integer :: T,Tn + + call remove('xtb.out') + +!---- writing wall pot in xcontrol + if (.not.without_pot) then + call write_wall(env,solu%nat,solu%ell_abc,clus%ell_abc,'xcontrol') + end if + +!--- Setting threads + call new_ompautoset(env,'subprocess',1,T,Tn) + +!--- Jobcall optimization + jobcall = trim(env%ProgName)//' '//trim(fname)//' --opt '//optlevflag(env%optlev) + jobcall = trim(jobcall)//' '//trim(env%gfnver) + if (without_pot) then + jobcall = trim(jobcall)//' '//trim(env%solv) + end if + jobcall = trim(jobcall)//' > xtb_opt.out 2>/dev/null' + call command(trim(jobcall)) + +! cleanup + call remove('wbo') + call remove('charges') + call remove('xtbrestart') + +!--- Jobcall SP for gbsa model + if (.not.without_pot) then + jobcall = trim(env%ProgName)//' xtbopt.coord --sp '//trim(env%gfnver) + jobcall = trim(jobcall)//' '//trim(env%solv) + jobcall = trim(jobcall)//' > xtb_sp.out 2>/dev/null' + call command(trim(jobcall)) + end if + +! cleanup + call remove('wbo') + call remove('charges') + call remove('xtbrestart') + +end subroutine opt_cluster + +!___________________________________________________________________________________ +! +! xTB docking calculation performed in parallel +!___________________________________________________________________________________ + +subroutine ensemble_dock(env,outer_ell_abc,nfrag1,frag1_file,frag2_file,n_shell& + &,n_solvent,NTMP,TMPdir,conv) + use crest_parameters + use iomod + use crest_data + use qcg_coord_type + + implicit none + type(systemdata) :: env + + character(len=*),intent(in) :: TMPdir !directory name + integer,intent(in) :: NTMP !number of structures to be optimized + integer,intent(in) :: nfrag1 !#atoms of larger fragment + integer,intent(in) :: conv(env%nqcgclust+1) + real(wp),intent(in) :: outer_ell_abc(env%nqcgclust,3) + integer,intent(in) :: n_shell,n_solvent + + integer :: i,k + integer :: vz,T,Tn + character(len=20) :: pipe + character(len=1024) :: jobcall + character(len=512) :: thispath,tmppath + character(len=*),intent(in) :: frag1_file + character(len=*),intent(in) :: frag2_file + character(len=64) :: frag1 + character(len=64) :: frag2 + real(wp) :: percent + character(len=2) :: flag + integer :: funit + +! some options + pipe = '2>/dev/null' + frag1 = 'solvent_cluster.coord' + frag2 = 'solvent' + call getcwd(thispath) + +! setting the threads for correct parallelization + call new_ompautoset(env,'auto',NTMP,T,Tn) + + write (jobcall,'(a,1x,''dock'',1x,a,1x,a,1x,a,1x,f4.2,1x,''--nfrag1'',1x,i0,1x,& + & ''--input xcontrol --fast > xtb_dock.out '',a)') & + & trim(env%ProgName),trim(frag1_file),trim(frag2_file),& + & trim(env%gfnver),env%optlev,nfrag1,trim(pipe) + + flag = '$' + do i = 1,NTMP + vz = i + write (tmppath,'(a,i0)') trim(TMPdir),conv(i) + call chdirdbug(trim(tmppath)) + open (newunit=funit,file='xcontrol') + write (funit,'(a,"fix")') trim(flag) + write (funit,'(3x,"atoms: 1-",i0)') n_shell !Initial number of atoms (starting solvent shell) + write (funit,'(a,"wall")') trim(flag) + write (funit,'(3x,"potential=polynomial")') + write (funit,'(3x,"ellipsoid:",1x,3(g0,",",1x),i0,"-",i0)') outer_ell_abc(conv(vz),:), & + & n_shell+1,n_shell+n_solvent !Initial number of atoms (starting solvent shell) + close (funit) + call chdirdbug(trim(thispath)) + end do + + k = 0 !counting the finished jobs + +!___________________________________________________________________________________ + +!$omp parallel & +!$omp shared( vz,NTMP,percent,k,TMPdir,conv,n_shell,n_solvent,jobcall ) +!$omp single + do i = 1,NTMP + vz = i + !$omp task firstprivate( vz ) private( tmppath ) + write (tmppath,'(a,i0)') trim(TMPdir),conv(vz) + call command('cd '//trim(tmppath)//' && '//trim(jobcall)) + !$omp critical + k = k+1 + percent = real(k)/real(NTMP)*100 + !$omp end critical + !$omp end task + end do + +!$omp taskwait +!$omp end single +!$omp end parallel + +!___________________________________________________________________________________ + call chdirdbug(trim(thispath)) + +end subroutine ensemble_dock + +!___________________________________________________________________________________ +! +! xTB CFF optimization performed in parallel +!___________________________________________________________________________________ + +subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added,eread) + use crest_parameters + use iomod + use crest_data + use strucrd + implicit none + + type(systemdata) :: env + character(len=*),intent(in) :: fname !file base name + character(len=*),intent(in) :: TMPdir !directory name + integer,intent(inout) :: NTMP !number of structures to be optimized + integer,intent(inout) :: conv(env%nqcgclust+1) + logical,intent(in) :: pr + logical,intent(in) :: nothing_added(env%nqcgclust) + integer,intent(in) :: n12 + real(wp),intent(out) :: eread(env%nqcgclust) + integer :: i,k + integer :: vz,T,Tn + integer :: funit + character(len=512) :: thispath,tmppath + character(len=1024) :: jobcall + character(len=2) :: flag + real(wp) :: percent + logical :: ex,e_there + character(len=*),parameter :: pipe = '2>/dev/null' + + !> redirect to calculator version in new implementation + if (.not.env%legacy) then + call cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added,eread) + return + end if + +! setting the threads for correct parallelization + call new_ompautoset(env,'auto',NTMP,T,Tn) + + if (pr) then + write (stdout,'(2x,''Starting optimizations + SP of structures'')') + write (stdout,'(2x,i0,'' jobs to do.'')') NTMP + end if + +! pr eq true => post opt run, which has to be performed in every directory !!! + if (pr) then + k = 0 + NTMP = env%nqcgclust + do i = 1,env%nqcgclust + k = k+1 + conv(k) = i + conv(env%nqcgclust+1) = k + end do + end if + + call getcwd(thispath) + do i = 1,NTMP + write (tmppath,'(a,i0)') trim(TMPdir),conv(i) + call chdirdbug(trim(tmppath)) + open (newunit=funit,file='xcontrol') + if (n12 .ne. 0) then + flag = '$' + write (funit,'(a,"fix")') trim(flag) + write (funit,'(3x,"atoms: 1-",i0)') n12 !Initial number of atoms (starting solvent shell) + end if + close (funit) + if (pr.and.nothing_added(i)) call remove('xcontrol') + call chdirdbug(trim(thispath)) + end do + +!--- Jobcall + write (jobcall,'(a,1x,a,1x,a,'' --input xcontrol --opt '',i0,1x,a,'' >xtb.out'')') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),nint(env%optlev),trim(pipe) + + if (NTMP .lt. 1) then + write (stdout,'(2x,"No structures to be optimized")') + return + end if + + k = 0 !counting the finished jobs + if (pr) call crest_oloop_pr_progress(env,NTMP,k) +!___________________________________________________________________________________ + +!$omp parallel & +!$omp shared( env, vz,jobcall,NTMP,percent,k,TMPdir,conv ) +!$omp single + do i = 1,NTMP + vz = i + !$omp task firstprivate( vz ) private( tmppath ) + write (tmppath,'(a,i0)') trim(TMPdir),conv(vz) + call command('cd '//trim(tmppath)//' && '//trim(jobcall)) + !$omp critical + k = k+1 + percent = real(k)/real(NTMP)*100 + if (pr) then + call crest_oloop_pr_progress(env,NTMP,k) + end if + !$omp end critical + !$omp end task + end do +!$omp taskwait +!$omp end single +!$omp end parallel + +!__________________________________________________________________________________ + + do i = 1,NTMP + write (tmppath,'(a,i0)') trim(TMPdir),conv(i) + call chdirdbug(trim(tmppath)) + call remove('xtbrestart') + call chdirdbug(trim(thispath)) + end do + + !create the system call for sp (needed for gbsa model) + write (jobcall,'(a,1x,a,1x,a,'' --sp '',a,1x,a,'' >xtb_sp.out'')') & + & trim(env%ProgName),'xtbopt.coord',trim(env%gfnver),trim(env%solv),trim(pipe) + + if (NTMP .lt. 1) then + write (stdout,'(2x,"Nothing to do")') + return + end if + + k = 0 !counting the finished jobs + if (pr) call crest_oloop_pr_progress(env,NTMP,k) +!___________________________________________________________________________________ + +!$omp parallel & +!$omp shared( vz,jobcall,NTMP,percent,k,TMPdir,conv ) +!$omp single + do i = 1,NTMP + vz = i + !$omp task firstprivate( vz ) private( tmppath ) + write (tmppath,'(a,i0)') trim(TMPdir),conv(vz) + call command('cd '//trim(tmppath)//' && '//trim(jobcall)) + !$omp critical + k = k+1 + percent = real(k)/real(NTMP)*100 + if (pr) then + call crest_oloop_pr_progress(env,NTMP,k) + end if + !$omp end critical + !$omp end task + end do +!$omp taskwait +!$omp end single +!$omp end parallel + +!___________________________________________________________________________________ + + do i = 1,NTMP + write (tmppath,'(a,i0)') trim(TMPdir),conv(i) + call chdirdbug(trim(tmppath)) + + call grepval('xtb_sp.out','| TOTAL ENERGY',e_there,eread(i)) + + call remove('xtbrestart') + !call remove('xcontrol') + call chdirdbug(trim(thispath)) + end do + + if (pr) then + write (stdout,*) '' + write (stdout,'(2x,"done.")') + end if + +end subroutine cff_opt + +subroutine cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir, & + & conv,nothing_added,eread) + use crest_parameters + use iomod + use crest_data + use strucrd + use crest_calculator + use optimize_module + implicit none + + type(systemdata) :: env + character(len=*),intent(in) :: fname !file base name + character(len=*),intent(in) :: TMPdir !directory name + integer,intent(inout) :: NTMP !number of structures to be optimized + integer,intent(inout) :: conv(env%nqcgclust+1) + logical,intent(in) :: pr + logical,intent(in) :: nothing_added(env%nqcgclust) + integer,intent(in) :: n12 + real(wp),intent(out) :: eread(env%nqcgclust) + integer :: i,k + integer :: vz,T,Tn + integer :: funit + character(len=512) :: thispath,tmppath + character(len=1024) :: jobcall + character(len=2) :: flag + real(wp) :: percent + logical :: gbsa_tmp,opt_nofreeze + integer :: io,nconstraints_tmp + character(len=40) :: solv_tmp + real(wp) :: etot + type(calcdata),allocatable :: newcalcs(:) + type(calculation_settings) :: clevel + type(coord) :: mol,molopt + type(coord),allocatable :: structures(:) + real(wp),allocatable :: grd(:,:) + character(len=*),parameter :: pipe = '2>/dev/null' + + !> setting the threads to accelerate individual energy calculations + call new_ompautoset(env,'max',NTMP,T,Tn) + + if (pr) then + write (stdout,'(2x,"Starting optimizations + SP of structures")') + write (stdout,'(2x,i0,'' jobs to do.'')') NTMP + end if + if (NTMP .lt. 1) then + write (stdout,'(2x,"No structures to be optimized")') + return + end if + +! pr eq true => post opt run, which has to be performed in every directory !!! + if (pr) then + k = 0 + NTMP = env%nqcgclust + do i = 1,env%nqcgclust + k = k+1 + conv(k) = i + conv(env%nqcgclust+1) = k + end do + end if + + !> Local storage for structures. + allocate (structures(NTMP)) + + call getcwd(thispath) + do i = 1,NTMP + write (tmppath,'(a,i0)') trim(TMPdir),conv(i) + call chdirdbug(trim(tmppath)) + call structures(i)%open(fname) + call chdirdbug(trim(thispath)) + end do + + if (NTMP .lt. 1) then + write (stdout,'(2x,"No structures to be optimized")') + return + end if + +!--- Jobcall WITHOUT GBSA, back up data + solv_tmp = env%solv + gbsa_tmp = env%gbsa + env%solv = '' + env%gbsa = .false. + + !> keep everything nice and separate, we have different molecules after all... + !> also, this will be gas-phase + call clevel%create(env%gfnver,chrg=env%chrg,uhf=env%uhf) + allocate (newcalcs(NTMP)) + do i = 1,NTMP + call newcalcs(i)%add(clevel) + !> other important settings from env + newcalcs(i)%optlev = int(env%optlev) + end do + + !> ------------------------------------------------- + !> OPTIMIZATIONS + !> ------------------------------------------------- + !> The structures may have different numbers + !> and it should not not be many structures anyways. + !> therefore, just optimize them serially. + + k = 0 !counting the finished jobs + if (pr) call crest_oloop_pr_progress(env,NTMP,k) +!___________________________________________________________________________________ + + do i = 1,NTMP + mol = structures(i) + allocate (grd(3,mol%nat)) + opt_nofreeze = (pr.and.nothing_added(i)) + if (.not.opt_nofreeze.and.n12 > 0) then + call newcalcs(i)%set_freeze(mol%nat,1,n12) + if (n12 == mol%nat) cycle !> safeguard against freezing all + end if + + call optimize_geometry(mol,molopt,newcalcs(i),etot,grd, & + & .false.,.false.,io) + structures(i) = molopt + structures(i)%energy = etot + + k = k+1 + percent = real(k)/real(NTMP)*100.0_wp + if (pr) then + call crest_oloop_pr_progress(env,NTMP,k) + end if + + deallocate (grd) + end do + !> clear up space + deallocate (newcalcs) +!__________________________________________________________________________________ + +!> ------------------------------------------------- +!> SINGLEPOINTS +!> ------------------------------------------------- +!> same as for optimizations, turn on impl. solv again + env%solv = solv_tmp + env%gbsa = gbsa_tmp + + !> again, keep everything nice and separate (now with impl. solv) + call clevel%create(env%gfnver,chrg=env%chrg,uhf=env%uhf,& + & solvmodel=env%solv,solvent=env%solvent & + ) + allocate (newcalcs(NTMP)) + do i = 1,NTMP + call newcalcs(i)%add(clevel) + end do + + k = 0 !counting the finished jobs + if (pr) call crest_oloop_pr_progress(env,NTMP,k) +!___________________________________________________________________________________ + + do i = 1,NTMP + mol = structures(i) + allocate (grd(3,mol%nat)) + + call engrad(mol,newcalcs(i),etot,grd,io) + structures(i)%energy = etot + + k = k+1 + percent = real(k)/real(NTMP)*100.0_wp + if (pr) then + call crest_oloop_pr_progress(env,NTMP,k) + end if + + deallocate (grd) + end do +!___________________________________________________________________________________ + + !> for compatibility reasons, let's write the optimized geometries + !> and pass on energies + call getcwd(thispath) + do i = 1,NTMP + eread(i) = structures(i)%energy + write (tmppath,'(a,i0)') trim(TMPdir),conv(i) + call chdirdbug(trim(tmppath)) + call structures(i)%write('xtbopt.coord') + call chdirdbug(trim(thispath)) + end do + + if (allocated(newcalcs)) deallocate (newcalcs) + if (allocated(structures)) deallocate (structures) +end subroutine cff_opt_calculator + +!___________________________________________________________________________________ +! +! xTB SP performed in parallel +!___________________________________________________________________________________ +subroutine ens_sp_with_io(env,ens,clus,resultspath) + use crest_parameters + use crest_data + use qcg_coord_type + use strucrd + use iomod + implicit none + type(systemdata),intent(inout) :: env + type(ensemble),intent(inout) :: ens + type(coord_qcg),intent(inout) :: clus + character(len=512),intent(in) :: resultspath + character(len=512) :: tmppath2,to,comment + integer :: i,io,minpos + logical :: e_there,not_param,ex + + call getcwd(tmppath2) + + !--- Write folder with xyz-coordinates + do i = 1,ens%nall + call rdxmolselec('ensemble.xyz',i,clus%nat,clus%at,clus%xyz) + write (to,'("TMPSP",i0)') i + io = makedir(trim(to)) + call copysub('.UHF',to) + call copysub('.CHRG',to) + call chdirdbug(to) + call wrxyz('cluster.xyz',clus%nat,clus%at,clus%xyz*bohr) + call chdirdbug(tmppath2) + end do + !--- SP + write (stdout,*) + call ens_sp(env,'cluster.xyz',ens%nall,'TMPSP') + !--- Getting energy + do i = 1,ens%nall + call rdxmolselec('ensemble.xyz',i,clus%nat,clus%at,clus%xyz) + write (to,'("TMPSP",i0)') i + call chdirdbug(to) + call grepval('xtb_sp.out','| TOTAL ENERGY',e_there,ens%er(i)) + call chdirdbug(tmppath2) + end do + + if (.not.e_there) then + write (stdout,*) + write (stdout,*) 'Energy not found. Error in xTB computations occured' + call chdirdbug(to) + call minigrep('xtb_sp.out','solv_model_loadInternalParam',not_param) + call chdirdbug(tmppath2) + if (not_param) then + write (stdout,*) ' !!!WARNIG: CHOSEN SOLVENT NOT PARAMETERIZED & + & FOR IMPLICIT SOLVATION MODEL!!!' + write (stdout,'('' CHECK IF '',A,'' IS AVAILABLE IN xTB'')') env%solv + write (stdout,*) ' PLEASE RESTART THE ENSEMBLE GENERATION WITH AVAILABLE& + & PARAMETERIZATION IF YOU NEED ENERGIES' + call copysub('crest_conformers.xyz',resultspath) + write (stdout,*) ' The enesemble can be found in the directory& + & as ' + error stop + end if + end if + call ens%write('full_ensemble.xyz') + +!--- crest_best structure + minpos = minloc(ens%er,dim=1) + write (to,'("TMPSP",i0)') minpos + call chdirdbug(to) + call rdxmol('cluster.xyz',clus%nat,clus%at,clus%xyz) + call chdirdbug(tmppath2) + write (comment,'(F20.8)') ens%er(minpos) + inquire (file='crest_best.xyz',exist=ex) + if (ex) then + call rmrf('crest_best.xyz') !remove crest_best from + end if + call wrxyz('crest_best.xyz',clus%nat,clus%at,clus%xyz,trim(comment)) + +end subroutine ens_sp_with_io + +subroutine ens_sp(env,fname,NTMP,TMPdir) + use crest_parameters + use iomod + use crest_data + use strucrd + implicit none + + type(systemdata) :: env + character(len=*),intent(in) :: fname !file base name + character(len=*),intent(in) :: TMPdir !directory name + integer,intent(inout) :: NTMP !number of structures to be optimized + + integer :: i,k + integer :: vz,T,Tn + character(len=20) :: pipe + character(len=512) :: thispath,tmppath + character(len=1024) :: jobcall + real(wp) :: percent + +! setting the threads for correct parallelization + call new_ompautoset(env,'auto',NTMP,T,Tn) + + write (stdout,'(2x,''---------------------------------------------'')') + write (stdout,'(2x,''Single point computation with GBSA/ALPB model'')') + write (stdout,'(2x,''---------------------------------------------'')') + write (stdout,'(2x,i0,'' jobs to do.'')') NTMP + + pipe = '2>/dev/null' + + call getcwd(thispath) + + if (NTMP .lt. 1) then + write (stdout,'(2x,"No structures to be optimized")') + return + end if + +!--- Jobcall + write (jobcall,'(a,1x,a,1x,a,'' --sp '',a,1x,a,'' > xtb_sp.out'')') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) + + k = 0 !counting the finished jobs + call crest_oloop_pr_progress(env,NTMP,k) + +!___________________________________________________________________________________ + +!$omp parallel & +!$omp shared( env,vz,NTMP,percent,k,TMPdir,jobcall ) +!$omp single + do i = 1,NTMP + vz = i + !$omp task firstprivate( vz ) private( tmppath ) + call initsignal() + !$omp critical + write (tmppath,'(a,i0)') trim(TMPdir),vz + !$omp end critical + call command('cd '//trim(tmppath)//' && '//trim(jobcall)) + !$omp critical + k = k+1 + percent = real(k)/real(NTMP)*100 + call crest_oloop_pr_progress(env,NTMP,k) + !$omp end critical + !$omp end task + end do +!$omp taskwait +!$omp end single +!$omp end parallel + +!__________________________________________________________________________________ + + do i = 1,NTMP + write (tmppath,'(a,i0)') trim(TMPdir),i + call chdirdbug(trim(tmppath)) + call remove('xtbrestart') + call chdirdbug(trim(thispath)) + end do + write (stdout,*) '' + write (stdout,'(2x,"done.")') + +end subroutine ens_sp + +!___________________________________________________________________________________ +! +! xTB Freq compuatation performed in parallel +!___________________________________________________________________________________ + +subroutine ens_freq(env,fname,NTMP,TMPdir,opt) + use crest_parameters + use iomod + use crest_data + use strucrd + implicit none + + type(systemdata) :: env + character(len=*),intent(in) :: fname !file base name + character(len=*),intent(in) :: TMPdir !directory name + integer,intent(inout) :: NTMP !number of structures to be optimized + + integer :: i,k + integer :: vz,T,Tn + character(len=512) :: thispath,tmppath + character(len=1024) :: jobcall + real(wp) :: percent + logical :: opt + character(len=*),parameter :: pipe = '2>/dev/null' + + !> redirect to new calculator version if available + if (.not.env%legacy) then + call ens_freq_calculator(env,fname,NTMP,TMPdir,opt) + return + end if + +! setting the threads for correct parallelization + call new_ompautoset(env,'auto',NTMP,T,Tn) + + write (stdout,'(2x,''Starting reoptimizations + Frequency computation of ensemble'')') + write (stdout,'(2x,i0,'' jobs to do.'')') NTMP + + call getcwd(thispath) + + if (NTMP .lt. 1) then + write (stdout,'(2x,"No structures to be optimized")') + return + end if + + k = 0 !counting the finished jobs + call crest_oloop_pr_progress(env,NTMP,k) + +!--- Jobcall + if (.not.opt) then + write (jobcall,'(a,1x,a,1x,a,'' --hess '',a,'' >xtb_freq.out'')') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(pipe) + else + write (jobcall,'(a,1x,a,1x,a,'' --ohess '',a,'' >xtb_freq.out'')') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(pipe) + end if + +!___________________________________________________________________________________ + +!$omp parallel & +!$omp shared( env,vz,NTMP,percent,k,TMPdir,jobcall ) +!$omp single + do i = 1,NTMP + vz = i + !$omp task firstprivate( vz ) private( tmppath ) + write (tmppath,'(a,i0)') trim(TMPdir),i + call command('cd '//trim(tmppath)//' && '//trim(jobcall)) + !$omp critical + k = k+1 + percent = real(k)/real(NTMP)*100 + call crest_oloop_pr_progress(env,NTMP,k) + !$omp end critical + !$omp end task + end do +!$omp taskwait +!$omp end single +!$omp end parallel + +!__________________________________________________________________________________ + + do i = 1,NTMP + write (tmppath,'(a,i0)') trim(TMPdir),i + call chdirdbug(trim(tmppath)) + call remove('xtbrestart') + call chdirdbug(trim(thispath)) + end do + write (stdout,*) '' + write (stdout,'(2x,"done.")') + +end subroutine ens_freq + +subroutine ens_freq_calculator(env,fname,NTMP,TMPdir,opt) + use crest_parameters + use iomod + use crest_data + use strucrd + use crest_calculator + use hessian_tools + implicit none + + type(systemdata) :: env + character(len=*),intent(in) :: fname !file base name + character(len=*),intent(in) :: TMPdir !directory name + integer,intent(inout) :: NTMP !number of structures to be optimized + + integer :: i,k + integer :: vz,T,Tn + character(len=*),parameter :: pipe = '2>/dev/null' + character(len=512) :: thispath,tmppath + character(len=1024) :: jobcall + real(wp) :: percent + logical :: opt + + !> local calculation setup + type(coord) :: tmpmol,mol + type(calculation_settings) :: clevel + type(calcdata),allocatable :: newcalcs(:) + real(wp),allocatable :: tmpgrd(:,:),hess(:,:),freq(:) + real(wp) :: etmp + integer :: n3,io,ich + + real(wp) :: ithr,fscal,sthr + integer :: nt,nfreq,nrt + real(wp),allocatable :: temps(:),et(:),ht(:),stot(:),gt(:) + real(wp) :: zpve + +! setting the threads for correct parallelization + call new_ompautoset(env,'max',NTMP,T,Tn) + + write (stdout,'(2x,''Starting reoptimizations + Frequency computation of ensemble'')') + write (stdout,'(2x,i0,'' jobs to do.'')') NTMP + + call getcwd(thispath) + + if (NTMP .lt. 1) then + write (stdout,'(2x,"No structures to be optimized")') + return + end if + + k = 0 !counting the finished jobs + call crest_oloop_pr_progress(env,NTMP,k) + +!--- Jobcall + if (.not.opt) then + write (jobcall,'(a,1x,a,1x,a,'' --hess '',a,'' >xtb_freq.out'')') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(pipe) + else + write (jobcall,'(a,1x,a,1x,a,'' --ohess '',a,'' >xtb_freq.out'')') & + & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(pipe) + end if + +!--- prepare calcs + call clevel%create(env%gfnver,chrg=env%chrg,uhf=env%uhf) + allocate (newcalcs(NTMP)) + do i = 1,NTMP + call newcalcs(i)%add(clevel) + newcalcs(i)%optlev = int(env%optlev) + !call newcalcs(i)%info(stdout) + end do + +!--- prepare thermo + !> inversion threshold + ithr = env%thermo%ithr + !> frequency scaling factor + fscal = env%thermo%fscal + !> RR-HO interpolation + sthr = env%thermo%sthr + + !> we just need one temperature + nt = 1 + allocate (temps(nt),et(nt),ht(nt),gt(nt),stot(nt),source=0.0_wp) + temps(:) = 298.15_wp + +!___________________________________________________________________________________ +!> serial runtype + do i = 1,NTMP + write (tmppath,'(a,i0)') trim(TMPdir),i + call chdirdbug(trim(tmppath)) + call tmpmol%open(fname) + + allocate (tmpgrd(3,tmpmol%nat),source=0.0_wp) + if (opt) then + call optimize_geometry(tmpmol,mol,newcalcs(i),etmp,tmpgrd, & + & .false.,.false.,io) + else + mol = tmpmol + end if + + n3 = mol%nat*3 + allocate (hess(n3,n3),source=0.0_wp) + allocate (freq(n3),source=0.0_wp) + + !>-- compute Hessian + call numhess2(mol%nat,mol%at,mol%xyz,newcalcs(i),hess,io) + + !>-- Projects and mass-weights the Hessian + call prj_mw_hess(mol%nat,mol%at,n3,mol%xyz,hess(:,:)) + + !>-- Computes the Frequencies + call frequencies(mol%nat,mol%at,mol%xyz,n3,newcalcs(i),hess(:,:),freq(:),io) + + !> write dummy "xtb_freq.out" + open (newunit=ich,file="xtb_freq.out") + !> calcthermo wants input in Angstroem + call calcthermo(mol%nat,mol%at,mol%xyz*autoaa,freq,.true., & + & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,ich) + close (ich) + + deallocate (freq,hess,tmpgrd) + k = k+1 + call crest_oloop_pr_progress(env,NTMP,k) + call chdirdbug(trim(thispath)) + end do + +!__________________________________________________________________________________ + + write (stdout,*) + write (stdout,'(2x,"done.")') +end subroutine ens_freq_calculator + +!============================================================! +! subroutine wr_cluster_cut +! Cuts a cluster file and and writes the parts +! +! On Input: fname - name of the coord file +! n1 - number of atoms fragment1 +! n2 - number of atmos fragment2 +! iter - number of solvent molecules +! fname_solu_cut - name of outputfile fragment1 +! fname_solv_cut - name of outputfile fragment2 +! +!============================================================! + +subroutine wr_cluster_cut(fname_cluster,n1,n2,iter,fname_solu_cut,fname_solv_cut) + use crest_parameters + use strucrd + implicit none + integer,intent(in) :: n1,n2,iter + real(wp) :: xyz1(3,n1) + real(wp) :: xyz2(3,n2*iter) + integer :: at1(n1),at2(n2*iter) + character(len=*),intent(in) :: fname_cluster,fname_solu_cut,fname_solv_cut + character(len=256) :: atmp + character(len=2) :: a2 + integer :: ich,i,k,stat,io,io2 + + !ich = 142 + open (newunit=ich,file=fname_cluster,iostat=stat) + read (ich,'(a)') atmp + k = 1 + do i = 1,n1 + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + call coordline(atmp,a2,xyz1(1:3,k),io2) + at1(k) = e2i(a2) + k = k+1 + end do + k = 1 + do i = 1,n2*iter + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + call coordline(atmp,a2,xyz2(1:3,k),io2) + at2(k) = e2i(a2) + k = k+1 + end do + + call wrc0(fname_solu_cut,n1,at1,xyz1) + call wrc0(fname_solv_cut,n2*iter,at2,xyz2) + close (ich) + +end subroutine wr_cluster_cut + +!---------------------------------------------------------------------------- +! write a wall potential in a file used as xtb input + +subroutine write_wall(env,n1,rabc1,rabc12,fname) + use crest_parameters + use crest_data + + implicit none + + type(systemdata) :: env + integer,intent(in) :: n1 + real(wp),intent(in) :: rabc1(3),rabc12(3) + character(len=8) :: flag + character(len=*) :: fname + integer :: funit + + open (newunit=funit,file=fname) + flag = '$' + write (funit,'(a,"wall")') trim(flag) + write (funit,'(3x,"potential=polynomial")') + write (funit,'(3x,"ellipsoid:",1x,3(g0,",",1x),"all")') rabc12 + write (funit,'(3x,"ellipsoid:",1x,3(g0,",",1x),"1-",i0)') rabc1,n1 + if (env%constrain_solu) then + write (funit,'("$fix")') + write (funit,'(3x,"atoms: 1-",i0)') n1 + end if + call write_cts(funit,env%cts) + call write_cts_biasext(funit,env%cts) + if (env%cts%used) then !Only, if user set constrians is an $end written + write (funit,'(a)') '$end' + end if + close (funit) + +end subroutine write_wall + +subroutine check_dock(neg_E) + use crest_parameters + use crest_data + use iomod,only:minigrep,grepval + + implicit none + real(wp) :: int_E + logical,intent(out) :: neg_E + logical :: ex + character(len=*),parameter :: filename = 'xtbscreen.xyz' + + neg_E = .false. + int_E = 0.0_wp + + call minigrep('xtb_dock.out',' Lowest Interaction Energy: ********** kcal/mol',ex) + if (ex) return + + call grepval('xtb_dock.out','Lowest Interaction Energy:',ex,int_E) + + if (ex.and.int_E < 0.0_wp) neg_E = .true. + +end subroutine check_dock + +subroutine write_constraint(env,coord_name,fname) + use crest_parameters + use crest_data + use iomod + + implicit none + + type(systemdata) :: env + character(len=*),intent(in) :: fname,coord_name + integer :: funit + + call copysub(coord_name,'coord.ref') + open (newunit=funit,file=fname) + call write_cts(funit,env%cts) + call write_cts_biasext(funit,env%cts) + if (env%cts%used) then !Only, if user set constrians is an $end written + write (funit,'(a)') '$end' + end if + close (funit) + +end subroutine write_constraint + +!==============================================================================! + +subroutine get_interaction_E(env,solu,solv,clus,iter,E_inter) + use iso_fortran_env,wp => real64 + use crest_data + use iomod + use qcg_coord_type + use strucrd + implicit none + + type(systemdata) :: env + type(coord_qcg),intent(in) :: solu,solv,clus + real(wp) :: e_cluster,e_solute,e_solvent + real(wp) :: E_inter(env%nsolv) ! interaction energy + integer :: iter + logical :: e_there + + call remove('cluster.coord') + +!--- Prepare input coordinate files + call clus%write('cluster.coord') + call wr_cluster_cut('cluster.coord',solu%nat,solv%nat,iter,'solute_cut.coord','solvent_cut.coord') + +!--- Perform single point calculations and recieve energies + call xtb_sp_qcg(env,'solute_cut.coord',e_there,e_solute) + if (.not.e_there) write (stdout,*) 'Solute energy not found' + + call xtb_sp_qcg(env,'solvent_cut.coord',e_there,e_solvent) + if (.not.e_there) write (stdout,*) 'Solvent energy not found' + + call xtb_sp_qcg(env,'cluster.coord',e_there,e_cluster) + if (.not.e_there) write (stdout,*) 'Cluster energy not found' + + E_inter(iter) = e_cluster-e_solute-e_solvent + +end subroutine get_interaction_E + +!===============================================================================! +subroutine chdirdbug(path) + implicit none + character(len=*),intent(in) :: path + logical,parameter :: debug = .false. + character(len=500) :: debugpath + call chdir(path) + if (debug) then + call getcwd(debugpath) + write (*,'(a,a)') '>>>>>>> NOW IN ',trim(debugpath) + end if +end subroutine chdirdbug + +!===============================================================================! +subroutine qcg_envcalc_reinit(env,mol,addconstraints,printinfo) + use crest_parameters + use crest_data + use qcg_coord_type + use strucrd + use parse_xtbinput + implicit none + type(systemdata),intent(inout) :: env + type(coord),intent(inout) :: mol + logical,intent(in) :: addconstraints + logical,intent(in) :: printinfo + + !> clear old data + if (allocated(env%calc%calcs)) deallocate (env%calc%calcs) + env%calc%ncalculations = 0 + + !> and re-initialize + call env2calc(env,env%calc,mol) + + !> add constraints from 'cts' if we want this + if (addconstraints) then + if (allocated(env%calc%cons)) deallocate (env%calc%cons) + env%calc%nconstraints = 0 + if (printinfo) then + write (stdout,'(a,a,a)') 'Parsing xtb-type constraints from internal backup to set up calculators ...' + end if + call parse_constraints_from_cts(env%calc,mol,env%cts) + end if + + !> do a printout to stdout, if selected + if (printinfo) then + call env%calc%info(stdout) + end if + +end subroutine qcg_envcalc_reinit + diff --git a/src/qcg/qcg_printouts.f90 b/src/qcg/qcg_printouts.f90 new file mode 100644 index 00000000..e13dbf71 --- /dev/null +++ b/src/qcg/qcg_printouts.f90 @@ -0,0 +1,298 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2021-2025 Christoph Plett, Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module qcg_printouts + use crest_parameters,only:stdout,wp + + use crest_data + use iomod + implicit none + public + +contains + + subroutine qcg_head() + implicit none + write (stdout,*) + write (stdout,'(10x,''========================================'')') + write (stdout,'(10x,''| ---------------- |'')') + write (stdout,'(10x,''| Q C G |'')') + write (stdout,'(10x,''| ---------------- |'')') + write (stdout,'(10x,''| Quantum Cluster Growth |'')') + write (stdout,'(10x,''| University of Bonn, MCTC |'')') + write (stdout,'(10x,''========================================'')') + write (stdout,'(10x,'' S. Grimme, S. Spicher, C. Plett.'')') + write (stdout,*) + write (stdout,'(10x,''Cite work conducted with this code as:'')') + write (stdout,'(/,9x,''S. Spicher, C. Plett, P. Pracht, A. Hansen,'')') + write (stdout,'(9x,''S. Grimme, JCTC, 2022, 18, 3174-3189.'')') + write (stdout,*) + end subroutine qcg_head + + subroutine write_qcg_setup(env) + implicit none + type(systemdata) :: env + + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| quantum cluster growth: INPUT |'')') + write (stdout,'(2x,''========================================='')') + write (stdout,*) + select case (env%qcg_runtype) + case (0) + write (stdout,'(2x,''QCG: Only Cluster Generation'')') + case (1) + write (stdout,'(2x,''QCG: Cluster + Ensemble Generation'')') + if (env%ensemble_method .eq. 0) write (stdout,'(2x,''Ensemble generated via CREST'')') + if (env%ensemble_method .eq. 1) write (stdout,'(2x,''Ensemble generated via MD Simulation'')') + if (env%ensemble_method .eq. 2) write (stdout,'(2x,''Ensemble generated via MetaDynamic'')') + case (2) + write (stdout,'(2x,''QCG: Calculation of delta E_solv'')') + if (env%ensemble_method .eq. 0) write (stdout,'(2x,''Ensemble generated via CREST'')') + if (env%ensemble_method .eq. 1) write (stdout,'(2x,''Ensemble generated via MD Simulation'')') + if (env%ensemble_method .eq. 2) write (stdout,'(2x,''Ensemble generated via MetaDynamic'')') + case (3) + write (stdout,'(2x,''QCG: Calculation of delta G_solv'')') + if (env%ensemble_method .eq. 0) write (stdout,'(2x,''Ensemble generated via CREST'')') + if (env%ensemble_method .eq. 1) write (stdout,'(2x,''Ensemble generated via MD Simulation'')') + if (env%ensemble_method .eq. 2) write (stdout,'(2x,''Ensemble generated via MetaDynamic'')') + case default + continue + end select + write (stdout,*) + write (stdout,'(2x,''input parameters '')') + write (stdout,'(2x,''solute : '',a)') trim(env%solu_file) + write (stdout,'(2x,''charge : '',i0)') env%chrg + write (stdout,'(2x,''uhf : '',i0)') env%uhf + write (stdout,'(2x,''solvent : '',a)') trim(env%solv_file) + if (env%nsolv .ne. 0) then + write (stdout,'(2x,''# of solvents to add : '',i0)') env%nsolv + else if (env%nsolv .eq. 0) then + write (stdout,'(2x,''# of solvents to add : until convergence, but maximal'',1x,i4)') env%max_solv + end if + if (env%nqcgclust .ne. 0) then + write (stdout,'(2x,''# of cluster generated : '',i0)') env%nqcgclust + else + write (stdout,'(2x,''Cluster generated that are above 10 % populated '')') + end if + + write (stdout,'(2x,''# of CPUs used : '',i0)') env%Threads + if (env%solvent .eq. '') then + write (stdout,'(2x,''No gbsa/alpb model'' )') + else + write (stdout,'(2x,''Solvation model : '',a)') env%solvent + end if + write (stdout,'(2x,''xtb opt level : '',a)') trim(optlevflag(env%optlev)) + write (stdout,'(2x,''System temperature [K] : '',F5.1)') env%tboltz + write (stdout,'(2x,''RRHO scaling factor : '',F4.2)') env%freq_scal + write (stdout,*) + + end subroutine write_qcg_setup + +!========================================================================================! +!========================================================================================! +!> QCG-printouts +!==============================================================================! +!========================================================================================! + + subroutine print_qcg_grow() + implicit none + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| quantum cluster growth: GROW |'')') + write (stdout,'(2x,''========================================='')') + write (stdout,*) + end subroutine print_qcg_grow + subroutine pr_qcg_fastgrow() + implicit none + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| quantum cluster growth: FASTGROW |'')') + write (stdout,'(2x,''========================================='')') + write (stdout,*) + end subroutine pr_qcg_fastgrow + subroutine print_qcg_ensemble() + implicit none + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| quantum cluster growth: ENSEMBLE |'')') + write (stdout,'(2x,''========================================='')') + write (stdout,*) + end subroutine print_qcg_ensemble + subroutine print_qcg_opt() + implicit none + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| quantum cluster growth: OPT |'')') + write (stdout,'(2x,''========================================='')') + write (stdout,*) + write (stdout,'(2x,''Very tight post optimization of lowest cluster'')') + end subroutine print_qcg_opt + subroutine pr_qcg_fill() + implicit none + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| quantum cluster growth: CFF |'')') + write (stdout,'(2x,''========================================='')') + write (stdout,*) + write (stdout,'(2x,''CUT-FREEZE-FILL Algorithm to generate reference solvent cluster'')') + end subroutine pr_qcg_fill + subroutine pr_qcg_freq() + implicit none + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| Frequency evaluation |'')') + write (stdout,'(2x,''========================================='')') + write (stdout,*) + end subroutine pr_qcg_freq + subroutine pr_eval_solute() + implicit none + write (stdout,*) + write (stdout,'(2x,''________________________________________________________________________'')') + write (stdout,*) + write (stdout,'(2x,''__________________ Solute Cluster Generation _____________________'')') + write (stdout,*) + write (stdout,'(2x,''________________________________________________________________________'')') + write (stdout,*) + end subroutine pr_eval_solute + subroutine pr_eval_solvent() + implicit none + write (stdout,*) + write (stdout,*) + write (stdout,'(2x,''________________________________________________________________________'')') + write (stdout,*) + write (stdout,'(2x,''_________________ Solvent Cluster Generation _____________________'')') + write (stdout,*) + write (stdout,'(2x,''________________________________________________________________________'')') + write (stdout,*) + end subroutine pr_eval_solvent + subroutine pr_eval_eval() + implicit none + write (stdout,*) + write (stdout,*) + write (stdout,'(2x,''________________________________________________________________________'')') + write (stdout,*) + write (stdout,'(2x,''_________________________ Evaluation ____________________________'')') + write (stdout,*) + write (stdout,'(2x,''________________________________________________________________________'')') + write (stdout,*) + write (stdout,*) + end subroutine pr_eval_eval + subroutine pr_freq_energy() + implicit none + write (stdout,'(2x,"# H(T) SVIB SROT STRA G(T)")') + write (stdout,'(2x," [kcal/mol] [ cal/mol/K ] [kcal/mol]")') + write (stdout,'(2x,"--------------------------------------------------------")') + end subroutine pr_freq_energy + subroutine pr_eval_1(G,H) + implicit none + real(wp),intent(in) :: G,H + write (stdout,'(2x,"-----------------------------------------------------")') + write (stdout,'(2x,"Gsolv and Hsolv ref. state: [1 M gas/solution] ")') + write (stdout,'(2x,"G_solv (incl.RRHO) =",F8.2," kcal/mol")') G + write (stdout,'(2x,"H_solv (incl.RRHO) =",F8.2," kcal/mol")') H + write (stdout,'(2x,"-----------------------------------------------------")') + write (stdout,*) + end subroutine pr_eval_1 + subroutine pr_eval_2(srange,G,scal) + implicit none +! Dummy + integer,intent(in) :: srange + real(wp),intent(in) :: G(srange) + real(wp),intent(in) :: scal(srange) +! Stack + integer :: i + write (stdout,'(2x,"-----------------------------------------------------")') + write (stdout,'(2x,"Solvation free energies with scaled translational")') + write (stdout,'(2x,"and rotational degrees of freedom: Gsolv (scaling)")') + do i = 1,srange + write (stdout,'(10x,">>",2x,f8.2," (",f4.2,")",4x,"<<")') G(i),scal(i) + end do + write (stdout,'(2x,"-----------------------------------------------------")') + end subroutine pr_eval_2 + subroutine pr_eval_3(srange,freqscal,scal,G) + implicit none +! Dummy + integer,intent(in) :: srange + integer,intent(in) :: freqscal + real(wp),intent(in) :: scal + real(wp),intent(in) :: G(srange) + write (stdout,*) + write (stdout,'(2x,"==================================================")') + write (stdout,'(2x,"| Gsolv with SCALED RRHO contributions: ",f4.2,4x"|")') scal + write (stdout,'(2x,"| [1 bar gas/ 1 M solution] |")') + write (stdout,'(2x,"| |")') + write (stdout,'(2x,"| G_solv (incl.RRHO)+dV(T)=",F8.2," kcal/mol |")') G(freqscal) + write (stdout,'(2x,"==================================================")') + write (stdout,*) + end subroutine pr_eval_3 + subroutine pr_fill_energy() + implicit none + write (stdout,'(x,'' Size'',2x,''Cluster '',2x,''E /Eh '',7x,''De/kcal'',3x,& + &''Detot/kcal'',2x,''Opt'',4x)') + end subroutine pr_fill_energy + subroutine pr_ensemble_energy() + implicit none + write (stdout,*) + write (stdout,'(x,'' Cluster'',3x,''E /Eh '',7x,& + &''Density'',2x,''Efix'',7x,''R av/act.'',1x,& + &''Surface'',3x,''Opt'',4x)') + end subroutine pr_ensemble_energy + subroutine pr_qcg_esolv() + implicit none + write (stdout,*) + write (stdout,'(2x,''========================================='')') + write (stdout,'(2x,''| quantum cluster growth: ESOLV |'')') + write (stdout,'(2x,''| |'')') + end subroutine pr_qcg_esolv + subroutine pr_grow_energy() + implicit none + write (stdout,'(x,'' Size'',7x,''E'',8x,''De'',7x,''Detot'',6x,& + &''Density'',5x,''Eatom'',4x,''av. R'', 1x,'' Rlast'',3x,& + &''Volume'',4x,''Opt'')') + write (stdout,'(12x,''[Eh]'',4x,''[kcal]'',5x,''[kcal]'',5x,& + &''[u/Å^3]'',5x,''[kcal]'',3x,''[bohr]'', 1x,''[bohr]'',1x,& + &''[bohr^3]'')') + + end subroutine pr_grow_energy + + subroutine pr_freq_file(ich) + implicit none + integer :: ich + write (ich,'(2x,"# H(T) SVIB SROT STRA G(T)")') + write (ich,'(2x," [kcal/mol] [ cal/mol/K ] [kcal/mol]")') + write (ich,'(2x,"--------------------------------------------------------")') + end subroutine pr_freq_file + +!========================================================================================! + + subroutine xtbiff_print_deprecated() + external creststop + write (stdout,*) + write (stdout,*) 'WARNING WARNING WARNING' + write (stdout,*) ' The use of xtbiff in QCG is deprecated and is disabled' + write (stdout,*) ' following CREST 3.0.3, in favor of the aISS algorithm.' + write (stdout,*) ' This requires a current version of the xtb program.' + write (stdout,*) + call creststop(status_safety) + end subroutine xtbiff_print_deprecated + +!========================================================================================! +!========================================================================================! +end module qcg_printouts diff --git a/src/qcg/qcg_utils.f90 b/src/qcg/qcg_utils.f90 new file mode 100644 index 00000000..fb453ba3 --- /dev/null +++ b/src/qcg/qcg_utils.f90 @@ -0,0 +1,774 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2021-2025 Christoph Plett, Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module qcg_utils + use crest_parameters,only:stdout,wp + use crest_data + use iomod + implicit none + public + +contains + +!========================================================================================! +!> Convert given QCG coordinate files into (TM format) +!> Write "solute" and "solvent" coordinate files +!========================================================================================! + subroutine inputcoords_qcg(env,solute,solvent) + use crest_parameters + use crest_data + use strucrd + use qcg_coord_type + use iomod + implicit none + + type(systemdata),intent(inout) :: env + type(coord_qcg),intent(out) :: solute,solvent + + logical :: ex11,ex21,solu,solv + type(coord_qcg) :: mol + integer :: i + +!--------------------Checking for input-------------! + + !Solute + inquire (file=env%solu_file,exist=ex11) + inquire (file='solute',exist=solu) + if (solu) call copy('solute','solute.old') !Backup solute file + if ((.not.ex11).and.(.not.solu)) then + error stop 'No (valid) solute file! exit.' + else if ((.not.ex11).and.(solu)) then + env%solu_file = 'solute' + end if + + !Solvent + inquire (file=env%solv_file,exist=ex21) + inquire (file='solvent',exist=solv) + if (solu) call copy('solvent','solvent.old') !Backup solvent file + if ((.not.ex21).and.(.not.solv)) then + error stop 'No (valid) solvent file! exit.' + else if ((.not.ex11).and.(solu)) then + env%solu_file = 'solvent' + end if + +!---------------Handling solute---------------------! + call mol%open(env%solu_file) + call mol%write('solute') + solute%nat = mol%nat + solute%at = mol%at + solute%xyz = mol%xyz + + !--- if the input was a SDF file, special handling + env%sdfformat = .false. + call checkcoordtype(env%solu_file,i) + if (i == 31.or.i == 32) then + !Add sdf stuff here, if somebody needs it + end if + !--- Add as ref structure in env + call env%ref%load(mol) + call mol%deallocate() +!---------------Handling solvent---------------------! + + call mol%open(env%solv_file) + call mol%write('solvent') + solvent%nat = mol%nat + solvent%at = mol%at + solvent%xyz = mol%xyz + call mol%deallocate() + + !--- if the input was a SDF file, special handling + env%sdfformat = .false. + call checkcoordtype(env%solv_file,i) + if (i == 31.or.i == 32) then + !Add sdf stuff here, if somebody needs it + end if + + return + end subroutine inputcoords_qcg + +!==============================================================================! + + subroutine write_reference(env,solu,clus) + use crest_data + use qcg_coord_type + use iomod + use strucrd + implicit none + type(systemdata):: env ! MAIN STORAGE OS SYSTEM DATA + type(coord_qcg) :: solu,clus + type(coord_qcg) :: ref_mol,ref_clus + ref_mol = solu + call rdcoord(env%solu_file,ref_mol%nat,ref_mol%at,ref_mol%xyz) !original solute coordinates + call remove(env%fixfile) + ref_clus = clus + ref_clus%xyz(1:3,1:solu%nat) = solu%xyz + call wrc0(env%fixfile,ref_clus%nat,ref_clus%at,ref_clus%xyz) + end subroutine write_reference + +!=============================================================================! + + subroutine aver(pr,env,runs,e_tot,S,H,G,sasa,a_present,a_tot) + use crest_parameters + use crest_data + + implicit none +!---- Dummy + type(systemdata),intent(in) :: env + integer,intent(in) :: runs + real(wp),intent(inout) :: e_tot + real(wp),intent(in),optional :: a_tot + real(wp),intent(out) :: S + real(wp),intent(out) :: H + real(wp),intent(out) :: G + real(wp),intent(out) :: sasa +!---- Stack + logical,intent(in) :: pr,a_present + integer :: j,jmin + real(wp) :: A + real(wp) :: e0 + real(wp),allocatable :: de(:) + real(wp),allocatable :: p(:) + real(wp) :: pmax + real(wp) :: eav + real(wp) :: area + real(wp) :: beta + real(wp) :: temp + integer :: ich48 + dimension e_tot(runs) + dimension a_tot(runs) + + temp = env%tboltz + allocate (de(runs),source=0.0d0) + allocate (p(runs),source=0.0d0) + + beta = 1./(temp*8.314510/4.184/1000.+1.d-14) + e0 = e_tot(1) + de(1:runs) = (e_tot(1:runs)-e0) + call qcg_boltz(env,runs,de,p) + + A = 0 + eav = 0 + pmax = 0 + area = 0 + do j = 1,runs + A = A+p(j)*log(p(j)+1.d-12) + eav = eav+p(j)*e_tot(j) + if (p(j) .gt. pmax) then + pmax = p(j) + jmin = j + end if + if (a_present) area = area+p(j)*a_tot(j) + end do + sasa = area + S = (1./beta)*A + H = eav + G = eav+S + if (pr) then + open (newunit=ich48,file='population.dat') + write (ich48,'(2x, ''cluster'',2x,''E_norm [Eh]'',2x, ''De [kcal]'', 4x, ''p'')') + do j = 1,runs + if (j .lt. 10) then + write (ich48,'(5x,i0,3x,f11.6,5x,f6.4,3x,f6.4)') j,e_tot(j)/autokcal,de(j),p(j) + else + write (ich48,'(5x,i0,2x,f11.6,5x,f6.4,3x,f6.4)') j,e_tot(j)/autokcal,de(j),p(j) + end if + end do + write (ich48,*) + write (ich48,'(''Ensemble free energy [Eh]:'', f20.10)') G/autokcal + close (ich48) + end if + + deallocate (de,p) + + end subroutine aver + + !==============================================================================! + + subroutine get_sphere(pr,mol,r_logical) + use crest_parameters + use qcg_coord_type + use miscdata + implicit none + type(coord_qcg),intent(inout) :: mol + type(coord_qcg) :: dum + logical :: pr + logical :: r_logical !Determines wether r is overwritten or not + real(wp),parameter :: pi43 = pi*4.0d0/3.0d0 + real(wp),parameter :: third = 1.0d0/3.0d0 + integer :: i + real(wp) :: rad(mol%nat),xyz_tmp(3,mol%nat) + external get_volume + + do i = 1,mol%nat + rad(i) = bohr*rcov_qcg(mol%at(i))*1.40 ! scale factor adjusted to rough + xyz_tmp(1:3,i) = bohr*mol%xyz(1:3,i) + end do + + dum = mol + dum%xyz = xyz_tmp + + call get_volume(dum,rad) + + mol%atot = dum%atot/bohr**2 + mol%vtot = dum%vtot/bohr**3 + + if (r_logical) then + mol%rtot = mol%vtot*3.0/4.d0/pi + mol%rtot = mol%rtot**(1.d0/3.d0) + end if + + if (pr) then + if (r_logical) then + write (stdout,'(2x,''molecular radius (Bohr**1):'',F8.2)') mol%rtot + end if + write (stdout,'(2x,''molecular area (Bohr**2):'',F8.2)') mol%atot + write (stdout,'(2x,''molecular volume (Bohr**3):'',F8.2)') mol%vtot + end if + end subroutine get_sphere + + !=============================================================================! + ! + subroutine cma_shifting(solu,solv) + use crest_parameters + use crest_data + use iomod + use qcg_coord_type + use strucrd + use axis_module,only:cma + implicit none + + type(coord_qcg) :: solu,solv + + integer :: i + + call cma(solu%nat,solu%at,solu%xyz,solu%cma) + call cma(solv%nat,solv%at,solv%xyz,solv%cma) + + do i = 1,solu%nat + solu%xyz(1:3,i) = solu%xyz(1:3,i)-solu%cma(1:3) + end do + do i = 1,solv%nat + solv%xyz(1:3,i) = solv%xyz(1:3,i)-solv%cma(1:3) + end do + + end subroutine cma_shifting + +!==============================================================================! +! + subroutine get_ellipsoid(env,solu,solv,clus,pr1) + use crest_parameters + use crest_data + use iomod + use qcg_coord_type + use strucrd + use axis_module + implicit none + + type(systemdata) :: env + type(coord_qcg) :: solu,solv,clus + type(coord_qcg) :: dummy_solu,dummy_solv + real(wp) :: rabc_solu(3),rabc_solv(3) + real(wp) :: aniso,sola + real(wp) :: rmax_solu,rmax_solv + real(wp) :: boxr,roff,r + character(len=10) :: fname + logical :: ex,pr,pr1 + + real(wp),parameter :: pi43 = pi*4.0d0/3.0d0 + real(wp),parameter :: third = 1.0d0/3.0d0 + + pr = .false. !Outprint deactivated + + fname = 'eaxis.qcg' + inquire (file=fname,exist=ex) + + if (pr1) then !First time called +!--- Moving all coords to the origin (transformation) + call axistrf(solu%nat,solu%nat,solu%at,solu%xyz) +! call axistrf(solv%nat,solv%nat,solv%at,solv%xyz) !Not done in original QCG code + call axistrf(clus%nat,solu%nat,clus%at,clus%xyz) + +!--- Overwrite solute and solvent coord in original file with transformed and optimized ones + call solu%write('solute') + call solv%write('solvent') + +!--- Getting axis + write (stdout,*) 'Solute:' + call axis(pr1,solu%nat,solu%at,solu%xyz,solu%eax) + write (stdout,*) 'Solvent:' + call axis(pr1,solv%nat,solv%at,solv%xyz,solv%eax) + write (stdout,*) + end if + +!--- Computing anisotropy factor of solute and solvent + sola = sqrt(1.+(solu%eax(1)-solu%eax(3))/((solu%eax(1)+solu%eax(2)+solu%eax(3))/3.)) + aniso = sqrt(1.+(solv%eax(1)-solv%eax(3))/((solv%eax(1)+solv%eax(2)+solv%eax(3))/3.)) ! =1 for a spherical system + +!--- Get maximum intramoleclar distance of solute and solvent + call getmaxrad(solu%nat,solu%at,solu%xyz,rmax_solu) + call getmaxrad(solv%nat,solv%at,solv%xyz,rmax_solv) + +!--- Getting V and A of dummies + dummy_solu = solu + dummy_solv = solv !Why is dummy_solv%vtot different to solv%vtot + call get_sphere(.false.,dummy_solu,.false.) + call get_sphere(.false.,dummy_solv,.false.) + +!--- Computation of outer Wall + roff = sola*dummy_solu%vtot/1000 + boxr = ((0.5*aniso*clus%nmol*dummy_solv%vtot+dummy_solu%vtot)/pi43)**third+roff+rmax_solv*0.5 !0.5 both + r = (boxr**3/(solu%eax(1)*solu%eax(2)*solu%eax(3)))**third ! volume of ellipsoid = volume of sphere + rabc_solv = solu%eax*r ! outer solvent wall + +!--- Computation of inner wall + roff = sola*dummy_solu%vtot/1000 + boxr = ((sola*dummy_solu%vtot)/pi43)**third+roff+rmax_solu*0.1 !0.1 before + r = (boxr**3/(solu%eax(1)*solu%eax(2)*solu%eax(3)))**third ! volume of ellipsoid = volume of sphere + rabc_solu = solu%eax*r + dummy_solu%ell_abc(1) = solu%eax(1)**2/sum((solu%eax(1:3))**2) + dummy_solu%ell_abc(2) = solu%eax(2)**2/sum((solu%eax(1:3))**2) + dummy_solu%ell_abc(3) = solu%eax(3)**2/sum((solu%eax(1:3))**2) + rabc_solu = dummy_solu%ell_abc*r + + solu%aniso = sola + solv%aniso = aniso + solu%ell_abc = rabc_solu + clus%ell_abc = rabc_solv*env%potscal + + if (pr1) then + write (stdout,'(2x,''solvent anisotropy :'',4f10.3)') aniso + write (stdout,'(2x,''solute anisotropy :'',4f10.3)') sola + write (stdout,'(2x,''roff inner wall :'',4f10.3)') roff + write (stdout,'(2x,''solute max dist :'',4f10.3)') rmax_solu + write (stdout,'(2x,''solvent max dist :'',4f10.3)') rmax_solv + write (stdout,'(2x,''inner unit axis :'',3f10.3)') dummy_solu%ell_abc(1:3) + write (stdout,'(2x,''inner ellipsoid/Bohr :'',3f10.3)') rabc_solu(1:3) + write (stdout,'(2x,''scaling factor outer ellipsoid:'',3f10.3)') env%potscal + write (stdout,'(2x,''outer ellipsoid/Bohr :'',3f10.3)') clus%ell_abc(1:3) + if (env%potscal .gt. 1.0_wp) write & + &(stdout,'(2x,''!!!WARNING: A SCALING FACTOR LARGER 1.0 IS ONLY RECOMMENDED FOR MICROSOLVATION'')') + write (stdout,*) + end if + + end subroutine get_ellipsoid + +!==============================================================================! + + subroutine getmaxrad(n,at,xyz,r) + use crest_parameters,only:wp + use miscdata,only:rcov_qcg + implicit none + real(wp) :: xyz(3,n),r + integer :: n,at(n) + real(wp) :: rx,ry,rz,rr + integer :: i,j + + r = 0 + do i = 1,n-1 + do j = i+1,n + rx = xyz(1,i)-xyz(1,j) + ry = xyz(2,i)-xyz(2,j) + rz = xyz(3,i)-xyz(3,j) + rr = sqrt(rx**2+ry**2+rz**2)+rcov_qcg(at(i))+rcov_qcg(at(j)) + if (rr .gt. r) r = rr + end do + end do + end subroutine getmaxrad + +!==============================================================================! + + subroutine ellipsout(fname,n,at,xyz,r1) + use crest_parameters + use strucrd,only:i2e + implicit none + + integer :: i + integer :: n,at(n) + real(wp) :: xyz(3,n),r1(3) + real(wp) :: x,y,z,f,rr + character(len=*) :: fname + integer :: ich11 + + open (newunit=ich11,file=fname) + write (ich11,'(a)') '$coord' + do i = 1,n + write (ich11,'(3F24.14,6x,a)') xyz(1,i),xyz(2,i),xyz(3,i),i2e(at(i)) + end do + do i = 1,500 + call random_number(x) + call random_number(f) + if (f .gt. 0.5) x = -x + call random_number(y) + call random_number(f) + if (f .gt. 0.5) y = -y + call random_number(z) + call random_number(f) + if (f .gt. 0.5) z = -z + rr = sqrt(x*x+y*y+z*z) + x = x*r1(1)/rr + y = y*r1(2)/rr + z = z*r1(3)/rr + write (ich11,'(3F24.14,6x,a2)') x,y,z,'he' + end do + write (ich11,'(a)') '$end' + close (ich11) + + end subroutine ellipsout + +!==============================================================================! + + subroutine both_ellipsout(fname,n,at,xyz,r1,r2) + use crest_parameters + use strucrd,only:i2e + implicit none + + integer :: i + integer :: n,at(n) + real(wp) :: xyz(3,n),r1(3) + real(wp),optional :: r2(3) + real(wp) :: x,y,z,f,rr + character(len=*) :: fname + integer :: ich11 + + open (newunit=ich11,file=fname) + write (ich11,'(a)') '$coord' + do i = 1,n + write (ich11,'(3F24.14,6x,a)') xyz(1,i),xyz(2,i),xyz(3,i),i2e(at(i)) + end do + do i = 1,500 + call random_number(x) + call random_number(f) + if (f .gt. 0.5) x = -x + call random_number(y) + call random_number(f) + if (f .gt. 0.5) y = -y + call random_number(z) + call random_number(f) + if (f .gt. 0.5) z = -z + rr = sqrt(x*x+y*y+z*z) + x = x*r1(1)/rr + y = y*r1(2)/rr + z = z*r1(3)/rr + write (ich11,'(3F24.14,6x,a2)') x,y,z,'he' + end do + if (present(r2)) then + do i = 1,100 + call random_number(x) + call random_number(f) + if (f .gt. 0.5) x = -x + call random_number(y) + call random_number(f) + if (f .gt. 0.5) y = -y + call random_number(z) + call random_number(f) + if (f .gt. 0.5) z = -z + rr = sqrt(x*x+y*y+z*z) + x = x*r2(1)/rr + y = y*r2(2)/rr + z = z*r2(3)/rr + write (ich11,'(3F24.14,6x,a2)') x,y,z,'b' + end do + end if + write (ich11,'(a)') '$end' + close (ich11) + + end subroutine both_ellipsout + +!==============================================================================! + + subroutine analyze_cluster(nsolv,n,nS,nM,xyz,at,av,last) + use crest_parameters + use axis_module,only:cma + implicit none + real(wp) xyz(3,n) + real(wp) av,last + integer n,nS,nM,nsolv,at(n) + real(wp) xyzM(3,nM) + integer atm(nM) + real(wp) xyzS(3,nS) + integer atS(nS) + real(wp) x1(3),x2(3),r + integer i,is,ie + + if (nsolv .eq. 1) return + xyzS(1:3,1:nS) = xyz(1:3,1:nS) + atS(1:nS) = at(1:nS) + call cma(nS,atS,xyzS,x1) + + av = 0 + do i = 1,nsolv + is = nS+(i-1)*nM+1 + ie = is+nM-1 + xyzM(1:3,1:nM) = xyz(1:3,is:ie) + atM(1:nM) = at(is:ie) + call cma(nM,atM,xyzM,x2) + r = sqrt((x1(1)-x2(1))**2+(x1(2)-x2(2))**2+(x1(3)-x2(3))**2) + if (i .lt. nsolv) then + av = av+r + else + last = r + end if + end do + av = av/real(nsolv-1,wp) + end subroutine analyze_cluster + +!==============================================================================! +! + subroutine qcg_boltz(env,n,e,p) + use crest_parameters + use crest_data + implicit none + type(systemdata),intent(in) :: env + integer,intent(in) :: n + real(wp),intent(in) :: e(:) + real(wp),intent(out) :: p(:) + integer :: i + real(wp) :: temp + real(wp) :: f,hsum,esum + + temp = env%tboltz + f = 8.314*temp/4.184d+3 + esum = 0 + do i = 1,n + esum = esum+exp(-e(i)/f) + end do + hsum = 0 + do i = 1,n + p(i) = exp(-e(i)/f)/esum + end do + end subroutine qcg_boltz + +!==============================================================================! + +!==============================================================================! + + subroutine fill_take(env,n2,n12,rabc,ipos) + use crest_parameters + use crest_data + use strucrd + use axis_module,only:cma + implicit none + + type(systemdata) :: env + integer,intent(in) :: n2,n12 + real(wp),intent(in) :: rabc(3) + integer,intent(out) :: ipos + integer :: i,m,n21 + integer :: at2(n2),at12(n12) + integer :: counter + real(wp) :: xyz2(3,n2),xyz12(3,n12) + real(wp) :: etmp(100) + real(wp) :: eabc + real(wp) :: cma2(3) + real(wp),allocatable :: dist(:) + + eabc = 0 + counter = 0 + n21 = n12-n2+1 + if (env%use_xtbiff) then + call rdxtbiffE('xtbscreen.xyz',m,n12,etmp) + else + call rdxtbiffE('best.xyz',m,n12,etmp) + end if + + allocate (dist(m),source=0.0d0) + dist = 0.0d0 + + do i = 1,m + if (env%use_xtbiff) then + call rdxmolselec('xtbscreen.xyz',i,n12,at12,xyz12) + else + call rdxmolselec('final_structures.xyz',i,n12,at12,xyz12) + end if + + at2(1:n2) = at12(n21:n12) + xyz2(1:3,1:n2) = xyz12(1:3,n21:n12) + call cma(n2,at2,xyz2,cma2) + call calc_dist(cma2,rabc,dist(i),eabc) + if (eabc .gt. 1.0d0) then + dist(i) = 1.0d42 + counter = counter+1 + end if + end do + + ipos = minloc(dist(1:m),dim=1) + + if (counter .eq. m) ipos = 0 + + deallocate (dist) + end subroutine fill_take + +!==============================================================================! + + subroutine calc_dist(xyz,rabc,dist,eabc) + use crest_parameters + implicit none + + real(wp),intent(in) :: xyz(3) + real(wp),intent(in) :: rabc(3) + real(wp),intent(out) :: dist + real(wp),intent(out) :: eabc + real(wp) :: center(3),rc(3) + + center = 0.d0 + rc = (xyz(1:3)-center) + dist = norm2(rc) + eabc = sum((xyz(1:3)**2)/(rabc(1:3)**2)) + end subroutine calc_dist + +!==============================================================================! + + subroutine sort_min(i,j,col,A) + use crest_parameters + implicit none + integer,intent(in) :: i,j,col + real*8,intent(inout) :: A(i,j) + real*8 :: buf(j) + integer :: nsize,irow,krow + nsize = i + + do irow = 1,nsize + krow = minloc(A(irow:nsize,col),dim=1)+irow-1 + buf(:) = A(irow,:) + A(irow,:) = A(krow,:) + A(krow,:) = buf(:) + end do + end subroutine sort_min + +!==============================================================================! + + subroutine qcg_dump_sorted_ensemble(ens,e_ens,fname) + use crest_parameters + use crest_data + use strucrd + implicit none + type(ensemble),intent(in) :: ens + real(wp),intent(in) :: e_ens(ens%nall) + real(wp),allocatable :: dum(:) + character(len=*) :: fname + integer :: ich,i,e_min + allocate(dum(ens%nall)) + dum(:) = e_ens(:) + open (newunit=ich,file=fname) + do i = 1,ens%nall + e_min = minloc(dum,dim=1) + call wrxyz(ich,ens%nat,ens%at,ens%xyz(:,:,e_min),e_ens(e_min)) + dum(e_min) = huge(1.0_wp) + end do + close (ich) + deallocate(dum) + end subroutine qcg_dump_sorted_ensemble + +!==============================================================================! + + subroutine rdtherm(fname,ht,svib,srot,stra,gt) + use crest_parameters + use crest_data + use iomod + + implicit none +! Dummy + real(wp),intent(out) :: ht + real(wp),intent(out) :: gt + real(wp),intent(out) :: svib + real(wp),intent(out) :: srot + real(wp),intent(out) :: stra +! Stack + integer :: nn,io,counter,hg_line,ich + real(wp) :: xx(20) + logical :: ende + character(len=*) :: fname + character(len=128) :: a + + ende = .false. + counter = 0 + hg_line = 0 + + open (newunit=ich,file=fname) + do while (.not.ende) + read (ich,'(a)',iostat=io) a + if (io .lt. 0) then + ende = .true. + cycle + end if + if (index(a,'G(T)/Eh ') .ne. 0) then + hg_line = counter + end if + if (index(a,' VIB ') .ne. 0) then + call readl(a,xx,nn) + svib = xx(5) + if (svib .eq. 0.0d0) then + call readl(a,xx,nn) + svib = xx(4) + end if + end if + if (index(a,' ROT ') .ne. 0) then + call readl(a,xx,nn) + srot = xx(4) + end if + if (index(a,' TR ') .ne. 0) then + call readl(a,xx,nn) + stra = xx(4) + end if + if (counter .eq. hg_line+2) then + call readl(a,xx,nn) + ht = xx(3)*autokcal + gt = xx(5)*autokcal + end if + counter = counter+1 + end do + close (ich) + end subroutine rdtherm + +!============================================================! +! Read the Energies from a xtbiff output +!============================================================! + + subroutine rdxtbiffE(fname,m,n,e) + use crest_parameters + implicit none + integer :: m,n + character(len=*),intent(in) :: fname + real(wp) :: e(:) + + character(len=128) :: line + real(wp) :: xx(10) + integer :: ich,i,j,nn + + open (newunit=ich,file=fname) + + j = 1 +10 continue + read (ich,'(a)',end=999) line + read (ich,'(a)') line + call readl(line,xx,nn) + e(j) = xx(1) + do i = 1,n + read (ich,'(a)') line + end do + j = j+1 + goto 10 + +999 close (ich) + m = j-1 + end subroutine rdxtbiffE + +!==============================================================================! +!==============================================================================! +end module qcg_utils diff --git a/src/qcg/solvtool.f90 b/src/qcg/solvtool.f90 deleted file mode 100644 index 575e093c..00000000 --- a/src/qcg/solvtool.f90 +++ /dev/null @@ -1,3389 +0,0 @@ -!================================================================================! -! This file is part of crest. -! -! Copyright (C) 2023 Christoph Plett, Sebastian Spicher, Philipp Pracht -! -! crest is free software: you can redistribute it and/or modify it under -! the terms of the GNU Lesser General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! crest is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public License -! along with crest. If not, see . -!================================================================================! -!===================================================================! -! This file contains routines related to QCG and microsolvation -!===================================================================! -!======================================================! -! main routine -!======================================================! -subroutine crest_solvtool(env, tim) - use iso_fortran_env, wp => real64 - use crest_data - use iomod - use zdata - use strucrd - implicit none - - type(systemdata):: env ! MAIN STORAGE OS SYSTEM DATA - type(timer):: tim - !> Information about solvent, solute and cluster - type(zmolecule) :: solute, solvent, cluster, cluster_backup - type(ensemble) :: full_ensemble, solvent_ensemble - - integer :: progress,io - character(len=512) :: thispath - - real(wp), parameter :: eh = 627.509541d0 - -!--- Molecule settings - solute%nmol = 1 - solvent%nmol = 1 - cluster%nmol = 1 - - progress = 0 - call getcwd(thispath) - - !>----------------------------------- - call qcg_head() - !>----------------------------------- - -!> Check, if xtb is present - call checkprog_silent(env%ProgName,.true.,iostat=io) - if(io /= 0 ) error stop 'No xtb found' - -!> Check, if xtbiff is present (if it is required) - if (env%use_xtbiff) then - call checkprog_silent(env%ProgIFF,.true.,iostat=io) - if(io /= 0 ) error stop 'No xtbiff found' - else - write (*, *) - write (*, *) ' The use of the aISS algorithm is requested (recommend).' - write (*, *) ' This requires xtb version 6.6.0 or newer.' - write (*, *) ' xTB-IFF can still be used with the --xtbiff flag.' - write (*, *) - end if - -!------------------------------------------------------------------------------ -! Setup -!------------------------------------------------------------------------------ - - call write_qcg_setup(env) !Just an outprint of setup - call read_qcg_input(env, solute, solvent) !Reading mol. data and determining r,V,A - call qcg_setup(env, solute, solvent) - call qcg_restart(env, progress, solute, solvent, cluster, full_ensemble,& - & solvent_ensemble, cluster_backup) - -!----------------------------------------------------------------------------- -! Grow -!----------------------------------------------------------------------------- - if (progress .le. env%qcg_runtype .and. progress .eq. 0) then - cluster = solute - call qcg_grow(env, solute, solvent, cluster, tim) - if (.not. env%cff) then - allocate (cluster_backup%at(cluster%nat)) - allocate (cluster_backup%xyz(3, cluster%nat)) - cluster_backup = cluster - end if - progress = progress + 1 - call chdir(thispath) - end if - -!------------------------------------------------------------------------------ -! Ensemble search -!------------------------------------------------------------------------------ - if (progress .le. env%qcg_runtype .and. progress .eq. 1) then - call print_qcg_ensemble() - call qcg_ensemble(env, solute, solvent, cluster, full_ensemble, tim, 'ensemble') - progress = progress + 1 - call chdir(thispath) - end if - -!------------------------------------------------------------------------------ -! Solvent cluster generation -!------------------------------------------------------------------------------ - if (progress .le. env%qcg_runtype .and. progress .eq. 2) then !esolv - call pr_eval_solvent() - if (env%cff) then !CFF - call qcg_cff(env, solute, solvent, cluster, full_ensemble,& - & solvent_ensemble, tim) - else !Normal ensemble generation - call print_qcg_ensemble() - call cluster%deallocate - allocate (cluster%at(cluster_backup%nat)) - allocate (cluster%xyz(3, cluster_backup%nat)) - cluster = cluster_backup - deallocate (cluster_backup%at) - deallocate (cluster_backup%xyz) - env%solv_md = .true. - call qcg_ensemble(env, solute, solvent, cluster, solvent_ensemble,& - & tim, 'solvent_ensemble') - end if - call pr_qcg_esolv() - write (*, '(2x,"|",9x,F8.2," kcal/mol ",12x,"|")') & - & full_ensemble%g - solvent_ensemble%g - (solute%energy*eh) - write (*, '(2x,''========================================='')') - call chdir(thispath) - progress = progress + 1 - end if - -!------------------------------------------------------------------------------ -! Frequency computation and evaluation -!------------------------------------------------------------------------------ - if (progress .le. env%qcg_runtype .and. progress .eq. 3) then !gsolv - call qcg_freq(env, tim, solute, solvent, full_ensemble, solvent_ensemble) - call qcg_eval(env, solute, full_ensemble, solvent_ensemble) - - progress = progress + 1 - end if - - !<---------------------------------- -! call tim%stop(2) !stop a timer - -!------------------------------------------------------------------------------ -! Cleanup and deallocation -!------------------------------------------------------------------------------ - if (env%scratchdir .ne. 'qcg_tmp') call qcg_cleanup(env) - if (.not. env%keepModef) call rmrf('qcg_tmp') - call solute%deallocate - call solvent%deallocate - call cluster%deallocate - call full_ensemble%deallocate - call solvent_ensemble%deallocate - return -end subroutine crest_solvtool - -subroutine qcg_setup(env, solu, solv) - use iso_fortran_env, wp => real64 - use crest_data - use iomod - use zdata - use strucrd - use axis_module - implicit none - - type(systemdata):: env - type(zmolecule) :: solv, solu - - integer :: io, f, r - integer :: num_O, num_H, i - character(len=*), parameter :: outfmt = '(1x,1x,a,1x,f14.7,a,1x)' - logical :: e_there, tmp, used_tmp - character(len=512) :: thispath, tmp_grow - character(len=40) :: solv_tmp - character(len=80) :: atmp - character(len=20) :: gfnver_tmp - - call getcwd(thispath) - - ! Remove scratch dir, if present - inquire (file='./qcg_tmp/solute_properties/solute', exist=tmp) - if (tmp) call rmrf('qcg_tmp') !User given scratch dir will be removed anyway after run - - ! Make scratch directories - if (env%scratchdir .eq. '') then !check if scratch was not set - env%scratchdir = 'qcg_tmp' - io = makedir('qcg_tmp') - end if - if(env%fixfile /= 'none selected') then - call copysub(env%fixfile, env%scratchdir) - end if - call chdir(env%scratchdir) - - f = makedir('solute_properties') - if(env%fixfile /= 'none selected') then - call copysub(env%fixfile, env%scratchdir) - end if - r = makedir('solvent_properties') - - if (.not. env%nopreopt) then - write (*, *) - write (*, '(2x,''========================================='')') - write (*, '(2x,''| Preoptimization |'')') - write (*, '(2x,''========================================='')') - end if - - solv_tmp = env%solv - env%solv = '' - -!---- Properties solute - call chdir('solute_properties') - call env%wrtCHRG('') !Write three lines in QCG mode, but xtb anyway only reads first one - -!---- Geometry preoptimization solute - if (env%final_gfn2_opt) then !If GFN2 final opt, solute also GFN2 optimized - gfnver_tmp = env%gfnver - env%gfnver = '--gfn2' - end if - - if ((.not. env%nopreopt) .and. (solu%nat /= 1)) then - call xtb_opt_qcg(env, solu, .true.) - end if - -!--- Axistrf - call axistrf(solu%nat, solu%nat, solu%at, solu%xyz) - call wrc0('solute', solu%nat, solu%at, solu%xyz) - -!---- LMO/SP-Computation solute - if (env%use_xtbiff) then - write (*, *) 'Generating LMOs for solute' - call xtb_lmo(env, 'solute') - else - call xtb_sp_qcg(env, 'solute') - end if - - if (env%final_gfn2_opt) then !If GFN2 final opt, solute also GFN2 optimized - env%gfnver = gfnver_tmp - end if - - call grepval('xtb.out', '| TOTAL ENERGY', e_there, solu%energy) - if (.not. e_there) then - write (*, *) 'Total Energy of solute not found' - else - write (*, outfmt) 'Total Energy of solute: ', solu%energy, ' Eh' - end if - - if (env%use_xtbiff) then - call rename('xtblmoinfo', 'solute.lmo') - end if - - call chdir(thispath) - -! No constraints for solvent possible - used_tmp = env%cts%used - env%cts%used = .false. - -!---- Properties solvent - call chdir(env%scratchdir) - call chdir('solvent_properties') - !No charges for solvent written. This is currently not possible - -!---- Geometry preoptimization solvent - if ((.not. env%nopreopt) .and. (solv%nat /= 1)) then - call xtb_opt_qcg(env, solv, .false.) - end if - call wrc0('solvent', solv%nat, solv%at, solv%xyz) - -!---- LMO-Computation solvent - if (env%use_xtbiff) then - write (*, *) 'Generating LMOs for solvent' - call xtb_lmo(env, 'solvent')!,solv%chrg) - else - call xtb_sp_qcg(env, 'solvent') - end if - - call grepval('xtb.out', '| TOTAL ENERGY', e_there, solv%energy) - if (.not. e_there) then - write (*, '(1x,a)') 'Total Energy of solvent not found' - else - write (*, outfmt) 'Total energy of solvent:', solv%energy, ' Eh' - end if - - if (env%use_xtbiff) then - call rename('xtblmoinfo', 'solvent.lmo') - end if - - call chdir(thispath) - -!---- Overwriting solute and solvent in original folder - call wrc0('solute', solu%nat, solu%at, solu%xyz) - call wrc0('solvent', solv%nat, solv%at, solv%xyz) - - num_O = 0 - num_H = 0 -!--- Check, if water is solvent - if (solv%nat .eq. 3) then - do i = 1, solv%nat - if (solv%at(i) .eq. 8) num_O = num_O + 1 - if (solv%at(i) .eq. 1) num_H = num_H + 1 - end do - end if - if (num_O .eq. 1 .AND. num_H .eq. 2) then - env%water = .true. - if (.not. env%noconst) env%constrain_solu = .true. - end if - - env%solv = solv_tmp - env%cts%used = used_tmp - -end subroutine qcg_setup - -subroutine read_qcg_input(env, solu, solv) - use iso_fortran_env, wp => real64 - use crest_data - use iomod - use zdata - use strucrd - use atmasses - implicit none - - type(systemdata) :: env - type(zmolecule), intent(inout) :: solu, solv - logical :: pr - real(wp), parameter :: amutokg = 1.66053886E-27 - real(wp), parameter :: third = 1.0d0/3.0d0 - integer :: i - real(wp) :: r_solu, r_solv - - pr = .true. - -!--- Read in solu and solv coordinates and make solute and solvent file in WD - call inputcoords_qcg(env, solu, solv) - -!--- CMA-Trafo - call cma_shifting(solu, solv) - -!--- Setting solute charge and uhf to input - solu%chrg = env%chrg - solu%uhf = env%uhf - -!--- Getting r, V, A - write (*, *) - write (*, *) 'Solute geometry' - call get_sphere(.true., solu, .true.) !r,V,A of solute - write (*, *) 'Solvent geometry' - call get_sphere(.true., solv, .true.) !r,V,A of solvent - - r_solu = solu%vtot**third - r_solv = solv%vtot**third - write (*, *) - write (*, '(2x,''radius of solute : '',f8.2)') r_solu - write (*, '(2x,''radius of solvent : '',f8.2)') r_solv - -!--- Determine masses (for later density computation) - do i = 1, solu%nat - solu%mass = solu%mass + ams(solu%at(i)) - end do - do i = 1, solv%nat - solv%mass = solv%mass + ams(solv%at(i)) - end do - solu%mass = solu%mass*amutokg - solv%mass = solv%mass*amutokg - -!--- If directed docking is requested, it is read in here: - if(allocated(env%directed_file)) then - if (env%use_xtbiff) error stop 'xTB-IFF does not support directed docking. & - &Please use the aISS algorithm of xtb.' - call read_directed_input(env) - end if - -end subroutine read_qcg_input - -!> Read input for directed docking -subroutine read_directed_input(env) - use iso_fortran_env, wp => real64 - use crest_data - implicit none - - type(systemdata) :: env - - integer :: nlines - integer :: io, ich, i, i_check - integer :: index - character(len=512) :: dum - character(len=1), parameter :: delim_space = ' ', delim_tab = achar(9) - - open (newunit=ich, file=env%directed_file) - !First check number of lines - nlines = 0 - do - read(ich,*,iostat=io) - if (io /= 0) exit - nlines = nlines + 1 - end do - !Allocate directed list - !First entry is the atom number, Second how many solvents to add to this atom - allocate(env%directed_list(nlines,2)) - allocate(env%directed_number(nlines), source = 0) - !Now read lines into directed_list - rewind(ich) - do i=1, nlines - read(ich,'(A)') dum - !> Remove leading tab and spaces first - dum = adjustl(dum) !Leading spaces are removed - index = SCAN(trim(dum), delim_tab) - if (index == 1) then !Leading tab -> remove it - dum = dum(2:) - end if - index = SCAN(trim(dum), delim_space) - if (index == 0) then !No space = check for tab - index = SCAN(trim(dum), delim_tab) - end if - if (index == 0) then !Second value is missing - write(*,'(a,1x,i0)') "No second value found in directed list on line", i - error stop - end if - env%directed_list(i, 1) = dum(1:index-1) - env%directed_list(i, 2) = dum(index+1:) - !Remove multiple spaces - env%directed_list(i, 2) = adjustl(env%directed_list(i, 2)) - !Check, if spaces are still in second argument (e.g. a third number is giveb) - index = SCAN(trim(env%directed_list(i, 2)), delim_space) - if (index == 0) index = SCAN(trim(dum), delim_tab) - if (index /= 0) then - write(*,'(a,1x,i0)') "Too many values at line", i - error stop - end if - !> Make array with which solvent molecule at which atom to add - read(env%directed_list(i,2), *, iostat=io) env%directed_number(i) - env%directed_number(i) = sum(env%directed_number) - if (io/= 0) then - write(*,'(a,1x,i0)') "Second value is no number in line", i - error stop - end if - end do - close(ich) - write(*,*) 'Performing directed docking' - do i=1, nlines - write(*,'(a,1x,a,1x,a,1x,a)') 'Docking', trim(env%directed_list(i,2)),& - & 'solvent molecules at', trim(env%directed_list(i,1)) - end do - -end subroutine read_directed_input - - -subroutine qcg_grow(env, solu, solv, clus, tim) - use crest_parameters - use crest_data - use iomod - use zdata - use strucrd - implicit none - - type(systemdata) :: env - type(zmolecule) :: solu, solv, clus - type(timer) :: tim - - integer :: minE_pos, m - integer :: iter = 1 - integer :: i, j, io, v - integer :: max_cycle - logical :: e_there, high_e, success, neg_E - real(wp) :: etmp(500) - real(wp), allocatable :: e_each_cycle(:) - real(wp) :: dens, dum, efix - real(wp) :: e_diff = 0.0_wp - real(wp), parameter :: eh = 627.509541d0 - real(wp), allocatable :: E_inter(:) - real(wp) :: shr = 0.0_wp - real(wp) :: shr_av = 0.0_wp - real(wp) :: mean = 0.0_wp - real(wp) :: mean_old = 0.0_wp - real(wp) :: mean_diff = 0.0_wp - character(len=*), parameter :: outfmt = '(1x,1x,a,1x,f14.7,a,1x)' - character(len=512) :: thispath, resultspath - character(len=20) :: gfnver_tmp - integer :: ich99, ich15, ich88 - character(len=LEN(env%solv)) :: solv_tmp - logical :: gbsa_tmp - - interface - subroutine both_ellipsout(fname, n, at, xyz, r1, r2) - use iso_fortran_env, only: wp => real64 - use strucrd, only: i2e - implicit none - - integer :: i, j - integer :: n, at(n) - real(wp) :: dum(3) - real(wp) :: rx, ry, rz - real(wp) :: xyz(3, n), r1(3) - real(wp), optional :: r2(3) - real :: x, y, z, f, rr - character(len=*) :: fname - integer :: ich11 - end subroutine both_ellipsout - end interface - - if (env%nsolv .gt. 0) then - allocate (e_each_cycle(env%nsolv)) - allocate (E_inter(env%nsolv)) - else - allocate (e_each_cycle(env%max_solv)) - allocate (E_inter(env%max_solv)) - end if - - call tim%start(5, 'Grow') - - call pr_eval_solute() - call print_qcg_grow() - call getcwd(thispath) - io = makedir('grow') - call chdir('grow') !Results directory - -!--- Output Files - open (newunit=ich99, file='qcg_energy.dat') - write (ich99, '(i0,2F20.8)') 0, solu%energy, solv%energy - open (newunit=ich15, file='qcg_grow.xyz') ! for molden movie - open (newunit=ich88, file='qcg_conv.dat') ! for convergence check - write (ich88, '('' # Energy Run. Aver. Diff / au.'')') - - call getcwd(resultspath) - call chdir(thispath) - - if (env%water) then - if (.not. env%user_wscal) then - if (solu%nat .lt. 18) then - env%potscal = 0.7_wp - else - env%potscal = 0.8_wp - end if - write (*, *) - write (*, '(2x,''Water as solvent recognized,& - & adjusting scaling factor for outer wall pot to '',F4.2)')& - & env%potscal - write (*, *) - end if - end if - if (env%constrain_solu) write (*, '(2x,''Constraining solute during Growth '')') - - call get_ellipsoid(env, solu, solv, clus, .true.) - call pr_grow_energy() - - call chdir(env%scratchdir) - v = makedir('tmp_grow') - if(env%fixfile /= 'none selected') then - call copysub(env%fixfile, 'tmp_grow') - end if - if (env%use_xtbiff) then - call copy('solute_properties/solute.lmo', 'tmp_grow/solute.lmo') - call copy('solvent_properties/solvent.lmo', 'tmp_grow/solvent.lmo') - end if - call chdir('tmp_grow') - call wrc0('solute', solu%nat, solu%at, solu%xyz) - call wrc0('solvent', solv%nat, solv%at, solv%xyz) - call env%wrtCHRG('') !Write .CHRG file for docking - - call ellipsout('solute_cavity.coord', clus%nat, clus%at, clus%xyz, solu%ell_abc) - solv%ell_abc = clus%ell_abc - - clus%chrg = solu%chrg - clus%uhf = solu%uhf - - if (env%nsolv .gt. 0) then - max_cycle = env%nsolv !User set number of solvents to add - else - max_cycle = env%max_solv !No solvent number set - end if - -!-------------------------------------------------------- -! Start Loop -!-------------------------------------------------------- - do iter = 1, max_cycle - e_there = .false. - success = .false. - high_e = .false. - neg_E = .false. -!---- LMO-Computation - if (iter .gt. 1) then - call get_ellipsoid(env, solu, solv, clus, .false.) - if (env%use_xtbiff) then - call xtb_lmo(env, 'xtbopt.coord')!,clus%chrg) - call grepval('xtb.out', '| TOTAL ENERGY', e_there, clus%energy) - if (.not. e_there) then - write (*, '(1x,a)') 'Total Energy of cluster LMO computation not found' - end if - call rename('xtblmoinfo', 'cluster.lmo') - end if - end if - - call both_ellipsout('twopot_1.coord', clus%nat, clus%at, clus%xyz,& - & clus%ell_abc, solu%ell_abc) - - do while (.not. success) !For restart with larger wall pot - if (iter .eq. 1) then - if (env%use_xtbiff) then - call xtb_iff(env, 'solute.lmo', 'solvent.lmo', solu, solv) - !solu for nat of core pot. solv for outer ellips - call check_iff(neg_E) - else - call xtb_dock(env, 'solute', 'solvent', solu, solv) - call check_dock(neg_E) - end if - -!-- If Interaction Energy is not negativ and existent, wall pot. too small and increase - if (neg_E) then - success = .true. - else - if (env%potscal .lt. 1.0_wp) then - write (*, *) ' Wall Potential too small, increasing size by 5 %' - solv%ell_abc = solv%ell_abc*1.05_wp - env%potscal = env%potscal*1.05_wp - if (env%potscal .gt. 1.0_wp) env%potscal = 1.0_wp - write (*, '('' New scaling factor '',F4.2)') env%potscal - else - success = .true. - end if - end if - else - if (env%use_xtbiff) then - call xtb_iff(env, 'cluster.lmo', 'solvent.lmo', solu, clus) - call check_iff(neg_E) - else - call xtb_dock(env, 'cluster.coord', 'solvent', solu, clus) - call check_dock(neg_E) - end if - - if (neg_E) then - success = .true. - else - if (env%potscal .lt. 1.0_wp) then - write (*, *) ' Wall Potential too small, increasing size by 5 %' - clus%ell_abc = clus%ell_abc*1.05_wp - env%potscal = env%potscal*1.05_wp - if (env%potscal .gt. 1.0_wp) env%potscal = 1.0_wp - write (*, '('' New scaling factor '',F4.2)') env%potscal - else - success = .true. - end if - end if - end if - end do - -!--- Increase cluster size - call clus%deallocate - clus%nat = clus%nat + solv%nat - allocate (clus%at(clus%nat)) - allocate (clus%xyz(3, clus%nat)) - clus%nmol = clus%nmol + 1 - -!--- Select xtb-IFF stucture to proceed - if (env%use_xtbiff) then - call rdxtbiffE('xtbscreen.xyz', m, clus%nat, etmp) !Get energy of screening - minE_pos = minloc(etmp(1:m), dim=1) !Get minimum of those - !Read the struc into clus%xyz - call rdxmolselec('xtbscreen.xyz', minE_pos, clus%nat, clus%at, clus%xyz) - else - call rdcoord('best.xyz', clus%nat, clus%at, clus%xyz, clus%energy) - end if - - call remove('cluster.coord') - call wrc0('cluster.coord', clus%nat, clus%at, clus%xyz) - call both_ellipsout('twopot_2.coord', clus%nat, clus%at, clus%xyz,& - & clus%ell_abc, solu%ell_abc) - - success = .false. - -!--- Cluster restart, if interaction energy not negativ (wall pot. too small) - gfnver_tmp = env%gfnver !> backup original level of theory - do while (.not. success) -!--- Cluster optimization - if (env%cts%used) then - call write_reference(env, solu, clus) !new fixed file - end if - - if (env%use_xtbiff) then - call opt_cluster(env, solu, clus, 'cluster.coord', .false.) - call rdcoord('xtbopt.coord', clus%nat, clus%at, clus%xyz) - end if - -!--- Interaction energy - !gfnver_tmp = env%gfnver - env%gfnver = env%lmover - gbsa_tmp = env%gbsa - solv_tmp = env%solv - env%gbsa = .false. - env%solv = '' - call get_interaction_E(env, solu, solv, clus, iter, E_inter) - env%gbsa = gbsa_tmp - env%solv = solv_tmp - if (E_inter(iter) .lt. 0) then - success = .true. - else - if (env%potscal .lt. 1.0_wp) then - write (*, *) ' Interaction Energy positiv, increasing outer wall pot by 5 %' - clus%ell_abc = clus%ell_abc*1.05_wp - env%potscal = env%potscal*1.05_wp - if (env%potscal .gt. 1.0_wp) env%potscal = 1.0_wp - write (*, '('' New scaling factor '',F4.2)') env%potscal - else - success = .true. - end if - end if - end do - env%gfnver = gfnver_tmp - -!--- For output - if (env%use_xtbiff) then - call grepval('xtb.out', '| TOTAL ENERGY', e_there, clus%energy) - call wrc0('optimized_cluster.coord', clus%nat, clus%at, clus%xyz) - if (.not. e_there) then - write (*, '(1x,a)') 'Total Energy of cluster not found.' - end if - else - !Energy already read from xyz file - end if - e_each_cycle(iter) = clus%energy - -!--- Calclulate fix energy + diff. energy - efix = clus%energy/sqrt(float(clus%nat)) - dum = solu%energy - if (iter .gt. 1) dum = e_each_cycle(iter - 1) - e_diff = e_diff + eh*(e_each_cycle(iter) - solv%energy - dum) - call ellipsout('cluster_cavity.coord', clus%nat, clus%at, clus%xyz, clus%ell_abc) - call both_ellipsout('twopot_cavity.coord', clus%nat, clus%at, clus%xyz,& - & clus%ell_abc, solu%ell_abc) - -!--- Density calculations - call get_sphere(.false., clus, .false.) !V, A of new cluster - dens = 0.001*(solu%mass + iter*solv%mass)/(1.0d-30*clus%vtot*bohr**3) - -!--- Movie file - write (ich15, *) clus%nat - write (ich15, '('' SCF done '',2F16.8)') eh*(e_each_cycle(iter) - solv%energy - dum) - do j = 1, clus%nat - write (ich15, '(a,1x,3F24.10)') i2e(clus%at(j)), clus%xyz(1:3, j)*bohr - end do - -!--- Output - ! dist of new mol from solute for output - call analyze_cluster(iter, clus%nat, solu%nat, solv%nat, clus%xyz, clus%at, shr_av, shr) - - write (*, '(x,i4,F13.6,1x,f7.2,3x,f8.2,6x,f6.3,3x,f8.3,3x,2f6.1,2x,f8.1,3x,a,x)') & - & iter, e_each_cycle(iter), eh*(e_each_cycle(iter) - solv%energy - dum),& - & e_diff, dens, efix, shr_av, shr, clus%vtot, trim(optlevflag(env%optlev)) - write (ich99, '(i4,F20.10,3x,f8.1)') iter, e_each_cycle(iter), clus%vtot - -!--- Calculate moving average - mean_old = mean - do i = 0, iter - 1 - mean = mean + E_inter(iter - i) - end do - mean = mean/iter - mean_diff = mean - mean_old - write (ich88, '(i5,1x,3F13.8)') iter, E_inter(iter)*eh, mean, mean_diff - -!--- Check if converged when no nsolv was given - if (env%nsolv .eq. 0) then - if (abs(mean_diff) .lt. 1.0d-4 .and. iter .gt. 5) then - env%nsolv = iter - exit - end if - if (iter .eq. env%max_solv) then - write (*, '(1x,''No convergence could be reached upon adding'',1x,i4,1x,& - & ''solvent molecules.'')') env%max_solv - write (*, *) ' Proceeding.' - env%nsolv = env%max_solv - exit - end if - end if -!----------------------------------------------- -! End loop -!----------------------------------------------- - end do - - if (env%nsolv .eq. 0) env%nsolv = iter !if no env%solv was given - - if (env%gfnver .ne. '--gfn2' .and. env%final_gfn2_opt) then - gfnver_tmp = env%gfnver - env%gfnver = '--gfn2' - write (*, '(2x,''Final gfn2 optimization'')') - call opt_cluster(env, solu, clus, 'cluster.coord', .false.) - call rdcoord('xtbopt.coord', clus%nat, clus%at, clus%xyz) - call wrc0('cluster.coord', clus%nat, clus%at, clus%xyz) - call grepval('xtb_sp.out', '| TOTAL ENERGY', e_there, clus%energy) - if (.not. e_there) then - write (*, '(1x,a)') 'Total Energy of cluster not found.' - else - write (*, '(2x,''Total gfn2-energy of cluster/Eh:'',f20.6)') clus%energy - end if - env%gfnver = gfnver_tmp - end if - - call wrxyz('cluster.xyz', clus%nat, clus%at, clus%xyz*bohr) - -!--- One optimization without Wall Potential and with implicit model - gfnver_tmp = env%gfnver - if (env%final_gfn2_opt) env%gfnver = '--gfn2' - call opt_cluster(env, solu, clus, 'cluster.xyz', .true.) - env%gfnver = gfnver_tmp - call rename('xtbopt.xyz', 'cluster_optimized.xyz') - call copysub('cluster_optimized.xyz', resultspath) - -!--- output and files - write (*, *) - write (*, '(2x,''Growth finished after '',i0,'' solvents added'')') env%nsolv - write (*, '(2x,''Results can be found in grow directory'')') - write (*, '(2x,''Energy list in file '')') - write (*, '(2x,''Interaction energy in file '')') - write (*, '(2x,''Growing process in '')') - write (*, '(2x,''Final geometry after grow in and '')') - write (*, '(2x,''Final geometry optimized without wall potential in '')') - write (*, '(2x,''Potentials and geometry written in and '')') - - close (ich99) - close (ich88) - close (ich15) - -!--- Saving results and cleanup - call copysub('cluster.coord', resultspath) - call copysub('cluster.xyz', resultspath) - call copysub('twopot_cavity.coord', resultspath) - call copysub('cluster_cavity.coord', resultspath) - call copysub('solute_cavity.coord', resultspath) -! call rename('xcontrol','wall_potential') - env%constrain_solu = .false. - call write_wall(env, solu%nat, solu%ell_abc, clus%ell_abc, 'wall_potential') - call copysub('wall_potential', resultspath) - - call chdir(thispath) - call chdir(env%scratchdir) - if (.not. env%keepModef) call rmrf('tmp_grow') - - deallocate (e_each_cycle, E_inter) - - call tim%stop(5) - -end subroutine qcg_grow - -subroutine qcg_ensemble(env, solu, solv, clus, ens, tim, fname_results) - use crest_parameters - use crest_data - use iomod - use zdata - use strucrd - use utilities - use cregen_interface - implicit none - - type(systemdata) :: env - type(zmolecule) :: solu, solv, clus - type(ensemble) :: ens, dum - type(timer) :: tim - - integer :: i, j, k - integer :: io, f, r, ich,T,Tn - integer :: minpos - character(len=512) :: thispath, resultspath, tmppath, tmppath2 - character(len=512) :: scratchdir_tmp - character(len=512) :: jobcall - character(len=256) :: inpnam, outnam - character(len=80) :: fname, pipe, to - character(len=*) :: fname_results - character(len=64) :: comment - character(len=20) :: gfnver_tmp - character(len=LEN(env%solv)) :: solv_tmp - logical :: gbsa_tmp - logical :: ex, mdfail, e_there - logical :: checkiso_tmp, cbonds_tmp - real(wp), allocatable :: e_fix(:), e_clus(:) - real(wp), parameter :: eh = 627.509541d0 - real(wp) :: S, H, G, dens, shr, shr_av - real(wp) :: sasa - real(wp) :: newtemp, newmdtime, newmdstep, newhmass - real(wp) :: newmetadlist, newmetadexp, newmetadfac - real(wp) :: optlev_tmp - real(wp) :: e0 - real(wp), allocatable :: de(:) - real(wp), allocatable :: p(:) - integer :: ich98, ich65, ich48 - logical :: not_param = .false. - type(timer) :: tim_dum !Dummy timer to avoid double counting - - interface - subroutine aver(pr, env, runs, e_tot, S, H, G, sasa, a_present, a_tot) - use iso_fortran_env, only: wp => real64 - use crest_data - - implicit none - type(systemdata), intent(in) :: env - integer, intent(in) :: runs - real(wp), intent(inout) :: e_tot - real(wp), intent(in), optional :: a_tot - real(wp), intent(out) :: S - real(wp), intent(out) :: H - real(wp), intent(out) :: G - real(wp), intent(out) :: sasa - logical, intent(in) :: pr, a_present - dimension e_tot(runs) - dimension a_tot(runs) - end subroutine aver - end interface - - if (.not. env%solv_md) then - call tim%start(6, 'Solute-Ensemble') - else - call tim%start(7, 'Solvent-Ensemble') - end if - - call tim_dum%init(20) - -!--- Setting up directories - call getcwd(thispath) - f = makedir(fname_results) - call chdir(fname_results) - call getcwd(resultspath) - call chdir(thispath) - -!--- Setting defaults - env%cts%NCI = .true. !Activating to have wall pot. written in coord file for xtb - optlev_tmp = env%optlev - env%optlev = 0.0d0 - gbsa_tmp = env%gbsa - solv_tmp = env%solv - env%gbsa = .false. - env%solv = '' - -!--- Setting up potential constraints - allocate (env%cts%pots(10)) - env%cts%pots = '' - write (env%cts%pots(1), '("$wall")') - write (env%cts%pots(2), '(2x,"potential=polynomial")') - write (env%cts%pots(3), '(2x,"ellipsoid:",1x,3(g0,",",1x),"all")') clus%ell_abc - if (.not. env%solv_md) write (env%cts%pots(4), '(2x,"ellipsoid:",1x,3(g0,",",1x),"1-",i0)')& - & solu%ell_abc, solu%nat - - if (env%cts%used) then - call write_reference(env, solu, clus) !new fixed file - call copysub(env%fixfile, env%scratchdir) - end if - - call chdir(env%scratchdir) - scratchdir_tmp = env%scratchdir - if (.not. env%solv_md) then - io = makedir('tmp_MTD') - call copysub('.CHRG', 'tmp_MTD') - call copysub('.UHF', 'tmp_MTD') - if (env%cts%used) call copysub(env%fixfile, 'tmp_MTD') - call chdir('tmp_MTD') - else - io = makedir('tmp_solv_MTD') - call chdir('tmp_solv_MTD') - end if - call getcwd(tmppath2) - call wrc0('crest_input', clus%nat, clus%at, clus%xyz) - - if (env%solv_md) then - call wr_cluster_cut('crest_input', solu%nat, solv%nat, env%nsolv,& - & 'solute_cut.coord', 'solvent_shell.coord') - call remove('crest_input') - call copy('solvent_shell.coord', 'crest_input') - deallocate (clus%at) - deallocate (clus%xyz) - call rdnat('solvent_shell.coord', clus%nat) - allocate (clus%at(clus%nat), clus%xyz(3, clus%nat)) - call rdcoord('solvent_shell.coord', clus%nat, clus%at, clus%xyz) - end if - - !For newcregen: If env%crestver .eq. crest_solv .and. .not. env%QCG then conffile .eq. .true. - env%QCG = .false. - call inputcoords(env, 'crest_input') - call defaultGF(env) !Setting MTD parameter - -!--- Special constraints for gff to safeguard stability - if (env%ensemble_opt .eq. '--gff') then - checkiso_tmp = env%checkiso - env%checkiso = .true. - cbonds_tmp = env%cts%cbonds_md - env%cts%cbonds_md = .true. - call autoBondConstraint_withEZ('coord', env%forceconst, env%wbofile) - call rd_cbonds('bondlengths', env) - end if - - gfnver_tmp = env%gfnver - write (*, *) ' Method for ensemble search:', env%ensemble_opt -! if (env%ens_const) write(*,*) ' Solute fixed during ensemble generation' - env%gfnver = env%ensemble_opt !Setting method for ensemble search - - !---------------------------------------------------------------- - ! Case selection of normal Crest, MD or MTD - !---------------------------------------------------------------- - - select case (env%ensemble_method) - case (-1:0) !qcgmtd/Crest runtype - - !Defaults - !General settings: - if (.not. env%user_mdstep) then - if (env%ensemble_opt .EQ. '--gff') then - env%mdstep = 1.5d0 - else - env%mdstep = 5.0d0 - end if - end if - !Runtype specific settings: - if(env%ensemble_method == 0) then - if (.not. env%user_dumxyz) then - env%mddumpxyz = 200 - end if - if (.not. env%user_mdtime) then - env%mdtime = 10.0 - end if - else if(env%ensemble_method == -1) then - if (.not. env%user_dumxyz) then - env%mddumpxyz = 50 - end if - if (.not. env%user_mdtime) then - env%mdtime = 5.0 - end if - env%nmdtemp = 100 - env%MaxRestart = 6 - endif - - env%iterativeV2 = .true. !Safeguards more precise ensemble search - write (*, *) 'Starting ensemble cluster generation by CREST routine' - call confscript2i(env, tim_dum) !Calling ensemble search - call copy('crest_rotamers.xyz', 'crest_rotamers_0.xyz') - - case (1:2) ! Single MD or MTD - - !---- Setting threads - call new_ompautoset(env,'auto',1,T,Tn) - - !--- Setting new defaults for MD/MTD in qcg - if (env%mdtemp .lt. 0.0d0) then - newtemp = 400.00d0 - else if (.not. env%user_temp) then - newtemp = 298.0 - else - newtemp = env%mdtemp - end if - - if (.not. env%user_mdtime) then - newmdtime = 100.0 !100.0 - else - newmdtime = env%mdtime - end if - - if (.not. env%user_dumxyz) then - env%mddumpxyz = 1000 - end if - - if (.not. env%user_mdstep) then - if (env%ensemble_opt .ne. '--gff') then - newmdstep = 4.0d0 - else - newmdstep = 1.5d0 - end if - else - newmdstep = env%mdstep - end if - - if (env%ensemble_opt .ne. '--gff') then - newhmass = 4.0 - else - newhmass = 5.0 - end if - - if (.not. allocated(env%metadfac)) then - allocate (env%metadfac(1)) - allocate (env%metadexp(1)) - allocate (env%metadlist(1)) - end if - newmetadfac = 0.02_wp - newmetadexp = 0.1_wp - newmetadlist = 10.0_wp - - fname = 'coord' - pipe = ' > xtb.out 2>/dev/null' - - !--- Writing constraining file xcontrol - !--- Providing xcontrol overwrites constraints in coord file - - open (newunit=ich, file='xcontrol') - if (env%cts%NCI) then - do i = 1, 10 - if (trim(env%cts%pots(i)) .ne. '') then - write (ich, '(a)') trim(env%cts%pots(i)) - end if - end do - end if - - if (.not. env%solv_md) then - write (ich, '(a)') '$constrain' - write (ich, '(2x,a,i0)') 'atoms: 1-', solu%nat - write (ich, '(2x,a)') 'force constant=0.5' - write (ich, '(2x,a,a)') 'reference=ref.coord' - end if - - write (ich, '(a)') '$md' - write (ich, '(2x,a,f10.2)') 'hmass=', newhmass - write (ich, '(2x,a,f10.2)') 'time=', newmdtime - write (ich, '(2x,a,f10.2)') 'temp=', newtemp - write (ich, '(2x,a,f10.2)') 'step=', newmdstep - write (ich, '(2x,a,i0)') 'shake=', env%shake - write (ich, '(2x,a,i0)') 'dump=', env%mddumpxyz - write (ich, '(2x,a)') 'dumpxyz=500.0' - - if (env%ensemble_method .EQ. 2) then - write (ich, '(a)') '$metadyn' - write (ich, '(2x,a,i0,a,i0)') 'atoms: ', solu%nat + 1, '-', clus%nat - write (ich, '(2x,a,f10.2)') 'save=', newmetadlist - write (ich, '(2x,a,f10.2)') 'kpush=', newmetadfac - write (ich, '(2x,a,f10.2)') 'alp=', newmetadexp - end if - - if (env%cts%cbonds_md) call write_cts_CBONDS(ich, env%cts) - - close (ich) - -!--- Writing jobcall - write (jobcall, '(a,1x,a,1x,a,'' --md --input xcontrol '',a,1x,a,a)') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), trim(env%solv), pipe -!--- slightly different jobcall for QMDFF usage - if (env%useqmdff) then - write (jobcall, '(a,1x,a,1x,a,'' --md --input xcontrol --qmdff'',a,1x,a,a)') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), trim(env%solv), pipe - end if - -!--- MD - if (env%ensemble_method .EQ. 1) then - call normalMD(fname, env, 1, newtemp, newmdtime) - write (*, *) 'Starting MD with the settings:' - write (*, '('' MD time /ps :'',f8.1)') newmdtime - write (*, '('' MD Temperature /K :'',f8.1)') newtemp - write (*, '('' dt /fs :'',f8.1)') newmdstep - write (tmppath, '(a,i0)') 'NORMMD1' - - r = makedir(tmppath) - call copysub('xcontrol', tmppath) - call chdir(tmppath) - call copy('coord', 'ref.coord') - call chdir(tmppath2) - - call command('cd '//trim(tmppath)//' && '//trim(jobcall), io) - - inquire (file=trim(tmppath)//'/'//'xtb.trj', exist=ex) - if (.not. ex .or. io .ne. 0) then - write (*, '(a,i0,a)') '*Warning: MD seemingly failed (no xtb.trj)*' - else - write (*, *) '*MD finished*' - end if - - if (env%trackorigin) then - call set_trj_origins('NORMMD', 'md') - end if - call chdir('NORMMD1') - end if - -!--- MTD - - if (env%ensemble_method .EQ. 2) then - call MetaMD(env, 1, newmdtime, env%metadfac(1), env%metadexp(1), & - & env%metadlist(1)) - write (*, '(a,i4,a)') 'Starting Meta-MD with the settings:' - write (*, '('' MTD time /ps :'',f8.1)') newmdtime - write (*, '('' dt /fs :'',f8.1)') newmdstep - write (*, '('' MTD Temperature /K :'',f8.1)') newtemp - write (*, '('' dumpstep(trj) /fs :'',i8)') env%mddumpxyz - write (*, '('' Vbias factor k /Eh :'',f8.4)') newmetadfac - write (*, '('' Vbias exp α /bohr⁻²:'',f8.2)') newmetadexp - - write (tmppath, '(a,i0)') 'METADYN1' - r = makedir(tmppath) - call copysub('xcontrol', tmppath) - call chdir(tmppath) - call copy('coord', 'ref.coord') - - call chdir(tmppath2) - - call command('cd '//trim(tmppath)//' && '//trim(jobcall), io) - - inquire (file=trim(tmppath)//'/'//'xtb.trj', exist=ex) - if (.not. ex .or. io .ne. 0) then - write (*, '(a,i0,a)') '*Warning: Meta-MTD seemingly failed (no xtb.trj)*' - else - write (*, *) '*MTD finished*' - end if - - if (env%trackorigin) then - call set_trj_origins('METADYN', 'mtd') - end if - - call chdir('METADYN1') - - end if - - call rename('xtb.trj', 'crest_rotamers_0.xyz') - call copysub('crest_rotamers_0.xyz', tmppath2) - call dum%open('crest_rotamers_0.xyz') - -!--- M(T)D stability check - call minigrep('xtb.out', 'M(T)D is unstable, emergency exit', mdfail) - if (dum%nall .eq. 1) then - call copysub('xtb.out', resultspath) - write (*, *) 'ERROR : M(T)D results only in one structure' - if (mdfail) then - write (*, *) ' It was unstable' - else - write (*, *) ' The M(T)D time step might be too large or the M(T)D time too short.' - end if - call copysub('xtb.out', resultspath) - error stop ' Please check the xtb.out file in the ensemble folder' - end if - if (mdfail) then - write (*, *) - write (*, *) ' WARNING: The M(T)D was unstable.' - write (*, *) ' Please check the xtb.out file in the ensemble folder.' - write (*, *) - call copysub('xtb.out', resultspath) - end if - call dum%deallocate - call chdir(tmppath2) - call wrc0('coord', clus%nat, clus%at, clus%xyz) - call inputcoords(env, 'coord') !Necessary - -!--- Optimization - call print_qcg_opt - !if (env%gfnver .eq. '--gfn2') - call multilevel_opt(env, 99) - - end select - - env%QCG = .true. - -!--- Optimization with gfn2 if necessary - if (env%final_gfn2_opt) then - gfnver_tmp = env%gfnver -! if (env%gfnver .ne. '--gfn2') then - write (*, '(2x,a)') 'GFN2-xTB optimization' - env%gfnver = '--gfn2' - call rmrf('OPTIM') - call multilevel_opt(env, 99) - end if - -!--- Final optimization without potentials - call rmrf('OPTIM') - env%optlev = 1.0d0 !Higher precision for less scattering - env%cts%NCI = .false. !Dactivating the wall pot. - env%cts%pots = '' - deallocate (env%cts%pots) - call multilevel_opt(env, 99) - - !Clustering to exclude similar structures if requested with -cluster - if (env%properties == 70) then - write(*,'(3x,''Clustering the remaining structures'')') - call checkname_xyz(crefile,inpnam,outnam) - call ccegen(env, .false. , inpnam) - call move(trim(clusterfile),trim(outnam)) - end if - -!--- Energy sorting and removal of dublicates - env%gbsa = gbsa_tmp - env%solv = solv_tmp - call newcregen(env, 0) - call checkname_xyz(crefile, inpnam, outnam) - call copy(inpnam, 'ensemble.xyz') - call ens%open('ensemble.xyz') !Read in ensemble - call clus%deallocate() - clus%nat = ens%nat - allocate (clus%at(clus%nat)) - allocate (clus%xyz(3, clus%nat)) - -!------------------------------------------------------------- -! SP with GBSA model and without wall potentials -!------------------------------------------------------------- - - !--- Write folder with xyz-coordinates - do i = 1, ens%nall - call rdxmolselec('ensemble.xyz', i, clus%nat, clus%at, clus%xyz) - write (to, '("TMPSP",i0)') i - io = makedir(trim(to)) - call copysub('.UHF', to) - call copysub('.CHRG', to) - call chdir(to) - call wrxyz('cluster.xyz', clus%nat, clus%at, clus%xyz*bohr) - call chdir(tmppath2) - end do - !--- SP - write (*, *) - call ens_sp(env, 'cluster.xyz', ens%nall, 'TMPSP') - !--- Getting energy - do i = 1, ens%nall - call rdxmolselec('ensemble.xyz', i, clus%nat, clus%at, clus%xyz) - write (to, '("TMPSP",i0)') i - call chdir(to) - call grepval('xtb_sp.out', '| TOTAL ENERGY', e_there, ens%er(i)) - call chdir(tmppath2) - end do - - if (.not. e_there) then - write (*, *) - write (*, *) 'Energy not found. Error in xTB computations occured' - call chdir(to) - call minigrep('xtb_sp.out', 'solv_model_loadInternalParam', not_param) - call chdir(tmppath2) - if (not_param) then - write (*, *) ' !!!WARNIG: CHOSEN SOLVENT NOT PARAMETERIZED & - & FOR IMPLICIT SOLVATION MODEL!!!' - write (*, '('' CHECK IF '',A,'' IS AVAILABLE IN xTB'')') env%solv - write (*, *) ' PLEASE RESTART THE ENSEMBLE GENERATION WITH AVAILABLE& - & PARAMETERIZATION IF YOU NEED ENERGIES' - call copysub('crest_conformers.xyz', resultspath) - write (*, *) ' The enesemble can be found in the directory& - & as ' - error stop - end if - end if - - env%gfnver = gfnver_tmp - call ens%write('full_ensemble.xyz') - -!--- crest_best structure - minpos = minloc(ens%er, dim=1) - write (to, '("TMPSP",i0)') minpos - call chdir(to) - call rdxmol('cluster.xyz', clus%nat, clus%at, clus%xyz) - call chdir(tmppath2) - write (comment, '(F20.8)') ens%er(minpos) - inquire (file='crest_best.xyz', exist=ex) - if (ex) then - call rmrf('crest_best.xyz') !remove crest_best from - end if - call wrxyz('crest_best.xyz', clus%nat, clus%at, clus%xyz, comment) - -!------------------------------------------------------------- -! Processing results -!------------------------------------------------------------- - - allocate (e_fix(ens%nall)) - allocate (e_clus(ens%nall)) - - call pr_ensemble_energy() - - open (newunit=ich98, file='cluster_energy.dat') - write (ich98, '(3x,''#'',9x,''Energy [Eh]'',6x,''SASA'')') - -!--- Fixation energy of optimization - do i = 1, ens%nall - call chdir('OPTIM') - write (to, '("TMPCONF",i0)') i - call chdir(to) - call grepval('xtb.out', ' :: add. restraining', e_there, e_fix(i)) - call chdir(tmppath2) - - call rdxmolselec('full_ensemble.xyz', i, clus%nat, clus%at, clus%xyz) - call get_sphere(.false., clus, .false.) - dens = 0.001*(solu%mass + env%nsolv*solv%mass)/(1.0d-30*clus%vtot*bohr**3) - if (env%solv_md) then - call analyze_cluster(env%nsolv - 1, clus%nat, solv%nat, solv%nat, clus%xyz, clus%at, shr_av, shr) - else - call analyze_cluster(env%nsolv, clus%nat, solu%nat, solv%nat, clus%xyz, clus%at, shr_av, shr) - end if - write (ich98, '(i4,F20.10,3x,f8.1)') env%nsolv, ens%er(i), clus%atot - write (*, '(x,i4,4x,F13.6,2x,f6.3,1x,f8.3,2x,2f6.1,3x,f8.1,3x,a)') & - & i, ens%er(i), dens, e_fix(i), shr_av, shr, clus%atot, trim(optlevflag(env%optlev)) - e_fix(i) = e_fix(i)*eh/sqrt(float(clus%nat)) - end do - close (ich98) - call copysub('cluster_energy.dat', resultspath) - -!--- Checking Boltzmann weighting - write (*, *) - call remove('full_ensemble.xyz') - call sort_ensemble(ens, ens%er, 'full_ensemble.xyz') - e_clus = ens%er*eh - call sort_min(ens%nall, 1, 1, e_clus) - ens%er = e_clus/eh !Overwrite ensemble energy with sorted one - allocate (de(ens%nall), source=0.0d0) - allocate (p(ens%nall), source=0.0d0) - e0 = e_clus(1) - de(1:ens%nall) = (e_clus(1:ens%nall) - e0) - call qcg_boltz(env, ens%nall, de, p) - k = 0 - if (.not. env%user_nclust) env%nqcgclust = 0 !Needed for solvent ensemble - if (env%nqcgclust .eq. 0) then - do i = 1, ens%nall !Count how many are above 10% - if ((p(i)) .gt. 0.1) then - k = k + 1 - end if - end do - if ((k .eq. 0) .or. (k .gt. 10)) then - k = 10 !If too many structures are relevant, set it 10 - else if ((k .lt. 4) .and. (ens%nall .ge. 4)) then - k = 4 !If too less structures are relevant, set it 4 - else if (ens%nall .gt. 0) then - k=ens%nall - else - error stop 'No structure left. Something went wrong.' - end if - write (*, '(2x,a,1x,i0)') 'Conformers taken:', k - env%nqcgclust = k - else - if (env%nqcgclust .gt. ens%nall) then - k = ens%nall !Input larger than remaining structures - write (*, '(''Less than '',1x,i0,1x,''structures remain'')') env%nqcgclust - write (*, '(''Only '',1x,i0,1x,''structures are taken'')') ens%nall - if (env%cff) env%nqcgclust = ens%nall !Only for CFF, else a second qcg_ensemble run starts for solvent - else - write (*, '(''Taking '',1x,i0,1x,''structures'')') env%nqcgclust - k = env%nqcgclust !user input - end if - end if - - open (newunit=ich65, file='final_ensemble.xyz') - do i = 1, k - open (newunit=ich48, file='full_population.dat') - write (ich48, '(2x, ''cluster'',2x,''E_norm [Eh]'',2x, ''De [kcal]'', 4x, ''p'')') - do j = 1, ens%nall - if (j .lt. 10) then - write (ich48, '(5x,i0,3x,f11.6,5x,f6.4,3x,f6.4)') j, e_clus(j)/eh, de(j), p(j) - else - write (ich48, '(5x,i0,2x,f11.6,5x,f6.4,3x,f6.4)') j, e_clus(j)/eh, de(j), p(j) - end if - end do - close (ich48) - -!--- Take k energetic least structures (written at beginning of file) - call rdxmolselec('full_ensemble.xyz', i, clus%nat, clus%at, clus%xyz) - call wrxyz(ich65, clus%nat, clus%at, clus%xyz*bohr, ens%er(i)) - end do - close (ich65) - - call ens%deallocate() - call ens%open('final_ensemble.xyz') - ens%er = e_clus(1:k)/eh - -!--- Getting G,S,H - write (*, *) - write (*, '(2x,''------------------------------------------------------------------------'')') - write (*, '(2x,''------------------------------------------------------------------------'')') - write (*, '(2x,''Boltz. averaged energy of final cluster:'')') - call aver(.true., env, ens%nall, e_clus(1:ens%nall), S, H, G, sasa, .false.) - write (*, '(7x,''G /Eh :'',F14.8)') G/eh - write (*, '(7x,''T*S /kcal :'',f8.3)') S - - ens%g = G - ens%s = S - - deallocate (e_fix) - deallocate (e_clus) - -!---Folder management - call rename('cregen.out.tmp', 'thermo_data') - call copysub('thermo_data', resultspath) - call copysub('crest_best.xyz', resultspath) - call copysub('cre_members.out', resultspath) - call copysub('full_ensemble.xyz', resultspath) - call copysub('final_ensemble.xyz', resultspath) - call copysub('population.dat', resultspath) - call copysub('full_population.dat', resultspath) - -!---Deleting ensemble tmp - call chdir(thispath) - call chdir(env%scratchdir) - if (.not. env%keepModef) call rmrf(tmppath2) -!----Outprint - write (*, *) - write (*, '(2x,''Ensemble generation finished.'')') - write (*, '(2x,''Results can be found in ensemble directory'')') - write (*, '(2x,''Lowest energy conformer in file '')') - write (*, '(2x,''List of full ensemble in file '')') - write (*, '(2x,''List of used ensemble in file '')') - write (*, '(2x,''Thermodynamical data in file '')') - write (*, '(2x,''Population of full ensemble in file '')') - write (*, '(2x,''Population in file '')') - - env%gfnver = gfnver_tmp - env%optlev = optlev_tmp - if (env%ensemble_opt .eq. '--gff') then - env%cts%cbonds_md = cbonds_tmp - env%checkiso = checkiso_tmp - end if - - call tim_dum%clear - - if (.not. env%solv_md) then - call tim%stop(6) - else - call tim%stop(7) - end if - -end subroutine qcg_ensemble - -subroutine qcg_cff(env, solu, solv, clus, ens, solv_ens, tim) - use crest_parameters - use crest_data - use iomod - use zdata - use strucrd - - implicit none - - type(systemdata) :: env - type(timer) :: tim - type(zmolecule) :: solu, solv, clus - type(ensemble) :: solv_ens - type(ensemble), intent(in) :: ens - - integer :: i, j, k, iter - integer :: io, r - integer :: nsolv, n_ini - integer :: ipos, dum - integer :: v_ratio - integer :: minE_pos, m, nat_tot - integer :: nat_frag1 !number of atoms larger fragment (=solvent shell) - integer :: conv(env%nqcgclust + 1) - integer :: solv_added, minpos - character(len=512) :: thispath, resultspath, tmppath, tmppath2 - character(len=64) :: fname_lmo1, fname_lmo2, comment - character(len=20) :: to - real(wp), allocatable :: e_empty(:), inner_ell_abc(:, :) - real(wp), allocatable :: outer_ell_abc(:, :) - real(wp), allocatable :: e_cur(:, :) - real(wp) :: e_cluster(env%nqcgclust) - real(wp), parameter :: eh = 627.509541d0 - real(wp) :: S, H, G - real(wp) :: sasa, tmp_optlev - real(wp) :: etmp(500) - real(wp) :: e_fix(env%nqcgclust), e_norm(env%nqcgclust) - real(wp) :: dum_e, de - real(wp) :: de_tot(env%nqcgclust) - real(wp) :: shr = 0 - real(wp) :: shr_av = 0 - real(wp) :: dens, atotS - logical :: ex, skip, e_there - logical :: all_converged - logical, allocatable :: converged(:), nothing_added(:) - - character(len=20) :: gfnver_tmp - real(wp) :: optlev_tmp - integer :: ich98, ich31 - - interface - subroutine aver(pr, env, runs, e_tot, S, H, G, sasa, a_present, a_tot) - use iso_fortran_env, only: wp => real64 - use crest_data - - implicit none - type(systemdata), intent(in) :: env - integer, intent(in) :: runs - real(wp), intent(inout) :: e_tot - real(wp), intent(in), optional :: a_tot - real(wp), intent(out) :: S - real(wp), intent(out) :: H - real(wp), intent(out) :: G - real(wp), intent(out) :: sasa - logical, intent(in) :: pr, a_present - dimension e_tot(runs) - dimension a_tot(runs) - end subroutine aver - end interface - - call tim%start(8, 'CFF') - - allocate (e_empty(env%nqcgclust)) - allocate (converged(env%nqcgclust)) - allocate (nothing_added(env%nqcgclust)) - allocate (outer_ell_abc(env%nqcgclust, 3)) - allocate (inner_ell_abc(env%nqcgclust, 3)) - - v_ratio = nint(solu%vtot/solv%vtot) - allocate (e_cur(env%nsolv + v_ratio, env%nqcgclust), source=0.0d0) - -!--- Setting defaults (same as ensemble optimization to have comparable structures) - optlev_tmp = env%optlev - env%optlev = 1.0d0 !Increaseing percision for ensemble search to minimze scattering - gfnver_tmp = env%gfnver - if (env%final_gfn2_opt) then - env%gfnver = '--gfn2' - else - env%gfnver = env%ensemble_opt !CFF always with ensemble method - end if - nothing_added = .false. - - dum = 0 - converged = .false. - all_converged = .false. - nat_tot = clus%nat - solu%nat!*env%nqcgclust - - if (solu%vtot/solv%vtot .lt. 1.0d0) then - skip = .true. - else - skip = .false. - end if - -!--- Folder management - call getcwd(thispath) - r = makedir('solvent_ensemble') - call chdir('solvent_ensemble') - call getcwd(resultspath) - call chdir(thispath) - call chdir(env%scratchdir) - call getcwd(tmppath) - io = makedir('tmp_CFF') - call chdir('tmp_CFF') - call getcwd(tmppath2) - call chdir(tmppath) - call chdir('solvent_properties') - if (env%use_xtbiff) then - call copysub('solvent.lmo', tmppath2) - else - call copysub('solvent', tmppath2) - end if - call chdir(tmppath2) - -!--- SP of each cluster - call ens%write('ensemble.xyz') - do i = 1, env%nqcgclust - call rdxmolselec('ensemble.xyz', i, clus%nat, clus%at, clus%xyz) - clus%nmol = clus%nat/solv%nat - write (to, '("TMPCFF",i0)') i - io = makedir(trim(to)) - if (env%use_xtbiff) then - call copysub('solvent.lmo', to) - else - call copysub('solvent', to) - end if - call chdir(to) - call wrc0('cluster.coord', clus%nat, clus%at, clus%xyz) - call wr_cluster_cut('cluster.coord', solu%nat, solv%nat, env%nsolv, 'solute_cut.coord', 'solvent_shell.coord') - call xtb_sp_qcg(env, 'solvent_shell.coord') - call grepval('xtb.out', '| TOTAL ENERGY', ex, e_empty(i)) - call copy('solvent_shell.coord', 'solvent_cluster.coord') - call copy('solvent_cluster.coord', 'filled_cluster.coord') - call get_ellipsoid(env, solu, solv, clus, .false.) !solu, to have same cavity to fill solvent in - outer_ell_abc(i, 1:3) = clus%ell_abc(1:3) - inner_ell_abc(i, 1:3) = solu%ell_abc(1:3) - call chdir(tmppath2) - end do - - if (skip) write (*, '(2x,''solute smaller than solvent, cff skipped'')') - - clus%nat = clus%nat - solu%nat - n_ini = clus%nat - -!--- If solvent molecules are added - if (.not. skip) then - call pr_qcg_fill() - write (*, '(2x,''now adding solvents to fill cluster...'')') - call pr_fill_energy() - write (*, '(2x,''------------------------------------------------------------------------'')') - nat_frag1 = env%nsolv*solv%nat - - iter = 0 -!--- Main cycle for addition of solvent molecules - convergence: do while (.not. all_converged) - k = 0 - iter = iter + 1 - !--- Setting array, with only numbers of dirs that are not converged - do i = 1, env%nqcgclust - if (.not. converged(i)) then - k = k + 1 - conv(k) = i - conv(env%nqcgclust + 1) = k !How many jobs are open - else - cycle - end if - end do - conv(k + 1:env%nqcgclust) = 0 - - if (env%use_xtbiff) then -!----------- LMO computation for solvent cluster--------------------------------------------------- - call ensemble_lmo(env, 'solvent_cluster.coord', solv, conv(env%nqcgclust + 1),& - & 'TMPCFF', conv) -!-------------------------------------------------------------------------------------------------- - - do i = 1, env%nqcgclust - if (.not. converged(i)) then - write (to, '("TMPCFF",i0)') i - call chdir(to) - call rename('xtblmoinfo', 'solvent_cluster.lmo') - call chdir(tmppath2) - else - cycle - end if - end do - end if - - call chdir(tmppath2) - - fname_lmo1 = 'solvent_cluster.lmo' - fname_lmo2 = 'solvent.lmo' - -!--- Solvent addition to the cluster--------------------------------------------- - if (env%use_xtbiff) then - call ensemble_iff(env, outer_ell_abc, nat_frag1, fname_lmo1, fname_lmo2,& - &conv(env%nqcgclust + 1), 'TMPCFF', conv) - else - call ensemble_dock(env, outer_ell_abc, nat_frag1, 'solvent_cluster.coord',& - &'solvent', clus%nat, solv%nat, conv(env%nqcgclust + 1), 'TMPCFF', conv) - end if -!-------------------------------------------------------------------------------- - - nat_frag1 = nat_frag1 + solv%nat - - !--- Increase cluster size - deallocate (clus%at) - deallocate (clus%xyz) - clus%nat = clus%nat + solv%nat - allocate (clus%at(clus%nat)) - allocate (clus%xyz(3, clus%nat)) - clus%nmol = clus%nmol + 1 - - do i = 1, env%nqcgclust - if (.not. converged(i)) then - write (to, '("TMPCFF",i0)') i - call chdir(to) - call remove('xtbrestart') - call remove('xcontrol') - - if (env%use_xtbiff) then - !--- Select xtb-IFF stucture to proceed - call rdxtbiffE('xtbscreen.xyz', m, clus%nat, etmp) !Get energy of screening - minE_pos = minloc(etmp(1:m), dim=1) !Get minimum of those - call rdxmolselec('xtbscreen.xyz', minE_pos, clus%nat, clus%at, clus%xyz) !Read the struc into clus%xyz - call wrc0('solvent_cluster.coord', clus%nat, clus%at, clus%xyz) - else - call rdcoord('best.xyz', clus%nat, clus%at, clus%xyz, e_cur(iter, i)) - call wrc0('solvent_cluster.coord', clus%nat, clus%at, clus%xyz) - end if - - !--- Check if converged - call fill_take(env, solv%nat, clus%nat, inner_ell_abc(i, 1:3), ipos) - if (ipos .eq. 0) then - converged(i) = .true. - write (*, '(2x,''no more solvents can be placed inside cavity of cluster: '',i0)') i - write (*, '(2x,''previous cluster taken...'')') - if (iter .eq. 1) nothing_added(i) = .true. - end if - call chdir(tmppath2) - - else - cycle - end if - end do - -!--- Check, if a structure was converged and iff was not necessary - k = 0 - do i = 1, env%nqcgclust - if (.not. converged(i)) then - k = k + 1 - conv(k) = i - conv(env%nqcgclust + 1) = k !How many jobs are open - else - cycle - end if - end do - conv(k + 1:env%nqcgclust) = 0 - -! if(env%use_xtbiff) then -!--- Parallel optimization------------------------------------------------------------------- - call cff_opt(.false., env, 'solvent_cluster.coord', n_ini, conv(env%nqcgclust + 1)& - &, 'TMPCFF', conv, nothing_added) -!---------------------------------------------------------------------------------------------- -! end if - - do i = 1, env%nqcgclust - if (.not. converged(i)) then - write (to, '("TMPCFF",i0)') i - call chdir(to) - if (env%use_xtbiff) then - call copy('xtbopt.coord', 'solvent_cluster.coord') - call grepval('xtb_sp.out', '| TOTAL ENERGY', e_there, e_cur(iter, i)) - end if - dum_e = e_empty(i) - if (iter - nsolv .gt. 1) dum_e = e_cur(iter - 1, i) - de = eh*(e_cur(iter, i) - solv%energy - dum_e) - de_tot(i) = de_tot(i) + de - !---- Check if solvent added is repulsive - if (de .gt. 0) then - converged(i) = .true. - write (*, '(2x,''adding solvent is repulsive for cluster: '',i0)') i - write (*, '(2x,''previous cluster taken...'')') - if (iter .eq. 1) nothing_added(i) = .true. - else !Only if the addition was not repulsive - call copy('solvent_cluster.coord', 'filled_cluster.coord') - write (*, '(i4,5x,i3,1x,F13.6,3x,f7.2,5x,f7.2,4x,a)') & - & iter + env%nsolv, i, e_cur(iter, i), de, de_tot(i),& - & trim(optlevflag(env%optlev)) - end if - call chdir(tmppath2) - end if - end do - - !--- Check if everything is converged - dum = 0 - do i = 1, env%nqcgclust - if (converged(1)) then - dum = dum + 1 - end if - end do - - if (dum .eq. env%nqcgclust) then - all_converged = .true. - else - nat_tot = nat_tot + solv%nat - end if - - write (*, '(2x,''------------------------------------------------------------------------'')') - !--- Or if maximum solvent is added - if (iter - nsolv .eq. v_ratio) then - write (*, '(2x,''volume filled'')') - all_converged = .true. - call copy('solvent_cluster.coord', 'filled_cluster.coord') - end if - - end do convergence - - end if - - !Now in every TMPPath the final cluster file filled_cluster.coord is present - -!--------------------------------------------------------------------- -! Final Optimization -!--------------------------------------------------------------------- - - tmp_optlev = env%optlev - if (env%optlev .lt. 1.0) env%optlev = 1.0d0 !higher accuracy - - if (.not. skip) then - call cff_opt(.true., env, 'filled_cluster.coord', n_ini, conv(env%nqcgclust + 1),& - & 'TMPCFF', conv, nothing_added) - else - n_ini = 0 !If this is 0, no constraining will be done (optimization of total system) - nothing_added = .true. - call cff_opt(.true., env, 'filled_cluster.coord', n_ini, env%nqcgclust, 'TMPCFF',& - & conv, nothing_added) - end if - env%optlev = tmp_optlev - - call pr_ensemble_energy() - - solv_ens%nall = env%nqcgclust - solv_ens%nat = nat_tot - -!--- Getting results-------------------------------------------------------------- - open (newunit=ich31, file='crest_rotamers_0.xyz') - open (newunit=ich98, file='cluster_energy.dat') - write (ich98, '(3x,''#'',11x,''Energy [Eh]'',6x,''SASA'')') - - do i = 1, env%nqcgclust - write (to, '("TMPCFF",i0)') i - call chdir(to) - call copy('xtbopt.coord', 'final_cluster.coord') - -!--- Reading structure - call clus%deallocate() - call rdnat('final_cluster.coord', clus%nat) - allocate (clus%at(clus%nat), clus%xyz(3, clus%nat)) - call rdcoord('final_cluster.coord', clus%nat, clus%at, clus%xyz) - -!--- Getting energy and calculating properties - call grepval('xtb_sp.out', '| TOTAL ENERGY', e_there, e_cluster(i)) - call grepval('xtb_sp.out', ' :: add. restraining', e_there, e_fix(i)) - e_fix(i) = e_fix(i)*eh/sqrt(float(clus%nat)) - call get_sphere(.false., clus, .false.) - if (clus%nat .gt. n_ini) then - solv_added = (clus%nat - (n_ini))/solv%nat - else - solv_added = 0 - end if - dens = 0.001*((clus%nat/solv%nat)*solv%mass)/(1.0d-30*clus%vtot*bohr**3) - call analyze_cluster(solv_added, clus%nat, n_ini, solv%nat, clus%xyz, clus%at, shr_av, shr) - e_norm(i) = e_cluster(i)*env%nsolv/(clus%nat/solv%nat) - atotS = clus%atot*env%nsolv/(clus%nat/solv%nat) - -!--- Writing outputfiles - write (ich31, '(2x,i0)') clus%nat - write (ich31, '(2x,f18.8,2x,a)') e_cluster(i) - do j = 1, clus%nat - write (ich31, '(1x,a2,1x,3f20.10)') i2e(clus%at(j), 'nc'), clus%xyz(1:3, j)*bohr - end do - - write (ich98, '(''No'',i4,F20.10,3x,f8.1)') i, e_norm(i), atotS - -!--- Print to screen - write (*, '(x,i4,4x,F13.6,2x,f6.3,1x,f8.3,2x,2f6.1,3x,f8.1,3x,a)') & - & i, e_norm(i), dens, e_fix(i), shr_av, shr, atotS, trim(optlevflag(env%optlev)) - - call chdir(tmppath2) - end do - - close (ich98) - close (ich31) - - call solv_ens%deallocate() - call solv_ens%open('crest_rotamers_0.xyz') - - solv_ens%er = e_cluster - call copy('crest_rotamers_0.xyz', 'crest_ensemble.xyz') - -!--- crest_best structure - minpos = minloc(solv_ens%er, dim=1) - write (to, '("TMPCFF",i0)') minpos - call chdir(to) - call clus%deallocate - call rdnat('final_cluster.coord', clus%nat) - allocate (clus%at(clus%nat), clus%xyz(3, clus%nat)) - call rdcoord('final_cluster.coord', clus%nat, clus%at, clus%xyz) - clus%xyz = clus%xyz*bohr - call chdir(tmppath2) - write (comment, '(F20.8)') solv_ens%er(minpos) - call wrxyz('crest_best.xyz', clus%nat, clus%at, clus%xyz, comment) - -!--- Boltz. average------------------------------------------------------------------------- - write (*, *) - write (*, '(2x,''------------------------------------------------------------------------'')') - write (*, '(2x,''------------------------------------------------------------------------'')') - write (*, '(2x,''Boltz. averaged energy of final cluster:'')') - e_cluster = solv_ens%er*eh - e_norm = e_norm*eh - call sort_min(env%nqcgclust, 1, 1, e_norm) - call aver(.true., env, solv_ens%nall, e_norm(1:env%nqcgclust), S, H, G, sasa, .false.) - write (*, '(7x,''G /Eh :'',F14.8)') G/eh - write (*, '(7x,''T*S /kcal :'',f8.3)') S - solv_ens%er = e_norm/eh !normalized energy needed for final evaluation - - solv_ens%g = G - solv_ens%s = S - -!--- Cleanup - call copysub('crest_ensemble.xyz', resultspath) - call copysub('cluster_energy.dat', resultspath) - call copysub('crest_best.xyz', resultspath) - call copysub('population.dat', resultspath) - call chdir(tmppath) - if (.not. env%keepModef) call rmrf('tmp_CFF') - call chdir(thispath) - -!--- Printouts - write (*, *) - write (*, '(2x,''Solvent cluster generation finished.'')') - write (*, '(2x,''Results can be found in solvent_cluster directory'')') - write (*, '(2x,''Structures in file '')') - write (*, '(2x,''Energies in file '')') - write (*, '(2x,''Population in file '')') - - env%gfnver = gfnver_tmp - env%optlev = optlev_tmp - - deallocate (e_empty) - deallocate (converged) - deallocate (outer_ell_abc) - deallocate (inner_ell_abc) - - call tim%stop(8) - -end subroutine qcg_cff - -subroutine qcg_freq(env, tim, solu, solv, solu_ens, solv_ens) - use crest_parameters - use crest_data - use iomod - use zdata - use strucrd - - implicit none - - type(systemdata) :: env - type(timer) :: tim - type(zmolecule) :: solu, solv, clus - type(ensemble) :: solu_ens, solv_ens - - integer :: r, io, f, g, h - integer :: i - character(len=512) :: thispath, resultspath, tmppath, tmppath2 - character(len=80) :: to - character(len=20) :: gfnver_tmp - real(wp) :: optlev_tmp - real(wp) :: gt(3) - real(wp) :: ht(3) - real(wp) :: svib(3) - real(wp) :: srot(3) - real(wp) :: stra(3) - integer :: ich65, ich56, ich33, ich81 - logical :: opt - - call tim%start(9, 'Frequencies') - - call pr_qcg_freq() - -!--- Setting defaults (same as ensemble optimization and cff to have comparable structures) - optlev_tmp = env%optlev - env%optlev = 1.0d0 !Increaseing percision for ensemble search to minimze scattering - gfnver_tmp = env%gfnver - env%gfnver = env%freqver !Setting method - -!--- Folder management - call getcwd(thispath) - r = makedir('frequencies') - call chdir('frequencies') - call getcwd(resultspath) - call chdir(thispath) - call chdir(env%scratchdir) - call getcwd(tmppath) - io = makedir('tmp_freq') - call copysub('.CHRG', 'tmp_freq') - call copysub('.UHF', 'tmp_freq') - call chdir('tmp_freq') - call getcwd(tmppath2) - f = makedir('tmp_solu') - call copysub('.CHRG', 'tmp_solu') - call copysub('.UHF', 'tmp_solu') - g = makedir('tmp_solv') - h = makedir('tmp_gas1') !One solute molecule - call copysub('.CHRG', 'tmp_gas1') - call copysub('.UHF', 'tmp_gas1') - -!--- Frequencies solute molecule - write (*, *) ' SOLUTE MOLECULE' - call chdir('tmp_gas1') - call wrc0('solute.coord', solu%nat, solu%at, solu%xyz) - call chdir(tmppath2) - opt = .false. - call ens_freq(env, 'solute.coord', 1, 'tmp_gas', opt) - call chdir('tmp_gas1') - call rdtherm('xtb_freq.out', ht(3), svib(3), srot(3), stra(3), gt(3)) - solu%gt = gt(3) - solu%ht = ht(3) - solu%svib = svib(3) - solu%srot = srot(3) - solu%stra = stra(3) - - call chdir(tmppath2) - -!--- Folder setup for cluster - call chdir('tmp_solu') - call solu_ens%write('solute_ensemble.xyz') - -!--- All cluster are of the same size - call clus%deallocate() - clus%nat = solu_ens%nat - allocate (clus%at(clus%nat)) - allocate (clus%xyz(3, clus%nat)) - clus%xyz = 0 - clus%nmol = env%nsolv + 1 !clus%nat/clus%at - - do i = 1, solu_ens%nall - call rdxmolselec('solute_ensemble.xyz', i, clus%nat, clus%at, clus%xyz) - -!--- Solute cluster - write (to, '("TMPFREQ",i0)') i - io = makedir(trim(to)) - call copysub('.UHF', to) - call copysub('.CHRG', to) - call chdir(to) - open (newunit=ich65, file='cluster.xyz') - call wrxyz(ich65, clus%nat, clus%at, clus%xyz*bohr) - close (ich65) - - call chdir(tmppath2) - - !--- Solvent cluster (only if cff, than the solvent shell is taken, which was fixed all the time) - if (env%cff) then - call chdir('tmp_solv') - write (to, '("TMPFREQ",i0)') i - io = makedir(trim(to)) - call chdir(to) - call wrc0('cluster.coord', clus%nat, clus%at, clus%xyz) - call wr_cluster_cut('cluster.coord', solu%nat, solv%nat, env%nsolv,& - & 'solute_cut.coord', 'solvent_cut.coord') - - call chdir(tmppath2) - end if - call chdir('tmp_solu') - - end do - - write (*, *) ' SOLUTE CLUSTER' - -!> Frequency calculation - opt = .true. - call ens_freq(env, 'cluster.xyz', solu_ens%nall, 'TMPFREQ', opt) - call chdir(tmppath2) - - write (*, *) ' SOLVENT CLUSTER' - if (env%cff) then - call chdir('tmp_solv') - call ens_freq(env, 'solvent_cut.coord', solu_ens%nall, 'TMPFREQ', opt) - call chdir(tmppath2) - end if - - call clus%deallocate() - - !--- Frequencies solvent cluster (only, if not cff was used) - if (.not. env%cff) then - call chdir('tmp_solv') - call solv_ens%write('solvent_ensemble.xyz') - - do i = 1, solv_ens%nall - write (to, '("TMPFREQ",i0)') i - io = makedir(trim(to)) - call copysub('.UHF', to) - call copysub('.CHRG', to) - call chdir(to) - open (newunit=ich65, file='solv_cluster.xyz') - call wrxyz(ich65, solv_ens%nat, solv_ens%at, solv_ens%xyz(:, :, i)) - close (ich65) - call chdir(tmppath2) - call chdir('tmp_solv') - end do -!> Frequency calculation - call ens_freq(env, 'solv_cluster.xyz', solv_ens%nall, 'TMPFREQ', opt) - call chdir(tmppath2) - end if - -!---------------------------------------------------------------------------- -! Data read out -!---------------------------------------------------------------------------- - -!--- Solute in gas phase - write (*, *) - write (*, *) ' Solute Gas properties' - call pr_freq_energy() - open (newunit=ich56, file='solute.dat') - call pr_freq_file(ich56) - write (*, '(2x,5f10.2)') ht(3), svib(3), srot(3), stra(3), gt(3) - write (ich56, '(2x,5f10.2)') ht(3), svib(3), srot(3), stra(3), gt(3) - close (ich56) - -!--- Solute cluster - write (*, *) - write (*, *) ' Solute cluster properties' - open (newunit=ich33, file='solute_cluster.dat') - - call chdir('tmp_solu') - - allocate (solu_ens%gt(solu_ens%nall)) - allocate (solu_ens%ht(solu_ens%nall)) - allocate (solu_ens%svib(solu_ens%nall)) - allocate (solu_ens%srot(solu_ens%nall)) - allocate (solu_ens%stra(solu_ens%nall)) - - call pr_freq_energy() - call pr_freq_file(ich33) - - do i = 1, solu_ens%nall - write (to, '("TMPFREQ",i0)') i - call chdir(to) - call rdtherm('xtb_freq.out', ht(1), svib(1), srot(1), stra(1), gt(1)) - write (*, '(2x,i0,2x,5f10.2)') i, ht(1), svib(1), srot(1), stra(1), gt(1) - write (ich33, '(2x,i0,2x,5f10.2)') i, ht(1), svib(1), srot(1), stra(1), gt(1) - solu_ens%gt(i) = gt(1) - solu_ens%ht(i) = ht(1) - solu_ens%svib(i) = svib(1) - solu_ens%srot(i) = srot(1) - solu_ens%stra(i) = stra(1) - - call chdir(tmppath2) - call chdir('tmp_solu') - end do - close (ich33) - -!--- Solvent cluster - write (*, *) - write (*, *) ' Solvent cluster properties' - call chdir(tmppath2) - open (newunit=ich81, file='solvent_cluster.dat') - - call chdir('tmp_solv') - - allocate (solv_ens%gt(solv_ens%nall)) - allocate (solv_ens%ht(solv_ens%nall)) - allocate (solv_ens%svib(solv_ens%nall)) - allocate (solv_ens%srot(solv_ens%nall)) - allocate (solv_ens%stra(solv_ens%nall)) - - call pr_freq_energy() - call pr_freq_file(ich81) - - do i = 1, solv_ens%nall - write (to, '("TMPFREQ",i0)') i - call chdir(to) - call rdtherm('xtb_freq.out', ht(2), svib(2), srot(2), stra(2), gt(2)) - write (*, '(2x,i0,2x,5f10.2)') i, ht(2), svib(2), srot(2), stra(2), gt(2) - write (ich81, '(2x,i0,2x,5f10.2)') i, ht(2), svib(2), srot(2), stra(2), gt(2) - solv_ens%gt(i) = gt(2) - solv_ens%ht(i) = ht(2) - solv_ens%svib(i) = svib(2) - solv_ens%srot(i) = srot(2) - solv_ens%stra(i) = stra(2) - call chdir(tmppath2) - call chdir('tmp_solv') - end do - close (ich81) - -!--- Saving results - call chdir(tmppath2) - call copysub('solute.dat', resultspath) - call copysub('solute_cluster.dat', resultspath) - call copysub('solvent_cluster.dat', resultspath) - -!--- Deleting tmp directory - call chdir(tmppath) - if (.not. env%keepModef) call rmrf(tmppath2) - call chdir(thispath) - - env%gfnver = gfnver_tmp - env%optlev = optlev_tmp - - call tim%stop(9) - -end subroutine qcg_freq - -subroutine qcg_eval(env, solu, solu_ens, solv_ens) - use iso_fortran_env, wp => real64 - use crest_data - use iomod - use zdata - use strucrd - - implicit none - - type(systemdata) :: env - type(zmolecule) :: solu - type(ensemble) :: solu_ens, solv_ens - - character(len=512) :: thispath - - integer :: i, j - integer :: srange - integer :: freqscal - real(wp) :: g1(solu_ens%nall) - real(wp) :: g2(solv_ens%nall) - real(wp) :: g3 - real(wp) :: Gsolv(20) - real(wp) :: Hsolv - real(wp) :: G_solute(20) - real(wp) :: H_solute - real(wp) :: G_solvent(20) - real(wp) :: H_solvent - real(wp) :: G_mono(20) - real(wp) :: H_mono - real(wp) :: S(20) - real(wp) :: volw - real(wp) :: sasa - real(wp) :: dum, dum1, dum2 - real(wp) :: e_solute(solu_ens%nall) - real(wp) :: e_solvent(solv_ens%nall) - real(wp) :: scal(20) - integer :: ich23 - real(wp), parameter :: eh = 627.509541d0 - - interface - subroutine aver(pr, env, runs, e_tot, S, H, G, sasa, a_present, a_tot) - use iso_fortran_env, only: wp => real64 - use crest_data - - implicit none - type(systemdata), intent(in) :: env - integer, intent(in) :: runs - real(wp), intent(inout) :: e_tot - real(wp), intent(in), optional :: a_tot - real(wp), intent(out) :: S - real(wp), intent(out) :: H - real(wp), intent(out) :: G - real(wp), intent(out) :: sasa - logical, intent(in) :: pr, a_present - dimension e_tot(runs) - dimension a_tot(runs) - end subroutine aver - end interface - - call pr_eval_eval() - - call getcwd(thispath) - - freqscal = nint(env%freq_scal/0.05) - srange = 20 - do i = 1, srange - scal(i) = 0.05*i - end do - -!--- Solute Cluster - !H_solv - do i = 1, solu_ens%nall - e_solute(i) = solu_ens%er(i)*eh + solu_ens%ht(i) - end do - call aver(.false., env, solu_ens%nall, e_solute, dum1, H_solute, dum2, sasa, .false.) - !G_solv - do i = 1, srange - do j = 1, solu_ens%nall - g1(j) = solu_ens%ht(j) - (env%tboltz*(solu_ens%svib(j) + scal(i)*(solu_ens%srot(j) + solu_ens%stra(j)))/1000) - e_solute(j) = solu_ens%er(j)*eh + g1(j) - end do - call aver(.false., env, solu_ens%nall, e_solute, S(i), dum, G_solute(i), sasa, .false.) - end do - -!--- Solvent Cluster - !H_solv - do i = 1, solv_ens%nall - e_solvent(i) = solv_ens%er(i)*eh + solv_ens%ht(i) - end do - call aver(.false., env, solv_ens%nall, e_solvent, dum1, H_solvent, dum2, sasa, .false.) - - !G_solv - do i = 1, srange - do j = 1, solv_ens%nall - g2(j) = solv_ens%ht(j) - & - & (env%tboltz*(solv_ens%svib(j) + scal(i)*(solv_ens%srot(j) + solv_ens%stra(j)))/1000) - e_solvent(j) = solv_ens%er(j)*eh + g2(j) - end do - call aver(.false., env, solv_ens%nall, e_solvent, S(i), dum, G_solvent(i), sasa, .false.) - end do - -!--- Solute gas phase - H_mono = solu%energy*eh + solu%ht - do i = 1, srange - g3 = solu%ht - (env%tboltz*(solu%svib + scal(i)*(solu%srot + solu%stra))/1000) - G_mono(i) = solu%energy*eh + g3 - end do - - Gsolv(1:20) = G_solute(1:20) - G_solvent(1:20) - G_mono(1:20) - Hsolv = H_solute - H_solvent - H_mono - -!--- Calculate Volume work and include - volw = (env%tboltz*8.31451/1000./4.184)*log(24.47d0*env%tboltz/298.15) - Gsolv(1:20) = Gsolv(1:20) - volw - Hsolv = Hsolv - volw - call pr_eval_1(Gsolv(20), Hsolv) - call pr_eval_2(srange, Gsolv, scal) - call pr_eval_3(srange, freqscal, env%freq_scal, Gsolv) - -! Save Result - open (newunit=ich23, file='frequencies/result.dat') - write (ich23, '("Solvation Free Energy [kcal/mol] :")') - write (ich23, '(f8.2)') Gsolv(freqscal) - close (ich23) - -end subroutine qcg_eval - -subroutine write_qcg_setup(env) - use crest_data - use iomod - implicit none - - type(systemdata) :: env - - write (*, *) - write (*, '(2x,''========================================='')') - write (*, '(2x,''| quantum cluster growth: INPUT |'')') - write (*, '(2x,''========================================='')') - write (*, *) - select case (env%qcg_runtype) - case (0) - write (*, '(2x,''QCG: Only Cluster Generation'')') - case (1) - write (*, '(2x,''QCG: Cluster + Ensemble Generation'')') - if (env%ensemble_method .eq. 0) write (*, '(2x,''Ensemble generated via CREST'')') - if (env%ensemble_method .eq. 1) write (*, '(2x,''Ensemble generated via MD Simulation'')') - if (env%ensemble_method .eq. 2) write (*, '(2x,''Ensemble generated via MetaDynamic'')') - case (2) - write (*, '(2x,''QCG: Calculation of delta E_solv'')') - if (env%ensemble_method .eq. 0) write (*, '(2x,''Ensemble generated via CREST'')') - if (env%ensemble_method .eq. 1) write (*, '(2x,''Ensemble generated via MD Simulation'')') - if (env%ensemble_method .eq. 2) write (*, '(2x,''Ensemble generated via MetaDynamic'')') - case (3) - write (*, '(2x,''QCG: Calculation of delta G_solv'')') - if (env%ensemble_method .eq. 0) write (*, '(2x,''Ensemble generated via CREST'')') - if (env%ensemble_method .eq. 1) write (*, '(2x,''Ensemble generated via MD Simulation'')') - if (env%ensemble_method .eq. 2) write (*, '(2x,''Ensemble generated via MetaDynamic'')') - case default - continue - end select - write (*, *) - write (*, '(2x,''input parameters '')') - write (*, '(2x,''solute : '',a)') trim(env%solu_file) - write (*, '(2x,''charge : '',i0)') env%chrg - write (*, '(2x,''uhf : '',i0)') env%uhf - write (*, '(2x,''solvent : '',a)') trim(env%solv_file) - if (env%nsolv .ne. 0) then - write (*, '(2x,''# of solvents to add : '',i0)') env%nsolv - else if (env%nsolv .eq. 0) then - write (*, '(2x,''# of solvents to add : until convergence, but maximal'',1x,i4)') env%max_solv - end if - if (env%nqcgclust .ne. 0) then - write (*, '(2x,''# of cluster generated : '',i0)') env%nqcgclust - else - write (*, '(2x,''Cluster generated that are above 10 % populated '')') - end if - - write (*, '(2x,''# of CPUs used : '',i0)') env%Threads - if (env%solvent .eq. '') then - write (*, '(2x,''No gbsa/alpb model'' )') - else - write (*, '(2x,''Solvation model : '',a)') env%solvent - end if - write (*, '(2x,''xtb opt level : '',a)') trim(optlevflag(env%optlev)) - write (*, '(2x,''System temperature [K] : '',F5.1)') env%tboltz - write (*, '(2x,''RRHO scaling factor : '',F4.2)') env%freq_scal - write (*, *) - if (env%use_xtbiff) write (*, '(2x,''Use of xTB-IFF standalone requested'')') - -end subroutine write_qcg_setup - -subroutine get_sphere(pr, zmol, r_logical) - use crest_parameters, only : wp - use zdata - - implicit none - type(zmolecule), intent(inout) :: zmol - type(zmolecule) :: dum - logical :: pr - logical :: r_logical !Determines wether r is overwritten or not - real(wp), parameter :: pi43 = 3.1415926540d0*4.0d0/3.0d0 - real(wp), parameter :: pi = 3.1415926540d0 - real(wp), parameter :: third = 1.0d0/3.0d0 - real(wp), parameter :: bohr = 0.52917726d0 - - integer :: i - real*8 :: rad(zmol%nat), xyz_tmp(3, zmol%nat) - real(wp), allocatable :: rcov(:) - - allocate (rcov(94)) - rcov = (/ & - & 2.18230009, 1.73469996, 3.49559999, 3.09820008, 3.21600008, & - & 2.91030002, 2.62249994, 2.48169994, 2.29959989, 2.13739991, & - & 3.70819998, 3.48390007, 4.01060009, 3.79169989, 3.50169992, & - & 3.31069994, 3.10459995, 2.91479993, 4.24109983, 4.10349989, & - & 3.89030004, 3.76419997, 3.72110009, 3.44140005, 3.54620004, & - & 3.44210005, 3.43269992, 3.34619999, 3.30080009, 3.23090005, & - & 3.95790005, 3.86190009, 3.66249990, 3.52679992, 3.36619997, & - & 3.20959997, 4.61759996, 4.47639990, 4.21960020, 4.05970001, & - & 3.85960007, 3.75430012, 3.56900001, 3.46230006, 3.39750004, & - & 3.35249996, 3.33080006, 3.46199989, 4.26230001, 4.18739986, & - & 4.01499987, 3.89010000, 3.73799992, 3.58890009, 5.05670023, & - & 5.18139982, 4.62610006, 4.62010002, 4.57019997, 4.52710009, & - & 4.48960018, 4.45149994, 4.42339993, 4.12430000, 4.24270010, & - & 4.15409994, 4.27939987, 4.24499989, 4.22079992, 4.19859982, & - & 4.01300001, 4.24499989, 4.09800005, 3.98550010, 3.89549994, & - & 3.74900007, 3.44560003, 3.35249996, 3.25640011, 3.35990000, & - & 4.31269979, 4.27640009, 4.11749983, 4.00540018, 3.86439991, & - & 3.72160006, 5.07959986, 4.92939997, 4.70429993, 4.42519999, & - & 4.45940018, 4.39569998, 4.35389996, 4.43410015/) - - do i = 1, zmol%nat - rad(i) = bohr*rcov(zmol%at(i))*1.40 ! scale factor adjusted to rough - xyz_tmp(1:3, i) = bohr*zmol%xyz(1:3, i) - end do - - dum = zmol - dum%xyz = xyz_tmp - - call get_volume(dum, rad) - - zmol%atot = dum%atot/bohr**2 - zmol%vtot = dum%vtot/bohr**3 - - if (r_logical) then - zmol%rtot = zmol%vtot*3.0/4.d0/pi - zmol%rtot = zmol%rtot**(1.d0/3.d0) - end if - - if (pr) then - if (r_logical) then - write (*, '(2x,''molecular radius (Bohr**1):'',F8.2)') zmol%rtot - end if - write (*, '(2x,''molecular area (Bohr**2):'',F8.2)') zmol%atot - write (*, '(2x,''molecular volume (Bohr**3):'',F8.2)') zmol%vtot - end if - - deallocate (rcov) -end subroutine get_sphere - -subroutine cma_shifting(solu, solv) - use iso_fortran_env, wp => real64 - use crest_data - use iomod - use zdata - use strucrd - use axis_module, only: cma - implicit none - - type(zmolecule) :: solu, solv - - integer :: i - - call cma(solu%nat, solu%at, solu%xyz, solu%cma) - call cma(solv%nat, solv%at, solv%xyz, solv%cma) - - do i = 1, solu%nat - solu%xyz(1:3, i) = solu%xyz(1:3, i) - solu%cma(1:3) - end do - do i = 1, solv%nat - solv%xyz(1:3, i) = solv%xyz(1:3, i) - solv%cma(1:3) - end do - -end subroutine cma_shifting - -subroutine get_ellipsoid(env, solu, solv, clus, pr1) - use iso_fortran_env, wp => real64 - use crest_data - use iomod - use zdata - use strucrd - use axis_module - implicit none - - type(systemdata) :: env - type(zmolecule) :: solu, solv, clus - type(zmolecule) :: dummy_solu, dummy_solv - real(wp) :: rabc_solu(3), rabc_solv(3) - real(wp) :: aniso, sola - real(wp) :: rmax_solu, rmax_solv - real(wp) :: boxr, roff, r - character(len=10) :: fname - logical :: ex, pr, pr1 - - real(wp), parameter :: pi43 = 3.1415926540d0*4.0d0/3.0d0 - real(wp), parameter :: pi = 3.1415926540d0 - real(wp), parameter :: third = 1.0d0/3.0d0 - - pr = .false. !Outprint deactivated - - fname = 'eaxis.qcg' - inquire (file=fname, exist=ex) - - if (pr1) then !First time called -!--- Moving all coords to the origin (transformation) - call axistrf(solu%nat, solu%nat, solu%at, solu%xyz) -! call axistrf(solv%nat,solv%nat,solv%at,solv%xyz) !Not done in original QCG code - call axistrf(clus%nat, solu%nat, clus%at, clus%xyz) - -!--- Overwrite solute and solvent coord in original file with transformed and optimized ones - call wrc0('solute', solu%nat, solu%at, solu%xyz) - call wrc0('solvent', solv%nat, solv%at, solv%xyz) - -!--- Getting axis - write (*, *) 'Solute:' - call axis(pr1, solu%nat, solu%at, solu%xyz, solu%eax) - write (*, *) 'Solvent:' - call axis(pr1, solv%nat, solv%at, solv%xyz, solv%eax) - write (*, *) - end if - -!--- Computing anisotropy factor of solute and solvent - sola = sqrt(1.+(solu%eax(1) - solu%eax(3))/((solu%eax(1) + solu%eax(2) + solu%eax(3))/3.)) - aniso = sqrt(1.+(solv%eax(1) - solv%eax(3))/((solv%eax(1) + solv%eax(2) + solv%eax(3))/3.)) ! =1 for a spherical system - -!--- Get maximum intramoleclar distance of solute and solvent - call getmaxrad(solu%nat, solu%at, solu%xyz, rmax_solu) - call getmaxrad(solv%nat, solv%at, solv%xyz, rmax_solv) - -!--- Getting V and A of dummies - dummy_solu = solu - dummy_solv = solv !Why is dummy_solv%vtot different to solv%vtot - call get_sphere(.false., dummy_solu, .false.) - call get_sphere(.false., dummy_solv, .false.) - -!--- Computation of outer Wall - roff = sola*dummy_solu%vtot/1000 - boxr = ((0.5*aniso*clus%nmol*dummy_solv%vtot + dummy_solu%vtot)/pi43)**third + roff + rmax_solv*0.5 !0.5 both - r = (boxr**3/(solu%eax(1)*solu%eax(2)*solu%eax(3)))**third ! volume of ellipsoid = volume of sphere - rabc_solv = solu%eax*r ! outer solvent wall - -!--- Computation of inner wall - roff = sola*dummy_solu%vtot/1000 - boxr = ((sola*dummy_solu%vtot)/pi43)**third + roff + rmax_solu*0.1 !0.1 before - r = (boxr**3/(solu%eax(1)*solu%eax(2)*solu%eax(3)))**third ! volume of ellipsoid = volume of sphere - rabc_solu = solu%eax*r - dummy_solu%ell_abc(1) = solu%eax(1)**2/sum((solu%eax(1:3))**2) - dummy_solu%ell_abc(2) = solu%eax(2)**2/sum((solu%eax(1:3))**2) - dummy_solu%ell_abc(3) = solu%eax(3)**2/sum((solu%eax(1:3))**2) - rabc_solu = dummy_solu%ell_abc*r - - solu%aniso = sola - solv%aniso = aniso - solu%ell_abc = rabc_solu - clus%ell_abc = rabc_solv*env%potscal - - if (pr1) then - write (*, '(2x,''solvent anisotropy :'',4f10.3)') aniso - write (*, '(2x,''solute anisotropy :'',4f10.3)') sola - write (*, '(2x,''roff inner wall :'',4f10.3)') roff - write (*, '(2x,''solute max dist :'',4f10.3)') rmax_solu - write (*, '(2x,''solvent max dist :'',4f10.3)') rmax_solv - write (*, '(2x,''inner unit axis :'',3f10.3)') dummy_solu%ell_abc(1:3) - write (*, '(2x,''inner ellipsoid/Bohr :'',3f10.3)') rabc_solu(1:3) - write (*, '(2x,''scaling factor outer ellipsoid:'',3f10.3)') env%potscal - write (*, '(2x,''outer ellipsoid/Bohr :'',3f10.3)') clus%ell_abc(1:3) - if (env%potscal .gt. 1.0_wp) write & - &(*, '(2x,''!!!WARNING: A SCALING FACTOR LARGER 1.0 IS ONLY FOR MICROSOLVATION RECOMMENDED'')') - write (*, *) - end if - -end subroutine get_ellipsoid - -subroutine getmaxrad(n, at, xyz, r) - use crest_parameters, only : wp - implicit none - real(wp) :: xyz(3, n), r - integer :: n, at(n) - - real(wp) :: rx, ry, rz, rr - integer :: i, j - real(wp), allocatable :: rcov(:) - - allocate (rcov(94)) - rcov = (/ & - & 2.18230009, 1.73469996, 3.49559999, 3.09820008, 3.21600008, & - & 2.91030002, 2.62249994, 2.48169994, 2.29959989, 2.13739991, & - & 3.70819998, 3.48390007, 4.01060009, 3.79169989, 3.50169992, & - & 3.31069994, 3.10459995, 2.91479993, 4.24109983, 4.10349989, & - & 3.89030004, 3.76419997, 3.72110009, 3.44140005, 3.54620004, & - & 3.44210005, 3.43269992, 3.34619999, 3.30080009, 3.23090005, & - & 3.95790005, 3.86190009, 3.66249990, 3.52679992, 3.36619997, & - & 3.20959997, 4.61759996, 4.47639990, 4.21960020, 4.05970001, & - & 3.85960007, 3.75430012, 3.56900001, 3.46230006, 3.39750004, & - & 3.35249996, 3.33080006, 3.46199989, 4.26230001, 4.18739986, & - & 4.01499987, 3.89010000, 3.73799992, 3.58890009, 5.05670023, & - & 5.18139982, 4.62610006, 4.62010002, 4.57019997, 4.52710009, & - & 4.48960018, 4.45149994, 4.42339993, 4.12430000, 4.24270010, & - & 4.15409994, 4.27939987, 4.24499989, 4.22079992, 4.19859982, & - & 4.01300001, 4.24499989, 4.09800005, 3.98550010, 3.89549994, & - & 3.74900007, 3.44560003, 3.35249996, 3.25640011, 3.35990000, & - & 4.31269979, 4.27640009, 4.11749983, 4.00540018, 3.86439991, & - & 3.72160006, 5.07959986, 4.92939997, 4.70429993, 4.42519999, & - & 4.45940018, 4.39569998, 4.35389996, 4.43410015/) - - r = 0 - do i = 1, n - 1 - do j = i + 1, n - rx = xyz(1, i) - xyz(1, j) - ry = xyz(2, i) - xyz(2, j) - rz = xyz(3, i) - xyz(3, j) - rr = sqrt(rx**2 + ry**2 + rz**2) + rcov(at(i)) + rcov(at(j)) - if (rr .gt. r) r = rr - end do - end do - - deallocate (rcov) - -end subroutine getmaxrad - -subroutine ellipsout(fname, n, at, xyz, r1) - use iso_fortran_env, only: wp => real64 - use strucrd, only: i2e - implicit none - - integer :: i - integer :: n, at(n) - real(wp) :: xyz(3, n), r1(3) - real(wp) :: x, y, z, f, rr - character(len=*) :: fname - integer :: ich11 - - open (newunit=ich11, file=fname) - write (ich11, '(a)') '$coord' - do i = 1, n - write (ich11, '(3F24.14,6x,a)') xyz(1, i), xyz(2, i), xyz(3, i), i2e(at(i)) - end do - do i = 1, 500 - call random_number(x) - call random_number(f) - if (f .gt. 0.5) x = -x - call random_number(y) - call random_number(f) - if (f .gt. 0.5) y = -y - call random_number(z) - call random_number(f) - if (f .gt. 0.5) z = -z - rr = sqrt(x*x + y*y + z*z) - x = x*r1(1)/rr - y = y*r1(2)/rr - z = z*r1(3)/rr - write (ich11, '(3F24.14,6x,a2)') x, y, z, 'he' - end do - write (ich11, '(a)') '$end' - close (ich11) - -end subroutine ellipsout - -subroutine both_ellipsout(fname, n, at, xyz, r1, r2) - use iso_fortran_env, only: wp => real64 - use strucrd, only: i2e - implicit none - - integer :: i - integer :: n, at(n) - real(wp) :: xyz(3, n), r1(3) - real(wp), optional :: r2(3) - real(wp) :: x, y, z, f, rr - character(len=*) :: fname - integer :: ich11 - - open (newunit=ich11, file=fname) - write (ich11, '(a)') '$coord' - do i = 1, n - write (ich11, '(3F24.14,6x,a)') xyz(1, i), xyz(2, i), xyz(3, i), i2e(at(i)) - end do - do i = 1, 500 - call random_number(x) - call random_number(f) - if (f .gt. 0.5) x = -x - call random_number(y) - call random_number(f) - if (f .gt. 0.5) y = -y - call random_number(z) - call random_number(f) - if (f .gt. 0.5) z = -z - rr = sqrt(x*x + y*y + z*z) - x = x*r1(1)/rr - y = y*r1(2)/rr - z = z*r1(3)/rr - write (ich11, '(3F24.14,6x,a2)') x, y, z, 'he' - end do - if (present(r2)) then - do i = 1, 100 - call random_number(x) - call random_number(f) - if (f .gt. 0.5) x = -x - call random_number(y) - call random_number(f) - if (f .gt. 0.5) y = -y - call random_number(z) - call random_number(f) - if (f .gt. 0.5) z = -z - rr = sqrt(x*x + y*y + z*z) - x = x*r2(1)/rr - y = y*r2(2)/rr - z = z*r2(3)/rr - write (ich11, '(3F24.14,6x,a2)') x, y, z, 'b' - end do - end if - write (ich11, '(a)') '$end' - close (ich11) - -end subroutine both_ellipsout - -subroutine get_interaction_E(env, solu, solv, clus, iter, E_inter) - use iso_fortran_env, wp => real64 - use crest_data - use iomod - use zdata - use strucrd - implicit none - - type(systemdata) :: env - type(zmolecule), intent(in) :: solu, solv, clus - real(wp) :: e_cluster, e_solute, e_solvent - real(wp) :: E_inter(env%nsolv) ! interaction energy - integer :: iter - logical :: e_there - - call remove('cluster.coord') - -!--- Prepare input coordinate files - call wrc0('cluster.coord', clus%nat, clus%at, clus%xyz) - call wr_cluster_cut('cluster.coord', solu%nat, solv%nat, iter, 'solute_cut.coord', 'solvent_cut.coord') - -!--- Perform single point calculations and recieve energies - call xtb_sp_qcg(env, 'solute_cut.coord') - call grepval('xtb.out', '| TOTAL ENERGY', e_there, e_solute) - if (.not. e_there) write (*, *) 'Solute energy not found' - call xtb_sp_qcg(env, 'solvent_cut.coord') - call grepval('xtb.out', '| TOTAL ENERGY', e_there, e_solvent) - if (.not. e_there) write (*, *) 'Solvent energy not found' - call xtb_sp_qcg(env, 'cluster.coord') - call grepval('xtb.out', '| TOTAL ENERGY', e_there, e_cluster) - if (.not. e_there) write (*, *) 'Cluster energy not found' - - E_inter(iter) = e_cluster - e_solute - e_solvent - -end subroutine get_interaction_E - -subroutine analyze_cluster(nsolv, n, nS, nM, xyz, at, av, last) - use iso_fortran_env, only: wp => real64 - use axis_module, only: cma - implicit none - real(wp) xyz(3, n) - real(wp) av, last - integer n, nS, nM, nsolv, at(n) - real(wp) xyzM(3, nM) - integer atm(nM) - real(wp) xyzS(3, nS) - integer atS(nS) - real(wp) x1(3), x2(3), r - integer i, is, ie - - if (nsolv .eq. 1) return - xyzS(1:3, 1:nS) = xyz(1:3, 1:nS) - atS(1:nS) = at(1:nS) - call cma(nS, atS, xyzS, x1) - - av = 0 - do i = 1, nsolv - is = nS + (i - 1)*nM + 1 - ie = is + nM - 1 - xyzM(1:3, 1:nM) = xyz(1:3, is:ie) - atM(1:nM) = at(is:ie) - call cma(nM, atM, xyzM, x2) - r = sqrt((x1(1) - x2(1))**2 + (x1(2) - x2(2))**2 + (x1(3) - x2(3))**2) - if (i .lt. nsolv) then - av = av + r - else - last = r - end if - end do - av = av/float(nsolv - 1) -end subroutine analyze_cluster - -subroutine aver(pr, env, runs, e_tot, S, H, G, sasa, a_present, a_tot) - use iso_fortran_env, only: wp => real64 - use crest_data - - implicit none -!---- Dummy - type(systemdata), intent(in) :: env - integer, intent(in) :: runs - real(wp), intent(inout) :: e_tot - real(wp), intent(in), optional :: a_tot - real(wp), intent(out) :: S - real(wp), intent(out) :: H - real(wp), intent(out) :: G - real(wp), intent(out) :: sasa -!---- Stack - logical, intent(in) :: pr, a_present - integer :: j, jmin - real(wp) :: A - real(wp) :: e0 - real(wp), allocatable :: de(:) - real(wp), allocatable :: p(:) - real(wp) :: pmax - real(wp) :: eav - real(wp) :: area - real(wp) :: beta - real(wp) :: temp - integer :: ich48 - real(wp), parameter :: eh = 627.509541d0 - dimension e_tot(runs) - dimension a_tot(runs) - - temp = env%tboltz - allocate (de(runs), source=0.0d0) - allocate (p(runs), source=0.0d0) - - beta = 1./(temp*8.314510/4.184/1000.+1.d-14) - e0 = e_tot(1) - de(1:runs) = (e_tot(1:runs) - e0) - call qcg_boltz(env, runs, de, p) - - A = 0 - eav = 0 - pmax = 0 - area = 0 - do j = 1, runs - A = A + p(j)*log(p(j) + 1.d-12) - eav = eav + p(j)*e_tot(j) - if (p(j) .gt. pmax) then - pmax = p(j) - jmin = j - end if - if (a_present) area = area + p(j)*a_tot(j) - end do - sasa = area - S = (1./beta)*A - H = eav - G = eav + S - if (pr) then - open (newunit=ich48, file='population.dat') - write (ich48, '(2x, ''cluster'',2x,''E_norm [Eh]'',2x, ''De [kcal]'', 4x, ''p'')') - do j = 1, runs - if (j .lt. 10) then - write (ich48, '(5x,i0,3x,f11.6,5x,f6.4,3x,f6.4)') j, e_tot(j)/eh, de(j), p(j) - else - write (ich48, '(5x,i0,2x,f11.6,5x,f6.4,3x,f6.4)') j, e_tot(j)/eh, de(j), p(j) - end if - end do - write (ich48, *) - write (ich48, '(''Ensemble free energy [Eh]:'', f20.10)') G/eh - close (ich48) - end if - - deallocate (de, p) - -end subroutine aver - -subroutine qcg_boltz(env, n, e, p) - use iso_fortran_env, only: wp => real64 - use crest_data - implicit none - type(systemdata), intent(in) :: env - integer, intent(in) :: n - real(wp), intent(in) :: e(*) - real(wp), intent(out) :: p(*) - integer :: i - real(wp) :: temp - real(wp) :: f, hsum, esum - - temp = env%tboltz - f = 8.314*temp/4.184d+3 - esum = 0 - do i = 1, n - esum = esum + exp(-e(i)/f) - end do - hsum = 0 - do i = 1, n - p(i) = exp(-e(i)/f)/esum - end do -end subroutine qcg_boltz - -subroutine fill_take(env, n2, n12, rabc, ipos) - use iso_fortran_env, only: wp => real64 - use crest_data - use strucrd - use axis_module, only: cma - implicit none - - type(systemdata) :: env - integer, intent(in) :: n2, n12 - real(wp), intent(in) :: rabc(3) - integer, intent(out) :: ipos - integer :: i, m, n21 - integer :: at2(n2), at12(n12) - integer :: counter - real(wp) :: xyz2(3, n2), xyz12(3, n12) - real(wp) :: etmp(100) - real(wp) :: eabc - real(wp) :: cma2(3) - real(wp), allocatable :: dist(:) - - eabc = 0 - counter = 0 - n21 = n12 - n2 + 1 - if (env%use_xtbiff) then - call rdxtbiffE('xtbscreen.xyz', m, n12, etmp) - else - call rdxtbiffE('best.xyz', m, n12, etmp) - end if - - allocate (dist(m), source=0.0d0) - dist = 0.0d0 - - do i = 1, m - if (env%use_xtbiff) then - call rdxmolselec('xtbscreen.xyz', i, n12, at12, xyz12) - else - call rdxmolselec('final_structures.xyz', i, n12, at12, xyz12) - end if - - at2(1:n2) = at12(n21:n12) - xyz2(1:3, 1:n2) = xyz12(1:3, n21:n12) - call cma(n2, at2, xyz2, cma2) - call calc_dist(cma2, rabc, dist(i), eabc) - if (eabc .gt. 1.0d0) then - dist(i) = 1.0d42 - counter = counter + 1 - end if - end do - - ipos = minloc(dist(1:m), dim=1) - - if (counter .eq. m) ipos = 0 - - deallocate (dist) -end subroutine fill_take - -subroutine calc_dist(xyz, rabc, dist, eabc) - use iso_fortran_env, only: wp => real64 - implicit none - - real(wp), intent(in) :: xyz(3) - real(wp), intent(in) :: rabc(3) - real(wp), intent(out) :: dist - real(wp), intent(out) :: eabc - real(wp) :: center(3), rc(3) - - center = 0.d0 - rc = (xyz(1:3) - center) - dist = norm2(rc) - eabc = sum((xyz(1:3)**2)/(rabc(1:3)**2)) -end subroutine calc_dist - -subroutine sort_min(i, j, col, A) - use iso_fortran_env, only: wp => real64 - implicit none - integer, intent(in) :: i, j, col - real*8, intent(inout) :: A(i, j) - real*8 :: buf(j) - integer :: nsize, irow, krow -! dimension A(i,j) - nsize = i - - do irow = 1, nsize - krow = minloc(A(irow:nsize, col), dim=1) + irow - 1 - buf(:) = A(irow, :) - A(irow, :) = A(krow, :) - A(krow, :) = buf(:) - end do -end subroutine sort_min - -subroutine sort_ensemble(ens, e_ens, fname) - use iso_fortran_env, only: wp => real64 - use crest_data - use strucrd - implicit none - type(ensemble) :: ens - real(wp) :: e_ens(ens%nall), dum(ens%nall) - character(len=*) :: fname - integer :: ich - integer :: i, e_min - - dum = e_ens - - open (newunit=ich, file=fname) - - do i = 1, ens%nall - e_min = minloc(dum, dim=1) - call wrxyz(ich, ens%nat, ens%at, ens%xyz(:, :, e_min), e_ens(e_min)) - dum(e_min) = 0.0d0 - end do - close (ich) - -end subroutine sort_ensemble - -subroutine rdtherm(fname, ht, svib, srot, stra, gt) - use iso_fortran_env, only: wp => real64 - use crest_data - use iomod - - implicit none -! Dummy - real(wp), intent(out) :: ht - real(wp), intent(out) :: gt - real(wp), intent(out) :: svib - real(wp), intent(out) :: srot - real(wp), intent(out) :: stra -! Stack - integer :: nn - integer :: io - integer :: counter - integer :: hg_line - real(wp) :: xx(20) - logical :: ende - character(len=*) :: fname - character(len=128) :: a - real(wp), parameter :: eh = 627.509541d0 - integer :: ich - - ende = .false. - counter = 0 - hg_line = 0 - - open (newunit=ich, file=fname) - do while (.not. ende) - read (ich, '(a)', iostat=io) a - if (io .lt. 0) then - ende = .true. - cycle - end if - if (index(a, 'G(T)/Eh ') .ne. 0) then - hg_line = counter - end if - if (index(a, ' VIB ') .ne. 0) then - call readl(a, xx, nn) - svib = xx(5) - if (svib .eq. 0.0d0) then - call readl(a, xx, nn) - svib = xx(4) - end if - end if - if (index(a, ' ROT ') .ne. 0) then - call readl(a, xx, nn) - srot = xx(4) - end if - if (index(a, ' TR ') .ne. 0) then - call readl(a, xx, nn) - stra = xx(4) - end if - if (counter .eq. hg_line + 2) then - call readl(a, xx, nn) - ht = xx(3)*eh - gt = xx(5)*eh - end if - counter = counter + 1 - end do - close (ich) -end subroutine rdtherm - -subroutine pr_freq_file(ich) - implicit none - integer :: ich - write (ich, '(2x,"# H(T) SVIB SROT STRA G(T)")') - write (ich, '(2x," [kcal/mol] [ cal/mol/K ] [kcal/mol]")') - write (ich, '(2x,"--------------------------------------------------------")') -end subroutine pr_freq_file - -subroutine qcg_restart(env, progress, solu, solv, clus, solu_ens, solv_ens, clus_backup) - use iso_fortran_env, wp => real64 - use crest_data - use iomod - use zdata - use strucrd - - implicit none - - type(systemdata) :: env - type(zmolecule) :: solu, solv, clus, clus_backup - type(ensemble) :: solu_ens, solv_ens - integer :: progress - - integer :: i - character(len=512) :: thispath - character(len=6) :: counter - character(len=7) :: counter2 - character(len=8) :: counter3 - logical :: grow, solu_ensemble, solv_ensemble - logical :: solv_cff, solv_present, freq, tmp, ex - real(wp), allocatable :: xyz(:, :) - real(wp), parameter :: eh = 627.509541d0 - - grow = .false. - solu_ensemble = .false. - solv_ensemble = .false. - solv_cff = .false. - solv_present = .false. - freq = .false. - tmp = .false. - - inquire (file='./grow/cluster.coord', exist=grow) - inquire (file='./ensemble/final_ensemble.xyz', exist=solu_ensemble) - inquire (file='./solvent_ensemble/final_ensemble.xyz', exist=solv_ensemble) - inquire (file='./solvent_ensemble/crest_ensemble.xyz', exist=solv_cff) - inquire (file='./frequencies/result.dat', exist=freq) - - if (solv_cff .or. solv_ensemble) solv_present = .true. - - call getcwd(thispath) - -!--------------------------------------------------------------------------------- -! Check, if everything needed is present -!--------------------------------------------------------------------------------- - - if (freq .and. ((.not. grow) .or. (.not. solu_ensemble) .or. (.not. solv_ensemble))) then - progress = 0 - call rmrf('frequencies') - freq = .false. - end if - - if (solv_present .and. ((.not. grow) .or. (.not. solu_ensemble))) then - progress = 0 - call rmrf('solvent_ensemble') - solv_present = .false. - solv_cff = .false. - solv_ensemble = .false. - end if - - if (solu_ensemble .and. (.not. grow)) then - progress = 0 - call rmrf('ensemble') - solu_ensemble = .false. - end if - -!------------------------------------------------------------- -! Data read out -!------------------------------------------------------------- - -!--- Grow process - if (grow) then - env%qcg_restart = .true. - call chdir('grow') - call rdnat('cluster.coord', clus%nat) - allocate (clus%at(clus%nat), clus%xyz(3, clus%nat)) - call rdcoord('cluster.coord', clus%nat, clus%at, clus%xyz) - clus%nmol = (clus%nat - solu%nat)/solv%nat + 1 - allocate (xyz(3, clus%nat)) - xyz = clus%xyz - call get_ellipsoid(env, solu, solv, clus, .true.) - clus%xyz = xyz !Needed, because get_ellipsoid performs axistransformation and not fitting potential - deallocate (xyz) - - if (.not. env%cff) then - allocate (clus_backup%at(clus%nat)) - allocate (clus_backup%xyz(3, clus%nat)) - clus_backup = clus - end if - - if (clus%nmol - 1 .ge. env%nsolv) then - progress = 1 - env%nsolv = clus%nmol - 1 - write (*, *) - write (*, *) - write (*, '(''Found cluster with '',i0,'' solvents'')') env%nsolv - call chdir(thispath) - else - error stop 'The found cluster is smaller than nsolv. Please restart the whole computaion by removing the grow directory' - !Future implementation continue grow process - call chdir(thispath) - if (solu_ensemble) call rmrf('ensemble') - if (solv_ensemble) call rmrf('solvent_ensemble') - if (freq) call rmrf('frequencies') - solu_ensemble = .false. - solv_ensemble = .false. - freq = .false. - progress = 0 - end if - end if - -!--- Solute Ensemble - if (solu_ensemble) then - call chdir('ensemble') - call solu_ens%open('final_ensemble.xyz') - call rdensemble('final_ensemble.xyz', solu_ens%nat, solu_ens%nall, solu_ens%at, solu_ens%xyz, solu_ens%er) - env%nqcgclust = solu_ens%nall - write (*, '(" Ensemble of solute-cluster found.")') - write (*, '(" Taking all ", i0, " structures")') env%nqcgclust - call grepval('population.dat', 'Ensemble free energy [Eh]:', ex, solu_ens%G) - solu_ens%G = solu_ens%G*eh - write (*, *) 'Solute Ensmeble Free E [kcal/mol]', solu_ens%G - call chdir(thispath) - progress = 2 - end if - -!--- Solvent Ensemble - if (solv_present) then - call chdir('solvent_ensemble') - write (*, '(" Ensemble of solvent-cluster found.")') - - !--- Case CFF - if (solv_cff) then - call solv_ens%open('crest_ensemble.xyz') - do i = 1, solv_ens%nall - if (i .le. 9) then - write (counter, '(''No '',i1)') i - call grepval('cluster_energy.dat', counter, ex, solv_ens%er(i)) - else if (i .le. 99) then - write (counter2, '(''No '',i2)') i - call grepval('cluster_energy.dat', counter2, ex, solv_ens%er(i)) - else - write (counter3, '(''No '',i3)') i - call grepval('cluster_energy.dat', counter3, ex, solv_ens%er(i)) - end if - write (*, *) 'Energy of cluster', i, solv_ens%er(i) - end do - end if - - !--- Case MD/Crest run - if (solv_ensemble) then - call solv_ens%open('final_ensemble.xyz') - call rdensemble('final_ensemble.xyz', solv_ens%nat, solv_ens%nall, solv_ens%at, solv_ens%xyz, solv_ens%er) - end if - call grepval('population.dat', 'Ensemble free energy [Eh]:', ex, solv_ens%G) - solv_ens%G = solv_ens%G*eh - write (*, *) 'solvent ensmeble free E [kcal/mol]', solv_ens%G - call chdir(thispath) - progress = 3 - end if - -!--- Frequencies - if (freq) then - write (*, *) - write (*, *) - write (*, *) ' Nothing to do' - progress = 4 - end if - -end subroutine qcg_restart - -subroutine qcg_cleanup(env) - use crest_data - - implicit none - - type(systemdata) :: env - character(len=280) :: thispath - logical :: tmp - - call getcwd(thispath) - call chdir(env%scratchdir) - inquire (file='./solute_properties/solute', exist=tmp) - if (tmp) then - call rmrf('solute_properties') - call rmrf('solvent_properties') - end if - -end subroutine qcg_cleanup - -subroutine write_reference(env, solu, clus) - use iso_fortran_env, wp => real64 - use crest_data - use zdata, only: zmolecule - use iomod - use strucrd - - implicit none - type(systemdata):: env ! MAIN STORAGE OS SYSTEM DATA - type(zmolecule) :: solu, clus - type(zmolecule) :: ref_mol, ref_clus - - ref_mol = solu - call rdcoord(env%solu_file, ref_mol%nat, ref_mol%at, ref_mol%xyz) !original solute coordinates - call remove(env%fixfile) - ref_clus = clus - ref_clus%xyz(1:3, 1:solu%nat) = solu%xyz - call wrc0(env%fixfile, ref_clus%nat, ref_clus%at, ref_clus%xyz) - -end subroutine write_reference - - -!========================================================================================! -!> Convert given QCG coordinate files into (TM format) -!> Write "solute" and "solvent" coordinate files -!========================================================================================! -subroutine inputcoords_qcg(env, solute, solvent) - use iso_fortran_env,only:wp => real64 - use crest_data - use strucrd - use zdata - use iomod - implicit none - - type(systemdata), intent(inout) :: env - type(zmolecule), intent(out) :: solute, solvent - - logical :: ex11,ex21,solu,solv - type(coord) :: mol - type(zmolecule) :: zmol,zmol1 - integer :: i - -!--------------------Checking for input-------------! - - !Solute - inquire (file=env%solu_file,exist=ex11) - inquire (file='solute',exist=solu) - if (solu) call copy('solute','solute.old') !Backup solute file - if ((.not. ex11) .and. (.not. solu)) then - error stop 'No (valid) solute file! exit.' - else if ((.not. ex11) .and. (solu)) then - env%solu_file = 'solute' - end if - - !Solvent - inquire (file=env%solv_file,exist=ex21) - inquire (file='solvent',exist=solv) - if (solu) call copy('solvent','solvent.old') !Backup solvent file - if ((.not. ex21) .and. (.not. solv)) then - error stop 'No (valid) solvent file! exit.' - else if ((.not. ex11) .and. (solu)) then - env%solu_file = 'solvent' - end if - -!---------------Handling solute---------------------! - call mol%open(env%solu_file) - call mol%write('solute') - solute%nat = mol%nat - solute%at = mol%at - solute%xyz = mol%xyz - call mol%deallocate() - - !--- if the input was a SDF file, special handling - env%sdfformat = .false. - call checkcoordtype(env%solu_file,i) - if (i == 31.or.i == 32) then - !Add sdf stuff here, if somebody needs it - end if - -!---------------Handling solvent---------------------! - - call mol%open(env%solv_file) - call mol%write('solvent') - solvent%nat = mol%nat - solvent%at = mol%at - solvent%xyz = mol%xyz - call mol%deallocate() - - !--- if the input was a SDF file, special handling - env%sdfformat = .false. - call checkcoordtype(env%solv_file,i) - if (i == 31.or.i == 32) then - !Add sdf stuff here, if somebody needs it - end if - - return -end subroutine inputcoords_qcg diff --git a/src/qcg/solvtool_misc.f90 b/src/qcg/solvtool_misc.f90 deleted file mode 100644 index 3ff1ca92..00000000 --- a/src/qcg/solvtool_misc.f90 +++ /dev/null @@ -1,1063 +0,0 @@ -!================================================================================! -! This file is part of crest. -! -! Copyright (C) 2021 Christoph Plett, Sebastian Spicher, Philipp Pracht -! -! crest is free software: you can redistribute it and/or modify it under -! the terms of the GNU Lesser General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! crest is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public License -! along with crest. If not, see . -!================================================================================! - -!-------------------------------------------------------------------------------------------- -! A quick single point xtb calculation without wbo -!-------------------------------------------------------------------------------------------- -subroutine xtb_sp_qcg(env, fname) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - implicit none - character(len=*) :: fname - type(systemdata) :: env - character(len=512) :: jobcall - character(*), parameter :: pipe = ' > xtb.out 2> /dev/null' - integer :: io,T,Tn - call remove('gfnff_topo') - call remove('energy') - call remove('charges') - call remove('xtbrestart') - -!---- setting threads - call new_ompautoset(env,'auto',1,T,Tn) - -!---- jobcall - write (jobcall, '(a,1x,a,1x,a,'' --sp '',a,1x,a)') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), trim(env%solv), trim(pipe) - - call command(trim(jobcall), io) -!---- cleanup - call remove('energy') - call remove('charges') - call remove('xtbrestart') - call remove('xtbtopo.mol') - call remove('gfnff_topo') -end subroutine xtb_sp_qcg - -!-------------------------------------------------------------------------------------------- -! A quick single xtb optimization gets zmol and overwrites it with optimized stuff -!-------------------------------------------------------------------------------------------- -subroutine xtb_opt_qcg(env, zmol, constrain) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use zdata - use strucrd - - implicit none - type(systemdata), intent(in) :: env - type(zmolecule), intent(inout) :: zmol - - character(:), allocatable :: fname - character(len=512) :: jobcall - logical :: constrain - logical :: const - character(*), parameter :: pipe = ' > xtb_opt.out 2> /dev/null' - integer :: io,T,Tn - -!--- Write coordinated - fname = 'coord' - call wrc0(fname, zmol%nat, zmol%at, zmol%xyz) !write coord for xtbopt routine - -!---- setting threads - call new_ompautoset(env,'auto',1,T,Tn) - -!---- jobcall & Handling constraints - if(constrain .AND. env%cts%used) then - call write_constraint(env, fname, 'xcontrol') - call wrc0('coord.ref', zmol%nat, zmol%at, zmol%xyz) !write coord for xtbopt routine - write (jobcall, '(a,1x,a,1x,a,'' --opt --input xcontrol '',a,1x,a)') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), trim(env%solv), trim(pipe) - else - write (jobcall, '(a,1x,a,1x,a,'' --opt '',a,1x,a)') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), trim(env%solv), trim(pipe) - end if - - call command(trim(jobcall), io) -!---- cleanup - call rdcoord('xtbopt.coord', zmol%nat, zmol%at, zmol%xyz) - call remove('energy') - call remove('charges') - call remove('xtbrestart') - call remove('xtbtopo.mol') - call remove('gfnff_topo') -end subroutine xtb_opt_qcg - -!___________________________________________________________________________________ -! -! An xTB single point calculation and lmo generation on all available threads -!___________________________________________________________________________________ - -subroutine xtb_lmo(env, fname)!,chrg) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use zdata - implicit none - type(systemdata) :: env - character(len=*), intent(in) :: fname - character(len=80) :: pipe - character(len=512) :: jobcall - integer :: T,Tn,io - - pipe = ' > xtb.out 2>/dev/null' - -!---- setting threads - call new_ompautoset(env,'auto',1,T,Tn) - -!---- jobcall, special gbsa treatment not needed, as the entire flag is included in env%solv - write (jobcall, '(a,1x,a,1x,a,'' --sp --lmo '',a)') & - & trim(env%ProgName), trim(fname), trim(env%lmover), trim(pipe) - call command(trim(jobcall), exitstat=io) - - if(io /= 0)then - write(*,*) 'error in xtb_lmo' - stop - endif - -!--- cleanup - call remove('wbo') - call remove('charges') - call remove('xtbrestart') - call remove('xtbscreen.xyz') - call remove('lmocent.coord') - call remove('coordprot.0') -end subroutine xtb_lmo - -!___________________________________________________________________________________ -! -! An xTB-IFF calculation on all available threads -!___________________________________________________________________________________ - -subroutine xtb_iff(env, file_lmo1, file_lmo2, solu, clus) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use zdata - - implicit none - - type(systemdata) :: env - type(zmolecule), intent(in) :: solu, clus - character(len=80) :: pipe - character(len=512) :: jobcall - character(len=*) :: file_lmo1, file_lmo2 - integer :: T,Tn - -!--- Option setting - pipe = ' > iff.out 2>/dev/null' - -!--- Setting threads - call new_ompautoset(env,'auto',1,T,Tn) - -!--- Jobcall - if (env%sameRandomNumber) then - write (jobcall, '(a,1x,a,1x,a,'' -nfrag1 '',i3,'' -ellips '',3f9.3,'' -qcg -test '',a)') & - & trim(env%ProgIFF), trim(file_lmo1), trim(file_lmo2), solu%nat, clus%ell_abc, trim(pipe) - else - write (jobcall, '(a,1x,a,1x,a,'' -nfrag1 '',i3,'' -ellips '',3f9.3,'' -qcg '',a)') & - & trim(env%ProgIFF), trim(file_lmo1), trim(file_lmo2), solu%nat, clus%ell_abc, trim(pipe) -! & trim(env%ProgIFF),trim(solvent_file),trim(solute_file),solu%nat,clus%ell_abc,trim(pipe) - end if - call command(trim(jobcall)) - -!--- Cleanup - call remove('xtbiff_bestsofar.xyz') - call remove('xtbiff_genstart.xyz') - call remove('xtbrestart') - -end subroutine xtb_iff - -!___________________________________________________________________________________ -! -! An xTB docking on all available threads -!___________________________________________________________________________________ - -subroutine xtb_dock(env, fnameA, fnameB, solu, clus) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use zdata - - implicit none - - type(systemdata) :: env - type(zmolecule), intent(in) :: solu, clus - character(len=*), intent(in) :: fnameA, fnameB - character(len=80) :: pipe - character(len=512) :: jobcall - integer :: i, ich, T, Tn - - call remove('xtb_dock.out') - call remove('xcontrol') - - pipe = ' 2>/dev/null' - -!---- writing wall pot in xcontrol - call write_wall(env, solu%nat, solu%ell_abc, clus%ell_abc, 'xcontrol') - -!---- Write directed stuff, if requested - if (allocated(env%directed_file)) then - do i=1, size(env%directed_number) - if & - & ((i==1 .and. env%directed_number(i) >= clus%nmol) .OR. & - & (env%directed_number(i) >= clus%nmol .and. env%directed_number(i-1) < clus%nmol)) & - & then - open(newunit=ich, file='xcontrol', status='old', position='append', action='write') - write(ich,'("$directed")') - write(ich,'(a,1x,a)') 'atoms:', trim(env%directed_list(i,1)) - write(ich,'("$end")') - end if - end do - end if - -!--- Setting threads - call new_ompautoset(env,'auto',1,T,Tn) - -!--- Jobcall docking - write (jobcall, '(a,1x,''dock'',1x,a,1x,a,1x,a,1x,f4.2,1x,''--nfrag1'',1x,i0,1x,a,1x, & - & ''--input xcontrol > xtb_dock.out'',a)') & - & trim(env%ProgName), trim(fnameA), trim(fnameB), trim(env%gfnver),& - & env%optlev, solu%nat, trim(env%docking_qcg_flag), trim(pipe) - call command(trim(jobcall)) - -! cleanup - call remove('wbo') - call remove('charges') - call remove('xtbrestart') - -end subroutine xtb_dock - -!___________________________________________________________________________________ -! -! An xTB optimization on all available threads -!___________________________________________________________________________________ - -subroutine opt_cluster(env, solu, clus, fname, without_pot) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use zdata - - implicit none - - type(systemdata) :: env - type(zmolecule), intent(in) :: solu, clus - character(len=*), intent(in) :: fname - logical, optional, intent(in) :: without_pot - character(len=80) :: pipe - character(len=:),allocatable :: jobcall - integer :: T,Tn - - if (env%niceprint) then - call printprogbar(0.0_wp) - end if - - call remove('xtb.out') - pipe = ' 2>/dev/null' - -!---- writing wall pot in xcontrol - if (.not. without_pot) then - call write_wall(env, solu%nat, solu%ell_abc, clus%ell_abc, 'xcontrol') - end if - -!--- Setting threads - call new_ompautoset(env,'subprocess',1,T,Tn) - -!--- Jobcall optimization - jobcall = trim(env%ProgName)//' '//trim(fname)//' --opt '//optlevflag(env%optlev) - jobcall = trim(jobcall)//' '//trim(env%gfnver) - if(without_pot)then - jobcall = trim(jobcall)//' '//trim(env%solv) - endif - jobcall = trim(jobcall)//' > xtb_opt.out 2>/dev/null' - call command(trim(jobcall)) - -! cleanup - call remove('wbo') - call remove('charges') - call remove('xtbrestart') - -!--- Jobcall SP for gbsa model - if (.not. without_pot) then - jobcall = trim(env%ProgName)//' xtbopt.coord --sp '//trim(env%gfnver) - jobcall = trim(jobcall)//' '//trim(env%solv) - jobcall = trim(jobcall)//' > xtb_sp.out 2>/dev/null' - end if - call command(trim(jobcall)) - -! cleanup - call remove('wbo') - call remove('charges') - call remove('xtbrestart') - -end subroutine opt_cluster - -!___________________________________________________________________________________ -! -! xTB LMO calculation performed in parallel -!___________________________________________________________________________________ - -subroutine ensemble_lmo(env, fname, self, NTMP, TMPdir, conv) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use zdata - - implicit none - type(systemdata) :: env - type(zmolecule), intent(in) :: self - character(len=*), intent(in) :: fname !file base name - character(len=*), intent(in) :: TMPdir !directory name - integer, intent(in) :: NTMP !number of structures to be optimized - integer, intent(in) :: conv(env%nqcgclust + 1) - integer :: i, k,T, Tn - integer :: vz - character(len=20) :: pipe - character(len=512) :: thispath, tmppath - character(len=1024) :: jobcall - real(wp) :: percent - -! setting the threads for correct parallelization - call new_ompautoset(env,'auto',NTMP,T,Tn) - - pipe = '2>/dev/null' - - !create the system call (it is the same for every optimization) - - write (jobcall, '(a,1x,a,1x,a,'' --sp --lmo --chrg '',f4.1,1x,a,'' >xtb_lmo.out'')') & - & trim(env%ProgName), trim(fname), trim(env%lmover), self%chrg, trim(pipe) - k = 0 !counting the finished jobs -!___________________________________________________________________________________ - -!$omp parallel & -!$omp shared( vz,jobcall,NTMP,percent,k,TMPdir,conv ) -!$omp single - do i = 1, NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath ) - write (tmppath, '(a,i0)') trim(TMPdir), conv(vz) - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical - k = k + 1 - percent = float(k)/float(NTMP)*100 - !$omp end critical - !$omp end task - end do -!$omp taskwait -!$omp end single -!$omp end parallel - -!___________________________________________________________________________________ - - call getcwd(thispath) - do i = 1, NTMP - write (tmppath, '(a,i0)') trim(TMPdir), i - call chdir(trim(tmppath)) - call remove('xtbrestart') - call chdir(trim(thispath)) - end do - -end subroutine ensemble_lmo - -!___________________________________________________________________________________ -! -! xTB-IFF calculation performed in parallel -!___________________________________________________________________________________ - -subroutine ensemble_iff(env, outer_ell_abc, nfrag1, frag1_file, frag2_file, NTMP, TMPdir, conv) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use zdata - - implicit none - type(systemdata) :: env - - character(len=*), intent(in) :: TMPdir !directory name - integer, intent(in) :: NTMP !number of structures to be optimized - integer, intent(in) :: nfrag1 !#atoms of larger fragment - integer, intent(in) :: conv(env%nqcgclust + 1) - real(wp), intent(in) :: outer_ell_abc(env%nqcgclust, 3) - - integer :: i, k - integer :: vz,T,Tn - character(len=20) :: pipe - character(len=512) :: tmppath - character(len=1024) :: jobcall - character(len=64), intent(in) :: frag1_file - character(len=64), intent(in) :: frag2_file - character(len=64) :: frag1 - character(len=64) :: frag2 - real(wp) :: percent - -! some options - pipe = '2>/dev/null' - frag1 = 'solvent_cluster.lmo' - frag2 = 'solvent.lmo' - -! setting the threads for correct parallelization - call new_ompautoset(env,'auto',NTMP,T,Tn) - - k = 0 !counting the finished jobs - -!___________________________________________________________________________________ - -!$omp parallel & -!$omp shared( vz,NTMP,percent,k,TMPdir,conv ) -!$omp single - do i = 1, NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath,jobcall ) -! create the system call - write (jobcall, '(a,1x,a,1x,a,'' -nfrag1 '',i3,'' -ellips '',3f9.3,'' -qcg '',a,'' >iff.out'')') & -& trim(env%ProgIFF), trim(frag1_file), trim(frag2_file), nfrag1, outer_ell_abc(conv(vz), 1:3)*0.9, trim(pipe) - write (tmppath, '(a,i0)') trim(TMPdir), conv(vz) - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical - k = k + 1 - percent = float(k)/float(NTMP)*100 - !$omp end critical - !$omp end task - end do -!$omp taskwait -!$omp end single -!$omp end parallel - -!___________________________________________________________________________________ - -end subroutine ensemble_iff - -!___________________________________________________________________________________ -! -! xTB docking calculation performed in parallel -!___________________________________________________________________________________ - -subroutine ensemble_dock(env, outer_ell_abc, nfrag1, frag1_file, frag2_file, n_shell& - &, n_solvent, NTMP, TMPdir, conv) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use zdata - - implicit none - type(systemdata) :: env - - character(len=*), intent(in) :: TMPdir !directory name - integer, intent(in) :: NTMP !number of structures to be optimized - integer, intent(in) :: nfrag1 !#atoms of larger fragment - integer, intent(in) :: conv(env%nqcgclust + 1) - real(wp), intent(in) :: outer_ell_abc(env%nqcgclust, 3) - integer, intent(in) :: n_shell, n_solvent - - integer :: i, k - integer :: vz, T,Tn - character(len=20) :: pipe - character(len=1024) :: jobcall - character(len=512) :: thispath, tmppath - character(len=*), intent(in) :: frag1_file - character(len=*), intent(in) :: frag2_file - character(len=64) :: frag1 - character(len=64) :: frag2 - real(wp) :: percent - character(len=2) :: flag - integer :: ich31 - -! some options - pipe = '2>/dev/null' - frag1 = 'solvent_cluster.coord' - frag2 = 'solvent' - call getcwd(thispath) - -! setting the threads for correct parallelization - call new_ompautoset(env,'auto',NTMP,T,Tn) - - write (jobcall, '(a,1x,''dock'',1x,a,1x,a,1x,a,1x,f4.2,1x,''--nfrag1'',1x,i0,1x,& - & ''--input xcontrol --fast > xtb_dock.out '',a)') & - & trim(env%ProgName), trim(frag1_file), trim(frag2_file),& - & trim(env%gfnver), env%optlev, nfrag1, trim(pipe) - - flag = '$' - do i = 1, NTMP - vz = i - write (tmppath, '(a,i0)') trim(TMPdir), conv(i) - call chdir(trim(tmppath)) - open (newunit=ich31, file='xcontrol') - write (ich31, '(a,"fix")') trim(flag) - write (ich31, '(3x,"atoms: 1-",i0)') n_shell !Initial number of atoms (starting solvent shell) - write (ich31, '(a,"wall")') trim(flag) - write (31, '(3x,"potential=polynomial")') - write (ich31, '(3x,"ellipsoid:",1x,3(g0,",",1x),i0,"-",i0)') outer_ell_abc(conv(vz), :), & - & n_shell + 1, n_shell + n_solvent !Initial number of atoms (starting solvent shell) - close (ich31) - call chdir(trim(thispath)) - end do - - k = 0 !counting the finished jobs - -!___________________________________________________________________________________ - -!$omp parallel & -!$omp shared( vz,NTMP,percent,k,TMPdir,conv,n_shell,n_solvent,jobcall ) -!$omp single - do i = 1, NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath ) - write (tmppath, '(a,i0)') trim(TMPdir), conv(vz) - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical - k = k + 1 - percent = float(k)/float(NTMP)*100 - !$omp end critical - !$omp end task - end do - -!$omp taskwait -!$omp end single -!$omp end parallel - -!___________________________________________________________________________________ - call chdir(trim(thispath)) - -end subroutine ensemble_dock - -!___________________________________________________________________________________ -! -! xTB CFF optimization performed in parallel -!___________________________________________________________________________________ - -subroutine cff_opt(postopt, env, fname, n12, NTMP, TMPdir, conv, nothing_added) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use strucrd - implicit none - - type(systemdata) :: env - character(len=*), intent(in) :: fname !file base name - character(len=*), intent(in) :: TMPdir !directory name - integer, intent(inout) :: NTMP !number of structures to be optimized - integer, intent(inout) :: conv(env%nqcgclust + 1) - logical, intent(in) :: postopt - logical, intent(in) :: nothing_added(env%nqcgclust) - integer :: i, k, n12 - integer :: vz,T,Tn - integer :: ich31 - character(len=20) :: pipe - character(len=512) :: thispath, tmppath - character(len=1024) :: jobcall - character(len=2) :: flag - real(wp) :: percent - -! setting the threads for correct parallelization - call new_ompautoset(env,'auto',NTMP,T,Tn) - - if (postopt) then - write (*, '(2x,''Starting optimizations + SP of structures'')') - write (*, '(2x,i0,'' jobs to do.'')') NTMP - end if - -! postopt eq true => post opt run, which has to be performed in every directory !!! - if (postopt) then - k = 0 - NTMP = env%nqcgclust - do i = 1, env%nqcgclust - k = k + 1 - conv(k) = i - conv(env%nqcgclust + 1) = k - end do - end if - pipe = '2>/dev/null' - - call getcwd(thispath) - do i = 1, NTMP - write (tmppath, '(a,i0)') trim(TMPdir), conv(i) - call chdir(trim(tmppath)) - open (newunit=ich31, file='xcontrol') - if (n12 .ne. 0) then - flag = '$' - write (ich31, '(a,"fix")') trim(flag) - write (ich31, '(3x,"atoms: 1-",i0)') n12 !Initial number of atoms (starting solvent shell) - end if - close (ich31) - if (postopt .and. nothing_added(i)) call remove('xcontrol') - call chdir(trim(thispath)) - end do - -!--- Jobcall - write (jobcall, '(a,1x,a,1x,a,'' --input xcontrol --opt '',i0,1x,a,'' >xtb.out'')') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), nint(env%optlev), trim(pipe) - - if (NTMP .lt. 1) then - write (*, '(2x,"No structures to be optimized")') - return - end if - - k = 0 !counting the finished jobs - if (postopt) call printprogbar(0.0_wp) -!___________________________________________________________________________________ - -!$omp parallel & -!$omp shared( vz,jobcall,NTMP,percent,k,TMPdir,conv ) -!$omp single - do i = 1, NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath ) - write (tmppath, '(a,i0)') trim(TMPdir), conv(vz) - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical - k = k + 1 - percent = float(k)/float(NTMP)*100 - if (postopt) then - call printprogbar(percent) - end if - !$omp end critical - !$omp end task - end do -!$omp taskwait -!$omp end single -!$omp end parallel - -!__________________________________________________________________________________ - - do i = 1, NTMP - write (tmppath, '(a,i0)') trim(TMPdir), conv(i) - call chdir(trim(tmppath)) - call remove('xtbrestart') - call chdir(trim(thispath)) - end do - - !create the system call for sp (needed for gbsa model) - write (jobcall, '(a,1x,a,1x,a,'' --sp '',a,1x,a,'' >xtb_sp.out'')') & - & trim(env%ProgName), 'xtbopt.coord', trim(env%gfnver), trim(env%solv), trim(pipe) - - if (NTMP .lt. 1) then - write (*, '(2x,"Nothing to do")') - return - end if - - k = 0 !counting the finished jobs - if (postopt) call printprogbar(0.0_wp) -!___________________________________________________________________________________ - -!$omp parallel & -!$omp shared( vz,jobcall,NTMP,percent,k,TMPdir,conv ) -!$omp single - do i = 1, NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath ) - write (tmppath, '(a,i0)') trim(TMPdir), conv(vz) - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical - k = k + 1 - percent = float(k)/float(NTMP)*100 - if (postopt) then - call printprogbar(percent) - end if - !$omp end critical - !$omp end task - end do -!$omp taskwait -!$omp end single -!$omp end parallel - -!___________________________________________________________________________________ - - do i = 1, NTMP - write (tmppath, '(a,i0)') trim(TMPdir), conv(i) - call chdir(trim(tmppath)) - call remove('xtbrestart') - !call remove('xcontrol') - call chdir(trim(thispath)) - end do - - if (postopt) then - write (*, *) '' - write (*, '(2x,"done.")') - end if - -end subroutine cff_opt - -!___________________________________________________________________________________ -! -! xTB SP performed in parallel -!___________________________________________________________________________________ - -subroutine ens_sp(env, fname, NTMP, TMPdir) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use strucrd - implicit none - - type(systemdata) :: env - character(len=*), intent(in) :: fname !file base name - character(len=*), intent(in) :: TMPdir !directory name - integer, intent(inout) :: NTMP !number of structures to be optimized - - integer :: i, k - integer :: vz, T, Tn - character(len=20) :: pipe - character(len=512) :: thispath, tmppath - character(len=1024) :: jobcall - real(wp) :: percent - -! setting the threads for correct parallelization - call new_ompautoset(env,'auto',NTMP,T,Tn) - - write (*, '(2x,''Single point computation with GBSA model'')') - write (*, '(2x,i0,'' jobs to do.'')') NTMP - - pipe = '2>/dev/null' - - call getcwd(thispath) - - if (NTMP .lt. 1) then - write (*, '(2x,"No structures to be optimized")') - return - end if - -!--- Jobcall - write (jobcall, '(a,1x,a,1x,a,'' --sp '',a,1x,a,'' > xtb_sp.out'')') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), trim(env%solv), trim(pipe) - - k = 0 !counting the finished jobs - call printprogbar(0.0_wp) -!___________________________________________________________________________________ - -!$omp parallel & -!$omp shared( vz,NTMP,percent,k,TMPdir,jobcall ) -!$omp single - do i = 1, NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath ) - call initsignal() - !$omp critical - write (tmppath, '(a,i0)') trim(TMPdir), vz - !$omp end critical - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical - k = k + 1 - percent = float(k)/float(NTMP)*100 - call printprogbar(percent) - !$omp end critical - !$omp end task - end do -!$omp taskwait -!$omp end single -!$omp end parallel - -!__________________________________________________________________________________ - - do i = 1, NTMP - write (tmppath, '(a,i0)') trim(TMPdir), i - call chdir(trim(tmppath)) - call remove('xtbrestart') - call chdir(trim(thispath)) - end do - write (*, *) '' - write (*, '(2x,"done.")') - -end subroutine ens_sp - -!___________________________________________________________________________________ -! -! xTB Freq compuatation performed in parallel -!___________________________________________________________________________________ - -subroutine ens_freq(env, fname, NTMP, TMPdir, opt) - use iso_fortran_env, only: wp => real64 - use iomod - use crest_data - use strucrd - implicit none - - type(systemdata) :: env - character(len=*), intent(in) :: fname !file base name - character(len=*), intent(in) :: TMPdir !directory name - integer, intent(inout) :: NTMP !number of structures to be optimized - - integer :: i, k - integer :: vz, T,Tn - character(len=20) :: pipe - character(len=512) :: thispath, tmppath - character(len=1024) :: jobcall - real(wp) :: percent - logical :: opt - -! setting the threads for correct parallelization - call new_ompautoset(env,'auto',NTMP,T,Tn) - - write (*, '(2x,''Starting reoptimizations + Frequency computation of ensemble'')') - write (*, '(2x,i0,'' jobs to do.'')') NTMP - - pipe = '2>/dev/null' - - call getcwd(thispath) - - if (NTMP .lt. 1) then - write (*, '(2x,"No structures to be optimized")') - return - end if - - k = 0 !counting the finished jobs - call printprogbar(0.0_wp) - -!--- Jobcall - if (.not. opt) then - write (jobcall, '(a,1x,a,1x,a,'' --hess '',a,'' >xtb_freq.out'')') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), trim(pipe) - else - write (jobcall, '(a,1x,a,1x,a,'' --ohess '',a,'' >xtb_freq.out'')') & - & trim(env%ProgName), trim(fname), trim(env%gfnver), trim(pipe) - end if - -!___________________________________________________________________________________ - -!$omp parallel & -!$omp shared( vz,NTMP,percent,k,TMPdir,jobcall ) -!$omp single - do i = 1, NTMP - vz = i - !$omp task firstprivate( vz ) private( tmppath ) - write (tmppath, '(a,i0)') trim(TMPdir), i - call command('cd '//trim(tmppath)//' && '//trim(jobcall)) - !$omp critical - k = k + 1 - percent = float(k)/float(NTMP)*100 - call printprogbar(percent) - !$omp end critical - !$omp end task - end do -!$omp taskwait -!$omp end single -!$omp end parallel - -!__________________________________________________________________________________ - - do i = 1, NTMP - write (tmppath, '(a,i0)') trim(TMPdir), i - call chdir(trim(tmppath)) - call remove('xtbrestart') - call chdir(trim(thispath)) - end do - write (*, *) '' - write (*, '(2x,"done.")') - -end subroutine ens_freq - -!============================================================! -! Read the Energies from a xtbiff output -!============================================================! - -subroutine rdxtbiffE(fname, m, n, e) - - implicit none - integer :: m, n - character(len=*),intent(in) :: fname - real*8 :: e(*) - - character(len=128) :: line - real*8 :: xx(10) - integer :: ich, i, j, nn - - open (newunit=ich, file=fname) - - j = 1 -10 continue - read (ich, '(a)', end=999) line - read (ich, '(a)') line - call readl(line, xx, nn) - e(j) = xx(1) - do i = 1, n - read (ich, '(a)') line - end do - j = j + 1 - goto 10 - -999 close (ich) - m = j - 1 -end - -!============================================================! -! subroutine wr_cluster_cut -! Cuts a cluster file and and writes the parts -! -! On Input: fname - name of the coord file -! n1 - number of atoms fragment1 -! n2 - number of atmos fragment2 -! iter - number of solvent molecules -! fname_solu_cut - name of outputfile fragment1 -! fname_solv_cut - name of outputfile fragment2 -! -!============================================================! - -subroutine wr_cluster_cut(fname_cluster, n1, n2, iter, fname_solu_cut, fname_solv_cut) - use iso_fortran_env, only: wp => real64 - use strucrd - - implicit none - integer, intent(in) :: n1, n2, iter - real(wp) :: xyz1(3, n1) - real(wp) :: xyz2(3, n2*iter) - integer :: at1(n1), at2(n2*iter) - character(len=*), intent(in) :: fname_cluster, fname_solu_cut, fname_solv_cut - character(len=256) :: atmp - character(len=2) :: a2 - integer :: ich, i, k, stat, io, io2 - - ich = 142 - open (unit=ich, file=fname_cluster, iostat=stat) - read (ich, '(a)') atmp - k = 1 - do i = 1, n1 - read (ich, '(a)', iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - call coordline(atmp, a2, xyz1(1:3, k), io2) - at1(k) = e2i(a2) - k = k + 1 - end do - k = 1 - do i = 1, n2*iter - read (ich, '(a)', iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - call coordline(atmp, a2, xyz2(1:3, k), io2) - at2(k) = e2i(a2) - k = k + 1 - end do - - call wrc0(fname_solu_cut, n1, at1, xyz1) - call wrc0(fname_solv_cut, n2*iter, at2, xyz2) - close (ich) - -end subroutine wr_cluster_cut - -subroutine check_iff(neg_E) - use iso_fortran_env, only: wp => real64 - use crest_data - - implicit none - integer :: io, ich - real(wp) :: int_E - character(len=50) :: tmp - logical, intent(out) :: neg_E - - logical :: ex - character(len=*), parameter :: filename = 'xtbscreen.xyz' - - neg_E = .false. - int_E = 0.0_wp - - inquire (file=filename, exist=ex) - if (.not. ex) return - - open (newunit=ich, file=filename, status="old", iostat=io) - if (io == 0) read (ich, '(a)', iostat=io) - if (io == 0) read (ich, '(a)', iostat=io) tmp - close (ich) - if (io /= 0) return - - tmp = adjustl(tmp(11:)) - read (tmp, *, iostat=io) int_E - neg_E = io == 0 .and. int_E < 0.0_wp - -end subroutine check_iff - -!---------------------------------------------------------------------------- -! write a wall potential in a file used as xtb input - -subroutine write_wall(env,n1,rabc1,rabc12,fname) - use iso_fortran_env, only : wp => real64 - use crest_data - - implicit none - - type(systemdata) :: env - integer, intent(in) :: n1 - real(wp),intent(in) :: rabc1(3),rabc12(3) - character (len=8) :: flag - character(len=*) :: fname - - open(unit=31,file=fname) - flag='$' - write(31,'(a,"wall")') trim(flag) - write(31,'(3x,"potential=polynomial")') - write(31,'(3x,"ellipsoid:",1x,3(g0,",",1x),"all")') rabc12 - write(31,'(3x,"ellipsoid:",1x,3(g0,",",1x),"1-",i0)') rabc1,n1 - if(env%constrain_solu) then - write(31,'("$fix")') - write(31,'(3x,"atoms: 1-",i0)') n1 - end if - call write_cts(31,env%cts) - call write_cts_biasext(31,env%cts) - if(env%cts%used) then !Only, if user set constrians is an $end written - write(31,'(a)') '$end' - end if - - close(31) - -end subroutine write_wall - -subroutine check_dock(neg_E) - use iso_fortran_env, only: wp => real64 - use crest_data - use iomod, only: minigrep, grepval - - implicit none - real(wp) :: int_E - logical, intent(out) :: neg_E - logical :: ex - character(len=*), parameter :: filename = 'xtbscreen.xyz' - - neg_E = .false. - int_E = 0.0_wp - - call minigrep('xtb_dock.out', ' Lowest Interaction Energy: ********** kcal/mol', ex) - if (ex) return - - call grepval('xtb_dock.out', 'Lowest Interaction Energy:', ex, int_E) - - if (ex .and. int_E < 0.0_wp) neg_E = .true. - -end subroutine check_dock - -subroutine write_constraint(env,coord_name,fname) - use iso_fortran_env, only : wp => real64 - use crest_data - use iomod - - implicit none - - type(systemdata) :: env - character(len=*),intent(in) :: fname, coord_name - - call copysub(coord_name, 'coord.ref') - open(unit=31,file=fname) - call write_cts(31,env%cts) - call write_cts_biasext(31,env%cts) - if(env%cts%used) then !Only, if user set constrians is an $end written - write(31,'(a)') '$end' - end if - - close(31) - -end subroutine write_constraint diff --git a/src/qcg/volume.f90 b/src/qcg/volume.f90 index 01e726c9..11d402f8 100644 --- a/src/qcg/volume.f90 +++ b/src/qcg/volume.f90 @@ -22,603 +22,596 @@ ! Jaroslav Skrivánek, Ming-Chya Wu ! Comput. Phys. Commun. 165(2005)59 -subroutine get_volume(zmol, rad) - use iso_fortran_env, wp => real64 - use zdata - implicit none - type(Zmolecule), intent(inout) :: zmol - real(wp), intent(in) :: rad(zmol%nat) - real(wp), allocatable :: xyz_rad(:, :) - integer, allocatable :: neigh_list(:) - integer, allocatable :: neigh_index(:) - integer, allocatable :: neigh_type(:) - real(wp) :: va_part(2) - integer :: i - - allocate (xyz_rad(zmol%nat, 4), neigh_list(zmol%nat), neigh_index(zmol%nat)) - allocate (neigh_type(zmol%nat**2)) - - zmol%vtot = 0d0 - zmol%atot = 0d0 +subroutine get_volume(mol,rad) + use crest_parameters + use qcg_coord_type + implicit none + type(coord_qcg),intent(inout) :: mol + real(wp),intent(in) :: rad(mol%nat) + real(wp),allocatable :: xyz_rad(:,:) + integer,allocatable :: neigh_list(:) + integer,allocatable :: neigh_index(:) + integer,allocatable :: neigh_type(:) + real(wp) :: va_part(2) + integer :: i + + allocate (xyz_rad(mol%nat,4),neigh_list(mol%nat),neigh_index(mol%nat)) + allocate (neigh_type(mol%nat**2)) + + mol%vtot = 0d0 + mol%atot = 0d0 !--- Copying Input - do i = 1, zmol%nat - xyz_rad(i, 1:3) = zmol%xyz(1:3, i) - xyz_rad(i, 4) = rad(i) - end do + do i = 1,mol%nat + xyz_rad(i,1:3) = mol%xyz(1:3,i) + xyz_rad(i,4) = rad(i) + end do !--- Checking neighbors (different to usual CREST neighbors to account for more atoms) - call create_neigh(zmol%nat, xyz_rad, neigh_list, & - & neigh_index, neigh_type) + call create_neigh(mol%nat,xyz_rad,neigh_list, & + & neigh_index,neigh_type) !--- Compute V and A - do i = 1, zmol%nat - call calcVA(i, xyz_rad, neigh_list, neigh_index, & - & neigh_type, zmol%nat, va_part) - zmol%vtot = zmol%vtot + va_part(1) - zmol%atot = zmol%atot + va_part(2) - end do + do i = 1,mol%nat + call calcVA(i,xyz_rad,neigh_list,neigh_index, & + & neigh_type,mol%nat,va_part) + mol%vtot = mol%vtot+va_part(1) + mol%atot = mol%atot+va_part(2) + end do - deallocate (xyz_rad, neigh_type, neigh_index) - deallocate (neigh_list) + deallocate (xyz_rad,neigh_type,neigh_index) + deallocate (neigh_list) - return + return end subroutine get_volume -subroutine create_neigh(nat, xyz_rad, neigh_list, neigh_index, neigh_type) - use iso_fortran_env, wp => real64 - implicit none - - integer, intent(in) :: nat - real(wp), intent(in) :: xyz_rad(nat, 4) - integer :: neigh_list(nat), neigh_index(nat), neigh_type(nat**2) - - integer :: neigh_tmp(nat), dum(nat) - integer :: i, j - real(wp) :: x, y, z, d, ri, r - - neigh_index = 0 - neigh_index(1) = 1 - neigh_list = 0 - neigh_tmp = 0 - do i = 1, nat - !--- Check, if there are neighbors and which - neigh_list(i) = 0 - x = xyz_rad(i, 1) - y = xyz_rad(i, 2) - z = xyz_rad(i, 3) - r = xyz_rad(i, 4) - do j = 1, nat - if (j .NE. i) then - if (dabs(x - xyz_rad(j, 1)) .lt. r + xyz_rad(j, 4)) then - d = dsqrt((x - xyz_rad(j, 1))**2 + (y - xyz_rad(j, 2))**2 + (z - xyz_rad(j, 3))**2) - ri = xyz_rad(j, 4) - if (d .lt. r + ri) then - if (d + r .LE. ri) then - neigh_list(i) = -1 - exit - elseif (d + ri .gt. r) then - neigh_list(i) = neigh_list(i) + 1 - neigh_tmp(neigh_list(i)) = j - end if - end if +subroutine create_neigh(nat,xyz_rad,neigh_list,neigh_index,neigh_type) + use crest_parameters + implicit none + + integer,intent(in) :: nat + real(wp),intent(in) :: xyz_rad(nat,4) + integer :: neigh_list(nat),neigh_index(nat),neigh_type(nat**2) + + integer :: neigh_tmp(nat),dum(nat) + integer :: i,j + real(wp) :: x,y,z,d,ri,r + + neigh_index = 0 + neigh_index(1) = 1 + neigh_list = 0 + neigh_tmp = 0 + do i = 1,nat + !--- Check, if there are neighbors and which + neigh_list(i) = 0 + x = xyz_rad(i,1) + y = xyz_rad(i,2) + z = xyz_rad(i,3) + r = xyz_rad(i,4) + do j = 1,nat + if (j .NE. i) then + if (abs(x-xyz_rad(j,1)) .lt. r+xyz_rad(j,4)) then + d = sqrt((x-xyz_rad(j,1))**2+(y-xyz_rad(j,2))**2+(z-xyz_rad(j,3))**2) + ri = xyz_rad(j,4) + if (d .lt. r+ri) then + if (d+r .LE. ri) then + neigh_list(i) = -1 + exit + elseif (d+ri .gt. r) then + neigh_list(i) = neigh_list(i)+1 + neigh_tmp(neigh_list(i)) = j end if - end if - end do - dum = neigh_list !Somhow the first entry in neigh_list is overwritten in the following do cycle + end if + end if + end if + end do + dum = neigh_list !Somhow the first entry in neigh_list is overwritten in the following do cycle - !--- No neighbors - if (neigh_list(i) .LE. 0) then - neigh_index(i + 1) = neigh_index(i) + !--- No neighbors + if (neigh_list(i) .LE. 0) then + neigh_index(i+1) = neigh_index(i) !--- Neighbors - else - if(i < nat) then - neigh_index(i + 1) = neigh_index(i) + neigh_list(i) - end if - do j = 1, neigh_list(i) - neigh_type(neigh_index(i) + j - 1) = neigh_tmp(j) - end do + else + if (i < nat) then + neigh_index(i+1) = neigh_index(i)+neigh_list(i) end if - end do - neigh_list = dum + do j = 1,neigh_list(i) + neigh_type(neigh_index(i)+j-1) = neigh_tmp(j) + end do + end if + end do + neigh_list = dum - return + return end subroutine create_neigh -subroutine calcVA(num, xyz_rad, neigh_list, neigh_index, neigh_type, nat, va_part) - use iso_fortran_env, wp => real64 - implicit none - - integer, intent(in) :: num, nat - real(wp), intent(in) :: xyz_rad(nat, 4) - integer, intent(in) :: neigh_list(nat), neigh_index(nat), neigh_type(nat**2) - real(wp), intent(out) :: va_part(2) - real(wp) :: circles(nat, 4), single_sphere(nat, 4) - real(wp) :: int_parts(nat**2, 3), av_part(2) - real(wp) :: rad - - integer :: neigh_tmp(nat), nint_parts, npos - integer :: i, j - real(wp), parameter :: pi = 3.1415926540d0 - - !--- No neighbors - if (neigh_list(num) .eq. 0) then - va_part(1) = 4d0*pi*xyz_rad(num, 4)**3/3.d0 - va_part(2) = 4d0*pi*xyz_rad(num, 4)**2 - !--- Subset - elseif (neigh_list(num) .lt. 0) then - va_part(1) = 0d0 - va_part(2) = 0d0 - !--- Neighbors exist - else - - neigh_tmp(1) = num - - do i = 1, (neigh_list(num)) - neigh_tmp(i + 1) = neigh_type(neigh_index(num) + i - 1) - end do - do i = 1, neigh_list(num) + 1 - do j = 1, 4 - single_sphere(i, j) = xyz_rad(neigh_tmp(i), j) - end do +subroutine calcVA(num,xyz_rad,neigh_list,neigh_index,neigh_type,nat,va_part) + use crest_parameters + implicit none + + integer,intent(in) :: num,nat + real(wp),intent(in) :: xyz_rad(nat,4) + integer,intent(in) :: neigh_list(nat),neigh_index(nat),neigh_type(nat**2) + real(wp),intent(out) :: va_part(2) + real(wp) :: circles(nat,4),single_sphere(nat,4) + real(wp) :: int_parts(nat**2,3),av_part(2) + real(wp) :: rad + + integer :: neigh_tmp(nat),nint_parts,npos + integer :: i,j + + !--- No neighbors + if (neigh_list(num) .eq. 0) then + va_part(1) = 4d0*pi*xyz_rad(num,4)**3/3.d0 + va_part(2) = 4d0*pi*xyz_rad(num,4)**2 + !--- Subset + elseif (neigh_list(num) .lt. 0) then + va_part(1) = 0d0 + va_part(2) = 0d0 + !--- Neighbors exist + else + + neigh_tmp(1) = num + + do i = 1, (neigh_list(num)) + neigh_tmp(i+1) = neigh_type(neigh_index(num)+i-1) + end do + do i = 1,neigh_list(num)+1 + do j = 1,4 + single_sphere(i,j) = xyz_rad(neigh_tmp(i),j) end do + end do - va_part(1) = 0d0 - va_part(2) = 0d0 + va_part(1) = 0d0 + va_part(2) = 0d0 - call generate_integration_parts(single_sphere, circles, nat, neigh_list(num), int_parts, nint_parts) + call generate_integration_parts(single_sphere,circles,nat,neigh_list(num),int_parts,nint_parts) - npos = 0 - do i = 1, (neigh_list(num)) - if (circles(i, 4) .gt. 0) then - npos = npos + 1 - end if - end do - - rad = single_sphere(1, 4) - !--- Selective integration as overlap was found - if (npos .gt. 0) then - call integrate(circles, int_parts, nat, nint_parts, rad, single_sphere(1, 3), av_part) - va_part(1) = va_part(1) + av_part(1) - va_part(2) = va_part(2) + av_part(2) - !--- Complete integration - else - call integrate(circles, int_parts, nat, nint_parts, rad, single_sphere(1, 3), av_part) - va_part(1) = va_part(1) + av_part(1) + 4d0*pi*single_sphere(1, 4)**3/3d0 - va_part(2) = va_part(2) + av_part(2) + 4d0*pi*single_sphere(1, 4)**2 + npos = 0 + do i = 1, (neigh_list(num)) + if (circles(i,4) .gt. 0) then + npos = npos+1 end if - end if - - return + end do + + rad = single_sphere(1,4) + !--- Selective integration as overlap was found + if (npos .gt. 0) then + call integrate(circles,int_parts,nat,nint_parts,rad,single_sphere(1,3),av_part) + va_part(1) = va_part(1)+av_part(1) + va_part(2) = va_part(2)+av_part(2) + !--- Complete integration + else + call integrate(circles,int_parts,nat,nint_parts,rad,single_sphere(1,3),av_part) + va_part(1) = va_part(1)+av_part(1)+4d0*pi*single_sphere(1,4)**3/3d0 + va_part(2) = va_part(2)+av_part(2)+4d0*pi*single_sphere(1,4)**2 + end if + end if + + return end subroutine calcVA -subroutine generate_integration_parts(single_sphere, circles, nat, num_neigh, int_parts, num_parts) - - use iso_fortran_env, wp => real64 - implicit none - real(wp), intent(in) :: single_sphere(nat, 4) - real(wp), intent(out) :: circles(nat, 4) - integer, intent(in) :: nat, num_neigh - real(wp), intent(out) :: int_parts(nat**2, 3) - integer, intent(out) :: num_parts - - integer :: nna - real(wp) :: int_partsnew(nat**2, 3), rad, x, y, a, b, c, d - integer :: i, j, k - real(wp), parameter :: pi = 3.1415926540d0 - - num_parts = 0 - - !--- Create circles first - rad = single_sphere(1, 4) - do i = 1, (num_neigh) - x = single_sphere(1, 1) - single_sphere(i + 1, 1) - y = single_sphere(1, 2) - single_sphere(i + 1, 2) - a = 8d0*rad**2*x - b = 8d0*rad**2*y - c = x**2 + y**2 + (single_sphere(1, 3) + rad - single_sphere(i + 1, 3))**2 - single_sphere(i + 1, 4)**2 - d = 4d0*rad**2*(x**2 + y**2 + (single_sphere(1, 3) - rad - single_sphere(i + 1, 3))**2 - single_sphere(i + 1, 4)**2) - circles(i, 1) = -a/(2d0*c) - circles(i, 2) = -b/(2d0*c) - circles(i, 3) = dsqrt((a**2 + b**2 - 4d0*c*d)/(4d0*c**2)) - if (c .gt. 0) then - circles(i, 4) = -1 - else - circles(i, 4) = 1 +subroutine generate_integration_parts(single_sphere,circles,nat,num_neigh,int_parts,num_parts) + use crest_parameters + implicit none + real(wp),intent(in) :: single_sphere(nat,4) + real(wp),intent(out) :: circles(nat,4) + integer,intent(in) :: nat,num_neigh + real(wp),intent(out) :: int_parts(nat**2,3) + integer,intent(out) :: num_parts + + integer :: nna + real(wp) :: int_partsnew(nat**2,3),rad,x,y,a,b,c,d + integer :: i,j,k + + num_parts = 0 + + !--- Create circles first + rad = single_sphere(1,4) + do i = 1, (num_neigh) + x = single_sphere(1,1)-single_sphere(i+1,1) + y = single_sphere(1,2)-single_sphere(i+1,2) + a = 8d0*rad**2*x + b = 8d0*rad**2*y + c = x**2+y**2+(single_sphere(1,3)+rad-single_sphere(i+1,3))**2-single_sphere(i+1,4)**2 + d = 4d0*rad**2*(x**2+y**2+(single_sphere(1,3)-rad-single_sphere(i+1,3))**2-single_sphere(i+1,4)**2) + circles(i,1) = -a/(2d0*c) + circles(i,2) = -b/(2d0*c) + circles(i,3) = sqrt((a**2+b**2-4d0*c*d)/(4d0*c**2)) + if (c .gt. 0) then + circles(i,4) = -1 + else + circles(i,4) = 1 + end if + end do + + !--- And than integration parts + !--- Only one circle + if (num_neigh .eq. 1) then + num_parts = 1 + int_parts(1,1) = 1 + int_parts(1,2) = 0d0 + int_parts(1,3) = 2d0*pi*circles(1,4) + !--- More circles + else + do i = 1, (num_neigh) + call make_parts(i,circles,nat,num_neigh,nna,int_partsnew) + if (nna .gt. 0) then + do j = 1,nna + do k = 1,3 + int_parts(num_parts+j,k) = int_partsnew(j,k) + end do + end do + num_parts = num_parts+nna end if - end do - - !--- And than integration parts - !--- Only one circle - if (num_neigh .eq. 1) then - num_parts = 1 - int_parts(1, 1) = 1 - int_parts(1, 2) = 0d0 - int_parts(1, 3) = 2d0*pi*circles(1, 4) - !--- More circles - else - do i = 1, (num_neigh) - call make_parts(i, circles, nat, num_neigh, nna, int_partsnew) - if (nna .gt. 0) then - do j = 1, nna - do k = 1, 3 - int_parts(num_parts + j, k) = int_partsnew(j, k) - end do - end do - num_parts = num_parts + nna - end if - end do - end if - return + end do + end if + return end subroutine generate_integration_parts !--- Create parts that are integratet later -subroutine make_parts(num, circles, nat, num_neigh, no_arc, int_partsnew) - use iso_fortran_env, wp => real64 - implicit none - - integer, intent(in) :: num - real(wp), intent(in) :: circles(nat, 4) - integer, intent(in) :: nat, num_neigh - real(wp), intent(out) :: int_partsnew(nat**2, 3) - integer, intent(out) :: no_arc - - integer :: i, j, m, counter_angles, counter_no_angles, counter - real(wp) :: c11, c12, c13, c21, c22, c23, dist, int11, int12, int21, int22, dum - real(wp) :: angles(nat**2), anglesnew(nat**2) - logical :: minmax - real(wp), parameter :: pi = 3.1415926540d0 - - no_arc = 0 - counter_angles = 0 - - c11 = circles(num, 1) - c12 = circles(num, 2) - c13 = circles(num, 3) - do i = 1, (num_neigh) - if (i .NE. num) then - c21 = circles(i, 1) - c22 = circles(i, 2) - c23 = circles(i, 3) - dist = dsqrt((c11 - c21)**2 + (c12 - c22)**2) - if ((dist .lt. c23 + c13) .and. (dabs(c23 - c13) .lt. dist)) then - !--- Two intersections - call intersection(num, i, nat, circles, int11, int12, int21, int22) - angles(counter_angles + 1) = int11 - angles(counter_angles + 2) = int12 - counter_angles = counter_angles + 2 - end if +subroutine make_parts(num,circles,nat,num_neigh,no_arc,int_partsnew) + use crest_parameters + implicit none + + integer,intent(in) :: num + real(wp),intent(in) :: circles(nat,4) + integer,intent(in) :: nat,num_neigh + real(wp),intent(out) :: int_partsnew(nat**2,3) + integer,intent(out) :: no_arc + + integer :: i,j,m,counter_angles,counter_no_angles,counter + real(wp) :: c11,c12,c13,c21,c22,c23,dist,int11,int12,int21,int22,dum + real(wp) :: angles(nat**2),anglesnew(nat**2) + logical :: minmax + + no_arc = 0 + counter_angles = 0 + + c11 = circles(num,1) + c12 = circles(num,2) + c13 = circles(num,3) + do i = 1, (num_neigh) + if (i .NE. num) then + c21 = circles(i,1) + c22 = circles(i,2) + c23 = circles(i,3) + dist = sqrt((c11-c21)**2+(c12-c22)**2) + if ((dist .lt. c23+c13).and.(abs(c23-c13) .lt. dist)) then + !--- Two intersections + call intersection(num,i,nat,circles,int11,int12,int21,int22) + angles(counter_angles+1) = int11 + angles(counter_angles+2) = int12 + counter_angles = counter_angles+2 end if - end do - if (counter_angles .eq. 0) then - counter_no_angles = 0 - do i = 1, (num_neigh) - if (i .NE. num) then - - !--- Check overlapping circles - dist = dsqrt((circles(num, 1) + circles(num, 3) - circles(i, 1))**2 + & - & (circles(num, 2) - circles(i, 2))**2) - if (dist .lt. circles(i, 3)) then - if (circles(i, 4) .gt. 0) then - counter = 1 - else - counter = 0 - end if - elseif (dist .gt. circles(i, 3)) then - if (circles(i, 4) .gt. 0) then - counter = 0 - else - counter = 1 - end if + end if + end do + if (counter_angles .eq. 0) then + counter_no_angles = 0 + do i = 1, (num_neigh) + if (i .NE. num) then + + !--- Check overlapping circles + dist = sqrt((circles(num,1)+circles(num,3)-circles(i,1))**2+ & + & (circles(num,2)-circles(i,2))**2) + if (dist .lt. circles(i,3)) then + if (circles(i,4) .gt. 0) then + counter = 1 + else + counter = 0 + end if + elseif (dist .gt. circles(i,3)) then + if (circles(i,4) .gt. 0) then + counter = 0 + else + counter = 1 + end if + else + dist = sqrt((circles(num,1)-circles(i,1))**2+(circles(num,2)-circles(i,2))**2) + if (dist .lt. circles(i,3)) then + if (circles(i,4) .gt. 0) then + counter = 1 else - dist = dsqrt((circles(num, 1) - circles(i, 1))**2 + (circles(num, 2) - circles(i, 2))**2) - if (dist .lt. circles(i, 3)) then - if (circles(i, 4) .gt. 0) then - counter = 1 - else - counter = 0 - end if - else - if (circles(i, 4) .gt. 0) then - counter = 0 - else - counter = 1 - end if - end if + counter = 0 end if - - counter_no_angles = counter_no_angles + counter - end if - end do - if (counter_no_angles .eq. (num_neigh - 1)) then - no_arc = 1 - int_partsnew(1, 1) = num - int_partsnew(1, 2) = 0d0 - int_partsnew(1, 3) = 2d0*pi*circles(num, 4) - end if - else - if (circles(num, 4) .gt. 0) then - minmax = .true. - else - minmax = .false. - end if - !--- Sort angles - do i = 1, (counter_angles - 1) - counter = i - dum = angles(i) - do j = i + 1, counter_angles - if (minmax) then - if (dum .gt. angles(j)) then - counter = j - dum = angles(j) - end if + else + if (circles(i,4) .gt. 0) then + counter = 0 else - if (dum .lt. angles(j)) then - counter = j - dum = angles(j) - end if + counter = 1 end if - end do - if (counter .NE. i) then - angles(counter) = angles(i) - angles(i) = dum - end if - end do - - !--- Remove equals - m = 1 - anglesnew(1) = angles(1) - do i = 2, counter_angles - if (dabs(angles(i) - angles(i - 1)) .gt. 1d-12) then - m = m + 1 - anglesnew(m) = angles(i) - end if - end do - counter_angles = m - do i = 1, m - angles(i) = anglesnew(i) - end do - do i = 1, (counter_angles - 1) - counter_no_angles = 0 - do j = 1, (num_neigh) - if (j .NE. num) then - c21 = c11 + c13*dcos((angles(i) + angles(i + 1))/2d0) - c22 = c12 + c13*dsin((angles(i) + angles(i + 1))/2d0) - !--- Check, if point is inside circle - dist = dsqrt((c21 - circles(j, 1))**2 + (c22 - circles(j, 2))**2) - if (dist .lt. circles(j, 3)) then - if (circles(j, 4) .gt. 0) then - counter_no_angles = counter_no_angles + 1 - end if - else - if (circles(j, 4) .LE. 0) then - counter_no_angles = counter_no_angles + 1 - end if - end if + end if + end if - end if - end do - if (counter_no_angles .eq. (num_neigh - 1)) then - no_arc = no_arc + 1 - int_partsnew(no_arc, 1) = num - int_partsnew(no_arc, 2) = angles(i) - int_partsnew(no_arc, 3) = angles(i + 1) - angles(i) - end if + counter_no_angles = counter_no_angles+counter + end if + end do + if (counter_no_angles .eq. (num_neigh-1)) then + no_arc = 1 + int_partsnew(1,1) = num + int_partsnew(1,2) = 0d0 + int_partsnew(1,3) = 2d0*pi*circles(num,4) + end if + else + if (circles(num,4) .gt. 0) then + minmax = .true. + else + minmax = .false. + end if + !--- Sort angles + do i = 1, (counter_angles-1) + counter = i + dum = angles(i) + do j = i+1,counter_angles + if (minmax) then + if (dum .gt. angles(j)) then + counter = j + dum = angles(j) + end if + else + if (dum .lt. angles(j)) then + counter = j + dum = angles(j) + end if + end if end do + if (counter .NE. i) then + angles(counter) = angles(i) + angles(i) = dum + end if + end do + + !--- Remove equals + m = 1 + anglesnew(1) = angles(1) + do i = 2,counter_angles + if (abs(angles(i)-angles(i-1)) .gt. 1d-12) then + m = m+1 + anglesnew(m) = angles(i) + end if + end do + counter_angles = m + do i = 1,m + angles(i) = anglesnew(i) + end do + do i = 1, (counter_angles-1) counter_no_angles = 0 - do i = 1, (num_neigh) - if (i .NE. num) then - c21 = c11 + c13*dcos((angles(1) + 2d0*pi + angles(counter_angles))/2d0) - c22 = c12 + c13*dsin((angles(1) + 2d0*pi + angles(counter_angles))/2d0) - !--- Check, if point is inside circle - dist = dsqrt((c21 - circles(i, 1))**2 + (c22 - circles(i, 2))**2) - if (dist .lt. circles(i, 3)) then - if (circles(i, 4) .gt. 0) then - counter_no_angles = counter_no_angles + 1 - end if - else - if (circles(i, 4) .LE. 0) then - counter_no_angles = counter_no_angles + 1 - end if + do j = 1, (num_neigh) + if (j .NE. num) then + c21 = c11+c13*cos((angles(i)+angles(i+1))/2d0) + c22 = c12+c13*sin((angles(i)+angles(i+1))/2d0) + !--- Check, if point is inside circle + dist = sqrt((c21-circles(j,1))**2+(c22-circles(j,2))**2) + if (dist .lt. circles(j,3)) then + if (circles(j,4) .gt. 0) then + counter_no_angles = counter_no_angles+1 end if + else + if (circles(j,4) .LE. 0) then + counter_no_angles = counter_no_angles+1 + end if + end if - end if + end if end do - if (counter_no_angles .eq. (num_neigh - 1)) then - no_arc = no_arc + 1 - int_partsnew(no_arc, 1) = num - int_partsnew(no_arc, 2) = angles(counter_angles) - int_partsnew(no_arc, 3) = angles(1) + circles(num, 4)*2d0*pi - angles(counter_angles) + if (counter_no_angles .eq. (num_neigh-1)) then + no_arc = no_arc+1 + int_partsnew(no_arc,1) = num + int_partsnew(no_arc,2) = angles(i) + int_partsnew(no_arc,3) = angles(i+1)-angles(i) end if - end if + end do + counter_no_angles = 0 + do i = 1, (num_neigh) + if (i .NE. num) then + c21 = c11+c13*cos((angles(1)+2d0*pi+angles(counter_angles))/2d0) + c22 = c12+c13*sin((angles(1)+2d0*pi+angles(counter_angles))/2d0) + !--- Check, if point is inside circle + dist = sqrt((c21-circles(i,1))**2+(c22-circles(i,2))**2) + if (dist .lt. circles(i,3)) then + if (circles(i,4) .gt. 0) then + counter_no_angles = counter_no_angles+1 + end if + else + if (circles(i,4) .LE. 0) then + counter_no_angles = counter_no_angles+1 + end if + end if - return + end if + end do + if (counter_no_angles .eq. (num_neigh-1)) then + no_arc = no_arc+1 + int_partsnew(no_arc,1) = num + int_partsnew(no_arc,2) = angles(counter_angles) + int_partsnew(no_arc,3) = angles(1)+circles(num,4)*2d0*pi-angles(counter_angles) + end if + end if + + return end subroutine make_parts !--- Computation of angles of two intersection points -subroutine intersection(point1, point2, nat, circles, int11, int12, int21, int22) - - use iso_fortran_env, wp => real64 - implicit none - integer, intent(in) :: point1, point2, nat - real(wp), intent(in) :: circles(nat, 4) - real(wp), intent(out) :: int11, int12, int21, int22 - - real(wp) :: c11, c12, c13, c21, c22, c23, f1, f2, f3, f4 - real(wp), parameter :: pi = 3.1415926540d0 - - c11 = circles(point1, 1) - c12 = circles(point1, 2) - c13 = circles(point1, 3) - c21 = circles(point2, 1) - c22 = circles(point2, 2) - c23 = circles(point2, 3) - if (dabs(c21 - c11) .lt. 1d-12) then - f1 = ((c13**2 - c23**2)/(c22 - c12) - (c22 - c12))/2d0 - f2 = dsqrt(c23**2 - f1**2) - if (f1 .eq. 0) then - int21 = 0d0 - int22 = pi - elseif (f1 .gt. 0) then - int21 = datan(dabs(f1/f2)) - int22 = pi - int21 - else - int21 = pi + datan(dabs(f1/f2)) - int22 = 3d0*pi - int21 - end if - f1 = f1 + c22 - c12 - if (f1 .eq. 0) then - int11 = 0d0 - int12 = pi - elseif (f1 .gt. 0) then - int11 = datan(dabs(f1/f2)) - int12 = pi - int11 +subroutine intersection(point1,point2,nat,circles,int11,int12,int21,int22) + use crest_parameters + implicit none + integer,intent(in) :: point1,point2,nat + real(wp),intent(in) :: circles(nat,4) + real(wp),intent(out) :: int11,int12,int21,int22 + + real(wp) :: c11,c12,c13,c21,c22,c23,f1,f2,f3,f4 + + c11 = circles(point1,1) + c12 = circles(point1,2) + c13 = circles(point1,3) + c21 = circles(point2,1) + c22 = circles(point2,2) + c23 = circles(point2,3) + if (abs(c21-c11) .lt. 1d-12) then + f1 = ((c13**2-c23**2)/(c22-c12)-(c22-c12))/2d0 + f2 = sqrt(c23**2-f1**2) + if (f1 .eq. 0) then + int21 = 0d0 + int22 = pi + elseif (f1 .gt. 0) then + int21 = atan(abs(f1/f2)) + int22 = pi-int21 + else + int21 = pi+atan(abs(f1/f2)) + int22 = 3d0*pi-int21 + end if + f1 = f1+c22-c12 + if (f1 .eq. 0) then + int11 = 0d0 + int12 = pi + elseif (f1 .gt. 0) then + int11 = atan(abs(f1/f2)) + int12 = pi-int11 + else + int11 = pi+atan(abs(f1/f2)) + int12 = 3d0*pi-int11 + end if + else + f3 = ((c13**2-c23**2-(c22-c12)**2)/(c21-c11)-(c21-c11))/2d0 + f4 = (c12-c22)/(c21-c11) + f1 = (-f3*f4+sqrt((f4**2+1d0)*c23**2-f3**2))/(f4**2+1d0) + f2 = f3+f4*f1 + if (f2 .eq. 0) then + if (f1 .gt. 0) then + int21 = pi/2d0 else - int11 = pi + datan(dabs(f1/f2)) - int12 = 3d0*pi - int11 + int21 = -pi/2d0 end if - else - f3 = ((c13**2 - c23**2 - (c22 - c12)**2)/(c21 - c11) - (c21 - c11))/2d0 - f4 = (c12 - c22)/(c21 - c11) - f1 = (-f3*f4 + dsqrt((f4**2 + 1d0)*c23**2 - f3**2))/(f4**2 + 1d0) - f2 = f3 + f4*f1 - if (f2 .eq. 0) then - if (f1 .gt. 0) then - int21 = pi/2d0 - else - int21 = -pi/2d0 - end if - elseif (f2 .gt. 0) then - int21 = datan(f1/f2) + elseif (f2 .gt. 0) then + int21 = atan(f1/f2) + else + int21 = pi+atan(f1/f2) + end if + f1 = f1+c22-c12 + f2 = f2+c21-c11 + if (f2 .eq. 0) then + if (f1 .gt. 0) then + int11 = pi/2d0 else - int21 = pi + datan(f1/f2) + int11 = -pi/2d0 end if - f1 = f1 + c22 - c12 - f2 = f2 + c21 - c11 - if (f2 .eq. 0) then - if (f1 .gt. 0) then - int11 = pi/2d0 - else - int11 = -pi/2d0 - end if - elseif (f2 .gt. 0) then - int11 = datan(f1/f2) + elseif (f2 .gt. 0) then + int11 = atan(f1/f2) + else + int11 = pi+atan(f1/f2) + end if + f1 = (-f3*f4-sqrt((f4**2+1d0)*c23**2-f3**2))/(f4**2+1d0) + f2 = f3+f4*f1 + if (f2 .eq. 0) then + if (f1 .gt. 0) then + int22 = pi/2d0 else - int11 = pi + datan(f1/f2) + int22 = -pi/2d0 end if - f1 = (-f3*f4 - dsqrt((f4**2 + 1d0)*c23**2 - f3**2))/(f4**2 + 1d0) - f2 = f3 + f4*f1 - if (f2 .eq. 0) then - if (f1 .gt. 0) then - int22 = pi/2d0 - else - int22 = -pi/2d0 - end if - elseif (f2 .gt. 0) then - int22 = datan(f1/f2) + elseif (f2 .gt. 0) then + int22 = atan(f1/f2) + else + int22 = pi+atan(f1/f2) + end if + f1 = f1+c22-c12 + f2 = f2+c21-c11 + if (f2 .eq. 0) then + if (f1 .gt. 0) then + int12 = pi/2d0 else - int22 = pi + datan(f1/f2) + int12 = -pi/2d0 end if - f1 = f1 + c22 - c12 - f2 = f2 + c21 - c11 - if (f2 .eq. 0) then - if (f1 .gt. 0) then - int12 = pi/2d0 - else - int12 = -pi/2d0 - end if - elseif (f2 .gt. 0) then - int12 = datan(f1/f2) - else - int12 = pi + datan(f1/f2) - end if - end if - if (int11 .lt. 0) int11 = int11 + 2d0*pi - if (int12 .lt. 0) int12 = int12 + 2d0*pi - if (int21 .lt. 0) int21 = int21 + 2d0*pi - if (int22 .lt. 0) int22 = int22 + 2d0*pi - - return + elseif (f2 .gt. 0) then + int12 = atan(f1/f2) + else + int12 = pi+atan(f1/f2) + end if + end if + if (int11 .lt. 0) int11 = int11+2d0*pi + if (int12 .lt. 0) int12 = int12+2d0*pi + if (int21 .lt. 0) int21 = int21+2d0*pi + if (int22 .lt. 0) int22 = int22+2d0*pi + + return end subroutine intersection -subroutine integrate(circles, int_parts, nat, nint_parts, rad, z1, av_part) - use iso_fortran_env, wp => real64 - implicit none - - real(wp), intent(in) :: circles(nat, 4), int_parts(nat**2, 3) - integer, intent(in) :: nat, nint_parts - real(wp), intent(in) :: rad, z1 - real(wp), intent(inout) :: av_part(2) - - integer :: i - real(wp) :: x, y, z, pre_V, xz, yz, pre_A, f - real(wp) :: pa, pd, p1, pb, pc, p2, v1, v2, v3, vJ1, vJ2, vJ3 - real(wp) :: d_v, d_a, part1, part2, part3, part4 - real(wp), parameter :: pi = 3.1415926540d0 - - av_part(1) = 0d0 - av_part(2) = 0d0 - - do i = 1, nint_parts - x = circles(nint(int_parts(i, 1)), 1) !> int_parts is type real(wp) and therefore - y = circles(nint(int_parts(i, 1)), 2) !> should not be used as an array index? - z = circles(nint(int_parts(i, 1)), 3) !> added nint() - xz = x*z - yz = y*z - pre_V = (4d0*rad**2 + x**2 + y**2 + z**2)/2d0 - pre_A = dsqrt(pre_V**2 - xz**2 - yz**2) - f = z**2 - pre_V - if (dabs(dabs(int_parts(i, 3)) - 2d0*pi) .lt. 1d-12) then - v1 = 2d0*pi/pre_A - v2 = 2d0*pi*pre_V/(pre_A**3) - v3 = pi*(2d0*pre_V**2 + xz**2 + yz**2)/(pre_A**5) - vJ1 = pi + f/2d0*v1 - vJ2 = (v1 + f*v2)/4d0 - vJ3 = (v2 + f*v3)/8d0 - d_v = (128d0*vJ3*rad**7 + 8d0*vJ2*rad**5 + & - & 2d0*vJ1*rad**3)/3d0 - 8d0*rad**4*vJ2*(z1 + rad) - d_a = 2d0*vJ1*rad**2 - if (int_parts(i, 3) .lt. 0) then - d_v = -d_v - d_a = -d_a - end if - av_part(1) = av_part(1) + d_v - av_part(2) = av_part(2) + d_a +subroutine integrate(circles,int_parts,nat,nint_parts,rad,z1,av_part) + use crest_parameters + implicit none + + real(wp),intent(in) :: circles(nat,4),int_parts(nat**2,3) + integer,intent(in) :: nat,nint_parts + real(wp),intent(in) :: rad,z1 + real(wp),intent(inout) :: av_part(2) + + integer :: i + real(wp) :: x,y,z,pre_V,xz,yz,pre_A,f + real(wp) :: pa,pd,p1,pb,pc,p2,v1,v2,v3,vJ1,vJ2,vJ3 + real(wp) :: d_v,d_a,part1,part2,part3,part4 + + av_part(1) = 0d0 + av_part(2) = 0d0 + + do i = 1,nint_parts + x = circles(nint(int_parts(i,1)),1) !> int_parts is type real(wp) and therefore + y = circles(nint(int_parts(i,1)),2) !> should not be used as an array index? + z = circles(nint(int_parts(i,1)),3) !> added nint() + xz = x*z + yz = y*z + pre_V = (4d0*rad**2+x**2+y**2+z**2)/2d0 + pre_A = sqrt(pre_V**2-xz**2-yz**2) + f = z**2-pre_V + if (abs(abs(int_parts(i,3))-2d0*pi) .lt. 1d-12) then + v1 = 2d0*pi/pre_A + v2 = 2d0*pi*pre_V/(pre_A**3) + v3 = pi*(2d0*pre_V**2+xz**2+yz**2)/(pre_A**5) + vJ1 = pi+f/2d0*v1 + vJ2 = (v1+f*v2)/4d0 + vJ3 = (v2+f*v3)/8d0 + d_v = (128d0*vJ3*rad**7+8d0*vJ2*rad**5+ & + & 2d0*vJ1*rad**3)/3d0-8d0*rad**4*vJ2*(z1+rad) + d_a = 2d0*vJ1*rad**2 + if (int_parts(i,3) .lt. 0) then + d_v = -d_v + d_a = -d_a + end if + av_part(1) = av_part(1)+d_v + av_part(2) = av_part(2)+d_a + else + if (int_parts(i,3) .lt. 0) then + p2 = int_parts(i,2)+int_parts(i,3) + p1 = int_parts(i,2) else - if (int_parts(i, 3) .lt. 0) then - p2 = int_parts(i, 2) + int_parts(i, 3) - p1 = int_parts(i, 2) - else - p1 = int_parts(i, 2) + int_parts(i, 3) - p2 = int_parts(i, 2) - end if - v1 = 2d0*(pi/2d0 - datan((pre_V*dcos((p1 - p2)/2d0) + & - & xz*dcos((p2 + p1)/2d0) + yz*dsin((p2 + p1)/2d0))/ & - & (pre_A*dsin((p1 - p2)/2d0))))/pre_A - pa = dsin(p1) - pb = dcos(p1) - pc = dsin(p2) - pd = dcos(p2) - part1 = (-xz*pa + yz*pb)/(pre_V + xz*pb + yz*pa)**1 - part2 = (-xz*pc + yz*pd)/(pre_V + xz*pd + yz*pc)**1 - part3 = (-xz*pa + yz*pb)/(pre_V + xz*pb + yz*pa)**2 - part4 = (-xz*pc + yz*pd)/(pre_V + xz*pd + yz*pc)**2 - v2 = (part1 - part2 + pre_V*v1)/(pre_A**2) - v3 = (part3 - part4 + (part1 - part2)/pre_V + (2d0*pre_V**2 + xz**2 + yz**2)*v2/pre_V)/(2d0*pre_A**2) - vJ1 = ((p1 - p2) + f*v1)/2d0 - vJ2 = (v1 + f*v2)/4d0 - vJ3 = (v2 + f*v3)/8d0 - d_v = (128d0*vJ3*rad**7 + 8d0*vJ2*rad**5 + & - & 2d0*vJ1*rad**3)/3d0 - 8d0*rad**4*vJ2*(z1 + rad) - d_a = 2d0*vJ1*rad**2 - if (int_parts(i, 3) .lt. 0) then - d_v = -d_v - d_a = -d_a - end if - av_part(1) = av_part(1) + d_v - av_part(2) = av_part(2) + d_a + p1 = int_parts(i,2)+int_parts(i,3) + p2 = int_parts(i,2) + end if + v1 = 2d0*(pi/2d0-atan((pre_V*cos((p1-p2)/2d0)+ & + & xz*cos((p2+p1)/2d0)+yz*sin((p2+p1)/2d0))/ & + & (pre_A*sin((p1-p2)/2d0))))/pre_A + pa = sin(p1) + pb = cos(p1) + pc = sin(p2) + pd = cos(p2) + part1 = (-xz*pa+yz*pb)/(pre_V+xz*pb+yz*pa)**1 + part2 = (-xz*pc+yz*pd)/(pre_V+xz*pd+yz*pc)**1 + part3 = (-xz*pa+yz*pb)/(pre_V+xz*pb+yz*pa)**2 + part4 = (-xz*pc+yz*pd)/(pre_V+xz*pd+yz*pc)**2 + v2 = (part1-part2+pre_V*v1)/(pre_A**2) + v3 = (part3-part4+(part1-part2)/pre_V+(2d0*pre_V**2+xz**2+yz**2)*v2/pre_V)/(2d0*pre_A**2) + vJ1 = ((p1-p2)+f*v1)/2d0 + vJ2 = (v1+f*v2)/4d0 + vJ3 = (v2+f*v3)/8d0 + d_v = (128d0*vJ3*rad**7+8d0*vJ2*rad**5+ & + & 2d0*vJ1*rad**3)/3d0-8d0*rad**4*vJ2*(z1+rad) + d_a = 2d0*vJ1*rad**2 + if (int_parts(i,3) .lt. 0) then + d_v = -d_v + d_a = -d_a end if - end do + av_part(1) = av_part(1)+d_v + av_part(2) = av_part(2)+d_a + end if + end do - return + return end subroutine integrate diff --git a/src/quicksort.f90 b/src/quicksort.f90 deleted file mode 100644 index 69f18de4..00000000 --- a/src/quicksort.f90 +++ /dev/null @@ -1,291 +0,0 @@ -!================================================================================! -! This file is part of crest. -! -! Copyright (C) 2020 Philipp Pracht -! -! crest is free software: you can redistribute it and/or modify it under -! the terms of the GNU Lesser General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! crest is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public License -! along with crest. If not, see . -!================================================================================! - -!=============================================================! -! classical quicksort algorithm, sort LOW-to-HIGH -!=============================================================! -recursive subroutine quicksort(n,arr) - implicit none - integer :: n,arr(n),i,j,k,m - integer :: pivot - integer,allocatable :: R(:),L(:) - integer :: rr,ll,rc,lc,pp - - if (n .le. 1) return - - pivot = arr(1) - if (arr(2) .lt. arr(1)) pivot = arr(2) - pp = 0 - do i = 1,n - if (arr(i) .eq. pivot) pp = pp+1 - end do - - ll = 0 - do i = 1,n - if (arr(i) .le. pivot) then - ll = ll+1 - end if - end do - ll = ll-pp - rr = n-ll-pp - allocate (L(ll),R(rr)) - - lc = 0 - rc = 0 - do j = 1,n - if (arr(j) .lt. pivot) then - lc = lc+1 - L(lc) = arr(j) - else if (arr(j) .gt. pivot) then - rc = rc+1 - R(rc) = arr(j) - end if - end do - - call quicksort(ll,L) - call quicksort(rr,R) - - do i = 1,ll - arr(i) = L(i) - end do - do k = 1,pp - m = k+ll - arr(m) = pivot - end do - do j = 1,rr - m = j+ll+pp - arr(m) = R(j) - end do - - deallocate (R,L) -end subroutine quicksort - -!=============================================================! -! classical quicksort algorithm, sort HIGH-to-LOW -!=============================================================! -recursive subroutine revquicksort(n,arr) - implicit none - integer :: n,arr(n),i,j,k,m - integer :: pivot - integer,allocatable :: R(:),L(:) - integer :: rr,ll,rc,lc,pp - - if (n .le. 1) return - - pivot = arr(1) - pp = 0 - do i = 1,n - if (arr(i) .eq. pivot) pp = pp+1 - end do - - ll = 0 - do i = 1,n - if (arr(i) .ge. pivot) then - ll = ll+1 - end if - end do - ll = ll-pp - rr = n-ll-pp - allocate (L(ll),R(rr)) - - lc = 0 - rc = 0 - do j = 1,n - if (arr(j) .gt. pivot) then - lc = lc+1 - L(lc) = arr(j) - else if (arr(j) .lt. pivot) then - rc = rc+1 - R(rc) = arr(j) - end if - end do - - call revquicksort(ll,L) - call revquicksort(rr,R) - - do i = 1,ll - arr(i) = L(i) - end do - do k = 1,pp - m = k+ll - arr(m) = pivot - end do - do j = 1,rr - m = j+ll+pp - arr(m) = R(j) - end do - - deallocate (R,L) -end subroutine revquicksort - -!=============================================================! -! other variant of quicksort algos -!=============================================================! -recursive subroutine qsort(a,first,last,ind) - implicit none - real*8 a(*),x,t - integer ind(*) - integer first,last - integer i,j,ii - - x = a((first+last)/2) - i = first - j = last - do - do while (a(i) < x) - i = i+1 - end do - do while (x < a(j)) - j = j-1 - end do - if (i >= j) exit - t = a(i); a(i) = a(j); a(j) = t - ii = ind(i); ind(i) = ind(j); ind(j) = ii - i = i+1 - j = j-1 - end do - if (first < i-1) call qsort(a,first,i-1,ind) - if (j+1 < last) call qsort(a,j+1,last,ind) -end subroutine qsort - -recursive subroutine qqsort(a,first,last) - implicit none - real*8 a(*),x,t - integer first,last - integer i,j - - x = a((first+last)/2) - i = first - j = last - do - do while (a(i) < x) - i = i+1 - end do - do while (x < a(j)) - j = j-1 - end do - if (i >= j) exit - t = a(i); a(i) = a(j); a(j) = t - i = i+1 - j = j-1 - end do - if (first < i-1) call qqsort(a,first,i-1) - if (j+1 < last) call qqsort(a,j+1,last) -end subroutine qqsort - -recursive subroutine maskqsort(a,first,last,mask) - implicit none - real*8 a(*),t - integer x - integer mask(*) - integer first,last - integer i,j,ii - - x = mask((first+last)/2) - i = first - j = last - do - do while (mask(i) < x) - i = i+1 - end do - do while (x < mask(j)) - j = j-1 - end do - if (i >= j) exit - t = a(i); a(i) = a(j); a(j) = t - ii = mask(i); mask(i) = mask(j); mask(j) = ii - i = i+1 - j = j-1 - end do - if (first < i-1) call maskqsort(a,first,i-1,mask) - if (j+1 < last) call maskqsort(a,j+1,last,mask) -end subroutine maskqsort - -recursive subroutine matqsort(adim,nall,a,adum,first,last,mask) - implicit none - integer :: adim,nall - real*8 a(adim,nall),adum(adim) - integer x - integer mask(nall) - integer first,last - integer i,j,ii - - x = mask((first+last)/2) - i = first - j = last - do - do while (mask(i) < x) - i = i+1 - end do - do while (x < mask(j)) - j = j-1 - end do - if (i >= j) exit - adum(:) = a(:,i); a(:,i) = a(:,j); a(:,j) = adum(:) - ii = mask(i); mask(i) = mask(j); mask(j) = ii - i = i+1 - j = j-1 - end do - if (first < i-1) call matqsort(adim,nall,a,adum,first,i-1,mask) - if (j+1 < last) call matqsort(adim,nall,a,adum,j+1,last,mask) -end subroutine matqsort - -recursive subroutine stringqsort(sdim,strs,first,last,mask) - implicit none - integer :: sdim - character(len=*) :: strs(sdim) - character(len=len(strs(1))) :: str - integer x - integer mask(sdim) - integer first,last - integer i,j,ii - x = mask((first+last)/2) - i = first - j = last - do - do while (mask(i) < x) - i = i+1 - end do - do while (x < mask(j)) - j = j-1 - end do - if (i >= j) exit - str = strs(i); strs(i) = strs(j); strs(j) = str - ii = mask(i); mask(i) = mask(j); mask(j) = ii - i = i+1 - j = j-1 - end do - if (first < i-1) call stringqsort(sdim,strs,first,i-1,mask) - if (j+1 < last) call stringqsort(sdim,strs,j+1,last,mask) -end subroutine stringqsort - -subroutine maskinvert(nall,mask) - implicit none - integer :: nall - integer :: mask(nall) - integer,allocatable :: imask(:) - integer :: i - allocate (imask(nall)) - do i = 1,nall - imask(mask(i)) = i - end do - mask(:) = imask(:) - deallocate (imask) - return -end subroutine maskinvert diff --git a/src/restartlog.f90 b/src/restartlog.f90 index 3584d12b..731c1387 100644 --- a/src/restartlog.f90 +++ b/src/restartlog.f90 @@ -206,6 +206,7 @@ subroutine dump_restart() if (debug) write (stdout,*) '%%% RESTART DEBUG dump summary' !> DO NOT OVERWRITE IF WE HAVEN'T REACHED THE PREVIOUS RESTART ENTRY POINT + if( restart_goal .eq. 0 ) return if( restart_tracker < restart_goal) return open (newunit=ich,file='crest.restart',status='replace',form='unformatted') diff --git a/src/sorting/CMakeLists.txt b/src/sorting/CMakeLists.txt new file mode 100644 index 00000000..c4f3ac04 --- /dev/null +++ b/src/sorting/CMakeLists.txt @@ -0,0 +1,41 @@ +# This file is part of crest. +# SPDX-Identifier: LGPL-3.0-or-later +# +# crest is free software: you can redistribute it and/or modify it under +# the terms of the GNU Lesser General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# crest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public License +# along with crest. If not, see . + +set(dir "${CMAKE_CURRENT_SOURCE_DIR}") + +list(APPEND srcs + "${dir}/canonical.f90" + "${dir}/ccegen.f90" + "${dir}/cregen.f90" + "${dir}/ensemblecomp.f90" + "${dir}/hungarian.f90" + "${dir}/irmsd_module.f90" + "${dir}/ls_rmsd.f90" + "${dir}/quicksort.f90" + "${dir}/rotcompare.f90" + "${dir}/sortens.f90" + "${dir}/unionize.f90" + "${dir}/zdata.f90" + "${dir}/ztopology.f90" +) + +set(srcs ${srcs} PARENT_SCOPE) + + + + + + diff --git a/src/canonical.f90 b/src/sorting/canonical.f90 similarity index 84% rename from src/canonical.f90 rename to src/sorting/canonical.f90 index 8c88a233..3931c5b4 100644 --- a/src/canonical.f90 +++ b/src/sorting/canonical.f90 @@ -2,7 +2,7 @@ module canonical_mod !************************************************************************* !* Implementation of different algorithms for determining atom identities -!* +!* !* A) Implementation of the CANGEN algorithm by Weininger et al. !* D.Weininger et al., J. Chem. Inf. Comput. Sci., 1989, 29, 97-101. !* doi.org/10.1021/ci00062a008 @@ -21,6 +21,7 @@ module canonical_mod use strucrd use adjacency use geo + use utilities, only: nth_prime implicit none private @@ -55,7 +56,9 @@ module canonical_mod procedure :: iterate procedure :: rankprint procedure :: stereo => analyze_stereo + procedure :: hasstereo => has_stereo procedure :: compare => compare_canonical_sorter + procedure :: add_h_ranks end type canonical_sorter logical,parameter :: debug = .false. @@ -107,7 +110,7 @@ end subroutine shrink_canonical_sorter !========================================================================================! - subroutine init_canonical_sorter(self,mol,wbo,invtype) + subroutine init_canonical_sorter(self,mol,wbo,invtype,heavy) !***************************************************************** !* Initializes the canonical_sorter and runs the CANGEN algorithm !***************************************************************** @@ -116,6 +119,7 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) type(coord),intent(in) :: mol real(wp),intent(in),optional :: wbo(mol%nat,mol%nat) character(len=*),intent(in),optional :: invtype + logical,intent(in),optional :: heavy integer :: nodes integer,allocatable :: Amat(:,:) !> adjacency matrix for FULL molecule integer :: counth,countb,countbo @@ -124,7 +128,7 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) integer :: i,j,k,l,ii,ati,atj,maxnei integer,allocatable :: ichrgs(:),frag(:) character(len=:),allocatable :: myinvtype - logical :: use_icharges + logical :: use_icharges,include_H,anyH !>--- optional argument handling if (present(invtype)) then @@ -132,6 +136,12 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) else myinvtype = 'cangen' end if + if (present(heavy)) then + include_H = .not.heavy + else + include_H = .false. + end if + anyH = any(mol%at(:).eq.1) !>--- all atoms of the full mol. graph are nodes nodes = mol%nat @@ -139,17 +149,17 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) !>--- map to heavy atom-only representation k = 0 do i = 1,mol%nat - if (mol%at(i) .ne. 1) k = k+1 + if (mol%at(i) .ne. 1.or.include_h) k = k+1 end do self%nat = nodes self%hatms = k - allocate (self%nmap(nodes)) - allocate (self%hmap(k)) - allocate (self%invariants(k),source=0_int64) - allocate (self%invariants0(k),source=0) - allocate (self%prime(k),source=2) - allocate (self%rank(k),source=1) - allocate (self%hadjac(k,k),source=0) + if (.not.allocated(self%nmap)) allocate (self%nmap(nodes)) + if (.not.allocated(self%hmap)) allocate (self%hmap(k)) + if (.not.allocated(self%invariants)) allocate (self%invariants(k),source=0_int64) + if (.not.allocated(self%invariants0)) allocate (self%invariants0(k),source=0) + if (.not.allocated(self%prime)) allocate (self%prime(k),source=2) + if (.not.allocated(self%rank)) allocate (self%rank(k),source=1) + if (.not.allocated(self%hadjac)) allocate (self%hadjac(k,k),source=0) !>--- determine number of subgraphs via CN call mol%cn_to_bond(cn,Bmat,'cov') @@ -170,13 +180,13 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) end do if (debug) write (stdout,*) 'maximum number of neighbours',maxnei self%maxnei = maxnei - allocate (self%neigh(maxnei,mol%nat),source=0) + if (.not.allocated(self%neigh)) allocate (self%neigh(maxnei,mol%nat),source=0) !>--- fill rest of self k = 0 do i = 1,nodes l = 0 - if (mol%at(i) .ne. 1) then + if (mol%at(i) .ne. 1.or.include_h) then k = k+1 self%nmap(i) = k self%hmap(k) = i @@ -190,8 +200,11 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) end if end do end do + !> H's excluded from hadjac, always do i = 1,k + if (mol%at(self%hmap(i)) .eq. 1) cycle do j = 1,i-1 + if (mol%at(self%hmap(j)) .eq. 1) cycle self%hadjac(j,i) = Amat(self%hmap(j),self%hmap(i)) self%hadjac(i,j) = self%hadjac(j,i) end do @@ -226,9 +239,9 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) case default !> CANGEN - if(.not.present(wbo))then + if (.not.present(wbo)) then error stop 'CANGEN implementation requires wbo matrix as argument' - endif + end if do i = 1,k ii = self%hmap(i) ati = mol%at(ii) @@ -239,7 +252,7 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) if (Amat(j,ii) .ne. 0) then if (mol%at(j) .eq. 1) then counth = counth+1 !> count H neighbours - countbo2 = countbo2-wbo(j,ii) !> but NOT in total bond order + countbo2 = countbo2-wbo(j,ii) !> but NOT in total bond order end if countb = countb+1 !> count all neighbours !countbo2 = countbo2+wbo(j,ii) !> sum the total bond order @@ -264,8 +277,8 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) call debugprint(self,mol) end if !>--- start assignment - allocate (self%newrank(k),source=0) !> workspace - allocate (self%newinv(k),source=0_int64) !>workspace + if (.not.allocated(self%newrank)) allocate (self%newrank(k),source=0) !> workspace + if (.not.allocated(self%newinv)) allocate (self%newinv(k),source=0_int64) !>workspace call self%update_ranks() self%rank(:) = self%newrank(:) if (debug) then @@ -276,6 +289,14 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype) call debugprint(self,mol) end if call self%iterate(mol) !> iterate recursively until ranking doesn't change + +!>--- finally, if required, add H atoms + if (include_H .and. anyH) then + !> sinc H's will have been added with rank 1, shift all ranks + self%rank(:) = self%rank(:)-1 + call self%add_h_ranks(mol) + end if + end subroutine init_canonical_sorter !========================================================================================! @@ -475,7 +496,7 @@ subroutine analyze_stereo(self,mol) zero = count(self%neigh(:,ii) == 0) nei = self%maxnei-zero !>--- consider only atoms with 4 unique (in terms of CANGEN ranks) neighbours as stereocenter - if (nei == 4) then + if (nei == 4) then do j = 1,4 jj = self%neigh(j,ii) if (mol%at(jj) == 1) then !> one hydrogen allowed @@ -513,6 +534,42 @@ subroutine analyze_stereo(self,mol) deallocate (neiranks,isstereo) end subroutine analyze_stereo +!===========================================================================================! + + function has_stereo(self,mol) result(yesno) + implicit none + logical :: yesno + class(canonical_sorter),intent(in) :: self + type(coord),intent(in) :: mol + integer :: i,ii,zero,nei,j,jj,maxrank + integer :: k,l,rs + integer,allocatable :: neiranks(:,:) + real(wp) :: coords(3,4) + logical,allocatable :: isstereo(:) + allocate (isstereo(mol%nat),source=.false.) + allocate (neiranks(4,mol%nat),source=0) + maxrank = maxval(self%rank(:)) + do i = 1,self%hatms + ii = self%hmap(i) + zero = count(self%neigh(:,ii) == 0) + nei = self%maxnei-zero +!>--- consider only atoms with 4 unique (in terms of ranks) neighbours as stereocenter + if (nei == 4) then + do j = 1,4 + jj = self%neigh(j,ii) + if (mol%at(jj) == 1) then !> one hydrogen allowed + neiranks(j,ii) = maxrank+1 + else + neiranks(j,ii) = self%rank(jj) + end if + end do + isstereo(ii) = unique_neighbours(4,neiranks(:,ii)) + end if + end do + yesno = any(isstereo(:)) + deallocate (neiranks,isstereo) + end function has_stereo + !========================================================================================! function compare_canonical_sorter(self,other) result(yesno) @@ -569,44 +626,53 @@ function compare_canonical_sorter(self,other) result(yesno) return end function compare_canonical_sorter -!========================================================================================! !========================================================================================! - function nth_prime(x) result(prime) + subroutine add_h_ranks(self,mol) +!****************************************************************** +!* Mapps ranks of the heavy atoms back to the full molecule order +!* And continues ranks for H atoms, based on neighbor list +!****************************************************************** implicit none - integer,intent(in) :: x - integer :: prime - integer :: c,num,i - logical :: is_prime - integer,parameter :: prime_numbers(100) = (/2,3,5,7,11,13,17,19,23,29, & - & 31,37,41,43,47,53,59,61,67,71,73,79,83,89,97,101,103,107,109, & - & 113,127,131,137,139,149,151,157,163,167,173,179,181,191,193,197, & - & 199,211,223,227,229,233,239,241,251,257,263,269,271,277,281,283, & - & 293,307,311,313,317,331,337,347,349,353,359,367,373,379,383,389, & - & 397,401,409,419,421,431,433,439,443,449,457,461,463,467,479,487, & - & 491,499,503,509,521,523,541/) - if (x <= 100) then - prime = prime_numbers(x) - return + class(canonical_sorter),intent(inout) :: self + type(coord),intent(in) :: mol + integer,allocatable :: rankh(:) + integer,allocatable :: rankmap(:) + integer :: i,ii,zero,nei,j,jj,maxrank,rr,maxrank2 + logical :: hneigh +!>--- self%rank must already have the correct dimension! + if (size(self%rank,1) .ne. mol%nat) then + stop 'wrong dimension for adding H to canonical ranks!' end if - c = 0 - num = 1 - do while (c < x) - num = num+1 - is_prime = .true. - do i = 2,int(sqrt(real(num))) - if (mod(num,i) == 0) then - is_prime = .false. - exit - end if - end do - if (is_prime) then - c = c+1 + +!>--- otherwise, analyze and resize + maxrank = maxval(self%rank(:),1) + +!>--- cycle through atoms, assign ranks depending on neighbour list + allocate (rankmap(maxrank),source=0) + rr = 0 + do i = 1,self%hatms + if (mol%at(i) .ne. 1) cycle + ii = self%neigh(1,i) + jj = self%rank(ii) + rankmap(jj) = 1 + end do + do i = 1,maxrank + if (rankmap(i) .eq. 1) then + rr = rr+1 + rankmap(i) = maxrank+rr end if end do - prime = num - end function nth_prime + do i = 1,self%hatms + if (mol%at(i) .ne. 1) cycle + ii = self%neigh(1,i) + jj = self%rank(ii) + self%rank(i) = rankmap(jj) + end do + deallocate (rankmap) + end subroutine add_h_ranks +!========================================================================================! !========================================================================================! subroutine debugprint(can,mol) diff --git a/src/ccegen.f90 b/src/sorting/ccegen.f90 similarity index 100% rename from src/ccegen.f90 rename to src/sorting/ccegen.f90 diff --git a/src/cregen.f90 b/src/sorting/cregen.f90 similarity index 85% rename from src/cregen.f90 rename to src/sorting/cregen.f90 index 31b86ca9..8f9f978f 100644 --- a/src/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -37,6 +37,7 @@ module cregen_interface !* module to load an interface to the newcregen routine !* mandatory to handle the optional input arguments !******************************************************* + use unionize_module implicit none interface subroutine newcregen(env,quickset,infile) @@ -49,7 +50,33 @@ subroutine newcregen(env,quickset,infile) integer,intent(in),optional :: quickset character(len=*),intent(in),optional :: infile end subroutine newcregen + + subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) + use strucrd + implicit none + !> INPUT + integer,intent(in) :: nall + type(coord),intent(inout),target :: structures(nall) + integer,intent(in),optional :: printlvl + integer,intent(in),optional :: iinversion + end subroutine cregen_irmsd_all + + subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) + use crest_data + use strucrd + implicit none + !> INPUT + type(systemdata),intent(inout) :: env + integer,intent(in) :: nall + type(coord),intent(inout),target :: structures(nall) + integer,intent(inout) :: groups(nall) + logical,intent(in),optional :: allcanon + integer,intent(in),optional :: printlvl + end subroutine cregen_irmsd_sort + end interface +!>--- Additional Related RE-EXPORTS + public :: unionizeEnsembles end module cregen_interface subroutine newcregen(env,quickset,infile) @@ -87,6 +114,7 @@ subroutine newcregen(env,quickset,infile) !>--- sorting arguments integer,allocatable :: gref(:),group(:) integer :: ng + integer :: i integer,allocatable :: degen(:,:) !>--- float data @@ -163,7 +191,7 @@ subroutine newcregen(env,quickset,infile) call rdensemble(fname,nat,nallref,at,xyz,comments) !call rdensemble(fname,nallref,structures) !allocate(references, source=structures) - + !>--- track ensemble for restart call trackensemble(fname,nat,nallref,at,xyz,comments) @@ -241,6 +269,19 @@ subroutine newcregen(env,quickset,infile) ng = group(0) allocate (degen(3,ng)) call cregen_groupinfo(nall,ng,group,degen) + else + ng = nall + if (ng > 0) then + allocate (degen(3,ng)) + do i = 1, ng + degen(1,i) = 1 + degen(2,i) = i + degen(3,i) = i + end do + else + allocate (degen(3,1)) + degen = 0 + end if end if if (sortRMSD2) then allocate (group(0:nall)) @@ -464,7 +505,7 @@ subroutine cregen_director(env,simpleset,checkbroken,sortE,sortRMSD,sortRMSD2, & logical,intent(out) :: anal logical,intent(out) :: topocheck logical,intent(out) :: checkez - logical,intent(out) :: saveelow + logical,intent(out) :: saveelow checkbroken = .true. !> fragmentized structures are sorted out sortE = .true. !> sort based on energy @@ -636,6 +677,7 @@ subroutine discardbroken(ch,env,topocheck,nat,nall,at,xyz,comments,newnall) use crest_data use strucrd use miscdata,only:rcov + use quicksort_interface implicit none !> INPUT type(systemdata) :: env ! MAIN STORAGE OS SYSTEM DATA @@ -731,7 +773,8 @@ subroutine discardbroken(ch,env,topocheck,nat,nall,at,xyz,comments,newnall) order = orderref call xyzqsort(nat,nall,xyz,c0,order,1,nall) order = orderref - call stringqsort(nall,comments,1,nall,order) + !call stringqsort(nall,comments,1,nall,order) + call stringqsort(nall,len(comments(1)),comments,1,nall,order) llan = nall-newnall write (ch,'('' number of removed clashes :'',i6)') llan @@ -764,6 +807,7 @@ subroutine cregen_topocheck(ch,env,checkez,nat,nall,at,xyz,comments,newnall) use miscdata,only:rcov use utilities use crest_cn_module + use quicksort_interface implicit none type(systemdata) :: env ! MAIN STORAGE OS SYSTEM DATA integer,intent(in) :: ch ! printout channel @@ -881,7 +925,8 @@ subroutine cregen_topocheck(ch,env,checkez,nat,nall,at,xyz,comments,newnall) order = orderref call xyzqsort(nat,nall,xyz,c1,order,1,nall) order = orderref - call stringqsort(nall,comments,1,nall,order) + !call stringqsort(nall,comments,1,nall,order) + call stringqsort(nall,len(comments(1)),comments,1,nall,order) llan = nall-newnall write (ch,'('' number of topology mismatches :'',i6)') llan @@ -1050,6 +1095,7 @@ subroutine cregen_esort(ch,nat,nall,xyz,comments,nallout,ewin) !************************************************************** use crest_parameters use strucrd + use quicksort_interface implicit none integer,intent(in) :: ch integer,intent(in) :: nat @@ -1088,7 +1134,8 @@ subroutine cregen_esort(ch,nat,nall,xyz,comments,nallout,ewin) deallocate (c0) order = orderref - call stringqsort(nall,comments,1,nall,order) + !call stringqsort(nall,comments,1,nall,order) + call stringqsort(nall,len(comments(1)),comments,1,nall,order) !>-- determine cut-off of energies if (ewin < 9999.9_wp) then @@ -1143,6 +1190,7 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) use ls_rmsd use axis_module use utilities + use quicksort_interface implicit none type(systemdata) :: env integer,intent(in) :: ch @@ -1413,7 +1461,7 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) order = orderref call maskqsort(er,1,nall,order) order = orderref - call stringqsort(nall,comments,1,nall,order) + call stringqsort(nall,len(comments(1)),comments,1,nall,order) order = orderref call matqsort(3,nall,rot,rotdum,1,nall,order) end if @@ -1507,6 +1555,395 @@ end subroutine cregen_CRE !=========================================================================================! +subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) +!******************************************** +!* Proof-of-concept routine to run all +!* pairs of RMSD for an array of structures +!******************************************** + use crest_parameters + use crest_data + use strucrd + use axis_module + use canonical_mod + use irmsd_module + use utilities,only:lin + implicit none + !> INPUT + integer,intent(in) :: nall + type(coord),intent(inout),target :: structures(nall) + integer,intent(in),optional :: printlvl + integer,intent(in),optional :: iinversion + !> LOCAL + integer :: i,j,ii,jj,T,nallpairs,cc,nat + integer :: prlvl,iunit + type(rmsd_cache),allocatable :: rcaches(:) + type(coord),allocatable,target :: workmols(:) + type(canonical_sorter),allocatable :: sorters(:) + real(wp),allocatable :: rmsds(:) + type(coord),pointer :: ref,mol + type(coord) :: molloc + real(wp) :: rmsdval,runtime + logical :: stereocheck + type(timer) :: profiler + + logical,parameter :: debug = .false. + real(wp),allocatable :: debugrmsds(:) + + !> for implementing OpenMP parallelism + T = 1 + + !> print level + if (present(printlvl)) then + prlvl = printlvl + else + prlvl = 0 + end if + + !> set up timer + call profiler%init(3) + + !> prepare workspace + nallpairs = (nall*(nall+1))/2 + allocate (rmsds(nallpairs),source=0.0_wp) + if (debug) then + allocate (debugrmsds(nallpairs),source=0.0_wp) + end if + + allocate (rcaches(T)) + ref => structures(1) + nat = ref%nat + allocate (workmols(T)) + do i = 1,T + mol => workmols(i) + allocate (mol%at(ref%nat)) + allocate (mol%xyz(3,ref%nat)) + nullify (mol) + call rcaches(i)%allocate(ref%nat) + end do + + !> set up ranks for each structure + call profiler%start(1) + allocate (sorters(nall)) + if (prlvl > 0) then + write (stdout,'(a)',advance='no') 'CREGEN> Setting up canonical atom ranks ... ' + flush (stdout) + end if + do ii = 1,nall + mol => structures(ii) + call axis(mol%nat,mol%at,mol%xyz) + call sorters(ii)%init(mol,invtype='apsp+',heavy=.false.) + !call sorters(ii)%add_h_ranks(mol) + if (ii == 1) then + stereocheck = .not. (sorters(ii)%hasstereo(ref)) + end if + call sorters(ii)%shrink() + end do + call profiler%stop(1) + if (prlvl > 0) then + call profiler%write_timing(stdout,1,'done.',.true.) + runtime = (profiler%get(1)/real(nall,wp))*1000.0_wp + write (stdout,'(a,f0.3,a)') 'CREGEN> Corresponding to approximately ',runtime, & + & ' ms per processed structure' + end if + + !> allow user to set inversion check (false rotamers) + if (present(iinversion)) then + select case (iinversion) + case (0) + continue + case (1) + stereocheck = .true. + case (2) + stereocheck = .false. + end select + if (prlvl > 1) then + write (stdout,'(a,l2)') 'CREGEN> Check for false rotamers (geometry inversion)? -->',stereocheck + end if + end if + + !> And finally, run the RMSD checks + call profiler%start(2) + if (prlvl > 0) then + write (stdout,*) + write (stdout,'(a)',advance='no') 'CREGEN> Running all pair RMSDs ... ' + flush (stdout) + end if + cc = 1 + do ii = 1,nall + rcaches(cc)%stereocheck = stereocheck + rcaches(cc)%rank(1:nat,1) = sorters(ii)%rank(1:nat) + do jj = ii+1,nall + workmols(cc)%nat = structures(jj)%nat + workmols(cc)%at(:) = structures(jj)%at(:) + workmols(cc)%xyz(:,:) = structures(jj)%xyz(:,:) + !molloc = structures(jj) + rcaches(cc)%rank(:,2) = sorters(jj)%rank(:) + call min_rmsd(structures(ii),workmols(cc), & + & rcache=rcaches(cc),rmsdout=rmsdval) + rmsds(lin(ii,jj)) = rmsdval + end do + end do + call profiler%stop(2) + if (prlvl > 0) then + call profiler%write_timing(stdout,2,'done.',.true.) + !write (stdout,'(a)',advance='yes') 'done.' + runtime = (profiler%get(2)/real(nallpairs,wp))*1000.0_wp + write (stdout,'(a,f0.3,a)') 'CREGEN> Corresponding to approximately ',runtime, & + & ' ms per processed RMSD' + + end if + + if (debug) then + !> RMSD without permutation + do ii = 1,nall + do jj = ii+1,nall + rmsdval = rmsd(structures(ii),structures(jj)) + debugrmsds(lin(ii,jj)) = rmsdval + end do + end do + end if + + if (prlvl > 1) then + write (stdout,'(a)') 'CREGEN> Writing cregen_rmsds.csv with RMSDs in Angström' + open (newunit=iunit,file='cregen_rmsds.csv') + if (debug) then + write (iunit,'(a,3(",",a))') 'A','B','rmsd','rmsdref' + do ii = 1,nall + do jj = ii+1,nall + write (iunit,'(i0,",",i0,2(",",f0.7))') & + & min(ii,jj),max(ii,jj),rmsds(lin(ii,jj))*autoaa,debugrmsds(lin(ii,jj))*autoaa + end do + end do + else + write (iunit,'(a,",",a,",",a)') 'A','B','rmsd' + do ii = 1,nall + do jj = ii+1,nall + write (iunit,'(i0,",",i0,",",f0.7)') min(ii,jj),max(ii,jj),rmsds(lin(ii,jj))*autoaa + end do + end do + end if + close (iunit) + end if + + deallocate (sorters) + deallocate (workmols) + deallocate (rcaches) + deallocate (rmsds) +end subroutine cregen_irmsd_all + +!=========================================================================================! + +subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) +!******************************************************* +!* Proof-of-concept routine to analyze an +!* ensemble only via the iRMSD procedure. +!* Conformers are identified by the rthr threshold only +!******************************************************* + use crest_parameters + use crest_data + use iomod,only:to_str + use strucrd + use axis_module + use canonical_mod + use irmsd_module + use utilities,only:lin + use omp_lib + implicit none + !> INPUT + type(systemdata),intent(inout) :: env + integer,intent(in) :: nall + type(coord),intent(inout),target :: structures(nall) + integer,intent(inout) :: groups(nall) + logical,intent(in),optional :: allcanon + integer,intent(in),optional :: printlvl + + !> LOCAL + integer :: i,j,ii,jj,T,Tn,nallpairs,cc,nat + integer :: gcount + integer :: prlvl,iunit + type(rmsd_cache),allocatable :: rcaches(:) + type(coord),allocatable,target :: workmols(:) + type(canonical_sorter),allocatable :: sorters(:) + real(wp),allocatable :: rmsds(:) + type(coord),pointer :: ref,mol + type(coord) :: molloc + real(wp) :: rmsdval,runtime,RTHR + logical :: stereocheck,individual_IDs + type(timer) :: profiler + + logical,parameter :: debug = .true. + +!>--- handle optional arguments + if (present(allcanon)) then + individual_IDs = allcanon + else + individual_IDs = .false. + end if + if (present(printlvl)) then + prlvl = printlvl + else + prlvl = 1 + end if + +!>--- set up parallelization + call new_ompautoset(env,'max',nall,T,Tn) + +!>--- set up timer + call profiler%init(3) + +!>--- set up parameters (note we are working with BOHR internally) + RTHR = env%rthr*aatoau + +!>--- print some sorting data + if (prlvl > 0) then + write (stdout,'(a)') 'CREGEN> Info for iRMSD sorting:' + write (stdout,'(2x,a,i9)') 'number of structures :',nall + write (stdout,'(2x,a,f9.5,a)') 'RTHR (RMSD threshold) :',RTHR*autoaa,' Å' + write (stdout,'(2x,a,i9)') 'OpenMP threads :',T + write (stdout,'(2x,a,a9)') 'Individual atom IDs? :',to_str(individual_IDs) + write (stdout,'(2x,a)',advance='no') 'False rotamer check? :' + select case(env%iinversion) + case (0) + write(stdout,'(a9)') 'auto' + case (1) + write(stdout,'(a9)') 'on' + case (2) + write(stdout,'(a9)') 'off' + end select + write (stdout,*) + end if + +!>--- Set up atom identities (either for all, or just the first structure) + if (individual_IDs) then + allocate (sorters(nall)) + else + allocate (sorters(1)) + end if + if (prlvl > 0) then + write (stdout,'(a)',advance='no') 'CREGEN> Setting up canonical atom ranks ... ' + flush (stdout) + call profiler%start(1) + end if + ref => structures(1) + !$omp parallel & + !$omp shared(sorters, structures, stereocheck) & + !$omp private(mol,ii) + !$omp do schedule(dynamic) + do ii = 1,nall + mol => structures(ii) + call axis(mol%nat,mol%at,mol%xyz) + if (individual_IDs.or.ii == 1) then + call sorters(ii)%init(mol,invtype='apsp+',heavy=.false.) + end if + if (ii == 1) then + stereocheck = .not. (sorters(ii)%hasstereo(ref)) + end if + if (individual_IDs.or.ii == 1) then + call sorters(ii)%shrink() + end if + end do + !$omp end do + !$omp end parallel + if (prlvl > 0) then + call profiler%stop(1) + call profiler%write_timing(stdout,1,'done.',.true.) + runtime = (profiler%get(1)/real(nall,wp))*1000.0_wp + write (stdout,'(1x,a,f0.3,a)') '* Corresponding to approximately ',runtime, & + & ' ms per processed RMSD' + write (stdout,*) + end if + + !>--- allow user to set inversion check (false rotamers) + select case (env%iinversion) + case (0) + continue + case (1) + stereocheck = .true. + case (2) + stereocheck = .false. + end select + if (prlvl > 1) then + write (stdout,'(a,l2)') 'CREGEN> Check for false rotamers (geometry inversion)? -->',stereocheck + end if + +!>--- allocate work cache + if (prlvl > 0) then + write (stdout,'(a)',advance='no') 'CREGEN> Allocating iRMSD work cache ... ' + flush (stdout) + end if + allocate (rcaches(T)) + ref => structures(1) + nat = ref%nat + allocate (workmols(T)) + do i = 1,T + mol => workmols(i) + allocate (mol%at(ref%nat)) + allocate (mol%xyz(3,ref%nat)) + nullify (mol) + call rcaches(i)%allocate(ref%nat) + rcaches(i)%stereocheck = stereocheck + end do + if (prlvl > 0) then + write (stdout,'(a)') 'done.' + write (stdout,*) + end if + +!>--- run the checks + if (prlvl > 0) then + write (stdout,'(a)',advance='no') 'CREGEN> Running all pair RMSDs ... ' + flush (stdout) + call profiler%start(2) + end if + gcount = maxval(groups(:)) + do ii = 1,nall +!>--- find next unassigned conformer and assign a new group + if (groups(ii) .ne. 0) cycle + gcount = gcount+1 + groups(ii) = gcount + +!>--- Then, cross-check all other unassigned conformers + !$omp parallel & + !$omp shared(nall, nat, groups, individual_IDs, sorters, rcaches) & + !$omp shared(workmols, structures, ii) & + !$omp private(jj,rmsdval,cc) + !$omp do schedule(dynamic) + do jj = ii+1,nall + cc = omp_get_thread_num()+1 + if (groups(jj) .ne. 0) cycle + if (individual_IDs) then + rcaches(cc)%rank(1:nat,1) = sorters(ii)%rank(1:nat) + rcaches(cc)%rank(1:nat,2) = sorters(jj)%rank(1:nat) + else + rcaches(cc)%rank(1:nat,1) = sorters(1)%rank(1:nat) + rcaches(cc)%rank(1:nat,2) = sorters(1)%rank(1:nat) + end if + workmols(cc)%nat = structures(jj)%nat + workmols(cc)%at(:) = structures(jj)%at(:) + workmols(cc)%xyz(:,:) = structures(jj)%xyz(:,:) + call min_rmsd(structures(ii),workmols(cc), & + & rcache=rcaches(cc),rmsdout=rmsdval) + if (rmsdval < RTHR) groups(jj) = gcount + end do + !$omp end do + !$omp end parallel + end do + if (prlvl > 0) then + call profiler%stop(2) + call profiler%write_timing(stdout,2,'done.',.true.) + write (stdout,*) + end if + + if (debug) then + write (*,*) 'assigned groups, and count' + do ii = 1,maxval(groups(:)) + write (*,*) ii,count(groups(:) == ii) + end do + end if + +end subroutine cregen_irmsd_sort + +!=========================================================================================! + subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) !**************************************************************** !* subroutine cregen_EQUAL @@ -1941,6 +2378,7 @@ subroutine cregen_repairorder(nat,nall,xyz,comments,group) use crest_data use strucrd use utilities + use quicksort_interface implicit none integer,intent(in) :: nat integer,intent(in) :: nall @@ -1994,7 +2432,8 @@ subroutine cregen_repairorder(nat,nall,xyz,comments,group) call xyzqsort(nat,nall,xyz,cdum,order,1,nall) deallocate (cdum) order = orderref - call stringqsort(nall,comments,1,nall,order) + !call stringqsort(nall,comments,1,nall,order) + call stringqsort(nall,len(comments(1)),comments,1,nall,order) if (ttag) then edum = grepenergy(comments(1)) write (btmp,*) edum,'!t1' @@ -2194,6 +2633,7 @@ subroutine cregen_conffile(env,cname,nat,nall,at,xyz,comments,ng,degen) open (newunit=ich,file=trim(cname)) do i = 1,ng k = degen(2,i) + if (k <= 0 .or. k > nall) cycle if (i .eq. 1.or.env%printscoords) then !write a scoord.* for each conformer? scoord.1 is always written call getname1(i,newcomment) c0(:,:) = xyz(:,:,k)/bohr @@ -2314,11 +2754,13 @@ end subroutine cregen_bonusfiles subroutine cregen_setthreads(ch,env,pr) use crest_parameters use crest_data + use omp_lib implicit none type(systemdata) :: env integer :: ch logical :: pr - integer :: TID,OMP_GET_NUM_THREADS,OMP_GET_THREAD_NUM,nproc,T,Tn + !integer :: TID,OMP_GET_NUM_THREADS,OMP_GET_THREAD_NUM, + integer :: TID,nproc,T,Tn !>---- setting the threads for OMP parallel usage if (env%autothreads) then call new_ompautoset(env,'max',0,T,Tn) diff --git a/src/ensemblecomp.f90 b/src/sorting/ensemblecomp.f90 similarity index 100% rename from src/ensemblecomp.f90 rename to src/sorting/ensemblecomp.f90 diff --git a/src/sorting/hungarian.f90 b/src/sorting/hungarian.f90 new file mode 100644 index 00000000..dd9b1d5c --- /dev/null +++ b/src/sorting/hungarian.f90 @@ -0,0 +1,592 @@ +module hungarian_module +!************************************************************ +!* Implementations of +!* A) The Hungarian (Kuhn-Munkres) Algorithm +!* in O(n³) time (Edmons & Karp / Tomizawa). +!* +!* B) A Rectengular linear assignment problem algorithm +!* (LSAP) accodring to +!* D.F. Crouse, IEEE Trans. Aerosp. Electron. Syst., +!* 2016, 52, 1679-1696, doi: 10.1109/TAES.2016.140952 +!* +!* Implemented in single precision with a cache to +!* circumvent repeated memory allocation. +!* +!* Also includes some wrappers for standalone use +!************************************************************ + use iso_fortran_env,sp => real32,wp => real64 + implicit none + private + + public :: hungarian + interface hungarian + module procedure hungarian_cached + module procedure hungarian_wrap_int + module procedure hungarian_wrap_sp + module procedure hungarian_wrap_wp + end interface hungarian + + public :: lsap + interface lsap + module procedure lsap_cached + module procedure lsap_wrap_int + module procedure lsap_wrap_sp + module procedure lsap_wrap_wp + end interface lsap + + real(sp),parameter,private :: inf = huge(1.0_sp) !> Use huge intrinsic for large numbers + integer,parameter,private :: infi = huge(1) !> Use huge intrinsic for large numbers + + public :: assignment_cache + type :: assignment_cache + integer :: J,W + real(sp),allocatable :: Cost(:) !> Cost(J*W), 1D for more efficient memory access + !> Hungarian algo related + real(sp),allocatable :: answers(:) !> answers(J) + integer,allocatable :: job(:) !> job(W+1) + real(sp),allocatable :: ys(:) !> ys(J) + real(sp),allocatable :: yt(:) !> yt(W+1) + real(sp),allocatable :: Ct(:,:) !> Ct(W,J) + real(sp),allocatable :: min_to(:) !> min_to(W+1) + integer,allocatable :: prv(:) !> prv(W+1) + logical,allocatable :: in_Z(:) !> in_Z(W+1) + !> LSAP related + integer,allocatable :: a(:),b(:) !> a(J), b(J) + real(sp),allocatable :: u(:),v(:) !> u(J), v(W) + real(sp),allocatable :: shortestPathCosts(:) !> ...(W) + integer,allocatable :: path(:),remaining(:) !> path(W), remaining(W) + integer,allocatable :: col4row(:),row4col(:) !> col4row(J), row4col(W) + logical,allocatable :: SR(:),SC(:) !> SR(J), SC(W) + contains + procedure :: allocate => allocate_assignment_cache + procedure :: deallocate => deallocate_assignment_cache + end type assignment_cache + + interface ckmin + module procedure ckmin_int + module procedure ckmin_sp + end interface ckmin + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + subroutine allocate_assignment_cache(self,J,W,lsapcache) + implicit none + integer,intent(in) :: J + integer,intent(in) :: W + class(assignment_cache),intent(inout) :: self + logical,intent(in),optional :: lsapcache + logical :: yesno + yesno = .false. + if (present(lsapcache)) yesno = lsapcache + + !> Store dimensions + self%J = J + self%W = W + if (J > W) then + error stop 'linear assignment problems require rectengular matrices!' + end if + allocate (self%Cost(J*W)) + + !> Allocate arrays based on input dimensions & algo type + if (.not.yesno) then + !> Hungarian algo cache: + allocate (self%answers(J)) + allocate (self%job(W+1)) + !> Allocate workspace arrays + allocate (self%ys(J)) + allocate (self%yt(W+1)) + allocate (self%Ct(W,J)) + allocate (self%min_to(W+1)) + allocate (self%prv(W+1)) + allocate (self%in_Z(W+1)) + else + !> LSAP cache + allocate (self%a(J),self%b(J)) + allocate (self%u(J),self%v(W),self%shortestPathCosts(W)) + allocate (self%path(W),self%col4row(J),self%row4col(W)) + allocate (self%SR(J),self%SC(W),self%remaining(W)) + end if + end subroutine allocate_assignment_cache + + subroutine deallocate_assignment_cache(self) + implicit none + class(assignment_cache),intent(inout) :: self + ! Deallocate arrays if they are allocated + if (allocated(self%Cost)) deallocate (self%Cost) + if (allocated(self%answers)) deallocate (self%answers) + if (allocated(self%job)) deallocate (self%job) + if (allocated(self%ys)) deallocate (self%ys) + if (allocated(self%yt)) deallocate (self%yt) + if (allocated(self%Ct)) deallocate (self%Ct) + if (allocated(self%min_to)) deallocate (self%min_to) + if (allocated(self%prv)) deallocate (self%prv) + if (allocated(self%in_Z)) deallocate (self%in_Z) + if (allocated(self%a)) deallocate (self%a) + if (allocated(self%b)) deallocate (self%b) + if (allocated(self%u)) deallocate (self%u) + if (allocated(self%v)) deallocate (self%v) + if (allocated(self%shortestPathCosts)) deallocate (self%shortestPathCosts) + if (allocated(self%path)) deallocate (self%path) + if (allocated(self%col4row)) deallocate (self%col4row) + if (allocated(self%row4col)) deallocate (self%row4col) + if (allocated(self%SR)) deallocate (self%SR) + if (allocated(self%SC)) deallocate (self%SC) + if (allocated(self%remaining)) deallocate (self%remaining) + end subroutine deallocate_assignment_cache + +!========================================================================================! + + logical function ckmin_int(a,b) result(yesno) + !> Helper function to compute the minimum and update + integer,intent(inout) :: a + integer,intent(in) :: b + yesno = .false. + if (b < a) then + a = b + yesno = .true. + end if + end function ckmin_int + + logical function ckmin_sp(a,b) result(yesno) + !> Helper function to compute the minimum and update + real(sp),intent(inout) :: a + real(sp),intent(in) :: b + yesno = .false. + if (b < a) then + a = b + yesno = .true. + end if + end function ckmin_sp + + subroutine hungarian_cached(cache,J,W) + !**************************************************************** + !* Hungarian algorithm implementation to solve an assignment + !* problem in O(n³) time. + !* This implementation refers to a cache, which is created + !* to avoid repeated memory allocation. + !* Passing J and W explicitly enables reuse of memory + !* for smaller sub-problems (i.e. cache%J >= J, W accoridingly) + !* Unfortunately, this algorithm has problems with + !* assignments of equal cost. + !* + !* Inputs (all within cache, except J and W): + !* C(J, W) - Cost matrix of dimensions J-by-W, + !* where C(jj, ww) is the cost to assign + !* jj-th job to ww-th worker + !* J - Number of jobs + !* W - Number of workers + !* Outputs (all within cache): + !* answers(J) - Vector of length J, where answers(jj) is + !* the minimum cost to assign the first jj + !* jobs to distinct workers + !* job(W+1) - Vector where job(ww) is the job assigned to + !* the ww-th worker (or -1 if no job is assigned) + !**************************************************************** + integer,intent(in) :: J + integer,intent(in) :: W + type(assignment_cache),intent(inout) :: cache + integer :: jj_cur,ww_cur,jj,ww_next,ww + real(sp) :: delta + + !> IMPORTANT: associate to have shorter variable names + associate (C => cache%Cost, & + & answers => cache%answers, & + & job => cache%job, & + & ys => cache%ys, & + & yt => cache%yt, & + & Ct => cache%Ct, & + & min_to => cache%min_to, & + & prv => cache%prv, & + & in_Z => cache%in_Z) + + job = -1 + ys = 0 + yt = 0 + !Ct = transpose(reshape(C,[J,W])) + + do jj_cur = 1,J !> O(n¹) + ww_cur = W+1 + job(ww_cur) = jj_cur + min_to = inf + prv = -1 + in_Z = .false. + + do while (job(ww_cur) /= -1) !> O(n¹) -> O(n²) + in_Z(ww_cur) = .true. + jj = job(ww_cur) + delta = inf + do ww = 1,W !> O(n²) -> O(n³) + if (.not.in_Z(ww)) then + !if (ckmin(min_to(ww),Ct(ww,jj)-ys(jj)-yt(ww))) then + if (ckmin(min_to(ww),C(jj+(ww-1)*J)-ys(jj)-yt(ww))) then + prv(ww) = ww_cur + end if + if (ckmin(delta,min_to(ww))) then + ww_next = ww + end if + end if + end do + + do ww = 1,W+1 + if (in_Z(ww)) then + ys(job(ww)) = ys(job(ww))+delta + yt(ww) = yt(ww)-delta + else + min_to(ww) = min_to(ww)-delta + end if + end do + ww_cur = ww_next + end do + + !> Update assignments along alternating path + do while (ww_cur /= W+1) + job(ww_cur) = job(prv(ww_cur)) + ww_cur = prv(ww_cur) + end do + + answers(jj_cur) = -yt(W+1) + end do + + end associate + end subroutine hungarian_cached + +!========================================================================================! + + subroutine hungarian_wrap_int(C,J,W,answers,job) + !********************************************* + !* Wrapper for integer precision + !********************************************* + implicit none + integer,intent(in) :: J + integer,intent(in) :: W + integer,intent(in) :: C(J,W) + integer,intent(out) :: answers(J) + integer,intent(out) :: job(W+1) + type(assignment_cache) :: cache + + call cache%allocate(J,W) + cache%Cost(1:J*W) = reshape(real(C(1:J,1:W),sp),[J*W]) + call hungarian_cached(cache,J,W) + + answers(1:J) = nint(cache%answers(1:J)) + job(1:W+1) = cache%job(1:W+1) + call cache%deallocate() + end subroutine hungarian_wrap_int + + subroutine hungarian_wrap_sp(C,J,W,answers,job) + !********************************************* + !* Wrapper for single precision + !********************************************* + implicit none + integer,intent(in) :: J + integer,intent(in) :: W + real(sp),intent(in) :: C(J,W) + real(sp),intent(out) :: answers(J) + integer,intent(out) :: job(W+1) + type(assignment_cache) :: cache + + call cache%allocate(J,W) + cache%Cost(1:J*W) = reshape(C(1:J,1:W),[J*W]) + call hungarian_cached(cache,J,W) + + answers(1:J) = cache%answers(1:J) + job(1:W+1) = cache%job(1:W+1) + call cache%deallocate() + end subroutine hungarian_wrap_sp + + subroutine hungarian_wrap_wp(C,J,W,answers,job) + !********************************************* + !* Wrapper for double precision + !********************************************* + implicit none + integer,intent(in) :: J + integer,intent(in) :: W + real(wp),intent(in) :: C(J,W) + real(wp),intent(out) :: answers(J) + integer,intent(out) :: job(W+1) + type(assignment_cache) :: cache + + call cache%allocate(J,W) + cache%Cost(1:J*W) = reshape(real(C(1:J,1:W),sp),[J*W]) + call hungarian_cached(cache,J,W) + + answers(1:J) = real(cache%answers(1:J),wp) + job(1:W+1) = cache%job(1:W+1) + call cache%deallocate() + end subroutine hungarian_wrap_wp + +!========================================================================================! +!========================================================================================! + +!**************************************************************** +!* The following implements an alternative algorithm capable +!* to better handle assignments with equivalent costs +!* The algorithm follows +!* D.F. Crouse, IEEE Trans. Aerosp. Electron. Syst., +!* 2016, 52, 1679-1696, doi: 10.1109/TAES.2016.140952 +!* +!* The source code is a free Fortran-adaptation +!* of the C++ lsap algorithm in SciPy +!**************************************************************** + + function augmenting_path(nr,nc,cost,u,v,path,row4col, & + & shortestPathCosts,i,SR,SC, & + & remaining,minValue) result(sink) + implicit none + integer,intent(in) :: nr !> Number of columns (jobs) + integer,intent(in) :: nc !> Number of columns (workers) + real(sp),intent(in) :: cost(:) !> Cost matrix (1D, nr*nc length) + real(sp),intent(inout) :: u(:) !> Dual variables for rows (jobs) + real(sp),intent(inout) :: v(:) !> Dual variables for columns (workers) + integer,intent(inout) :: path(:) !> Path array + integer,intent(inout) :: row4col(:) !> Array storing which row is assigned to which column + real(sp),intent(inout) :: shortestPathCosts(:) !> Array for storing shortest path costs + integer,intent(inout) :: i !> Current row being processed + logical,intent(inout) :: SR(:) !> Boolean array for rows + logical,intent(inout) :: SC(:) !> Boolean array for columns + integer,intent(inout) :: remaining(:) !> Array of remaining columns to be processed + real(sp),intent(inout) :: minValue !> Minimum value of the path cost + integer :: sink !> The resulting sink (column) from the augmenting path + integer :: num_remaining,indx,j,it + real(sp) :: lowest,r + + minValue = 0.0_sp + num_remaining = nc + + !> Initialize the remaining array in reverse order + do it = 1,nc + remaining(it) = nc-(it-1) + end do + + !> Initialize SR, SC, and shortestPathCosts + SR = .false. + SC = .false. + shortestPathCosts = inf !> Set to a very large value + + !> Start finding the shortest augmenting path + sink = -1 + do while (sink == -1) + indx = -1 + lowest = inf + SR(i) = .true. + + do it = 1,num_remaining + j = remaining(it) + r = minValue+cost(i+((j-1)*nr))-u(i)-v(j) + if (r < shortestPathCosts(j)) then + path(j) = i + shortestPathCosts(j) = r + end if + + !> Choose the smallest cost or a new sink node + if (shortestPathCosts(j) < lowest.or. & + (shortestPathCosts(j) == lowest.and.row4col(j) == -1)) then + lowest = shortestPathCosts(j) + indx = it + end if + end do + + minValue = lowest + if (minValue == inf) then !> Infeasible cost matrix + sink = -1 + return + end if + + j = remaining(indx) + if (row4col(j) == -1) then + sink = j + else + i = row4col(j) + end if + + SC(j) = .true. + + remaining(indx) = remaining(num_remaining) + num_remaining = num_remaining-1 + end do + end function augmenting_path + + subroutine swap(x,y) + implicit none + integer,intent(inout) :: x,y + integer :: temp + temp = x + x = y + y = temp + end subroutine swap + + subroutine lsap_cached(lcache,nr,nc,maximize,iostatus) + implicit none + type(assignment_cache),intent(inout) :: lcache + integer,intent(in) :: nr,nc + logical,intent(in) :: maximize + integer :: iostatus + integer :: curRow,curRow_iter,currowtmp,i,j,jj,sink + real(sp) :: minValue + logical :: transposed + integer :: tmpx + !> error codes + integer,parameter :: RECTANGULAR_LSAP_TRANSPOSED = 1 + integer,parameter :: RECTANGULAR_LSAP_INFEASIBLE = 2 + + !> use associates to offload allocation outside the routine + associate (cost => lcache%Cost, & + & a => lcache%a,b => lcache%b, & + & u => lcache%u,v => lcache%v, & + & shortestPathCosts => lcache%shortestPathCosts, & + & path => lcache%path,col4row => lcache%col4row,row4col => lcache%row4col, & + & remaining => lcache%remaining,SR => lcache%SR,SC => lcache%SC) + + !> Handle trivial inputs + if (nr == 1.or.nc == 1) then + a(1) = 1 + b(1) = 1 + iostatus = 0 + return + end if + + !> Determine if we need to transpose the matrix + !> Let the user handle that outside the call + if (nc < nr) then + iostatus = RECTANGULAR_LSAP_TRANSPOSED + return + end if + + !> Negate the cost matrix for maximization + if (maximize) then + cost = -cost + end if + + !> Initialize + u(:) = 0.0_sp + v(:) = 0.0_sp + col4row(:) = -1 + row4col(:) = -1 + path(:) = -1 + + !> Iteratively build the solution + do curRow = 1,nr + curRowtmp = curRow + !> Call augmenting_path routine + sink = augmenting_path(nr,nc,cost,u,v,path,row4col, & + & shortestPathCosts,curRowtmp, & + & SR,SC,remaining,minValue) + if (sink < 0) then + iostatus = RECTANGULAR_LSAP_INFEASIBLE + return + end if + + !> Update dual variables + u(curRow) = u(curRow)+minValue + do i = 1,nr + if (SR(i).and.i /= curRow) then + u(i) = u(i)+minValue-shortestPathCosts(col4row(i)) + end if + end do + + do j = 1,nc + if (SC(j)) then + v(j) = v(j)-minValue+shortestPathCosts(j) + end if + end do + + !> Augment previous solution + j = sink + do jj=1,nc+1 !> avoid infinite loop + i = path(j) + row4col(j) = i + call swap(col4row(i),j) + if (i == curRow) exit + end do + end do + + !> Finalize the assignment + do i = 1,nr + a(i) = i + b(i) = col4row(i) + end do + + iostatus = 0 + end associate + end subroutine lsap_cached + +!========================================================================================! + + subroutine lsap_wrap_int(C,J,W,a,b) + !********************************************* + !* Wrapper for integer precision + !********************************************* + implicit none + integer,intent(in) :: J + integer,intent(in) :: W + integer,intent(in) :: C(J,W) + integer,intent(out),allocatable :: a(:) + integer,intent(out),allocatable :: b(:) + type(assignment_cache) :: cache + integer :: io + + call cache%allocate(J,W,.true.) + cache%Cost(1:J*W) = reshape(real(C(1:J,1:W),sp), [J*W]) + call lsap_cached(cache,J,W,.false.,io) + + allocate(a(J), b(J)) + a(1:J) = cache%a(1:J) + b(1:J) = cache%b(1:J) + call cache%deallocate() + end subroutine lsap_wrap_int + + + subroutine lsap_wrap_sp(C,J,W,a,b) + !********************************************* + !* Wrapper for single precision + !********************************************* + implicit none + integer,intent(in) :: J + integer,intent(in) :: W + real(sp),intent(in) :: C(J,W) + integer,intent(out),allocatable :: a(:) + integer,intent(out),allocatable :: b(:) + type(assignment_cache) :: cache + integer :: io + + call cache%allocate(J,W,.true.) + cache%Cost(1:J*W) = reshape(C(1:J,1:W), [J*W]) + call lsap_cached(cache,J,W,.false.,io) + + allocate(a(J), b(J)) + a(1:J) = cache%a(1:J) + b(1:J) = cache%b(1:J) + call cache%deallocate() + end subroutine lsap_wrap_sp + + + subroutine lsap_wrap_wp(C,J,W,a,b) + !********************************************* + !* Wrapper for double precision + !********************************************* + implicit none + integer,intent(in) :: J + integer,intent(in) :: W + real(wp),intent(in) :: C(J,W) + integer,intent(out),allocatable :: a(:) + integer,intent(out),allocatable :: b(:) + type(assignment_cache) :: cache + integer :: io + + call cache%allocate(J,W,.true.) + cache%Cost(1:J*W) = reshape(real(C(1:J,1:W),sp), [J*W]) + call lsap_cached(cache,J,W,.false.,io) + + allocate(a(J), b(J)) + a(1:J) = cache%a(1:J) + b(1:J) = cache%b(1:J) + call cache%deallocate() + end subroutine lsap_wrap_wp + +!========================================================================================! +!========================================================================================! +end module hungarian_module diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 new file mode 100644 index 00000000..41d05bf5 --- /dev/null +++ b/src/sorting/irmsd_module.f90 @@ -0,0 +1,987 @@ + +module irmsd_module +!***************************************** +!* Module that implements a more +!* modern interface to calculating RMSDs +!***************************************** + use crest_parameters + use strucrd + use hungarian_module + use axis_module + implicit none + private + + public :: rmsd + public :: min_rmsd + + public :: checkranks,fallbackranks + + real(wp),parameter :: bigval = huge(bigval) + + type :: rmsd_core_cache +!************************************* +!* Memory cache for rmsd_core routine +!************************************* + real(wp),allocatable :: x(:,:) + real(wp),allocatable :: y(:,:) + real(wp),allocatable :: xi(:) + real(wp),allocatable :: yi(:) + contains + procedure :: allocate => allocate_rmsd_core_cache + end type rmsd_core_cache + + public :: rmsd_cache + type :: rmsd_cache +!**************************************************** +!* cache implementation to avoid repeated allocation +!* and enable shared-memory parallelism +!**************************************************** + real(wp),allocatable :: xyzscratch(:,:,:) + integer,allocatable :: rank(:,:) + integer,allocatable :: best_order(:,:) + integer,allocatable :: current_order(:) + integer,allocatable :: target_order(:) + integer,allocatable :: order_bkup(:,:) + integer,allocatable :: iwork(:) + integer,allocatable :: iwork2(:,:) + logical,allocatable :: assigned(:) !> atom-wise + logical,allocatable :: rassigned(:) !> rank-wise + + integer :: nranks = 0 + integer,allocatable :: ngroup(:) + logical :: stereocheck = .false. + + type(rmsd_core_cache),allocatable :: ccache + type(assignment_cache),allocatable :: acache + contains + procedure :: allocate => allocate_rmsd_cache + end type rmsd_cache + + real(wp),parameter :: inf = huge(1.0_wp) + real(wp),parameter :: imat(3,3) = reshape([1.0_wp,0.0_wp,0.0_wp, & + & 0.0_wp,1.0_wp,0.0_wp, & + & 0.0_wp,0.0_wp,1.0_wp], & + & [3,3]) + + real(wp),parameter :: Rx180(3,3) = reshape([1.0_wp,0.0_wp,0.0_wp, & + & 0.0_wp,-1.0_wp,0.0_wp, & + & 0.0_wp,0.0_wp,-1.0_wp], & + & [3,3]) + + real(wp),parameter :: Ry180(3,3) = reshape([-1.0_wp,0.0_wp,0.0_wp, & + & 0.0_wp,1.0_wp,0.0_wp, & + & 0.0_wp,0.0_wp,-1.0_wp], & + & [3,3]) + + real(wp),parameter :: Rz180(3,3) = reshape([-1.0_wp,0.0_wp,0.0_wp, & + & 0.0_wp,-1.0_wp,0.0_wp, & + & 0.0_wp,0.0_wp,1.0_wp], & + & [3,3]) + + real(wp), parameter :: Rx90(3,3) = reshape([ & + & 1.0_wp, 0.0_wp, 0.0_wp, & + & 0.0_wp, 0.0_wp, 1.0_wp, & + & 0.0_wp, -1.0_wp, 0.0_wp & + & ], [3,3]) + real(wp),parameter :: Rx90T(3,3) = transpose(Rx90) + + real(wp), parameter :: Ry90(3,3) = reshape([ & + & 0.0_wp, 0.0_wp, -1.0_wp, & + & 0.0_wp, 1.0_wp, 0.0_wp, & + & 1.0_wp, 0.0_wp, 0.0_wp & + & ], [3,3]) + real(wp),parameter :: Ry90T(3,3) = transpose(Ry90) + + real(wp), parameter :: Rz90(3,3) = reshape([ & + & 0.0_wp, 1.0_wp, 0.0_wp, & + & -1.0_wp, 0.0_wp, 0.0_wp, & + & 0.0_wp, 0.0_wp, 1.0_wp & + & ], [3,3]) + real(wp),parameter :: Rz90T(3,3) = transpose(Rz90) + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + subroutine allocate_rmsd_core_cache(self,nat) + implicit none + class(rmsd_core_cache),intent(inout) :: self + integer,intent(in) :: nat + if (allocated(self%x)) deallocate (self%x) + if (allocated(self%y)) deallocate (self%y) + if (allocated(self%xi)) deallocate (self%xi) + if (allocated(self%yi)) deallocate (self%yi) + allocate (self%xi(nat),source=0.0_wp) + allocate (self%yi(nat),source=0.0_wp) + allocate (self%x(3,nat),source=0.0_wp) + allocate (self%y(3,nat),source=0.0_wp) + end subroutine allocate_rmsd_core_cache + + subroutine allocate_rmsd_cache(self,nat) + implicit none + class(rmsd_cache),intent(inout) :: self + integer,intent(in) :: nat + if (allocated(self%xyzscratch)) deallocate (self%xyzscratch) + if (allocated(self%rank)) deallocate (self%rank) + if (allocated(self%best_order)) deallocate (self%best_order) + if (allocated(self%current_order)) deallocate (self%current_order) + if (allocated(self%target_order)) deallocate (self%target_order) + if (allocated(self%order_bkup)) deallocate (self%order_bkup) + if (allocated(self%iwork)) deallocate (self%iwork) + if (allocated(self%iwork2)) deallocate (self%iwork2) + if (allocated(self%assigned)) deallocate (self%assigned) + if (allocated(self%rassigned)) deallocate (self%rassigned) + if (allocated(self%ngroup)) deallocate (self%ngroup) + if (allocated(self%ccache)) deallocate (self%ccache) + if (allocated(self%acache)) deallocate (self%acache) + allocate (self%assigned(nat),source=.false.) + allocate (self%rassigned(nat),source=.false.) + allocate (self%best_order(nat,3),source=0) + allocate (self%current_order(nat),source=0) + allocate (self%target_order(nat),source=0) + allocate (self%order_bkup(nat,32),source=0) + allocate (self%iwork(nat),source=0) + allocate (self%iwork2(nat,2),source=0) + allocate (self%rank(nat,2),source=0) + self%nranks = 0 + allocate (self%ngroup(nat),source=0) + allocate (self%xyzscratch(3,nat,2),source=0.0_wp) + allocate (self%ccache) + allocate (self%acache) + call self%ccache%allocate(nat) + call self%acache%allocate(nat,nat,.true.) !> assume we are only using the LSAP implementation + end subroutine allocate_rmsd_cache + +!========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< OPTIONAL arguments + logical,intent(in),optional :: mask(ref%nat) + real(wp),intent(inout),target,optional :: scratch(3,ref%nat,2) + real(wp),intent(out),optional :: rotmat(3,3) + real(wp),intent(out),target,optional :: gradient(3,ref%nat) + type(rmsd_core_cache),intent(inout),optional,target :: ccache + !> variables + type(rmsd_core_cache),allocatable,target :: ccachetmp + type(rmsd_core_cache),pointer :: ccptr + real(wp) :: x_center(3),y_center(3),Udum(3,3) + real(wp),target :: gdum(3,3) + integer :: nat,getrotmat + logical :: calc_u + real(wp),allocatable,target :: tmpscratch(:,:,:) + logical :: getgrad + real(wp),pointer :: grdptr(:,:) + real(wp),pointer :: scratchptr(:,:,:) + integer :: ic,k + + !> initialize to large value + rmsdval = bigval + !> check structure consistency + if (mol%nat .ne. ref%nat) return + + !> get rotation matrix? + getrotmat = 0 + calc_u = .false. + if (present(rotmat)) then + getrotmat = 1 + calc_u = .true. + end if + + !> get gradient? + if (present(gradient)) then + getgrad = .true. + gradient(:,:) = 0.0_wp + grdptr => gradient + else + getgrad = .false. + grdptr => gdum + end if + + !> use present cache? + if (present(ccache)) then + ccptr => ccache + else + allocate (ccachetmp) + call ccachetmp%allocate(ref%nat) + ccptr => ccachetmp + end if + +!>--- substructure? + if (present(mask)) then + nat = count(mask(:)) + !> scratch workspace to use? + if (present(scratch)) then + scratchptr => scratch + else + allocate (tmpscratch(3,nat,2)) + scratchptr => tmpscratch + end if + + !> do the mapping + k = 0 + do ic = 1,ref%nat + if (mask(ic)) then + k = k+1 + scratchptr(1:3,k,1) = mol%xyz(1:3,ic) + scratchptr(1:3,k,2) = ref%xyz(1:3,ic) + end if + end do + + !> calculate + call rmsd_core(nat,scratchptr(1:3,1:nat,1),scratchptr(1:3,1:nat,2), & + & calc_u,Udum,rmsdval,getgrad,grdptr,ccptr) + + !> go backwards through gradient (if necessary) to restore atom order + if (getgrad) then + k = nat + do ic = nat,1,-1 + if (mask(ic)) then + grdptr(1:3,ic) = grdptr(1:3,k) + grdptr(1:3,k) = 0.0_wp + k = k-1 + end if + end do + end if + + nullify (scratchptr) + if (allocated(tmpscratch)) deallocate (tmpscratch) + + else +!>--- standard calculation (Quarternion algorithm) + call rmsd_core(ref%nat,mol%xyz,ref%xyz, & + & calc_u,Udum,rmsdval,getgrad,grdptr,ccptr) + end if + + !> pass on rotation matrix if asked for + if (calc_u) rotmat = Udum + + end function rmsd + +!========================================================================================! + + subroutine rmsd_core(nat,xyz1,xyz2,calc_u,U,error,calc_g,grad,ccache) +!********************************************************** +!* Rewrite or RMSD code with modified memory management +!* Adapted from ls_rmsd, and using some of its subroutines +!* The goal is to offload memory allocation to outside +!* the routine in case it is repeadetly called +!********************************************************** + use ls_rmsd,only:dstmev,rotation_matrix + implicit none + integer,intent(in) :: nat + real(wp),intent(in) :: xyz1(3,nat) + real(wp),intent(in) :: xyz2(3,nat) + logical,intent(in) :: calc_u + real(wp),dimension(3,3),intent(out) :: U + real(wp),intent(out) :: error + logical,intent(in) :: calc_g + real(wp),intent(inout) :: grad(:,:) + type(rmsd_core_cache),intent(inout) :: ccache + + !> LOCAL + integer :: i,j + real(wp) :: x_center(3) + real(wp) :: y_center(3) + real(wp) :: x_norm,y_norm,lambda + real(wp) :: Rmatrix(3,3) + real(wp) :: S(4,4) + real(wp) :: q(4) + real(wp) :: tmp(3),rnat + integer :: io + + !> associate + associate (x => ccache%x,y => ccache%y,xi => ccache%xi,yi => ccache%yi) + + !> make copies of the original coordinates + x(:,:) = xyz1(:,:) + y(:,:) = xyz2(:,:) + + !> calculate the barycenters, centroidal coordinates, and the norms + x_norm = 0.0_wp + y_norm = 0.0_wp + rnat = 1.0_wp/real(nat,wp) + do i = 1,3 + xi(:) = x(i,:) + yi(:) = y(i,:) + x_center(i) = sum(xi(1:nat))*rnat + y_center(i) = sum(yi(1:nat))*rnat + xi(:) = xi(:)-x_center(i) + yi(:) = yi(:)-y_center(i) + x(i,:) = xi(:) + y(i,:) = yi(:) + x_norm = x_norm+dot_product(xi,xi) + y_norm = y_norm+dot_product(yi,yi) + end do + + !> calculate the R matrix + do i = 1,3 + do j = 1,3 + Rmatrix(i,j) = dot_product(x(i,:),y(j,:)) + end do + end do + + !> S matrix + S(1,1) = Rmatrix(1,1)+Rmatrix(2,2)+Rmatrix(3,3) + S(2,1) = Rmatrix(2,3)-Rmatrix(3,2) + S(3,1) = Rmatrix(3,1)-Rmatrix(1,3) + S(4,1) = Rmatrix(1,2)-Rmatrix(2,1) + + S(1,2) = S(2,1) + S(2,2) = Rmatrix(1,1)-Rmatrix(2,2)-Rmatrix(3,3) + S(3,2) = Rmatrix(1,2)+Rmatrix(2,1) + S(4,2) = Rmatrix(1,3)+Rmatrix(3,1) + + S(1,3) = S(3,1) + S(2,3) = S(3,2) + S(3,3) = -Rmatrix(1,1)+Rmatrix(2,2)-Rmatrix(3,3) + S(4,3) = Rmatrix(2,3)+Rmatrix(3,2) + + S(1,4) = S(4,1) + S(2,4) = S(4,2) + S(3,4) = S(4,3) + S(4,4) = -Rmatrix(1,1)-Rmatrix(2,2)+Rmatrix(3,3) + + !> Calculate eigenvalues and eigenvectors, and + !> take the maximum eigenvalue lambda and the corresponding eigenvector q. + call dstmev(S,lambda,q,io) + if (io /= 0) then + error = -1.0_wp + return + end if + + if (calc_u) then + !> reset + U(:,:) = Imat(:,:) + !> convert quaternion q to rotation matrix U + call rotation_matrix(q,U) + end if + + !> RMS Deviation + error = sqrt(max(0.0_wp, ((x_norm+y_norm)-2.0_wp*lambda))*rnat) + + if (calc_g) then + !> Gradient of the error of xyz1 w.r.t xyz2 + do i = 1,nat + do j = 1,3 + tmp(:) = matmul(transpose(U(:,:)),y(:,i)) + grad(j,i) = ((x(j,i)-tmp(j))/error)*rnat + end do + end do + end if + + end associate + end subroutine rmsd_core + +!========================================================================================! + + subroutine min_rmsd(ref,mol,rcache,rmsdout,align) +!********************************************************************* +!* Main routine to determine minium RMSD considering atom permutation +!* Input +!* ref - the reference structure +!* mol - the structure to be matched to ref +!* Optinal arguments +!* rcache - memory cache +!* rmsdout - the calculated RMSD scalar +!* align - quarternion-align mol in the last stage +!********************************************************************* + implicit none + !> IN & OUTPUT + type(coord),intent(in) :: ref + type(coord),intent(inout) :: mol + type(rmsd_cache),intent(inout),optional,target :: rcache + real(wp),intent(out),optional :: rmsdout + logical,intent(in),optional :: align + + !> LOCAL + type(rmsd_cache),pointer :: cptr + type(rmsd_cache),allocatable,target :: local_rcache + integer :: nat,ii,rnk,dumpunit,uniquenesscase + real(wp) :: calc_rmsd + real(wp) :: tmprmsd_sym(32),dum + real(wp) :: rotmat(3,3),rotconst(3) + logical,parameter :: debug = .false. + +!>--- Initialization + if (present(rcache)) then + cptr => rcache + else + allocate (local_rcache) + if (ref%nat .ne. mol%nat) then + error stop 'Unequal molecule size in min_rmsd()' + end if + nat = max(ref%nat,mol%nat) + call local_rcache%allocate(nat) + call fallbackranks(ref,mol,nat,local_rcache%rank) + cptr => local_rcache + end if + +!>-- Consistency check + cptr%nranks = maxval(cptr%rank(:,1)) + if (cptr%nranks .ne. maxval(cptr%rank(:,2))) then + error stop "Different atom identities in min_rmsd, can't restore an atom order!" + end if + +!>--- First sorting, to at least restore rank order (only if that's not the case!) + if (.not.all(cptr%rank(:,1) .eq. cptr%rank(:,2))) then + call rank_2_order(ref%nat,cptr%rank(:,1),cptr%target_order) + call rank_2_order(mol%nat,cptr%rank(:,2),cptr%current_order) + if (debug) then + write (*,*) 'current order & rank & target order' + do ii = 1,mol%nat + write (*,*) cptr%current_order(ii),cptr%rank(ii,2),cptr%target_order(ii) + end do + end if + call molatomsort(mol,mol%nat,cptr%current_order,cptr%target_order,cptr%iwork) + cptr%rank(:,2) = cptr%rank(:,1) !> since the ranks must be equal now! + if (debug) then + write (*,*) 'sorted order & rank' + do ii = 1,mol%nat + write (*,*) cptr%current_order(ii),cptr%rank(ii,2) + end do + end if + end if + +!>--- Count symmetry equivalent groups and assign all unique atoms immediately +! Note, the rank can be zero if we only are looking at heavy atoms + if (all(cptr%ngroup(:) .eq. 0)) then + do ii = 1,ref%nat + rnk = cptr%rank(ii,1) + if (rnk > 0) then + cptr%ngroup(rnk) = cptr%ngroup(rnk)+1 + end if + end do + end if + !> assignment reset + cptr%assigned(:) = .false. + cptr%rassigned(:) = .false. + cptr%rassigned(cptr%nranks+1:) = .true. !> skip unneeded allocation space + do ii = 1,ref%nat + cptr%iwork(ii) = ii !> also init iwork + cptr%target_order(ii) = ii !> also init target_order + rnk = cptr%rank(ii,2) + if (rnk < 1) then + cptr%assigned(ii) = .true. + cycle + end if + if (cptr%ngroup(rnk) .eq. 1) then + cptr%assigned(ii) = .true. + cptr%rassigned(rnk) = .true. + end if + end do + if (debug) then + write (*,*) 'rank & # members' + do ii = 1,mol%nat + if (cptr%ngroup(ii) > 0) then + write (*,*) ii,cptr%ngroup(ii) + end if + end do + end if + +!>--- Perform the desired symmetry operations, align with rotational axis, run LSAP algo +!> Since the rotational axis alignment can be a bit arbitrary w.r.t 180° rotations +!> we need to check these as well. + if (debug) then + open (newunit=dumpunit,file='debugirmsd.xyz') + call ref%append(dumpunit) + end if + !> initialize to huge + tmprmsd_sym(:) = inf + !> initial alignment of mol + call axis(mol%nat,mol%at,mol%xyz,rotconst) + call min_rmsd_rotcheck_unique(mol,rotconst,uniquenesscase) + + !> Running the checks and check of uniqueness of rotational axes + call min_rmsd_rotcheck_permute(ref,mol,cptr,tmprmsd_sym,1,uniquenesscase) + if (debug) then + write (*,*) 'Total LSAP cost:',minval(tmprmsd_sym(1:16)) + call mol%append(dumpunit) + end if + + !> mirror z and re-run the same checks (i.e. the false rotamer inversion) + if (cptr%stereocheck) then + mol%xyz(3,:) = -mol%xyz(3,:) !> mirror z + call axis(mol%nat,mol%at,mol%xyz) !> align + + !> Running the checks + call min_rmsd_rotcheck_permute(ref,mol,cptr,tmprmsd_sym,2,uniquenesscase) + if (debug) then + write (*,*) 'Total LSAP cost (inverted):',minval(tmprmsd_sym(17:32)) + call mol%append(dumpunit) + end if + mol%xyz(3,:) = -mol%xyz(3,:) !> restore z + end if + +!>--- select the best match among the ones after symmetry operations and use its ordering + ii = minloc(tmprmsd_sym(1:32),1) + if (debug) then + write (*,*) 'final alignment:',ii,"/ 32" + end if + if (ii > 16) then + mol%xyz(3,:) = -mol%xyz(3,:) + if (debug) write (*,*) 'inverting' + end if + if ((ii > 4 .and. ii < 9) .or. (ii > 20 .and. ii < 25))then + if(uniquenesscase == 1) mol%xyz = matmul(Rx90,mol%xyz) + if(uniquenesscase == 2) mol%xyz = matmul(Rz90,mol%xyz) + if(uniquenesscase == 3) mol%xyz = matmul(Rz90,mol%xyz) + if(debug) write (*,*) '90° tilt' + else if ((ii > 8 .and. ii < 13) .or. (ii > 24 .and. ii < 29))then + mol%xyz = matmul(Ry90,mol%xyz) + else if ((ii > 12 .and. ii < 17) .or. (ii > 28))then + mol%xyz = matmul(Rx90,mol%xyz) + endif + select case (ii) !> 180° rotations + case (1,5,9,13,17,21,25,29) + continue + case (2,6,10,14,18,22,26,30) + mol%xyz = matmul(Rx180,mol%xyz) + if (debug) write (*,*) '180°x' + case (3,7,11,15,19,23,27,31) + mol%xyz = matmul(Rx180,mol%xyz) + mol%xyz = matmul(Ry180,mol%xyz) + if (debug) write (*,*) '180°x, 180°y' + case (4,8,12,16,20,24,28,32) + mol%xyz = matmul(Ry180,mol%xyz) + if (debug) write (*,*) '180°y' + end select + cptr%current_order(:) = cptr%order_bkup(:,ii) + + if (debug) then + write (*,*) 'Determined remapping' + do ii = 1,mol%nat + write (*,*) cptr%current_order(ii),'-->',cptr%target_order(ii) + end do + end if + + call molatomsort(mol,mol%nat,cptr%current_order,cptr%target_order,cptr%iwork) + if (debug) then + call mol%append(dumpunit) + close (dumpunit) + end if + +!>--- final RMSD with fully restored atom order + if (present(align)) then + calc_rmsd = rmsd(ref,mol,scratch=cptr%xyzscratch,ccache=cptr%ccache,rotmat=rotmat) + if (align) then + mol%xyz = matmul(rotmat,mol%xyz) + end if + else + calc_rmsd = rmsd(ref,mol,scratch=cptr%xyzscratch,ccache=cptr%ccache) + end if + + if (present(rmsdout)) rmsdout = calc_rmsd + end subroutine min_rmsd + +!========================================================================================! + + subroutine min_rmsd_iterate_through_groups(ref,mol,rcache,val) + implicit none + type(coord),intent(in) :: ref + type(coord),intent(inout) :: mol + type(rmsd_cache),intent(inout),target :: rcache + real(wp),intent(out) :: val + integer :: rr,ii,jj + real(wp) :: val0 + type(assignment_cache),pointer :: aptr + logical,parameter :: debug = .false. + + !> reset val + val = 0.0_wp + + if (debug) then + write (*,*) '# ranks:',rcache%nranks + end if + aptr => rcache%acache + do rr = 1,rcache%nranks + if (rcache%rassigned(rr)) cycle + + !> LSAP wrapper that computes the relevant Cost matrix for the atoms of rank rr + call compute_linear_sum_assignment( & + & ref,mol,rcache%rank,rcache%ngroup,rr, & + & rcache%iwork2,aptr,val0) + + do ii = 1,rcache%ngroup(rr) + rcache%iwork(rcache%iwork2(ii,1)) = rcache%iwork2(ii,2) + end do + + !> add up the total LSAP cost (of considered ranks) + !> we need this if we have to decide on a mapping in case of false enantiomers + val = val+val0 + end do + + end subroutine min_rmsd_iterate_through_groups + +!========================================================================================! + + subroutine min_rmsd_rotcheck_unique(mol,rot,uniquenesscase,thr) +!******************************************************* +!* Based on the rotational constants, determine what we +!* need to do with the molecule in the following +!******************************************************* + implicit none + type(coord),intent(inout) :: mol + real(wp),intent(in) :: rot(3) + integer,intent(out) :: uniquenesscase + real(wp),intent(in),optional :: thr + logical :: unique(3) + integer :: nunique + + uniquenesscase = 0 + call uniqueax(rot,unique,thr) + + nunique = count(unique,1) + select case(nunique) + case ( 3 ) !> 3 unique principal axes + uniquenesscase = 0 + case ( 1 ) !> one unique principal axis + if(unique(1)) uniquenesscase = 1 !> A unique (long axis) + if(unique(3)) uniquenesscase = 2 !> C unique (short axis) + case ( 0 ) !> rotationally ambiguous system + uniquenesscase = 3 + end select + end subroutine min_rmsd_rotcheck_unique + +!=======================================================================================! + + subroutine min_rmsd_rotcheck_permute(ref,mol,cptr,values,step,uniquenesscase) + implicit none + type(coord),intent(in) :: ref + type(coord),intent(inout) :: mol + type(rmsd_cache),intent(inout),target :: cptr + real(wp),intent(inout) :: values(:) + integer,intent(in) :: step,uniquenesscase + integer :: rr,ii,jj,debugunit2 + real(wp) :: vals(16),dum + logical,parameter :: debug = .false. + + !> reset val + vals(:) = inf + + if (debug) then + open (newunit=debugunit2,file='rotdebug.xyz') + call ref%append(debugunit2) + end if + + ALIGNLOOP : do ii=1,4 + call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) + vals(1+4*(ii-1)) = dum + if (debug) call mol%append(debugunit2) + cptr%order_bkup(:,1+4*(ii-1)+16*(step-1)) = cptr%iwork(:) + + mol%xyz = matmul(Rx180,mol%xyz) + call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) + vals(2+4*(ii-1)) = dum + if (debug) call mol%append(debugunit2) + cptr%order_bkup(:,2+4*(ii-1)+16*(step-1)) = cptr%iwork(:) + + mol%xyz = matmul(Ry180,mol%xyz) + call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) + vals(3+4*(ii-1)) = dum + if (debug) call mol%append(debugunit2) + cptr%order_bkup(:,3+4*(ii-1)+16*(step-1)) = cptr%iwork(:) + + mol%xyz = matmul(Rx180,mol%xyz) + call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) + vals(4+4*(ii-1)) = dum + if (debug) call mol%append(debugunit2) + cptr%order_bkup(:,4+4*(ii-1)+16*(step-1)) = cptr%iwork(:) + + mol%xyz = matmul(Ry180,mol%xyz) !> restore + + !exit ALIGNLOOP + select case(uniquenesscase) + case( 0 ) !> 3 Unique moments of inertia + exit ALIGNLOOP + case( 1 ) !> only one unique moment of inertia (A) + if( ii == 2 )then + mol%xyz = matmul(Rx90T,mol%xyz) + exit ALIGNLOOP + endif + mol%xyz = matmul(Rx90,mol%xyz) + case (2) !> only one unique moment of inertia (C) + if( ii == 2 )then + mol%xyz = matmul(Rz90T,mol%xyz) + exit ALIGNLOOP + endif + mol%xyz = matmul(Rz90,mol%xyz) + case (3) + if( ii == 1)then + mol%xyz = matmul(Rz90,mol%xyz) + else if(ii == 2)then + mol%xyz = matmul(Rz90T,mol%xyz) + mol%xyz = matmul(Ry90,mol%xyz) + else if(ii == 3)then + mol%xyz = matmul(Ry90T,mol%xyz) + mol%xyz = matmul(Rx90,mol%xyz) + else + mol%xyz = matmul(Rx90T,mol%xyz) + exit ALIGNLOOP + endif + end select + + + enddo ALIGNLOOP + + + if (debug) then + close (debugunit2) + write (*,*) 'vals:',vals(:) + end if + + do ii = 1,16 + values(ii+16*(step-1)) = vals(ii) + end do + end subroutine min_rmsd_rotcheck_permute + +!========================================================================================! + + subroutine fallbackranks(ref,mol,nat,ranks) +!***************************************************************** +!* If we are doing ranks on-the-fly (i.e. without canonical algo) +!* we can fall back to just using the atom types +!***************************************************************** + implicit none + type(coord),intent(in) :: ref,mol + integer,intent(in) :: nat + integer,intent(inout) :: ranks(nat,2) + + integer,allocatable :: typemap(:),rtypemap(:) + integer :: k,ii + allocate (typemap(nat),source=0) + k = 0 + do ii = 1,ref%nat + if (.not.any(typemap(:) .eq. ref%at(ii))) then + k = k+1 + typemap(k) = ref%at(ii) + end if + end do + do ii = 1,mol%nat + if (.not.any(typemap(:) .eq. mol%at(ii))) then + k = k+1 + typemap(k) = mol%at(ii) + end if + end do + k = maxval(typemap(:)) + allocate (rtypemap(k),source=0) + do ii = 1,nat + if (typemap(ii) == 0) cycle + rtypemap(typemap(ii)) = ii + end do + !> assign + do ii = 1,ref%nat + ranks(ii,1) = rtypemap(ref%at(ii)) + end do + do ii = 1,mol%nat + ranks(ii,2) = rtypemap(mol%at(ii)) + end do + deallocate (rtypemap) + deallocate (typemap) + end subroutine fallbackranks + +!========================================================================================! + + subroutine compute_linear_sum_assignment(ref,mol,ranks, & + & ngroups,targetrank,iwork2,acache,val0) +!************************************************************** +!* Run the linear assignment algorithm on the desired subset +!* of atoms (via rank and targetrank) +!************************************************************** + implicit none + !> IN & OUTPUT + type(coord),intent(in) :: ref + type(coord),intent(inout) :: mol + integer,intent(in) :: ranks(:,:) + integer,intent(in) :: ngroups(:) + integer,intent(in) :: targetrank + integer,intent(inout) :: iwork2(:,:) + type(assignment_cache),intent(inout),optional,target :: acache + real(wp),intent(out) :: val0 + + !> LOCAL + type(assignment_cache),pointer :: aptr + type(assignment_cache),allocatable,target :: local_acache + integer :: nat,i,j,ii,jj,rnknat,iostatus + real(sp) :: dists(3) + + logical,parameter :: debug = .false. + + val0 = 0.0_wp + + if (present(acache)) then + aptr => acache + else + allocate (local_acache) + if (ref%nat .ne. mol%nat) then + error stop 'Unequal molecule size in compute_linear_sum_assignment()' + end if + nat = max(ref%nat,mol%nat) + call local_acache%allocate(nat,nat,.true.) + aptr => local_acache + end if + + !> Compute the cost matrix, which is simply the distance matrix + !> between the two molecules. + !> To avoid computational overhead we can skip the square root. + !> It won't affect the result + !> Also, since aptr%Cost is a flattened matrix, we only fill + !> the first rnknat**2 entries + rnknat = ngroups(targetrank) + ii = 0 + do i = 1,ref%nat + if (ranks(i,1) .ne. targetrank) cycle + ii = ii+1 + iwork2(ii,1) = i !> mapping using the first column of iwork2 + jj = 0 + do j = 1,mol%nat + if (ranks(j,2) .ne. targetrank) cycle + jj = jj+1 + dists(:) = (ref%xyz(:,i)-mol%xyz(:,j))**2 !> use i and j + aptr%Cost(jj+(ii-1)*rnknat) = sum(dists) + end do + end do + + if (debug) then + write (*,*) 'target rank',targetrank,'# atoms',rnknat + end if + + call lsap(aptr,rnknat,rnknat,.false.,iostatus) + + !> paasing back the determined order as second column of iwork2 + if (iostatus == 0) then + if (debug) then + do i = 1,rnknat + write (*,*) iwork2(aptr%a(i),1),'-->',iwork2(aptr%b(i),1) + end do + end if + do i = 1,rnknat + jj = aptr%a(i) + ii = aptr%b(i) + if(ii == -1 .or. jj == -1) cycle !> cycle bad assignments + val0 = val0+aptr%Cost(jj+(ii-1)*rnknat) + iwork2(i,2) = iwork2(aptr%b(i),1) + end do + else + !> in the unlikely case we have a failure of the LSAP + !> we do just a 1:1 mapping, just so that the algo doesn't crash + iwork2(1:rnknat,2) = iwork2(1:rnknat,1) + end if + + end subroutine compute_linear_sum_assignment + +!========================================================================================! + + subroutine rank_2_order(nat,rank,order) + implicit none + integer,intent(in) :: nat + integer,intent(in) :: rank(nat) + integer,intent(out) :: order(nat) + integer :: ii,jj,k,maxrank + order(:) = 0 + maxrank = maxval(rank(:)) + k = 0 + do ii = 1,maxrank + do jj = 1,nat + if (rank(jj) == ii) then + k = k+1 + order(jj) = k + end if + end do + end do + end subroutine rank_2_order + +!========================================================================================! + + function checkranks(nat,ranks1,ranks2) result(yesno) +!*********************************************************************** +!* Check two rank arrays to see if we have the same amount of +!* atoms in the same ranks (a condition to bein able to work with them) +!*********************************************************************** + implicit none + logical :: yesno + integer,intent(in) :: nat + integer,intent(in) :: ranks1(nat) + integer,intent(in) :: ranks2(nat) + integer :: ii,jj,maxrank1,maxrank2 + integer :: count1,count2 + yesno = .false. + + maxrank1 = maxval(ranks1) + maxrank2 = maxval(ranks2) + !> different maxranks, so we can't have the same and return + if (maxrank1 .ne. maxrank2) return + + do ii = 1,maxrank1 + count1 = 0 + count2 = 0 + do jj = 1,nat + if (ranks1(jj) .eq. ii) count1 = count1+1 + if (ranks2(jj) .eq. ii) count2 = count2+1 + end do + !> not the same amount of atoms in rank ii, return from function + if (count1 .ne. count2) return + end do + + !> if we reach this point we can assume the given ranks are o.k. + yesno = .true. + end function checkranks + +!========================================================================================! + + subroutine molatomsort(mol,n,current_order,target_order,index_map) + implicit none + type(coord),intent(inout) :: mol + integer,intent(in) :: n + integer,intent(inout) :: current_order(n) + integer,intent(in) :: target_order(n) + integer,intent(inout) :: index_map(n) + integer :: i,j,correct_atom,current_position + + !> Step 1: Create a mapping from target_order to current_order positions + do i = 1,n + index_map(current_order(i)) = i + end do + + !> Step 2: Restore the target order + do i = 1,n + correct_atom = target_order(i) + current_position = index_map(correct_atom) + + if (i /= current_position) then + !> Swap atoms i and current_position in molecule + call mol%swap(i,current_position) + + !> Update the index map since the atoms have been swapped + index_map(current_order(i)) = current_position + index_map(current_order(current_position)) = i + + !> Update the current_order array to reflect the swap + j = current_order(i) + current_order(i) = current_order(current_position) + current_order(current_position) = j + end if + end do + end subroutine molatomsort + +!========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<. + +srcs += files( + 'canonical.f90', + 'ccegen.f90', + 'cregen.f90', + 'ensemblecomp.f90', + 'hungarian.f90', + 'irmsd_module.f90', + 'ls_rmsd.f90', + 'quicksort.f90', + 'rotcompare.f90', + 'sortens.f90', + 'unionize.f90', + 'zdata.f90', + 'ztopology.f90', +) diff --git a/src/sorting/quicksort.f90 b/src/sorting/quicksort.f90 new file mode 100644 index 00000000..16b0742c --- /dev/null +++ b/src/sorting/quicksort.f90 @@ -0,0 +1,367 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2020-2024 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module quicksort_interface +!******************************************************** +!* module to load an interface to the quicksort routines +!* mandatory to handle optional input arguments +!******************************************************** + implicit none + interface + recursive subroutine quicksort(n,arr) + implicit none + integer :: n,arr(n) + end subroutine quicksort + + recursive subroutine qsort(a,first,last,ind) + use iso_fortran_env,only:wp => real64 + implicit none + real(wp) :: a(*) + integer :: ind(*) + integer :: first,last + end subroutine qsort + + recursive subroutine qqsort(a,first,last) + use iso_fortran_env,only:wp => real64 + implicit none + real(wp) :: a(*) + integer :: first,last + end subroutine qqsort + + recursive subroutine maskqsort(a,first,last,mask) + use iso_fortran_env,only:wp => real64 + implicit none + real(wp) :: a(*) + integer :: first,last + integer :: mask(*) + end subroutine maskqsort + + recursive subroutine matqsort(adim,nall,a,adum,first,last,mask) + use iso_fortran_env,only:wp => real64 + implicit none + integer :: adim,nall + real(wp) :: a(adim,nall),adum(adim) + integer :: first,last + integer :: mask(nall) + end subroutine matqsort + + recursive subroutine stringqsort(sdim,slen,strs,first,last,mask) + implicit none + integer,intent(in) :: sdim,slen + character(len=slen) :: strs(sdim) + integer :: first,last + integer :: mask(sdim) + end subroutine stringqsort + + subroutine maskinvert(nall,mask) + implicit none + integer :: nall + integer :: mask(nall) + end subroutine maskinvert + + recursive subroutine ensemble_qsort(nall,structures,first,last,mask) + use crest_parameters + use strucrd,only:coord + implicit none + integer,intent(in) :: nall + type(coord),intent(inout) :: structures(nall) + integer,intent(in) :: first,last + integer,intent(inout),optional :: mask(nall) + end subroutine ensemble_qsort + + end interface +end module quicksort_interface + +!=============================================================! +! classical quicksort algorithm, sort LOW-to-HIGH +!=============================================================! +recursive subroutine quicksort(n,arr) + implicit none + integer :: n,arr(n),i,j,k,m + integer :: pivot + integer,allocatable :: R(:),L(:) + integer :: rr,ll,rc,lc,pp + + if (n .le. 1) return + + pivot = arr(1) + if (arr(2) .lt. arr(1)) pivot = arr(2) + pp = 0 + do i = 1,n + if (arr(i) .eq. pivot) pp = pp+1 + end do + + ll = 0 + do i = 1,n + if (arr(i) .le. pivot) then + ll = ll+1 + end if + end do + ll = ll-pp + rr = n-ll-pp + allocate (L(ll),R(rr)) + + lc = 0 + rc = 0 + do j = 1,n + if (arr(j) .lt. pivot) then + lc = lc+1 + L(lc) = arr(j) + else if (arr(j) .gt. pivot) then + rc = rc+1 + R(rc) = arr(j) + end if + end do + + call quicksort(ll,L) + call quicksort(rr,R) + + do i = 1,ll + arr(i) = L(i) + end do + do k = 1,pp + m = k+ll + arr(m) = pivot + end do + do j = 1,rr + m = j+ll+pp + arr(m) = R(j) + end do + + deallocate (R,L) +end subroutine quicksort + +!=============================================================! +! other variant of quicksort algos +!=============================================================! +recursive subroutine qsort(a,first,last,ind) + use iso_fortran_env,only:wp => real64 + implicit none + real(wp) :: a(*) + real(wp) :: x,t + integer :: ind(*) + integer :: first,last,i,j,ii + + x = a((first+last)/2) + i = first + j = last + do + do while (a(i) < x) + i = i+1 + end do + do while (x < a(j)) + j = j-1 + end do + if (i >= j) exit + t = a(i); a(i) = a(j); a(j) = t + ii = ind(i); ind(i) = ind(j); ind(j) = ii + i = i+1 + j = j-1 + end do + if (first < i-1) call qsort(a,first,i-1,ind) + if (j+1 < last) call qsort(a,j+1,last,ind) +end subroutine qsort + +recursive subroutine qqsort(a,first,last) + use iso_fortran_env,only:wp => real64 + implicit none + real(wp) :: a(*) + real(wp) :: x,t + integer :: first,last,i,j + + x = a((first+last)/2) + i = first + j = last + do + do while (a(i) < x) + i = i+1 + end do + do while (x < a(j)) + j = j-1 + end do + if (i >= j) exit + t = a(i); a(i) = a(j); a(j) = t + i = i+1 + j = j-1 + end do + if (first < i-1) call qqsort(a,first,i-1) + if (j+1 < last) call qqsort(a,j+1,last) +end subroutine qqsort + +recursive subroutine maskqsort(a,first,last,mask) + use iso_fortran_env,only:wp => real64 + implicit none + real(wp) :: a(*) + real(wp) :: t + integer :: x,first,last,i,j,ii + integer :: mask(*) + + x = mask((first+last)/2) + i = first + j = last + do + do while (mask(i) < x) + i = i+1 + end do + do while (x < mask(j)) + j = j-1 + end do + if (i >= j) exit + t = a(i); a(i) = a(j); a(j) = t + ii = mask(i); mask(i) = mask(j); mask(j) = ii + i = i+1 + j = j-1 + end do + if (first < i-1) call maskqsort(a,first,i-1,mask) + if (j+1 < last) call maskqsort(a,j+1,last,mask) +end subroutine maskqsort + +recursive subroutine matqsort(adim,nall,a,adum,first,last,mask) + use iso_fortran_env,only:wp => real64 + implicit none + integer :: adim,nall + real(wp) :: a(adim,nall),adum(adim) + integer :: x,first,last,i,j,ii + integer :: mask(nall) + + x = mask((first+last)/2) + i = first + j = last + do + do while (mask(i) < x) + i = i+1 + end do + do while (x < mask(j)) + j = j-1 + end do + if (i >= j) exit + adum(:) = a(:,i); a(:,i) = a(:,j); a(:,j) = adum(:) + ii = mask(i); mask(i) = mask(j); mask(j) = ii + i = i+1 + j = j-1 + end do + if (first < i-1) call matqsort(adim,nall,a,adum,first,i-1,mask) + if (j+1 < last) call matqsort(adim,nall,a,adum,j+1,last,mask) +end subroutine matqsort + +recursive subroutine stringqsort(sdim,slen,strs,first,last,mask) + implicit none + integer,intent(in) :: sdim,slen + character(len=slen) :: strs(sdim) + character(len=slen) :: str + integer :: x,first,last,i,j,ii + integer :: mask(sdim) + x = mask((first+last)/2) + i = first + j = last + do + do while (mask(i) < x) + i = i+1 + end do + do while (x < mask(j)) + j = j-1 + end do + if (i >= j) exit + str = strs(i); strs(i) = strs(j); strs(j) = str + ii = mask(i); mask(i) = mask(j); mask(j) = ii + i = i+1 + j = j-1 + end do + if (first < i-1) call stringqsort(sdim,slen,strs,first,i-1,mask) + if (j+1 < last) call stringqsort(sdim,slen,strs,j+1,last,mask) +end subroutine stringqsort + +subroutine maskinvert(nall,mask) + implicit none + integer :: nall + integer :: mask(nall) + integer,allocatable :: imask(:) + integer :: i + allocate (imask(nall)) + do i = 1,nall + imask(mask(i)) = i + end do + mask(:) = imask(:) + deallocate (imask) + return +end subroutine maskinvert + +!========================================================================================! + +recursive subroutine ensemble_qsort(nall,structures,first,last,mask) + use crest_parameters + use strucrd,only:coord + implicit none + integer,intent(in) :: nall + type(coord),intent(inout) :: structures(nall) + integer,intent(in) :: first,last + integer,intent(inout),optional :: mask(nall) + + !> LOCAL + type(coord),allocatable :: tmpmol + integer :: i,j,mm,ii + real(wp) :: ee + + if (present(mask)) then +!>--- sort according to a given mask (reference order) + mm = mask((first+last)/2) + i = first + j = last + do + do while (mask(i) < mm) + i = i+1 + end do + do while (mm < mask(j)) + j = j-1 + end do + if (i >= j) exit + ii = mask(i); mask(i) = mask(j); mask(j) = ii + allocate (tmpmol) + tmpmol = structures(i); structures(i) = structures(j); structures(j) = tmpmol + deallocate (tmpmol) + i = i+1 + j = j-1 + end do + if (first < i-1) call ensemble_qsort(nall,structures,first,i-1,mask) + if (j+1 < last) call ensemble_qsort(nall,structures,j+1,last,mask) + + else +!>--- standard, sort according to energy of structures + ee = structures((first+last)/2)%energy + i = first + j = last + do + do while (structures(i)%energy < ee) + i = i+1 + end do + do while (ee < structures(j)%energy) + j = j-1 + end do + if (i >= j) exit + allocate (tmpmol) + tmpmol = structures(i); structures(i) = structures(j); structures(j) = tmpmol + deallocate (tmpmol) + i = i+1 + j = j-1 + end do + if (first < i-1) call ensemble_qsort(nall,structures,first,i-1) + if (j+1 < last) call ensemble_qsort(nall,structures,j+1,last) + end if +end subroutine ensemble_qsort + diff --git a/src/rotcompare.f90 b/src/sorting/rotcompare.f90 similarity index 100% rename from src/rotcompare.f90 rename to src/sorting/rotcompare.f90 diff --git a/src/sortens.f90 b/src/sorting/sortens.f90 similarity index 100% rename from src/sortens.f90 rename to src/sorting/sortens.f90 diff --git a/src/sorting/unionize.f90 b/src/sorting/unionize.f90 new file mode 100644 index 00000000..453fdada --- /dev/null +++ b/src/sorting/unionize.f90 @@ -0,0 +1,178 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2025 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module unionize_module + use crest_parameters + use strucrd,only:coord + use axis_module + use irmsd_module + use canonical_mod + use quicksort_interface,only:ensemble_qsort + implicit none + private + +! logical,parameter :: debug = .true. + logical,parameter :: debug = .false. + + public :: unionizeEnsembles + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + subroutine unionizeEnsembles(nin,inputs,nmerge,newmols,rthr,ethr) +!*************************************************************************** +!* Merge two ensembles into a new one +!* We asume "inputs" is our reference into which "newmols" shall be merged. +!* "inputs" must be an allocatable list of structures and is OVERWRITTEN +!* by the new list. +!* Setting rthr and ethr to zero (or omitting the arguments) +!* will lead to every structure being identified as unique and +!* append it to the output ensemble. +!*************************************************************************** + implicit none + integer,intent(inout) :: nin + type(coord),allocatable,intent(inout) :: inputs(:) + integer,intent(in) :: nmerge + type(coord),intent(in),target :: newmols(nmerge) + real(wp),intent(in),optional :: rthr,ethr + !> LOCAL + integer :: nout + type(coord),allocatable :: structures(:) + logical :: dupe,broken + integer :: i,j,k,l,nat,ntaken,first,last + type(canonical_sorter) :: newsort,refsort + real(wp) :: rthr_ref,ethr_ref + real(wp) :: rmsdval,deltaE + type(coord),pointer :: mol + logical :: topocheck + type(rmsd_cache),allocatable :: rcache !> similarity check cache (iRMSD) + integer,allocatable :: similarto(:) + + nout = 0 + dupe = .false. + broken = .false. + topocheck = .true. + nat = newmols(1)%nat + if (present(ethr)) then + ethr_ref = ethr + else + ethr_ref = 0.0_wp + end if + if (present(rthr)) then + rthr_ref = rthr + else + rthr_ref = 0.0_wp + end if +!>--- allocate mapping + allocate (similarto(nmerge),source=0) + +!>--- we can skip the soring is "inputs" is empty + if (nin .ne. 0) then +!>--- Prepare comparison data storage + if (debug) write (*,*) + if (.not.allocated(rcache)) then + if (debug) write (*,*) "allocating RCACHE" + !$omp critical + allocate (rcache) + call rcache%allocate(nat) + !$omp end critical + end if + !$omp critical + call refsort%init(inputs(1),invtype='apsp+',heavy=.false.) + call newsort%init(newmols(1),invtype='apsp+',heavy=.false.) + !$omp end critical + +!>--- double loop to count duplicates + COMPAREOUTER: do i = 1,nin + COMPAREINNER: do j = 1,nmerge + if (similarto(j) .ne. 0) cycle COMPAREINNER + mol => newmols(j) + !> Energy difference + deltaE = (mol%energy-inputs(i)%energy)*autokcal + !> we can skip some comparisons if the energy difference is too large + if (abs(deltaE) .gt. ethr) cycle COMPAREINNER + + !> Geometry difference (permutation-invariant RMSD) + if (topocheck) then + rcache%rank(1:nat,1) = newsort%rank(1:nat) + rcache%rank(1:nat,2) = refsort%rank(1:nat) + end if + call min_rmsd(mol,inputs(i), & + & rcache=rcache,rmsdout=rmsdval) + + if (debug) write (*,'(a,es15.4,a,es15.4,a)') 'RMSD=',rmsdval*autoaa, & + & ' Å, delta E=',deltaE,' kcal/mol' + + !> Check + if (abs(deltaE) .lt. ethr_ref.and.rmsdval*autoaa .lt. rthr_ref) then + dupe = .true. + similarto(j) = i + if (deltaE < 0.0_wp) then + !> if the energy is lower, we replace the molecule (better conformation) + inputs(i) = mol + end if + exit COMPAREINNER + end if + end do COMPAREINNER + end do COMPAREOUTER + nullify (mol) + !$omp critical + call newsort%deallocate() + call refsort%deallocate() + !$omp end critical + end if + + ntaken = count(similarto(:) .eq. 0) + nout = nin+ntaken + +!>--- after having checked the molecules, allocate new (output) space + allocate (structures(nout)) + k = 0 + if (nin .ne. 0) then + do i = 1,nin + k = k+1 + structures(k) = inputs(i) + end do + end if + do i = 1,nmerge + if (similarto(i) .eq. 0) then + k = k+1 + structures(k) = newmols(i) + end if + end do + +!>--- for good measure, sort by energy again + first = 1 + last = nout + call ensemble_qsort(nout,structures,first,last) + +!>-- overwrite "inputs" + nin = nout + if(allocated(inputs)) deallocate(inputs) + call move_alloc(structures,inputs) + + end subroutine unionizeEnsembles + +!=========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<--- QCG information - integer :: nmol !> number of molecules - real(wp) :: cma(3) !> center of mass - real(wp) :: aniso !> anisotropy factor - real(wp) :: ell_abc(3) !> ellipsoid axis - real(wp) :: atot !> surface area - real(wp) :: vtot !> volume - real(wp) :: rtot !> radius - real(wp) :: mass !> mass - real(wp) :: gt !> gibbs free energy - real(wp) :: ht !> enthalpy - real(wp) :: svib !> vibrational entropy - real(wp) :: srot !> rotational entropy - real(wp) :: stra !> translational entropy - real(wp) :: eax(3) !> molecular axis - !>--- procedures to be used with the zmol type contains procedure :: wrtable => wrtable !> write CNs and neighbours diff --git a/src/ztopology.f90 b/src/sorting/ztopology.f90 similarity index 100% rename from src/ztopology.f90 rename to src/sorting/ztopology.f90 diff --git a/src/strucreader.f90 b/src/strucreader.f90 index 24c7e583..ee88c821 100644 --- a/src/strucreader.f90 +++ b/src/strucreader.f90 @@ -50,6 +50,7 @@ module strucrd !>--- some constants and name mappings real(wp),parameter :: bohr = 0.52917726_wp + real(wp),parameter :: aatoau = 1.0_wp/bohr real(wp),parameter :: autokcal = 627.509541_wp !>-- filetypes as integers integer,parameter :: tmcoord = 1 @@ -135,6 +136,7 @@ module strucrd public :: pdbdata public :: coord public :: ensemble + public :: mollist public :: coordline public :: get_atlist @@ -213,20 +215,28 @@ module strucrd procedure :: get_CN => coord_get_CN !> calculate coordination number procedure :: get_z => coord_get_z !> calculate nuclear charge procedure :: cn_to_bond => coord_cn_to_bond !> generate neighbour matrix from CN + procedure :: swap => atswp !> swap two atoms coordinates and their at() entries end type coord !=========================================================================================! - !ensemble class. contains all structures of an ensemble - !by convention coordinates are in Angström for an ensemble! + !> ensemble class. contains all structures of an ensemble + !> by convention coordinates are in Angström for an ensemble! type :: ensemble - !--- data - integer :: nat = 0 !number of total atoms - integer :: nall = 0 !number of structures - integer,allocatable :: vnat(:) !used instead of nat if not all structures have the same number of atoms, in which case nat will be =maxval(vnat,1) + logical :: mixed = .false. !> if all molecules were the same == .false. + + !> data + integer :: nat = 0 !> (max) number of total atoms + integer :: nall = 0 !> number of structures + + !> if all structures were the same molecule these are filled + !> mixed==.false. + integer,allocatable :: at(:) !> atom types as integer, dimension will be at(nat) + real(wp),allocatable :: xyz(:,:,:) !> coordinates, dimension will be xyz(3,nat,nall) + real(wp),allocatable :: er(:) !> energy of each structure, dimension will be eread(nall) - integer,allocatable :: at(:) !atom types as integer, dimension will be at(nat) - real(wp),allocatable :: xyz(:,:,:) !coordinates, dimension will be xyz(3,nat,nall) - real(wp),allocatable :: er(:) !energy of each structure, dimension will be eread(nall) + !> otherwise this is filled + !> mixed == .true. + type(coord),allocatable :: structures(:) real(wp) :: g !gibbs free energy real(wp) :: s !entropy @@ -240,8 +250,15 @@ module strucrd procedure :: deallocate => deallocate_ensembletype !clear memory space procedure :: open => openensemble !read an ensemble file procedure :: write => write_ensemble !write to file - + procedure :: get_mol => ensemble_get_mol !extract the i-th mol from ensemble type end type ensemble + +!==========================================================================================! + type :: mollist + integer :: nall = 0 + type(coord),allocatable :: structure(:) + end type mollist + !=========================================================================================! !=========================================================================================! contains !> MODULE PROCEDURES START HERE @@ -672,7 +689,12 @@ subroutine write_ensemble(self,fname) implicit none class(ensemble) :: self character(len=*),intent(in) :: fname - call wrensemble_conf_energy(fname,self%nat,self%nall,self%at,self%xyz,self%er) + if (.not.self%mixed) then + call wrensemble_conf_energy(fname,self%nat,self%nall,self%at,self%xyz,self%er) + else + self%structures(:)%energy = self%er(:) + call wrensemble_coord_name(fname,self%nall,self%structures) + end if return end subroutine write_ensemble @@ -709,18 +731,21 @@ end subroutine wrensemble_coord_channel subroutine deallocate_ensembletype(self) implicit none class(ensemble) :: self + + self%mixed = .false. self%nat = 0 self%nall = 0 - if (allocated(self%vnat)) deallocate (self%vnat) if (allocated(self%at)) deallocate (self%at) if (allocated(self%xyz)) deallocate (self%xyz) if (allocated(self%er)) deallocate (self%er) + + if (allocated(self%structures)) deallocate (self%structures) + if (allocated(self%gt)) deallocate (self%gt) if (allocated(self%ht)) deallocate (self%ht) if (allocated(self%svib)) deallocate (self%svib) if (allocated(self%srot)) deallocate (self%srot) if (allocated(self%stra)) deallocate (self%stra) - return end subroutine deallocate_ensembletype @@ -739,32 +764,81 @@ subroutine openensemble(self,fname) real(wp),allocatable :: eread(:) integer :: nall integer :: i,j,k,ich,io - logical :: ex + logical :: ex,conform + type(coord),allocatable :: structures(:) inquire (file=fname,exist=ex) if (.not.ex) then error stop 'ensemble file does not exist.' end if - call rdensembleparam(fname,nat,nall) - - if (nat > 0.and.nall > 0) then - call self%deallocate() - allocate (at(nat),xyz(3,nat,nall),eread(nall)) - call rdensemble(fname,nat,nall,at,xyz,eread) - - self%nat = nat - self%nall = nall - call move_alloc(at,self%at) - call move_alloc(xyz,self%xyz) - call move_alloc(eread,self%er) + !> we check if all the structures in the file + !> are actually the same length (nat), if not we need to + !> take care of this and read into self%structures instead + call rdensembleparam(fname,nat,nall,conform) + self%mixed = .not.conform + + if (conform) then + if (nat > 0.and.nall > 0) then + call self%deallocate() + allocate (at(nat),xyz(3,nat,nall),eread(nall)) + call rdensemble(fname,nat,nall,at,xyz,eread) + + self%nat = nat + self%nall = nall + call move_alloc(at,self%at) + call move_alloc(xyz,self%xyz) + call move_alloc(eread,self%er) + else + error stop 'format error while reading ensemble file.' + end if else - error stop 'format error while reading ensemble file.' + call rdensemble_coord_type(fname,self%nall,self%structures) + allocate(self%er(nall),source=0.0_wp) + self%er(:) = self%structures(:)%energy end if return end subroutine openensemble + subroutine ensemble_get_mol(self,i,mol) + class(ensemble) :: self + integer,intent(in) :: i + class(coord),intent(inout) :: mol + integer :: n + logical :: reinitialize + if (i > self%nall) error stop 'can´t get molecule from ensemble. i>nall' + if (i < 1) error stop 'can´t get molecule from ensemble. i<1' + if (.not.self%mixed) then + n = self%nat + reinitialize = .not. (mol%nat == n) + if (reinitialize) then + mol%nat = n + if (allocated(mol%at)) deallocate (mol%at) + allocate (mol%at(n),source=0) + if (allocated(mol%xyz)) deallocate (mol%xyz) + allocate (mol%xyz(3,n),source=0.0_wp) + end if + mol%energy = self%er(i) + mol%at(:) = self%at(:) + !> Important, ens is in Angström, mol is in Bohrs + mol%xyz(1:3,1:n) = self%xyz(1:3,1:n,i)*aatoau + else !> self%mixed == .true. + n = self%structures(i)%nat + reinitialize = .not. (mol%nat == n) + if (reinitialize) then + if (allocated(mol%at)) deallocate (mol%at) + allocate (mol%at(n),source=0) + if (allocated(mol%xyz)) deallocate (mol%xyz) + allocate (mol%xyz(3,n),source=0.0_wp) + end if + mol%nat = self%structures(i)%nat + mol%at(:) = self%structures(i)%at(:) + mol%xyz(:,:) = self%structures(i)%xyz(:,:) + mol%energy = self%structures(i)%energy + end if + end subroutine ensemble_get_mol + !=========================================================================================! !=========================================================================================! ! 2. ROUTINES FOR READING SINGLE STRUCTURES (COORDS) @@ -1220,7 +1294,7 @@ end subroutine rdPDB ! nat - number of atoms ! ! On Output: at - atom number as integer -! xyz - coordinates (in Angström) +! xyz - coordinates (in Bohr) !============================================================! subroutine rdxmolselec(fname,m,nat,at,xyz,comment) @@ -1506,10 +1580,10 @@ subroutine coord_get_z(self,z) end subroutine coord_get_z !==================================================================! - - subroutine coord_cn_to_bond(self,cn,bond,cn_type,cn_thr) - implicit none - class(coord) :: self + + subroutine coord_cn_to_bond(self,cn,bond,cn_type,cn_thr) + implicit none + class(coord) :: self real(wp),intent(out),allocatable :: cn(:) real(wp),intent(out),allocatable,optional :: bond(:,:) real(wp),intent(in),optional :: cn_thr @@ -1519,8 +1593,7 @@ subroutine coord_cn_to_bond(self,cn,bond,cn_type,cn_thr) allocate (cn(self%nat),source=0.0_wp) call calculate_CN(self%nat,self%at,self%xyz,cn, & & cntype=cn_type,cnthr=cn_thr,bond=bond) - end subroutine coord_cn_to_bond - + end subroutine coord_cn_to_bond !=========================================================================================! !=========================================================================================! @@ -1721,7 +1794,7 @@ subroutine wrxyz_channel_energy(ch,nat,at,xyz,er) integer :: i,j,k,ich,io logical :: ex write (ch,'(2x,i0)') nat - write (ch,'(2x,f18.8)') er + write (ch,'(2x,a,f18.8)') "energy=",er do j = 1,nat write (ch,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) end do @@ -1935,12 +2008,14 @@ subroutine writecoord(self,fname) implicit none class(coord) :: self character(len=*),intent(in) :: fname + character(len=80) :: comment if (.not.allocated(self%xyz)) then write (*,*) 'Cannot write ',trim(fname),'. not allocated' end if if (index(fname,'.xyz') .ne. 0) then + write (comment,'(a,G0.12)') ' energy= ',self%energy self%xyz = self%xyz*bohr !to Angström - call wrxyz(fname,self%nat,self%at,self%xyz) + call wrxyz(fname,self%nat,self%at,self%xyz,comment) self%xyz = self%xyz/bohr !back else call wrc0(fname,self%nat,self%at,self%xyz) @@ -1962,7 +2037,7 @@ subroutine appendcoord(self,io) if (allocated(self%comment)) then call wrxyz(io,self%nat,self%at,self%xyz,trim(self%comment)) else if (self%energy .ne. 0.0_wp) then - write (atmp,'(a,f22.10)') ' Etot= ',self%energy + write (atmp,'(a,f22.10)') ' energy= ',self%energy call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) else call wrxyz(io,self%nat,self%at,self%xyz) @@ -1980,9 +2055,9 @@ subroutine appendlog(self,io,energy,gnorm) character(len=64) :: atmp self%xyz = self%xyz*bohr !to Angström if (present(gnorm).and.present(energy)) then - write (atmp,'(a,f22.10,a,f16.8)') ' Etot= ',energy,' grad.norm.= ',gnorm + write (atmp,'(a,f22.10,a,f16.8)') ' energy= ',energy,' grad.norm.= ',gnorm else if (present(energy)) then - write (atmp,'(a,f22.10)') ' Etot= ',energy + write (atmp,'(a,f22.10)') ' energy= ',energy else atmp = '' end if @@ -2230,14 +2305,14 @@ function grepenergy(line) integer :: i,io,k atmp = trim(line) energy = 0.0_wp - if(index(atmp,'energy=').ne.0)then - k=index(atmp,'energy=') - atmp=atmp(k+7:) + if (index(atmp,'energy=') .ne. 0) then + k = index(atmp,'energy=') + atmp = atmp(k+7:) read (atmp,*,iostat=io) energy - if(io.ne.0) energy=0.0_wp - else if(index(atmp,'energy:').ne.0)then - k=index(atmp,'energy:') - atmp=atmp(k+7:) + if (io .ne. 0) energy = 0.0_wp + else if (index(atmp,'energy:') .ne. 0) then + k = index(atmp,'energy:') + atmp = atmp(k+7:) read (atmp,*,iostat=io) energy if (io .ne. 0) energy = 0.0_wp else @@ -2370,6 +2445,25 @@ subroutine get_atlist(nat,atlist,line,at) deallocate (substr) end subroutine get_atlist +!=========================================================================================! + + subroutine atswp(self,ati,atj) + !******************************** + !* swap atom ati with atj in mol + !******************************** + implicit none + class(coord),intent(inout) :: self + integer,intent(in) :: ati,atj + real(wp) :: xyztmp(3) + integer :: attmp + xyztmp(1:3) = self%xyz(1:3,ati) + attmp = self%at(ati) + self%xyz(1:3,ati) = self%xyz(1:3,atj) + self%at(ati) = self%at(atj) + self%xyz(1:3,atj) = xyztmp(1:3) + self%at(atj) = attmp + end subroutine atswp + !=========================================================================================! !=========================================================================================! ! end of the module diff --git a/src/utilmod.f90 b/src/utilmod.f90 index 5ba52271..a33251b1 100644 --- a/src/utilmod.f90 +++ b/src/utilmod.f90 @@ -49,6 +49,7 @@ module utilities public :: distcma public :: binomial public :: factorial + public :: nth_prime !========================================================================================! !========================================================================================! @@ -544,64 +545,199 @@ end subroutine dumpenergies !========================================================================================! - function binomial(n, k) result(res) + function binomial(n,k) result(res) !************************************************** -!* Function to calculate the binomial coefficient +!* Function to calculate the binomial coefficient !* !* ⎛ n ⎞ !* ⎝ k ⎠ = n! / (k! * (n - k)!) !* !************************************************** implicit none - integer, intent(in) :: n, k + integer,intent(in) :: n,k real(wp) :: reswp integer :: res - reswp = factorial(n) / (factorial(k) * factorial(n - k)) + reswp = factorial(n)/(factorial(k)*factorial(n-k)) res = nint(reswp) end function binomial - function factorial(x) result(fact) !*************************************************** -!* Function to calculate the factorial of a number -!* factorial(x) = x! = x * (x-1) * (x-2) * ... * 1 +!* Function to calculate the factorial of a number +!* factorial(x) = x! = x * (x-1) * (x-2) * ... * 1 !*************************************************** implicit none - integer, intent(in) :: x + integer,intent(in) :: x integer :: i real(wp) :: fact fact = 1.0_wp - do i = 2, x - fact = fact * real(i,wp) + do i = 2,x + fact = fact*real(i,wp) end do end function factorial - - recursive subroutine get_combinations(n, k, ntot, c, combinations, tmp, depth) + recursive subroutine get_combinations(n,k,ntot,c,combinations,tmp,depth) implicit none - integer, intent(in) :: n, k, ntot, depth !> depth should start out as 0 + integer,intent(in) :: n,k,ntot,depth !> depth should start out as 0 integer,intent(inout) :: c,tmp(k) - integer, intent(inout) :: combinations(k,ntot) + integer,intent(inout) :: combinations(k,ntot) integer :: i if (depth >= k) then - c=c+1 + c = c+1 combinations(:,c) = tmp(:) return - else if(depth==0)then - do i=1,n - tmp(depth+1) = i - call get_combinations(n, k, ntot, c, combinations, tmp, depth+1) - enddo - else - do i=1,tmp(depth) - if(i==tmp(depth)) cycle - tmp(depth+1) = i - call get_combinations(n, k, ntot, c, combinations, tmp, depth+1) - enddo + else if (depth == 0) then + do i = 1,n + tmp(depth+1) = i + call get_combinations(n,k,ntot,c,combinations,tmp,depth+1) + end do + else + do i = 1,tmp(depth) + if (i == tmp(depth)) cycle + tmp(depth+1) = i + call get_combinations(n,k,ntot,c,combinations,tmp,depth+1) + end do end if end subroutine get_combinations +!========================================================================================! + function nth_prime(n) result(prime) +!******************************************** +!* get the n-th prime number. +!* The first thousand are saved as a +!* parameter to reduce computational effort. +!******************************************** + implicit none + integer,intent(in) :: n + integer :: prime + integer :: c,num,i + logical :: is_prime +!&< + integer,parameter :: maxprimepar = 1000 + integer, parameter :: prime_numbers(maxprimepar) = (/ & + & 2, 3, 5, 7, 11, 13, 17, 19, 23, 29, & + & 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, & + & 73, 79, 83, 89, 97, 101, 103, 107, 109, 113, & + & 127, 131, 137, 139, 149, 151, 157, 163, 167, 173, & + & 179, 181, 191, 193, 197, 199, 211, 223, 227, 229, & + & 233, 239, 241, 251, 257, 263, 269, 271, 277, 281, & + & 283, 293, 307, 311, 313, 317, 331, 337, 347, 349, & + & 353, 359, 367, 373, 379, 383, 389, 397, 401, 409, & + & 419, 421, 431, 433, 439, 443, 449, 457, 461, 463, & + & 467, 479, 487, 491, 499, 503, 509, 521, 523, 541, & + & 547, 557, 563, 569, 571, 577, 587, 593, 599, 601, & + & 607, 613, 617, 619, 631, 641, 643, 647, 653, 659, & + & 661, 673, 677, 683, 691, 701, 709, 719, 727, 733, & + & 739, 743, 751, 757, 761, 769, 773, 787, 797, 809, & + & 811, 821, 823, 827, 829, 839, 853, 857, 859, 863, & + & 877, 881, 883, 887, 907, 911, 919, 929, 937, 941, & + & 947, 953, 967, 971, 977, 983, 991, 997, 1009, 1013, & + & 1019, 1021, 1031, 1033, 1039, 1049, 1051, 1061, 1063, 1069, & + & 1087, 1091, 1093, 1097, 1103, 1109, 1117, 1123, 1129, 1151, & + & 1153, 1163, 1171, 1181, 1187, 1193, 1201, 1213, 1217, 1223, & + & 1229, 1231, 1237, 1249, 1259, 1277, 1279, 1283, 1289, 1291, & + & 1297, 1301, 1303, 1307, 1319, 1321, 1327, 1361, 1367, 1373, & + & 1381, 1399, 1409, 1423, 1427, 1429, 1433, 1439, 1447, 1451, & + & 1453, 1459, 1471, 1481, 1483, 1487, 1489, 1493, 1499, 1511, & + & 1523, 1531, 1543, 1549, 1553, 1559, 1567, 1571, 1579, 1583, & + & 1597, 1601, 1607, 1609, 1613, 1619, 1621, 1627, 1637, 1657, & + & 1663, 1667, 1669, 1693, 1697, 1699, 1709, 1721, 1723, 1733, & + & 1741, 1747, 1753, 1759, 1777, 1783, 1787, 1789, 1801, 1811, & + & 1823, 1831, 1847, 1861, 1867, 1871, 1873, 1877, 1879, 1889, & + & 1901, 1907, 1913, 1931, 1933, 1949, 1951, 1973, 1979, 1987, & + & 1993, 1997, 1999, 2003, 2011, 2017, 2027, 2029, 2039, 2053, & + & 2063, 2069, 2081, 2083, 2087, 2089, 2099, 2111, 2113, 2129, & + & 2131, 2137, 2141, 2143, 2153, 2161, 2179, 2203, 2207, 2213, & + & 2221, 2237, 2239, 2243, 2251, 2267, 2269, 2273, 2281, 2287, & + & 2293, 2297, 2309, 2311, 2333, 2339, 2341, 2347, 2351, 2357, & + & 2371, 2377, 2381, 2383, 2389, 2393, 2399, 2411, 2417, 2423, & + & 2437, 2441, 2447, 2459, 2467, 2473, 2477, 2503, 2521, 2531, & + & 2539, 2543, 2549, 2551, 2557, 2579, 2591, 2593, 2609, 2617, & + & 2621, 2633, 2647, 2657, 2659, 2663, 2671, 2677, 2683, 2687, & + & 2689, 2693, 2699, 2707, 2711, 2713, 2719, 2729, 2731, 2741, & + & 2749, 2753, 2767, 2777, 2789, 2791, 2797, 2801, 2803, 2819, & + & 2833, 2837, 2843, 2851, 2857, 2861, 2879, 2887, 2897, 2903, & + & 2909, 2917, 2927, 2939, 2953, 2957, 2963, 2969, 2971, 2999, & + & 3001, 3011, 3019, 3023, 3037, 3041, 3049, 3061, 3067, 3079, & + & 3083, 3089, 3109, 3119, 3121, 3137, 3163, 3167, 3169, 3181, & + & 3187, 3191, 3203, 3209, 3217, 3221, 3229, 3251, 3253, 3257, & + & 3259, 3271, 3299, 3301, 3307, 3313, 3319, 3323, 3329, 3331, & + & 3343, 3347, 3359, 3361, 3371, 3373, 3389, 3391, 3407, 3413, & + & 3433, 3449, 3457, 3461, 3463, 3467, 3469, 3491, 3499, 3511, & + & 3517, 3527, 3529, 3533, 3539, 3541, 3547, 3557, 3559, 3571, & + & 3581, 3583, 3593, 3607, 3613, 3617, 3623, 3631, 3637, 3643, & + & 3659, 3671, 3673, 3677, 3691, 3697, 3701, 3709, 3719, 3727, & + & 3733, 3739, 3761, 3767, 3769, 3779, 3793, 3797, 3803, 3821, & + & 3823, 3833, 3847, 3851, 3853, 3863, 3877, 3881, 3889, 3907, & + & 3911, 3917, 3919, 3923, 3929, 3931, 3943, 3947, 3967, 3989, & + & 4001, 4003, 4007, 4013, 4019, 4021, 4027, 4049, 4051, 4057, & + & 4073, 4079, 4091, 4093, 4099, 4111, 4127, 4129, 4133, 4139, & + & 4153, 4157, 4159, 4177, 4201, 4211, 4217, 4219, 4229, 4231, & + & 4241, 4243, 4253, 4259, 4261, 4271, 4273, 4283, 4289, 4297, & + & 4327, 4337, 4339, 4349, 4357, 4363, 4373, 4391, 4397, 4409, & + & 4421, 4423, 4441, 4447, 4451, 4457, 4463, 4481, 4483, 4493, & + & 4507, 4513, 4517, 4519, 4523, 4547, 4549, 4561, 4567, 4583, & + & 4591, 4597, 4603, 4621, 4637, 4639, 4643, 4649, 4651, 4657, & + & 4663, 4673, 4679, 4691, 4703, 4721, 4723, 4729, 4733, 4751, & + & 4759, 4783, 4787, 4789, 4793, 4799, 4801, 4813, 4817, 4831, & + & 4861, 4871, 4877, 4889, 4903, 4909, 4919, 4931, 4933, 4937, & + & 4943, 4951, 4957, 4967, 4969, 4973, 4987, 4993, 4999, 5003, & + & 5009, 5011, 5021, 5023, 5039, 5051, 5059, 5077, 5081, 5087, & + & 5099, 5101, 5107, 5113, 5119, 5147, 5153, 5167, 5171, 5179, & + & 5189, 5197, 5209, 5227, 5231, 5233, 5237, 5261, 5273, 5279, & + & 5281, 5297, 5303, 5309, 5323, 5333, 5347, 5351, 5381, 5387, & + & 5393, 5399, 5407, 5413, 5417, 5419, 5431, 5437, 5441, 5443, & + & 5449, 5471, 5477, 5479, 5483, 5501, 5503, 5507, 5519, 5521, & + & 5527, 5531, 5557, 5563, 5569, 5573, 5581, 5591, 5623, 5639, & + & 5641, 5647, 5651, 5653, 5657, 5659, 5669, 5683, 5689, 5693, & + & 5701, 5711, 5717, 5737, 5741, 5743, 5749, 5779, 5783, 5791, & + & 5801, 5807, 5813, 5821, 5827, 5839, 5843, 5849, 5851, 5857, & + & 5861, 5867, 5869, 5879, 5881, 5897, 5903, 5923, 5927, 5939, & + & 5953, 5981, 5987, 6007, 6011, 6029, 6037, 6043, 6047, 6053, & + & 6067, 6073, 6079, 6089, 6091, 6101, 6113, 6121, 6131, 6133, & + & 6143, 6151, 6163, 6173, 6197, 6199, 6203, 6211, 6217, 6221, & + & 6229, 6247, 6257, 6263, 6269, 6271, 6277, 6287, 6299, 6301, & + & 6311, 6317, 6323, 6329, 6337, 6343, 6353, 6359, 6361, 6367, & + & 6373, 6379, 6389, 6397, 6421, 6427, 6449, 6451, 6469, 6473, & + & 6481, 6491, 6521, 6529, 6547, 6551, 6553, 6563, 6569, 6571, & + & 6577, 6581, 6599, 6607, 6619, 6637, 6653, 6659, 6661, 6673, & + & 6679, 6689, 6691, 6701, 6703, 6709, 6719, 6733, 6737, 6761, & + & 6763, 6779, 6781, 6791, 6793, 6803, 6823, 6827, 6829, 6833, & + & 6841, 6857, 6863, 6869, 6871, 6883, 6899, 6907, 6911, 6917, & + & 6947, 6949, 6959, 6961, 6967, 6971, 6977, 6983, 6991, 6997, & + & 7001, 7013, 7019, 7027, 7039, 7043, 7057, 7069, 7079, 7103, & + & 7109, 7121, 7127, 7129, 7151, 7159, 7177, 7187, 7193, 7207, & + & 7211, 7213, 7219, 7229, 7237, 7243, 7247, 7253, 7283, 7297, & + & 7307, 7309, 7321, 7331, 7333, 7349, 7351, 7369, 7393, 7411, & + & 7417, 7433, 7451, 7457, 7459, 7477, 7481, 7487, 7489, 7499, & + & 7507, 7517, 7523, 7529, 7537, 7541, 7547, 7549, 7559, 7561, & + & 7573, 7577, 7583, 7589, 7591, 7603, 7607, 7621, 7639, 7643, & + & 7649, 7669, 7673, 7681, 7687, 7691, 7699, 7703, 7717, 7723, & + & 7727, 7741, 7753, 7757, 7759, 7789, 7793, 7817, 7823, 7829, & + & 7841, 7853, 7867, 7873, 7877, 7879, 7883, 7901, 7907, 7919 /) +!&> + if (n <= maxprimepar) then + prime = prime_numbers(n) + return + end if + c = maxprimepar + num = prime_numbers(maxprimepar) + do while (c < n) + num = num+1 + is_prime = .true. + do i = 2,int(sqrt(real(num))) + if (mod(num,i) == 0) then + is_prime = .false. + exit + end if + end do + if (is_prime) then + c = c+1 + end if + end do + prime = num + end function nth_prime !========================================================================================! !========================================================================================! diff --git a/subprojects/tblite b/subprojects/tblite index 660d1678..6f6cd7d2 160000 --- a/subprojects/tblite +++ b/subprojects/tblite @@ -1 +1 @@ -Subproject commit 660d1678d6f36999d7ffda6e710d5ff00ff2f8ff +Subproject commit 6f6cd7d20d97b22ef00d420904343c7bb8e2afdf From 7077e752e26f9ace85b807b54079072c57e7f03d Mon Sep 17 00:00:00 2001 From: "lukas.rindt" Date: Thu, 18 Dec 2025 15:37:20 +0100 Subject: [PATCH 116/374] merged with maintenance and working thermo+reconstruction --- src/algos/hessian_tools.f90 | 14 ++++-- src/algos/numhess.f90 | 15 ++---- src/calculator/hessian_reconstruct.f90 | 6 --- src/entropy/thermochem_module.f90 | 56 ++++++++++----------- src/optimize/optimize_module.f90 | 70 +++++++++----------------- src/qcg/qcg_misc.f90 | 9 ++-- 6 files changed, 72 insertions(+), 98 deletions(-) diff --git a/src/algos/hessian_tools.f90 b/src/algos/hessian_tools.f90 index b8ad197f..716db799 100644 --- a/src/algos/hessian_tools.f90 +++ b/src/algos/hessian_tools.f90 @@ -29,7 +29,7 @@ module hessian_tools use crest_parameters,only:wp,stdout - use crest_data + ! use crest_data use crest_calculator use strucrd !use optimize_module @@ -65,6 +65,7 @@ subroutine frequencies(nat,at,xyz,nat3,prj_mw_hess,freq,io) real(wp),allocatable :: work(:) integer :: lwork,liwork,info,i + integer :: unit !>LAPCK external :: dsyevd @@ -90,6 +91,13 @@ subroutine frequencies(nat,at,xyz,nat3,prj_mw_hess,freq,io) end if end do + open (newunit=unit,file="frequencies") + write (unit,*) "Frequencies:" + do i = 1,size(freq) + write (unit,*) freq(i) + end do + close (unit) + return end subroutine frequencies @@ -148,10 +156,6 @@ subroutine prj_mw_hess(nat,at,nat3,xyz,hess) allocate (hess_ut(nat3*(nat3+1)/2),source=0.0_wp) allocate (pmode(nat3,1),source=0.0_wp) - do i = 1,size(hess,dim=1) - print*,hess(1,i) - end do - !> Transforms matrix of the upper triangle vector call dsqtoh(nat3,hess,hess_ut) diff --git a/src/algos/numhess.f90 b/src/algos/numhess.f90 index bd6063ad..0562ea43 100644 --- a/src/algos/numhess.f90 +++ b/src/algos/numhess.f90 @@ -276,7 +276,7 @@ subroutine numhess_thermostat(env,mol,nat3,hess,freq,etot) implicit none !> INPUT type(systemdata) :: env - type(coord), intent(inout) :: mol + type(coord),intent(inout) :: mol integer,intent(in) :: nat3 real(wp),intent(in) :: hess(nat3,nat3) real(wp),intent(inout) :: freq(nat3) @@ -288,6 +288,7 @@ subroutine numhess_thermostat(env,mol,nat3,hess,freq,etot) real(wp) :: zpve character(len=*),parameter :: outfmt = & & '(10x,"::",1x,a,f24.12,1x,a,1x,"::")' + integer :: iunit !> inversion threshold ithr = env%thermo%ithr @@ -309,7 +310,7 @@ subroutine numhess_thermostat(env,mol,nat3,hess,freq,etot) !> calcthermo wants input in Bohr call calcthermo(mol%nat,mol%at,mol%xyz,freq,.true., & - & ithr,fscal,sthr,nt,temps,et,ht,gt,stot) + & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,iunit) !> printoutgeometr zpve = et(nrt)-ht(nrt) @@ -353,7 +354,7 @@ subroutine thermo_standalone(env) integer :: nt,nfreq,nrt real(wp),allocatable :: temps(:),et(:),ht(:),stot(:),gt(:) real(wp) :: zpve - integer :: ich,i + integer :: ich,i,iunit character(len=*),parameter :: outfmt = & & '(10x,"::",1x,a,f24.12,1x,a,1x,"::")' @@ -413,15 +414,9 @@ subroutine thermo_standalone(env) !write(*,*) nrt temps = env%thermo%temps -<<<<<<< HEAD !> calcthermo wants input in Bohr call calcthermo(mol%nat,mol%at,mol%xyz,freq,.true., & - & ithr,fscal,sthr,nt,temps,et,ht,gt,stot) -======= - !> calcthermo wants input in Angstroem - call calcthermo(mol%nat,mol%at,mol%xyz*autoaa,freq,.true., & - & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,stdout) ->>>>>>> pprcht/3.0.3-maintenance + & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,iunit) !> printout zpve = et(nrt)-ht(nrt) diff --git a/src/calculator/hessian_reconstruct.f90 b/src/calculator/hessian_reconstruct.f90 index 40e83231..99dbd29d 100644 --- a/src/calculator/hessian_reconstruct.f90 +++ b/src/calculator/hessian_reconstruct.f90 @@ -132,12 +132,6 @@ subroutine construct_hessian_bfgs(self) end if tmp(j) = HUGE(tmp(j)) end if - open(newunit=unit, file="reconstruct_bfgs.txt", status="unknown", position="append") - write(unit,*) "cycle:", i - do k = 1, 5 - write(unit,*) hess(k) - enddo - close(unit) end do end if diff --git a/src/entropy/thermochem_module.f90 b/src/entropy/thermochem_module.f90 index 6d2a29aa..de5d2aaa 100644 --- a/src/entropy/thermochem_module.f90 +++ b/src/entropy/thermochem_module.f90 @@ -165,8 +165,6 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & call prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,sym,symchar,iunit) - print*,freq - n3 = 3*nat allocate (vibs(n3)) vibthr = 1.0 @@ -222,7 +220,7 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & write (iunit,dblfmt) "rotor cutoff ",sthr,"cm⁻¹" write (iunit,dblfmt) "imag. cutoff ",ithr,"cm⁻¹" write (iunit,'(10x,":",49("."),":")') - end if + end if vibs = vibs*rcmtoau ! thermodyn needs vibs and zp in Eh @@ -243,29 +241,29 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & stot(j) = (ts(j)/temps(j))*autocal end do - if ( pr )then - write (iunit,'(a)') - write (iunit,'(a10)',advance='no') "T/K" - write (iunit,'(a16)',advance='no') "H(0)-H(T)+PV" - write (iunit,'(a16)',advance='no') "H(T)/Eh" - write (iunit,'(a16)',advance='no') "T*S/Eh" - write (iunit,'(a16)',advance='no') "G(T)/Eh" - write (iunit,'(a)') - write (iunit,'(3x,72("-"))') - do i = 1,nt - write (iunit,'(3f10.2)',advance='no') temps(i) - write (iunit,'(3e16.6)',advance='no') ht(i) - write (iunit,'(3e16.6)',advance='no') et(i) - write (iunit,'(3e16.6)',advance='no') ts(i) - write (iunit,'(3e16.6)',advance='no') gt(i) - if (i == rt .and. nt > 1) then - write (iunit,'(1x,"(used)")') - else - write (iunit,'(a)') - end if - end do - write (iunit,'(3x,72("-"))') - end if + if (pr) then + write (iunit,'(a)') + write (iunit,'(a10)',advance='no') "T/K" + write (iunit,'(a16)',advance='no') "H(0)-H(T)+PV" + write (iunit,'(a16)',advance='no') "H(T)/Eh" + write (iunit,'(a16)',advance='no') "T*S/Eh" + write (iunit,'(a16)',advance='no') "G(T)/Eh" + write (iunit,'(a)') + write (iunit,'(3x,72("-"))') + do i = 1,nt + write (iunit,'(3f10.2)',advance='no') temps(i) + write (iunit,'(3e16.6)',advance='no') ht(i) + write (iunit,'(3e16.6)',advance='no') et(i) + write (iunit,'(3e16.6)',advance='no') ts(i) + write (iunit,'(3e16.6)',advance='no') gt(i) + if (i == rt.and.nt > 1) then + write (iunit,'(1x,"(used)")') + else + write (iunit,'(a)') + end if + end do + write (iunit,'(3x,72("-"))') + end if xyz = xyz*aatoau @@ -277,7 +275,7 @@ subroutine calc_thermo_from_hess(mol,hess,pr,nt,temps,ithr,& & fscal,sthr,et,ht,gt,stot) type(coord),intent(inout) :: mol integer :: nat3 - integer :: io + integer :: io,iunit logical :: pr real(wp) :: ithr,fscal,sthr real(wp),intent(in) :: temps(nt) @@ -298,7 +296,9 @@ subroutine calc_thermo_from_hess(mol,hess,pr,nt,temps,ithr,& call frequencies(mol%nat,mol%at,mol%xyz,nat3,hess,freq,io) call calcthermo(mol%nat,mol%at,mol%xyz,freq,pr,ithr,fscal,sthr,nt,temps, & - & et,ht,gt,stot) + & et,ht,gt,stot,iunit) + + call print_hessian(hess(:,:),nat3,'','numhess') end subroutine calc_thermo_from_hess diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index a942a85a..203270fc 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -35,7 +35,7 @@ module optimize_module use optimize_utils use thermochem_module use hessian_reconstruct - use hessian_tools + !use hessian_tools implicit none private @@ -60,7 +60,7 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) integer,intent(out) :: iostatus real(wp),intent(inout) :: etot real(wp),intent(inout) :: grd(3,mol%nat) - real(wp),allocatable :: H_inv(:,:), freq(:) + real(wp),allocatable :: H_inv(:,:),freq(:) integer :: nat3 integer :: io @@ -91,16 +91,16 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) !> optimization select case (calc%opt_engine) - case ( 0) - call ancopt(molnew,calc,etot,grd,pr,wr,iostatus) - case ( 1) - !> l-bfgs goes here + case (0) + call ancopt(molnew,calc,etot,grd,pr,wr,iostatus) + case (1) + !> l-bfgs goes here !write(stdout,'(a)') 'L-BFGS currently not implemented' !stop call lbfgs_optimize(molnew,calc,etot,grd,pr,iostatus) - case ( 2) - !> rfo goes here - call rfopt(molnew,calc,etot,grd,pr,wr,iostatus) + case (2) + !> rfo goes here + call rfopt(molnew,calc,etot,grd,pr,wr,iostatus) case (-1) call gradientdescent(molnew,calc,etot,grd,pr,wr,iostatus) case default @@ -110,47 +110,25 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) molnew%energy = etot if (calc%do_HU) then !> Hessian construction and post-processing happen here - !print*, "Energies", calc%chess%energy - !print*, "Gradients", calc%chess%gradient - !print*, "Coords", calc%chess%coords - !print*, "Order", calc%chess%order call calc%chess%construct_hessian_bfgs() - !allocate(H_inv(size(calc%chess%B,1),size(calc%chess%B,2))) - !H_inv(:,:) = invert_matrix(calc%chess%B) - - print* - print*,"THERMO FROM MY OWN SHITTY HESSIAN" - print* + write (stdout,*) + write (stdout,*) "THERMO FROM RECONSTRUCTED HESSIAN:" + write (stdout,*) call calc_thermo_from_hess(molnew,calc%chess%B,pr, & & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & & calc%ht,calc%gt,calc%stot) - print* - print*,"THERMO FROM BFGS" - print* + !print* + !print*,"THERMO FROM BFGS" + !print* !call calc_thermo_from_hess(molnew,calc%chess%H,pr, & !& calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & !& calc%ht,calc%gt,calc%stot) - call mass_weight_hess(molnew%nat,molnew%at,nat3,calc%chess%H(:,:)) - - allocate(freq(nat3)) - - call frequencies(molnew%nat,molnew%at,molnew%xyz,nat3,calc%chess%H(:,:),freq,io) - - call calcthermo(molnew%nat,molnew%at,mol%xyz,freq,pr,calc%ithr,calc%fscal,calc%sthr, & - & calc%nt,calc%temperatures, & - & calc%et,calc%ht,calc%gt,calc%stot) - - !write(stdout,*) "et:", calc%et - !write(stdout,*) "ht:", calc%ht - !write(stdout,*) "gt:", calc%gt - !write(stdout,*) "stot:", calc%stot - call calc%chess%dealloc() deallocate (calc%chess) end if @@ -169,16 +147,16 @@ subroutine print_opt_data(calc,ich,natoms,tag) integer :: tight,nat real(wp) :: ethr,gthr character(len=:),allocatable :: ttag - if(present(tag))then - ttag=tag + if (present(tag)) then + ttag = tag else - ttag=' ' - endif - if(present(natoms))then - nat=natoms + ttag = ' ' + end if + if (present(natoms)) then + nat = natoms else - nat=0 - endif + nat = 0 + end if write (ich,'(a,a)',advance='no') ttag,'Optimization engine: ' select case (calc%opt_engine) @@ -215,7 +193,7 @@ subroutine print_opt_data(calc,ich,natoms,tag) & ethr,' Eh,',gthr,' Eh/a0' write (ich,'(a,a,i0)') ttag,'maximum optimization steps: ',calc%maxcycle - + end subroutine print_opt_data !========================================================================================! diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index 82e61672..237312b9 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -92,6 +92,7 @@ subroutine xtb_opt_qcg(env,mol,constrain) use crest_data use qcg_coord_type use strucrd + use optimize_module implicit none type(systemdata),intent(in) :: env @@ -1270,6 +1271,8 @@ subroutine ens_freq_calculator(env,fname,NTMP,TMPdir,opt) use strucrd use crest_calculator use hessian_tools + use thermochem_module + use optimize_module implicit none type(systemdata) :: env @@ -1371,12 +1374,12 @@ subroutine ens_freq_calculator(env,fname,NTMP,TMPdir,opt) call prj_mw_hess(mol%nat,mol%at,n3,mol%xyz,hess(:,:)) !>-- Computes the Frequencies - call frequencies(mol%nat,mol%at,mol%xyz,n3,newcalcs(i),hess(:,:),freq(:),io) + call frequencies(mol%nat,mol%at,mol%xyz,n3,hess(:,:),freq(:),io) !> write dummy "xtb_freq.out" open (newunit=ich,file="xtb_freq.out") - !> calcthermo wants input in Angstroem - call calcthermo(mol%nat,mol%at,mol%xyz*autoaa,freq,.true., & + !> calcthermo wants input in Bohr + call calcthermo(mol%nat,mol%at,mol%xyz,freq,.true., & & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,ich) close (ich) From 86911c7d7a38db40bb2b0d4a7a532a033d505e7b Mon Sep 17 00:00:00 2001 From: "lukas.rindt" Date: Thu, 18 Dec 2025 16:18:51 +0100 Subject: [PATCH 117/374] step catcher implemented --- src/calculator/hessian_reconstruct.f90 | 51 ++++++++++++++++---------- src/entropy/thermochem_module.f90 | 14 +++++-- 2 files changed, 41 insertions(+), 24 deletions(-) diff --git a/src/calculator/hessian_reconstruct.f90 b/src/calculator/hessian_reconstruct.f90 index 99dbd29d..514a08e3 100644 --- a/src/calculator/hessian_reconstruct.f90 +++ b/src/calculator/hessian_reconstruct.f90 @@ -2,6 +2,7 @@ module hessian_reconstruct use iso_fortran_env,only:wp => real64 use hessupdate_module use optimize_maths + use crest_parameters implicit none private @@ -79,7 +80,7 @@ subroutine update_cashed_hessian(self,gradient,energy,coords) class(cashed_hessian),intent(inout) :: self real(wp),intent(in) :: gradient(:,:),energy,coords(:,:) integer :: idx,i - + self%stepcount = self%stepcount+1 idx = minloc(self%order,1) self%order(idx) = self%stepcount @@ -94,7 +95,7 @@ subroutine construct_hessian_bfgs(self) integer :: i,j,k,nat3 real(wp),allocatable :: tmp(:),tmp_coords(:,:),tmp_grads(:,:),hess(:),dx(:) real(wp) :: gnorm - integer :: unit + integer :: unit,iter,made_iters nat3 = 3*self%natm @@ -114,27 +115,37 @@ subroutine construct_hessian_bfgs(self) end do call dsqtoh(nat3,self%hguess_mat,hess) - if (minval(tmp) == 0) then - print*,"ERROR: Number of recursive steps for hessian reconstruction larger than number of geoemtry optimization steps!" - else - do i = 1,self%steps - if (i == 1) then - j = minloc(tmp,1) - tmp(j) = HUGE(tmp(j)) - else - j = minloc(tmp,1) - if (j == 1) then - dx = tmp_coords(j,:)-tmp_coords(self%steps,:) - call bfgs(nat3,gnorm,tmp_grads(j,:),tmp_grads(self%steps,:),dx,hess) - else - dx = tmp_coords(j,:)-tmp_coords(j-1,:) - call bfgs(nat3,gnorm,tmp_grads(j,:),tmp_grads(j-1,:),dx,hess) - end if - tmp(j) = HUGE(tmp(j)) - end if + made_iters = self%steps + + if (minval(tmp) == 0) then !> Implement keyword like exact HU that kills the process + made_iters = maxval(tmp) !> if made_iters This only happens if made_iters>steps + if (j == 1) then !> => Not affected if too many steps requested + dx = tmp_coords(j,:)-tmp_coords(self%steps,:) + call bfgs(nat3,gnorm,tmp_grads(j,:),tmp_grads(self%steps,:),dx,hess) + else + dx = tmp_coords(j,:)-tmp_coords(j-1,:) + call bfgs(nat3,gnorm,tmp_grads(j,:),tmp_grads(j-1,:),dx,hess) + end if + tmp(j) = HUGE(tmp(j)) + end if + end do + call dhtosq(nat3,self%B,hess) end subroutine construct_hessian_bfgs diff --git a/src/entropy/thermochem_module.f90 b/src/entropy/thermochem_module.f90 index de5d2aaa..f89fa4c1 100644 --- a/src/entropy/thermochem_module.f90 +++ b/src/entropy/thermochem_module.f90 @@ -102,7 +102,7 @@ subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar,iunit) end subroutine prepthermo subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & - & et,ht,gt,stot,iunit) + & et,ht,gt,stot,iunit_in) !************************************************************** !* Calculate thermodynamic contributions for a given structure !* from it's frequencies (from second derivatives/the Hessian) @@ -123,7 +123,7 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & real(wp),intent(in) :: sthr !rotor cut integer,intent(in) :: nt real(wp),intent(in) :: temps(nt) - integer,intent(in) :: iunit + integer,intent(in),optional :: iunit_in real(wp) :: et(nt) !< enthalpy in Eh real(wp) :: ht(nt) !< enthalpy in Eh real(wp) :: gt(nt) !< free energy in Eh @@ -143,7 +143,7 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & real(wp) :: vibthr real(wp),allocatable :: vibs(:) - integer :: i,j + integer :: i,j,iunit integer :: n3,rt real(wp) :: adum(nt) character(len=64) :: atmp @@ -163,6 +163,12 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & xyz = xyz*autoaa + if (present(iunit_in)) then + iunit = iunit_in + else + iunit = stdout + end if + call prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,sym,symchar,iunit) n3 = 3*nat @@ -296,7 +302,7 @@ subroutine calc_thermo_from_hess(mol,hess,pr,nt,temps,ithr,& call frequencies(mol%nat,mol%at,mol%xyz,nat3,hess,freq,io) call calcthermo(mol%nat,mol%at,mol%xyz,freq,pr,ithr,fscal,sthr,nt,temps, & - & et,ht,gt,stot,iunit) + & et,ht,gt,stot) call print_hessian(hess(:,:),nat3,'','numhess') From 69c7689c698bb53f9e9f886d7f4d3c4280fe8bed Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 19 Dec 2025 23:21:29 +0100 Subject: [PATCH 118/374] refactor rigidconf to molbuilder --- src/CMakeLists.txt | 2 +- src/algos/playground.f90 | 57 +- src/graphs/adjacency.f90 | 9 +- src/meson.build | 2 +- src/{rigidconf => molbuilder}/CMakeLists.txt | 1 + src/{rigidconf => molbuilder}/analyze.f90 | 0 src/molbuilder/construct.f90 | 675 ++++++++++++++++++ src/{rigidconf => molbuilder}/meson.build | 1 + src/{rigidconf => molbuilder}/reconstruct.f90 | 0 src/{rigidconf => molbuilder}/rigidconf.f90 | 0 src/{rigidconf => molbuilder}/tree.f90 | 0 src/sorting/irmsd_module.f90 | 2 +- src/strucreader.f90 | 1 + 13 files changed, 731 insertions(+), 19 deletions(-) rename src/{rigidconf => molbuilder}/CMakeLists.txt (97%) rename src/{rigidconf => molbuilder}/analyze.f90 (100%) create mode 100644 src/molbuilder/construct.f90 rename src/{rigidconf => molbuilder}/meson.build (97%) rename src/{rigidconf => molbuilder}/reconstruct.f90 (100%) rename src/{rigidconf => molbuilder}/rigidconf.f90 (100%) rename src/{rigidconf => molbuilder}/tree.f90 (100%) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 2b5d882a..5299c326 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -23,7 +23,7 @@ add_subdirectory("dynamics") add_subdirectory("qcg") add_subdirectory("qmhelpers") add_subdirectory("graphs") -add_subdirectory("rigidconf") +add_subdirectory("molbuilder") add_subdirectory("discretize") add_subdirectory("entropy") add_subdirectory("legacy_algos") diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index 533dfe63..5501b9ae 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -31,7 +31,6 @@ subroutine crest_playground(env,tim) use crest_data use crest_calculator use strucrd - use canonical_mod implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim @@ -51,7 +50,6 @@ subroutine crest_playground(env,tim) real(wp) :: energy real(wp),allocatable :: grad(:,:),geo(:,:),csv(:,:),q(:) - type(canonical_sorter) :: can !========================================================================================! call tim%start(14,'Test implementation') !========================================================================================! @@ -63,20 +61,53 @@ subroutine crest_playground(env,tim) write (*,*) " \_/\_/ \___|_|\___\___/|_| |_| |_|\___|" write (*,*) !========================================================================================! - call env%ref%to(mol) - write (*,*) - write (*,*) 'Input structure:' - call mol%append(stdout) - write (*,*) +! call env%ref%to(mol) +! write (*,*) +! write (*,*) 'Input structure:' +! call mol%append(stdout) +! write (*,*) +!!========================================================================================! +! +! allocate (grad(3,mol%nat),source=0.0_wp) +! call env2calc(env,calc,mol) +! calc%calcs(1)%rdwbo = .true. +! call calc%info(stdout) +! +! call engrad(mol,calc,energy,grad,io) +! call calculation_summary(calc,mol,energy,grad) !========================================================================================! + block + use construct_mod + type(coord) :: base,side,new + type(coord),allocatable :: splitlist(:) + integer,allocatable :: alignmap(:,:) + + !call base%open("base.xyz") + !call side%open("side.xyz") + + open (newunit=ich,file='molbuilder.xyz') + !call base%append(ich) + !call side%append(ich) + + !allocate (alignmap(3,2),source=0) + + !alignmap(1:3,1) = [9,7,8] + !alignmap(1:3,2) = [3,1,2] + !call attach(base,side,alignmap,new) + !call new%append(ich) + - allocate (grad(3,mol%nat),source=0.0_wp) - call env2calc(env,calc,mol) - calc%calcs(1)%rdwbo = .true. - call calc%info(stdout) + call new%open("struc.xyz") + !call split(new, [8,9],base,side) + call split(new, [6,7,8],splitlist,alignmap) - call engrad(mol,calc,energy,grad,io) - call calculation_summary(calc,mol,energy,grad) + do i=1,size(splitlist,1) + call splitlist(i)%append(ich) + enddo + !call base%append(ich) + !call side%append(ich) + close (ich) + end block !========================================================================================! call tim%stop(14) diff --git a/src/graphs/adjacency.f90 b/src/graphs/adjacency.f90 index 84262c0d..8393e5d4 100644 --- a/src/graphs/adjacency.f90 +++ b/src/graphs/adjacency.f90 @@ -90,10 +90,12 @@ subroutine setup_fragments(V,A,frag) integer,intent(in) :: V integer,intent(in) :: A(V,V) !> OUTPUT - integer,intent(out) :: frag(V) + integer,allocatable,intent(out) :: frag(:) !> LOCAL integer :: i,j,k,nfrag integer,allocatable :: tmp(:) + if(allocated(frag)) deallocate(frag) + allocate(frag(V)) frag = 0 nfrag = 0 allocate (tmp(V),source=0) @@ -147,11 +149,12 @@ subroutine check_rings_min(V,A,rings) integer,intent(in) :: V integer,intent(in) :: A(V,V) !> OUTPUT - logical,intent(out) :: rings(V,V) + logical,allocatable,intent(out) :: rings(:,:) !> LOCAL integer,allocatable :: Adum(:,:) integer,allocatable :: tmp(:) integer :: i,j + if(.not.allocated(rings)) allocate(rings(V,V)) rings = .false. allocate(Adum(V,V), source = 0) allocate(tmp(V), source = 0) @@ -196,7 +199,7 @@ subroutine get_ring_min(V,A,M,N,path,nring) path = 0 nring = 0 - allocate(Atmp(V,V), source=0) + allocate(Atmp(V,V), source=A) Atmp(:,:) = A(:,:) Atmp(M,N) = 0 Atmp(N,M) = 0 diff --git a/src/meson.build b/src/meson.build index c758a99e..38acf284 100644 --- a/src/meson.build +++ b/src/meson.build @@ -22,7 +22,7 @@ subdir('algos') subdir('parsing') subdir('qmhelpers') subdir('graphs') -subdir('rigidconf') +subdir('molbuilder') subdir('discretize') subdir('entropy') subdir('legacy_algos') diff --git a/src/rigidconf/CMakeLists.txt b/src/molbuilder/CMakeLists.txt similarity index 97% rename from src/rigidconf/CMakeLists.txt rename to src/molbuilder/CMakeLists.txt index c70e846d..abbeada4 100644 --- a/src/rigidconf/CMakeLists.txt +++ b/src/molbuilder/CMakeLists.txt @@ -21,6 +21,7 @@ list(APPEND srcs "${dir}/tree.f90" "${dir}/analyze.f90" "${dir}/reconstruct.f90" + "${dir}/construct.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/rigidconf/analyze.f90 b/src/molbuilder/analyze.f90 similarity index 100% rename from src/rigidconf/analyze.f90 rename to src/molbuilder/analyze.f90 diff --git a/src/molbuilder/construct.f90 b/src/molbuilder/construct.f90 new file mode 100644 index 00000000..04044291 --- /dev/null +++ b/src/molbuilder/construct.f90 @@ -0,0 +1,675 @@ +module construct_mod + !*********************************************** + !* A module for constructing molecules + !* E.g. replacing functional groups and so on + !*********************************************** + use crest_parameters + use strucrd + use irmsd_module + use adjacency + use miscdata,only:rcov + implicit none + private + + public :: attach + + public :: split + interface split + module procedure split_onbond + module procedure split_onshared + end interface split + +!=============================================================================! +contains !> MODULE PROCEDURES START HERE +!=============================================================================! + + subroutine attach(base,side,alignmap,new,clash,remove_base,remove_side) + !*********************************************************************** + !* This routine attaches a side-molecule to a base-molecule + !* The assumption is that we have (at least) 3 proxy atoms + !* that are used to match the side to the base, specified + !* via the alignmap. + !* Args: + !* base - base molecule + !* side - side chain molecule to attach to base + !* alignmap - (x,2) specification list of x proxy atoms in side/base + !* new - newly constructed molecule + !* + !* Optionl args: + !* clash - logical, were clashes produced? + !* remove_base - list of atoms to remove from base upon + !* constructing the new mol + !* remove_side - list of atoms to remove from side upon + !* constructing the new mol + !*********************************************************************** + implicit none + !> IN/OUTPUTS + type(coord),intent(in) :: base + type(coord),intent(in) :: side + integer,intent(in) :: alignmap(:,:) + type(coord),intent(out) :: new + + logical,intent(out),optional :: clash + integer,intent(in),optional :: remove_base(:) + integer,intent(in),optional :: remove_side(:) + + !> LOCAL + type(coord) :: cutout_base,cutout_side,side_tmp + logical,allocatable :: cutlist_base(:),cutlist_side(:) + integer,allocatable :: current_order(:),target_order(:),idx(:) + real(wp) :: rms,Umat(3,3),shift(3),center_base(3),center_side(3) + integer :: nalign,nat_new + + integer :: ii,jj,kk + + character(len=*),parameter :: source = "attach()" + + !> defaults/checks of the alignmap + nalign = size(alignmap,1) + if (nalign < 3) then + error stop source//": alignmap needs at leaast 3 atoms" + end if + if (size(alignmap,2) .ne. 2) then + error stop source//": alignmap has wrong dimension" + end if + !> alignmap(:,1) --> base atoms + if (any(alignmap(:,1) > base%nat).or.any(alignmap(:,1) < 1)) then + error stop source//": alignmap(:,1) has invalid values" + end if + !> alignmap(:,2) --> side atoms + if (any(alignmap(:,2) > side%nat).or.any(alignmap(:,2) < 1)) then + error stop source//": alignmap(:,2) has invalid values" + end if + + !> helper arrays + allocate (target_order(nalign),current_order(nalign),idx(nalign),source=0) + + !> generate cutout of base + allocate (cutlist_base(base%nat),source=.false.) + kk = 0 + do ii = 1,nalign + cutlist_base(alignmap(ii,1)) = .true. + current_order(ii) = ii + end do + kk = 0 + do ii = 1,base%nat + do jj = 1,nalign + if (alignmap(jj,1) == ii) then + kk = kk+1 + target_order(kk) = jj + end if + end do + end do + cutout_base = base%cutout(cutlist_base) + call molatomsort(cutout_base,nalign,current_order,target_order,idx) + + !> generate cutout of side + allocate (cutlist_side(side%nat),source=.false.) + do ii = 1,nalign + cutlist_side(alignmap(ii,2)) = .true. + current_order(ii) = ii + end do + kk = 0 + do ii = 1,side%nat + do jj = 1,nalign + if (alignmap(jj,2) == ii) then + kk = kk+1 + target_order(kk) = jj + end if + end do + end do + cutout_side = side%cutout(cutlist_side) + call molatomsort(cutout_side,nalign,current_order,target_order,idx) + + !> determine offset and translate + do ii = 1,3 + center_base(ii) = sum(cutout_base%xyz(ii,:))/real(cutout_base%nat) + center_side(ii) = sum(cutout_side%xyz(ii,:))/real(cutout_side%nat) + end do + shift(1:3) = center_base(1:3)-center_side(1:3) + + !> determine the rotation matrix and translation + rms = rmsd(cutout_base,cutout_side,rotmat=Umat) + + !> build the new rotated and translated side molecule + side_tmp = side + side_tmp%xyz = matmul(Umat,side_tmp%xyz) + !> determine offset and translate + shift = 0.0_wp + do jj = 1,nalign + shift(:) = shift(:)+base%xyz(:,alignmap(jj,1))-side_tmp%xyz(:,alignmap(jj,2)) + end do + shift(:) = shift(:)/real(nalign) + do ii = 1,side_tmp%nat + side_tmp%xyz(1:3,ii) = side_tmp%xyz(1:3,ii)+shift(1:3) + end do + + !> construct the new molecule, re-use cutlists + cutlist_base(:) = .false. + cutlist_side(:) = .false. + do ii = 1,nalign + !> always remove the align atoms on the side chain + cutlist_side(alignmap(ii,2)) = .true. + end do + if (present(remove_base)) then + !> optional removal on the base side + kk = size(remove_base,1) + do ii = 1,kk + cutlist_base(remove_base(ii)) = .true. + end do + end if + if (present(remove_side)) then + !> optional removal on the base side + kk = size(remove_side,1) + do ii = 1,kk + cutlist_side(remove_side(ii)) = .true. + end do + end if + + new%nat = 0 + do ii = 1,base%nat + if (.not.cutlist_base(ii)) new%nat = new%nat+1 + end do + do ii = 1,side%nat + if (.not.cutlist_side(ii)) new%nat = new%nat+1 + end do + allocate (new%at(new%nat),source=0) + allocate (new%xyz(3,new%nat),source=0.0_wp) + kk = 0 + do ii = 1,base%nat + if (.not.cutlist_base(ii)) then + kk = kk+1 + new%at(kk) = base%at(ii) + new%xyz(1:3,kk) = base%xyz(1:3,ii) + end if + end do + do ii = 1,side%nat + if (.not.cutlist_side(ii)) then + kk = kk+1 + new%at(kk) = side_tmp%at(ii) + new%xyz(1:3,kk) = side_tmp%xyz(1:3,ii) + end if + end do + + if (present(clash)) then + clash = .false. + !> TODO implement geometric clash check + end if + end subroutine attach + +!==============================================================================! + + subroutine split_onbond(input,bond,base,side,wbo) + implicit none + !> IN/OUTPUTS + type(coord),intent(in) :: input + integer,intent(in) :: bond(2) + type(coord),intent(out) :: base + type(coord),intent(out) :: side + !> OPTIONAL + real(wp),intent(in),optional :: wbo(input%nat,input%nat) + !> LOCAL + real(wp),allocatable :: cn(:),wbofake(:,:) + integer :: V,fbase,fside + integer,allocatable :: A(:,:),Anew(:,:) + integer,allocatable :: frag(:),fragnew(:) + logical,allocatable :: in_ring(:,:) + integer,allocatable :: path_tmp(:) + integer :: npath,nbase,nside + logical :: needs_capping + real(wp) :: distcap + integer :: ii,jj,kk + + character(len=*),parameter :: source = "split_onbond()" + + !> checks + if (any(bond(:) > input%nat).or.(any(bond(:) < 1))) then + error stop source//": bond() has invalid atom specification" + end if + + !> we will be working with graphs. define number of vertices = #atoms + V = input%nat + + !> set up adjacency matrix + if (present(wbo)) then + call wbo2adjacency(V,wbo,A,0.01_wp) + else + call input%cn_to_bond(cn,wbofake) + call wbo2adjacency(V,wbofake,A,0.01_wp) + deallocate (wbofake,cn) + end if + + !> get fragment array (indicates which atom is on which fragment) + call setup_fragments(V,A,frag) + + !> if the two atoms are already on different fragments we + !> can immediatly proceed, otherwise we need to make some cuts + if (frag(bond(1)) .eq. frag(bond(2))) then + !> check if the two atoms actually correspond to an bond + if (A(bond(1),bond(2)) .eq. 0) then + error stop source//": specified atoms are not directly connected!" + end if + + needs_capping = .true. + !> safety: check for rings (need more cuts) + call check_rings_min(V,A,in_ring) + !allocate (path_tmp(V),source=0) + !call get_ring_min(V,A,bond(1),bond(2),path_tmp,npath) + !if (npath > 0) then + if (in_ring(bond(1),bond(2))) then + !> TODO - Implement actual fallback + error stop "Bond is in a ring! Can not split." + else + !> delete the bond and set up new fragment array + allocate (Anew(V,V),source=A) + Anew(bond(1),bond(2)) = 0 + Anew(bond(2),bond(1)) = 0 + call setup_fragments(V,Anew,frag) + end if + else + needs_capping = .false. + end if + + !> the logic here is: the fragment containing atom "bond(1)" + !> will be base, and includes everything except the fragment + !> containing atom "bond(2)"; even further fragments containing neither + fbase = frag(bond(1)) + fside = frag(bond(2)) + + nbase = 0 + nside = 0 + do ii = 1,input%nat + if (frag(ii) == fside) then + nside = nside+1 + else + nbase = nbase+1 + end if + end do + + !> capping off the cut bond (with H or smthg else) + if (needs_capping) then + nside = nside+1 + nbase = nbase+1 + end if + + !> construct output mols + base%nat = nbase + allocate (base%at(nbase),source=0) + allocate (base%xyz(3,nbase),source=0.0_wp) + side%nat = nside + allocate (side%at(nside),source=0) + allocate (side%xyz(3,nside),source=0.0_wp) + + jj = 0 + kk = 0 + do ii = 1,input%nat + if (frag(ii) == fside) then + jj = jj+1 + side%at(jj) = input%at(ii) + side%xyz(1:3,jj) = input%xyz(1:3,ii) + else + kk = kk+1 + base%at(kk) = input%at(ii) + base%xyz(1:3,kk) = input%xyz(1:3,ii) + end if + end do + + if (needs_capping) then + jj = jj+1 + side%at(jj) = 1 !> hydrogen + side%xyz(1:3,jj) = input%xyz(1:3,bond(1)) + distcap = (rcov(1)+rcov(input%at(bond(2))))*(3.0_wp/4.0_wp) + call place_at_distance(input%xyz(1:3,bond(2)),side%xyz(1:3,jj),distcap) + kk = kk+1 + base%at(kk) = 1 !> hydrogen + base%xyz(1:3,kk) = input%xyz(1:3,bond(2)) + distcap = (rcov(1)+rcov(input%at(bond(1))))*(3.0_wp/4.0_wp) + call place_at_distance(input%xyz(1:3,bond(1)),base%xyz(1:3,kk),distcap) + end if + + if (allocated(Anew)) deallocate (Anew) + if (allocated(frag)) deallocate (frag) + end subroutine split_onbond + +!==============================================================================! + subroutine split_onshared(input,sharedlist,structures,sharedmap,wbo) + implicit none + !> IN/OUTPUTS + type(coord),intent(in) :: input + integer,intent(in) :: sharedlist(:) + type(coord),intent(out),allocatable :: structures(:) + integer,intent(out),allocatable :: sharedmap(:,:) + !> OPTIONAL + real(wp),intent(in),optional :: wbo(input%nat,input%nat) + !> LOCAL + type(coord) :: shared + real(wp),allocatable :: cn(:),wbofake(:,:) + integer :: V,fbase,fside,nshared,ftmp + integer,allocatable :: A(:,:),Anew(:,:) + integer,allocatable :: frag(:),fragnew(:),molassign(:) + logical,allocatable :: in_ring(:,:) + integer,allocatable :: path_tmp(:) + integer,allocatable :: number_of_neighbours(:) + logical,allocatable :: terminal_atom(:) + logical,allocatable :: connected_to_share(:) + logical,allocatable :: assign_to_mols(:,:) + logical,allocatable :: unassigned_fragments(:) + logical,allocatable :: capping_mapping(:,:) + integer :: npath,nbase,nside,nfrag,nfragnew + logical :: needs_capping + real(wp) :: distcap + integer :: ii,jj,jjj,kk,sii,M,mm,nn,ll + + integer :: bond(2) + + character(len=*),parameter :: source = "split_onshared()" + + !> we will be working with graphs. define number of vertices = #atoms + V = input%nat + !> how many atoms are shared + nshared = size(sharedlist,1) + + !> checks + if (any(sharedlist(:) > input%nat).or.(nshared < 1)) then + + error stop source//": sharedlist() has invalid atom specification" + end if + + !> set up adjacency matrix + if (present(wbo)) then + call wbo2adjacency(V,wbo,A,0.01_wp) + else + call input%cn_to_bond(cn,wbofake) + call wbo2adjacency(V,wbofake,A,0.01_wp) + deallocate (wbofake,cn) + end if + +!> ---------------------------------------------------------------------------- +!> BOOKKEEPING START +!> ---------------------------------------------------------------------------- + !> get fragment array (indicates which atom is on which fragment) + call setup_fragments(V,A,frag) + + !> some other mappings + allocate (number_of_neighbours(V),source=0) + do ii = 1,V + number_of_neighbours(ii) = sum(A(:,ii)) + end do + allocate (terminal_atom(V),source=.false.) + do ii = 1,V + terminal_atom(ii) = (number_of_neighbours(ii) == 1) + end do + + !> The cutting logic starts here. + !> First, we need to identify all atoms actually sharing fragments with the shared atoms + allocate (connected_to_share(V),source=.false.) + do ii = 1,V + ftmp = frag(ii) + do jj = 1,nshared + if (ftmp == frag(sharedlist(jj))) then + connected_to_share(ii) = .true. + exit + end if + end do + end do + !> all atoms NOT part of that list will be present in both output fragments + + !> Then, we take the graph and construct a new one with detachted "shared" atoms + allocate (Anew(V,V),source=A) + do ii = 1,nshared + sii = sharedlist(ii) + do jj = 1,V + if (jj == sii) cycle + if ((A(jj,sii) == 1).and. & !> look at existing bonds to shared section + & .not.any(sharedlist(:) == jj).and. & !> exctept to other shared section atoms + & .not.terminal_atom(jj)) then !> and except terminal atoms (directly bound to shared section) + Anew(jj,sii) = 0 + Anew(sii,jj) = 0 + end if + end do + end do + !> get new fragments + call setup_fragments(V,Anew,fragnew) + !> due to the cutting we should have at least two more fragments in total, compared to before. + !> for now we only handle exactly that +2 fragment case + nfrag = maxval(frag) + nfragnew = maxval(fragnew) + M = 0 + if (nfragnew < (nfrag+2)) then + error stop source//": system fragmentation yields currently unhandled edge-case" + else + M = nfragnew-nfrag + !> now we can check asignment to new, split-up fragments + !> we distinguish between the shared secion (:,1), and all M others (:,2:M) + allocate (assign_to_mols(V,M+1),source=.false.) + allocate (unassigned_fragments(nfragnew),source=.true.) + !> first, get the separated shared-region + mm = M+1 + do ii = 1,nshared + sii = fragnew(sharedlist(ii)) + unassigned_fragments(sii) = .false. + do jj = 1,V + if (fragnew(jj) == sii) then + assign_to_mols(jj,1:mm) = .true. + end if + end do + end do + !> then, all atoms that had no connection to the shared region + !> and hence are present everywhere (except the shard region) + do ii = 1,V + if (.not.connected_to_share(ii)) then + sii = fragnew(ii) + unassigned_fragments(sii) = .false. + do jj = 1,V + if (fragnew(jj) == sii) then + assign_to_mols(jj,2:mm) = .true. + end if + end do + end if + end do + + !!> exactly M fragments should be remaining + if (count(unassigned_fragments) .ne. M) then + error stop source//": wrong number of unassigned_fragments" + end if + mm = 1 + do ii = 1,V + if (all(assign_to_mols(ii,:).eqv..false.)) then + mm = mm+1 !> molecule new assignment number (except mm=1 because that is the shared region) + sii = fragnew(ii) !> the reference fragment + do jj = 1,V + if (fragnew(jj) .eq. sii) assign_to_mols(jj,mm) = .true. + end do + end if + end do + end if + + !> prepare capping. + !> Entries will be .true. for atoms that need to be added to fragment + allocate (capping_mapping(V,M),source=.false.) + do ii = 1,M + mm = ii+1 + do jj = 1,nshared + do kk = 1,V + if (A(kk,sharedlist(jj)) == 1.and..not.assign_to_mols(kk,mm)) then + capping_mapping(kk,ii) = .true. + end if + end do + end do + end do + +!> ---------------------------------------------------------------------------- +!> BOOKKEEPING END +!> ---------------------------------------------------------------------------- +!> MOLECULE CONSTRUCTION START +!> ---------------------------------------------------------------------------- + + allocate (structures(M)) !> we know that splitting produces M fragment + allocate (sharedmap(nshared,M),source=0) + do ii = 1,M + mm = ii+1 + !> count atoms, allocate + nn = count(assign_to_mols(:,mm),1)+count(capping_mapping(:,ii),1) + structures(ii)%nat = nn + allocate (structures(ii)%at(nn),source=2) + allocate (structures(ii)%xyz(3,nn),source=0.0_wp) + kk = 0 + jjj = 0 + !> directly assigned atoms + do jj = 1,V + if (assign_to_mols(jj,mm)) then + kk = kk+1 + structures(ii)%at(kk) = input%at(jj) + structures(ii)%xyz(1:3,kk) = input%xyz(1:3,jj) + if (any(sharedlist(:) == jj)) then + jjj = jjj+1 + sharedmap(jjj,ii) = jj + end if + end if + end do + !> capping atoms + do jj = 1,V + if (capping_mapping(jj,ii)) then + kk = kk+1 + structures(ii)%at(kk) = 1 !input%at(jj) + structures(ii)%xyz(1:3,kk) = input%xyz(1:3,jj) + !> repair distance for capping atoms + do ll = 1,V + if ((A(ll,jj) == 1).and.assign_to_mols(ll,mm)) then + distcap = (rcov(1)+rcov(input%at(ll)))*(3.0_wp/4.0_wp) + call place_at_distance(input%xyz(1:3,ll),structures(ii)%xyz(1:3,kk),distcap) + end if + end do + end if + end do + end do + +!> ---------------------------------------------------------------------------- +!> MOLECULE CONSTRUCTION END +!> ---------------------------------------------------------------------------- + + if (allocated(number_of_neighbours)) deallocate (number_of_neighbours) + if (allocated(terminal_atom)) deallocate (terminal_atom) + if (allocated(connected_to_share)) deallocate (connected_to_share) + if (allocated(Anew)) deallocate (Anew) + if (allocated(frag)) deallocate (frag) + end subroutine split_onshared + +!=============================================================================! + pure subroutine place_at_distance(ref,moving,dist,tol,ierr) + implicit none + real(wp),intent(in) :: ref(3) + real(wp),intent(inout) :: moving(3) + real(wp),intent(in) :: dist + real(wp),intent(in),optional :: tol + integer,intent(out),optional :: ierr + + real(wp) :: v(3),r,t + real(wp),parameter :: default_tol = 1.0d-12 + + t = default_tol + if (present(tol)) t = tol + + v = moving-ref + r = sqrt(dot_product(v,v)) + + if (present(ierr)) ierr = 0 + if (r <= t) then + !> Direction is undefined (moving ~= ref), so we cannot keep the axis. + if (present(ierr)) ierr = 1 + return + end if + + moving = ref+(dist/r)*v + end subroutine place_at_distance + +!==============================================================================! + + subroutine methylize_from_methane(x,n,h_new,h_aligned,r_ch,ok) + use geo + implicit none + real(wp),intent(in) :: x(3),n(3) + real(wp),intent(out) :: h_new(3,3) + real(wp),intent(out),optional :: h_aligned(3) + real(wp),intent(in),optional :: r_ch + logical,intent(out),optional :: ok + + real(wp) :: rch,invs3,pi + real(wp) :: Htmpl(3,4) + real(wp) :: dir(3),a(3),axis(3),tmp(3) + real(wp) :: angle,d + integer :: k + real(wp),parameter :: eps = 1.0e-12_wp + logical :: success + + pi = acos(-1.0_wp) + + rch = 1.09_wp*aatoau + if (present(r_ch)) rch = r_ch + + !>--- methane proxy (C at origin), perfect tetrahedral directions + invs3 = 1.0_wp/sqrt(3.0_wp) + Htmpl(:,1) = rch*(/1.0_wp,1.0_wp,1.0_wp/)*invs3 + Htmpl(:,2) = rch*(/1.0_wp,-1.0_wp,-1.0_wp/)*invs3 + Htmpl(:,3) = rch*(/-1.0_wp,1.0_wp,-1.0_wp/)*invs3 + Htmpl(:,4) = rch*(/-1.0_wp,-1.0_wp,1.0_wp/)*invs3 + + !>--- desired direction: outward from x away from neighbor n + dir = x-n + if (vec_len(dir) < eps) then + h_new = 0.0_wp + if (present(h_aligned)) h_aligned = 0.0_wp + if (present(ok)) ok = .false. + return + end if + call unitv(dir) + + !>--- template direction: use H1 bond direction (unit) + a = Htmpl(:,1) + call unitv(a) + + !>--- compute rotation: rotate a + call crosp(a,dir,axis) + d = dotp(a,dir,3) + + if (vec_len(axis) < eps) then + !> a parallel or anti-parallel to dir + if (d > 0.0_wp) then + angle = 0.0_wp + axis = (/1.0_wp,0.0_wp,0.0_wp/) ! dummy axis (unused) + else + !> 180° rotation: choose any axis perpendicular to a + tmp = (/1.0_wp,0.0_wp,0.0_wp/) + if (abs(dotp(a,tmp,3)) > 0.9_wp) tmp = (/0.0_wp,1.0_wp,0.0_wp/) + call crosp(a,tmp,axis) + call unitv(axis) + angle = pi + end if + else + call unitv(axis) + angle = tangle(a,dir) !> radians, [0..pi] + end if + + !> --- rotate & translate: H = x + R * Htmpl + !> Return the other three (2..4) as "new" + do k = 2,4 + tmp = Htmpl(:,k) + if (abs(angle) > 0.0_wp) call rodrot(tmp,axis,angle) + h_new(:,k-1) = x+tmp + end do + + if (present(h_aligned)) then + tmp = Htmpl(:,1) + if (abs(angle) > 0.0_wp) call rodrot(tmp,axis,angle) + h_aligned = x+tmp + end if + + success = .true. + if (present(ok)) ok = success + end subroutine methylize_from_methane + +!=============================================================================! +!#############################################################################! +!=============================================================================! +end module construct_mod + diff --git a/src/rigidconf/meson.build b/src/molbuilder/meson.build similarity index 97% rename from src/rigidconf/meson.build rename to src/molbuilder/meson.build index 22aebeda..9fd75381 100644 --- a/src/rigidconf/meson.build +++ b/src/molbuilder/meson.build @@ -19,4 +19,5 @@ srcs += files( 'tree.f90', 'analyze.f90', 'reconstruct.f90', + 'construct.f90', ) diff --git a/src/rigidconf/reconstruct.f90 b/src/molbuilder/reconstruct.f90 similarity index 100% rename from src/rigidconf/reconstruct.f90 rename to src/molbuilder/reconstruct.f90 diff --git a/src/rigidconf/rigidconf.f90 b/src/molbuilder/rigidconf.f90 similarity index 100% rename from src/rigidconf/rigidconf.f90 rename to src/molbuilder/rigidconf.f90 diff --git a/src/rigidconf/tree.f90 b/src/molbuilder/tree.f90 similarity index 100% rename from src/rigidconf/tree.f90 rename to src/molbuilder/tree.f90 diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index 41d05bf5..3e07e896 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -14,7 +14,7 @@ module irmsd_module public :: rmsd public :: min_rmsd - public :: checkranks,fallbackranks + public :: checkranks,fallbackranks,molatomsort real(wp),parameter :: bigval = huge(bigval) diff --git a/src/strucreader.f90 b/src/strucreader.f90 index ee88c821..76628d63 100644 --- a/src/strucreader.f90 +++ b/src/strucreader.f90 @@ -1533,6 +1533,7 @@ function coord_getcutout(self,atlist) result(molout) if (newnat == self%nat) then molout = self else + molout%nat = newnat allocate (molout%at(newnat),source=0) allocate (molout%xyz(3,newnat),source=0.0_wp) k = 0 From 2c5b257b431b5d79322ca5c307446cc7c730fc93 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 20 Dec 2025 00:36:31 +0100 Subject: [PATCH 119/374] methyl capping --- src/algos/playground.f90 | 7 +++- src/molbuilder/construct.f90 | 66 ++++++++++++++++++++++++++++++------ 2 files changed, 62 insertions(+), 11 deletions(-) diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index 5501b9ae..74e8bbee 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -78,7 +78,7 @@ subroutine crest_playground(env,tim) !========================================================================================! block use construct_mod - type(coord) :: base,side,new + type(coord) :: base,side,new,newnew type(coord),allocatable :: splitlist(:) integer,allocatable :: alignmap(:,:) @@ -104,9 +104,14 @@ subroutine crest_playground(env,tim) do i=1,size(splitlist,1) call splitlist(i)%append(ich) enddo + + call attach(splitlist(1), splitlist(2), alignmap,newnew) + + call newnew%append(ich) !call base%append(ich) !call side%append(ich) close (ich) + end block !========================================================================================! diff --git a/src/molbuilder/construct.f90 b/src/molbuilder/construct.f90 index 04044291..117a2426 100644 --- a/src/molbuilder/construct.f90 +++ b/src/molbuilder/construct.f90 @@ -341,6 +341,7 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,wbo) integer,intent(out),allocatable :: sharedmap(:,:) !> OPTIONAL real(wp),intent(in),optional :: wbo(input%nat,input%nat) + integer,allocatable :: ncapped(:) !> LOCAL type(coord) :: shared real(wp),allocatable :: cn(:),wbofake(:,:) @@ -355,10 +356,10 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,wbo) logical,allocatable :: assign_to_mols(:,:) logical,allocatable :: unassigned_fragments(:) logical,allocatable :: capping_mapping(:,:) - integer :: npath,nbase,nside,nfrag,nfragnew - logical :: needs_capping - real(wp) :: distcap - integer :: ii,jj,jjj,kk,sii,M,mm,nn,ll + logical,allocatable :: methylizemapping(:,:) + integer :: npath,nfrag,nfragnew,nbonds + real(wp) :: distcap,methylproxy(3,3) + integer :: ii,jj,jjj,kk,sii,sjj,M,mm,nn,ll,lll integer :: bond(2) @@ -485,11 +486,31 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,wbo) end if !> prepare capping. - !> Entries will be .true. for atoms that need to be added to fragment allocate (capping_mapping(V,M),source=.false.) + allocate (methylizemapping(nshared,M),source=.false.) + !> First, simple, chemoinformatic rules do ii = 1,M mm = ii+1 do jj = 1,nshared + nbonds = 0 + kk = sharedlist(jj) + do ll = 1,V + if ((A(ll,kk) == 1).and.assign_to_mols(ll,mm)) then + nbonds = nbonds+1 + end if + end do + if (nbonds == 1.and.input%at(kk) == 6) then + methylizemapping(jj,ii) = .true. + end if + end do + end do + !> then "regular" capping, we determine original atoms as proxy for + !> the cap (and later adjust the bondlength) + !> Entries will be .true. for atoms that need to be added to fragment + do ii = 1,M + mm = ii+1 + do jj = 1,nshared + if (methylizemapping(jj,ii)) cycle do kk = 1,V if (A(kk,sharedlist(jj)) == 1.and..not.assign_to_mols(kk,mm)) then capping_mapping(kk,ii) = .true. @@ -506,10 +527,14 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,wbo) allocate (structures(M)) !> we know that splitting produces M fragment allocate (sharedmap(nshared,M),source=0) + allocate (ncapped(M),source=0) + do ii = 1,M mm = ii+1 !> count atoms, allocate - nn = count(assign_to_mols(:,mm),1)+count(capping_mapping(:,ii),1) + nn = count(assign_to_mols(:,mm),1)+ & + & count(capping_mapping(:,ii),1)+ & + & count(methylizemapping(:,ii),1)*3 structures(ii)%nat = nn allocate (structures(ii)%at(nn),source=2) allocate (structures(ii)%xyz(3,nn),source=0.0_wp) @@ -523,7 +548,7 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,wbo) structures(ii)%xyz(1:3,kk) = input%xyz(1:3,jj) if (any(sharedlist(:) == jj)) then jjj = jjj+1 - sharedmap(jjj,ii) = jj + sharedmap(jjj,ii) = kk end if end if end do @@ -531,6 +556,7 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,wbo) do jj = 1,V if (capping_mapping(jj,ii)) then kk = kk+1 + ncapped(ii) = ncapped(ii)+1 structures(ii)%at(kk) = 1 !input%at(jj) structures(ii)%xyz(1:3,kk) = input%xyz(1:3,jj) !> repair distance for capping atoms @@ -542,12 +568,32 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,wbo) end do end if end do + !> methylation atoms + do jj = 1,nshared + if (methylizemapping(jj,ii)) then + sjj = sharedlist(jj) + do ll = 1,V + if (A(ll,sjj) == 1 .and.assign_to_mols(ll,mm)) then + call methylize(input%xyz(1:3,sjj),input%xyz(1:3,ll),methylproxy) + do lll=1,3 + kk=kk+1 + structures(ii)%at(kk) = 1 + structures(ii)%xyz(1:3,kk) = methylproxy(1:3,lll) + enddo + exit + end if + end do + end if + end do end do !> ---------------------------------------------------------------------------- !> MOLECULE CONSTRUCTION END !> ---------------------------------------------------------------------------- + if (allocated(assign_to_mols)) deallocate (assign_to_mols) + if (allocated(capping_mapping)) deallocate (capping_mapping) + if (allocated(unassigned_fragments)) deallocate (unassigned_fragments) if (allocated(number_of_neighbours)) deallocate (number_of_neighbours) if (allocated(terminal_atom)) deallocate (terminal_atom) if (allocated(connected_to_share)) deallocate (connected_to_share) @@ -585,7 +631,7 @@ end subroutine place_at_distance !==============================================================================! - subroutine methylize_from_methane(x,n,h_new,h_aligned,r_ch,ok) + subroutine methylize(x,n,h_new,h_aligned,r_ch,ok) use geo implicit none real(wp),intent(in) :: x(3),n(3) @@ -615,7 +661,7 @@ subroutine methylize_from_methane(x,n,h_new,h_aligned,r_ch,ok) Htmpl(:,4) = rch*(/-1.0_wp,-1.0_wp,1.0_wp/)*invs3 !>--- desired direction: outward from x away from neighbor n - dir = x-n + dir = n-x if (vec_len(dir) < eps) then h_new = 0.0_wp if (present(h_aligned)) h_aligned = 0.0_wp @@ -666,7 +712,7 @@ subroutine methylize_from_methane(x,n,h_new,h_aligned,r_ch,ok) success = .true. if (present(ok)) ok = success - end subroutine methylize_from_methane + end subroutine methylize !=============================================================================! !#############################################################################! From 502ea5eea64c5488b169c1f5e2e9f738dac0ce86 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 4 Jan 2026 16:38:09 +0100 Subject: [PATCH 120/374] additional optional args in split routine --- src/algos/playground.f90 | 7 +++--- src/molbuilder/construct.f90 | 46 +++++++++++++++++++++++++++++------- 2 files changed, 42 insertions(+), 11 deletions(-) diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index 74e8bbee..74d77430 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -80,7 +80,7 @@ subroutine crest_playground(env,tim) use construct_mod type(coord) :: base,side,new,newnew type(coord),allocatable :: splitlist(:) - integer,allocatable :: alignmap(:,:) + integer,allocatable :: alignmap(:,:),ncap(:) !call base%open("base.xyz") !call side%open("side.xyz") @@ -99,13 +99,14 @@ subroutine crest_playground(env,tim) call new%open("struc.xyz") !call split(new, [8,9],base,side) - call split(new, [6,7,8],splitlist,alignmap) + call split(new, [6,7,8],splitlist,alignmap,ncap=ncap) + write(*,*) ncap do i=1,size(splitlist,1) call splitlist(i)%append(ich) enddo - call attach(splitlist(1), splitlist(2), alignmap,newnew) + call attach(splitlist(1), splitlist(2), alignmap,newnew,remove_lastx=ncap) call newnew%append(ich) !call base%append(ich) diff --git a/src/molbuilder/construct.f90 b/src/molbuilder/construct.f90 index 117a2426..c07020f4 100644 --- a/src/molbuilder/construct.f90 +++ b/src/molbuilder/construct.f90 @@ -23,7 +23,8 @@ module construct_mod contains !> MODULE PROCEDURES START HERE !=============================================================================! - subroutine attach(base,side,alignmap,new,clash,remove_base,remove_side) + subroutine attach(base,side,alignmap,new,clash, & + & remove_base,remove_side,remove_lastx) !*********************************************************************** !* This routine attaches a side-molecule to a base-molecule !* The assumption is that we have (at least) 3 proxy atoms @@ -41,6 +42,8 @@ subroutine attach(base,side,alignmap,new,clash,remove_base,remove_side) !* constructing the new mol !* remove_side - list of atoms to remove from side upon !* constructing the new mol + !* remove_lastx - integer (one for base and side) to remove + !* final x atoms in constructing new mol !*********************************************************************** implicit none !> IN/OUTPUTS @@ -52,6 +55,7 @@ subroutine attach(base,side,alignmap,new,clash,remove_base,remove_side) logical,intent(out),optional :: clash integer,intent(in),optional :: remove_base(:) integer,intent(in),optional :: remove_side(:) + integer,intent(in),optional :: remove_lastx(:) !> LOCAL type(coord) :: cutout_base,cutout_side,side_tmp @@ -165,6 +169,14 @@ subroutine attach(base,side,alignmap,new,clash,remove_base,remove_side) cutlist_side(remove_side(ii)) = .true. end do end if + if (present(remove_lastx)) then + do ii = base%nat-(remove_lastx(1)-1),base%nat + cutlist_base(ii) = .true. + end do + do ii = side%nat-(remove_lastx(2)-1),side%nat + cutlist_side(ii) = .true. + end do + end if new%nat = 0 do ii = 1,base%nat @@ -332,7 +344,8 @@ subroutine split_onbond(input,bond,base,side,wbo) end subroutine split_onbond !==============================================================================! - subroutine split_onshared(input,sharedlist,structures,sharedmap,wbo) + subroutine split_onshared(input,sharedlist,structures,sharedmap,& + & wbo,ncap,position_mapping) implicit none !> IN/OUTPUTS type(coord),intent(in) :: input @@ -341,13 +354,16 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,wbo) integer,intent(out),allocatable :: sharedmap(:,:) !> OPTIONAL real(wp),intent(in),optional :: wbo(input%nat,input%nat) - integer,allocatable :: ncapped(:) + integer,intent(out),allocatable,optional :: ncap(:) + integer,intent(out),allocatable,optional :: position_mapping(:,:) !> LOCAL type(coord) :: shared real(wp),allocatable :: cn(:),wbofake(:,:) integer :: V,fbase,fside,nshared,ftmp integer,allocatable :: A(:,:),Anew(:,:) integer,allocatable :: frag(:),fragnew(:),molassign(:) + integer,allocatable :: ncapped(:) + integer,allocatable :: pos_map(:,:) logical,allocatable :: in_ring(:,:) integer,allocatable :: path_tmp(:) integer,allocatable :: number_of_neighbours(:) @@ -357,6 +373,7 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,wbo) logical,allocatable :: unassigned_fragments(:) logical,allocatable :: capping_mapping(:,:) logical,allocatable :: methylizemapping(:,:) + integer :: npath,nfrag,nfragnew,nbonds real(wp) :: distcap,methylproxy(3,3) integer :: ii,jj,jjj,kk,sii,sjj,M,mm,nn,ll,lll @@ -485,7 +502,7 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,wbo) end do end if - !> prepare capping. + !> prepare mapping and capping. allocate (capping_mapping(V,M),source=.false.) allocate (methylizemapping(nshared,M),source=.false.) !> First, simple, chemoinformatic rules @@ -528,6 +545,7 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,wbo) allocate (structures(M)) !> we know that splitting produces M fragment allocate (sharedmap(nshared,M),source=0) allocate (ncapped(M),source=0) + allocate (pos_map(V,M), source=0) do ii = 1,M mm = ii+1 @@ -550,6 +568,7 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,wbo) jjj = jjj+1 sharedmap(jjj,ii) = kk end if + pos_map(jj,ii) = kk end if end do !> capping atoms @@ -573,13 +592,14 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,wbo) if (methylizemapping(jj,ii)) then sjj = sharedlist(jj) do ll = 1,V - if (A(ll,sjj) == 1 .and.assign_to_mols(ll,mm)) then + if (A(ll,sjj) == 1.and.assign_to_mols(ll,mm)) then call methylize(input%xyz(1:3,sjj),input%xyz(1:3,ll),methylproxy) - do lll=1,3 - kk=kk+1 + do lll = 1,3 + kk = kk+1 + ncapped(ii) = ncapped(ii)+1 structures(ii)%at(kk) = 1 structures(ii)%xyz(1:3,kk) = methylproxy(1:3,lll) - enddo + end do exit end if end do @@ -591,6 +611,16 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,wbo) !> MOLECULE CONSTRUCTION END !> ---------------------------------------------------------------------------- + if (present(ncap)) then + call move_alloc(ncapped,ncap) + end if + + if(present(position_mapping))then + call move_alloc(pos_map,position_mapping) + endif + + if (allocated(pos_map)) deallocate(pos_map) + if (allocated(ncapped)) deallocate (ncapped) if (allocated(assign_to_mols)) deallocate (assign_to_mols) if (allocated(capping_mapping)) deallocate (capping_mapping) if (allocated(unassigned_fragments)) deallocate (unassigned_fragments) From 8cbbde9f3438524994b92bfba09af92e3c6acbee Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 4 Jan 2026 20:01:28 +0100 Subject: [PATCH 121/374] Add atom order restoring in attach routine --- src/algos/playground.f90 | 10 +++--- src/molbuilder/CMakeLists.txt | 1 + src/molbuilder/construct.f90 | 59 ++++++++++++++++++++++++++++------- src/molbuilder/meson.build | 1 + 4 files changed, 55 insertions(+), 16 deletions(-) diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index 74d77430..2f76ecc2 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -80,7 +80,7 @@ subroutine crest_playground(env,tim) use construct_mod type(coord) :: base,side,new,newnew type(coord),allocatable :: splitlist(:) - integer,allocatable :: alignmap(:,:),ncap(:) + integer,allocatable :: alignmap(:,:),ncap(:),position_mapping(:,:) !call base%open("base.xyz") !call side%open("side.xyz") @@ -99,14 +99,16 @@ subroutine crest_playground(env,tim) call new%open("struc.xyz") !call split(new, [8,9],base,side) - call split(new, [6,7,8],splitlist,alignmap,ncap=ncap) + call split(new, [6,7,8],splitlist,alignmap,ncap=ncap,position_mapping=position_mapping) - write(*,*) ncap + !write(*,*) position_mapping(:,1) + !write(*,*) position_mapping(:,2) do i=1,size(splitlist,1) call splitlist(i)%append(ich) enddo - call attach(splitlist(1), splitlist(2), alignmap,newnew,remove_lastx=ncap) + call attach(splitlist(1), splitlist(2), alignmap,newnew, & + & remove_lastx=ncap,original_map=position_mapping) call newnew%append(ich) !call base%append(ich) diff --git a/src/molbuilder/CMakeLists.txt b/src/molbuilder/CMakeLists.txt index abbeada4..fe21c9b6 100644 --- a/src/molbuilder/CMakeLists.txt +++ b/src/molbuilder/CMakeLists.txt @@ -22,6 +22,7 @@ list(APPEND srcs "${dir}/analyze.f90" "${dir}/reconstruct.f90" "${dir}/construct.f90" + "${dir}/construct_list.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/molbuilder/construct.f90 b/src/molbuilder/construct.f90 index c07020f4..3e7c4cf0 100644 --- a/src/molbuilder/construct.f90 +++ b/src/molbuilder/construct.f90 @@ -24,7 +24,7 @@ module construct_mod !=============================================================================! subroutine attach(base,side,alignmap,new,clash, & - & remove_base,remove_side,remove_lastx) + & original_map,remove_base,remove_side,remove_lastx) !*********************************************************************** !* This routine attaches a side-molecule to a base-molecule !* The assumption is that we have (at least) 3 proxy atoms @@ -38,6 +38,7 @@ subroutine attach(base,side,alignmap,new,clash, & !* !* Optionl args: !* clash - logical, were clashes produced? + !* original_map - original atom position mapping !* remove_base - list of atoms to remove from base upon !* constructing the new mol !* remove_side - list of atoms to remove from side upon @@ -53,6 +54,7 @@ subroutine attach(base,side,alignmap,new,clash, & type(coord),intent(out) :: new logical,intent(out),optional :: clash + integer,intent(in),optional :: original_map(:,:) integer,intent(in),optional :: remove_base(:) integer,intent(in),optional :: remove_side(:) integer,intent(in),optional :: remove_lastx(:) @@ -61,6 +63,7 @@ subroutine attach(base,side,alignmap,new,clash, & type(coord) :: cutout_base,cutout_side,side_tmp logical,allocatable :: cutlist_base(:),cutlist_side(:) integer,allocatable :: current_order(:),target_order(:),idx(:) + integer,allocatable :: revorder_base(:),revorder_side(:) real(wp) :: rms,Umat(3,3),shift(3),center_base(3),center_side(3) integer :: nalign,nat_new @@ -170,6 +173,7 @@ subroutine attach(base,side,alignmap,new,clash, & end do end if if (present(remove_lastx)) then + !> useful for not transfering appended capping atoms do ii = base%nat-(remove_lastx(1)-1),base%nat cutlist_base(ii) = .true. end do @@ -177,27 +181,58 @@ subroutine attach(base,side,alignmap,new,clash, & cutlist_side(ii) = .true. end do end if - + allocate (revorder_base(base%nat),source=0) + allocate (revorder_side(side%nat),source=0) + if (present(original_map)) then + !> if we have info on the original order, avoid all atoms + !> present in all fragments + do ii = 1,size(original_map,1) + if (all(original_map(ii,:) .ne. 0)) then + cutlist_side(original_map(ii,2)) = .true. + end if + if (original_map(ii,1) .ne. 0) then + revorder_base(original_map(ii,1)) = ii + end if + if (original_map(ii,2) .ne. 0) then + revorder_side(original_map(ii,2)) = ii + end if + end do + end if + kk = max(maxval(revorder_base),maxval(revorder_side)) new%nat = 0 do ii = 1,base%nat - if (.not.cutlist_base(ii)) new%nat = new%nat+1 + if (.not.cutlist_base(ii)) then + new%nat = new%nat+1 + if (revorder_base(ii) .eq. 0) then + kk = kk+1 + revorder_base(ii) = kk + end if + end if end do do ii = 1,side%nat - if (.not.cutlist_side(ii)) new%nat = new%nat+1 + if (.not.cutlist_side(ii)) then + new%nat = new%nat+1 + if(revorder_side(ii).eq.0)then + kk=kk+1 + revorder_side(ii) = kk + endif + end if end do allocate (new%at(new%nat),source=0) allocate (new%xyz(3,new%nat),source=0.0_wp) - kk = 0 + !kk = 0 do ii = 1,base%nat if (.not.cutlist_base(ii)) then - kk = kk+1 + !kk = kk+1 + kk = revorder_base(ii) new%at(kk) = base%at(ii) new%xyz(1:3,kk) = base%xyz(1:3,ii) end if end do do ii = 1,side%nat if (.not.cutlist_side(ii)) then - kk = kk+1 + !kk = kk+1 + kk = revorder_side(ii) new%at(kk) = side_tmp%at(ii) new%xyz(1:3,kk) = side_tmp%xyz(1:3,ii) end if @@ -545,7 +580,7 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,& allocate (structures(M)) !> we know that splitting produces M fragment allocate (sharedmap(nshared,M),source=0) allocate (ncapped(M),source=0) - allocate (pos_map(V,M), source=0) + allocate (pos_map(V,M),source=0) do ii = 1,M mm = ii+1 @@ -568,7 +603,7 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,& jjj = jjj+1 sharedmap(jjj,ii) = kk end if - pos_map(jj,ii) = kk + pos_map(jj,ii) = kk end if end do !> capping atoms @@ -615,11 +650,11 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,& call move_alloc(ncapped,ncap) end if - if(present(position_mapping))then + if (present(position_mapping)) then call move_alloc(pos_map,position_mapping) - endif + end if - if (allocated(pos_map)) deallocate(pos_map) + if (allocated(pos_map)) deallocate (pos_map) if (allocated(ncapped)) deallocate (ncapped) if (allocated(assign_to_mols)) deallocate (assign_to_mols) if (allocated(capping_mapping)) deallocate (capping_mapping) diff --git a/src/molbuilder/meson.build b/src/molbuilder/meson.build index 9fd75381..52d0f0f5 100644 --- a/src/molbuilder/meson.build +++ b/src/molbuilder/meson.build @@ -20,4 +20,5 @@ srcs += files( 'analyze.f90', 'reconstruct.f90', 'construct.f90', + 'construct_list.f90', ) From 4c0ee5caf87ea90f1fee612ee4df1499fd053726 Mon Sep 17 00:00:00 2001 From: "lukas.rindt" Date: Mon, 5 Jan 2026 13:11:50 +0100 Subject: [PATCH 122/374] pre benchmarking version --- src/algos/numhess.f90 | 2 +- src/calculator/calc_type.f90 | 7 ++++--- src/calculator/calculator.F90 | 2 +- src/optimize/ancopt.f90 | 18 +++++++++------- src/optimize/optimize_module.f90 | 36 ++++++++++++++++++-------------- src/optimize/rfo.f90 | 9 +------- src/parsing/parse_calcdata.f90 | 5 ++++- 7 files changed, 42 insertions(+), 37 deletions(-) diff --git a/src/algos/numhess.f90 b/src/algos/numhess.f90 index 0562ea43..0b722dfd 100644 --- a/src/algos/numhess.f90 +++ b/src/algos/numhess.f90 @@ -310,7 +310,7 @@ subroutine numhess_thermostat(env,mol,nat3,hess,freq,etot) !> calcthermo wants input in Bohr call calcthermo(mol%nat,mol%at,mol%xyz,freq,.true., & - & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,iunit) + & ithr,fscal,sthr,nt,temps,et,ht,gt,stot) !> THIS HAS IUNIT IN IT!!!! !> printoutgeometr zpve = et(nrt)-ht(nrt) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 01fdcddc..3683e1f8 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -272,9 +272,10 @@ module calc_type !>--- Hessian Reconstructor type(cashed_hessian),allocatable :: chess - logical :: do_HU = .false. - integer :: hu_steps = 10 - integer :: nt + logical :: do_HR = .false. + logical :: full_HR = .false. !> Keyword for HR with all opt steps + integer :: hu_steps = 10 !> default number of update steps + integer :: nt !> following all required for thermochemistry real(wp),allocatable :: temperatures(:) real(wp),allocatable :: et(:),ht(:),gt(:),stot(:) real(wp) :: ithr,fscal,sthr diff --git a/src/calculator/calculator.F90 b/src/calculator/calculator.F90 index 2d5ff8c3..819a3f73 100644 --- a/src/calculator/calculator.F90 +++ b/src/calculator/calculator.F90 @@ -301,7 +301,7 @@ subroutine engrad_mol(mol,calc,energy,gradient,iostatus) !>--- Hessian Reconstruct !********************************************** - if (calc%do_HU .and. allocated(calc%chess)) then + if (calc%do_HR .and. allocated(calc%chess)) then call calc%chess%update(gradient,energy,mol%xyz) end if diff --git a/src/optimize/ancopt.f90 b/src/optimize/ancopt.f90 index 7496caef..776710e2 100644 --- a/src/optimize/ancopt.f90 +++ b/src/optimize/ancopt.f90 @@ -501,10 +501,10 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & end if !> Transform hessian to cartesian coordinate basis (still wrong) - if (calc%do_HU) then - call dhtosq(nat3,test_hess(:,:),OPT%hess(:)) - calc%chess%H(:,:) = matmul(matmul(Transpose(OPT%B(:,:)), test_hess(:,:)), OPT%B(:,:)) - end if + !if (calc%do_HR) then + ! call dhtosq(nat3,test_hess(:,:),OPT%hess(:)) + ! calc%chess%H(:,:) = matmul(matmul(Transpose(OPT%B(:,:)), test_hess(:,:)), OPT%B(:,:)) + !end if !>------------------------------------------------------------------------ !> rational function (RF) method @@ -649,9 +649,13 @@ function alp_generate(gnorm,calc) result(alp) real(wp) :: alp, shift, l, k if (calc%optlev == 1) then - L = 2 - k = 2000 - shift = 0.0005 + L = 2.0_wp + k = 2000.0_wp + shift = 0.0005_wp + else if (calc%optlev == 2) then + L = 1.0_wp + k = 8000.0_wp + shift = 0.0009_wp else L = calc%L k = calc%k diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index 203270fc..d161e50e 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -80,8 +80,8 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) !$omp end critical end if - !> Check if Hessian Reconstruct is called - if (calc%do_HU) then + !> Check if Hessian Reconstruct is called and initialize the type + if (calc%do_HR) then allocate (calc%chess) call calc%chess%alloc(mol%nat,calc%hu_steps,calc%hguess) end if @@ -109,25 +109,29 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) end select molnew%energy = etot - if (calc%do_HU) then !> Hessian construction and post-processing happen here + if (calc%do_HR) then !> Hessian construction and post-processing happen here + if (calc%full_HR) then - call calc%chess%construct_hessian_bfgs() + write (stdout,*) + write (stdout,*) "THERMO FROM BFGS" !> This is here for full hessian reconstruct + write (stdout,*) - write (stdout,*) - write (stdout,*) "THERMO FROM RECONSTRUCTED HESSIAN:" - write (stdout,*) + call calc_thermo_from_hess(molnew,calc%chess%H,pr, & + & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & + & calc%ht,calc%gt,calc%stot) - call calc_thermo_from_hess(molnew,calc%chess%B,pr, & - & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & - & calc%ht,calc%gt,calc%stot) + else - !print* - !print*,"THERMO FROM BFGS" - !print* + call calc%chess%construct_hessian_bfgs() - !call calc_thermo_from_hess(molnew,calc%chess%H,pr, & - !& calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & - !& calc%ht,calc%gt,calc%stot) + write (stdout,*) + write (stdout,*) "THERMO FROM RECONSTRUCTED HESSIAN:" + write (stdout,*) + + call calc_thermo_from_hess(molnew,calc%chess%B,pr, & + & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & + & calc%ht,calc%gt,calc%stot) + end if call calc%chess%dealloc() deallocate (calc%chess) diff --git a/src/optimize/rfo.f90 b/src/optimize/rfo.f90 index 1d6b1425..3f7bb3bb 100644 --- a/src/optimize/rfo.f90 +++ b/src/optimize/rfo.f90 @@ -348,16 +348,9 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) dx_test = displ*alpold !allocate(calc%chess%H(nat3,nat3)) - if (calc%do_HU) then + if (calc%full_HR) then call dhtosq(nat3,calc%chess%H(:,:),OPT%hess(:)) end if - - open(newunit=unit, file="opt_bfgs.txt", status="unknown", position="append") - write(unit,*) "cycle:", iter - do i = 1, 5 - write(unit,*) OPT%hess(i) - enddo - close(unit) !>------------------------------------------------------------------------ !> rational function (RF) method !>------------------------------------------------------------------------ diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 72e110cc..1119066a 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -609,7 +609,10 @@ subroutine parse_calc_auto(env,calc,kv,rd) calc%exact_rf = kv%value_b case ('chess') - calc%do_HU = kv%value_b + calc%do_HR = kv%value_b + + case ('full_chess') !> Do Hessian Reconstruct with all optimization steps + calc%full_HR = kv%value_b case default rd = .false. From 49d5302f2b8c77c51b9202eecd02b9caa4e2af85 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 5 Jan 2026 14:45:01 +0100 Subject: [PATCH 123/374] Basic split specification via toml file --- src/algos/playground.f90 | 23 +++++---- src/classes.f90 | 13 ++++- src/molbuilder/construct_list.f90 | 79 +++++++++++++++++++++++++++++++ src/parsing/parse_maindata.f90 | 10 +++- src/sorting/quicksort.f90 | 31 ++++++++++++ 5 files changed, 144 insertions(+), 12 deletions(-) create mode 100644 src/molbuilder/construct_list.f90 diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index 2f76ecc2..9f5a4213 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -96,25 +96,28 @@ subroutine crest_playground(env,tim) !call attach(base,side,alignmap,new) !call new%append(ich) - - call new%open("struc.xyz") + !call new%open("struc.xyz") + call env%ref%to(new) !call split(new, [8,9],base,side) - call split(new, [6,7,8],splitlist,alignmap,ncap=ncap,position_mapping=position_mapping) - + if (allocated(env%splitqueue)) then + call split(new,env%splitqueue(1)%atms,splitlist,alignmap,ncap=ncap,position_mapping=position_mapping) + else + call split(new,[1,2,3],splitlist,alignmap,ncap=ncap,position_mapping=position_mapping) + end if !write(*,*) position_mapping(:,1) !write(*,*) position_mapping(:,2) - do i=1,size(splitlist,1) + do i = 1,size(splitlist,1) call splitlist(i)%append(ich) - enddo + end do - call attach(splitlist(1), splitlist(2), alignmap,newnew, & + call attach(splitlist(1),splitlist(2),alignmap,newnew, & & remove_lastx=ncap,original_map=position_mapping) - + call newnew%append(ich) !call base%append(ich) !call side%append(ich) - close (ich) - + close (ich) + end block !========================================================================================! diff --git a/src/classes.f90 b/src/classes.f90 index 93bcd63e..8fc739ed 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -29,6 +29,7 @@ module crest_data use strucrd,only:coord use crest_type_timer,only:timer use lwoniom_module,only:lwoniom_input + use construct_list !> from molbuilder dir implicit none public :: systemdata @@ -460,6 +461,8 @@ module crest_data !>--- reference structure data (the input structure) type(refdata) :: ref + type(split_atms),allocatable :: splitqueue(:) + type(construct_heap) :: splitheap !>--- QCG data integer :: qcg_runtype = 0 !> Default is grow, 1= ensemble & opt, 2= e_solv, 3= g_solv @@ -640,6 +643,7 @@ module crest_data procedure :: rmhy => pqueue_removehybrid procedure :: addrefine => add_to_refinequeue procedure :: wrtCHRG => wrtCHRG + procedure :: addsplitqueue => env_addsplitqueue end type systemdata !========================================================================================! @@ -719,7 +723,7 @@ subroutine legacy_constraints_info(self) write (*,'(a)') trim(self%cbonds(i)) end if end do - if(self%n_cbonds>10) write(*,*) '... and some more' + if (self%n_cbonds > 10) write (*,*) '... and some more' end if end subroutine legacy_constraints_info @@ -815,6 +819,13 @@ subroutine add_to_refinequeue(self,refinetype) return end subroutine add_to_refinequeue + subroutine env_addsplitqueue(self,raw_split) + implicit none + class(systemdata) :: self + integer,intent(in) :: raw_split(:) + call add_to_splitqueue(self%splitqueue,raw_split) + end subroutine env_addsplitqueue + !========================================================================================! !========================================================================================! !> write a .CHRG (and .UHF) file in the specified dir, but only if it is needed diff --git a/src/molbuilder/construct_list.f90 b/src/molbuilder/construct_list.f90 new file mode 100644 index 00000000..027ac6f6 --- /dev/null +++ b/src/molbuilder/construct_list.f90 @@ -0,0 +1,79 @@ +module construct_list + !************************************************** + !* Bookkeeping module for reconstructing moleucles + !************************************************** + use crest_parameters + use strucrd + use quicksort_interface,only:qqsorti + implicit none + private + + type :: split_atms + integer :: natms = 0 + integer,allocatable :: atms(:) + end type split_atms + + type :: construct_layer + integer :: nnodes = 0 + type(coord),allocatable :: node(:) + !> initial/reconstructed molecule + type(coord) :: mol + end type construct_layer + + type :: construct_heap + integer :: nlayer = 0 + type(construct_layer),allocatable :: layer(:) + + end type construct_heap + + !> exported types + public :: split_atms + public :: construct_heap + !> exported helper functions + public :: add_to_splitqueue + +!=============================================================================! +contains !> MODULE PROCEDURES START HERE +!=============================================================================! + + subroutine add_to_splitqueue(splitqueue,raw_split) + implicit none + type(split_atms),intent(inout),allocatable :: splitqueue(:) + integer,intent(in) :: raw_split(:) + type(split_atms) :: tmpsplit + type(split_atms),allocatable :: tmpsplitqueue(:) + integer :: ii,n,nall,nallnew + logical :: duplicate + + n = size(raw_split,1) + allocate (tmpsplit%atms(n)) + tmpsplit%natms = n + tmpsplit%atms(:) = raw_split(:) + call qqsorti(tmpsplit%atms,1,n) + + if (.not.allocated(splitqueue)) then + allocate (splitqueue(1)) + splitqueue(1) = tmpsplit + else + nall = size(splitqueue,1) + nallnew = nall+1 + duplicate = .false. + do ii = 1,nall + if (all(splitqueue(ii)%atms(:) .eq. tmpsplit%atms(:))) then + duplicate = .true. + exit + end if + end do + if (.not.duplicate) then + allocate (tmpsplitqueue(nallnew)) + do ii = 1,nall + tmpsplitqueue(ii) = splitqueue(ii) + end do + tmpsplitqueue(nallnew) = tmpsplit + call move_alloc(tmpsplitqueue,splitqueue) + end if + end if + + end subroutine add_to_splitqueue + +end module construct_list diff --git a/src/parsing/parse_maindata.f90 b/src/parsing/parse_maindata.f90 index deb971aa..34f5ae30 100644 --- a/src/parsing/parse_maindata.f90 +++ b/src/parsing/parse_maindata.f90 @@ -29,7 +29,6 @@ module parse_maindata use crest_restartlog use strucrd,only:coord !> modules used for parsing the root_object - !> use parse_keyvalue,only:keyvalue,valuetypes use parse_block,only:datablock use parse_datastruct,only:root_object @@ -72,6 +71,15 @@ subroutine parse_main_auto(env,kv,istat) select case (kv%key) case ('optlev','ancopt_level') env%optlev = optlevnum(kv%rawvalue) + + case ('split') + if (kv%id .ne. valuetypes%int_array.or. & + & kv%na < 3) then + write (stdout,'(a)') '**ERROR** "split" must be a list of at least 3 integers' + call creststop(status_config) + end if + call env%addsplitqueue(kv%value_ia) + case default istat = istat+1 end select diff --git a/src/sorting/quicksort.f90 b/src/sorting/quicksort.f90 index 16b0742c..f89cea13 100644 --- a/src/sorting/quicksort.f90 +++ b/src/sorting/quicksort.f90 @@ -44,6 +44,12 @@ recursive subroutine qqsort(a,first,last) integer :: first,last end subroutine qqsort + recursive subroutine qqsorti(a,first,last) + implicit none + integer :: a(*) + integer :: first,last + end subroutine qqsorti + recursive subroutine maskqsort(a,first,last,mask) use iso_fortran_env,only:wp => real64 implicit none @@ -204,6 +210,31 @@ recursive subroutine qqsort(a,first,last) if (j+1 < last) call qqsort(a,j+1,last) end subroutine qqsort +recursive subroutine qqsorti(a,first,last) + implicit none + integer :: a(*) + integer :: x,t + integer :: first,last,i,j + + x = a((first+last)/2) + i = first + j = last + do + do while (a(i) < x) + i = i+1 + end do + do while (x < a(j)) + j = j-1 + end do + if (i >= j) exit + t = a(i); a(i) = a(j); a(j) = t + i = i+1 + j = j-1 + end do + if (first < i-1) call qqsorti(a,first,i-1) + if (j+1 < last) call qqsorti(a,j+1,last) +end subroutine qqsorti + recursive subroutine maskqsort(a,first,last,mask) use iso_fortran_env,only:wp => real64 implicit none From f64d84bcff6bc41847e25f781697fd748cb75206 Mon Sep 17 00:00:00 2001 From: "lukas.rindt" Date: Wed, 7 Jan 2026 15:57:30 +0100 Subject: [PATCH 124/374] Newton raphson implemented --- src/optimize/CMakeLists.txt | 1 + src/optimize/newton_raphson.f90 | 461 +++++++++++++++++++++++++++++++ src/optimize/newton_raphson1.f90 | 257 +++++++++++++++++ src/optimize/optimize_module.f90 | 4 + src/parsing/parse_calcdata.f90 | 2 + 5 files changed, 725 insertions(+) create mode 100644 src/optimize/newton_raphson.f90 create mode 100644 src/optimize/newton_raphson1.f90 diff --git a/src/optimize/CMakeLists.txt b/src/optimize/CMakeLists.txt index 3b953469..3675888e 100644 --- a/src/optimize/CMakeLists.txt +++ b/src/optimize/CMakeLists.txt @@ -21,6 +21,7 @@ list(APPEND srcs "${dir}/gd.f90" "${dir}/rfo.f90" "${dir}/lbfgs.f90" + "${dir}/newton_raphson.f90" "${dir}/hessupdate.f90" "${dir}/modelhessian.f90" "${dir}/coordtrafo.f90" diff --git a/src/optimize/newton_raphson.f90 b/src/optimize/newton_raphson.f90 new file mode 100644 index 00000000..f88d3b27 --- /dev/null +++ b/src/optimize/newton_raphson.f90 @@ -0,0 +1,461 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2021 - 2022 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +! +! Routines were adapted from the xtb code (github.com/grimme-lab/xtb) +! under the Open-source software LGPL-3.0 Licencse. +!================================================================================! + +!> This module implements a standard RFO algorithm (in Cart. coords) + +module newton_raphson_module + use iso_fortran_env,only:wp => real64,sp => real32 + use crest_calculator + use axis_module + use strucrd + use ls_rmsd + + use optimize_type + use optimize_maths + use modelhessian_module + use hessupdate_module + use optimize_utils + use hessian_reconstruct + implicit none + private + + public :: newton_raphson + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + subroutine newton_raphson(mol,calc,etot,grd,pr,wr,iostatus) +!************************************************************************* +!> subroutine rfopt +!> Implementation of the standard rational function optimizer (RFO) +!> +!> Input/Output: +!> mol - object containing the molecule, +!> Cartesian coordinates in Bohrs. +!> will be overwritten on output +!> calc - object containing calculation settings +!> and optimization thresholds (look for calc% ) +!> etot - on input initial energy (do a singlepoint before ancopt) +!> on output final energy +!> grd - Cartesian gradient +!> pr - printout bool +!> wr - logfile (crestopt.log.xyz) bool +!> iostatus - return status of the routine +!> (success=0, error<0, not converged>0) +!!*********************************************************************** + implicit none + !> INPUT/OUTPUT + type(coord),intent(inout) :: mol + type(calcdata),intent(inout) :: calc + real(wp),intent(inout) :: etot + real(wp),intent(inout) :: grd(3,mol%nat) + logical,intent(in) :: pr + logical,intent(in) :: wr + integer,intent(out) :: iostatus + !> LOCAL + integer :: tight + real(wp) :: eel + real(wp) :: et + real(wp) :: egap + logical :: fail + !> Local objects + type(coord) :: molopt + type(optimizer) :: OPT + type(mhparam) :: mhset + + real(wp) :: step,amu2au,au2cm,dumi,dumj,damp,hlow,edum,s6,thr + real(wp) :: maxdispl,gthr,ethr,hmax,energy,rij(3),t1,t0,w1,w0 + real(wp) :: rot(3),gnorm + integer :: n3,i,j,k,l,jjj,ic,jc,ia,ja,ii,jj,info,nat3 + integer :: nvar,iter,nread,maxcycle,maxmicro,itry,maxopt,iupdat,iii + integer :: id,ihess,error + integer :: ilog,imax(3) + real(wp) :: depred,echng,alp,alpold,gnold,eold,gchng,dummy,dsnrm,maxd + real(wp),allocatable :: h(:,:) + real(wp),allocatable :: b(:,:) + real(wp),allocatable :: fc(:) + real(wp),allocatable :: eig(:) + real(wp),allocatable :: aux(:) + real(wp),allocatable :: hess(:) + integer,allocatable :: iwork(:) + integer,allocatable :: totsym(:) + real(wp),allocatable :: pmode(:,:) + real(wp),allocatable :: grmsd(:,:) + real(wp),allocatable :: grd1(:) + real(wp),allocatable :: gold(:) + real(wp),allocatable :: displ(:) + integer :: nvar1,npvar,npvar1 + real(wp), allocatable :: int_hess(:), c(:) + integer, allocatable :: IPIV(:) + integer :: info2,info3 + type(convergence_log),allocatable :: avconv + real(wp) :: U(3,3),x_center(3),y_center(3),rmsdval + integer :: modef + logical :: ex,converged,linear,exact + logical :: econverged,gconverged,lowered + real(wp) :: estart,esave + real(wp),parameter :: r4dum = 1.e-8 + integer :: unit + real(wp), allocatable :: dx_test(:) + !> LAPACK & BLAS + external :: dgemv + external :: dppsv + external :: dspsv + real(wp), external :: ddot + !real(sp),external :: sdot + + iostatus = 0 + fail = .false. + converged = .false. + if (mol%nat .eq. 1) return +!> defaults + tight = calc%optlev + modef = 0 + call get_optthr(mol%nat,tight,calc,ethr,gthr) + iupdat = calc%iupdat + hlow = calc%hlow_opt !> 0.01 in ancopt, 0.002 too small + hmax = calc%hmax_opt + maxdispl = calc%maxdispl_opt + gnorm = 0.0_wp + depred = 0.0_wp + echng = 0.0_wp + alp = 1.0_wp + alpold = 1.0_wp + exact = calc%exact_rf .or. tight>0 + + maxmicro = 100 + maxcycle = calc%maxcycle + if (maxcycle .lt. maxmicro) maxmicro = maxcycle + + !> check if the molecule is linear + call axis(mol%nat,mol%at,mol%xyz,rot,dumi) + linear = (rot(3) .lt. 1.d-10).or.(mol%nat == 2) + + !> set degrees of freedom + nat3 = 3*mol%nat + nvar = nat3-6 + if (linear) then + nvar = nat3-5 + end if + if (calc%nfreeze .gt. 0) then ! exact fixing + nvar = nat3-3*calc%nfreeze-3 + if (nvar .le. 0) nvar = 1 + end if + + !$omp critical + allocate (pmode(nat3,1),grmsd(3,mol%nat)) ! dummy allocated + !$omp end critical + +!>--- print a summary of settings, if desired + if (pr) then + call print_optsummary(calc,tight,nvar,maxcycle,maxmicro, & + & ethr,gthr,linear,wr) + end if + +!>--- initialize OPT object + !$omp critical + allocate (h(nat3,nat3),hess(nat3*(nat3+1)/2),eig(nat3)) + call OPT%allocate2(mol%nat) !> NOTE: OPT%nvar will be nat*3 !!! + allocate (molopt%at(mol%nat),molopt%xyz(3,mol%nat)) + nvar1 = OPT%nvar+1 + npvar = OPT%nvar*(nvar1)/2 !> packed size of Hessian (note the abuse of nvar1!) + allocate (gold(OPT%nvar),displ(OPT%nvar),grd1(OPT%nvar),source=0.0_wp) + allocate(int_hess(size(OPT%hess))) + allocate(c(nat3)) + allocate(IPIV(nat3)) + !$omp end critical + +!>------------------------------------------------------------------------ +!>--- put the Hessian guess into the type +!>------------------------------------------------------------------------ + k = 0 + do i = 1,nat3 + do j = 1,i + k = k+1 + if (i /= j) then + OPT%hess(k) = 0.0_wp + else + OPT%hess(k) = calc%hguess + end if + end do + end do + +!>--- backup coordinates, and starting energy + molopt%nat = mol%nat + molopt%at = mol%at + molopt%xyz = mol%xyz + estart = etot + +!>--- initialize .log file, if desired + ilog = 942 + if (wr) then + open (newunit=ilog,file='crestopt.log.xyz') + end if + + iter = 0 + +!>--- start with a printout of the preceeding single point + if (pr) call print_optiter(iter) + gnorm = norm2(grd) + if (pr) then + write (*,'(" * total energy :",f14.7,1x,"Eh")',advance='no') etot + write (*,'(5x,"change ΔE",e18.7,1x,"Eh")') 0.0_wp + write (*,'(3x,"gradient norm :",f14.7,1x,"Eh/a0")',advance='no') gnorm + write (*,'(2x,"predicted",e18.7)',advance='no') 0.0_wp + write (*,'(1x,"("f7.2"%)")')-0.0_wp + end if + +!>====================================================================== + NR_iter: do while (iter < maxcycle.and..not.converged) +!>====================================================================== +!>--- count the step and print out + iter = iter+1 + if (pr) call print_optiter(iter) + gold = reshape(grd, [nat3]) + gnold = gnorm + eold = energy + +!>--- calc predicted energy change based on E = E0 + delta * G + delta^2 * H + if (iter > 1) then + call prdechng(OPT%nvar,gold,displ,OPT%hess,depred) + end if + +!>------------------------------------------------------------------------ +!>--- SINGLEPOINT CALCULATION +!>------------------------------------------------------------------------ + grd = 0.0_wp + call engrad(molopt,calc,energy,grd,iostatus) + if (iostatus .ne. 0) then + fail = .true. + exit NR_iter + end if + gnorm = norm2(grd) + grd1 = reshape(grd, [nat3]) + +!>--- dump to .log file + if (wr) then + call molopt%appendlog(ilog,energy) + end if + + if (gnorm .gt. 500.0_wp) then + if (pr) write (*,*) '|grad| > 500, something is totally wrong!' + fail = .true. + iostatus = -1 + exit NR_iter + end if + +!>--- check for convergence + gchng = gnorm-gnold + echng = energy-eold + econverged = abs(echng) .lt. ethr + gconverged = gnorm .lt. gthr + lowered = echng .lt. 0.0_wp + +!>--- optimization step printout + if (pr) then + write (*,'(" * total energy :",f14.7,1x,"Eh")',advance='no') energy + write (*,'(5x,"change ΔE",e18.7,1x,"Eh")') echng + write (*,'(3x,"gradient norm :",f14.7,1x,"Eh/a0")',advance='no') gnorm + write (*,'(2x,"predicted",e18.7)',advance='no') depred + if (iter > 1) then + dummy = (depred-echng)/echng*100.0_wp + if (abs(dummy) < 1000.0_wp) then + write (*,'(1x,"("f7.2"%)")') dummy + else + write (*,'(1x,"(*******%)")') + end if + else + write (*,'(1x,"("f7.2"%)")')-100.0_wp + end if + end if + +!>--- dynamic scaling in dependence of grad norm +!>--- if we are close to convergence we can take larger steps + alpold = alp + + alp = 1.0d-1 + if (gnorm .lt. 0.002) then ! 0.002 + alp = 1.5d-1 ! 1.5 + end if + if (gnorm .lt. 0.0006) then + alp = 2.0d-1 ! 2 + end if + if (gnorm .lt. 0.0003) then + alp = 3.0d-1 ! 3 + end if + + !if (calc%optlev>0) then + !alp = alp_generate(gnorm, calc) + !endif + +!>------------------------------------------------------------------------ +!> Update the Hessian +!>------------------------------------------------------------------------ + if (iter .gt. 1) then +!>--- Hessian update, but only after first iteration (iter > 1) + select case (iupdat) + case (0) + call bfgs(OPT%nvar,gnorm,grd1,gold,displ*alpold,OPT%hess) + case (1) + call powell(OPT%nvar,gnorm,grd1,gold,displ*alpold,OPT%hess) + case (2) + call sr1(OPT%nvar,gnorm,grd1,gold,displ*alpold,OPT%hess) + case (3) + call bofill(OPT%nvar,gnorm,grd1,gold,displ*alpold,OPT%hess) + case (4) + call schlegel(OPT%nvar,gnorm,grd1,gold,displ*alpold,OPT%hess) + case default + write (*,*) 'invalid hessian update selection' + stop + end select + end if + + !allocate(calc%chess%H(nat3,nat3)) + if (calc%full_HR) then + call dhtosq(nat3,calc%chess%H(:,:),OPT%hess(:)) + end if +!>------------------------------------------------------------------------ +!> Newton Raphson (NR) method +!>------------------------------------------------------------------------ + +!> Solve linear system H*dx = -g + int_hess = OPT%hess + c = -grd1 !> This will become the update step after system is solved + call dppsv('U', nat3, 1, int_hess, c, nat3, info2) + if (info2 /= 0) then !> dppsv assumes matrix to be positive definite, fallback dspsv + int_hess = OPT%hess + c = -grd1 + call dspsv('U', nat3, 1, int_hess, IPIV, c, nat3, info3) + displ = c + else + displ = c + endif + +!>--- rescale displacement if necessary + maxd = alp*sqrt(ddot(OPT%nvar,displ,1,displ,1)) + if (maxd > maxdispl) then + if (pr) write (*,'(" * rescaling step by",f14.7)') maxdispl/maxd + displ = maxdispl*displ/maxd + end if + +!>--- now some output + dsnrm = sqrt(ddot(OPT%nvar,displ,1,displ,1)) + if (pr) then + !> this array is currently not used and will be overwritten in next step + gold = abs(displ) + imax(1) = maxloc(gold,1); gold(imax(1)) = 0.0_wp + imax(2) = maxloc(gold,1); gold(imax(2)) = 0.0_wp + imax(3) = maxloc(gold,1) + write (*,'(3x,"displ. norm :",f14.7,1x,"a.u.")',advance='no') & + dsnrm*alp + !write (*,'(6x,"lambda ",e18.7)') eaug(1) + write (*,'(3x,"maximum displ.:",f14.7,1x,"a.u.")',advance='no') & + abs(displ(imax(1)))*alp + write (*,'(6x,"in coords ",3("#",i0,", "),"...")') imax + end if + +!>------------------------------------------------------------------------ +!>--- new coordinates +!>------------------------------------------------------------------------ + molopt%xyz = molopt%xyz+reshape(displ, [3,molopt%nat])*alp + +!>--- converged ? + econverged = abs(echng) .lt. ethr + gconverged = gnorm .lt. gthr + lowered = echng .lt. 0.0_wp + converged = econverged.and.gconverged.and.lowered + if (pr) then + call print_convd(econverged,gconverged) + end if + if (converged) then + converged = .true. + etot = energy + exit NR_iter + end if + +!>====================================================================== + end do NR_iter +!>====================================================================== + +!>--- close .log file + if (wr) then + close (ilog) + end if + + if (converged) then +!>--- if the relaxation converged properly do this + iostatus = 0 + if (pr) then + call rmsd(mol%nat,mol%xyz,molopt%xyz,1,U,x_center,y_center,rmsdval,.false.,grmsd) + write (*,'(/,3x,"***",1x,a,1x,i0,1x,a,1x,"***",/)') & + "GEOMETRY OPTIMIZATION CONVERGED AFTER",iter,"ITERATIONS" + write (*,'(72("-"))') + write (*,'(1x,"total energy gain :",F18.7,1x,"Eh",F14.4,1x,"kcal/mol")') & + etot-estart, (etot-estart)*autokcal + write (*,'(1x,"total RMSD :",F18.7,1x,"a0",F14.4,1x,"Å")') & + rmsdval,rmsdval*autoaa + write (*,'(72("-"))') + end if + else if (iostatus .ne. 0) then +!>--- if iostatus =/= 0, something went wrong in the relaxation + if (pr) then + write (*,'(/,3x,"***",1x,a,1x,"***",/)') & + "GEOMETRY RELAXATION FAILED" + end if + else +!>--- not converging in the given cycles is considered a FAILURE + !> some iostatus>0 is selected to signal this + iostatus = iter + if (pr) then + write (*,'(/,3x,"***",1x,a,1x,i0,1x,a,1x,"***",/)') & + "FAILED TO CONVERGE GEOMETRY OPTIMIZATION IN",iter,"ITERATIONS" + end if + end if + +!>--- overwrite input structure with optimized one + mol%nat = molopt%nat + mol%at = molopt%at + mol%xyz = molopt%xyz + +!> deallocate data + !$omp critical + if (allocated(gold)) deallocate (gold) + if (allocated(displ)) deallocate (displ) + if (allocated(grd1)) deallocate (grd1) + if (allocated(grmsd)) deallocate (grmsd) + if (allocated(pmode)) deallocate (pmode) + if (allocated(h)) deallocate (h) + if (allocated(hess)) deallocate (hess) + if (allocated(molopt%at)) deallocate (molopt%at) + if (allocated(molopt%xyz)) deallocate (molopt%xyz) + call OPT%deallocate + !$omp end critical + + return + end subroutine newton_raphson + +!========================================================================================! +!========================================================================================! +end module newton_raphson_module \ No newline at end of file diff --git a/src/optimize/newton_raphson1.f90 b/src/optimize/newton_raphson1.f90 new file mode 100644 index 00000000..41f28bfc --- /dev/null +++ b/src/optimize/newton_raphson1.f90 @@ -0,0 +1,257 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2025 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +!> This module implemnts a simple L-BFGS with different coordinate choices + +module newton_raphson_module + use,intrinsic :: iso_fortran_env,only:wp => real64 + use crest_calculator + use strucrd + use optimize_type !> This module provides the 'optimizer' type. + use optimize_utils + use coordinate_transform_module + implicit none + private + + public :: newton_raphson + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + function lbfgs_direction(nvar,g,k,OPT) result(d) + !******************************************************************************* + !* Two-loop recursion routine to compute the search direction. + !* + !* This function uses the stored correction pairs (S and Y) and + !* corresponding scaling factors (rho) to approximate the product + !* H*g, where H is the inverse Hessian approximation. + !* + !* The algorithm proceeds in two loops: + !* 1. The first (backward) loop computes the coefficients "alpha" and + !* subtracts corrections from the gradient. + !* 2. The second (forward) loop applies the corrections in the reverse order. + !* Finally, the result is negated to obtain the descent direction. + !* Note, this routine is NOT called for the very first iteration (k == 0) + !* + !* @param nvar Dimension of the variable space. + !* @param k Number of stored correction pairs (k ≤ m). + !* @param g Current gradient vector. + !* @param OPT optimizer type that stores the following variables + !* => S Matrix containing the s-vectors (x_{k+1} - x_k), + !* of size(nvar, m). + !* => Y Matrix containing the y-vectors (g_{k+1} - g_k), + !* of size(nvar, m). + !* => rho Array of stored values 1/(y^T*s) for each correction. + !* => alpha coefficients (get computed in this function) + !* => q temporary workspace + !* @param gamm Scaling factor for the initial Hessian approximation. + !* + !* @return d Computed search direction (negative approximate inverse + !* Hessian times g). + !******************************************************************************** + !> INPUT + integer,intent(in) :: nvar,k + type(optimizer),intent(inout) :: OPT + real(wp),intent(in) :: g(nvar) + !> OUTPUT + real(wp) :: d(nvar) + !> LOCAL + integer :: i + external :: dppsv + external :: dspsv + real(wp) :: c(nvar) + integer :: IPIV(nvar) + integer :: info2,info3 + real(wp), allocatable :: int_hess(:) + + if (.not. allocated(int_hess)) then + allocate(int_hess(size(OPT%hess))) + endif + int_hess = OPT%hess + c = -g !> This will become the update step after system is solved + call dppsv('L', nvar, 1, int_hess, c, nvar, info2) + if (info2 /= 0) then + int_hess = OPT%hess + c = -g + call dspsv('L', nvar, 1, int_hess, IPIV, c, nvar, info3) + d = c + else + d = c + endif + + end function lbfgs_direction + +!========================================================================================! + + subroutine newton_raphson(mol,calc,etot,grd,pr,io) + !************************************************************************** + !* L-BFGS Optimization Routine + !* + !* Performs optimization using the Limited-memory BFGS (L-BFGS) algorithm. + !* The routine updates the coordinate vector x to approach a local minimum of the + !* objective function. It integrates with an optimizer type (OPT) to manage the + !* correction pairs (s and y) and related internal data using associate constructs. + !* + !* The main steps include: + !* 1. Evaluating the objective function and gradient at the current x. + !* 2. Computing the search direction via the two-loop recursion (lbfgs_direction). + !* 3. Updating x using a fixed step (with the option to incorporate a line search). + !* 4. Updating the correction pairs: s = x_new - x and y = g_new - g, while managing + !* the history using a shifting strategy when full. + !* + !* @param io Integer. Output status variable (0 indicates success). + !************************************************************************** + implicit none + !> INPUT + type(coord),intent(inout) :: mol + type(calcdata),intent(in) :: calc + real(wp),intent(inout) :: etot + real(wp),intent(inout) :: grd(3,mol%nat) + logical,intent(in) :: pr + !> OUTPUT + integer,intent(out) :: io + !> LOCAL + type(optimizer) :: OPT + integer :: iter,k,nvar,m + integer :: tight,max_iter + real(wp) :: gnorm,deltaE,energy + real(wp) :: ethr,gthr,maxerise + logical :: econverged,gconverged,converged,Erise + real(wp),allocatable :: x(:),g(:),d(:),g_new(:),x_new(:),gtmp(:,:) + real(wp) :: f,f_new,gamm,step + integer :: ilog + + !> Prepare settings + io = 0 + nvar = compute_nvar(mol) + m = calc%lbfgs_histsize + gnorm = norm2(grd) + deltaE = huge(deltaE) + tight = calc%optlev + call get_optthr(mol%nat,tight,calc,ethr,gthr) + max_iter = calc%maxcycle !> automatic setting in get_optthr or by user + maxerise = calc%maxerise + econverged = .false. + gconverged = .false. + converged = .false. + + open (newunit=ilog,file='crestopt.log.xyz') + call mol%appendlog(ilog,etot) + + !$omp critical + !> Allocate the vectors for position, gradient, and search direction. + allocate (x(nvar),g(nvar),d(nvar),g_new(nvar),x_new(nvar),gtmp(3,mol%nat)) + !> Allocate matrices to store up to m correction pairs (columns correspond to each stored pair). + call OPT%allocate2(mol%nat) + !$omp end critical + + !> First trafo + call transform_mol('cart2v',mol,nvar,x) + call transform_grd('cart2v',mol,grd,nvar,g) + + iter = 0 + if (pr) then + call print_optiter(iter) + write (*,'(" * total energy :",f14.7,1x,"Eh")',advance='no') etot + write (*,'(5x,"change ΔE",e18.7,1x,"Eh")') 0.0_wp + write (*,'(3x,"gradient norm :",f14.7,1x,"Eh/a0")') gnorm + end if + + LBFGS_iter: do while (.not.converged.and.iter < max_iter) + iter = iter+1 + if (pr) call print_optiter(iter) + + if (iter == 1) then + !> First iteration: use the steepest descent direction. + d = -g + else + !> Compute the search direction using the two-loop recursion. + d = lbfgs_direction(nvar,g,k,OPT) + end if + + !--------------------------------------------------------- + !> A fixed step size could be used here for simplicity. + ! In a full implementation, a line search could be used. + ! If the energy rises, we reduce the stepsize iteratively + !--------------------------------------------------------- + step = 0.0008_wp + + Erise = .true. + do while (Erise) + !> Update the position: x_new = x + step * d. + x_new = x+step*d + + !====================================================================! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Evaluate the objective and gradient at the new position. + call transform_mol('v2cart',mol,nvar,x_new) + grd = 0.0_wp + call engrad(mol,calc,energy,gtmp,io) + call mol%appendlog(ilog,energy) + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< maxerise) + if (Erise) then + step = step*0.25_wp + if (pr) then + write (*,'(" * energy rise detected, decreasing stepsize")') + end if + end if + end do + econverged = abs(deltaE) .lt. ethr + gconverged = gnorm .lt. gthr + + call bfgs(OPT%nvar,gnorm,g_new,g,d*step,OPT%hess) + + !> Update the current position, gradient, and function value. + x = x_new + g = g_new + etot = energy + + !> Optional: print iteration information. + if (pr) then + write (*,'(" * total energy :",f14.7,1x,"Eh")',advance='no') etot + write (*,'(5x,"change ΔE",e18.7,1x,"Eh")') deltaE + write (*,'(3x,"gradient norm :",f14.7,1x,"Eh/a0")',advance='no') gnorm + call print_convd(econverged,gconverged) + end if + converged = econverged.and.gconverged + end do LBFGS_iter + + !> Final trafo + call transform_mol('v2cart',mol,nvar,x_new) + call transform_grd('v2cart',mol,grd,nvar,g_new) + + !> Deallocate all temporary arrays. + deallocate (x_new,g_new,d,g,x) + end subroutine newton_raphson + +!========================================================================================! +!========================================================================================! +end module newton_raphson_module + diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index d161e50e..b2019297 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -35,6 +35,7 @@ module optimize_module use optimize_utils use thermochem_module use hessian_reconstruct + use newton_raphson_module !use hessian_tools implicit none private @@ -101,6 +102,9 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) case (2) !> rfo goes here call rfopt(molnew,calc,etot,grd,pr,wr,iostatus) + case (3) + !> newton-raphson step goes here, this is a newton step with updated hessians, i.e. quasi Newton + call newton_raphson(molnew,calc,etot,grd,pr,wr,iostatus) case (-1) call gradientdescent(molnew,calc,etot,grd,pr,wr,iostatus) case default diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 1119066a..5bd49b10 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -588,6 +588,8 @@ subroutine parse_calc_auto(env,calc,kv,rd) calc%opt_engine = 1 case ('rfo','rfo-cart') calc%opt_engine = 2 + case('newton') + calc%opt_engine = 3 case ('gd','gradient descent') calc%opt_engine = -1 case default From 235598e166c5da5b9b42eaf41088e2b16641c1b4 Mon Sep 17 00:00:00 2001 From: "lukas.rindt" Date: Wed, 7 Jan 2026 16:00:47 +0100 Subject: [PATCH 125/374] newton printout added --- src/optimize/newton_raphson1.f90 | 257 ------------------------------- src/optimize/optutils.f90 | 2 + 2 files changed, 2 insertions(+), 257 deletions(-) delete mode 100644 src/optimize/newton_raphson1.f90 diff --git a/src/optimize/newton_raphson1.f90 b/src/optimize/newton_raphson1.f90 deleted file mode 100644 index 41f28bfc..00000000 --- a/src/optimize/newton_raphson1.f90 +++ /dev/null @@ -1,257 +0,0 @@ -!================================================================================! -! This file is part of crest. -! -! Copyright (C) 2025 Philipp Pracht -! -! crest is free software: you can redistribute it and/or modify it under -! the terms of the GNU Lesser General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! crest is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public License -! along with crest. If not, see . -!================================================================================! - -!> This module implemnts a simple L-BFGS with different coordinate choices - -module newton_raphson_module - use,intrinsic :: iso_fortran_env,only:wp => real64 - use crest_calculator - use strucrd - use optimize_type !> This module provides the 'optimizer' type. - use optimize_utils - use coordinate_transform_module - implicit none - private - - public :: newton_raphson - -!========================================================================================! -!========================================================================================! -contains !> MODULE PROCEDURES START HERE -!========================================================================================! -!========================================================================================! - - function lbfgs_direction(nvar,g,k,OPT) result(d) - !******************************************************************************* - !* Two-loop recursion routine to compute the search direction. - !* - !* This function uses the stored correction pairs (S and Y) and - !* corresponding scaling factors (rho) to approximate the product - !* H*g, where H is the inverse Hessian approximation. - !* - !* The algorithm proceeds in two loops: - !* 1. The first (backward) loop computes the coefficients "alpha" and - !* subtracts corrections from the gradient. - !* 2. The second (forward) loop applies the corrections in the reverse order. - !* Finally, the result is negated to obtain the descent direction. - !* Note, this routine is NOT called for the very first iteration (k == 0) - !* - !* @param nvar Dimension of the variable space. - !* @param k Number of stored correction pairs (k ≤ m). - !* @param g Current gradient vector. - !* @param OPT optimizer type that stores the following variables - !* => S Matrix containing the s-vectors (x_{k+1} - x_k), - !* of size(nvar, m). - !* => Y Matrix containing the y-vectors (g_{k+1} - g_k), - !* of size(nvar, m). - !* => rho Array of stored values 1/(y^T*s) for each correction. - !* => alpha coefficients (get computed in this function) - !* => q temporary workspace - !* @param gamm Scaling factor for the initial Hessian approximation. - !* - !* @return d Computed search direction (negative approximate inverse - !* Hessian times g). - !******************************************************************************** - !> INPUT - integer,intent(in) :: nvar,k - type(optimizer),intent(inout) :: OPT - real(wp),intent(in) :: g(nvar) - !> OUTPUT - real(wp) :: d(nvar) - !> LOCAL - integer :: i - external :: dppsv - external :: dspsv - real(wp) :: c(nvar) - integer :: IPIV(nvar) - integer :: info2,info3 - real(wp), allocatable :: int_hess(:) - - if (.not. allocated(int_hess)) then - allocate(int_hess(size(OPT%hess))) - endif - int_hess = OPT%hess - c = -g !> This will become the update step after system is solved - call dppsv('L', nvar, 1, int_hess, c, nvar, info2) - if (info2 /= 0) then - int_hess = OPT%hess - c = -g - call dspsv('L', nvar, 1, int_hess, IPIV, c, nvar, info3) - d = c - else - d = c - endif - - end function lbfgs_direction - -!========================================================================================! - - subroutine newton_raphson(mol,calc,etot,grd,pr,io) - !************************************************************************** - !* L-BFGS Optimization Routine - !* - !* Performs optimization using the Limited-memory BFGS (L-BFGS) algorithm. - !* The routine updates the coordinate vector x to approach a local minimum of the - !* objective function. It integrates with an optimizer type (OPT) to manage the - !* correction pairs (s and y) and related internal data using associate constructs. - !* - !* The main steps include: - !* 1. Evaluating the objective function and gradient at the current x. - !* 2. Computing the search direction via the two-loop recursion (lbfgs_direction). - !* 3. Updating x using a fixed step (with the option to incorporate a line search). - !* 4. Updating the correction pairs: s = x_new - x and y = g_new - g, while managing - !* the history using a shifting strategy when full. - !* - !* @param io Integer. Output status variable (0 indicates success). - !************************************************************************** - implicit none - !> INPUT - type(coord),intent(inout) :: mol - type(calcdata),intent(in) :: calc - real(wp),intent(inout) :: etot - real(wp),intent(inout) :: grd(3,mol%nat) - logical,intent(in) :: pr - !> OUTPUT - integer,intent(out) :: io - !> LOCAL - type(optimizer) :: OPT - integer :: iter,k,nvar,m - integer :: tight,max_iter - real(wp) :: gnorm,deltaE,energy - real(wp) :: ethr,gthr,maxerise - logical :: econverged,gconverged,converged,Erise - real(wp),allocatable :: x(:),g(:),d(:),g_new(:),x_new(:),gtmp(:,:) - real(wp) :: f,f_new,gamm,step - integer :: ilog - - !> Prepare settings - io = 0 - nvar = compute_nvar(mol) - m = calc%lbfgs_histsize - gnorm = norm2(grd) - deltaE = huge(deltaE) - tight = calc%optlev - call get_optthr(mol%nat,tight,calc,ethr,gthr) - max_iter = calc%maxcycle !> automatic setting in get_optthr or by user - maxerise = calc%maxerise - econverged = .false. - gconverged = .false. - converged = .false. - - open (newunit=ilog,file='crestopt.log.xyz') - call mol%appendlog(ilog,etot) - - !$omp critical - !> Allocate the vectors for position, gradient, and search direction. - allocate (x(nvar),g(nvar),d(nvar),g_new(nvar),x_new(nvar),gtmp(3,mol%nat)) - !> Allocate matrices to store up to m correction pairs (columns correspond to each stored pair). - call OPT%allocate2(mol%nat) - !$omp end critical - - !> First trafo - call transform_mol('cart2v',mol,nvar,x) - call transform_grd('cart2v',mol,grd,nvar,g) - - iter = 0 - if (pr) then - call print_optiter(iter) - write (*,'(" * total energy :",f14.7,1x,"Eh")',advance='no') etot - write (*,'(5x,"change ΔE",e18.7,1x,"Eh")') 0.0_wp - write (*,'(3x,"gradient norm :",f14.7,1x,"Eh/a0")') gnorm - end if - - LBFGS_iter: do while (.not.converged.and.iter < max_iter) - iter = iter+1 - if (pr) call print_optiter(iter) - - if (iter == 1) then - !> First iteration: use the steepest descent direction. - d = -g - else - !> Compute the search direction using the two-loop recursion. - d = lbfgs_direction(nvar,g,k,OPT) - end if - - !--------------------------------------------------------- - !> A fixed step size could be used here for simplicity. - ! In a full implementation, a line search could be used. - ! If the energy rises, we reduce the stepsize iteratively - !--------------------------------------------------------- - step = 0.0008_wp - - Erise = .true. - do while (Erise) - !> Update the position: x_new = x + step * d. - x_new = x+step*d - - !====================================================================! - !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Evaluate the objective and gradient at the new position. - call transform_mol('v2cart',mol,nvar,x_new) - grd = 0.0_wp - call engrad(mol,calc,energy,gtmp,io) - call mol%appendlog(ilog,energy) - !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< maxerise) - if (Erise) then - step = step*0.25_wp - if (pr) then - write (*,'(" * energy rise detected, decreasing stepsize")') - end if - end if - end do - econverged = abs(deltaE) .lt. ethr - gconverged = gnorm .lt. gthr - - call bfgs(OPT%nvar,gnorm,g_new,g,d*step,OPT%hess) - - !> Update the current position, gradient, and function value. - x = x_new - g = g_new - etot = energy - - !> Optional: print iteration information. - if (pr) then - write (*,'(" * total energy :",f14.7,1x,"Eh")',advance='no') etot - write (*,'(5x,"change ΔE",e18.7,1x,"Eh")') deltaE - write (*,'(3x,"gradient norm :",f14.7,1x,"Eh/a0")',advance='no') gnorm - call print_convd(econverged,gconverged) - end if - converged = econverged.and.gconverged - end do LBFGS_iter - - !> Final trafo - call transform_mol('v2cart',mol,nvar,x_new) - call transform_grd('v2cart',mol,grd,nvar,g_new) - - !> Deallocate all temporary arrays. - deallocate (x_new,g_new,d,g,x) - end subroutine newton_raphson - -!========================================================================================! -!========================================================================================! -end module newton_raphson_module - diff --git a/src/optimize/optutils.f90 b/src/optimize/optutils.f90 index 148cd121..e9195874 100644 --- a/src/optimize/optutils.f90 +++ b/src/optimize/optutils.f90 @@ -355,6 +355,8 @@ subroutine print_optsummary(calc,tight,nvar,maxcycle,maxmicro, & write (*,chrfmt) "algorithm "," L-BFGS" case (2) write (*,chrfmt) "algorithm ","Rational Function" + case (3) + write (*,chrfmt) "algorithm ","Quasi Newton" case (-1) write (*,chrfmt) "algorithm ","Gradient Descent" end select From f4bb3b5831a36e409dd9e152674da5ce1fce5432 Mon Sep 17 00:00:00 2001 From: "lukas.rindt" Date: Thu, 8 Jan 2026 17:10:39 +0100 Subject: [PATCH 126/374] Thermochem writeout implemented correctly --- src/entropy/thermochem_module.f90 | 26 ++++++++++++++++++++++++-- src/optimize/optimize_module.f90 | 4 ++-- 2 files changed, 26 insertions(+), 4 deletions(-) diff --git a/src/entropy/thermochem_module.f90 b/src/entropy/thermochem_module.f90 index f89fa4c1..a252c344 100644 --- a/src/entropy/thermochem_module.f90 +++ b/src/entropy/thermochem_module.f90 @@ -278,7 +278,7 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & end subroutine calcthermo subroutine calc_thermo_from_hess(mol,hess,pr,nt,temps,ithr,& - & fscal,sthr,et,ht,gt,stot) + & fscal,sthr,et,ht,gt,stot, etot) type(coord),intent(inout) :: mol integer :: nat3 integer :: io,iunit @@ -289,6 +289,12 @@ subroutine calc_thermo_from_hess(mol,hess,pr,nt,temps,ithr,& real(wp),allocatable,intent(out) :: et(:),ht(:),gt(:),stot(:) real(wp),intent(inout) :: hess(:,:) real(wp),allocatable :: freq(:) + real(wp), intent(in) :: etot + real(wp) :: zpve + integer :: nrt + real(wp),allocatable :: int_temps(:) + character(len=*),parameter :: outfmt = & + & '(10x,"::",1x,a,f24.12,1x,a,1x,"::")' nat3 = 3*mol%nat allocate (freq(nat3)) @@ -296,6 +302,10 @@ subroutine calc_thermo_from_hess(mol,hess,pr,nt,temps,ithr,& allocate (ht(nt)) allocate (gt(nt)) allocate (stot(nt)) + allocate (int_temps(nt)) + + int_temps = abs(temps-298.15_wp) + nrt = minloc(int_temps(:),1) call prj_mw_hess(mol%nat,mol%at,nat3,mol%xyz,hess) @@ -304,8 +314,20 @@ subroutine calc_thermo_from_hess(mol,hess,pr,nt,temps,ithr,& call calcthermo(mol%nat,mol%at,mol%xyz,freq,pr,ithr,fscal,sthr,nt,temps, & & et,ht,gt,stot) - call print_hessian(hess(:,:),nat3,'','numhess') + zpve = et(nrt)-ht(nrt) + write (stdout,*) + write (stdout,'(10x,a)') repeat(':',50) + write (stdout,'(10x,"::",7x,a,f12.2,1x,a,8x,"::")') "THERMODYNAMICS at",temps(nrt),'K' + write (stdout,'(10x,a)') repeat(':',50) + write (stdout,outfmt) 'TOTAL FREE ENERGY',etot+gt(nrt),'Eh' + write (stdout,'(10x,a)') '::'//repeat('-',46)//'::' + write (stdout,outfmt) 'total energy ',etot,'Eh' + write (stdout,outfmt) 'ZPVE ',zpve,'Eh' + write (stdout,outfmt) 'G(RRHO) w/o ZPVE ',gt(nrt)-zpve,'Eh' + write (stdout,outfmt) 'G(RRHO) total ',gt(nrt),'Eh' + write (stdout,'(10x,a)') repeat(':',50) end subroutine calc_thermo_from_hess + end module thermochem_module diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index b2019297..00188e09 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -122,7 +122,7 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) call calc_thermo_from_hess(molnew,calc%chess%H,pr, & & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & - & calc%ht,calc%gt,calc%stot) + & calc%ht,calc%gt,calc%stot,etot) else @@ -134,7 +134,7 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) call calc_thermo_from_hess(molnew,calc%chess%B,pr, & & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & - & calc%ht,calc%gt,calc%stot) + & calc%ht,calc%gt,calc%stot,etot) end if call calc%chess%dealloc() From 42f7ebcaa6268f8dfc74ec56ae0ecdd76c50f2e7 Mon Sep 17 00:00:00 2001 From: "lukas.rindt" Date: Fri, 9 Jan 2026 11:46:41 +0100 Subject: [PATCH 127/374] first engrad tracked bug fixed --- src/calculator/hessian_reconstruct.f90 | 1 + src/optimize/optimize_module.f90 | 3 ++- src/parsing/parse_calcdata.f90 | 2 +- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/src/calculator/hessian_reconstruct.f90 b/src/calculator/hessian_reconstruct.f90 index 514a08e3..bfe7ec13 100644 --- a/src/calculator/hessian_reconstruct.f90 +++ b/src/calculator/hessian_reconstruct.f90 @@ -19,6 +19,7 @@ module hessian_reconstruct integer :: stepcount = 0 real(wp) :: hguess = 0.02_wp real(wp),allocatable ::hguess_mat(:,:) + logical :: track_step = .true. contains diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index 00188e09..afaf0a20 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -88,8 +88,9 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) end if !> initial singlepoint + if (calc%do_HR) calc%chess%track_step = .false. !this is not tracked to avoid duplicate call engrad(molnew,calc,etot,grd,iostatus) - + if (calc%do_HR) calc%chess%track_step = .true. !> optimization select case (calc%opt_engine) case (0) diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 5bd49b10..04fcdc34 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -588,7 +588,7 @@ subroutine parse_calc_auto(env,calc,kv,rd) calc%opt_engine = 1 case ('rfo','rfo-cart') calc%opt_engine = 2 - case('newton') + case('newton','nr') calc%opt_engine = 3 case ('gd','gradient descent') calc%opt_engine = -1 From 5eab1755a3fb836de48deca265759492cb83c24c Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 11 Jan 2026 21:52:36 +0100 Subject: [PATCH 128/374] Some queue wrapper --- src/algos/CMakeLists.txt | 1 + src/algos/meson.build | 1 + src/algos/playground.f90 | 46 ++----- src/algos/queueing.f90 | 196 ++++++++++++++++++++++++++++++ src/classes.f90 | 4 + src/crest_main.f90 | 143 +++++++++++----------- src/molbuilder/construct_list.f90 | 154 ++++++++++++++++++++++- 7 files changed, 440 insertions(+), 105 deletions(-) create mode 100644 src/algos/queueing.f90 diff --git a/src/algos/CMakeLists.txt b/src/algos/CMakeLists.txt index 40277f7f..b42f9199 100644 --- a/src/algos/CMakeLists.txt +++ b/src/algos/CMakeLists.txt @@ -35,6 +35,7 @@ list(APPEND srcs "${dir}/search_conformers.f90" "${dir}/search_entropy.f90" "${dir}/parallel.f90" + "${dir}/queueing.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/algos/meson.build b/src/algos/meson.build index cebe5f85..23b7354e 100644 --- a/src/algos/meson.build +++ b/src/algos/meson.build @@ -33,4 +33,5 @@ srcs += files( 'search_conformers.f90', 'search_entropy.f90', 'parallel.f90', + 'queueing.f90', ) diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index 9f5a4213..6a54e081 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -82,40 +82,20 @@ subroutine crest_playground(env,tim) type(coord),allocatable :: splitlist(:) integer,allocatable :: alignmap(:,:),ncap(:),position_mapping(:,:) - !call base%open("base.xyz") - !call side%open("side.xyz") - - open (newunit=ich,file='molbuilder.xyz') - !call base%append(ich) - !call side%append(ich) - - !allocate (alignmap(3,2),source=0) - - !alignmap(1:3,1) = [9,7,8] - !alignmap(1:3,2) = [3,1,2] - !call attach(base,side,alignmap,new) - !call new%append(ich) - - !call new%open("struc.xyz") + open (newunit=ich,file='molbuilder.xyz', & + status="unknown", & + action="write", & + position="append") call env%ref%to(new) - !call split(new, [8,9],base,side) - if (allocated(env%splitqueue)) then - call split(new,env%splitqueue(1)%atms,splitlist,alignmap,ncap=ncap,position_mapping=position_mapping) - else - call split(new,[1,2,3],splitlist,alignmap,ncap=ncap,position_mapping=position_mapping) - end if - !write(*,*) position_mapping(:,1) - !write(*,*) position_mapping(:,2) - do i = 1,size(splitlist,1) - call splitlist(i)%append(ich) - end do - - call attach(splitlist(1),splitlist(2),alignmap,newnew, & - & remove_lastx=ncap,original_map=position_mapping) - - call newnew%append(ich) - !call base%append(ich) - !call side%append(ich) + call new%append(ich) + !if(allocated(env%splitqueue))then + ! do i=1,env%splitheap%nlayer + ! write(*,*) 'layer',i + ! do j=1,env%splitheap%layer(i)%nnodes + ! call env%splitheap%layer(i)%node(j)%append(ich) + ! enddo + ! enddo + !endif close (ich) end block diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 new file mode 100644 index 00000000..e5397ad4 --- /dev/null +++ b/src/algos/queueing.f90 @@ -0,0 +1,196 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2026 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +subroutine crest_queue_setup(env,iterate) + use crest_parameters + use crest_data + use crest_calculator + use strucrd + use construct_list + use construct_mod + implicit none + type(systemdata),intent(inout) :: env + logical,intent(out) :: iterate + + integer :: splitlayers + integer :: ii,jj,nn + type(coord),pointer :: reference_mol + type(coord),target :: mol + integer,allocatable :: splitatms(:) + integer :: parentlayer,parentnode + character(len=1024) :: thispath + + iterate = .false. + + if (allocated(env%splitqueue)) then + + !> check for incompatible runtypes (or rather, whitelist a few) + if (.not.any(env%crestver == [crest_imtd,crest_imtd2,crest_sp, & + & crest_optimize,crest_moldyn,crest_rigcon,crest_trialopt,crest_bh,crest_test])) then + write (stdout,'(a)') '** ERROR ** Selected CREST runtype incompatible with substructure builder' + call creststop(status_config) + end if + if (allocated(env%ONIOM_input).or.allocated(env%ONIOM_toml)) then + write (stdout,'(a)') '** ERROR ** ONIOM incompatible with substructure builder' + call creststop(status_config) + end if + + !> if the program sees no problem, set the global boolean + env%substructure_queue = .true. + splitlayers = size(env%splitqueue,1) + + !> start constructing the splitheap + env%splitheap%nlayer = splitlayers + allocate (env%splitheap%layer(splitlayers)) + associate (heap => env%splitheap,layer => env%splitheap%layer) + + do ii = 1,heap%nlayer + layer%id = ii + + nn = env%splitqueue(ii)%natms + allocate (splitatms(nn)) + splitatms(:) = env%splitqueue(ii)%atms(:) + + if (ii == 1) then + call env%ref%to(mol) + reference_mol => mol + else + + call pick_parent(heap,ii,splitatms,parentlayer,parentnode) + if (parentlayer == 0) then + call env%ref%to(mol) + reference_mol => mol + else + mol = heap%layer(parentlayer)%node(parentnode) + reference_mol => mol + end if + end if + call split(reference_mol,splitatms,layer(ii)%node,layer(ii)%alignmap, & + & ncap=layer(ii)%ncapped,position_mapping=layer(ii)%position_mapping) + deallocate (splitatms) + layer(ii)%nnodes = size(layer(ii)%node,1) + call heap%map_origins_for_layer(ii) + end do + + call heap%setup_queue() + !write (*,*) 'endpoints selected:' + !do ii = 1,heap%nqueue + ! write (*,*) 'layer and node',heap%queue(ii)%layer,heap%queue(ii)%node + !end do + call getcwd(thispath) + heap%origindir = trim(thispath) + end associate + iterate = .true. + end if + + return + +contains + subroutine pick_parent(heap,current_layer,splitatms,parentlayer,parentnode) + use construct_list + implicit none + type(construct_heap),intent(inout) :: heap + integer,intent(inout) :: splitatms(:) + integer,intent(in) :: current_layer + integer,intent(out) :: parentlayer,parentnode + integer :: ii,jj,kk,prev_layer + logical :: matching + + parentlayer = 0 + parentnode = 0 + if (current_layer .eq. 1) return + + !> iterate through the previous layer and check which node + !> contains all the split atoms + prev_layer = current_layer-1 + LAYITER: do while (prev_layer >= 1) + do ii = 1,heap%layer(prev_layer)%nnodes + matching = .true. + do jj = 1,size(splitatms,1) + matching = matching.and.any(heap%layer(prev_layer)%origin(ii)%map(:) .eq. splitatms(jj)) + end do + if (matching) then + parentlayer = prev_layer + parentnode = ii + !> on the first match, exit + exit LAYITER + end if + end do + !> if no matching parent node was found, try again in one layer further up + if (parentnode == 0) prev_layer = prev_layer-1 + end do LAYITER + + !> IMPORTANT; we need to update the splitatms with the correctly mapped indices + if (parentnode .ne. 0) then + do ii = 1,size(splitatms,1) + jj = splitatms(ii) + call heap%find_current_position(jj,parentlayer,parentnode,kk) + splitatms(ii) = kk + end do + !> we also map the current node as a child node of the selected parent + if (.not.allocated(heap%layer(parentlayer)%childlayer)) then + ii = heap%layer(parentlayer)%nnodes + allocate (heap%layer(parentlayer)%childlayer(ii),source=0) + end if + heap%layer(parentlayer)%childlayer(parentnode) = current_layer + end if + + end subroutine pick_parent +end subroutine crest_queue_setup + +subroutine crest_queue_iter(env,iterate) + use crest_parameters + use crest_data + use strucrd + use iomod + implicit none + type(systemdata),intent(inout) :: env + logical,intent(out) :: iterate + integer :: ii,jj,kk,io + type(coord) :: mol + character(len=10) :: atmp + character(len=*),parameter :: dirname = 'crest_queue_' + + iterate = .false. + + if (allocated(env%splitqueue).and.env%splitheap%nqueue > 0) then + call chdir(env%splitheap%origindir) + ii = env%queue_iter+1 + env%queue_iter = ii + + associate (queue => env%splitheap%queue(ii)) + + jj = queue%layer + kk = queue%node + + !> create a dedicated work directory + write(atmp,'(i0)') ii + queue%workdir = dirname//trim(atmp) + io = makedir(queue%workdir) + call chdir(queue%workdir) + + mol = env%splitheap%layer(jj)%node(kk) + call env%ref%load(mol) + + end associate + if (ii < env%splitheap%nqueue) then + iterate = .true. + end if + end if +end subroutine crest_queue_iter diff --git a/src/classes.f90 b/src/classes.f90 index 8fc739ed..d2dcbc5e 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -461,8 +461,12 @@ module crest_data !>--- reference structure data (the input structure) type(refdata) :: ref + !>--- the reference mol may be partitioned into subfragments + !> the corresponding bookkeeping data is saved here + logical :: substructure_queue = .false. type(split_atms),allocatable :: splitqueue(:) type(construct_heap) :: splitheap + integer :: queue_iter = 0 !>--- QCG data integer :: qcg_runtype = 0 !> Default is grow, 1= ensemble & opt, 2= e_solv, 3= g_solv diff --git a/src/crest_main.f90 b/src/crest_main.f90 index 7d8a2ded..c7041d9b 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -36,7 +36,7 @@ program CREST character(len=512) :: thisdir character(len=1024) :: cmd real(wp) :: dumfloat,dumfloat2,d3,d4,d5,d6,d7,d8 - logical :: ex,ex1,ex2 + logical :: ex,ex1,ex2,iterate intrinsic :: iargc,getarg LOGICAL :: overflow,division_by_zero,invalid_operation @@ -141,22 +141,12 @@ program CREST case (p_compare) call compare_ensembles(env) call propquit(tim) -! !>--- protonation tool -! case (p_protonate) -! call protonate(env,tim) -! call propquit(tim) -!>--- deprotonation -! case (p_deprotonate) -! call deprotonate(env,tim) -! call propquit(tim) -!>--- tautomerization -! case (p_tautomerize) -! call tautomerize(env,tim) -! call propquit(tim) + !>--- extended tautomerization case (p_tautomerize2) call tautomerize_ext(env%ensemblename,env,tim) call propquit(tim) + !>--- stereoisomerization case (p_isomerize) call stereoisomerize(env,tim) @@ -165,8 +155,8 @@ program CREST !>--- reactor setup case (p_reactorset) call reactor_setup(env) - stop + !>--- enhanched ensemble entropy case (p_CREentropy) call entropic(env,.true.,.true.,.false.,env%ensemblename, & @@ -230,89 +220,102 @@ program CREST call xtbsp(env) end if !=========================================================================================! -!> MAIN WORKFLOW CALLS START HERE +!> SET UP QUEUES, IF REQUIRED +!=========================================================================================! + call crest_queue_setup(env,iterate) +!=========================================================================================! +!> MAIN WORKFLOW CALLS START HERE (including iterator) !=========================================================================================! -!> many of these routine calls take a detour through legacy_wrappers.f90 ! - select case (env%crestver) - case (crest_mfmdgc) !> MF-MD-GC algo (deprecated) - call confscript1(env,tim) - case (crest_imtd,crest_imtd2) !> MTD-GC algo - call confscript2i(env,tim) + ITERATOR: do while (iterate) + call crest_queue_iter(env,iterate) - case (crest_mdopt,crest_mdopt2) - call mdopt(env,tim) !> MDOPT +!> NOTE: many of these routine calls take a detour through legacy_wrappers.f90 ! + select case (env%crestver) + case (crest_mfmdgc) !> MF-MD-GC algo (deprecated) + call confscript1(env,tim) - case (crest_screen) - call screen(env,tim) !> SCREEN + case (crest_imtd,crest_imtd2) !> MTD-GC algo + call confscript2i(env,tim) - case (crest_nano) - call reactor(env,tim) !> NANO-REACTOR + case (crest_mdopt,crest_mdopt2) + call mdopt(env,tim) !> MDOPT - case (crest_compr) - call compress(env,tim) !> MTD COMPRESS mode + case (crest_screen) + call screen(env,tim) !> SCREEN - case (crest_msreac) - call msreact_handler(env,tim) !> MSREACT sub-program + case (crest_nano) + call reactor(env,tim) !> NANO-REACTOR - case (crest_pka) - call pkaquick(env,tim) + case (crest_compr) + call compress(env,tim) !> MTD COMPRESS mode - case (crest_solv) !> microsolvation tools - call crest_solvtool(env,tim) + case (crest_msreac) + call msreact_handler(env,tim) !> MSREACT sub-program - case (crest_sp) - call crest_singlepoint(env,tim) + case (crest_pka) + call pkaquick(env,tim) - case (crest_optimize) - call crest_optimization(env,tim) + case (crest_solv) !> microsolvation tools + call crest_solvtool(env,tim) - case (crest_moldyn) - call crest_moleculardynamics(env,tim) + case (crest_sp) + call crest_singlepoint(env,tim) - case (crest_s1) - call crest_search_1(env,tim) + case (crest_optimize) + call crest_optimization(env,tim) - case (crest_mecp) - call crest_search_mecp(env,tim) + case (crest_moldyn) + call crest_moleculardynamics(env,tim) - case (crest_numhessian) - call crest_numhess(env,tim) + case (crest_s1) + call crest_search_1(env,tim) - case (crest_scanning) - call crest_scan(env,tim) + case (crest_mecp) + call crest_search_mecp(env,tim) - case (crest_rigcon) !> rule-based conformer generation - call crest_rigidconf(env,tim) + case (crest_numhessian) + call crest_numhess(env,tim) - case (crest_trialopt) !> test optimization standalone - call trialOPT(env) + case (crest_scanning) + call crest_scan(env,tim) - case (crest_ensemblesp) !> singlepoints along ensemble - call crest_ensemble_singlepoints(env,tim) + case (crest_rigcon) !> rule-based conformer generation + call crest_rigidconf(env,tim) - case (crest_protonate) - call protonate(env,tim) + case (crest_trialopt) !> test optimization standalone + call trialOPT(env) - case (crest_deprotonate) - call deprotonate(env,tim) + case (crest_ensemblesp) !> singlepoints along ensemble + call crest_ensemble_singlepoints(env,tim) - case (crest_tautomerize) - call tautomerize(env,tim) + case (crest_protonate) + call protonate(env,tim) - case (crest_sorting) !> interface to standalone ensemble sorting - call crest_sort(env,tim) + case (crest_deprotonate) + call deprotonate(env,tim) - case (crest_bh) !> Standard basin-hopping - call crest_basinhopping(env,tim) + case (crest_tautomerize) + call tautomerize(env,tim) - case (crest_test) - call crest_playground(env,tim) + case (crest_sorting) !> interface to standalone ensemble sorting + call crest_sort(env,tim) - case default - continue - end select + case (crest_bh) !> Standard basin-hopping + call crest_basinhopping(env,tim) + + case (crest_test) + call crest_playground(env,tim) + + case default + continue + end select + end do ITERATOR + +!=========================================================================================! +!> ADDITIONAL OUTPUT FORMATTING +!=========================================================================================! if (env%outputsdf.or.env%sdfformat) then if (any((/crest_mfmdgc,crest_imtd,crest_imtd2/) == env%crestver)) then call new_wrsdfens(env,conformerfile,conformerfilebase//'.sdf',.false.) diff --git a/src/molbuilder/construct_list.f90 b/src/molbuilder/construct_list.f90 index 027ac6f6..5920546d 100644 --- a/src/molbuilder/construct_list.f90 +++ b/src/molbuilder/construct_list.f90 @@ -1,6 +1,6 @@ module construct_list !************************************************** - !* Bookkeeping module for reconstructing moleucles + !* Bookkeeping module for reconstructing molecules !************************************************** use crest_parameters use strucrd @@ -13,17 +13,48 @@ module construct_list integer,allocatable :: atms(:) end type split_atms + type :: origin_map + integer :: natms = 0 + integer,allocatable :: map(:) + end type origin_map + type :: construct_layer + integer :: id = 0 + integer :: parent = 0 + integer :: parentnode = 0 integer :: nnodes = 0 type(coord),allocatable :: node(:) + integer,allocatable :: childlayer(:) + integer,allocatable :: alignmap(:,:) + integer,allocatable :: ncapped(:) + integer,allocatable :: position_mapping(:,:) + type(origin_map),allocatable :: origin(:) !> initial/reconstructed molecule type(coord) :: mol end type construct_layer + type :: construct_queue + integer :: layer = 0 + integer :: node = 0 + integer :: duplicate_of_queue = 0 + character(len=:),allocatable :: workdir + character(len=:),allocatable :: file + end type construct_queue + type :: construct_heap + !> The gerneral mapping integer :: nlayer = 0 type(construct_layer),allocatable :: layer(:) - + !> the queue to treat endpoints + integer :: nqueue = 0 + type(construct_queue),allocatable :: queue(:) + !> originial directory + character(len=:),allocatable :: origindir + contains + procedure map_origins_for_layer + procedure find_current_position + procedure count_endpoints + procedure setup_queue end type construct_heap !> exported types @@ -76,4 +107,123 @@ subroutine add_to_splitqueue(splitqueue,raw_split) end subroutine add_to_splitqueue + recursive function find_original_atom(atom,heap,targetlayer,targetnode) result(this) + implicit none + type(construct_heap),intent(in) :: heap + integer,intent(in) :: targetlayer,targetnode,atom + integer :: this + integer :: ii,jj,kk + + this = 0 + kk = 0 + do ii = 1,size(heap%layer(targetlayer)%position_mapping,1) + if (atom == heap%layer(targetlayer)%position_mapping(ii,targetnode)) then + kk = ii + exit + end if + end do + if (heap%layer(targetlayer)%parent == 0.or.kk == 0) then + this = kk + else + ii = heap%layer(targetlayer)%parent + jj = heap%layer(targetlayer)%parentnode + this = find_original_atom(kk,heap,ii,jj) + end if + end function find_original_atom + + subroutine map_origins_for_layer(heap,targetlayer) + implicit none + class(construct_heap),intent(inout) :: heap + integer,intent(in) :: targetlayer + integer :: ii,jj,kk,nat + logical,parameter :: debug = .false. + if (targetlayer < 1.or.targetlayer > heap%nlayer) return + if (.not.allocated(heap%layer(targetlayer)%node)) return + associate (layer => heap%layer(targetlayer)) + if (allocated(layer%origin)) deallocate (layer%origin) + allocate (layer%origin(layer%nnodes)) + do ii = 1,layer%nnodes + nat = layer%node(ii)%nat + allocate (layer%origin(ii)%map(nat),source=0) + layer%origin(ii)%natms = nat + do jj = 1,nat + layer%origin(ii)%map(jj) = find_original_atom(jj,heap,targetlayer,ii) + end do + if (debug) then + write (stdout,*) 'Original atom positions for fragment',ii,'of layer',targetlayer + do jj = 1,nat + write (stdout,*) 'frag.atm.',jj,'<-- original:',layer%origin(ii)%map(jj) + end do + end if + end do + end associate + end subroutine map_origins_for_layer + + subroutine find_current_position(heap,atom,targetlayer,targetnode,current) + implicit none + class(construct_heap),intent(in) :: heap + integer,intent(in) :: atom,targetlayer,targetnode + integer,intent(out) :: current + integer :: ii,jj + current = 0 + associate (layer => heap%layer(targetlayer)) + do ii = 1,layer%node(targetnode)%nat + jj = layer%origin(targetnode)%map(ii) + if (jj == atom) then + current = ii + exit + end if + end do + end associate + end subroutine find_current_position + + function count_endpoints(heap) result(nendpoints) + implicit none + class(construct_heap) :: heap + integer :: nendpoints + integer :: ii,jj,kk + nendpoints = 0 + do ii = 1,heap%nlayer + if (.not.allocated(heap%layer(ii)%childlayer)) then + nendpoints = nendpoints+heap%layer(ii)%nnodes + else + do jj = 1,heap%layer(ii)%nnodes + if (heap%layer(ii)%childlayer(jj) == 0) then + nendpoints = nendpoints+1 + end if + end do + end if + end do + end function count_endpoints + + subroutine setup_queue(heap) + implicit none + class(construct_heap) :: heap + integer :: nqueue,kk,ii,jj + + nqueue = heap%count_endpoints() + heap%nqueue = nqueue + allocate (heap%queue(nqueue)) + + kk = 0 + do ii = 1,heap%nlayer + if (.not.allocated(heap%layer(ii)%childlayer)) then + do jj = 1,heap%layer(ii)%nnodes + kk = kk+1 + heap%queue(kk)%layer = ii + heap%queue(kk)%node = jj + end do + else + do jj = 1,heap%layer(ii)%nnodes + if (heap%layer(ii)%childlayer(jj) == 0) then + kk = kk+1 + heap%queue(kk)%layer = ii + heap%queue(kk)%node = jj + end if + end do + end if + end do + + end subroutine setup_queue + end module construct_list From c6bcacc28c0b085bd2c7c63b2b6407872c0322de Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 13 Jan 2026 17:54:15 +0100 Subject: [PATCH 129/374] Select output file in queue according to runtype --- src/algos/queueing.f90 | 30 +++++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index e5397ad4..3e6818e0 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -36,7 +36,7 @@ subroutine crest_queue_setup(env,iterate) integer :: parentlayer,parentnode character(len=1024) :: thispath - iterate = .false. + iterate = .true. if (allocated(env%splitqueue)) then @@ -174,6 +174,11 @@ subroutine crest_queue_iter(env,iterate) ii = env%queue_iter+1 env%queue_iter = ii + + write(stdout,'(/,70("§"))') + write(stdout,'(a,i0)') "§§§ QUEUE ITERATION ",ii + write(stdout,'(70("§"))') + associate (queue => env%splitheap%queue(ii)) jj = queue%layer @@ -184,13 +189,36 @@ subroutine crest_queue_iter(env,iterate) queue%workdir = dirname//trim(atmp) io = makedir(queue%workdir) call chdir(queue%workdir) + write(stdout,'(a,a)') 'Queue work (sub-)directory: ', & + & trim(queue%workdir) + + !> selecting output file depending on runtype + select case(env%crestver) + case ( crest_imtd,crest_imtd2 ) + queue%file = 'crest_conformers.xyz' + case ( crest_optimize ) + queue%file = 'crestopt.xyz' + case ( crest_moldyn ) + queue%file = 'crest_dynamics.trj.xyz' + case ( crest_bh ) + queue%file = 'crest_quenched.xyz' + case default + queue%file = 'struc.xyz' + end select mol = env%splitheap%layer(jj)%node(kk) call env%ref%load(mol) + call mol%write('coord') + + if(allocated(env%ref%wbo)) deallocate(env%ref%wbo) + env%nat = mol%nat + env%rednat = mol%nat end associate if (ii < env%splitheap%nqueue) then iterate = .true. end if + + write(stdout,*) end if end subroutine crest_queue_iter From fcb0b82f56d656ed4a71b245b8ab6d2171f6b4e4 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 13 Jan 2026 21:26:13 +0100 Subject: [PATCH 130/374] Copy function for calulation setting --- src/algos/queueing.f90 | 4 ++ src/calculator/calc_type.f90 | 102 +++++++++++++++++++++++------- src/molbuilder/construct_list.f90 | 2 + 3 files changed, 86 insertions(+), 22 deletions(-) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 3e6818e0..08ad3313 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -205,6 +205,9 @@ subroutine crest_queue_iter(env,iterate) case default queue%file = 'struc.xyz' end select + call queue%calc%copy(env%calc) + + call queue%calc%info(stdout) mol = env%splitheap%layer(jj)%node(kk) call env%ref%load(mol) @@ -213,6 +216,7 @@ subroutine crest_queue_iter(env,iterate) if(allocated(env%ref%wbo)) deallocate(env%ref%wbo) env%nat = mol%nat env%rednat = mol%nat + call env%calc%copy(queue%calc) end associate if (ii < env%splitheap%nqueue) then diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 839ee25e..47c993eb 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -188,6 +188,7 @@ module calc_type procedure :: create => create_calclevel_shortcut procedure :: norestarts => calculation_settings_norestarts procedure :: dumpdipgrad => calculation_dump_dipgrad + procedure :: copy => calculation_settings_copy end type calculation_settings !=========================================================================================! @@ -540,40 +541,50 @@ end subroutine calculation_init subroutine calculation_copy(self,src) class(calcdata) :: self type(calcdata) :: src + type(calculation_settings) :: newset integer :: i + call self%reset() + self%id = src%id - self%ncalculations = src%ncalculations if (allocated(self%calcs)) deallocate (self%calcs) !self%calcs = src%calcs - do i = 1,self%ncalculations - call self%add(src%calcs(i)) + do i = 1,src%ncalculations + call newset%copy(src%calcs(i)) + call self%add(newset) end do - self%nconstraints = src%nconstraints if (allocated(self%cons)) deallocate (self%cons) - !self%cons = src%cons - do i = 1,self%nconstraints + do i = 1,src%nconstraints call self%add(src%cons(i)) end do - self%optlev = src%optlev - self%micro_opt = src%micro_opt - self%maxcycle = src%maxcycle - self%maxdispl_opt = src%maxdispl_opt - self%hlow_opt = src%hlow_opt - self%hmax_opt = src%hmax_opt - self%acc_opt = src%acc_opt - self%exact_rf = src%exact_rf - self%average_conv = src%average_conv - self%tsopt = src%tsopt - self%iupdat = src%iupdat - - self%pr_energies = src%pr_energies - self%eout_unit = src%eout_unit - self%elog = src%elog - +!&> + self%optnewinit = src%optnewinit + self%anopt = src%anopt + self%optlev = src%optlev + self%micro_opt = src%micro_opt + self%maxcycle = src%maxcycle + self%maxdispl_opt = src%maxdispl_opt + self%ethr_opt = src%ethr_opt + self%gthr_opt = src%gthr_opt + self%hlow_opt = src%hlow_opt + self%hmax_opt = src%hmax_opt + self%acc_opt = src%acc_opt + self%maxerise = src%maxerise + self%hguess = src%hguess + self%exact_rf = src%exact_rf + self%average_conv = src%average_conv + self%tsopt = src%tsopt + self%iupdat = src%iupdat + self%opt_engine = src%opt_engine + self%lbfgs_histsize = src%lbfgs_histsize + + self%pr_energies = src%pr_energies + self%eout_unit = src%eout_unit + self%elog = src%elog +!&< return end subroutine calculation_copy @@ -980,6 +991,53 @@ subroutine calculation_settings_deallocate(self) return end subroutine calculation_settings_deallocate + subroutine calculation_settings_copy(self,src) + implicit none + class(calculation_settings),intent(out) :: self + type(calculation_settings) :: src + +!&> + if (allocated(src%calcspace)) self%calcspace = src%calcspace + if (allocated(src%calcfile)) self%calcfile = src%calcfile + if (allocated(src%gradfile)) self%gradfile = src%gradfile + if (allocated(src%path)) self%path = src%path + if (allocated(src%other)) self%other = src%other + if (allocated(src%binary)) self%binary = src%binary + if (allocated(src%systemcall)) self%systemcall = src%systemcall + if (allocated(src%description)) self%description = src%description + if (allocated(src%gradkey)) self%gradkey = src%gradkey + if (allocated(src%efile)) self%efile = src%efile + if (allocated(src%solvmodel)) self%solvmodel = src%solvmodel + if (allocated(src%solvent)) self%solvent = src%solvent + + self%id = src%id + self%prch = src%prch + self%chrg = src%chrg + self%uhf = src%uhf + + self%rdwbo = src%rdwbo + self%rddip = src%rddip + self%rddipgrad = src%rddipgrad + self%gradtype = src%gradtype + self%gradfmt = src%gradfmt + + self%tblitelvl = src%tblitelvl + self%etemp = src%etemp + self%accuracy = src%accuracy + self%apiclean = src%apiclean + self%maxscc = src%maxscc + self%saveint = src%saveint + + self%ngrid = src%ngrid + self%extpressure = src%extpressure + self%proberad = src%proberad + + self%ONIOM_highlowroot = src%ONIOM_highlowroot + self%ONIOM_id = src%ONIOM_id +!&< + return + end subroutine calculation_settings_copy + !=========================================================================================! subroutine calculation_settings_addconfig(self,config) diff --git a/src/molbuilder/construct_list.f90 b/src/molbuilder/construct_list.f90 index 5920546d..abe101eb 100644 --- a/src/molbuilder/construct_list.f90 +++ b/src/molbuilder/construct_list.f90 @@ -3,6 +3,7 @@ module construct_list !* Bookkeeping module for reconstructing molecules !************************************************** use crest_parameters + use crest_calculator use strucrd use quicksort_interface,only:qqsorti implicit none @@ -39,6 +40,7 @@ module construct_list integer :: duplicate_of_queue = 0 character(len=:),allocatable :: workdir character(len=:),allocatable :: file + type(calcdata) :: calc end type construct_queue type :: construct_heap From e26f45deae0292d6bafd2c7eaff63a6e09272a52 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 13 Jan 2026 21:57:15 +0100 Subject: [PATCH 131/374] deactivate restartlog for now... it is not working and messing with internal memory --- src/algos/parallel.f90 | 5 +++-- src/algos/queueing.f90 | 5 +++-- src/classes.f90 | 2 +- src/crest_main.f90 | 3 +++ src/restartlog.f90 | 2 ++ 5 files changed, 12 insertions(+), 5 deletions(-) diff --git a/src/algos/parallel.f90 b/src/algos/parallel.f90 index 68b89ff9..5d2f40c1 100644 --- a/src/algos/parallel.f90 +++ b/src/algos/parallel.f90 @@ -306,11 +306,12 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) nested = env%omp_allow_nested !>--- prepare objects for parallelization - allocate (calculations(T),source=mycalc) + allocate (calculations(T))!,source=mycalc) allocate (mols(T),molsnew(T)) do i = 1,T + call calculations(i)%copy(mycalc) do j = 1,mycalc%ncalculations - calculations(i)%calcs(j) = mycalc%calcs(j) + !calculations(i)%calcs(j) = mycalc%calcs(j) !>--- directories and io preparation ex = directory_exist(mycalc%calcs(j)%calcspace) if (.not.ex) then diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 08ad3313..4da06ca1 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -160,7 +160,7 @@ subroutine crest_queue_iter(env,iterate) use strucrd use iomod implicit none - type(systemdata),intent(inout) :: env + type(systemdata),intent(inout),target :: env logical,intent(out) :: iterate integer :: ii,jj,kk,io type(coord) :: mol @@ -216,7 +216,8 @@ subroutine crest_queue_iter(env,iterate) if(allocated(env%ref%wbo)) deallocate(env%ref%wbo) env%nat = mol%nat env%rednat = mol%nat - call env%calc%copy(queue%calc) + + env%calc => queue%calc end associate if (ii < env%splitheap%nqueue) then diff --git a/src/classes.f90 b/src/classes.f90 index d2dcbc5e..3eafff71 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -512,7 +512,7 @@ module crest_data !================================================! !>--- Calculation settings for newer implementations (version >= 3.0) - type(calcdata) :: calc + type(calcdata),pointer :: calc type(mddata) :: mddat type(bh_class),allocatable :: bh_ref !>--- rigidconf data diff --git a/src/crest_main.f90 b/src/crest_main.f90 index c7041d9b..02478c65 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -24,10 +24,12 @@ program CREST ! use iso_fortran_env,wp => real64 use crest_parameters !> Datatypes and constants use crest_data !> module for the main data storage (imports systemdata and timer) + use crest_calculator use crest_restartlog USE,INTRINSIC :: IEEE_EXCEPTIONS implicit none type(systemdata) :: env !> MAIN STORAGE OF SYSTEM DATA + type(calcdata),target :: calc_origin type(timer) :: tim !> timer object integer :: i,j,l,args,io @@ -47,6 +49,7 @@ program CREST !> Initialize system clock time call tim%init(20) + env%calc => calc_origin !=========================================================================================! !> set defaults and pars flags args = iargc() diff --git a/src/restartlog.f90 b/src/restartlog.f90 index 731c1387..1128a69d 100644 --- a/src/restartlog.f90 +++ b/src/restartlog.f90 @@ -78,6 +78,8 @@ function trackrestart(env) result(skip) logical :: skip type(systemdata),intent(in),optional :: env skip = .false. + return + restart_tracker = restart_tracker+1 if (debug) write (stdout,*) '%%% RESTART_TRACKER =',restart_tracker From 131304a0a932d5233a74f3790da7b0b82b1fbde2 Mon Sep 17 00:00:00 2001 From: LukasRindt Date: Wed, 14 Jan 2026 12:57:53 +0100 Subject: [PATCH 132/374] gfnff hr guess implemented and rfo gd fixed --- src/calculator/CMakeLists.txt | 1 + src/calculator/calc_type.f90 | 1 + src/calculator/hessian_reconstruct.f90 | 131 ++----------------------- src/calculator/hr_utils.f90 | 41 ++++++++ src/optimize/optimize_module.f90 | 19 +++- src/optimize/rfo.f90 | 13 ++- src/parsing/parse_calcdata.f90 | 14 +++ subprojects/tblite | 2 +- 8 files changed, 92 insertions(+), 130 deletions(-) create mode 100644 src/calculator/hr_utils.f90 diff --git a/src/calculator/CMakeLists.txt b/src/calculator/CMakeLists.txt index 7be9f663..f285fda5 100644 --- a/src/calculator/CMakeLists.txt +++ b/src/calculator/CMakeLists.txt @@ -40,6 +40,7 @@ list(APPEND srcs "${dir}/turbom_sc.f90" "${dir}/subprocess_engrad.f90" "${dir}/hessian_reconstruct.f90" + "${dir}/hr_utils.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 3683e1f8..445ebb6f 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -279,6 +279,7 @@ module calc_type real(wp),allocatable :: temperatures(:) real(wp),allocatable :: et(:),ht(:),gt(:),stot(:) real(wp) :: ithr,fscal,sthr + integer :: initialize_hr_type !> case defining initialization !>--- Parameters for smooth function within optimizer real(wp) :: L = 1.50_wp diff --git a/src/calculator/hessian_reconstruct.f90 b/src/calculator/hessian_reconstruct.f90 index bfe7ec13..dfcf2be6 100644 --- a/src/calculator/hessian_reconstruct.f90 +++ b/src/calculator/hessian_reconstruct.f90 @@ -6,7 +6,7 @@ module hessian_reconstruct implicit none private - public cashed_hessian,invert_matrix + public cashed_hessian type :: cashed_hessian @@ -20,28 +20,28 @@ module hessian_reconstruct real(wp) :: hguess = 0.02_wp real(wp),allocatable ::hguess_mat(:,:) logical :: track_step = .true. + integer :: initialize_type = 0 contains procedure :: alloc => cashed_hessian_allocate procedure :: dealloc => cashed_hessian_deallocate procedure :: update => update_cashed_hessian - procedure :: construct_hessian_lbfgs - procedure :: compute_intermediates procedure :: construct_hessian_bfgs end type cashed_hessian contains - subroutine cashed_hessian_allocate(self,N,steps,hguess) !> maybe make keywords optional later - integer,intent(in) :: N,steps + subroutine cashed_hessian_allocate(self,N,steps,hguess,initialize_type) !> maybe make keywords optional later + integer,intent(in) :: N,steps, initialize_type class(cashed_hessian),intent(inout) :: self real(wp),intent(in) :: hguess self%steps = steps self%hguess = hguess self%natm = N + self%initialize_type = initialize_type allocate (self%gradient(steps,3,N)) allocate (self%coords(steps,3,N)) allocate (self%energy(steps)) @@ -111,13 +111,10 @@ subroutine construct_hessian_bfgs(self) tmp_coords = reshape(self%coords, [self%steps,nat3]) tmp_grads = reshape(self%gradient, [self%steps,nat3]) - do k = 1,nat3 - self%hguess_mat(k,k) = self%hguess - end do - call dsqtoh(nat3,self%hguess_mat,hess) - made_iters = self%steps + call dsqtoh(nat3,self%hguess_mat,hess) !> Here, Hessian is packed and transferred to hess + if (minval(tmp) == 0) then !> Implement keyword like exact HU that kills the process made_iters = maxval(tmp) !> if made_iters refactor this to reduce memory by - class(cashed_hessian),intent(inout) :: self !> computing intermediates within this routine - integer,intent(in) :: n - real(wp),allocatable :: temp(:,:) - !real(wp), allocatable :: test_mat(:,:) - - !allocate (test_mat(3*self%natm,3*self%natm)) - - allocate (temp(3*self%natm,3*self%natm)) - if (n == 0) then - call self%compute_intermediates() - allocate (self%B(3*self%natm,3*self%natm)) - self%B = self%hguess - else - call self%construct_hessian_lbfgs(n-1) - temp = matmul(matmul(TRANSPOSE(self%V(n,:,:)),self%B),self%V(n,:,:))+self%p(n)*(matmul(reshape(self%s(n,:), [3*self%natm,1]),reshape(self%s(n,:), [1,3*self%natm]))) - self%B = temp - print* - print*,"updated Hessian number",N - print* - print*,temp(1,:) - end if - - end subroutine construct_hessian_lbfgs - - subroutine compute_intermediates(self) - class(cashed_hessian),intent(inout) :: self - integer :: i,j,k,l - real(wp),allocatable :: tmp(:),tmp_coords(:,:),tmp_grads(:,:) - real(wp),allocatable :: temp_mat(:,:) - - allocate (temp_mat(3*self%natm,3*self%natm)) - - allocate (tmp_coords(self%steps,3*self%natm)) - allocate (tmp_grads(self%steps,3*self%natm)) - allocate (tmp(self%steps)) - - tmp = self%order - self%I = 0.0_wp - - do k = 1,3*self%natm - self%I(k,k) = 1.0_wp - end do - - self%hguess_mat = 0.0_wp - - do l = 1,3*self%natm - self%hguess_mat = self%hguess - end do - - tmp_coords = reshape(self%coords, [self%steps,3*self%natm]) - tmp_grads = reshape(self%gradient, [self%steps,3*self%natm]) - - if (minval(tmp) == 0) then - print*,"ERROR: Number of recursive steps for hessian reconstruction larger than number of geoemtry optimization steps!" - else - do i = 1,self%steps - if (i == 1) then - j = minloc(tmp,1) - tmp(j) = HUGE(tmp(j)) - else - j = minloc(tmp,1) - if (j == 1) then - self%s(i-1,:) = tmp_coords(j,:)-tmp_coords(self%steps,:) - self%y(i-1,:) = tmp_grads(j,:)-tmp_grads(self%steps,:) - else - self%s(i-1,:) = tmp_coords(j,:)-tmp_coords(j-1,:) - self%y(i-1,:) = tmp_grads(j,:)-tmp_grads(j-1,:) - end if - self%p(i-1) = 1/(dot_product(self%y(i-1,:),self%s(i-1,:))) - self%V(i-1,:,:) = (self%I(:,:))-(self%p(i-1)*(matmul(reshape(self%y(i-1,:), [3*self%natm,1]),reshape(self%s(i-1,:), [1,3*self%natm])))) - tmp(j) = HUGE(tmp(j)) - !temp_mat = self%p(i-1)*(matmul(reshape(self%y(i-1,:), [3*self%natm,1]),reshape(self%s(i-1,:), [1,3*self%natm]))) - end if - end do - end if - - end subroutine compute_intermediates - - ! Returns the inverse of a matrix calculated by finding the LU -! decomposition. Depends on LAPACK. - function invert_matrix(A) result(Ainv) - real(wp),dimension(:,:),intent(in) :: A - real(wp),dimension(size(A,1),size(A,2)) :: Ainv - - real(wp),dimension(size(A,1)) :: work ! work array for LAPACK - integer,dimension(size(A,1)) :: ipiv ! pivot indices - integer :: n,info - - ! External procedures defined in LAPACK - external DGETRF - external DGETRI - - ! Store A in Ainv to prevent it from being overwritten by LAPACK - Ainv = A - n = size(A,1) - - ! DGETRF computes an LU factorization of a general M-by-N matrix A - ! using partial pivoting with row interchanges. - call DGETRF(n,n,Ainv,n,ipiv,info) - - if (info /= 0) then - stop 'Matrix is numerically singular!' - end if - - ! DGETRI computes the inverse of a matrix using the LU factorization - ! computed by DGETRF. - call DGETRI(n,Ainv,n,ipiv,work,n,info) - - if (info /= 0) then - stop 'Matrix inversion failed!' - end if - end function invert_matrix - end module hessian_reconstruct diff --git a/src/calculator/hr_utils.f90 b/src/calculator/hr_utils.f90 new file mode 100644 index 00000000..2ab67abe --- /dev/null +++ b/src/calculator/hr_utils.f90 @@ -0,0 +1,41 @@ +module hr_utils + use iso_fortran_env,only:wp => real64 + use crest_calculator + use crest_parameters + implicit none + private + + public hr_initialize_hessian + +contains + +subroutine hr_initialize_hessian(calc,at) + type(calcdata),intent(inout) :: calc + type(calcdata) :: newcalc + type(calculation_settings) :: clevel + integer :: k,idx,io, nat3 + integer, intent(in) :: at(:) + + nat3 = 3*calc%chess%natm + idx = minloc(calc%chess%order,1) !>gives location of first geometry that is saved + + !>initialize_type: 0 for scaled identity, 1 for gfnff guess, 2 for gfn2 guess + +select case (calc%chess%initialize_type) +case(0) + calc%chess%hguess_mat = 0.0_wp + do k = 1,nat3 + calc%chess%hguess_mat(k,k) = calc%chess%hguess + end do +case(1) + call clevel%create('gfnff', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? + call newcalc%add(clevel) + call numhess1(calc%chess%natm,at,calc%chess%coords(idx,:,:),newcalc,calc%chess%hguess_mat(:,:),io) +case(2) + call clevel%create('gfn2', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? + call newcalc%add(clevel) + call numhess1(calc%chess%natm,at,calc%chess%coords(idx,:,:),newcalc,calc%chess%hguess_mat(:,:),io) +end select +end subroutine hr_initialize_hessian + +end module hr_utils \ No newline at end of file diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index afaf0a20..eca03a5a 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -36,6 +36,7 @@ module optimize_module use thermochem_module use hessian_reconstruct use newton_raphson_module + use hr_utils !use hessian_tools implicit none private @@ -61,10 +62,11 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) integer,intent(out) :: iostatus real(wp),intent(inout) :: etot real(wp),intent(inout) :: grd(3,mol%nat) - real(wp),allocatable :: H_inv(:,:),freq(:) + real(wp),allocatable :: H_init(:,:),freq(:) integer :: nat3 integer :: io + iostatus = -1 !> do NOT overwrite original geometry !$omp critical @@ -84,7 +86,8 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) !> Check if Hessian Reconstruct is called and initialize the type if (calc%do_HR) then allocate (calc%chess) - call calc%chess%alloc(mol%nat,calc%hu_steps,calc%hguess) + allocate (H_init(nat3,nat3)) + call calc%chess%alloc(mol%nat,calc%hu_steps,calc%hguess,calc%initialize_hr_type) end if !> initial singlepoint @@ -114,7 +117,7 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) end select molnew%energy = etot - if (calc%do_HR) then !> Hessian construction and post-processing happen here + if (calc%do_HR .and. iostatus .eq. 0) then !> Hessian construction and post-processing happen here, only do it if geometry relaxation successful if (calc%full_HR) then write (stdout,*) @@ -126,7 +129,15 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) & calc%ht,calc%gt,calc%stot,etot) else - + + call hr_initialize_hessian(calc, molnew%at) + write(stdout,*) + write(stdout,*)"THERMO FROM INITIALIZED HESSIAN:" + write(stdout,*) + H_init(:,:) = calc%chess%hguess_mat(:,:) + call calc_thermo_from_hess(molnew,H_init,pr, & + & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & + & calc%ht,calc%gt,calc%stot,etot) call calc%chess%construct_hessian_bfgs() write (stdout,*) diff --git a/src/optimize/rfo.f90 b/src/optimize/rfo.f90 index 3f7bb3bb..6e11c510 100644 --- a/src/optimize/rfo.f90 +++ b/src/optimize/rfo.f90 @@ -368,7 +368,18 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !>--- choose solver for the RF eigenvalue problem if (exact.or.nvar1 .lt. 50) then - call solver_dspevx(nvar1,r4dum,Aaug,Uaug,eaug,fail) + if (iter .eq. 1) then + Uaug(:,1) = [-grd1(1:OPT%nvar),1.0_wp] + dsnrm = sqrt(ddot(nvar1,Uaug,1,Uaug,1)) + Uaug = Uaug/dsnrm + else + write(stdout,*) "Uaug before solver", Uaug + write(stdout,*) "Uaug relevant value before solver", abs(Uaug(nvar1,1)) + call solver_dspevx(nvar1,r4dum,Aaug,Uaug,eaug,fail) + write(stdout,*) "Uaug after solver", Uaug + write(stdout,*) "Uaug relevant value after solver", abs(Uaug(nvar1,1)) + write(stdout,*) "Failstatement", fail + endif else !>--- steepest decent guess for displacement if (iter .eq. 1) then diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 04fcdc34..01092633 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -598,6 +598,20 @@ subroutine parse_calc_auto(env,calc,kv,rd) call creststop(status_config) end select + case ('hr_init','hr_initialization') !> here we set how the matrix for hessian reconstruction is initialized + select case (kv%value_c) + case('identity') + calc%initialize_hr_type = 0 + case('gfnff', 'gfn-ff') + calc%initialize_hr_type = 1 + case('gfn2') + calc%initialize_hr_type = 2 + case default + !>--- keyword was recognized, but invalid argument supplied + write (stdout,fmtura) kv%value_c + call creststop(status_config) + end select + case ('freeze') call get_atlist(env%ref%nat,atlist,kv%value_c,env%ref%at) calc%nfreeze = count(atlist) diff --git a/subprojects/tblite b/subprojects/tblite index 6f6cd7d2..660d1678 160000 --- a/subprojects/tblite +++ b/subprojects/tblite @@ -1 +1 @@ -Subproject commit 6f6cd7d20d97b22ef00d420904343c7bb8e2afdf +Subproject commit 660d1678d6f36999d7ffda6e710d5ff00ff2f8ff From 4eabcfed2b1f2ccbf9224f6a21cc20b65b7521e5 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 14 Jan 2026 14:28:36 +0100 Subject: [PATCH 133/374] constraints mapping repaired --- src/algos/queueing.f90 | 119 +++++++++++++++++++++++------- src/algos/setuptest.f90 | 41 ++++++---- src/calculator/calc_type.f90 | 19 ++++- src/calculator/constraints.f90 | 42 ++++++++--- src/molbuilder/construct_list.f90 | 1 + 5 files changed, 165 insertions(+), 57 deletions(-) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 4da06ca1..22d7d050 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -89,12 +89,9 @@ subroutine crest_queue_setup(env,iterate) end do call heap%setup_queue() - !write (*,*) 'endpoints selected:' - !do ii = 1,heap%nqueue - ! write (*,*) 'layer and node',heap%queue(ii)%layer,heap%queue(ii)%node - !end do call getcwd(thispath) heap%origindir = trim(thispath) + heap%origincalc => env%calc end associate iterate = .true. end if @@ -154,15 +151,20 @@ subroutine pick_parent(heap,current_layer,splitatms,parentlayer,parentnode) end subroutine pick_parent end subroutine crest_queue_setup +!=============================================================================! +!#############################################################################! +!=============================================================================! + subroutine crest_queue_iter(env,iterate) use crest_parameters use crest_data use strucrd use iomod + use crest_calculator implicit none type(systemdata),intent(inout),target :: env logical,intent(out) :: iterate - integer :: ii,jj,kk,io + integer :: ii,jj,kk,io,nn,ll,lll,ati,atj type(coord) :: mol character(len=10) :: atmp character(len=*),parameter :: dirname = 'crest_queue_' @@ -170,42 +172,48 @@ subroutine crest_queue_iter(env,iterate) iterate = .false. if (allocated(env%splitqueue).and.env%splitheap%nqueue > 0) then +!>--- important restoring to initial calc/dir + env%calc => env%splitheap%origincalc call chdir(env%splitheap%origindir) + + !> next iter ii = env%queue_iter+1 env%queue_iter = ii + write (stdout,'(/,70("§"))') + write (stdout,'(a,i0)') "§§§ QUEUE ITERATION ",ii + write (stdout,'(70("§"))') - write(stdout,'(/,70("§"))') - write(stdout,'(a,i0)') "§§§ QUEUE ITERATION ",ii - write(stdout,'(70("§"))') - - associate (queue => env%splitheap%queue(ii)) - - jj = queue%layer - kk = queue%node + jj = env%splitheap%queue(ii)%layer + kk = env%splitheap%queue(ii)%node + associate (heap => env%splitheap,queue => env%splitheap%queue(ii)) !> create a dedicated work directory - write(atmp,'(i0)') ii + write (atmp,'(i0)') ii queue%workdir = dirname//trim(atmp) io = makedir(queue%workdir) call chdir(queue%workdir) - write(stdout,'(a,a)') 'Queue work (sub-)directory: ', & + write (stdout,'(a,a)') 'Queue work (sub-)directory: ', & & trim(queue%workdir) !> selecting output file depending on runtype - select case(env%crestver) - case ( crest_imtd,crest_imtd2 ) - queue%file = 'crest_conformers.xyz' - case ( crest_optimize ) - queue%file = 'crestopt.xyz' - case ( crest_moldyn ) - queue%file = 'crest_dynamics.trj.xyz' - case ( crest_bh ) - queue%file = 'crest_quenched.xyz' + select case (env%crestver) + case (crest_imtd,crest_imtd2) + queue%file = 'crest_conformers.xyz' + case (crest_optimize) + queue%file = 'crestopt.xyz' + case (crest_moldyn) + queue%file = 'crest_dynamics.trj.xyz' + case (crest_bh) + queue%file = 'crest_quenched.xyz' case default queue%file = 'struc.xyz' end select - call queue%calc%copy(env%calc) + +!>--- new calculator setup section and env update + call queue%calc%copy(env%calc,ignore_constraints=.true.) + !> for constraints we must be careful and map them to the new order + call update_constraints_queue(heap,jj,kk,env%calc,queue%calc) call queue%calc%info(stdout) @@ -213,7 +221,7 @@ subroutine crest_queue_iter(env,iterate) call env%ref%load(mol) call mol%write('coord') - if(allocated(env%ref%wbo)) deallocate(env%ref%wbo) + if (allocated(env%ref%wbo)) deallocate (env%ref%wbo) env%nat = mol%nat env%rednat = mol%nat @@ -224,6 +232,63 @@ subroutine crest_queue_iter(env,iterate) iterate = .true. end if - write(stdout,*) + write (stdout,*) end if + +contains + subroutine update_constraints_queue(heap,layer,node,refcalc,newcalc) + use construct_list + implicit none + type(construct_heap) :: heap + integer :: layer,node + type(calcdata),intent(in) :: refcalc + type(calcdata),intent(inout) :: newcalc + integer :: nn,ll,lll,ati,atj,nn2 + type(constraint),allocatable :: cons(:) + if (refcalc%nconstraints > 0) then + nn = refcalc%nconstraints + allocate (cons(nn)) + do ll = 1,nn + call cons(ll)%copy(refcalc%cons(ll)) + do lll = 1,cons(ll)%n + ati = cons(ll)%atms(lll) + call heap%find_current_position(ati,layer,node,atj) + cons(ll)%atms(lll) = atj !> overwrite with the current position + end do + if (any(cons(ll)%atms(:) .eq. 0)) then + cons(ll)%active = .false. + end if + end do + !> clean (active) constraints + nn2 = 0 + do ll = 1,nn + if (cons(ll)%active) nn2 = nn2+1 + end do + if (nn2 > 0) then + newcalc%nconstraints = nn2 + allocate (newcalc%cons(nn2)) + lll = 0 + do ll = 1,nn + if (cons(ll)%active) then + lll = lll+1 + call newcalc%cons(lll)%copy(cons(ll)) + end if + end do + end if + end if + end subroutine update_constraints_queue end subroutine crest_queue_iter + +!=============================================================================! +!#############################################################################! +!=============================================================================! + +subroutine crest_queue_reconstruct(env,tim) + use crest_parameters + use crest_data + implicit none + type(systemdata),intent(inout) :: env + type(timer),intent(inout) :: tim + +end subroutine crest_queue_reconstruct + diff --git a/src/algos/setuptest.f90 b/src/algos/setuptest.f90 index 7d12b8e2..ba322064 100644 --- a/src/algos/setuptest.f90 +++ b/src/algos/setuptest.f90 @@ -60,10 +60,10 @@ subroutine trialMD_calculator(env) type(timer) :: profiler type(calcdata) :: tmpcalc - type(calcdata) :: calcstart + type(calcdata),allocatable :: calcstart(:) real(wp) :: energy real(wp),allocatable :: grd(:,:) - integer :: T,Tn + integer :: T,Tn,ii character(len=*),parameter :: dirnam = 'TRIALMD' !>--- OMP settings (should be set to 1 to simulate max parallelization) @@ -91,10 +91,10 @@ subroutine trialMD_calculator(env) tmpcalc = env%calc mol = molstart tmpcalc%calcs(1)%rdwbo = .true. !> obtain WBOs - allocate(grd(3,mol%nat)) + allocate (grd(3,mol%nat)) call engrad(mol,tmpcalc,energy,grd,io) - call move_alloc(tmpcalc%calcs(1)%wbo, env%ref%wbo) - deallocate(grd) + call move_alloc(tmpcalc%calcs(1)%wbo,env%ref%wbo) + deallocate (grd) call tmpcalc%reset() MDSTART%shk%wbo = env%ref%wbo end if @@ -105,8 +105,6 @@ subroutine trialMD_calculator(env) MTD%mtdtype = cv_rmsd MTD%cvdump_fs = 550.0_wp call MDSTART%add(MTD) - calcstart = env%calc !> Save clean state before loop - pr = .false. !> supress stdout printout of MD !>--- Header @@ -116,6 +114,13 @@ subroutine trialMD_calculator(env) !>--- Iterative loop, since it is also tested if the MD runs at all counter = 1 maxiter = 6 + +!>--- temporary clean calculation storage per iteration + allocate (calcstart(maxiter)) + do ii = 1,maxiter + call calcstart(ii)%copy(env%calc) + end do + tstep = MDSTART%tstep shakemode = MDSTART%shk%shake_mode call profiler%init(maxiter) @@ -124,7 +129,9 @@ subroutine trialMD_calculator(env) !>--- Restore initial starting geometry mol = molstart !>--- Restore clean calculation state - env%calc = calcstart + !env%calc = calcstart + !call env%calc%copy(calcstart) + !>--- Modify MD output trajectory MD = MDSTART MD%tstep = tstep @@ -137,7 +144,7 @@ subroutine trialMD_calculator(env) io = 1 !================================! call profiler%start(counter) - call dynamics(mol,MD,env%calc,pr,io) + call dynamics(mol,MD,calcstart(counter),pr,io) call profiler%stop(counter) !================================! @@ -181,6 +188,8 @@ subroutine trialMD_calculator(env) !>--- End loop end do iterativ + deallocate(calcstart) + !>--- transfer final settings to global settings env%mdstep = MD%tstep env%mddat%tstep = MD%tstep @@ -302,28 +311,28 @@ subroutine trialOPT_calculator(env) !>--- setup call env%ref%to(mol) call env%ref%to(molopt) - allocate(grd(3,mol%nat), source=0.0_wp) + allocate (grd(3,mol%nat),source=0.0_wp) tmpcalc = env%calc !> create copy of calculator - tmpcalc%optlev = -1 !> set loose convergence thresholds + tmpcalc%optlev = -1 !> set loose convergence thresholds !>--- perform geometry optimization pr = .false. !> stdout printout wr = .true. !> write crestopt.log.xyz - if(wr)then + if (wr) then call remove('crestopt.log.xyz') - endif + end if call optimize_geometry(mol,molopt,tmpcalc,energy,grd,pr,wr,io) -!>--- check success +!>--- check success success = (io == 0) call trialOPT_warning(env,molopt,success) !>--- if the checks were successfull, env%ref is overwritten env%ref%nat = molopt%nat env%ref%at = molopt%at env%ref%xyz = molopt%xyz - env%ref%etot = energy + env%ref%etot = energy - deallocate(grd) + deallocate (grd) end subroutine trialOPT_calculator !========================================================================================! diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 47c993eb..d694e01e 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -538,27 +538,36 @@ end subroutine calculation_init !=========================================================================================! !> copy a calcdata object from src to self - subroutine calculation_copy(self,src) + subroutine calculation_copy(self,src,ignore_constraints) class(calcdata) :: self - type(calcdata) :: src + type(calcdata),intent(in) :: src + logical,intent(in),optional :: ignore_constraints type(calculation_settings) :: newset + type(constraint) :: newcons integer :: i + logical :: igno call self%reset() self%id = src%id if (allocated(self%calcs)) deallocate (self%calcs) - !self%calcs = src%calcs + self%ncalculations = 0 do i = 1,src%ncalculations call newset%copy(src%calcs(i)) call self%add(newset) end do + igno = .false. + if(present(ignore_constraints)) igno = ignore_constraints if (allocated(self%cons)) deallocate (self%cons) + self%nconstraints = 0 + if(.not.igno)then do i = 1,src%nconstraints - call self%add(src%cons(i)) + call newcons%copy(src%cons(i)) + call self%add(newcons) end do + endif !&> self%optnewinit = src%optnewinit @@ -883,11 +892,13 @@ subroutine calculation_info(self,iunit) write (iunit,'("> ",a)') 'User-defined constraints:' if (self%nconstraints <= 20) then do i = 1,self%nconstraints + if (.not.self%cons(i)%active) cycle call self%cons(i)%print(iunit) end do else constraintype(:) = 0 do i = 1,self%nconstraints + if (.not.self%cons(i)%active) cycle j = self%cons(i)%type if (j > 0.and.j < 9) then constraintype(j) = constraintype(j)+1 diff --git a/src/calculator/constraints.f90 b/src/calculator/constraints.f90 index c4629213..a36f3160 100644 --- a/src/calculator/constraints.f90 +++ b/src/calculator/constraints.f90 @@ -82,6 +82,7 @@ module constraints contains procedure :: print => print_constraint procedure :: deallocate => constraint_deallocate + procedure :: copy => constraint_copy procedure :: bondconstraint => create_bond_constraint generic,public :: sphereconstraint => create_sphere_constraint,create_sphere_constraint_all procedure,private :: create_sphere_constraint,create_sphere_constraint_all @@ -154,7 +155,7 @@ subroutine complete_defaults(self,mol) if (self%n .ne. 2) error stop '*** ERROR *** wrong number of atoms for bondrange constraint' if (.not.allocated(self%fc)) then allocate (self%fc(2)) - self%fc(1) = fcdefault/kB !> bondrange doesn't use 300K default! + self%fc(1) = fcdefault/kB !> bondrange doesn't use 300K default! self%fc(2) = betadefault else if (size(self%fc) < 2) error stop '*** ERROR *** wrong number of parameters for bondrange constraint' @@ -165,7 +166,7 @@ subroutine complete_defaults(self,mol) self%ref(2) = self%ref(1)-1.0_wp else dummy = minval(self%ref(:)) - self%ref(1) = maxval(self%ref(:)) + self%ref(1) = maxval(self%ref(:)) self%ref(2) = dummy end if @@ -288,7 +289,7 @@ subroutine calc_constraint(n,xyz,constr,energy,grd) energy = 0.0_wp grd = 0.0_wp - if(.not.constr%active) return + if (.not.constr%active) return select case (constr%type) case (bond) @@ -324,7 +325,7 @@ subroutine print_constraint(self,chnl) character(len=10) :: atm integer :: chnl logical :: pr - character(len=*),parameter :: headfmt ='("> constraint: ",a,a)' + character(len=*),parameter :: headfmt = '("> constraint: ",a,a)' if (self%type == 0) return pr = .true. select case (self%type) @@ -469,6 +470,27 @@ subroutine constraint_deallocate(self) return end subroutine constraint_deallocate + subroutine constraint_copy(self,src) + implicit none + class(constraint) :: self + type(constraint) :: src +!&> + if (allocated(src%atms )) self%atms = src%atms + if (allocated(src%ref )) self%ref = src%ref + if (allocated(src%fc )) self%fc = src%fc + self%active = src%active + self%type = src%type + self%n = src%n + self%frozenatms = src%frozenatms + if(src%frozenatms)then + call self%addfreeze(src%freezeptr) + endif + self%wscal = src%wscal + self%subtype = src%subtype +!&< + return + end subroutine constraint_copy + !========================================================================================! !> subroutine constraint_freezeassoc !> associate the freezeptr @@ -1082,10 +1104,10 @@ subroutine create_sphere_constraint(self,n,atms,r,k,alpha,logfermi) allocate (self%ref(3),source=r) ii = 0 do i = 1,n - if (atms(i))then - ii = ii +1 + if (atms(i)) then + ii = ii+1 self%atms(ii) = i - endif + end if end do self%ref(:) = r self%fc(1) = k @@ -1116,10 +1138,10 @@ subroutine create_ellips_constraint(self,n,atms,r,k,alpha,logfermi) allocate (self%ref(3),source=r) ii = 0 do i = 1,n - if (atms(i))then - ii = ii +1 + if (atms(i)) then + ii = ii+1 self%atms(ii) = i - endif + end if end do self%ref(:) = r(:) self%fc(1) = k diff --git a/src/molbuilder/construct_list.f90 b/src/molbuilder/construct_list.f90 index abe101eb..50a9fc09 100644 --- a/src/molbuilder/construct_list.f90 +++ b/src/molbuilder/construct_list.f90 @@ -52,6 +52,7 @@ module construct_list type(construct_queue),allocatable :: queue(:) !> originial directory character(len=:),allocatable :: origindir + type(calcdata),pointer :: origincalc contains procedure map_origins_for_layer procedure find_current_position From 1034af3b863aa725edd114b8f9df581cf86ceb3b Mon Sep 17 00:00:00 2001 From: LukasRindt Date: Thu, 15 Jan 2026 13:20:34 +0100 Subject: [PATCH 134/374] minor printout change --- src/optimize/rfo.f90 | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/optimize/rfo.f90 b/src/optimize/rfo.f90 index 6e11c510..8b72ae5a 100644 --- a/src/optimize/rfo.f90 +++ b/src/optimize/rfo.f90 @@ -373,12 +373,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) dsnrm = sqrt(ddot(nvar1,Uaug,1,Uaug,1)) Uaug = Uaug/dsnrm else - write(stdout,*) "Uaug before solver", Uaug - write(stdout,*) "Uaug relevant value before solver", abs(Uaug(nvar1,1)) call solver_dspevx(nvar1,r4dum,Aaug,Uaug,eaug,fail) - write(stdout,*) "Uaug after solver", Uaug - write(stdout,*) "Uaug relevant value after solver", abs(Uaug(nvar1,1)) - write(stdout,*) "Failstatement", fail endif else !>--- steepest decent guess for displacement From 2bb972d358ea43ebc0ea775760092050b85b1473 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 15 Jan 2026 15:57:20 +0100 Subject: [PATCH 135/374] start work on reconstruction --- src/algos/queueing.f90 | 102 ++++++++++++++++++++++++++++-- src/crest_main.f90 | 3 + src/molbuilder/construct_list.f90 | 6 +- 3 files changed, 104 insertions(+), 7 deletions(-) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 22d7d050..162ecc7d 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -90,6 +90,7 @@ subroutine crest_queue_setup(env,iterate) call heap%setup_queue() call getcwd(thispath) + call env%ref%to(heap%originmol) heap%origindir = trim(thispath) heap%origincalc => env%calc end associate @@ -120,7 +121,8 @@ subroutine pick_parent(heap,current_layer,splitatms,parentlayer,parentnode) do ii = 1,heap%layer(prev_layer)%nnodes matching = .true. do jj = 1,size(splitatms,1) - matching = matching.and.any(heap%layer(prev_layer)%origin(ii)%map(:) .eq. splitatms(jj)) + matching = matching.and. & + & any(heap%layer(prev_layer)%origin(ii)%map(:) .eq. splitatms(jj)) end do if (matching) then parentlayer = prev_layer @@ -151,9 +153,9 @@ subroutine pick_parent(heap,current_layer,splitatms,parentlayer,parentnode) end subroutine pick_parent end subroutine crest_queue_setup -!=============================================================================! -!#############################################################################! -!=============================================================================! +!=============================================================================! +!#############################################################################! +!=============================================================================! subroutine crest_queue_iter(env,iterate) use crest_parameters @@ -193,7 +195,7 @@ subroutine crest_queue_iter(env,iterate) queue%workdir = dirname//trim(atmp) io = makedir(queue%workdir) call chdir(queue%workdir) - write (stdout,'(a,a)') 'Queue work (sub-)directory: ', & + write (stdout,'(a,t28,a,t30,a)') 'Queue work (sub-)directory',':', & & trim(queue%workdir) !> selecting output file depending on runtype @@ -209,6 +211,7 @@ subroutine crest_queue_iter(env,iterate) case default queue%file = 'struc.xyz' end select + write (stdout,'(a,t28,a,t30,a)') 'Selected output file',':',queue%file !>--- new calculator setup section and env update call queue%calc%copy(env%calc,ignore_constraints=.true.) @@ -286,9 +289,98 @@ end subroutine crest_queue_iter subroutine crest_queue_reconstruct(env,tim) use crest_parameters use crest_data + use construct_list + use strucrd implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim + type(coord) :: mol + + if (.not. (allocated(env%splitqueue).and.env%splitheap%nqueue > 0)) then + return + end if + + write (stdout,'(/,80("#"))') + write (stdout,'(3("#"),t25,a,t78,3("#"))') 'QUEUE STRUCTURE RECONSTRUCTION' + write (stdout,'(80("#"),/)') + + !> reset + mol = env%splitheap%originmol + call env%ref%load(mol) + env%nat = mol%nat + env%rednat = mol%nat + env%calc => env%splitheap%origincalc + call chdir(env%splitheap%origindir) + + call recusrive_construct(env,env%splitheap,1) + +contains + recursive subroutine recusrive_construct(env,heap,targetlayer) + implicit none + type(systemdata),intent(inout) :: env + type(construct_heap),intent(inout) :: heap + integer,intent(in) :: targetlayer + + integer :: ii,jj + character(len=:),allocatable :: basefile,sidefile + type(coord),allocatable :: structures_b(:) + type(coord),allocatable :: structures_s(:) + integer :: nall_b,nall_s,id_b,id_s + logical :: ex + + character(len=*),parameter :: subdir_tmp = 'crest_queue_' + character(len=:),allocatable :: subdirfile + character(len=10) :: atmp + + associate (layer => heap%layer(targetlayer)) + if (layer%nnodes > 2) then + write (stdout,'(a)') 'currently unhandled edge-case in layer reconstruction:' + write (stdout,'(a,i0,a)') 'layer ',targetlayer,' was split in more than 2 structures' + stop + end if + + if (.not.allocated(layer%childlayer).or. & + & all(layer%childlayer(:) .eq. 0)) then + !> saveguard to not reconstruct layer multiple times + if (layer%nmols > 0) return + + !> pick base an side-group files + do ii = 1,heap%nqueue + if (heap%queue(ii)%layer == targetlayer.and.heap%queue(ii)%node == 1) then + basefile = heap%queue(ii)%file + id_b = ii + else if (heap%queue(ii)%layer == targetlayer.and.heap%queue(ii)%node == 2) then + sidefile = heap%queue(ii)%file + id_s = ii + end if + end do + + write (atmp,'(i0)') id_b + subdirfile = subdir_tmp//trim(atmp)//'/'//basefile + inquire (exist=ex,file=subdirfile) + if (ex) then + write (stdout,'(a,t28,a,t30,a)') 'Reading fragment(s) from',':',subdirfile + call rdensemble(subdirfile,nall_b,structures_b) + end if + + write (atmp,'(i0)') id_s + subdirfile = subdir_tmp//trim(atmp)//'/'//sidefile + inquire (exist=ex,file=subdirfile) + if (ex) then + write (stdout,'(a,t28,a,t30,a)') 'Reading fragment(s) from',':',subdirfile + call rdensemble(subdirfile,nall_s,structures_s) + end if + + else + do ii = 1,layer%nnodes + jj = layer%childlayer(ii) + if (jj == 0) cycle + call recusrive_construct(env,heap,jj) + end do + end if + + end associate + end subroutine recusrive_construct end subroutine crest_queue_reconstruct diff --git a/src/crest_main.f90 b/src/crest_main.f90 index 02478c65..f385a7c7 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -316,6 +316,9 @@ program CREST end do ITERATOR + call crest_queue_reconstruct(env,tim) + + !=========================================================================================! !> ADDITIONAL OUTPUT FORMATTING !=========================================================================================! diff --git a/src/molbuilder/construct_list.f90 b/src/molbuilder/construct_list.f90 index 50a9fc09..7dbcedf7 100644 --- a/src/molbuilder/construct_list.f90 +++ b/src/molbuilder/construct_list.f90 @@ -31,7 +31,8 @@ module construct_list integer,allocatable :: position_mapping(:,:) type(origin_map),allocatable :: origin(:) !> initial/reconstructed molecule - type(coord) :: mol + integer :: nmols = 0 + type(coord),allocatable :: mols(:) end type construct_layer type :: construct_queue @@ -50,7 +51,8 @@ module construct_list !> the queue to treat endpoints integer :: nqueue = 0 type(construct_queue),allocatable :: queue(:) - !> originial directory + !> originial data + type(coord) :: originmol character(len=:),allocatable :: origindir type(calcdata),pointer :: origincalc contains From 6946575bb2d0795cc600b0deaf0facdd127c102f Mon Sep 17 00:00:00 2001 From: LukasRindt Date: Fri, 16 Jan 2026 11:25:04 +0100 Subject: [PATCH 136/374] LAPACK error fixed --- src/optimize/rfo.f90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/optimize/rfo.f90 b/src/optimize/rfo.f90 index 8b72ae5a..bacf2f79 100644 --- a/src/optimize/rfo.f90 +++ b/src/optimize/rfo.f90 @@ -368,13 +368,13 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !>--- choose solver for the RF eigenvalue problem if (exact.or.nvar1 .lt. 50) then - if (iter .eq. 1) then - Uaug(:,1) = [-grd1(1:OPT%nvar),1.0_wp] - dsnrm = sqrt(ddot(nvar1,Uaug,1,Uaug,1)) - Uaug = Uaug/dsnrm - else - call solver_dspevx(nvar1,r4dum,Aaug,Uaug,eaug,fail) - endif + !if (iter .eq. 1) Uaug(:,1) = 0.0_wp + ! Uaug(:,1) = [-grd1(1:OPT%nvar),1.0_wp] + ! dsnrm = sqrt(ddot(nvar1,Uaug,1,Uaug,1)) + ! Uaug = Uaug/dsnrm + !else + call solver_dspevx(nvar1,0.0_wp,Aaug,Uaug,eaug,fail) + !endif else !>--- steepest decent guess for displacement if (iter .eq. 1) then From bd011b1f7ff10354326048f09973cb71b1541743 Mon Sep 17 00:00:00 2001 From: LukasRindt Date: Fri, 16 Jan 2026 18:10:42 +0100 Subject: [PATCH 137/374] Hessian initialization added --- src/calculator/calc_type.f90 | 1 + src/calculator/hessian_reconstruct.f90 | 31 ++---- src/calculator/hr_utils.f90 | 144 ++++++++++++++++++++----- src/optimize/newton_raphson.f90 | 25 +++-- src/optimize/optimize_module.f90 | 21 ++-- src/optimize/rfo.f90 | 31 ++++-- src/parsing/parse_calcdata.f90 | 24 ++++- 7 files changed, 197 insertions(+), 80 deletions(-) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 445ebb6f..162d3501 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -255,6 +255,7 @@ module calc_type integer :: iupdat = 0 !> 0=BFGS, 1=Powell, 2=SR1, 3=Bofill, 4=Schlegel integer :: opt_engine = 0 !> default: ANCOPT integer :: lbfgs_histsize = 20 !> L-BFGS history size + integer :: hess_init = 0 !> Initialization of the hessian, standard is scaled identity (with hguess) !>--- GFN0* data, needed for special MECP application type(gfn0_data),allocatable :: g0calc diff --git a/src/calculator/hessian_reconstruct.f90 b/src/calculator/hessian_reconstruct.f90 index dfcf2be6..4e965b56 100644 --- a/src/calculator/hessian_reconstruct.f90 +++ b/src/calculator/hessian_reconstruct.f90 @@ -14,11 +14,11 @@ module hessian_reconstruct real(wp),allocatable :: gradient(:,:,:) real(wp),allocatable :: coords(:,:,:) real(wp),allocatable :: energy(:) - real(wp),allocatable :: s(:,:),y(:,:),B(:,:),H(:,:),Hinv(:,:),p(:),rho(:),V(:,:,:),I(:,:) + real(wp),allocatable :: H(:,:) integer,allocatable :: order(:),natm integer :: stepcount = 0 real(wp) :: hguess = 0.02_wp - real(wp),allocatable ::hguess_mat(:,:) + real(wp),allocatable ::hess(:) logical :: track_step = .true. integer :: initialize_type = 0 @@ -46,16 +46,8 @@ subroutine cashed_hessian_allocate(self,N,steps,hguess,initialize_type) !> maybe allocate (self%coords(steps,3,N)) allocate (self%energy(steps)) allocate (self%order(steps)) - allocate (self%s(self%steps-1,3*N)) - allocate (self%y(self%steps-1,3*N)) - allocate (self%p(self%steps-1)) - allocate (self%rho(self%steps-1)) - allocate (self%V(self%steps-1,3*N,3*N)) - allocate (self%I(3*N,3*N)) - allocate (self%hguess_mat(3*N,3*N)) + allocate (self%hess((3*N*(3*N+1))/2)) allocate (self%H(3*N,3*N)) - allocate (self%Hinv(3*N,3*N)) - allocate (self%B(3*N,3*N)) self%order(:) = 0 @@ -68,12 +60,6 @@ subroutine cashed_hessian_deallocate(self) if (allocated(self%coords)) deallocate (self%coords) if (allocated(self%energy)) deallocate (self%energy) if (allocated(self%order)) deallocate (self%order) - if (allocated(self%s)) deallocate (self%s) - if (allocated(self%y)) deallocate (self%y) - if (allocated(self%p)) deallocate (self%p) - if (allocated(self%rho)) deallocate (self%rho) - if (allocated(self%V)) deallocate (self%V) - if (allocated(self%I)) deallocate (self%I) end subroutine cashed_hessian_deallocate @@ -94,7 +80,7 @@ end subroutine update_cashed_hessian subroutine construct_hessian_bfgs(self) class(cashed_hessian),intent(inout) :: self integer :: i,j,k,nat3 - real(wp),allocatable :: tmp(:),tmp_coords(:,:),tmp_grads(:,:),hess(:),dx(:) + real(wp),allocatable :: tmp(:),tmp_coords(:,:),tmp_grads(:,:),dx(:) real(wp) :: gnorm integer :: unit,iter,made_iters @@ -103,7 +89,6 @@ subroutine construct_hessian_bfgs(self) allocate (tmp_coords(self%steps,nat3)) allocate (tmp_grads(self%steps,nat3)) allocate (tmp(self%steps)) - allocate (hess(nat3*(nat3+1)/2)) allocate (dx(nat3)) tmp = self%order @@ -113,7 +98,7 @@ subroutine construct_hessian_bfgs(self) made_iters = self%steps - call dsqtoh(nat3,self%hguess_mat,hess) !> Here, Hessian is packed and transferred to hess + !>Hessian guess is installed previously in optimize routine but could also be read in explicitly for better readability? if (minval(tmp) == 0) then !> Implement keyword like exact HU that kills the process made_iters = maxval(tmp) !> if made_iters This only happens if made_iters>steps if (j == 1) then !> => Not affected if too many steps requested dx = tmp_coords(j,:)-tmp_coords(self%steps,:) - call bfgs(nat3,gnorm,tmp_grads(j,:),tmp_grads(self%steps,:),dx,hess) + call bfgs(nat3,gnorm,tmp_grads(j,:),tmp_grads(self%steps,:),dx,self%hess(:)) else dx = tmp_coords(j,:)-tmp_coords(j-1,:) - call bfgs(nat3,gnorm,tmp_grads(j,:),tmp_grads(j-1,:),dx,hess) + call bfgs(nat3,gnorm,tmp_grads(j,:),tmp_grads(j-1,:),dx,self%hess(:)) end if tmp(j) = HUGE(tmp(j)) end if end do - call dhtosq(nat3,self%B,hess) + call dhtosq(nat3,self%H(:,:),self%hess(:)) !>B needs to be renamed eventually! end subroutine construct_hessian_bfgs diff --git a/src/calculator/hr_utils.f90 b/src/calculator/hr_utils.f90 index 2ab67abe..c319d54f 100644 --- a/src/calculator/hr_utils.f90 +++ b/src/calculator/hr_utils.f90 @@ -2,40 +2,134 @@ module hr_utils use iso_fortran_env,only:wp => real64 use crest_calculator use crest_parameters + use optimize_maths + use modelhessian_module + use axis_module implicit none private - public hr_initialize_hessian + public initialize_hessian contains -subroutine hr_initialize_hessian(calc,at) +subroutine initialize_hessian(calc,type,xyz,nat,at,hess,hguess,pr) !>Matrix is forced to be positive definite type(calcdata),intent(inout) :: calc type(calcdata) :: newcalc type(calculation_settings) :: clevel - integer :: k,idx,io, nat3 - integer, intent(in) :: at(:) - - nat3 = 3*calc%chess%natm - idx = minloc(calc%chess%order,1) !>gives location of first geometry that is saved - - !>initialize_type: 0 for scaled identity, 1 for gfnff guess, 2 for gfn2 guess - -select case (calc%chess%initialize_type) -case(0) - calc%chess%hguess_mat = 0.0_wp - do k = 1,nat3 - calc%chess%hguess_mat(k,k) = calc%chess%hguess + type(mhparam) :: mhset + integer :: k,i,j,idx,io, nat3 + integer, intent(in) :: at(:), nat + real(wp),intent(inout) :: hess(:) + real(wp),allocatable :: hess_full(:,:) + real(wp),optional, intent(in) :: hguess + integer,intent(in) :: type + real(wp),intent(in) :: xyz(:,:) + logical,intent(in) :: pr + real(wp),allocatable :: pmode(:,:) + real(wp) :: rot(3), dumi + logical :: linear + + nat3 = 3*nat + + !$omp critical + allocate (pmode(nat3,1)) ! dummy allocated + !$omp end critical + + select case (type) + case(0) !>Initialize as a scaled identity + if (present(hguess)) then + k = 0 + do i = 1,nat3 + do j = 1,i + k = k+1 + if (i /= j) then + hess(k) = 0.0_wp + else + hess(k) = hguess + end if + end do + end do + else + write(stdout,*) "No hguess provided" + endif + case(1) + allocate(hess_full(nat3,nat3),source=0.0_wp) + call clevel%create('gfnff', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? + call newcalc%add(clevel) + call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) + call dsqtoh(nat3,hess_full(:,:),hess(:)) + case(2) + allocate(hess_full(nat3,nat3),source=0.0_wp) + call clevel%create('gfn1', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? + call newcalc%add(clevel) + call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) + call dsqtoh(nat3,hess_full(:,:),hess(:)) + case(3) + allocate(hess_full(nat3,nat3),source=0.0_wp) + call clevel%create('gfn2', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? + call newcalc%add(clevel) + call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) + call dsqtoh(nat3,hess_full(:,:),hess(:)) + case(4) + call modhes(calc,mhset,nat,xyz,at,hess(:),pr) + end select + + call axis(nat,at,xyz,rot,dumi) + linear = (rot(3) .lt. 1.d-10).or.(nat == 2) + + if (.not.linear) then + if (calc%nfreeze == 0) then + call trproj(nat,nat3,xyz,hess,.false.,0,pmode,1) !> normal + else + call trproj(nat,nat3,xyz,hess,.false.,calc%freezelist) !> fozen atoms + end if + end if + + call force_positive_definiteness(hess, nat3) + +end subroutine initialize_hessian + +subroutine force_positive_definiteness(hess,nat3) + real(wp), intent(inout) :: hess(:) + integer,intent(in) :: nat3 + real(wp), allocatable :: eigvec(:,:), eigval(:) + real(wp), allocatable :: work(:) + integer, allocatable :: iwork(:) + integer :: lwork, liwork, info, i, j, k, l + real(wp) :: elow, damp + + allocate(eigvec(nat3,nat3), eigval(nat3)) + lwork = 1 + 6*nat3 + 2*nat3*nat3 + liwork = 8*nat3 + allocate(work(lwork), iwork(liwork)) + + call dspevd('V','U',nat3,hess(:),eigval,eigvec,nat3, & + work,lwork,iwork,liwork,info) + + if (info /= 0) then + write(*,*) "dspevd failed, info = ", info + stop + end if + + + elow = minval(eigval) + damp = max(1.0e-4_wp - elow, 0.0_wp) + eigval = eigval + damp + + hess(:) = 0.0_wp + k = 0 + do j = 1,nat3 + do i = 1,j + k = k + 1 + hess(k) = 0.0_wp + do l = 1,nat3 + hess(k) = hess(k) + eigval(l)*eigvec(i,l)*eigvec(j,l) + end do + end do end do -case(1) - call clevel%create('gfnff', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? - call newcalc%add(clevel) - call numhess1(calc%chess%natm,at,calc%chess%coords(idx,:,:),newcalc,calc%chess%hguess_mat(:,:),io) -case(2) - call clevel%create('gfn2', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? - call newcalc%add(clevel) - call numhess1(calc%chess%natm,at,calc%chess%coords(idx,:,:),newcalc,calc%chess%hguess_mat(:,:),io) -end select -end subroutine hr_initialize_hessian + + deallocate(eigvec, eigval, work, iwork) + +end subroutine force_positive_definiteness end module hr_utils \ No newline at end of file diff --git a/src/optimize/newton_raphson.f90 b/src/optimize/newton_raphson.f90 index f88d3b27..090bc54b 100644 --- a/src/optimize/newton_raphson.f90 +++ b/src/optimize/newton_raphson.f90 @@ -35,6 +35,7 @@ module newton_raphson_module use hessupdate_module use optimize_utils use hessian_reconstruct + use hr_utils implicit none private @@ -190,17 +191,19 @@ subroutine newton_raphson(mol,calc,etot,grd,pr,wr,iostatus) !>------------------------------------------------------------------------ !>--- put the Hessian guess into the type !>------------------------------------------------------------------------ - k = 0 - do i = 1,nat3 - do j = 1,i - k = k+1 - if (i /= j) then - OPT%hess(k) = 0.0_wp - else - OPT%hess(k) = calc%hguess - end if - end do - end do + !k = 0 + !do i = 1,nat3 + ! do j = 1,i + ! k = k+1 + ! if (i /= j) then + ! OPT%hess(k) = 0.0_wp + ! else + ! OPT%hess(k) = calc%hguess + ! end if + ! end do + !end do + + call initialize_hessian(calc,calc%hess_init,mol%xyz,mol%nat,mol%at,hess,calc%hguess,pr) !>--- backup coordinates, and starting energy molopt%nat = mol%nat diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index eca03a5a..53022195 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -63,8 +63,8 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) real(wp),intent(inout) :: etot real(wp),intent(inout) :: grd(3,mol%nat) real(wp),allocatable :: H_init(:,:),freq(:) - integer :: nat3 - integer :: io + integer :: nat3,io,idx + real(wp),allocatable :: hess(:) iostatus = -1 @@ -117,7 +117,7 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) end select molnew%energy = etot - if (calc%do_HR .and. iostatus .eq. 0) then !> Hessian construction and post-processing happen here, only do it if geometry relaxation successful + if (calc%do_HR .and. iostatus .eq. 0) then !> Hessian reconstruction and post-processing happen here, only do it if geometry relaxation successful if (calc%full_HR) then write (stdout,*) @@ -129,22 +129,25 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) & calc%ht,calc%gt,calc%stot,etot) else + call initialize_hessian(calc,calc%hess_init,mol%xyz,mol%nat,mol%at,calc%chess%hess(:),calc%hguess,pr) + idx = minloc(calc%chess%order,1) - call hr_initialize_hessian(calc, molnew%at) - write(stdout,*) + call initialize_hessian(calc,calc%chess%initialize_type,calc%chess%coords(idx,:,:),molnew%nat,molnew%at,calc%chess%hess(:),calc%chess%hguess,pr) !> This hguess is set through the hguess variable of the optimizer and needs to be hardcoded/set explicitly before initialization for benchmarking!! + call dhtosq(nat3,H_init,calc%chess%hess) !> maybe this should all be inside the construct bfgs function later? -> cannot due to circular import!!! + write(stdout,*) !> Hessian type (gfnff,mod,identity) is set through input file and is already encoded into the calc object write(stdout,*)"THERMO FROM INITIALIZED HESSIAN:" - write(stdout,*) - H_init(:,:) = calc%chess%hguess_mat(:,:) + write(stdout,*) call calc_thermo_from_hess(molnew,H_init,pr, & & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & & calc%ht,calc%gt,calc%stot,etot) + call calc%chess%construct_hessian_bfgs() write (stdout,*) - write (stdout,*) "THERMO FROM RECONSTRUCTED HESSIAN:" + write (stdout,*) "THERMO FROM RECONSTRUCTED HESSIAN:" write (stdout,*) - call calc_thermo_from_hess(molnew,calc%chess%B,pr, & + call calc_thermo_from_hess(molnew,calc%chess%H(:,:),pr, & & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & & calc%ht,calc%gt,calc%stot,etot) end if diff --git a/src/optimize/rfo.f90 b/src/optimize/rfo.f90 index bacf2f79..8fee7146 100644 --- a/src/optimize/rfo.f90 +++ b/src/optimize/rfo.f90 @@ -35,6 +35,7 @@ module rfo_module use hessupdate_module use optimize_utils use hessian_reconstruct + use hr_utils implicit none private @@ -125,6 +126,12 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !real(sp),external :: sdot real(wp),allocatable :: test_hess(:) !> only for testing integer :: q,r,s !>only for testing + !>These are for spectral projection + real(wp), allocatable :: eigvec(:,:), eigval(:) + real(wp), allocatable :: work(:) + integer, allocatable :: iwork_spec(:) + integer :: lwork, liwork, info_spec + real(wp) :: elow, damp_spec, scale iostatus = 0 fail = .false. @@ -192,17 +199,19 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !>------------------------------------------------------------------------ !>--- put the Hessian guess into the type !>------------------------------------------------------------------------ - k = 0 - do i = 1,nat3 - do j = 1,i - k = k+1 - if (i /= j) then - OPT%hess(k) = 0.0_wp - else - OPT%hess(k) = calc%hguess - end if - end do - end do + !k = 0 + !do i = 1,nat3 + ! do j = 1,i + ! k = k+1 + ! if (i /= j) then + ! OPT%hess(k) = 0.0_wp + ! else + ! OPT%hess(k) = calc%hguess + ! end if + ! end do + !end do + + call initialize_hessian(calc,calc%hess_init,mol%xyz,mol%nat,mol%at,OPT%hess(:),calc%hguess,pr) !>Need to add printout about how hessian is initialized! Potentially also force positive definiteness by eigenvalue shifting! !>--- backup coordinates, and starting energy molopt%nat = mol%nat diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 01092633..eb440cbe 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -604,14 +604,36 @@ subroutine parse_calc_auto(env,calc,kv,rd) calc%initialize_hr_type = 0 case('gfnff', 'gfn-ff') calc%initialize_hr_type = 1 + case('gfn1') + calc%initialize_hr_type = 2 case('gfn2') - calc%initialize_hr_type = 2 + calc%initialize_hr_type = 3 + case('lindh') + calc%initialize_hr_type = 4 case default !>--- keyword was recognized, but invalid argument supplied write (stdout,fmtura) kv%value_c call creststop(status_config) end select + case ('hess_init','hess_initialization') !> here we set how the matrix for hessian reconstruction is initialized + select case (kv%value_c) + case('identity') + calc%hess_init = 0 + case('gfnff', 'gfn-ff') + calc%hess_init = 1 + case('gfn1') + calc%hess_init = 2 + case('gfn2') + calc%hess_init = 3 + case('lindh') + calc%hess_init = 4 + case default + !>--- keyword was recognized, but invalid argument supplied + write (stdout,fmtura) kv%value_c + call creststop(status_config) + end select + case ('freeze') call get_atlist(env%ref%nat,atlist,kv%value_c,env%ref%at) calc%nfreeze = count(atlist) From e2d1b21ff0d7a476172209c0b422adb6151c2d66 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 16 Jan 2026 18:14:28 +0100 Subject: [PATCH 138/374] cntd reconstruct --- src/algos/queueing.f90 | 134 ++++++++++++++++++++++++++--------- src/molbuilder/construct.f90 | 2 +- src/molbuilder/rigidconf.f90 | 4 -- 3 files changed, 100 insertions(+), 40 deletions(-) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 162ecc7d..e9560cc6 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -217,6 +217,11 @@ subroutine crest_queue_iter(env,iterate) call queue%calc%copy(env%calc,ignore_constraints=.true.) !> for constraints we must be careful and map them to the new order call update_constraints_queue(heap,jj,kk,env%calc,queue%calc) + do ll=1,heap%layer(jj)%node(kk)%nat + atj = heap%layer(jj)%origin(kk)%map(ll) + write(*,*) 'c',ll,'o',atj + + enddo call queue%calc%info(stdout) @@ -290,11 +295,14 @@ subroutine crest_queue_reconstruct(env,tim) use crest_parameters use crest_data use construct_list + use construct_mod use strucrd implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim type(coord) :: mol + integer :: ii,jj,kk,nall + type(coord),allocatable :: structures(:) if (.not. (allocated(env%splitqueue).and.env%splitheap%nqueue > 0)) then return @@ -313,6 +321,13 @@ subroutine crest_queue_reconstruct(env,tim) call chdir(env%splitheap%origindir) call recusrive_construct(env,env%splitheap,1) + nall = env%splitheap%layer(1)%nmols + allocate(structures(nall)) + do ii=1,nall + structures(ii) = env%splitheap%layer(1)%mols(ii) + enddo + deallocate(env%splitheap%layer(1)%mols) + call wrensemble('crest_queue_reconstruct.xyz',nall,structures) contains recursive subroutine recusrive_construct(env,heap,targetlayer) @@ -321,12 +336,14 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) type(construct_heap),intent(inout) :: heap integer,intent(in) :: targetlayer - integer :: ii,jj + integer :: ii,jj,kk + integer :: queuepos character(len=:),allocatable :: basefile,sidefile type(coord),allocatable :: structures_b(:) type(coord),allocatable :: structures_s(:) + type(coord) :: mol integer :: nall_b,nall_s,id_b,id_s - logical :: ex + logical :: ex,clash character(len=*),parameter :: subdir_tmp = 'crest_queue_' character(len=:),allocatable :: subdirfile @@ -339,45 +356,92 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) stop end if - if (.not.allocated(layer%childlayer).or. & - & all(layer%childlayer(:) .eq. 0)) then - !> saveguard to not reconstruct layer multiple times - if (layer%nmols > 0) return - - !> pick base an side-group files - do ii = 1,heap%nqueue - if (heap%queue(ii)%layer == targetlayer.and.heap%queue(ii)%node == 1) then - basefile = heap%queue(ii)%file - id_b = ii - else if (heap%queue(ii)%layer == targetlayer.and.heap%queue(ii)%node == 2) then - sidefile = heap%queue(ii)%file - id_s = ii + do ii = 1,layer%nnodes + if (allocated(layer%childlayer)) then + jj = layer%childlayer(ii) + else + jj = 0 + end if + if (jj == 0.and.ii == 1) then + + do kk = 1,heap%nqueue + if (heap%queue(kk)%layer == targetlayer.and.heap%queue(kk)%node == ii) then + basefile = heap%queue(kk)%file + id_b = kk + end if + end do + + write (atmp,'(i0)') id_b + subdirfile = subdir_tmp//trim(atmp)//'/'//basefile + inquire (exist=ex,file=subdirfile) + if (ex) then + write (stdout,'(a,t26,a,t30,a)',advance='no') & + & 'Reading fragment(s) from',':',subdirfile + call rdensemble(subdirfile,nall_b,structures_b) + write (stdout,'(1x,a,i0,a)') '--> ',nall_b,' structure(s)' + end if - end do - write (atmp,'(i0)') id_b - subdirfile = subdir_tmp//trim(atmp)//'/'//basefile - inquire (exist=ex,file=subdirfile) - if (ex) then - write (stdout,'(a,t28,a,t30,a)') 'Reading fragment(s) from',':',subdirfile - call rdensemble(subdirfile,nall_b,structures_b) - end if + else if (jj == 0.and.ii == 2) then + + do kk = 1,heap%nqueue + if (heap%queue(kk)%layer == targetlayer.and.heap%queue(kk)%node == ii) then + sidefile = heap%queue(kk)%file + id_s = kk + end if + end do + + write (atmp,'(i0)') id_s + subdirfile = subdir_tmp//trim(atmp)//'/'//sidefile + inquire (exist=ex,file=subdirfile) + if (ex) then + write (stdout,'(a,t26,a,t30,a)',advance='no') & + & 'Reading fragment(s) from',':',subdirfile + call rdensemble(subdirfile,nall_s,structures_s) + write (stdout,'(1x,a,i0,a)') '--> ',nall_s,' structure(s)' + end if - write (atmp,'(i0)') id_s - subdirfile = subdir_tmp//trim(atmp)//'/'//sidefile - inquire (exist=ex,file=subdirfile) - if (ex) then - write (stdout,'(a,t28,a,t30,a)') 'Reading fragment(s) from',':',subdirfile - call rdensemble(subdirfile,nall_s,structures_s) + else + call recusrive_construct(env,heap,jj) + if (ii == 1) then + nall_b = heap%layer(jj)%nmols + allocate (structures_b(nall_b)) + do kk = 1,nall_b + structures_b(kk) = heap%layer(jj)%mols(kk) + end do + !deallocate (heap%layer(jj)%mols) + else if (ii == 2) then + + nall_s = heap%layer(jj)%nmols + allocate (structures_s(nall_s)) + do kk = 1,nall_s + structures_s(kk) = heap%layer(jj)%mols(kk) + end do + !deallocate (heap%layer(jj)%mols) + end if end if + end do - else - do ii = 1,layer%nnodes - jj = layer%childlayer(ii) - if (jj == 0) cycle - call recusrive_construct(env,heap,jj) + write (stdout,*) + write (stdout,'(a,i0)') 'Reconstructing layer : ',targetlayer + write (stdout,'(2x,a,i0)') 'Base structures : ',nall_b + write (stdout,'(2x,a,i0)') 'Side chain structures : ',nall_s + write (stdout,'(2x,a,i0)') 'Max. combinations : ',nall_b*nall_s + + layer%nmols = 0 + kk = nall_b*nall_s + allocate (layer%mols(kk)) + do ii = 1,nall_b + do jj = 1,nall_s + call attach(structures_b(ii),structures_s(jj),layer%alignmap,mol, & + & remove_lastx=layer%ncapped,original_map=layer%position_mapping, & + & clash=clash) + if(.not.clash)then + layer%nmols = layer%nmols + 1 + layer%mols(layer%nmols) = mol + endif end do - end if + end do end associate end subroutine recusrive_construct diff --git a/src/molbuilder/construct.f90 b/src/molbuilder/construct.f90 index 3e7c4cf0..a4fa9c9b 100644 --- a/src/molbuilder/construct.f90 +++ b/src/molbuilder/construct.f90 @@ -74,7 +74,7 @@ subroutine attach(base,side,alignmap,new,clash, & !> defaults/checks of the alignmap nalign = size(alignmap,1) if (nalign < 3) then - error stop source//": alignmap needs at leaast 3 atoms" + error stop source//": alignmap needs at least 3 atoms" end if if (size(alignmap,2) .ne. 2) then error stop source//": alignmap has wrong dimension" diff --git a/src/molbuilder/rigidconf.f90 b/src/molbuilder/rigidconf.f90 index 1d7abde9..5b9e5de8 100644 --- a/src/molbuilder/rigidconf.f90 +++ b/src/molbuilder/rigidconf.f90 @@ -81,12 +81,8 @@ subroutine this_header write (stdout,'(7x,"┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━┓")') write (stdout,'(7x,"┃ R I G I D C O N F ┃ ")') write (stdout,'(7x,"┃ (name is work-in-progress) ┃ ")') - !write(stdout,'(7x,"┃ R i C o ┃")') - !write(stdout,'(7x,"┃ ConfAcc ┃")') write (stdout,'(7x,"┃ rule-based conformer generator ┃")') write (stdout,'(7x,"┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━┛")') - !write(stdout,'(12x,"C.Zurek, C.Bannwarth, P.Pracht")') - !write(stdout,*) end subroutine this_header end subroutine crest_rigidconf !========================================================================================! From cccc0c10f3310797929fe6b30896f6a24210e9db Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 16 Jan 2026 23:14:36 +0100 Subject: [PATCH 139/374] debug origin mapping --- src/algos/queueing.f90 | 41 ++++++++++----- src/molbuilder/construct_list.f90 | 85 ++++++++++++++++++++----------- 2 files changed, 81 insertions(+), 45 deletions(-) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index e9560cc6..168ac3b5 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -29,7 +29,7 @@ subroutine crest_queue_setup(env,iterate) logical,intent(out) :: iterate integer :: splitlayers - integer :: ii,jj,nn + integer :: ii,jj,nn,kk,ich type(coord),pointer :: reference_mol type(coord),target :: mol integer,allocatable :: splitatms(:) @@ -66,7 +66,6 @@ subroutine crest_queue_setup(env,iterate) nn = env%splitqueue(ii)%natms allocate (splitatms(nn)) splitatms(:) = env%splitqueue(ii)%atms(:) - if (ii == 1) then call env%ref%to(mol) reference_mol => mol @@ -79,6 +78,8 @@ subroutine crest_queue_setup(env,iterate) else mol = heap%layer(parentlayer)%node(parentnode) reference_mol => mol + heap%layer(ii)%parent = parentlayer + heap%layer(ii)%parentnode = parentnode end if end if call split(reference_mol,splitatms,layer(ii)%node,layer(ii)%alignmap, & @@ -93,12 +94,23 @@ subroutine crest_queue_setup(env,iterate) call env%ref%to(heap%originmol) heap%origindir = trim(thispath) heap%origincalc => env%calc + + !open(newunit=ich,file='split.xyz') + !do nn = 1,heap%nqueue + ! ii = heap%queue(nn)%layer + ! jj = heap%queue(nn)%node + ! write (*,*) ' layer,node',ii,jj + ! call heap%layer(ii)%node(jj)%append(ich) + ! do kk = 1,heap%layer(ii)%node(jj)%nat + ! write (*,*) 'c',kk,'o',heap%layer(ii)%origin(jj)%map(kk) + ! end do + !end do + !close(ich) end associate iterate = .true. end if return - contains subroutine pick_parent(heap,current_layer,splitatms,parentlayer,parentnode) use construct_list @@ -136,6 +148,7 @@ subroutine pick_parent(heap,current_layer,splitatms,parentlayer,parentnode) end do LAYITER !> IMPORTANT; we need to update the splitatms with the correctly mapped indices + !> reflecting their position in the selected parent layer if (parentnode .ne. 0) then do ii = 1,size(splitatms,1) jj = splitatms(ii) @@ -217,11 +230,11 @@ subroutine crest_queue_iter(env,iterate) call queue%calc%copy(env%calc,ignore_constraints=.true.) !> for constraints we must be careful and map them to the new order call update_constraints_queue(heap,jj,kk,env%calc,queue%calc) - do ll=1,heap%layer(jj)%node(kk)%nat + do ll = 1,heap%layer(jj)%node(kk)%nat atj = heap%layer(jj)%origin(kk)%map(ll) - write(*,*) 'c',ll,'o',atj + write (*,*) 'c',ll,'o',atj - enddo + end do call queue%calc%info(stdout) @@ -322,11 +335,11 @@ subroutine crest_queue_reconstruct(env,tim) call recusrive_construct(env,env%splitheap,1) nall = env%splitheap%layer(1)%nmols - allocate(structures(nall)) - do ii=1,nall + allocate (structures(nall)) + do ii = 1,nall structures(ii) = env%splitheap%layer(1)%mols(ii) - enddo - deallocate(env%splitheap%layer(1)%mols) + end do + deallocate (env%splitheap%layer(1)%mols) call wrensemble('crest_queue_reconstruct.xyz',nall,structures) contains @@ -436,10 +449,10 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) call attach(structures_b(ii),structures_s(jj),layer%alignmap,mol, & & remove_lastx=layer%ncapped,original_map=layer%position_mapping, & & clash=clash) - if(.not.clash)then - layer%nmols = layer%nmols + 1 - layer%mols(layer%nmols) = mol - endif + if (.not.clash) then + layer%nmols = layer%nmols+1 + layer%mols(layer%nmols) = mol + end if end do end do diff --git a/src/molbuilder/construct_list.f90 b/src/molbuilder/construct_list.f90 index 7dbcedf7..a18bbe72 100644 --- a/src/molbuilder/construct_list.f90 +++ b/src/molbuilder/construct_list.f90 @@ -112,35 +112,68 @@ subroutine add_to_splitqueue(splitqueue,raw_split) end subroutine add_to_splitqueue - recursive function find_original_atom(atom,heap,targetlayer,targetnode) result(this) + recursive subroutine find_original_atoms(heap,targetlayer,targetnode,atoms) implicit none type(construct_heap),intent(in) :: heap - integer,intent(in) :: targetlayer,targetnode,atom + integer,intent(in) :: targetlayer,targetnode + integer,intent(out),allocatable :: atoms(:) integer :: this - integer :: ii,jj,kk + integer :: ii,jj,kk,nat,dim1,dim2 + integer,allocatable :: tmpatoms(:) - this = 0 - kk = 0 - do ii = 1,size(heap%layer(targetlayer)%position_mapping,1) - if (atom == heap%layer(targetlayer)%position_mapping(ii,targetnode)) then - kk = ii - exit + write(*,*) "calling find_original_atoms" + associate (layer => heap%layer(targetlayer)) + nat = layer%node(targetnode)%nat + allocate (atoms(nat),source=0) + if (layer%parent == 0) then + call position_mapping_reverse( & + & layer%position_mapping,targetnode,nat,atoms) + else + ii = layer%parent + jj = layer%parentnode + call find_original_atoms(heap,ii,jj,tmpatoms) + dim1 = size(tmpatoms,1) + dim2 = size(layer%position_mapping,1) + if (dim1 .ne. dim2) then + stop "something went wrong in find_original_atoms()" + end if + do ii = 1,dim1 + kk = layer%position_mapping(ii,targetnode) + do jj = 1,nat + if (kk == jj) then + atoms(jj) = tmpatoms(ii) + end if + end do + end do + deallocate (tmpatoms) end if + end associate + end subroutine find_original_atoms + + subroutine position_mapping_reverse(position_mapping,node,nat,revats) + !* get the original (one layer up) atom positions for ati + !* of a given node from the saved position_mapping of the associated layer + !* Invalid setups return 0 + implicit none + integer,intent(in) :: position_mapping(:,:) + integer,intent(in) :: node,nat + integer,intent(out),allocatable :: revats(:) + integer :: ii,jj,dim1,dim2 + dim1 = size(position_mapping,1) + dim2 = size(position_mapping,2) + allocate (revats(nat),source=0) + if (node < 1.or.node > dim2) return + do ii = 1,dim1 + jj = position_mapping(ii,node) + if (jj > 0) revats(jj) = ii end do - if (heap%layer(targetlayer)%parent == 0.or.kk == 0) then - this = kk - else - ii = heap%layer(targetlayer)%parent - jj = heap%layer(targetlayer)%parentnode - this = find_original_atom(kk,heap,ii,jj) - end if - end function find_original_atom + end subroutine position_mapping_reverse subroutine map_origins_for_layer(heap,targetlayer) implicit none class(construct_heap),intent(inout) :: heap integer,intent(in) :: targetlayer - integer :: ii,jj,kk,nat + integer :: ii,jj logical,parameter :: debug = .false. if (targetlayer < 1.or.targetlayer > heap%nlayer) return if (.not.allocated(heap%layer(targetlayer)%node)) return @@ -148,18 +181,8 @@ subroutine map_origins_for_layer(heap,targetlayer) if (allocated(layer%origin)) deallocate (layer%origin) allocate (layer%origin(layer%nnodes)) do ii = 1,layer%nnodes - nat = layer%node(ii)%nat - allocate (layer%origin(ii)%map(nat),source=0) - layer%origin(ii)%natms = nat - do jj = 1,nat - layer%origin(ii)%map(jj) = find_original_atom(jj,heap,targetlayer,ii) - end do - if (debug) then - write (stdout,*) 'Original atom positions for fragment',ii,'of layer',targetlayer - do jj = 1,nat - write (stdout,*) 'frag.atm.',jj,'<-- original:',layer%origin(ii)%map(jj) - end do - end if + layer%origin(ii)%natms = layer%node(ii)%nat + call find_original_atoms(heap,targetlayer,ii,layer%origin(ii)%map) end do end associate end subroutine map_origins_for_layer @@ -209,7 +232,7 @@ subroutine setup_queue(heap) nqueue = heap%count_endpoints() heap%nqueue = nqueue allocate (heap%queue(nqueue)) - + kk = 0 do ii = 1,heap%nlayer if (.not.allocated(heap%layer(ii)%childlayer)) then From d4e1f8de6fdb77ebf5bf7474a3468a4116eebac9 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 17 Jan 2026 21:50:01 +0100 Subject: [PATCH 140/374] start adding classification routines --- src/algos/playground.f90 | 28 ++---- src/algos/queueing.f90 | 12 +-- src/classes.f90 | 2 +- src/molbuilder/CMakeLists.txt | 1 + src/molbuilder/analyze.f90 | 9 +- src/molbuilder/classify.f90 | 142 ++++++++++++++++++++++++++++++ src/molbuilder/construct.f90 | 4 +- src/molbuilder/construct_list.f90 | 4 +- src/molbuilder/meson.build | 1 + 9 files changed, 165 insertions(+), 38 deletions(-) create mode 100644 src/molbuilder/classify.f90 diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index 6a54e081..f57ff842 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -77,26 +77,16 @@ subroutine crest_playground(env,tim) ! call calculation_summary(calc,mol,energy,grad) !========================================================================================! block - use construct_mod - type(coord) :: base,side,new,newnew - type(coord),allocatable :: splitlist(:) - integer,allocatable :: alignmap(:,:),ncap(:),position_mapping(:,:) - - open (newunit=ich,file='molbuilder.xyz', & - status="unknown", & - action="write", & - position="append") + use molbuilder_classify + type(coord) :: new + type(coord_classify) :: newc call env%ref%to(new) - call new%append(ich) - !if(allocated(env%splitqueue))then - ! do i=1,env%splitheap%nlayer - ! write(*,*) 'layer',i - ! do j=1,env%splitheap%layer(i)%nnodes - ! call env%splitheap%layer(i)%node(j)%append(ich) - ! enddo - ! enddo - !endif - close (ich) + + call setup_classify(new,newc) + + do i=1,newc%nat + write(*,'(a,i0,3(1x,i0))') trim(i2e(newc%at(i),'nc')),i,newc%hyb(i),newc%nhn(i),newc%prio(i) + enddo end block diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 168ac3b5..08b0ec2e 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -22,8 +22,8 @@ subroutine crest_queue_setup(env,iterate) use crest_data use crest_calculator use strucrd - use construct_list - use construct_mod + use molbuilder_construct_list + use molbuilder_construct_mod implicit none type(systemdata),intent(inout) :: env logical,intent(out) :: iterate @@ -113,7 +113,7 @@ subroutine crest_queue_setup(env,iterate) return contains subroutine pick_parent(heap,current_layer,splitatms,parentlayer,parentnode) - use construct_list + use molbuilder_construct_list implicit none type(construct_heap),intent(inout) :: heap integer,intent(inout) :: splitatms(:) @@ -258,7 +258,7 @@ subroutine crest_queue_iter(env,iterate) contains subroutine update_constraints_queue(heap,layer,node,refcalc,newcalc) - use construct_list + use molbuilder_construct_list implicit none type(construct_heap) :: heap integer :: layer,node @@ -307,8 +307,8 @@ end subroutine crest_queue_iter subroutine crest_queue_reconstruct(env,tim) use crest_parameters use crest_data - use construct_list - use construct_mod + use molbuilder_construct_list + use molbuilder_construct_mod use strucrd implicit none type(systemdata),intent(inout) :: env diff --git a/src/classes.f90 b/src/classes.f90 index 3eafff71..44a88829 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -29,7 +29,7 @@ module crest_data use strucrd,only:coord use crest_type_timer,only:timer use lwoniom_module,only:lwoniom_input - use construct_list !> from molbuilder dir + use molbuilder_construct_list !> from molbuilder dir implicit none public :: systemdata diff --git a/src/molbuilder/CMakeLists.txt b/src/molbuilder/CMakeLists.txt index fe21c9b6..a6cc4945 100644 --- a/src/molbuilder/CMakeLists.txt +++ b/src/molbuilder/CMakeLists.txt @@ -23,6 +23,7 @@ list(APPEND srcs "${dir}/reconstruct.f90" "${dir}/construct.f90" "${dir}/construct_list.f90" + "${dir}/classify.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/molbuilder/analyze.f90 b/src/molbuilder/analyze.f90 index 2c040233..edad5caf 100644 --- a/src/molbuilder/analyze.f90 +++ b/src/molbuilder/analyze.f90 @@ -1,7 +1,7 @@ !================================================================================! ! This file is part of crest. ! -! Copyright (C) 2023 Philipp Pracht, Christopher Zurek, Christoph Bannwarth +! Copyright (C) 2026 Philipp Pracht ! ! crest is free software: you can redistribute it and/or modify it under ! the terms of the GNU Lesser General Public License as published by @@ -15,9 +15,6 @@ ! ! You should have received a copy of the GNU Lesser General Public License ! along with crest. If not, see . -! -! Routines were adapted from the xtb code (github.com/grimme-lab/xtb) -! under the Open-source software LGPL-3.0 Licencse. !================================================================================! module rigidconf_analyze @@ -208,10 +205,6 @@ subroutine rigidconf_user_file(fname,nat,na,nb,nc,wbo,ndieder,ztod,dvalues,dstep integer,intent(out),allocatable :: ztod(:) integer,intent(out),allocatable :: dvalues(:) real(wp),intent(out),allocatable :: dstep(:) - !integer,intent(in) :: ndieder - !integer,intent(out) :: ztod(nat) - !integer,intent(out) :: dvalues(ndieder) - !real(wp),intent(out) :: dstep(ndieder) !> LOCAL integer :: V,i,j,k,l,m,ich,io,n integer,allocatable :: Amap(:,:) diff --git a/src/molbuilder/classify.f90 b/src/molbuilder/classify.f90 new file mode 100644 index 00000000..d8b047db --- /dev/null +++ b/src/molbuilder/classify.f90 @@ -0,0 +1,142 @@ +!=============================================================================! +! This file is part of crest. +! +! Copyright (C) 2026 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!=============================================================================! + +module molbuilder_classify + use crest_parameters,only:wp + use strucrd,only:coord + use adjacency + use canonical_mod + implicit none + public + + type,extends(coord) :: coord_classify + !> new components that are added to the coord type: + integer,allocatable :: A(:,:) !> molecular graph/adjacency matrix + integer,allocatable :: Ah(:,:) !> heavy-atom molecular graph/adjacency + + !> per-atom properties + real(wp),allocatable :: CN(:) !> coordination number + integer,allocatable :: hyb(:) !> hybridization/neighbours count + integer,allocatable :: nhn(:) !> non-H-neighbours count + integer,allocatable :: prio(:) !> "invariants"/atom priorities + logical,allocatable :: inring(:) !> atom part of ring? + + contains + procedure :: as_coord + procedure :: from_coord + end type coord_classify + +!==============================================================================! +contains !> MODULE PROCEDURES START HERE +!==============================================================================! + +!> BASIC TYPE PROCEDURES + + function as_coord(this) result(mol) + class(coord_classify),intent(in) :: this + type(coord) :: mol + + mol%nat = this%nat + if (allocated(this%at)) mol%at = this%at + if (allocated(this%xyz)) mol%xyz = this%xyz + + mol%energy = this%energy + if (allocated(this%comment)) mol%comment = this%comment + mol%chrg = this%chrg + mol%uhf = this%uhf + mol%nbd = this%nbd + if (allocated(this%bond)) mol%bond = this%bond + if (allocated(this%lat)) mol%lat = this%lat + if (allocated(this%qat)) mol%qat = this%qat + mol%pdb = this%pdb + + end function as_coord + + subroutine from_coord(this,mol) + class(coord_classify),intent(inout) :: this + type(coord),intent(in) :: mol + + this%nat = mol%nat + if (allocated(mol%at)) this%at = mol%at + if (allocated(mol%xyz)) this%xyz = mol%xyz + + this%energy = mol%energy + if (allocated(mol%comment)) this%comment = mol%comment + this%chrg = mol%chrg + this%uhf = mol%uhf + this%nbd = mol%nbd + if (allocated(mol%bond)) this%bond = mol%bond + if (allocated(mol%lat)) this%lat = mol%lat + if (allocated(mol%qat)) this%qat = mol%qat + this%pdb = mol%pdb + end subroutine from_coord + +!=============================================================================! +!#############################################################################! +!=============================================================================! + +!> CLASSIFICATION ROUTINES + + subroutine setup_classify(mol,molc) + implicit none + type(coord),intent(in) :: mol + type(coord_classify),intent(out) :: molc + + real(wp),allocatable :: Bmat(:,:) + logical,allocatable :: rings(:,:) + type(canonical_sorter),allocatable :: tmpcan + integer :: nat + integer :: ii,jj + + !> Initialize + call molc%from_coord(mol) + nat = molc%nat + + !> set up CN, and from that topology + call mol%cn_to_bond(molc%CN,Bmat,'cov') + call wbo2adjacency(molc%nat,Bmat,molc%A,0.02_wp) + deallocate (Bmat) + + !> set up other parameters + allocate (molc%hyb(nat),source=0) + allocate (molc%inring(nat),source=.false.) + call check_rings_min(nat,molc%A,rings) + do ii = 1,nat + molc%hyb(ii) = sum(molc%A(:,ii)) + if (any(rings(:,ii))) molc%inring(ii) = .true. + end do + + allocate (tmpcan) + call tmpcan%init(mol,invtype='apsp+',heavy=.false.) + call move_alloc(tmpcan%rank,molc%prio) + call move_alloc(tmpcan%hadjac,molc%Ah) + deallocate (tmpcan) + + allocate (molc%nhn(nat),source=0) + do ii = 1,nat + molc%nhn(ii) = sum(molc%Ah(:,ii)) + end do + + end subroutine setup_classify + +!=============================================================================! +!#############################################################################! +!=============================================================================! +end module molbuilder_classify + diff --git a/src/molbuilder/construct.f90 b/src/molbuilder/construct.f90 index a4fa9c9b..5a45f603 100644 --- a/src/molbuilder/construct.f90 +++ b/src/molbuilder/construct.f90 @@ -1,4 +1,4 @@ -module construct_mod +module molbuilder_construct_mod !*********************************************** !* A module for constructing molecules !* E.g. replacing functional groups and so on @@ -782,5 +782,5 @@ end subroutine methylize !=============================================================================! !#############################################################################! !=============================================================================! -end module construct_mod +end module molbuilder_construct_mod diff --git a/src/molbuilder/construct_list.f90 b/src/molbuilder/construct_list.f90 index a18bbe72..5062621a 100644 --- a/src/molbuilder/construct_list.f90 +++ b/src/molbuilder/construct_list.f90 @@ -1,4 +1,4 @@ -module construct_list +module molbuilder_construct_list !************************************************** !* Bookkeeping module for reconstructing molecules !************************************************** @@ -254,4 +254,4 @@ subroutine setup_queue(heap) end subroutine setup_queue -end module construct_list +end module molbuilder_construct_list diff --git a/src/molbuilder/meson.build b/src/molbuilder/meson.build index 52d0f0f5..89e795ca 100644 --- a/src/molbuilder/meson.build +++ b/src/molbuilder/meson.build @@ -21,4 +21,5 @@ srcs += files( 'reconstruct.f90', 'construct.f90', 'construct_list.f90', + 'classify.f90', ) From 629260e7a03c348d6be6629181a521db8d8e3573 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 18 Jan 2026 23:18:01 +0100 Subject: [PATCH 141/374] Basic functional group identification interface, start implementing --alkylize --- src/algos/CMakeLists.txt | 1 + src/algos/alkylize.f90 | 46 +++++ src/algos/meson.build | 1 + src/algos/playground.f90 | 7 +- src/algos/queueing.f90 | 11 -- src/classes.f90 | 1 + src/confparse.f90 | 3 + src/crest_main.f90 | 9 +- src/legacy_algos/reactor.f90 | 3 +- src/minitools.f90 | 27 --- src/molbuilder/CMakeLists.txt | 2 + src/molbuilder/classify.f90 | 122 +----------- src/molbuilder/classify_func.f90 | 293 ++++++++++++++++++++++++++++ src/molbuilder/classify_type.f90 | 324 +++++++++++++++++++++++++++++++ src/molbuilder/meson.build | 2 + src/msreact/msmod.f90 | 2 +- src/strucreader.f90 | 40 +++- 17 files changed, 735 insertions(+), 159 deletions(-) create mode 100644 src/algos/alkylize.f90 create mode 100644 src/molbuilder/classify_func.f90 create mode 100644 src/molbuilder/classify_type.f90 diff --git a/src/algos/CMakeLists.txt b/src/algos/CMakeLists.txt index b42f9199..cbe8df57 100644 --- a/src/algos/CMakeLists.txt +++ b/src/algos/CMakeLists.txt @@ -36,6 +36,7 @@ list(APPEND srcs "${dir}/search_entropy.f90" "${dir}/parallel.f90" "${dir}/queueing.f90" + "${dir}/alkylize.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/algos/alkylize.f90 b/src/algos/alkylize.f90 new file mode 100644 index 00000000..cf22fccb --- /dev/null +++ b/src/algos/alkylize.f90 @@ -0,0 +1,46 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2026 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +subroutine crest_setup_alkylize(env) + use crest_parameters + use crest_data + use strucrd + use molbuilder_classify + implicit none + type(systemdata),intent(inout) :: env + type(coord_classify) :: molc + type(coord) :: mol + + call env%ref%to(mol) + + call underline("Analyzing Input Structure") + + call setup_classify(mol,molc) + call functional_group_classify(molc) + if(molc%nfuncs == 0)then + write(stdout,'(a)') 'no relevant substructures found' + else + write(stdout,'(a)') 'Found the following substructure parts' + call molc%print_funcgroups(stdout) + endif + + !> TODO the actual checkup + + write(stdout,*) +end subroutine crest_setup_alkylize diff --git a/src/algos/meson.build b/src/algos/meson.build index 23b7354e..a4283a63 100644 --- a/src/algos/meson.build +++ b/src/algos/meson.build @@ -34,4 +34,5 @@ srcs += files( 'search_entropy.f90', 'parallel.f90', 'queueing.f90', + 'alkylize.f90', ) diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index f57ff842..2d79367c 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -83,11 +83,16 @@ subroutine crest_playground(env,tim) call env%ref%to(new) call setup_classify(new,newc) + !call atinfo_classify(newc) + call functional_group_classify(newc) do i=1,newc%nat - write(*,'(a,i0,3(1x,i0))') trim(i2e(newc%at(i),'nc')),i,newc%hyb(i),newc%nhn(i),newc%prio(i) + write(*,'(a,i0,3(1x,i0),1x,a)') trim(i2e(newc%at(i),'nc')),i,& + & newc%hyb(i),newc%nhn(i),newc%prio(i),trim(newc%atinfo(i)) enddo + call newc%print_funcgroups(stdout) + end block !========================================================================================! diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 08b0ec2e..c300104d 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -95,17 +95,6 @@ subroutine crest_queue_setup(env,iterate) heap%origindir = trim(thispath) heap%origincalc => env%calc - !open(newunit=ich,file='split.xyz') - !do nn = 1,heap%nqueue - ! ii = heap%queue(nn)%layer - ! jj = heap%queue(nn)%node - ! write (*,*) ' layer,node',ii,jj - ! call heap%layer(ii)%node(jj)%append(ich) - ! do kk = 1,heap%layer(ii)%node(jj)%nat - ! write (*,*) 'c',kk,'o',heap%layer(ii)%origin(jj)%map(kk) - ! end do - !end do - !close(ich) end associate iterate = .true. end if diff --git a/src/classes.f90 b/src/classes.f90 index 44a88829..a5b88e19 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -543,6 +543,7 @@ module crest_data !>--- general logical data logical :: allrot = .true. !> use all rotational constants for check instead of mean? + logical :: alkylize = .false. !> alkylization setting logical :: altopt = .false. logical :: autothreads !> automatically determine threads logical :: autozsort !> do the ZSORT in the beginning ? diff --git a/src/confparse.f90 b/src/confparse.f90 index 9e06eb8d..3fc9c94a 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -1533,6 +1533,9 @@ subroutine parseflags(env,arg,nra) env%wallsetup = .true. env%potscal = 2.0_wp write (*,'(2x,a,1x,a)') '--wall-xxl:','requesting setup of wall potential (x2.0 size)' + + case ('-alkylize') + env%alkylize = .true. !========================================================================================! !------ flags for parallelization / disk space !========================================================================================! diff --git a/src/crest_main.f90 b/src/crest_main.f90 index f385a7c7..3518f56e 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -49,7 +49,7 @@ program CREST !> Initialize system clock time call tim%init(20) - env%calc => calc_origin + env%calc => calc_origin !=========================================================================================! !> set defaults and pars flags args = iargc() @@ -214,6 +214,12 @@ program CREST case default continue end select + +!>--- alkylation prep + if (env%alkylize) then + call crest_setup_alkylize(env) + end if + !=========================================================================================! !> PRE-OPTIMIZATION OF THE GEOMETRY !=========================================================================================! @@ -318,7 +324,6 @@ program CREST call crest_queue_reconstruct(env,tim) - !=========================================================================================! !> ADDITIONAL OUTPUT FORMATTING !=========================================================================================! diff --git a/src/legacy_algos/reactor.f90 b/src/legacy_algos/reactor.f90 index f9c27049..15869a32 100644 --- a/src/legacy_algos/reactor.f90 +++ b/src/legacy_algos/reactor.f90 @@ -739,7 +739,7 @@ end subroutine reactorreopt subroutine collectproducts(optdir,base,ndirs,oname,iso) use crest_parameters, only: wp, bohr use iomod - use strucrd, only: wrxyz,rdnat,rdcoord + use strucrd, only: wrxyz,rdnat,rdcoord,sumform implicit none character(len=*),intent(in) :: optdir character(len=*),intent(in) :: base @@ -757,7 +757,6 @@ subroutine collectproducts(optdir,base,ndirs,oname,iso) real(wp),allocatable :: xyz(:,:) integer,allocatable :: at(:) character(len=40),allocatable :: sumformulas(:) - character(len=40) :: sumform real(wp),allocatable :: energies(:) integer,allocatable :: nats(:) logical,allocatable :: taken(:) diff --git a/src/minitools.f90 b/src/minitools.f90 index 81c37d2f..af53131f 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -400,7 +400,6 @@ subroutine testtopo(fname,env,tmode) character(len=*) :: fname character(len=:),allocatable :: wbofile character(len=*) :: tmode - character(len=40) :: sumform type(zmolecule) :: zmol type(coord) :: mol real(wp),allocatable :: xyz(:,:) @@ -513,32 +512,6 @@ end subroutine testtopo !========================================================================================! -character(len=40) function sumform(nat,at) -!************************************************ -!* get sumformula as a string from the AT array -!************************************************ - use strucrd,only:i2e - implicit none - integer :: nat - integer :: at(nat) - integer :: sumat(94) - integer :: i - character(len=6) :: str - sumform = '' - sumat = 0 - do i = 1,nat - sumat(at(i)) = sumat(at(i))+1 - end do - do i = 1,94 - if (sumat(i) .lt. 1) cycle - write (str,'(a,i0)') trim(adjustl(i2e(i,'nc'))),sumat(i) - sumform = trim(sumform)//trim(str) - end do - return -end function sumform - -!=========================================================================================! - subroutine ensemble_analsym(fname,pr) !***************************************************************** !* read an ensemble and determine the symmetry for all structures diff --git a/src/molbuilder/CMakeLists.txt b/src/molbuilder/CMakeLists.txt index a6cc4945..027d1499 100644 --- a/src/molbuilder/CMakeLists.txt +++ b/src/molbuilder/CMakeLists.txt @@ -24,6 +24,8 @@ list(APPEND srcs "${dir}/construct.f90" "${dir}/construct_list.f90" "${dir}/classify.f90" + "${dir}/classify_type.f90" + "${dir}/classify_func.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/molbuilder/classify.f90 b/src/molbuilder/classify.f90 index d8b047db..5257189f 100644 --- a/src/molbuilder/classify.f90 +++ b/src/molbuilder/classify.f90 @@ -18,125 +18,19 @@ !=============================================================================! module molbuilder_classify - use crest_parameters,only:wp - use strucrd,only:coord - use adjacency - use canonical_mod + use molbuilder_classify_type + use molbuilder_classify_func implicit none - public + private - type,extends(coord) :: coord_classify - !> new components that are added to the coord type: - integer,allocatable :: A(:,:) !> molecular graph/adjacency matrix - integer,allocatable :: Ah(:,:) !> heavy-atom molecular graph/adjacency - - !> per-atom properties - real(wp),allocatable :: CN(:) !> coordination number - integer,allocatable :: hyb(:) !> hybridization/neighbours count - integer,allocatable :: nhn(:) !> non-H-neighbours count - integer,allocatable :: prio(:) !> "invariants"/atom priorities - logical,allocatable :: inring(:) !> atom part of ring? - - contains - procedure :: as_coord - procedure :: from_coord - end type coord_classify + !> RE-EXEPORTS + public :: coord_classify !> the extended coord type + public :: setup_classify !> setup a coord_classify from coord + public :: atinfo_classify !> add atinfo string to a coord_classify + public :: functional_group_classify !> try to determine some functional groups !==============================================================================! contains !> MODULE PROCEDURES START HERE !==============================================================================! -!> BASIC TYPE PROCEDURES - - function as_coord(this) result(mol) - class(coord_classify),intent(in) :: this - type(coord) :: mol - - mol%nat = this%nat - if (allocated(this%at)) mol%at = this%at - if (allocated(this%xyz)) mol%xyz = this%xyz - - mol%energy = this%energy - if (allocated(this%comment)) mol%comment = this%comment - mol%chrg = this%chrg - mol%uhf = this%uhf - mol%nbd = this%nbd - if (allocated(this%bond)) mol%bond = this%bond - if (allocated(this%lat)) mol%lat = this%lat - if (allocated(this%qat)) mol%qat = this%qat - mol%pdb = this%pdb - - end function as_coord - - subroutine from_coord(this,mol) - class(coord_classify),intent(inout) :: this - type(coord),intent(in) :: mol - - this%nat = mol%nat - if (allocated(mol%at)) this%at = mol%at - if (allocated(mol%xyz)) this%xyz = mol%xyz - - this%energy = mol%energy - if (allocated(mol%comment)) this%comment = mol%comment - this%chrg = mol%chrg - this%uhf = mol%uhf - this%nbd = mol%nbd - if (allocated(mol%bond)) this%bond = mol%bond - if (allocated(mol%lat)) this%lat = mol%lat - if (allocated(mol%qat)) this%qat = mol%qat - this%pdb = mol%pdb - end subroutine from_coord - -!=============================================================================! -!#############################################################################! -!=============================================================================! - -!> CLASSIFICATION ROUTINES - - subroutine setup_classify(mol,molc) - implicit none - type(coord),intent(in) :: mol - type(coord_classify),intent(out) :: molc - - real(wp),allocatable :: Bmat(:,:) - logical,allocatable :: rings(:,:) - type(canonical_sorter),allocatable :: tmpcan - integer :: nat - integer :: ii,jj - - !> Initialize - call molc%from_coord(mol) - nat = molc%nat - - !> set up CN, and from that topology - call mol%cn_to_bond(molc%CN,Bmat,'cov') - call wbo2adjacency(molc%nat,Bmat,molc%A,0.02_wp) - deallocate (Bmat) - - !> set up other parameters - allocate (molc%hyb(nat),source=0) - allocate (molc%inring(nat),source=.false.) - call check_rings_min(nat,molc%A,rings) - do ii = 1,nat - molc%hyb(ii) = sum(molc%A(:,ii)) - if (any(rings(:,ii))) molc%inring(ii) = .true. - end do - - allocate (tmpcan) - call tmpcan%init(mol,invtype='apsp+',heavy=.false.) - call move_alloc(tmpcan%rank,molc%prio) - call move_alloc(tmpcan%hadjac,molc%Ah) - deallocate (tmpcan) - - allocate (molc%nhn(nat),source=0) - do ii = 1,nat - molc%nhn(ii) = sum(molc%Ah(:,ii)) - end do - - end subroutine setup_classify - -!=============================================================================! -!#############################################################################! -!=============================================================================! end module molbuilder_classify - diff --git a/src/molbuilder/classify_func.f90 b/src/molbuilder/classify_func.f90 new file mode 100644 index 00000000..b1db1d85 --- /dev/null +++ b/src/molbuilder/classify_func.f90 @@ -0,0 +1,293 @@ +!=============================================================================! +! This file is part of crest. +! +! Copyright (C) 2026 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!=============================================================================! + +module molbuilder_classify_func + use crest_parameters,only:wp,stdout + use strucrd,only:coord,i2e + use adjacency + use canonical_mod + use molbuilder_classify_type + use quicksort_interface, only: qqsorti + implicit none + private + + public :: functional_group_classify !> try to determine some functional groups + +!==============================================================================! +contains !> MODULE PROCEDURES START HERE +!==============================================================================! + +!> FUNCTIONAL GROUP CLASSIFICATION ROUTINES + + subroutine functional_group_classify(molc) + implicit none + type(coord_classify),intent(inout) :: molc + type(functional_group) :: fg + integer :: ii,jj,nn,nfunc + logical :: success,updated,duplicate + + if (.not.allocated(molc%atinfo)) then + call atinfo_classify(molc) + end if + + !> basic functional groups from single atoms + do ii = 1,molc%nat + call functional_group_classify_simple(molc,ii,fg,success) + if (success) then + call molc%add(fg) + end if + end do + + updated = .true. + nfunc = size(molc%funcgroups,1) + do while (updated) + + do ii = 1,nfunc + if (molc%funcgroups(ii)%seeded) cycle + call functional_group_classify_extended(molc,ii,fg,success) + if (success) then + !> check for duplicates, only add new ones + duplicate = .false. + do jj = 1,nfunc + if (all(molc%funcgroups(jj)%ids .eq. fg%ids)) duplicate = .true. + end do + if (.not.duplicate) call molc%add(fg) + end if + molc%funcgroups(ii)%seeded = .true. + end do + + nn = size(molc%funcgroups,1) + if (nn == nfunc) then + updated = .false. + else + nfunc = nn + end if + end do + + end subroutine functional_group_classify + + subroutine functional_group_classify_simple(molc,ii,fg,success) + implicit none + type(coord_classify),intent(in) :: molc + type(functional_group),intent(out) :: fg + integer,intent(in) :: ii + logical,intent(out) :: success + integer :: jj,kk + success = .false. + call fg%clear() + select case (trim(molc%atinfo(ii))) + case ('CH3') + fg%name = 'methyl' + fg%natms = 4 + allocate (fg%ids(4),source=0) + fg%ids(1) = ii + kk = 1 + do jj = 1,molc%nat + if (molc%A(jj,ii) == 1) then + if (molc%at(jj) == 1) then + kk = kk+1 + fg%ids(kk) = jj + else + fg%attached_to = jj + end if + end if + end do + success = .true. + + case ('OH') + fg%name = "hydroxy" + fg%natms = 2 + allocate (fg%ids(2),source=0) + fg%ids(1) = ii + kk = 1 + do jj = 1,molc%nat + if (molc%A(jj,ii) == 1) then + if (molc%at(jj) == 1) then + kk = kk+1 + fg%ids(kk) = jj + else + fg%attached_to = jj + end if + end if + end do + success = .true. + + case ('SH') + fg%name = "thiol" + fg%natms = 2 + allocate (fg%ids(2),source=0) + fg%ids(1) = ii + kk = 1 + do jj = 1,molc%nat + if (molc%A(jj,ii) == 1) then + if (molc%at(jj) == 1) then + kk = kk+1 + fg%ids(kk) = jj + else + fg%attached_to = jj + end if + end if + end do + success = .true. + + case ('NH2','NR2','NR3') + fg%name = "amine" + if (trim(molc%atinfo(ii)) == 'NH2') fg%name = fg%name//' (1°)' + if (trim(molc%atinfo(ii)) == 'NR2') fg%name = fg%name//' (2°)' + if (trim(molc%atinfo(ii)) == 'NR3') fg%name = fg%name//' (3°)' + fg%natms = 3 + allocate (fg%ids(3),source=0) + fg%ids(1) = ii + kk = 1 + do jj = 1,molc%nat + if (molc%A(jj,ii) == 1) then + if (molc%at(jj) == 1) then + kk = kk+1 + fg%ids(kk) = jj + else + !TODO: logic for NR2 and NR3 + fg%attached_to = jj + end if + end if + end do + success = .true. + + case ('o') + fg%natms = 2 + allocate (fg%ids(2),source=0) + fg%ids(1) = ii + kk = 1 + do jj = 1,molc%nat + if (molc%A(jj,ii) == 1) then + if (molc%at(jj) == 6) then + kk = kk+1 + fg%ids(kk) = jj + fg%attached_to = jj + end if + end if + end do + if (kk == 2) then + fg%name = 'carbonyl' + end if + success = .true. + + case ('F','Cl','Br','I') + fg%name = 'halide' + fg%natms = 1 + allocate (fg%ids(1),source=ii) + fg%attached_to = maxloc(molc%A(:,ii),1) + success = .true. + + end select + end subroutine functional_group_classify_simple + + subroutine functional_group_classify_extended(molc,ii,fg,success) + implicit none + type(coord_classify),intent(inout) :: molc + type(functional_group),intent(out) :: fg + integer,intent(in) :: ii + logical,intent(out) :: success + integer :: jj,kk + success = .false. + call fg%clear() + select case (trim(molc%funcgroups(ii)%name)) + case ('methyl') + + call check_alkyl(molc,ii,fg,success) + if (success) then + fg%name = 'alkyl' + fg%natms = count(molc%lwork) + allocate (fg%ids(fg%natms),source=0) + kk = 0 + do jj = 1,molc%nat + if (molc%lwork(jj)) then + kk = kk+1 + fg%ids(kk) = jj + end if + end do + call qqsorti(fg%ids,1,fg%natms) + end if + + end select + end subroutine functional_group_classify_extended + +!=============================================================================! +!#############################################################################! +!=============================================================================! + +!> routines to check for specific functional groups + + subroutine check_alkyl(molc,istart,fg,success) + implicit none + type(coord_classify),intent(inout) :: molc + type(functional_group),intent(out) :: fg + integer,intent(in) :: istart + logical,intent(out) :: success + logical :: contin + integer :: ii,jj,nat,ati,atii + + success = .false. + + !> prepare + nat = molc%nat + if (.not.allocated(molc%lwork)) allocate (molc%lwork(nat)) + + molc%lwork(:) = .false. + ati = molc%funcgroups(istart)%ids(1) + do ii = 1,molc%funcgroups(istart)%natms + molc%lwork(molc%funcgroups(istart)%ids(ii)) = .true. + end do + !> walk + contin = .true. + atii = ati + do while (contin) + do ii = 1,nat + if (molc%lwork(ii)) cycle !> skip alreaty iterated atoms + if (molc%A(ii,ati) == 1) then + if (molc%at(ii) == 1) then + molc%lwork(ii) = .true. !> H's simply set to true + else if (molc%at(ii) == 6) then + if (trim(molc%atinfo(ii)) == 'CH2') then + !> continue chain + success = .true. !> at the first occurence of CH2 we have at least ethyl + atii = ii + molc%lwork(ii) = .true. + else + !> terminate chain on non-CH2 + if (success) fg%attached_to = ii + contin = .false. + end if + else + !> terminate chain for hetero atoms + if (success) fg%attached_to = ii + contin = .false. + end if + end if + end do + if (atii == ati) contin = .false. + ati = atii + end do + + end subroutine check_alkyl + +!=============================================================================! +!#############################################################################! +!=============================================================================! +end module molbuilder_classify_func + diff --git a/src/molbuilder/classify_type.f90 b/src/molbuilder/classify_type.f90 new file mode 100644 index 00000000..1ce52fc9 --- /dev/null +++ b/src/molbuilder/classify_type.f90 @@ -0,0 +1,324 @@ +!=============================================================================! +! This file is part of crest. +! +! Copyright (C) 2026 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!=============================================================================! + +module molbuilder_classify_type + use crest_parameters,only:wp,stdout + use strucrd,only:coord,i2e,sumform + use adjacency + use canonical_mod + implicit none + private + + type :: functional_group + character(len=:),allocatable :: name + integer :: natms = 0 + integer,allocatable :: ids(:) + integer :: attached_to = 0 + logical :: seeded = .false. + contains + procedure :: clear => clear_func_group + procedure :: copy => copy_func_group + end type functional_group + + type,extends(coord) :: coord_classify + !> new components that are added to the coord type: + integer,allocatable :: A(:,:) !> molecular graph/adjacency matrix + integer,allocatable :: Ah(:,:) !> heavy-atom molecular graph/adjacency + + !> per-atom properties/information + real(wp),allocatable :: CN(:) !> coordination number + integer,allocatable :: hyb(:) !> hybridization/neighbours count + integer,allocatable :: nhn(:) !> non-H-neighbours count + integer,allocatable :: prio(:) !> "invariants"/atom priorities + logical,allocatable :: inring(:) !> atom part of ring? + logical,allocatable :: term(:) !> terminal atom (H,F,Cl,...,=O,etc.) + character(len=10),allocatable :: atinfo(:) !> atom info + + !> functional groups + integer :: nfuncs=0 + type(functional_group),allocatable :: funcgroups(:) + + !> utility storage + logical,allocatable :: lwork(:) + integer,allocatable :: iwork(:) + + contains + procedure :: as_coord + procedure :: from_coord + generic,public :: add => coord_classify_add_fg + procedure,private :: coord_classify_add_fg + procedure :: print_funcgroups => coord_classify_print_functional + end type coord_classify + + public :: coord_classify !> the extended coord type + public :: functional_group !> subtype of coord_classify + public :: setup_classify !> setup a coord_classify from coord + public :: atinfo_classify !> add atinfo string to a coord_classify + +!==============================================================================! +contains !> MODULE PROCEDURES START HERE +!==============================================================================! + +!> BASIC TYPE PROCEDURES + + function as_coord(this) result(mol) + class(coord_classify),intent(in) :: this + type(coord) :: mol + + mol%nat = this%nat + if (allocated(this%at)) mol%at = this%at + if (allocated(this%xyz)) mol%xyz = this%xyz + + mol%energy = this%energy + if (allocated(this%comment)) mol%comment = this%comment + mol%chrg = this%chrg + mol%uhf = this%uhf + mol%nbd = this%nbd + if (allocated(this%bond)) mol%bond = this%bond + if (allocated(this%lat)) mol%lat = this%lat + if (allocated(this%qat)) mol%qat = this%qat + mol%pdb = this%pdb + + end function as_coord + + subroutine from_coord(this,mol) + class(coord_classify),intent(inout) :: this + type(coord),intent(in) :: mol + + this%nat = mol%nat + if (allocated(mol%at)) this%at = mol%at + if (allocated(mol%xyz)) this%xyz = mol%xyz + + this%energy = mol%energy + if (allocated(mol%comment)) this%comment = mol%comment + this%chrg = mol%chrg + this%uhf = mol%uhf + this%nbd = mol%nbd + if (allocated(mol%bond)) this%bond = mol%bond + if (allocated(mol%lat)) this%lat = mol%lat + if (allocated(mol%qat)) this%qat = mol%qat + this%pdb = mol%pdb + end subroutine from_coord + + subroutine clear_func_group(self) + implicit none + class(functional_group) :: self + if (allocated(self%name)) deallocate (self%name) + if (allocated(self%ids)) deallocate (self%ids) + self%attached_to = 0 + self%natms = 0 + self%seeded = .false. + end subroutine clear_func_group + + subroutine copy_func_group(self,fg) + implicit none + class(functional_group) :: self + type(functional_group) :: fg + if (allocated(fg%name)) self%name = fg%name + if (allocated(fg%ids)) self%ids = fg%ids + self%attached_to = fg%attached_to + self%natms = fg%natms + self%seeded = fg%seeded + end subroutine copy_func_group + + subroutine coord_classify_add_fg(self,fg) + implicit none + class(coord_classify) :: self + type(functional_group) :: fg + type(functional_group),allocatable :: fg_list(:) + integer :: ii,jj + if (.not.allocated(self%funcgroups)) then + allocate (self%funcgroups(1)) + call self%funcgroups(1)%copy(fg) + else + ii = size(self%funcgroups,1) + allocate (fg_list(ii+1)) + do jj = 1,ii + call fg_list(jj)%copy(self%funcgroups(jj)) + end do + call fg_list(ii+1)%copy(fg) + call move_alloc(fg_list,self%funcgroups) + end if + self%nfuncs = size(self%funcgroups,1) + end subroutine coord_classify_add_fg + +!=============================================================================! +!#############################################################################! +!=============================================================================! + +!> CLASSIFICATION ROUTINES + + subroutine setup_classify(mol,molc) + !*************************************************** + !* set up the derived coord_classify object "molc" + !* from a standard coord object "mol". + !* in particular, adjacency graphs, CN, etc. + !*************************************************** + implicit none + type(coord),intent(in) :: mol + type(coord_classify),intent(out) :: molc + + real(wp),allocatable :: Bmat(:,:) + logical,allocatable :: rings(:,:) + type(canonical_sorter),allocatable :: tmpcan + integer :: nat + integer :: ii,jj + + !> Initialize + call molc%from_coord(mol) + nat = molc%nat + + !> set up CN, and from that topology + call mol%cn_to_bond(molc%CN,Bmat,'cov') + call wbo2adjacency(molc%nat,Bmat,molc%A,0.02_wp) + deallocate (Bmat) + + !> set up other parameters + allocate (molc%hyb(nat),source=0) + allocate (molc%inring(nat),source=.false.) + allocate (molc%term(nat),source=.false.) + call check_rings_min(nat,molc%A,rings) + do ii = 1,nat + molc%hyb(ii) = sum(molc%A(:,ii)) + if (any(rings(:,ii))) molc%inring(ii) = .true. + if (molc%hyb(ii) .eq. 1) molc%term(ii) = .true. + end do + + allocate (tmpcan) + call tmpcan%init(mol,invtype='apsp+',heavy=.false.) + call move_alloc(tmpcan%rank,molc%prio) + call move_alloc(tmpcan%hadjac,molc%Ah) + deallocate (tmpcan) + + allocate (molc%nhn(nat),source=0) + do ii = 1,nat + molc%nhn(ii) = sum(molc%Ah(:,ii)) + end do + + end subroutine setup_classify + + subroutine atinfo_classify(molc) + !***************************************** + !* Update a coord_classify object "molc" + !* and fill in its atinfo strings based + !* on some basic chemoinformatics. + !**************************************** + implicit none + type(coord_classify),intent(inout) :: molc + integer :: nat + integer :: ii,jj + + if (molc%nat <= 0) then + write (stdout,*) 'molc not allocated in atinfo_classify()' + return + end if + if (allocated(molc%atinfo)) deallocate (molc%atinfo) + nat = molc%nat + allocate (molc%atinfo(nat),source=repeat(' ',10)) + + do ii = 1,molc%nat + associate (str => molc%atinfo(ii),ati => molc%at(ii)) + str = trim(i2e(ati)) + select case (ati) + + case (6) !> carbon + if (molc%hyb(ii) == 3) then !> sp2 + str = trim(i2e(ati,'lc')) + else if (molc%hyb(ii) == 4) then !> sp3 + if (molc%nhn(ii) == 1) then + str = trim(str)//'H3' + else if (molc%nhn(ii) == 2) then + str = trim(str)//'H2' + else if (molc%nhn(ii) == 0) then + str = 'methane' + end if + end if + + case (7) !> nitrogen + if (molc%hyb(ii) == 3) then + if (molc%nhn(ii) == 1) then + str = trim(str)//'H2' + else if (molc%nhn(ii) == 2) then + str = trim(str)//'R2' + else if (molc%nhn(ii) == 3) then + str = trim(str)//'R3' + else if (molc%nhn(ii) == 0) then + str = 'ammonia' + end if + else if (molc%hyb(ii) == 4) then + str = trim(str)//'4+' + end if + + case (8) !> oxygen + if (molc%hyb(ii) == 1) then + str = 'o' + else if (molc%hyb(ii) == 2) then + if (molc%nhn(ii) == 1) then + str = trim(str)//'H' + else if (molc%nhn(ii) == 0) then + str = 'water' + end if + end if + + case (16) !> sulfur + if (molc%hyb(ii) == 2) then + if (molc%nhn(ii) == 1) then + str = trim(str)//'H' + end if + end if + + end select + end associate + end do + end subroutine atinfo_classify + +!=============================================================================! +!#############################################################################! +!=============================================================================! + +!> PRINTOUTS and naming + + subroutine coord_classify_print_functional(self,prch) + implicit none + class(coord_classify) :: self + integer,intent(in) :: prch + + integer,allocatable :: at(:) + integer :: ii,jj,nn + + if (.not.allocated(self%funcgroups)) return + + do ii = 1,size(self%funcgroups,1) + nn = self%funcgroups(ii)%natms + allocate(at(nn),source=0) + do jj=1,nn + at(jj) = self%at(self%funcgroups(ii)%ids(jj)) + enddo + write (prch,'(3(1x,a))') 'functional group:', & + & self%funcgroups(ii)%name,sumform(nn,at) + deallocate(at) + end do + + end subroutine coord_classify_print_functional + +!=============================================================================! +!#############################################################################! +!=============================================================================! +end module molbuilder_classify_type + diff --git a/src/molbuilder/meson.build b/src/molbuilder/meson.build index 89e795ca..be8febf5 100644 --- a/src/molbuilder/meson.build +++ b/src/molbuilder/meson.build @@ -22,4 +22,6 @@ srcs += files( 'construct.f90', 'construct_list.f90', 'classify.f90', + 'classify_type.f90', + 'classify_func.f90', ) diff --git a/src/msreact/msmod.f90 b/src/msreact/msmod.f90 index 055640ed..3a44183f 100644 --- a/src/msreact/msmod.f90 +++ b/src/msreact/msmod.f90 @@ -774,7 +774,7 @@ subroutine write_fragments(env,mso,estart,nisomers,nfragpairs,fname,lprint) character(len=80) :: comment logical :: ex logical :: lprint - character(len=40) :: sumform,sumformula + character(len=40) :: sumformula real(wp) :: mass,erel nat = mso%pl%mol(1)%nat diff --git a/src/strucreader.f90 b/src/strucreader.f90 index 76628d63..e32284b2 100644 --- a/src/strucreader.f90 +++ b/src/strucreader.f90 @@ -139,6 +139,7 @@ module strucrd public :: mollist public :: coordline public :: get_atlist + public :: sumform !=========================================================================================! !coord class. contains a single structure in the PDB format. @@ -794,7 +795,7 @@ subroutine openensemble(self,fname) end if else call rdensemble_coord_type(fname,self%nall,self%structures) - allocate(self%er(nall),source=0.0_wp) + allocate (self%er(nall),source=0.0_wp) self%er(:) = self%structures(:)%energy end if @@ -2465,6 +2466,43 @@ subroutine atswp(self,ati,atj) self%at(atj) = attmp end subroutine atswp +!=========================================================================================! + + function sumform(nat,at) result(sumformula) +!************************************************ +!* get sumformula as a string from the AT array +!************************************************ + implicit none + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + character(len=:),allocatable :: sumformula + integer :: sumat(118) + integer :: i + character(len=6) :: str + sumformula = '' + sumat = 0 + do i = 1,nat + sumat(at(i)) = sumat(at(i))+1 + end do + !> carbon always first + if (sumat(6) > 0) then + write (str,'(a,i0)') trim(adjustl(i2e(6,'nc'))),sumat(6) + sumformula = trim(sumformula)//trim(str) + end if + do i = 2,118 + if (i == 6) cycle + if (sumat(i) .lt. 1) cycle + write (str,'(a,i0)') trim(adjustl(i2e(i,'nc'))),sumat(i) + sumformula = trim(sumformula)//trim(str) + end do + !> hydrogen always last + if (sumat(1) > 0) then + write (str,'(a,i0)') trim(adjustl(i2e(1,'nc'))),sumat(1) + sumformula = trim(sumformula)//trim(str) + end if + return + end function sumform + !=========================================================================================! !=========================================================================================! ! end of the module From fa1c916fd4a12248fdedc50c0df8afe2d279a1a1 Mon Sep 17 00:00:00 2001 From: LukasRindt Date: Mon, 19 Jan 2026 11:00:09 +0100 Subject: [PATCH 142/374] gf0 init added --- src/calculator/hr_utils.f90 | 12 +++++++++--- src/parsing/parse_calcdata.f90 | 18 +++++++++++------- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/src/calculator/hr_utils.f90 b/src/calculator/hr_utils.f90 index c319d54f..09ef834c 100644 --- a/src/calculator/hr_utils.f90 +++ b/src/calculator/hr_utils.f90 @@ -57,20 +57,26 @@ subroutine initialize_hessian(calc,type,xyz,nat,at,hess,hguess,pr) !>Matrix is f call clevel%create('gfnff', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? call newcalc%add(clevel) call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) - call dsqtoh(nat3,hess_full(:,:),hess(:)) + call dsqtoh(nat3,hess_full(:,:),hess(:)) !>Pack Hessian case(2) + allocate(hess_full(nat3,nat3),source=0.0_wp) + call clevel%create('gfn0', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? + call newcalc%add(clevel) + call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) + call dsqtoh(nat3,hess_full(:,:),hess(:)) + case(3) allocate(hess_full(nat3,nat3),source=0.0_wp) call clevel%create('gfn1', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? call newcalc%add(clevel) call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) call dsqtoh(nat3,hess_full(:,:),hess(:)) - case(3) + case(4) allocate(hess_full(nat3,nat3),source=0.0_wp) call clevel%create('gfn2', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? call newcalc%add(clevel) call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) call dsqtoh(nat3,hess_full(:,:),hess(:)) - case(4) + case(5) call modhes(calc,mhset,nat,xyz,at,hess(:),pr) end select diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index eb440cbe..de4bb8dc 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -604,30 +604,34 @@ subroutine parse_calc_auto(env,calc,kv,rd) calc%initialize_hr_type = 0 case('gfnff', 'gfn-ff') calc%initialize_hr_type = 1 - case('gfn1') + case('gfn0') calc%initialize_hr_type = 2 - case('gfn2') + case('gfn1') calc%initialize_hr_type = 3 - case('lindh') + case('gfn2') calc%initialize_hr_type = 4 + case('lindh') + calc%initialize_hr_type = 5 case default !>--- keyword was recognized, but invalid argument supplied write (stdout,fmtura) kv%value_c call creststop(status_config) end select - case ('hess_init','hess_initialization') !> here we set how the matrix for hessian reconstruction is initialized + case ('hess_init','hess_initialization') !> here we set how the hessian for optimization select case (kv%value_c) case('identity') calc%hess_init = 0 case('gfnff', 'gfn-ff') calc%hess_init = 1 - case('gfn1') + case('gfn0') calc%hess_init = 2 - case('gfn2') + case('gfn1') calc%hess_init = 3 - case('lindh') + case('gfn2') calc%hess_init = 4 + case('lindh') + calc%hess_init = 5 case default !>--- keyword was recognized, but invalid argument supplied write (stdout,fmtura) kv%value_c From 73790c9df1049956affa7e31165f110e32ba41e2 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 19 Jan 2026 21:45:52 +0100 Subject: [PATCH 143/374] Repair aklylize alignment --- src/algos/alkylize.f90 | 97 +++++- src/algos/playground.f90 | 1 + src/algos/queueing.f90 | 5 - src/algos/search_1.f90 | 8 +- src/algos/search_conformers.f90 | 540 +++++++++++++++--------------- src/algos/search_entropy.f90 | 10 +- src/algos/search_newnci.f90 | 10 +- src/molbuilder/classify_func.f90 | 20 +- src/molbuilder/construct.f90 | 43 ++- src/molbuilder/construct_list.f90 | 1 - src/strucreader.f90 | 26 +- 11 files changed, 454 insertions(+), 307 deletions(-) diff --git a/src/algos/alkylize.f90 b/src/algos/alkylize.f90 index cf22fccb..f092f76d 100644 --- a/src/algos/alkylize.f90 +++ b/src/algos/alkylize.f90 @@ -27,20 +27,103 @@ subroutine crest_setup_alkylize(env) type(coord_classify) :: molc type(coord) :: mol + integer :: ii,jj,kk + integer :: splt(3) + call env%ref%to(mol) call underline("Analyzing Input Structure") call setup_classify(mol,molc) call functional_group_classify(molc) - if(molc%nfuncs == 0)then - write(stdout,'(a)') 'no relevant substructures found' - else - write(stdout,'(a)') 'Found the following substructure parts' + if (molc%nfuncs == 0) then + write (stdout,'(a)') 'no relevant substructures found' + return + else + write (stdout,'(a)') 'Found the following substructure parts' call molc%print_funcgroups(stdout) - endif + end if + + do ii = 1,molc%nfuncs + associate (func => molc%funcgroups(ii)) + if (trim(func%name) == 'alkyl') then + + !> only for propane or longer + if (func%natms > 6) then + write (stdout,'(a)') 'selected alkyl group for fragment dispatching' + splt(:) = 0 + splt(1) = func%attached_to + kk = 1 + do while (kk < 3) + do jj = 1,molc%nat + if (molc%Ah(jj,splt(kk)) == 1.and. & + & .not.any(splt(:) .eq. jj).and. & + & any(func%ids(:) .eq. jj)) then + kk = kk+1 + splt(kk) = jj + end if + end do + end do + call env%addsplitqueue(splt) + end if - !> TODO the actual checkup + end if + end associate + end do - write(stdout,*) + write (stdout,*) end subroutine crest_setup_alkylize + +subroutine crest_proxy_nalkane(env,doreturn) + use crest_parameters + use crest_data + use strucrd + use molbuilder_classify + use INTERNALS_mod + implicit none + type(systemdata),intent(inout) :: env + logical,intent(out) :: doreturn + type(coord) :: mol,newmol + type(coord_classify) :: molc + integer :: ii,jj + integer,allocatable :: na(:),nb(:),nc(:) + real(wp),allocatable :: zmat(:,:) + + doreturn = .false. + + if (env%alkylize) then + call env%ref%to(mol) + call setup_classify(mol,molc) + call functional_group_classify(molc) + + do ii = 1,molc%nfuncs + if (molc%funcgroups(ii)%name == 'alkane') then + write (stdout,'(a)') '> This substructure contains an n-alkane.' + write (stdout,'(a)') '> SKIPPING sampling and writing linear structure.' + doreturn = .true. + + !> ZMAT construction to make the molecule linear + allocate (na(mol%nat),nb(mol%nat),nc(mol%nat),source=0) + allocate (zmat(3,mol%nat),source=0.0_wp) + call BETTER_XYZINT(mol%nat,mol%xyz,molc%A,na,nb,nc,zmat) + + !> setting internal CC dihedrals to trans-config + do jj=1,mol%nat + if(mol%at(jj) == 6 .and. mol%at(na(jj)) == 6 .and. & + mol%at(nb(jj)) == 6 .and. mol%at(nc(jj)) == 6)then + zmat(3,jj) = -pi + endif + enddo + call smallhead('Internal coordinates:') + call print_zmat(stdout,mol%nat,mol%at,zmat,na,nb,nc,.true.) + call reconstruct_zmat_to_mol(mol%nat,mol%at,zmat,na,nb,nc,newmol) + call newmol%write(conformerfile) + + exit + end if + end do + + end if + +end subroutine crest_proxy_nalkane + diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index 2d79367c..5f8d4a7e 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -93,6 +93,7 @@ subroutine crest_playground(env,tim) call newc%print_funcgroups(stdout) + write(*,*) newc%sumform() end block !========================================================================================! diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index c300104d..d021b46b 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -219,11 +219,6 @@ subroutine crest_queue_iter(env,iterate) call queue%calc%copy(env%calc,ignore_constraints=.true.) !> for constraints we must be careful and map them to the new order call update_constraints_queue(heap,jj,kk,env%calc,queue%calc) - do ll = 1,heap%layer(jj)%node(kk)%nat - atj = heap%layer(jj)%origin(kk)%map(ll) - write (*,*) 'c',ll,'o',atj - - end do call queue%calc%info(stdout) diff --git a/src/algos/search_1.f90 b/src/algos/search_1.f90 index 14613288..ece172ff 100644 --- a/src/algos/search_1.f90 +++ b/src/algos/search_1.f90 @@ -43,7 +43,7 @@ subroutine crest_search_1(env,tim) real(wp),allocatable :: eread(:) real(wp),allocatable :: xyz(:,:,:) integer,allocatable :: at(:) - logical :: dump + logical :: dump,doreturn !===========================================================! !>--- printout header @@ -61,10 +61,8 @@ subroutine crest_search_1(env,tim) write (stdout,*) !>--- saftey termination - if(mol%nat .le. 2)then - call catchdiatomic(env) - return - endif + call crest_sampling_skip(env,doreturn) + if (doreturn) return !===========================================================! !>--- Dynamics diff --git a/src/algos/search_conformers.f90 b/src/algos/search_conformers.f90 index 46842502..85d098d1 100644 --- a/src/algos/search_conformers.f90 +++ b/src/algos/search_conformers.f90 @@ -20,12 +20,12 @@ subroutine crest_search_imtdgc(env,tim) !******************************************************************* !* This is the re-implementation of CREST's iMTD-GC default workflow -!* +!* !* Compared to the legacy implementation, this version !* is separated from the entropy algo to keep things clean !* The entropy algo (sMTD-iMTD) can be found in search_entropy.f90 !******************************************************************* - use crest_parameters, only: wp,stdout + use crest_parameters,only:wp,stdout use crest_data use crest_calculator use strucrd @@ -39,7 +39,7 @@ subroutine crest_search_imtdgc(env,tim) type(timer),intent(inout) :: tim type(coord) :: mol,molnew integer :: i,j,k,l,io,ich,m - logical :: pr,wr + logical :: pr,wr,doreturn !===========================================================! type(calcdata) :: calc type(mddata) :: mddat @@ -74,142 +74,138 @@ subroutine crest_search_imtdgc(env,tim) call mol%append(stdout) write (stdout,*) -!>--- saftey termination - if(mol%nat .le. 2)then - call catchdiatomic(env) - return - endif - - !call env%calc%info(stdout) +!>--- saftey terminations + call crest_sampling_skip(env,doreturn) + if (doreturn) return !>--- sets the MD length according to a flexibility measure - call md_length_setup(env) + call md_length_setup(env) !>--- create the MD calculator saved to env call env_to_mddat(env) if (env%performMTD) then !>--- (optional) calculate a short 1ps test MTD to check settings - call tim%start(1,'Trial metadynamics (MTD)') - call trialmd(env) - call tim%stop(1) - if(env%iostatus_meta .ne. 0 ) return + call tim%start(1,'Trial metadynamics (MTD)') + call trialmd(env) + call tim%stop(1) + if (env%iostatus_meta .ne. 0) return end if !===========================================================! -!>--- Start mainloop +!>--- Start mainloop env%nreset = 0 start = .true. - MAINLOOP : do + MAINLOOP: do call printiter - if (.not. start) then + if (.not.start) then !>--- clean Dir for new iterations, but leave iteration backup files - call clean_V2i - env%nreset = env%nreset + 1 - else + call clean_V2i + env%nreset = env%nreset+1 + else !>--- at the beginning, wipe directory clean call V2cleanup(.false.) end if !===========================================================! !>--- Meta-dynamics loop - mtdloop: do i = 1,env%Maxrestart + mtdloop: do i = 1,env%Maxrestart - write(stdout,*) - write(stdout,'(1x,a)') '------------------------------' - write(stdout,'(1x,a,i0)') 'Meta-Dynamics Iteration ',i - write(stdout,'(1x,a)') '------------------------------' + write (stdout,*) + write (stdout,'(1x,a)') '------------------------------' + write (stdout,'(1x,a,i0)') 'Meta-Dynamics Iteration ',i + write (stdout,'(1x,a)') '------------------------------' - nsim = -1 !>--- enambles automatic MTD setup in init routines - call crest_search_multimd_init(env,mol,mddat,nsim) - allocate (mddats(nsim), source=mddat) - call crest_search_multimd_init2(env,mddats,nsim) + nsim = -1 !>--- enambles automatic MTD setup in init routines + call crest_search_multimd_init(env,mol,mddat,nsim) + allocate (mddats(nsim),source=mddat) + call crest_search_multimd_init2(env,mddats,nsim) - call tim%start(2,'Metadynamics (MTD)') - call crest_search_multimd(env,mol,mddats,nsim) - call tim%stop(2) + call tim%start(2,'Metadynamics (MTD)') + call crest_search_multimd(env,mol,mddats,nsim) + call tim%stop(2) !>--- a file called crest_dynamics.trj.xyz should have been written - ensnam = 'crest_dynamics.trj.xyz' + ensnam = 'crest_dynamics.trj.xyz' !>--- deallocate for next iteration - if(allocated(mddats))deallocate(mddats) + if (allocated(mddats)) deallocate (mddats) !==========================================================! !>--- Reoptimization of trajectories - call tim%start(3,'Geometry optimization') - call optlev_to_multilev(env%optlev,multilevel) - call crest_multilevel_oloop(env,ensnam,multilevel) - call tim%stop(3) - if(env%iostatus_meta .ne. 0 ) return + call tim%start(3,'Geometry optimization') + call optlev_to_multilev(env%optlev,multilevel) + call crest_multilevel_oloop(env,ensnam,multilevel) + call tim%stop(3) + if (env%iostatus_meta .ne. 0) return !>--- save the CRE under a backup name - call checkname_xyz(crefile,atmp,str) - call checkname_xyz('.cre',str,btmp) - call rename(atmp,btmp) + call checkname_xyz(crefile,atmp,str) + call checkname_xyz('.cre',str,btmp) + call rename(atmp,btmp) !>--- save cregen output - call checkname_tmp('cregen',atmp,btmp) - call rename('cregen.out.tmp',btmp) + call checkname_tmp('cregen',atmp,btmp) + call rename('cregen.out.tmp',btmp) !=========================================================! !>--- cleanup after first iteration and prepare next - if (i .eq. 1 .and. start) then - start = .false. + if (i .eq. 1.and.start) then + start = .false. !>-- obtain a first lowest energy as reference - env%eprivious = env%elowest + env%eprivious = env%elowest !>-- remove the two extreme-value MTDs - if (.not. env%readbias .and. env%runver .ne. 33 .and. & - & env%runver .ne. 787878 ) then - env%nmetadyn = env%nmetadyn - 2 - end if -!>-- the cleanup - call clean_V2i + if (.not.env%readbias.and.env%runver .ne. 33.and. & + & env%runver .ne. 787878) then + env%nmetadyn = env%nmetadyn-2 + end if +!>-- the cleanup + call clean_V2i !>-- and always do two cycles of MTDs - cycle mtdloop - endif + cycle mtdloop + end if !=========================================================! !>--- Check for lowest energy - call elowcheck(lower,env) - if (.not. lower) then - exit mtdloop - end if - enddo mtdloop + call elowcheck(lower,env) + if (.not.lower) then + exit mtdloop + end if + end do mtdloop !=========================================================! !>--- collect all ensembles from mtdloop and merge - write(stdout,*) - write (stdout,'(''========================================'')') - write (stdout,'('' MTD Simulations done '')') - write (stdout,'(''========================================'')') - write (stdout,'(1x,''Collecting ensmbles.'')') + write (stdout,*) + write (stdout,'(''========================================'')') + write (stdout,'('' MTD Simulations done '')') + write (stdout,'(''========================================'')') + write (stdout,'(1x,''Collecting ensmbles.'')') !>-- collecting all ensembles saved as ".cre_*.xyz" - call collectcre(env) - call newcregen(env,0) - call checkname_xyz(crefile,atmp,btmp) + call collectcre(env) + call newcregen(env,0) + call checkname_xyz(crefile,atmp,btmp) !>--- remaining number of structures - call remaining_in(atmp,env%ewin,nallout) + call remaining_in(atmp,env%ewin,nallout) !=========================================================! !>--- (optional) Perform additional MDs on the lowest conformers - if (env%rotamermds) then - call tim%start(4,'Molecular dynamics (MD)') - call crest_rotamermds(env,conformerfile) - call tim%stop(4) - if(env%iostatus_meta .ne. 0 ) return + if (env%rotamermds) then + call tim%start(4,'Molecular dynamics (MD)') + call crest_rotamermds(env,conformerfile) + call tim%stop(4) + if (env%iostatus_meta .ne. 0) return !>--- Reoptimization of trajectories - call checkname_xyz(crefile,atmp,btmp) - write(stdout,'('' Appending file '',a,'' with new structures'')')trim(atmp) - ensnam = 'crest_dynamics.trj.xyz' - call appendto(ensnam,trim(atmp)) - call tim%start(3,'Geometry optimization') - call crest_multilevel_wrap(env,trim(atmp),-1) - call tim%stop(3) - if(env%iostatus_meta .ne. 0 ) return - - call elowcheck(lower,env) - if (lower) then - call checkname_xyz(crefile,atmp,str) - call checkname_xyz('.cre',str,btmp) - call rename(atmp,btmp) - cycle MAINLOOP + call checkname_xyz(crefile,atmp,btmp) + write (stdout,'('' Appending file '',a,'' with new structures'')') trim(atmp) + ensnam = 'crest_dynamics.trj.xyz' + call appendto(ensnam,trim(atmp)) + call tim%start(3,'Geometry optimization') + call crest_multilevel_wrap(env,trim(atmp),-1) + call tim%stop(3) + if (env%iostatus_meta .ne. 0) return + + call elowcheck(lower,env) + if (lower) then + call checkname_xyz(crefile,atmp,str) + call checkname_xyz('.cre',str,btmp) + call rename(atmp,btmp) + cycle MAINLOOP + end if end if - end if !=========================================================! !>--- (optional) Perform GC step @@ -217,7 +213,7 @@ subroutine crest_search_imtdgc(env,tim) call tim%start(5,'Genetic crossing (GC)') call crest_newcross3(env) call tim%stop(5) - if(env%iostatus_meta .ne. 0 ) return + if (env%iostatus_meta .ne. 0) return call confg_chk3(env) call elowcheck(lower,env) @@ -231,32 +227,32 @@ subroutine crest_search_imtdgc(env,tim) !==========================================================! !>--- exit mainloop - exit MAINLOOP - enddo MAINLOOP + exit MAINLOOP + end do MAINLOOP !==========================================================! !>--- final ensemble optimization - write (stdout,'(/)') - write (stdout,'(3x,''================================================'')') - write (stdout,'(3x,''| Final Geometry Optimization |'')') - write (stdout,'(3x,''================================================'')') - call tim%start(3,'Geometry optimization') - call checkname_xyz(crefile,atmp,str) - call crest_multilevel_wrap(env,trim(atmp),0) - call tim%stop(3) - if(env%iostatus_meta .ne. 0 ) return + write (stdout,'(/)') + write (stdout,'(3x,''================================================'')') + write (stdout,'(3x,''| Final Geometry Optimization |'')') + write (stdout,'(3x,''================================================'')') + call tim%start(3,'Geometry optimization') + call checkname_xyz(crefile,atmp,str) + call crest_multilevel_wrap(env,trim(atmp),0) + call tim%stop(3) + if (env%iostatus_meta .ne. 0) return !==========================================================! !>--- final ensemble sorting -! call newcregen(env,0) +! call newcregen(env,0) !> this is actually done within the last crest_multilevel_ !> call, so I comment it out here !==========================================================! !>--- print CREGEN results and clean up Directory a bit - write (stdout,'(/)') - call smallhead('Final Ensemble Information') - call V2terminating() + write (stdout,'(/)') + call smallhead('Final Ensemble Information') + call V2terminating() !==========================================================! return @@ -271,7 +267,7 @@ subroutine crest_multilevel_wrap(env,ensnam,level) !* wrapper for the multilevel_oloop to select !* only a single optimization level !************************************************* - use crest_parameters, only: wp,stdout,bohr + use crest_parameters,only:wp,stdout,bohr use crest_data use crest_calculator use strucrd @@ -282,15 +278,15 @@ subroutine crest_multilevel_wrap(env,ensnam,level) logical :: multilevel(6) integer :: k multilevel = .false. - select case(level) - case( 1: ) !> explicit selection (level is a positie integer) - k = min(level,6) - multilevel(k) =.true. - case default - !>-- map global variable to multilevel selection (level is 0 or negative) - k = optlevmap_alt(env%optlev) + level + select case (level) + case (1:) !> explicit selection (level is a positie integer) + k = min(level,6) + multilevel(k) = .true. + case default + !>-- map global variable to multilevel selection (level is 0 or negative) + k = optlevmap_alt(env%optlev)+level k = max(1,k) - multilevel(k) =.true. + multilevel(k) = .true. end select call crest_multilevel_oloop(env,ensnam,multilevel) end subroutine crest_multilevel_wrap @@ -302,7 +298,7 @@ subroutine crest_multilevel_oloop(env,ensnam,multilevel_in) !* construct consecutive optimizations starting with !* crude thresholds to very tight ones !******************************************************* - use crest_parameters, only: wp,stdout,bohr + use crest_parameters,only:wp,stdout,bohr use crest_data use crest_calculator use strucrd @@ -311,7 +307,7 @@ subroutine crest_multilevel_oloop(env,ensnam,multilevel_in) use crest_restartlog use parallel_interface implicit none - type(systemdata) :: env + type(systemdata) :: env character(len=*),intent(in) :: ensnam logical,intent(in) :: multilevel_in(6) integer :: nat,nall @@ -327,7 +323,7 @@ subroutine crest_multilevel_oloop(env,ensnam,multilevel_in) integer :: optlevelbackup logical :: multilevel(6) - interface + interface subroutine crest_refine(env,input,output) use crest_data implicit none @@ -338,151 +334,151 @@ end subroutine crest_refine end interface !>--- save backup thresholds - ewinbackup = env%ewin - rthrbackup = env%rthr + ewinbackup = env%ewin + rthrbackup = env%rthr optlevelbackup = env%calc%optlev - hlowbackup = env%calc%hlow_opt - microbackup = env%calc%micro_opt + hlowbackup = env%calc%hlow_opt + microbackup = env%calc%micro_opt !>--- set multilevels, or enforce just one multilevel(:) = .false. - if(env%multilevelopt)then - multilevel(:) = multilevel_in(:) + if (env%multilevelopt) then + multilevel(:) = multilevel_in(:) else k = optlevmap_alt(env%optlev) multilevel(k) = .true. - endif + end if pr = .false. l = count(multilevel) - if( l > 1 )then - pr = .true. - write(stdout,*) - write(stdout,'(1x,a)') '======================================' - write(stdout,'(1x,a)') '| Multilevel Ensemble Optimization |' - write(stdout,'(1x,a)') '======================================' - endif - + if (l > 1) then + pr = .true. + write (stdout,*) + write (stdout,'(1x,a)') '======================================' + write (stdout,'(1x,a)') '| Multilevel Ensemble Optimization |' + write (stdout,'(1x,a)') '======================================' + end if + !>--- read ensemble call rdensembleparam(ensnam,nat,nall) if (nall .lt. 1) then - write(stdout,*) '**ERROR** empty ensemble file ',trim(ensnam) + write (stdout,*) '**ERROR** empty ensemble file ',trim(ensnam) env%iostatus_meta = status_failed return - endif + end if allocate (xyz(3,nat,nall),at(nat),eread(nall)) call rdensemble(ensnam,nat,nall,at,xyz,eread) !>--- track ensemble for restart call trackensemble(ensnam,nat,nall,at,xyz,eread) !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: crest_oloop requires coordinates in Bohrs - xyz = xyz / bohr + xyz = xyz/bohr !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- sequential optimizations of ensembles dump = .true. !> optimized structures will be written to crest_ensemble.xyz - do i=1,6 - if(multilevel(i))then - !>--- set threads - call new_ompautoset(env,'auto',nall,T,Tn) - !>--- set optimization parameters - call set_multilevel_options(env,i,.true.) - !>--- run parallel optimizations - call crest_oloop(env,nat,nall,at,xyz,eread,dump) - deallocate(eread,at,xyz) - !>--- rename ensemble and sort - call checkname_xyz(crefile,inpnam,outnam) - call rename(ensemblefile,trim(inpnam)) - !>--- check for empty ensemble content - call rdensembleparam(trim(inpnam),nat,nall) - if (nall .lt. 1) then - write(stdout,*) '**ERROR** empty ensemble file',trim(inpnam) - env%iostatus_meta = status_failed - return - endif - - write(stdout,*) - !==========================================================! - !>-- dedicated ensemble refinement step (overwrites inpnam) - call crest_refine(env,trim(inpnam)) - !==========================================================! - - !>--- CREGEN sorting - call sort_and_check(env,trim(inpnam)) - call checkname_xyz(crefile,inpnam,outnam) - !>--- check for empty ensemble content (again) - call rdensembleparam(trim(inpnam),nat,nall) - if (nall .lt. 1) then - write(stdout,*) '**ERROR** empty ensemble file',trim(inpnam) - env%iostatus_meta = status_failed - return - endif - !>--- read new ensemble for next iteration - allocate (xyz(3,nat,nall),at(nat),eread(nall)) - call rdensemble(trim(inpnam),nat,nall,at,xyz,eread) - !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: crest_oloop requires coordinates in Bohrs - xyz = xyz / bohr - !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- restore default sorting thresholds - env%ewin = ewinbackup - env%rthr = rthrbackup - env%calc%optlev = optlevelbackup - env%calc%hlow_opt = hlowbackup - env%calc%micro_opt = microbackup - endif - enddo - - if(allocated(eread)) deallocate(eread) - if(allocated(at)) deallocate(at) - if(allocated(xyz)) deallocate(xyz) + do i = 1,6 + if (multilevel(i)) then + !>--- set threads + call new_ompautoset(env,'auto',nall,T,Tn) + !>--- set optimization parameters + call set_multilevel_options(env,i,.true.) + !>--- run parallel optimizations + call crest_oloop(env,nat,nall,at,xyz,eread,dump) + deallocate (eread,at,xyz) + !>--- rename ensemble and sort + call checkname_xyz(crefile,inpnam,outnam) + call rename(ensemblefile,trim(inpnam)) + !>--- check for empty ensemble content + call rdensembleparam(trim(inpnam),nat,nall) + if (nall .lt. 1) then + write (stdout,*) '**ERROR** empty ensemble file',trim(inpnam) + env%iostatus_meta = status_failed + return + end if + + write (stdout,*) + !==========================================================! + !>-- dedicated ensemble refinement step (overwrites inpnam) + call crest_refine(env,trim(inpnam)) + !==========================================================! + + !>--- CREGEN sorting + call sort_and_check(env,trim(inpnam)) + call checkname_xyz(crefile,inpnam,outnam) + !>--- check for empty ensemble content (again) + call rdensembleparam(trim(inpnam),nat,nall) + if (nall .lt. 1) then + write (stdout,*) '**ERROR** empty ensemble file',trim(inpnam) + env%iostatus_meta = status_failed + return + end if + !>--- read new ensemble for next iteration + allocate (xyz(3,nat,nall),at(nat),eread(nall)) + call rdensemble(trim(inpnam),nat,nall,at,xyz,eread) + !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: crest_oloop requires coordinates in Bohrs + xyz = xyz/bohr + !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- restore default sorting thresholds + env%ewin = ewinbackup + env%rthr = rthrbackup + env%calc%optlev = optlevelbackup + env%calc%hlow_opt = hlowbackup + env%calc%micro_opt = microbackup + end if + end do + + if (allocated(eread)) deallocate (eread) + if (allocated(at)) deallocate (at) + if (allocated(xyz)) deallocate (xyz) return contains subroutine set_multilevel_options(env,i,pr) implicit none type(systemdata) :: env integer,intent(in) :: i - logical,intent(in) :: pr + logical,intent(in) :: pr - env%calc%hlow_opt = env%hlowopt + env%calc%hlow_opt = env%hlowopt env%calc%micro_opt = nint(env%microopt) - select case( i ) - case( 1 ) - if(pr) call smallhead('crude pre-optimization') - env%calc%optlev = -3 - !> larger thresholds - env%rthr = env%rthr * 2.0d0 - env%ewin = aint(env%ewin * 2.0d0) - case( 2 ) - if(pr) call smallhead('optimization with very loose thresholds') - env%calc%optlev = -2 - env%rthr = env%rthr *1.5d0 - env%ewin = aint(env%ewin * 2.0d0) - case( 3 ) - if(pr) call smallhead('optimization with loose thresholds') - env%calc%optlev = -1 + select case (i) + case (1) + if (pr) call smallhead('crude pre-optimization') + env%calc%optlev = -3 + !> larger thresholds + env%rthr = env%rthr*2.0d0 + env%ewin = aint(env%ewin*2.0d0) + case (2) + if (pr) call smallhead('optimization with very loose thresholds') + env%calc%optlev = -2 + env%rthr = env%rthr*1.5d0 + env%ewin = aint(env%ewin*2.0d0) + case (3) + if (pr) call smallhead('optimization with loose thresholds') + env%calc%optlev = -1 env%ewin = aint(env%ewin*(10.0d0/6.0d0)) - case( 4 ) - if(pr) call smallhead('optimization with regular thresholds') - env%calc%optlev = 0 - case( 5 ) - if(pr) call smallhead('optimization with tight thresholds') - env%calc%optlev = 1 - case( 6 ) - if(pr) call smallhead('optimization with very tight thresholds') - env%calc%optlev = 2 + case (4) + if (pr) call smallhead('optimization with regular thresholds') + env%calc%optlev = 0 + case (5) + if (pr) call smallhead('optimization with tight thresholds') + env%calc%optlev = 1 + case (6) + if (pr) call smallhead('optimization with very tight thresholds') + env%calc%optlev = 2 case default - if(pr) call smallhead('optimization with default thresholds') - env%ewin = 6.0_wp - env%rthr = 0.125_wp - env%calc%optlev = 0 + if (pr) call smallhead('optimization with default thresholds') + env%ewin = 6.0_wp + env%rthr = 0.125_wp + env%calc%optlev = 0 end select - call print_opt_data(env%calc, stdout, natoms=env%ref%nat) + call print_opt_data(env%calc,stdout,natoms=env%ref%nat) end subroutine set_multilevel_options end subroutine crest_multilevel_oloop @@ -493,7 +489,7 @@ subroutine crest_rotamermds(env,ensnam) !* set up and perform several MDs at different temperatures !* on the lowest few conformers !*********************************************************** - use crest_parameters, only: wp,stdout,bohr + use crest_parameters,only:wp,stdout,bohr use crest_data use crest_calculator use strucrd @@ -506,7 +502,7 @@ subroutine crest_rotamermds(env,ensnam) integer :: nsim type(mddata) :: mddat type(mddata),allocatable :: mddats(:) - type(coord) :: mol + type(coord) :: mol type(coord),allocatable :: mols(:) integer :: nat,nall real(wp),allocatable :: eread(:) @@ -515,65 +511,65 @@ subroutine crest_rotamermds(env,ensnam) integer :: nstrucs,i,j,k,io real(wp) :: temp,newtemp character(len=80) :: atmp - + !>--- coord setup call env%ref%to(mol) call rdensembleparam(ensnam,nat,nall) if (nall .lt. 1) then - write(stdout,*) '**ERROR** empty ensemble file',trim(ensnam) + write (stdout,*) '**ERROR** empty ensemble file',trim(ensnam) env%iostatus_meta = status_failed return - endif + end if !>--- determine how many MDs need to be run and setup call adjustnormmd(env) - nstrucs = min(nall, env%nrotammds) - nsim = nstrucs * env%temps + nstrucs = min(nall,env%nrotammds) + nsim = nstrucs*env%temps call crest_search_multimd_init(env,mol,mddat,nsim) - allocate (mddats(nsim), source=mddat) + allocate (mddats(nsim),source=mddat) call crest_search_multimd_init2(env,mddats,nsim) !>--- adjust T's and runtimes k = 0 - do i=1,env%temps + do i = 1,env%temps !> each T block 100K higher - temp = env%nmdtemp + (i-1)*100.0_wp - do j=1,nstrucs - k= k + 1 + temp = env%nmdtemp+(i-1)*100.0_wp + do j = 1,nstrucs + k = k+1 mddats(k)%tsoll = temp !> reduce runtime by 50% compared to MTDs - mddats(k)%length_ps = mddats(k)%length_ps * 0.5_wp + mddats(k)%length_ps = mddats(k)%length_ps*0.5_wp call mdautoset(mddats(k),io) - enddo - enddo + end do + end do !>--- read ensemble and prepare mols allocate (xyz(3,nat,nall),at(nat),eread(nall)) call rdensemble(ensnam,nat,nall,at,xyz,eread) !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: mols must be in Bohrs - xyz = xyz / bohr + xyz = xyz/bohr !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- print what we are doing - write(stdout,*) - write(atmp,'(''Additional regular MDs on lowest '',i0,'' conformer(s)'')')nstrucs - call smallheadline(trim(atmp)) + write (stdout,*) + write (atmp,'(''Additional regular MDs on lowest '',i0,'' conformer(s)'')') nstrucs + call smallheadline(trim(atmp)) !>--- and finally, run the MDs call crest_search_multimd2(env,mols,mddats,nsim) - if(allocated(mols))deallocate(mols) - if(allocated(mddats))deallocate(mddats) + if (allocated(mols)) deallocate (mols) + if (allocated(mddats)) deallocate (mddats) return end subroutine crest_rotamermds @@ -589,7 +585,7 @@ subroutine crest_newcross3(env) use iomod use utilities implicit none - type(systemdata) :: env + type(systemdata) :: env real(wp) :: ewinbackup integer :: i,imax,tmpconf,nremain character(len=128) :: inpnam,outnam,refnam @@ -605,8 +601,8 @@ subroutine crest_newcross3(env) imax = min(nint(env%mdtime*50.0d0),5000) if (env%setgcmax) then imax = nint(env%gcmax) - else if(imax<0)then - imax=5000 + else if (imax < 0) then + imax = 5000 end if if (env%quick) then imax = nint(float(imax)*0.5d0) @@ -614,7 +610,7 @@ subroutine crest_newcross3(env) !>-- call the crossing routine call checkname_xyz(crefile,refnam,tmppath) - call touch(trim(tmppath)) + call touch(trim(tmppath)) call crest_crossing(env,imax,trim(refnam),env%gcmaxparent) if (imax .lt. 1) then call remove(trim(tmppath)) @@ -629,17 +625,39 @@ subroutine crest_newcross3(env) multilevel(4) = .true. end if call crest_multilevel_oloop(env,'confcross.xyz',multilevel) - if(env%iostatus_meta .ne. 0 ) return + if (env%iostatus_meta .ne. 0) return !>-- append optimized crossed structures and original to a single file call checkname_xyz(crefile,inpnam,outnam) - write(stdout,'(a,a)')'appending new structures to ',trim(refnam) + write (stdout,'(a,a)') 'appending new structures to ',trim(refnam) call appendto(trim(inpnam),trim(refnam)) - do while(trim(inpnam).ne.trim(refnam)) + do while (trim(inpnam) .ne. trim(refnam)) call remove(trim(inpnam)) call checkname_xyz(crefile,inpnam,outnam) - enddo + end do end do end subroutine crest_newcross3 +!=============================================================================! +!#############################################################################! +!=============================================================================! + +subroutine crest_sampling_skip(env,doreturn) + use crest_data + implicit none + type(systemdata),intent(inout) :: env + logical,intent(out) :: doreturn + + doreturn = .false. + + !> Diatomic molecules need no sampling + if (env%ref%nat .le. 2) then + call catchdiatomic(env) + doreturn = .true. + return + end if + + !> "alkylize" special runtype + call crest_proxy_nalkane(env,doreturn) +end subroutine crest_sampling_skip diff --git a/src/algos/search_entropy.f90 b/src/algos/search_entropy.f90 index c273cdca..a2b62afb 100644 --- a/src/algos/search_entropy.f90 +++ b/src/algos/search_entropy.f90 @@ -37,7 +37,7 @@ subroutine crest_search_entropy(env,tim) type(timer),intent(inout) :: tim type(coord) :: mol,molnew integer :: i,j,k,l,io,ich,m - logical :: pr,wr + logical :: pr,wr,doreturn !===========================================================! type(calcdata) :: calc type(mddata) :: mddat @@ -80,11 +80,9 @@ subroutine crest_search_entropy(env,tim) call mol%append(stdout) write (stdout,*) -!>--- saftey termination - if(mol%nat .le. 2)then - call catchdiatomic(env) - return - endif +!>--- saftey terminations + call crest_sampling_skip(env,doreturn) + if (doreturn) return !>--- sets the MD length according to a flexibility measure call md_length_setup(env) diff --git a/src/algos/search_newnci.f90 b/src/algos/search_newnci.f90 index f5323e1e..eaf1f403 100644 --- a/src/algos/search_newnci.f90 +++ b/src/algos/search_newnci.f90 @@ -36,7 +36,7 @@ subroutine crest_search_newnci(env,tim) type(timer),intent(inout) :: tim type(coord) :: mol,molnew integer :: i,j,k,l,io,ich,m - logical :: pr,wr + logical :: pr,wr,doreturn !===========================================================! type(calcdata) :: calc type(mddata) :: mddat @@ -71,11 +71,9 @@ subroutine crest_search_newnci(env,tim) call mol%append(stdout) write (stdout,*) -!>--- saftey termination - if(mol%nat .le. 2)then - call catchdiatomic(env) - return - endif +!>--- saftey terminations + call crest_sampling_skip(env,doreturn) + if (doreturn) return !>--- sets the MD length according to a flexibility measure call md_length_setup(env) diff --git a/src/molbuilder/classify_func.f90 b/src/molbuilder/classify_func.f90 index b1db1d85..9f59bc15 100644 --- a/src/molbuilder/classify_func.f90 +++ b/src/molbuilder/classify_func.f90 @@ -23,7 +23,7 @@ module molbuilder_classify_func use adjacency use canonical_mod use molbuilder_classify_type - use quicksort_interface, only: qqsorti + use quicksort_interface,only:qqsorti implicit none private @@ -39,7 +39,7 @@ subroutine functional_group_classify(molc) implicit none type(coord_classify),intent(inout) :: molc type(functional_group) :: fg - integer :: ii,jj,nn,nfunc + integer :: ii,jj,nn,nfunc,nfunc2 logical :: success,updated,duplicate if (.not.allocated(molc%atinfo)) then @@ -55,7 +55,7 @@ subroutine functional_group_classify(molc) end do updated = .true. - nfunc = size(molc%funcgroups,1) + nfunc = molc%nfuncs do while (updated) do ii = 1,nfunc @@ -64,7 +64,8 @@ subroutine functional_group_classify(molc) if (success) then !> check for duplicates, only add new ones duplicate = .false. - do jj = 1,nfunc + nfunc2 = molc%nfuncs + do jj = 1,nfunc2 if (all(molc%funcgroups(jj)%ids .eq. fg%ids)) duplicate = .true. end do if (.not.duplicate) call molc%add(fg) @@ -72,7 +73,7 @@ subroutine functional_group_classify(molc) molc%funcgroups(ii)%seeded = .true. end do - nn = size(molc%funcgroups,1) + nn = molc%nfuncs if (nn == nfunc) then updated = .false. else @@ -209,9 +210,9 @@ subroutine functional_group_classify_extended(molc,ii,fg,success) select case (trim(molc%funcgroups(ii)%name)) case ('methyl') + !> n-alkyl chains always start from methyl call check_alkyl(molc,ii,fg,success) if (success) then - fg%name = 'alkyl' fg%natms = count(molc%lwork) allocate (fg%ids(fg%natms),source=0) kk = 0 @@ -265,6 +266,13 @@ subroutine check_alkyl(molc,istart,fg,success) else if (molc%at(ii) == 6) then if (trim(molc%atinfo(ii)) == 'CH2') then !> continue chain + fg%name = 'alkyl' + success = .true. !> at the first occurence of CH2 we have at least ethyl + atii = ii + molc%lwork(ii) = .true. + else if (trim(molc%atinfo(ii)) == 'CH3') then + !> continue chain + fg%name = 'alkane' success = .true. !> at the first occurence of CH2 we have at least ethyl atii = ii molc%lwork(ii) = .true. diff --git a/src/molbuilder/construct.f90 b/src/molbuilder/construct.f90 index 5a45f603..d14aa665 100644 --- a/src/molbuilder/construct.f90 +++ b/src/molbuilder/construct.f90 @@ -66,10 +66,11 @@ subroutine attach(base,side,alignmap,new,clash, & integer,allocatable :: revorder_base(:),revorder_side(:) real(wp) :: rms,Umat(3,3),shift(3),center_base(3),center_side(3) integer :: nalign,nat_new - - integer :: ii,jj,kk + logical :: closcontact + integer :: ii,jj,kk,ll character(len=*),parameter :: source = "attach()" + real(wp),parameter :: closedist = 0.95_wp !> defaults/checks of the alignmap nalign = size(alignmap,1) @@ -186,9 +187,28 @@ subroutine attach(base,side,alignmap,new,clash, & if (present(original_map)) then !> if we have info on the original order, avoid all atoms !> present in all fragments + closcontact = .false. do ii = 1,size(original_map,1) if (all(original_map(ii,:) .ne. 0)) then - cutlist_side(original_map(ii,2)) = .true. + if (.not.closcontact) then + cutlist_side(original_map(ii,2)) = .true. + else + cutlist_base(original_map(ii,1)) = .true. + end if + jj = original_map(ii,1) + if (.not.closcontact) then + do kk = 1,size(original_map,1) + ll = original_map(kk,2) + if (ll .ne. 0.and.original_map(kk,1) .eq. 0) then + !write (*,*) ii,jj,ll,sqrt(sum((side_tmp%xyz(:,ll)-base%xyz(:,jj))**2)) + if ((sum((side_tmp%xyz(:,ll)-base%xyz(:,jj))**2)) < closedist) then + closcontact = .true. + cutlist_side(original_map(ii,2)) = .false. + cutlist_base(original_map(ii,1)) = .true. + end if + end if + end do + end if end if if (original_map(ii,1) .ne. 0) then revorder_base(original_map(ii,1)) = ii @@ -197,6 +217,15 @@ subroutine attach(base,side,alignmap,new,clash, & revorder_side(original_map(ii,2)) = ii end if end do + if (closcontact) then + do kk = 1,size(original_map,1) + if (all(original_map(kk,:) .ne. 0).and. & + .not.any(original_map(kk,1) .eq. alignmap(:,1))) then + cutlist_side(original_map(kk,2)) = .false. + cutlist_base(original_map(kk,1)) = .true. + end if + end do + end if end if kk = max(maxval(revorder_base),maxval(revorder_side)) new%nat = 0 @@ -212,10 +241,10 @@ subroutine attach(base,side,alignmap,new,clash, & do ii = 1,side%nat if (.not.cutlist_side(ii)) then new%nat = new%nat+1 - if(revorder_side(ii).eq.0)then - kk=kk+1 - revorder_side(ii) = kk - endif + if (revorder_side(ii) .eq. 0) then + kk = kk+1 + revorder_side(ii) = kk + end if end if end do allocate (new%at(new%nat),source=0) diff --git a/src/molbuilder/construct_list.f90 b/src/molbuilder/construct_list.f90 index 5062621a..6bf3761c 100644 --- a/src/molbuilder/construct_list.f90 +++ b/src/molbuilder/construct_list.f90 @@ -121,7 +121,6 @@ recursive subroutine find_original_atoms(heap,targetlayer,targetnode,atoms) integer :: ii,jj,kk,nat,dim1,dim2 integer,allocatable :: tmpatoms(:) - write(*,*) "calling find_original_atoms" associate (layer => heap%layer(targetlayer)) nat = layer%node(targetnode)%nat allocate (atoms(nat),source=0) diff --git a/src/strucreader.f90 b/src/strucreader.f90 index e32284b2..d9a8b0fc 100644 --- a/src/strucreader.f90 +++ b/src/strucreader.f90 @@ -217,6 +217,7 @@ module strucrd procedure :: get_z => coord_get_z !> calculate nuclear charge procedure :: cn_to_bond => coord_cn_to_bond !> generate neighbour matrix from CN procedure :: swap => atswp !> swap two atoms coordinates and their at() entries + procedure :: sumform => coord_sumform !> generate a string with the sum formula end type coord !=========================================================================================! !> ensemble class. contains all structures of an ensemble @@ -2486,23 +2487,42 @@ function sumform(nat,at) result(sumformula) end do !> carbon always first if (sumat(6) > 0) then - write (str,'(a,i0)') trim(adjustl(i2e(6,'nc'))),sumat(6) + if (sumat(6) > 1) then + write (str,'(a,i0)') trim(adjustl(i2e(6,'nc'))),sumat(6) + else + str = 'C' + end if sumformula = trim(sumformula)//trim(str) end if do i = 2,118 if (i == 6) cycle if (sumat(i) .lt. 1) cycle - write (str,'(a,i0)') trim(adjustl(i2e(i,'nc'))),sumat(i) + if (sumat(i) > 1) then + write (str,'(a,i0)') trim(adjustl(i2e(i,'nc'))),sumat(i) + else + str = trim(i2e(i,'nc')) + end if sumformula = trim(sumformula)//trim(str) end do !> hydrogen always last if (sumat(1) > 0) then - write (str,'(a,i0)') trim(adjustl(i2e(1,'nc'))),sumat(1) + if (sumat(1) > 1) then + write (str,'(a,i0)') trim(adjustl(i2e(1,'nc'))),sumat(1) + else + str = 'H' + end if sumformula = trim(sumformula)//trim(str) end if return end function sumform + function coord_sumform(self) result(sumformula) + implicit none + class(coord) :: self + character(len=:),allocatable :: sumformula + sumformula = sumform(self%nat,self%at) + end function coord_sumform + !=========================================================================================! !=========================================================================================! ! end of the module From 56221d63f73ec10a5f75733c7647f3f275dd3d6b Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 20 Jan 2026 14:22:21 +0100 Subject: [PATCH 144/374] Bugfixes and minitool for func groups --- src/algos/alkylize.f90 | 2 +- src/minitools.f90 | 11 +++++++++-- src/molbuilder/classify_func.f90 | 1 + 3 files changed, 11 insertions(+), 3 deletions(-) diff --git a/src/algos/alkylize.f90 b/src/algos/alkylize.f90 index f092f76d..9aba1376 100644 --- a/src/algos/alkylize.f90 +++ b/src/algos/alkylize.f90 @@ -58,7 +58,7 @@ subroutine crest_setup_alkylize(env) do jj = 1,molc%nat if (molc%Ah(jj,splt(kk)) == 1.and. & & .not.any(splt(:) .eq. jj).and. & - & any(func%ids(:) .eq. jj)) then + & any(func%ids(:) .eq. jj) .and. kk < 3) then kk = kk+1 splt(kk) = jj end if diff --git a/src/minitools.f90 b/src/minitools.f90 index af53131f..fec05bce 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -395,6 +395,7 @@ subroutine testtopo(fname,env,tmode) use atmasses use zdata use strucrd + use molbuilder_classify implicit none type(systemdata) :: env character(len=*) :: fname @@ -402,6 +403,7 @@ subroutine testtopo(fname,env,tmode) character(len=*) :: tmode type(zmolecule) :: zmol type(coord) :: mol + type(coord_classify) :: molc real(wp),allocatable :: xyz(:,:) real(wp) :: dum integer,allocatable :: inc(:) @@ -474,7 +476,6 @@ subroutine testtopo(fname,env,tmode) if (.not.env%legacy.and.env%calc%ncalculations == 0) then call env2calc_setup(env) end if - call thermo_wrap(env,.true.,zmol%nat,zmol%at,xyz,'', & & nt,temps,et,ht,gt,stot,.false.) deallocate (stot,gt,ht,et,temps) @@ -504,10 +505,16 @@ subroutine testtopo(fname,env,tmode) end do close (ich) + case ('func') + call setup_classify(mol,molc) + call functional_group_classify(molc) + call molc%print_funcgroups(stdout) + + end select deallocate (xyz) write (*,*) - stop + call creststop(status_normal) end subroutine testtopo !========================================================================================! diff --git a/src/molbuilder/classify_func.f90 b/src/molbuilder/classify_func.f90 index 9f59bc15..a5722f29 100644 --- a/src/molbuilder/classify_func.f90 +++ b/src/molbuilder/classify_func.f90 @@ -66,6 +66,7 @@ subroutine functional_group_classify(molc) duplicate = .false. nfunc2 = molc%nfuncs do jj = 1,nfunc2 + if (molc%funcgroups(jj)%natms .ne. fg%natms) cycle if (all(molc%funcgroups(jj)%ids .eq. fg%ids)) duplicate = .true. end do if (.not.duplicate) call molc%add(fg) From 0bfd27b3850f0ec1d6221ebd4a735763273f2b8b Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 21 Jan 2026 16:07:21 +0100 Subject: [PATCH 145/374] alkylize, fix linearizing --- src/algos/alkylize.f90 | 51 +++++++++++------ src/algos/queueing.f90 | 9 ++- src/confparse.f90 | 6 +- src/crest_main.f90 | 1 + src/molbuilder/analyze.f90 | 87 +++++++++++++++------------- src/molbuilder/classify_func.f90 | 14 ++--- src/molbuilder/classify_type.f90 | 98 ++++++++++++++++++++++++++++---- src/molbuilder/construct.f90 | 15 ++++- src/molbuilder/tree.f90 | 9 +-- 9 files changed, 203 insertions(+), 87 deletions(-) diff --git a/src/algos/alkylize.f90 b/src/algos/alkylize.f90 index 9aba1376..977c9acc 100644 --- a/src/algos/alkylize.f90 +++ b/src/algos/alkylize.f90 @@ -27,7 +27,7 @@ subroutine crest_setup_alkylize(env) type(coord_classify) :: molc type(coord) :: mol - integer :: ii,jj,kk + integer :: ii,jj,kk,cc integer :: splt(3) call env%ref%to(mol) @@ -58,15 +58,25 @@ subroutine crest_setup_alkylize(env) do jj = 1,molc%nat if (molc%Ah(jj,splt(kk)) == 1.and. & & .not.any(splt(:) .eq. jj).and. & - & any(func%ids(:) .eq. jj) .and. kk < 3) then + & any(func%ids(:) .eq. jj).and.kk < 3) then kk = kk+1 splt(kk) = jj end if end do end do + !kk = 3 + !cc = splt(2) + !do jj = 1,molc%nat + ! if (molc%A(jj,cc) == 1.and. & + ! & .not.any(splt(:) .eq. jj).and. & + ! & any(func%ids(:) .eq. jj).and.molc%at(jj) == 1) then + ! kk = kk+1 + ! splt(kk) = jj + ! end if + !end do call env%addsplitqueue(splt) end if - + write (stdout,'(2x,a,5(1x,i0))') '> shared atoms:',splt(:) end if end associate end do @@ -88,6 +98,7 @@ subroutine crest_proxy_nalkane(env,doreturn) integer :: ii,jj integer,allocatable :: na(:),nb(:),nc(:) real(wp),allocatable :: zmat(:,:) + integer :: itmp(3) doreturn = .false. @@ -102,21 +113,25 @@ subroutine crest_proxy_nalkane(env,doreturn) write (stdout,'(a)') '> SKIPPING sampling and writing linear structure.' doreturn = .true. - !> ZMAT construction to make the molecule linear - allocate (na(mol%nat),nb(mol%nat),nc(mol%nat),source=0) - allocate (zmat(3,mol%nat),source=0.0_wp) - call BETTER_XYZINT(mol%nat,mol%xyz,molc%A,na,nb,nc,zmat) - - !> setting internal CC dihedrals to trans-config - do jj=1,mol%nat - if(mol%at(jj) == 6 .and. mol%at(na(jj)) == 6 .and. & - mol%at(nb(jj)) == 6 .and. mol%at(nc(jj)) == 6)then - zmat(3,jj) = -pi - endif - enddo - call smallhead('Internal coordinates:') - call print_zmat(stdout,mol%nat,mol%at,zmat,na,nb,nc,.true.) - call reconstruct_zmat_to_mol(mol%nat,mol%at,zmat,na,nb,nc,newmol) + call molc%get_zmat(.true.) + call molc%print_zmat(stdout) + + !> ZMAT construction to make the molecule linear + do jj = 1,molc%nat + if (molc%ztod(jj) .ne. 0) then + itmp(1) = molc%at(jj) + itmp(2) = molc%at(molc%zmap(jj,1)) + itmp(3) = molc%at(molc%zmap(jj,2)) + if(all(itmp(:).eq.6))then + !write(*,*) 'C-C bond:',molc%zmap(jj,1:2) + molc%zmat(3,jj) = -pi + endif + end if + end do + call molc%print_zmat(stdout) + call molc%from_zmat(newmol) + !call reconstruct_zmat_to_mol(mol%nat,mol%at,molc%zmat, & + ! molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3),newmol) call newmol%write(conformerfile) exit diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index d021b46b..8865e651 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -300,6 +300,7 @@ subroutine crest_queue_reconstruct(env,tim) type(coord) :: mol integer :: ii,jj,kk,nall type(coord),allocatable :: structures(:) + character(len=*),parameter :: recfile = 'crest_reconstruct.xyz' if (.not. (allocated(env%splitqueue).and.env%splitheap%nqueue > 0)) then return @@ -324,7 +325,13 @@ subroutine crest_queue_reconstruct(env,tim) structures(ii) = env%splitheap%layer(1)%mols(ii) end do deallocate (env%splitheap%layer(1)%mols) - call wrensemble('crest_queue_reconstruct.xyz',nall,structures) + + write(stdout,'(/,1x,a)') 'Wrting reconstructed structures to: "'//recfile//'"' + call wrensemble(recfile,nall,structures) + + write(stdout,*) + call crest_multilevel_wrap(env,recfile,0) + contains recursive subroutine recusrive_construct(env,heap,targetlayer) diff --git a/src/confparse.f90 b/src/confparse.f90 index 3fc9c94a..b69364f3 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -1147,7 +1147,9 @@ subroutine parseflags(env,arg,nra) case ('-keepdir','-keeptmp') !> Do not delete temporary directories at the end env%keepModef = .true. case ('-opt','-optlev') !> settings for optimization level of GFN-xTB - env%optlev = optlevnum(arg(i+1)) + if (nra >= i+1) then + env%optlev = optlevnum(arg(i+1)) + end if write (*,'(2x,a,1x,a)') trim(arg(i)),optlevflag(env%optlev) case ('-gfn','-gfn1','-gfn2','-gfn0','-gff','-gfnff') ctmp = argument @@ -2164,7 +2166,7 @@ subroutine parseflags(env,arg,nra) end if !>--- avoid 0 potscal - if(env%potscal < 1.0d-5) env%potscal = 1.0_wp + if (env%potscal < 1.0d-5) env%potscal = 1.0_wp !>--- automatic wall potential for the LEGACY version if ((env%NCI.or.env%wallsetup).and.env%legacy) then diff --git a/src/crest_main.f90 b/src/crest_main.f90 index 3518f56e..aa3faa9b 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -322,6 +322,7 @@ program CREST end do ITERATOR + env%calc => calc_origin call crest_queue_reconstruct(env,tim) !=========================================================================================! diff --git a/src/molbuilder/analyze.f90 b/src/molbuilder/analyze.f90 index edad5caf..99c26751 100644 --- a/src/molbuilder/analyze.f90 +++ b/src/molbuilder/analyze.f90 @@ -17,9 +17,8 @@ ! along with crest. If not, see . !================================================================================! -module rigidconf_analyze +module molbuilder_rigidconf_analyze use crest_parameters - use crest_data use strucrd use geo use INTERNALS_mod @@ -32,7 +31,7 @@ module rigidconf_analyze !========================================================================================! !========================================================================================! - subroutine rigidconf_analyze_fallback(env,mol,zmat,na,nb,nc,wbo, & + subroutine rigidconf_analyze_fallback(mol,zmat,na,nb,nc,wbo, & & ndieder,dvalues,dstep,ztod) !************************************************************ !* Fallback routine for the dihedral setup. @@ -43,7 +42,7 @@ subroutine rigidconf_analyze_fallback(env,mol,zmat,na,nb,nc,wbo, & !* dstep of 120° !* !* Input: -!* env,mol,zmat,na,nb,nc,wbo,ndieder +!* mol,zmat,na,nb,nc,wbo,ndieder !* !* Output: !* dvalues, dstep, ztod @@ -51,7 +50,6 @@ subroutine rigidconf_analyze_fallback(env,mol,zmat,na,nb,nc,wbo, & !************************************************************ implicit none !> INPUT - type(systemdata),intent(inout) :: env type(coord),intent(in) :: mol !> by convention mol is in Bohrs real(wp),intent(in) :: zmat(3,mol%nat) integer,intent(in) :: na(mol%nat),nb(mol%nat),nc(mol%nat) @@ -98,7 +96,7 @@ subroutine rigidconf_analyze_fallback(env,mol,zmat,na,nb,nc,wbo, & end subroutine rigidconf_analyze_fallback !========================================================================================! - subroutine rigidconf_count_fallback(nat,na,nb,nc,wbo,ndieder,ztod) + subroutine rigidconf_count_fallback(nat,na,nb,nc,A,ndieder,ztod) !************************************************************ !* Count number of unique single-bond dihedral angles that !* correspond to an entry in the zmat. @@ -107,7 +105,7 @@ subroutine rigidconf_count_fallback(nat,na,nb,nc,wbo,ndieder,ztod) !> INPUT integer,intent(in) :: nat integer,intent(in) :: na(nat),nb(nat),nc(nat) - real(wp),intent(in) :: wbo(nat,nat) + integer,intent(in) :: A(nat,nat) !> OUTPUT integer,intent(out) :: ndieder integer,intent(out),optional :: ztod(nat) @@ -128,7 +126,7 @@ subroutine rigidconf_count_fallback(nat,na,nb,nc,wbo,ndieder,ztod) if (Amap(j,l) > 0) then m = Amap(j,l) else - if (nint(wbo(j,l)) == 1) then + if (A(j,l) == 1) then k = k+1 Amap(j,l) = k Amap(l,j) = k @@ -144,44 +142,51 @@ subroutine rigidconf_count_fallback(nat,na,nb,nc,wbo,ndieder,ztod) end subroutine rigidconf_count_fallback !========================================================================================! - subroutine prune_zmat_dihedrals(nat,xyz,zmat,na,nb,nc,ztod) + subroutine prune_zmat_dihedrals(mol,zmat,na,nb,nc,ztod) !******************************************************** !* Remove zmat entries that correspond !* to the same bond and replace them with internal -!* dihedral angles. There you go, Christoph... +!* dihedral angles. +!* Giving preference to non-H-atoms in the selection !******************************************************** implicit none - integer,intent(in) :: nat - real(wp),intent(in) :: xyz(3,nat) - real(wp),intent(inout) :: zmat(3,nat) - integer,intent(inout) :: na(nat),nb(nat),nc(nat) - integer,intent(inout) :: ztod(nat) + class(coord),intent(in) :: mol + real(wp),intent(inout) :: zmat(3,mol%nat) + integer,intent(inout) :: na(mol%nat),nb(mol%nat),nc(mol%nat) + integer,intent(inout) :: ztod(mol%nat) integer :: i,j,k,l integer :: maxgroup,nmembers,refi - write (*,*) ztod - maxgroup = maxval(ztod,1) - do i = 1,maxgroup - nmembers = count(ztod(:) .eq. i) - if (nmembers < 2) cycle - do j = 1,nat - if (ztod(j) == i) then - refi = j - exit - end if - end do - do j = 1,nat - if (j == refi) cycle - if (ztod(j) == i) then - !nc(j) = nb(j) - nc(j) = refi - !call BANGLE2( xyz, j, na(j), nb(j), zmat(2,j) ) - call DIHED2(xyz,j,na(j),nb(j),nc(j),zmat(3,j)) - ztod(j) = 0 + associate (nat => mol%nat,at => mol%at,xyz => mol%xyz) + maxgroup = maxval(ztod,1) + do i = 1,maxgroup + nmembers = count(ztod(:) .eq. i) + if (nmembers < 2) cycle + refi = 0 + do j = 1,nat + if (ztod(j) == i.and.at(j) > 1) then + refi = j + exit + end if + end do + if (refi == 0) then + do j = 1,nat + if (ztod(j) == i) then + refi = j + exit + end if + end do end if + do j = 1,nat + if (j == refi) cycle + if (ztod(j) == i) then + nc(j) = refi + call DIHED2(xyz,j,na(j),nb(j),nc(j),zmat(3,j)) + ztod(j) = 0 + end if + end do end do - end do - write (*,*) ztod + end associate end subroutine prune_zmat_dihedrals !========================================================================================! @@ -261,7 +266,7 @@ subroutine rigidconf_user_file(fname,nat,na,nb,nc,wbo,ndieder,ztod,dvalues,dstep write (stdout,'(a,i0,1x,i0)') '**WARNING** no bond defined for atoms ',i,j cycle end if - write(stdout,'(">",1x,a,i0,a,i0,a,i0)') 'adding ',abs(n),' points for bond between atoms ', & + write (stdout,'(">",1x,a,i0,a,i0,a,i0)') 'adding ',abs(n),' points for bond between atoms ', & & i,' and ',j tmppairs(i,j) = abs(n) tmppairs(j,i) = abs(n) @@ -271,16 +276,16 @@ subroutine rigidconf_user_file(fname,nat,na,nb,nc,wbo,ndieder,ztod,dvalues,dstep allocate (dvalues(ndieder),source=0) allocate (dstep(ndieder),source=0.0_wp) dvalues(:) = 0 - dstep(:) = 360.0_wp * degtorad + dstep(:) = 360.0_wp*degtorad k = 0 do i = 1,nat do j = 1,i-1 if (tmppairs(j,i) > 0) then m = Amap(j,i) - if(m == 0) cycle + if (m == 0) cycle n = tmppairs(j,i) dvalues(m) = n - dstep(m) = (360.0_wp / real(n)) * degtorad + dstep(m) = (360.0_wp/real(n))*degtorad end if end do end do @@ -292,4 +297,4 @@ end subroutine rigidconf_user_file !========================================================================================! !========================================================================================! -end module rigidconf_analyze +end module molbuilder_rigidconf_analyze diff --git a/src/molbuilder/classify_func.f90 b/src/molbuilder/classify_func.f90 index a5722f29..13bc1bc4 100644 --- a/src/molbuilder/classify_func.f90 +++ b/src/molbuilder/classify_func.f90 @@ -101,7 +101,7 @@ subroutine functional_group_classify_simple(molc,ii,fg,success) fg%ids(1) = ii kk = 1 do jj = 1,molc%nat - if (molc%A(jj,ii) == 1) then + if (molc%bond(jj,ii) == 1) then if (molc%at(jj) == 1) then kk = kk+1 fg%ids(kk) = jj @@ -119,7 +119,7 @@ subroutine functional_group_classify_simple(molc,ii,fg,success) fg%ids(1) = ii kk = 1 do jj = 1,molc%nat - if (molc%A(jj,ii) == 1) then + if (molc%bond(jj,ii) == 1) then if (molc%at(jj) == 1) then kk = kk+1 fg%ids(kk) = jj @@ -137,7 +137,7 @@ subroutine functional_group_classify_simple(molc,ii,fg,success) fg%ids(1) = ii kk = 1 do jj = 1,molc%nat - if (molc%A(jj,ii) == 1) then + if (molc%bond(jj,ii) == 1) then if (molc%at(jj) == 1) then kk = kk+1 fg%ids(kk) = jj @@ -158,7 +158,7 @@ subroutine functional_group_classify_simple(molc,ii,fg,success) fg%ids(1) = ii kk = 1 do jj = 1,molc%nat - if (molc%A(jj,ii) == 1) then + if (molc%bond(jj,ii) == 1) then if (molc%at(jj) == 1) then kk = kk+1 fg%ids(kk) = jj @@ -176,7 +176,7 @@ subroutine functional_group_classify_simple(molc,ii,fg,success) fg%ids(1) = ii kk = 1 do jj = 1,molc%nat - if (molc%A(jj,ii) == 1) then + if (molc%bond(jj,ii) == 1) then if (molc%at(jj) == 6) then kk = kk+1 fg%ids(kk) = jj @@ -193,7 +193,7 @@ subroutine functional_group_classify_simple(molc,ii,fg,success) fg%name = 'halide' fg%natms = 1 allocate (fg%ids(1),source=ii) - fg%attached_to = maxloc(molc%A(:,ii),1) + fg%attached_to = maxloc(molc%bond(:,ii),1) success = .true. end select @@ -261,7 +261,7 @@ subroutine check_alkyl(molc,istart,fg,success) do while (contin) do ii = 1,nat if (molc%lwork(ii)) cycle !> skip alreaty iterated atoms - if (molc%A(ii,ati) == 1) then + if (molc%bond(ii,ati) == 1) then if (molc%at(ii) == 1) then molc%lwork(ii) = .true. !> H's simply set to true else if (molc%at(ii) == 6) then diff --git a/src/molbuilder/classify_type.f90 b/src/molbuilder/classify_type.f90 index 1ce52fc9..5925f1cc 100644 --- a/src/molbuilder/classify_type.f90 +++ b/src/molbuilder/classify_type.f90 @@ -22,6 +22,8 @@ module molbuilder_classify_type use strucrd,only:coord,i2e,sumform use adjacency use canonical_mod + use molbuilder_rigidconf_analyze + use INTERNALS_mod implicit none private @@ -38,7 +40,7 @@ module molbuilder_classify_type type,extends(coord) :: coord_classify !> new components that are added to the coord type: - integer,allocatable :: A(:,:) !> molecular graph/adjacency matrix + !integer,allocatable :: A(:,:) !> molecular graph/adjacency matrix integer,allocatable :: Ah(:,:) !> heavy-atom molecular graph/adjacency !> per-atom properties/information @@ -51,9 +53,15 @@ module molbuilder_classify_type character(len=10),allocatable :: atinfo(:) !> atom info !> functional groups - integer :: nfuncs=0 + integer :: nfuncs = 0 type(functional_group),allocatable :: funcgroups(:) + !> internal coordinates + integer :: ndieder = 0 + real(wp),allocatable :: zmat(:,:) + integer,allocatable :: zmap(:,:) !> na,nb,nc + integer,allocatable :: ztod(:) + !> utility storage logical,allocatable :: lwork(:) integer,allocatable :: iwork(:) @@ -63,7 +71,10 @@ module molbuilder_classify_type procedure :: from_coord generic,public :: add => coord_classify_add_fg procedure,private :: coord_classify_add_fg + procedure :: get_zmat => coord_classify_calculate_zmat + procedure :: from_zmat => coord_classify_reconstruct_from_zmat procedure :: print_funcgroups => coord_classify_print_functional + procedure :: print_zmat => coord_classify_print_zmat end type coord_classify public :: coord_classify !> the extended coord type @@ -164,7 +175,7 @@ end subroutine coord_classify_add_fg !> CLASSIFICATION ROUTINES - subroutine setup_classify(mol,molc) + subroutine setup_classify(mol,molc,wbo) !*************************************************** !* set up the derived coord_classify object "molc" !* from a standard coord object "mol". @@ -173,6 +184,7 @@ subroutine setup_classify(mol,molc) implicit none type(coord),intent(in) :: mol type(coord_classify),intent(out) :: molc + real(wp),intent(in),optional :: wbo(:,:) real(wp),allocatable :: Bmat(:,:) logical,allocatable :: rings(:,:) @@ -186,16 +198,19 @@ subroutine setup_classify(mol,molc) !> set up CN, and from that topology call mol%cn_to_bond(molc%CN,Bmat,'cov') - call wbo2adjacency(molc%nat,Bmat,molc%A,0.02_wp) + if (present(wbo)) then + Bmat(:,:) = wbo(:,:) + end if + call wbo2adjacency(molc%nat,Bmat,molc%bond,0.02_wp) deallocate (Bmat) !> set up other parameters allocate (molc%hyb(nat),source=0) allocate (molc%inring(nat),source=.false.) allocate (molc%term(nat),source=.false.) - call check_rings_min(nat,molc%A,rings) + call check_rings_min(nat,molc%bond,rings) do ii = 1,nat - molc%hyb(ii) = sum(molc%A(:,ii)) + molc%hyb(ii) = sum(molc%bond(:,ii)) if (any(rings(:,ii))) molc%inring(ii) = .true. if (molc%hyb(ii) .eq. 1) molc%term(ii) = .true. end do @@ -288,6 +303,52 @@ subroutine atinfo_classify(molc) end do end subroutine atinfo_classify + subroutine coord_classify_calculate_zmat(molc,natural) + implicit none + class(coord_classify),intent(inout) :: molc + logical,intent(in),optional :: natural + + if (.not.allocated(molc%xyz)) return + + if (allocated(molc%zmat)) deallocate (molc%zmat) + if (allocated(molc%zmap)) deallocate (molc%zmap) + if (allocated(molc%ztod)) deallocate (molc%ztod) + + allocate (molc%zmap(molc%nat,3),source=0) + allocate (molc%zmat(3,molc%nat),source=0.0_wp) + call BETTER_XYZINT(molc%nat,molc%xyz,molc%bond, & + & molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3),molc%zmat) + + if (present(natural)) then + if (natural) then + allocate (molc%ztod(molc%nat),source=0) + call rigidconf_count_fallback(molc%nat, & + & molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3), & + & molc%bond,molc%ndieder,molc%ztod) + end if + call molc%print_zmat(stdout) + call prune_zmat_dihedrals(molc,molc%zmat, & + & molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3),molc%ztod) + end if + + end subroutine coord_classify_calculate_zmat + + subroutine coord_classify_reconstruct_from_zmat(molc,mol) + implicit none + class(coord_classify),intent(inout) :: molc + type(coord),intent(out) :: mol + + mol = molc%as_coord() + + if (.not.allocated(molc%zmat)) then + write (stdout,*) '** ERROR ** in coord_classify_reconstruct_from_zmat(): zmat not allocated!' + return + end if + call GMETRY2(molc%nat,molc%zmat, & + & mol%xyz, & + & molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3)) + end subroutine coord_classify_reconstruct_from_zmat + !=============================================================================! !#############################################################################! !=============================================================================! @@ -306,17 +367,30 @@ subroutine coord_classify_print_functional(self,prch) do ii = 1,size(self%funcgroups,1) nn = self%funcgroups(ii)%natms - allocate(at(nn),source=0) - do jj=1,nn - at(jj) = self%at(self%funcgroups(ii)%ids(jj)) - enddo + allocate (at(nn),source=0) + do jj = 1,nn + at(jj) = self%at(self%funcgroups(ii)%ids(jj)) + end do write (prch,'(3(1x,a))') 'functional group:', & & self%funcgroups(ii)%name,sumform(nn,at) - deallocate(at) + deallocate (at) end do - end subroutine coord_classify_print_functional + subroutine coord_classify_print_zmat(self,prch) + implicit none + class(coord_classify) :: self + integer,intent(in) :: prch + if (.not.allocated(self%zmat)) then + write (prch,*) 'zmat not allocated!' + return + end if + + write (prch,'(/,a)') 'Internal coordinates:' + call print_zmat(prch,self%nat,self%at,self%zmat, & + & self%zmap(:,1),self%zmap(:,2),self%zmap(:,3),.true.) + end subroutine coord_classify_print_zmat + !=============================================================================! !#############################################################################! !=============================================================================! diff --git a/src/molbuilder/construct.f90 b/src/molbuilder/construct.f90 index d14aa665..104e016a 100644 --- a/src/molbuilder/construct.f90 +++ b/src/molbuilder/construct.f90 @@ -66,7 +66,7 @@ subroutine attach(base,side,alignmap,new,clash, & integer,allocatable :: revorder_base(:),revorder_side(:) real(wp) :: rms,Umat(3,3),shift(3),center_base(3),center_side(3) integer :: nalign,nat_new - logical :: closcontact + logical :: closcontact,failconstruct integer :: ii,jj,kk,ll character(len=*),parameter :: source = "attach()" @@ -191,7 +191,7 @@ subroutine attach(base,side,alignmap,new,clash, & do ii = 1,size(original_map,1) if (all(original_map(ii,:) .ne. 0)) then if (.not.closcontact) then - cutlist_side(original_map(ii,2)) = .true. + cutlist_side(original_map(ii,2)) = .true. else cutlist_base(original_map(ii,1)) = .true. end if @@ -209,6 +209,7 @@ subroutine attach(base,side,alignmap,new,clash, & end if end do end if + end if if (original_map(ii,1) .ne. 0) then revorder_base(original_map(ii,1)) = ii @@ -250,10 +251,15 @@ subroutine attach(base,side,alignmap,new,clash, & allocate (new%at(new%nat),source=0) allocate (new%xyz(3,new%nat),source=0.0_wp) !kk = 0 + failconstruct = .false. do ii = 1,base%nat if (.not.cutlist_base(ii)) then !kk = kk+1 kk = revorder_base(ii) + if (kk > new%nat) then + failconstruct = .true. + exit + end if new%at(kk) = base%at(ii) new%xyz(1:3,kk) = base%xyz(1:3,ii) end if @@ -262,6 +268,10 @@ subroutine attach(base,side,alignmap,new,clash, & if (.not.cutlist_side(ii)) then !kk = kk+1 kk = revorder_side(ii) + if (kk > new%nat) then + failconstruct = .true. + exit + end if new%at(kk) = side_tmp%at(ii) new%xyz(1:3,kk) = side_tmp%xyz(1:3,ii) end if @@ -270,6 +280,7 @@ subroutine attach(base,side,alignmap,new,clash, & if (present(clash)) then clash = .false. !> TODO implement geometric clash check + if (failconstruct) clash = .true. end if end subroutine attach diff --git a/src/molbuilder/tree.f90 b/src/molbuilder/tree.f90 index 25afb8e7..29704c28 100644 --- a/src/molbuilder/tree.f90 +++ b/src/molbuilder/tree.f90 @@ -57,7 +57,7 @@ subroutine rigidconf_tree(env,mol) use zdata,only:readwbo use adjacency use INTERNALS_mod - use rigidconf_analyze + use molbuilder_rigidconf_analyze use miscdata,only:rcov use crest_cn_module implicit none @@ -162,15 +162,16 @@ subroutine rigidconf_tree(env,mol) else !if (.true.) then !>--- fallback implementation for testing: All single-bonds with a corresponding !> entry in the zmatrix (this excludes terminal atoms, e.g. H) - call rigidconf_count_fallback(mol%nat,na,nb,nc,wbo,ndieder) + Amat(:,:) = nint(wbo(:,:)) + call rigidconf_count_fallback(mol%nat,na,nb,nc,Amat,ndieder) if (ndieder < 1) stop 'no dihedral angles selected!' allocate (dvalues(ndieder),source=0) allocate (dstep(ndieder),source=0.0_wp) allocate (ztod(mol%nat),source=0) - call rigidconf_analyze_fallback(env,mol,zmat,na,nb,nc,wbo, & + call rigidconf_analyze_fallback(mol,zmat,na,nb,nc,wbo, & & ndieder,dvalues,dstep,ztod) - !call prune_zmat_dihedrals(mol%nat, mol%xyz, zmat, na,nb,nc, ztod ) + !call prune_zmat_dihedrals(mol, zmat, na,nb,nc, ztod ) !call smallhead('New internal coordinates:') !call print_zmat(stdout,mol%nat,mol%at,zmat,na,nb,nc,.true.) From ccc4d5ffdf36439faf044a74301f129e4f8f72bb Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 21 Jan 2026 22:03:20 +0100 Subject: [PATCH 146/374] clash check based on CN --- src/algos/queueing.f90 | 28 ++++++++++++++++++++++++---- src/discretize/discretize.f90 | 5 +++-- src/molbuilder/construct.f90 | 20 +++++++++++++++++--- src/molbuilder/construct_list.f90 | 6 +++++- 4 files changed, 49 insertions(+), 10 deletions(-) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 8865e651..b5a6fe6e 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -82,6 +82,10 @@ subroutine crest_queue_setup(env,iterate) heap%layer(ii)%parentnode = parentnode end if end if + layer(ii)%refmol = reference_mol + call reference_mol%get_cn(layer(ii)%refcn) + allocate(layer(ii)%reficn(reference_mol%nat)) + layer(ii)%reficn(:) = nint(layer(ii)%refcn(:)) call split(reference_mol,splitatms,layer(ii)%node,layer(ii)%alignmap, & & ncap=layer(ii)%ncapped,position_mapping=layer(ii)%position_mapping) deallocate (splitatms) @@ -294,12 +298,16 @@ subroutine crest_queue_reconstruct(env,tim) use molbuilder_construct_list use molbuilder_construct_mod use strucrd + use iomod + use crest_calculator implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim type(coord) :: mol integer :: ii,jj,kk,nall + logical :: ex type(coord),allocatable :: structures(:) + type(calcdata),target :: newcalc character(len=*),parameter :: recfile = 'crest_reconstruct.xyz' if (.not. (allocated(env%splitqueue).and.env%splitheap%nqueue > 0)) then @@ -324,14 +332,25 @@ subroutine crest_queue_reconstruct(env,tim) do ii = 1,nall structures(ii) = env%splitheap%layer(1)%mols(ii) end do - deallocate (env%splitheap%layer(1)%mols) + !deallocate (env%splitheap%layer(1)%mols) + deallocate (env%splitheap%layer) + deallocate (env%splitheap%queue) write(stdout,'(/,1x,a)') 'Wrting reconstructed structures to: "'//recfile//'"' call wrensemble(recfile,nall,structures) - write(stdout,*) - call crest_multilevel_wrap(env,recfile,0) + call newcalc%copy(env%calc) + env%calc => newcalc + call env%calc%info(stdout) + + call crest_multilevel_wrap(env,recfile,0) + + inquire(file='cregen.out.tmp',exist=ex) + if(ex)then + call catdel('cregen.out.tmp') + call rmrf('crest_rotamers_*.xyz') + endif contains recursive subroutine recusrive_construct(env,heap,targetlayer) @@ -439,13 +458,14 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) do jj = 1,nall_s call attach(structures_b(ii),structures_s(jj),layer%alignmap,mol, & & remove_lastx=layer%ncapped,original_map=layer%position_mapping, & - & clash=clash) + & clash=clash,reficn=layer%reficn) if (.not.clash) then layer%nmols = layer%nmols+1 layer%mols(layer%nmols) = mol end if end do end do + write (stdout,'(2x,a,i0)') 'Successful combinations : ',layer%nmols end associate end subroutine recusrive_construct diff --git a/src/discretize/discretize.f90 b/src/discretize/discretize.f90 index 9bf8408a..c7f993eb 100644 --- a/src/discretize/discretize.f90 +++ b/src/discretize/discretize.f90 @@ -29,7 +29,7 @@ subroutine discretize_trj(env) use zdata,only:readwbo use adjacency use INTERNALS_mod - use rigidconf_analyze + use molbuilder_rigidconf_analyze use discretize_module implicit none !> INPUT/OUTPUT @@ -105,7 +105,8 @@ subroutine discretize_trj(env) if (.true.) then zmax = mol%nat allocate (ztod(zmax),source=0) - call rigidconf_count_fallback(mol%nat,na,nb,nc,wbo,ndieder,ztod) + Amat(:,:) = nint(wbo(:,:)) + call rigidconf_count_fallback(mol%nat,na,nb,nc,Amat,ndieder,ztod) if (ndieder < 1) stop 'no dihedral angles detected!' allocate (drep(ndieder),source=0) diff --git a/src/molbuilder/construct.f90 b/src/molbuilder/construct.f90 index 104e016a..11592220 100644 --- a/src/molbuilder/construct.f90 +++ b/src/molbuilder/construct.f90 @@ -24,7 +24,7 @@ module molbuilder_construct_mod !=============================================================================! subroutine attach(base,side,alignmap,new,clash, & - & original_map,remove_base,remove_side,remove_lastx) + & original_map,remove_base,remove_side,remove_lastx,reficn) !*********************************************************************** !* This routine attaches a side-molecule to a base-molecule !* The assumption is that we have (at least) 3 proxy atoms @@ -45,6 +45,7 @@ subroutine attach(base,side,alignmap,new,clash, & !* constructing the new mol !* remove_lastx - integer (one for base and side) to remove !* final x atoms in constructing new mol + !* reficn - CNs of the reference structure as integers !*********************************************************************** implicit none !> IN/OUTPUTS @@ -58,6 +59,7 @@ subroutine attach(base,side,alignmap,new,clash, & integer,intent(in),optional :: remove_base(:) integer,intent(in),optional :: remove_side(:) integer,intent(in),optional :: remove_lastx(:) + integer,intent(in),optional :: reficn(:) !> LOCAL type(coord) :: cutout_base,cutout_side,side_tmp @@ -65,6 +67,7 @@ subroutine attach(base,side,alignmap,new,clash, & integer,allocatable :: current_order(:),target_order(:),idx(:) integer,allocatable :: revorder_base(:),revorder_side(:) real(wp) :: rms,Umat(3,3),shift(3),center_base(3),center_side(3) + real(wp),allocatable :: cn(:) integer :: nalign,nat_new logical :: closcontact,failconstruct integer :: ii,jj,kk,ll @@ -191,7 +194,7 @@ subroutine attach(base,side,alignmap,new,clash, & do ii = 1,size(original_map,1) if (all(original_map(ii,:) .ne. 0)) then if (.not.closcontact) then - cutlist_side(original_map(ii,2)) = .true. + cutlist_side(original_map(ii,2)) = .true. else cutlist_base(original_map(ii,1)) = .true. end if @@ -280,7 +283,18 @@ subroutine attach(base,side,alignmap,new,clash, & if (present(clash)) then clash = .false. !> TODO implement geometric clash check - if (failconstruct) clash = .true. + if (failconstruct) then + clash = .true. + else if (present(reficn)) then + call new%get_cn(cn) + do ii = 1,new%nat + if (nint(cn(ii)) .ne. reficn(ii)) then + clash = .true. + !write(*,*) "removing clash" + exit + end if + end do + end if end if end subroutine attach diff --git a/src/molbuilder/construct_list.f90 b/src/molbuilder/construct_list.f90 index 6bf3761c..aa72ff23 100644 --- a/src/molbuilder/construct_list.f90 +++ b/src/molbuilder/construct_list.f90 @@ -33,6 +33,10 @@ module molbuilder_construct_list !> initial/reconstructed molecule integer :: nmols = 0 type(coord),allocatable :: mols(:) + !> reference + type(coord) :: refmol + real(wp),allocatable :: refcn(:) + integer,allocatable :: reficn(:) end type construct_layer type :: construct_queue @@ -180,7 +184,7 @@ subroutine map_origins_for_layer(heap,targetlayer) if (allocated(layer%origin)) deallocate (layer%origin) allocate (layer%origin(layer%nnodes)) do ii = 1,layer%nnodes - layer%origin(ii)%natms = layer%node(ii)%nat + layer%origin(ii)%natms = layer%node(ii)%nat call find_original_atoms(heap,targetlayer,ii,layer%origin(ii)%map) end do end associate From 23a84b11effe1442492ec942d37a8cd5de3022f4 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 22 Jan 2026 22:54:51 +0100 Subject: [PATCH 147/374] alkylize cleanup --- src/algos/alkylize.f90 | 40 ++++----- src/algos/queueing.f90 | 143 +++++++++++++++++++++++++------ src/calculator/calculator.F90 | 4 +- src/classes.f90 | 24 +++--- src/confparse.f90 | 11 +++ src/eval_timer.f90 | 27 +++--- src/molbuilder/classify_type.f90 | 2 +- src/parsing/parse_calcdata.f90 | 1 + 8 files changed, 182 insertions(+), 70 deletions(-) diff --git a/src/algos/alkylize.f90 b/src/algos/alkylize.f90 index 977c9acc..479f3c27 100644 --- a/src/algos/alkylize.f90 +++ b/src/algos/alkylize.f90 @@ -64,16 +64,6 @@ subroutine crest_setup_alkylize(env) end if end do end do - !kk = 3 - !cc = splt(2) - !do jj = 1,molc%nat - ! if (molc%A(jj,cc) == 1.and. & - ! & .not.any(splt(:) .eq. jj).and. & - ! & any(func%ids(:) .eq. jj).and.molc%at(jj) == 1) then - ! kk = kk+1 - ! splt(kk) = jj - ! end if - !end do call env%addsplitqueue(splt) end if write (stdout,'(2x,a,5(1x,i0))') '> shared atoms:',splt(:) @@ -98,7 +88,7 @@ subroutine crest_proxy_nalkane(env,doreturn) integer :: ii,jj integer,allocatable :: na(:),nb(:),nc(:) real(wp),allocatable :: zmat(:,:) - integer :: itmp(3) + integer :: itmp(4) doreturn = .false. @@ -108,32 +98,40 @@ subroutine crest_proxy_nalkane(env,doreturn) call functional_group_classify(molc) do ii = 1,molc%nfuncs - if (molc%funcgroups(ii)%name == 'alkane') then + if (molc%funcgroups(ii)%name == 'alkane'.or. & + & (molc%funcgroups(ii)%name == 'alkyl'.and. & + & molc%funcgroups(ii)%natms >= (molc%nat-3)) & + & ) then write (stdout,'(a)') '> This substructure contains an n-alkane.' - write (stdout,'(a)') '> SKIPPING sampling and writing linear structure.' - doreturn = .true. + if (env%alkylizeskip) then + write (stdout,'(a)') '> SKIPPING sampling and writing LINEAR structure.' + doreturn = .true. + else + write (stdout,'(a)') '> Writing LINEAR structure and sampling independently.' + end if call molc%get_zmat(.true.) call molc%print_zmat(stdout) - !> ZMAT construction to make the molecule linear + !> ZMAT construction to make the molecule linear do jj = 1,molc%nat if (molc%ztod(jj) .ne. 0) then itmp(1) = molc%at(jj) itmp(2) = molc%at(molc%zmap(jj,1)) itmp(3) = molc%at(molc%zmap(jj,2)) - if(all(itmp(:).eq.6))then - !write(*,*) 'C-C bond:',molc%zmap(jj,1:2) - molc%zmat(3,jj) = -pi - endif + itmp(4) = molc%at(molc%zmap(jj,3)) + if (all(itmp(:) > 1)) then + !write(*,*) 'C-C bond:',molc%zmap(jj,1:2) + molc%zmat(3,jj) = -pi + end if end if end do + call molc%print_zmat(stdout) call molc%from_zmat(newmol) - !call reconstruct_zmat_to_mol(mol%nat,mol%at,molc%zmat, & - ! molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3),newmol) call newmol%write(conformerfile) + call env%ref%load(newmol) exit end if end do diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index b5a6fe6e..0c50ca83 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -84,7 +84,7 @@ subroutine crest_queue_setup(env,iterate) end if layer(ii)%refmol = reference_mol call reference_mol%get_cn(layer(ii)%refcn) - allocate(layer(ii)%reficn(reference_mol%nat)) + allocate (layer(ii)%reficn(reference_mol%nat)) layer(ii)%reficn(:) = nint(layer(ii)%refcn(:)) call split(reference_mol,splitatms,layer(ii)%node,layer(ii)%alignmap, & & ncap=layer(ii)%ncapped,position_mapping=layer(ii)%position_mapping) @@ -233,6 +233,10 @@ subroutine crest_queue_iter(env,iterate) if (allocated(env%ref%wbo)) deallocate (env%ref%wbo) env%nat = mol%nat env%rednat = mol%nat + if (.not.env%user_mdtime) then + env%mdtime = -1.0_wp + env%mddat%length_ps = -1.0_wp + end if env%calc => queue%calc @@ -300,20 +304,25 @@ subroutine crest_queue_reconstruct(env,tim) use strucrd use iomod use crest_calculator + use utilities, only: checkname_xyz implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim type(coord) :: mol integer :: ii,jj,kk,nall - logical :: ex + logical :: ex,multilevel(6) + type(timer) :: timtmp type(coord),allocatable :: structures(:) type(calcdata),target :: newcalc + character(len=256) :: inpnam,outnam character(len=*),parameter :: recfile = 'crest_reconstruct.xyz' if (.not. (allocated(env%splitqueue).and.env%splitheap%nqueue > 0)) then return end if + call tim%start(9,'Queue reconstruction') + write (stdout,'(/,80("#"))') write (stdout,'(3("#"),t25,a,t78,3("#"))') 'QUEUE STRUCTURE RECONSTRUCTION' write (stdout,'(80("#"),/)') @@ -336,21 +345,36 @@ subroutine crest_queue_reconstruct(env,tim) deallocate (env%splitheap%layer) deallocate (env%splitheap%queue) - write(stdout,'(/,1x,a)') 'Wrting reconstructed structures to: "'//recfile//'"' + write (stdout,'(/,1x,a)') 'Wrting reconstructed structures to: "'//recfile//'"' call wrensemble(recfile,nall,structures) - write(stdout,*) + write (stdout,*) call newcalc%copy(env%calc) env%calc => newcalc call env%calc%info(stdout) - call crest_multilevel_wrap(env,recfile,0) - - inquire(file='cregen.out.tmp',exist=ex) - if(ex)then - call catdel('cregen.out.tmp') - call rmrf('crest_rotamers_*.xyz') - endif + select case (env%crestver) + case (crest_optimize) + call env%ref%load(structures(1)) + call crest_optimization(env,timtmp) + case default + call optlev_to_multilev(env%optlev,multilevel) + call crest_multilevel_oloop(env,recfile,multilevel) + if (env%iostatus_meta .ne. 0) return + + call smallheadline('FINAL GEOMETRY OPTIMIZATION IN QUEUE RECONSTRUCTION') + call checkname_xyz(crefile,inpnam,outnam) + call rename(inpnam,recfile) + call crest_multilevel_wrap(env,recfile,0) + + call V2terminating() + end select + + if (.not.env%keepmodef) then + call rmrf('crest_queue_*') + end if + + call tim%stop(9) contains recursive subroutine recusrive_construct(env,heap,targetlayer) @@ -365,7 +389,8 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) type(coord),allocatable :: structures_b(:) type(coord),allocatable :: structures_s(:) type(coord) :: mol - integer :: nall_b,nall_s,id_b,id_s + integer :: nall_b,nall_s,id_b,id_s,nallsq,sss + integer :: iliml,ilimu,jliml,jlimu logical :: ex,clash character(len=*),parameter :: subdir_tmp = 'crest_queue_' @@ -452,19 +477,89 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) write (stdout,'(2x,a,i0)') 'Max. combinations : ',nall_b*nall_s layer%nmols = 0 - kk = nall_b*nall_s + kk = min(nall_b*nall_s,env%queue_maxreconstruct) allocate (layer%mols(kk)) - do ii = 1,nall_b - do jj = 1,nall_s - call attach(structures_b(ii),structures_s(jj),layer%alignmap,mol, & - & remove_lastx=layer%ncapped,original_map=layer%position_mapping, & - & clash=clash,reficn=layer%reficn) - if (.not.clash) then - layer%nmols = layer%nmols+1 - layer%mols(layer%nmols) = mol - end if - end do - end do + + !> NOTE: + !> we want a balanced amount of combinations, sourcing + !> roughly equal amounts of structures from base and + !> side chain ensembles. + !> We implement some additional logic to do so: + !> 1. decide on size which is the inner loop (the smaller one) + !> 2. limit loops to square of max allowed output combis (kk) + !> 3. if we have space left, increase sampling + + nallsq = nint(sqrt(real(kk,wp))) + if (nall_b > nall_s) then + sssloop: do sss = 1,3 + select case (sss) + case (1) + iliml = 1 + jliml = 1 + ilimu = min(nall_b,nallsq) + jlimu = min(nall_s,nallsq) + case (2) + if (jlimu == nall_s) then + iliml = ilimu+1 + ilimu = nall_b + else + jliml = jlimu+1 + jlimu = nall_s + end if + case (3) + iliml = ilimu+1 + ilimu = nall_b + jliml = 1 + end select + iiloop: do ii = iliml,ilimu + jjloop: do jj = jliml,jlimu + call attach(structures_b(ii),structures_s(jj),layer%alignmap,mol, & + & remove_lastx=layer%ncapped,original_map=layer%position_mapping, & + & clash=clash,reficn=layer%reficn) + if (.not.clash) then + layer%nmols = layer%nmols+1 + layer%mols(layer%nmols) = mol + if (layer%nmols == kk) exit sssloop + end if + end do jjloop + end do iiloop + end do sssloop + else + sssloop2: do sss = 1,3 + + select case (sss) + case (1) + iliml = 1 + jliml = 1 + ilimu = min(nall_b,nallsq) + jlimu = min(nall_s,nallsq) + case (2) + if (ilimu == nall_b) then + jliml = jlimu+1 + jlimu = nall_s + else + iliml = ilimu+1 + ilimu = nall_b + end if + case (3) + jliml = jlimu+1 + jlimu = nall_s + iliml = 1 + end select + jjloop2: do jj = jliml,jlimu + iiloop2: do ii = iliml,ilimu + call attach(structures_b(ii),structures_s(jj),layer%alignmap,mol, & + & remove_lastx=layer%ncapped,original_map=layer%position_mapping, & + & clash=clash,reficn=layer%reficn) + if (.not.clash) then + layer%nmols = layer%nmols+1 + layer%mols(layer%nmols) = mol + if (layer%nmols == kk) exit sssloop2 + end if + end do iiloop2 + end do jjloop2 + end do sssloop2 + end if write (stdout,'(2x,a,i0)') 'Successful combinations : ',layer%nmols end associate diff --git a/src/calculator/calculator.F90 b/src/calculator/calculator.F90 index 85e02162..d9ddaca1 100644 --- a/src/calculator/calculator.F90 +++ b/src/calculator/calculator.F90 @@ -51,7 +51,7 @@ module crest_calculator !=========================================================================================! !>--- global engrad call counter - integer(int64),public :: engrad_total = 0 + real(wp),public :: engrad_total = 0.0_wp !>--- public module routines public :: potential_core @@ -126,7 +126,7 @@ subroutine engrad_mol(mol,calc,energy,gradient,iostatus) end do end if !>--- count the engrad call - engrad_total = engrad_total+1 + engrad_total = engrad_total+1.0_wp end if !>--- update ONIOM geometries diff --git a/src/classes.f90 b/src/classes.f90 index a5b88e19..fa25628b 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -467,6 +467,7 @@ module crest_data type(split_atms),allocatable :: splitqueue(:) type(construct_heap) :: splitheap integer :: queue_iter = 0 + integer :: queue_maxreconstruct = 10000 !>--- QCG data integer :: qcg_runtype = 0 !> Default is grow, 1= ensemble & opt, 2= e_solv, 3= g_solv @@ -544,11 +545,12 @@ module crest_data !>--- general logical data logical :: allrot = .true. !> use all rotational constants for check instead of mean? logical :: alkylize = .false. !> alkylization setting + logical :: alkylizeskip = .true. !> alkylization sampling skip logical :: altopt = .false. - logical :: autothreads !> automatically determine threads - logical :: autozsort !> do the ZSORT in the beginning ? + logical :: autothreads = .true. !> automatically determine threads + logical :: autozsort = .false. !> do the ZSORT in the beginning ? logical :: allowrestart = .true. !> allow restart in crest algos? - logical :: better !> found a better conformer and restart in V1 + logical :: better = .false. !> found a better conformer and restart in V1 logical :: ceh_guess = .false. !> use CEH guess in tblite or gfnff, if available logical :: cff !> CFF used in QCG-energy calculation logical :: cluster = .false. !> perform a clustering analysis @@ -559,7 +561,7 @@ module crest_data logical :: confgo !> perform only the CREGEN routine ? logical :: constrain_solu !> constrain the solute logical :: crest_ohess = .false. !> append numerical Hessian after optimization - logical :: doNMR !> determine NMR equivalencies in CREGEN ? + logical :: doNMR = .false. !> determine NMR equivalencies in CREGEN ? logical :: dryrun = .false. !> dryrun to print settings logical :: ENSO !> some options for usage of CREST within ENSO logical :: ens_const = .false. !> constrain solute also in Ensemble generation @@ -570,12 +572,12 @@ module crest_data logical :: extLFER = .false. !> read in external LFER parameters logical :: FINAL_GFN2_OPT = .false. logical :: fullcre = .false. !> calculate exact rotamer degeneracies - logical :: gbsa !> use gbsa + logical :: gbsa = .false. !> use gbsa logical :: gcmultiopt !> 2 level optimization for GC in V2 logical :: gradsp = .true. !> turn on/off gradient calculation in singlepoint logical :: heavyrmsd = .false. !> use only heavy atoms for RMSD in CREGEN? logical :: inplaceMode = .true. !> in-place mode: optimization dirs are created "on-the-fly" - logical :: iterativeV2 !> iterative version of V2 (= V3) + logical :: iterativeV2 = .true. !> iterative version of V2 (= V3) logical :: iru !> re-use previously found conformers as bias in iterative approach logical :: keepModef !> keep MODEF* dirs in V1 ? logical :: keepScratch = .false. !> keep scratch directory or delete it? @@ -584,10 +586,10 @@ module crest_data logical :: methautocorr !> try to automatically include Methyl equivalencies in CREGEN ? logical :: multilevelopt = .true. !> perform the multileveloptimization logical :: newcregen = .false. !> use the CREGEN rewrite - logical :: NCI !> NCI special usage - logical :: niceprint !> make a nice progress-bar printout + logical :: NCI = .false. !> NCI special usage + logical :: niceprint = .false. !> make a nice progress-bar printout logical :: noconst = .false. !> no constrain of solute during QCG Growth - logical :: onlyZsort !> do only the ZSORT routine ? + logical :: onlyZsort = .false. !> do only the ZSORT routine ? logical :: optpurge = .false. !> MDOPT purge application logical :: outputsdf = .false. !> write output ensemble as sdf? logical :: pcaexclude = .false. !> exclude user set atoms from PCA? @@ -617,7 +619,7 @@ module crest_data logical :: refine_esort = .false. !> if CREGEN is run after crest_refine, only sort energy? logical :: sameRandomNumber = .false. !> QCG related, choose same random number for iff logical :: scallen !> scale the automatically determined MD length by some factor? - logical :: scratch !> use scratch directory + logical :: scratch = .false. !> use scratch directory logical :: setgcmax = .false. !> adjust the maxmimum number of structures taken into account for GC? logical :: sdfformat = .false. !> was the SDF format used as input file? logical :: slow !> slowmode (counterpart to quick mode) @@ -636,7 +638,7 @@ module crest_data logical :: user_nclust = .false. !> true if number of cluster is set by user (only QCG) logical :: user_dumxyz = .false. !> true if dumpxyz is set by user logical :: user_wscal = .false. !> true if wscal is set by user - logical :: useqmdff !> use QMDFF in V2? + logical :: useqmdff = .false. !> use QMDFF in V2? logical :: water = .false. !> true if water is used as solvent (only QCG) logical :: wallsetup = .false. !> set up a wall potential? logical :: wbotopo = .false. !> set up topo with WBOs diff --git a/src/confparse.f90 b/src/confparse.f90 index b69364f3..d8c0ce1a 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -1537,7 +1537,18 @@ subroutine parseflags(env,arg,nra) write (*,'(2x,a,1x,a)') '--wall-xxl:','requesting setup of wall potential (x2.0 size)' case ('-alkylize') + write (*,'(2x,a,1x)',advance='no') '--alkylize' env%alkylize = .true. + if( nra >= i+1)then + ctmp = trim(arg(i+1)) + select case (ctmp) + case ('full','sample') + env%alkylizeskip = .false. + write(*,'(a,1x)',advance='no') ctmp + end select + endif + write(*,'(a)') ': automatic alkyl group dispatch' + !========================================================================================! !------ flags for parallelization / disk space !========================================================================================! diff --git a/src/eval_timer.f90 b/src/eval_timer.f90 index 80d0f883..596e55fe 100644 --- a/src/eval_timer.f90 +++ b/src/eval_timer.f90 @@ -23,9 +23,9 @@ subroutine eval_timer(tim) !******************************** use crest_parameters use crest_data - use crest_calculator,only: engrad_total + use crest_calculator,only:engrad_total use crest_restartlog - use iomod, only: get_peak_rss_kb + use iomod,only:get_peak_rss_kb implicit none type(timer) :: tim real(wp) :: time_total,time_avg,mem @@ -36,18 +36,23 @@ subroutine eval_timer(tim) time_total = tim%get() call tim%clear mem = real(get_peak_rss_kb(),wp) - write(stdout,'(" * Peak RSS: ",f8.2, " MiB")') mem/1024.0_wp - if(engrad_total > 0)then - write(atmp,'(f30.3)') time_total/real(engrad_total,wp) - write(stdout,'(" * Total number of energy+grad calls: ",i0)') & !,a,1x,a,a)') & - & engrad_total!,' (avg. wall-time',trim(adjustl(atmp)),' sec)' - write(stdout,*) - call dump_restart() - endif + write (stdout,'(" * Peak RSS: ",f8.2, " MiB")') mem/1024.0_wp + if (engrad_total > 0.0_wp) then + write (atmp,'(f30.3)') time_total/real(engrad_total,wp) + if (engrad_total < 10.0_wp**5) then + write (stdout,'(" * Total number of energy+grad calls: ",i0)') & + & nint(engrad_total) + else + write (stdout,'(" * Total number of energy+grad calls: ",es10.4)') & + & engrad_total + end if + write (stdout,*) + call dump_restart() + end if end subroutine eval_timer subroutine propquit(tim) - use crest_parameters, only: stdout + use crest_parameters,only:stdout use crest_data implicit none type(timer) :: tim diff --git a/src/molbuilder/classify_type.f90 b/src/molbuilder/classify_type.f90 index 5925f1cc..cebd0fef 100644 --- a/src/molbuilder/classify_type.f90 +++ b/src/molbuilder/classify_type.f90 @@ -326,7 +326,7 @@ subroutine coord_classify_calculate_zmat(molc,natural) & molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3), & & molc%bond,molc%ndieder,molc%ztod) end if - call molc%print_zmat(stdout) + !call molc%print_zmat(stdout) call prune_zmat_dihedrals(molc,molc%zmat, & & molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3),molc%ztod) end if diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 5f8bdf2f..d2247e5f 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -1062,6 +1062,7 @@ subroutine parse_md_auto(env,mddat,kv,rd) case ('length','length_ps') mddat%length_ps = kv%value_f + env%user_mdtime = .true. case ('dump') mddat%dumpstep = kv%value_f case ('hmass') From c50dbbafa8070d349ce5d1726b793ab16031f346 Mon Sep 17 00:00:00 2001 From: LukasRindt Date: Wed, 28 Jan 2026 09:44:44 +0100 Subject: [PATCH 148/374] Optimizers with scalable stepsize --- src/calculator/hr_utils.f90 | 20 +++---- src/optimize/ancopt.f90 | 94 +++++++++++--------------------- src/optimize/newton_raphson.f90 | 31 ++++++----- src/optimize/optimize_module.f90 | 2 +- src/optimize/optutils.f90 | 86 +++++++++++++++++++++++++++++ src/optimize/rfo.f90 | 57 ++++++------------- 6 files changed, 161 insertions(+), 129 deletions(-) diff --git a/src/calculator/hr_utils.f90 b/src/calculator/hr_utils.f90 index 09ef834c..207d1f0b 100644 --- a/src/calculator/hr_utils.f90 +++ b/src/calculator/hr_utils.f90 @@ -80,16 +80,16 @@ subroutine initialize_hessian(calc,type,xyz,nat,at,hess,hguess,pr) !>Matrix is f call modhes(calc,mhset,nat,xyz,at,hess(:),pr) end select - call axis(nat,at,xyz,rot,dumi) - linear = (rot(3) .lt. 1.d-10).or.(nat == 2) - - if (.not.linear) then - if (calc%nfreeze == 0) then - call trproj(nat,nat3,xyz,hess,.false.,0,pmode,1) !> normal - else - call trproj(nat,nat3,xyz,hess,.false.,calc%freezelist) !> fozen atoms - end if - end if + !call axis(nat,at,xyz,rot,dumi) + !linear = (rot(3) .lt. 1.d-10).or.(nat == 2) + + !if (.not.linear) then + ! if (calc%nfreeze == 0) then + ! call trproj(nat,nat3,xyz,hess,.false.,0,pmode,1) !> normal + ! else + ! call trproj(nat,nat3,xyz,hess,.false.,calc%freezelist) !> fozen atoms + ! end if + !end if call force_positive_definiteness(hess, nat3) diff --git a/src/optimize/ancopt.f90 b/src/optimize/ancopt.f90 index 776710e2..d432556d 100644 --- a/src/optimize/ancopt.f90 +++ b/src/optimize/ancopt.f90 @@ -24,7 +24,7 @@ module ancopt_module use iso_fortran_env,only:wp => real64,sp => real32 - !use crest_parameters, only + !use crest_parameters use crest_calculator use axis_module use strucrd @@ -343,18 +343,18 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & logical :: lowered integer :: i,j,ii,jj,jjj,iii,k,lwork,info,m,idum,imax(3) real(wp) :: energy,dsnrm,maxdispl,t0,w0,t1,w1 - real(wp) :: lambda,gnorm,dnorm,ddot,eold,xdum,estart,acc,e_in + real(wp) :: lambda,gnorm,dnorm,eold,xdum,estart,acc,e_in real(wp) :: depred,echng,dummy,maxd,alp,alpold,gchng,gnold real(wp),allocatable :: gold(:) real(wp),allocatable :: displ(:),gint(:) - real(sp),allocatable :: eaug(:) - real(sp),allocatable :: Uaug(:,:) - real(sp),allocatable :: Aaug(:) - real(sp),parameter :: r4dum = 1.e-8 + real(wp),allocatable :: eaug(:) + real(wp),allocatable :: Uaug(:,:) + real(wp),allocatable :: Aaug(:) + real(wp),parameter :: r4dum = 1.e-8 real(wp), allocatable :: test_hess(:,:) !> LAPACK & BLAS external :: dgemv - real(sp),external :: sdot + real(wp),external :: ddot integer :: q,r,s,nat3 !> ONLY for testing! nat3 = 3*mol%nat allocate(test_hess(nat3,nat3)) @@ -380,7 +380,7 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & nvar1 = OPT%nvar+1 !> dimension of RF calculation npvar = OPT%nvar*(nvar1)/2 !> packed size of Hessian (note the abuse of nvar1!) npvar1 = nvar1*(nvar1+1)/2 !> packed size of augmented Hessian - allocate (Uaug(nvar1,1),eaug(nvar1),Aaug(npvar1),source=0.0_sp) + allocate (Uaug(nvar1,1),eaug(nvar1),Aaug(npvar1),source=0.0_wp) !$omp end critical !! ======================================================================== @@ -464,20 +464,20 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & end if end if - alp = 1.0d0 - if (gnorm .lt. 0.002) then ! 0.002 - alp = 1.5d0 ! 1.5 - end if - if (gnorm .lt. 0.0006) then - alp = 2.0d0 ! 2 - end if - if (gnorm .lt. 0.0003) then - alp = 3.0d0 ! 3 - end if + !alp = 1.0d0 + !if (gnorm .lt. 0.002) then ! 0.002 + ! alp = 1.5d0 ! 1.5 + !end if + !if (gnorm .lt. 0.0006) then + ! alp = 2.0d0 ! 2 + !end if + !if (gnorm .lt. 0.0003) then + ! alp = 3.0d0 ! 3 + !end if + + alp = alp_generate(gnorm, calc%optlev,calc%opt_engine) + !write(stdout,*) alp - if (calc%optlev>0) then - alp = alp_generate(gnorm, calc) - endif !>------------------------------------------------------------------------ !> Update the Hessian !>------------------------------------------------------------------------ @@ -500,12 +500,6 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & end select end if - !> Transform hessian to cartesian coordinate basis (still wrong) - !if (calc%do_HR) then - ! call dhtosq(nat3,test_hess(:,:),OPT%hess(:)) - ! calc%chess%H(:,:) = matmul(matmul(Transpose(OPT%B(:,:)), test_hess(:,:)), OPT%B(:,:)) - !end if - !>------------------------------------------------------------------------ !> rational function (RF) method !>------------------------------------------------------------------------ @@ -517,24 +511,24 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & !> Aaug Uaug Uaug !>--- first, augment Hessian by gradient, everything packed, no blowup - Aaug(1:npvar) = real(OPT%hess(1:npvar),sp) - Aaug(npvar+1:npvar1-1) = real(gint(1:OPT%nvar),sp) - Aaug(npvar1) = 0.0_sp + Aaug(1:npvar) = OPT%hess(1:npvar) + Aaug(npvar+1:npvar1-1) = gint(1:OPT%nvar) + Aaug(npvar1) = 0.0_wp -!>--- choose solver +!>--- choose solver for the RF eigenvalue problem if (exact.or.nvar1 .lt. 50) then - call solver_sspevx(nvar1,r4dum,Aaug,Uaug,eaug,fail) + call solver_dspevx(nvar1,r4dum,Aaug,Uaug,eaug,fail) else !>--- steepest decent guess for displacement if (ii .eq. 1) then - Uaug(:,1) = [-real(gint(1:OPT%nvar),sp),1.0_sp] - dsnrm = sqrt(sdot(nvar1,Uaug,1,Uaug,1)) - Uaug = Uaug/real(dsnrm,sp) + Uaug(:,1) = [-gint(1:OPT%nvar),1.0_wp] + dsnrm = sqrt(ddot(nvar1,Uaug,1,Uaug,1)) + Uaug = Uaug/dsnrm end if - call solver_sdavidson(nvar1,r4dum,Aaug,Uaug,eaug,fail,.false.) + call solver_ddavidson(nvar1,r4dum,Aaug,Uaug,eaug,fail,.false.) !>--- if that failed, retry with better solver if (fail) then - call solver_sspevx(nvar1,r4dum,Aaug,Uaug,eaug,fail) + call solver_dspevx(nvar1,r4dum,Aaug,Uaug,eaug,fail) end if end if @@ -569,7 +563,7 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & write (*,'(6x,"in ANC''s ",3("#",i0,", "),"...")') imax !call prdispl(OPT%nvar,displ) end if -!>------------------------------------------------------------------------ +!>--------------------------------------------------------------------------- !>--- 2nd: exit and redo hessian (internal restart) if (ii .gt. 2.and.dsnrm .gt. 2.0) then @@ -643,30 +637,6 @@ subroutine trfp2xyz(nvar,nat3,p,xyz0,h,dspl) return end subroutine trfp2xyz - function alp_generate(gnorm,calc) result(alp) - type(calcdata),intent(in) :: calc - real(wp), intent(in) :: gnorm - real(wp) :: alp, shift, l, k - - if (calc%optlev == 1) then - L = 2.0_wp - k = 2000.0_wp - shift = 0.0005_wp - else if (calc%optlev == 2) then - L = 1.0_wp - k = 8000.0_wp - shift = 0.0009_wp - else - L = calc%L - k = calc%k - shift = calc%shift - endif - - alp = L/(1+euler**(k*(gnorm-shift)))+1 - - end function alp_generate - - !========================================================================================! !========================================================================================! end module ancopt_module diff --git a/src/optimize/newton_raphson.f90 b/src/optimize/newton_raphson.f90 index 090bc54b..90854359 100644 --- a/src/optimize/newton_raphson.f90 +++ b/src/optimize/newton_raphson.f90 @@ -203,7 +203,7 @@ subroutine newton_raphson(mol,calc,etot,grd,pr,wr,iostatus) ! end do !end do - call initialize_hessian(calc,calc%hess_init,mol%xyz,mol%nat,mol%at,hess,calc%hguess,pr) + call initialize_hessian(calc,calc%hess_init,mol%xyz,mol%nat,mol%at,OPT%hess,calc%hguess,pr) !>--- backup coordinates, and starting energy molopt%nat = mol%nat @@ -298,20 +298,20 @@ subroutine newton_raphson(mol,calc,etot,grd,pr,wr,iostatus) !>--- if we are close to convergence we can take larger steps alpold = alp - alp = 1.0d-1 - if (gnorm .lt. 0.002) then ! 0.002 - alp = 1.5d-1 ! 1.5 - end if - if (gnorm .lt. 0.0006) then - alp = 2.0d-1 ! 2 - end if - if (gnorm .lt. 0.0003) then - alp = 3.0d-1 ! 3 - end if - - !if (calc%optlev>0) then - !alp = alp_generate(gnorm, calc) - !endif + !alp = 1.0d-0 + !if (gnorm .lt. 0.002) then ! 0.002 + ! alp = 1.5d-0 ! 1.5 + !end if + !if (gnorm .lt. 0.0006) then + ! alp = 2.0d-0 ! 2 + !end if + !if (gnorm .lt. 0.0003) then + ! alp = 3.0d-1 ! 3 + !end if + + + alp = alp_generate(gnorm, calc%optlev,calc%opt_engine) + !write(stdout,*) alp !>------------------------------------------------------------------------ !> Update the Hessian @@ -459,6 +459,7 @@ subroutine newton_raphson(mol,calc,etot,grd,pr,wr,iostatus) return end subroutine newton_raphson + !========================================================================================! !========================================================================================! end module newton_raphson_module \ No newline at end of file diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index 53022195..9c323eb2 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -129,7 +129,7 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) & calc%ht,calc%gt,calc%stot,etot) else - call initialize_hessian(calc,calc%hess_init,mol%xyz,mol%nat,mol%at,calc%chess%hess(:),calc%hguess,pr) + idx = minloc(calc%chess%order,1) call initialize_hessian(calc,calc%chess%initialize_type,calc%chess%coords(idx,:,:),molnew%nat,molnew%at,calc%chess%hess(:),calc%chess%hguess,pr) !> This hguess is set through the hguess variable of the optimizer and needs to be hardcoded/set explicitly before initialization for benchmarking!! diff --git a/src/optimize/optutils.f90 b/src/optimize/optutils.f90 index e9195874..b2281fef 100644 --- a/src/optimize/optutils.f90 +++ b/src/optimize/optutils.f90 @@ -454,5 +454,91 @@ subroutine print_convd(econverged,gconverged) end subroutine print_convd !========================================================================================! + + function alp_generate(gnorm,optlev,optimizer) result(alp) +!**************************************************** +!* Computes stepsize scaling factor depending on optimizer +!* and optlev +!**************************************************** + integer, intent(in) :: optlev, optimizer + real(wp), intent(in) :: gnorm + real(wp) :: alp, shift, l, k, scaling + + alp = 1.0_wp + if (gnorm .lt. 0.002) then ! 0.002 + alp = 1.5_wp ! 1.5 + end if + if (gnorm .lt. 0.0006) then + alp = 2.0_wp ! 2 + end if + if (gnorm .lt. 0.0003) then + alp = 3.0_wp ! 3 + end if + + select case(optimizer) + case (0) !ancopt + select case(optlev) + case (-1) !loose + L=2.0_wp + k=4000_wp + shift=0.0005_wp + case(0) !normal + L=1.5_wp + k=8000_wp + shift=0.0007_wp + case(1) !tight + L=1.5_wp + k=6000_wp + shift=0.0007_wp + case(2) !vtight + L=2.0_wp + k=2000_wp + shift=0.0001_wp + end select + case (2) !rfo + select case(optlev) + case (-1) !loose + L=2.0_wp + k=2000_wp + shift=0.0005_wp + case(0) !normal + L=1.5_wp + k=8000_Wp + shift=0.0003_wp + case(1) !tight + L=0.05_wp + k=6000_wp + shift=0.0003_wp + case(2) !vtight, we do not scale here + L=0.0_wp + k=1.0_wp + shift=1.0_wp + end select + case (3) !Newton + select case(optlev) + case (-1) !loose + L=2.0_wp + k=4000_wp + shift=0.0005_wp + case(0) !normal + L=0.5_wp + k=4000_wp + shift=0.0001_wp + case(1) !tight, we do not scale here + L=0.0_wp + k=1.0_wp + shift=1.0_wp + case(2) !vtight + L=0.5_wp + k=8000_wp + shift=0.0003_wp + end select + end select + + + alp = L/(1+euler**(k*(gnorm-shift)))+1 + + end function alp_generate + !========================================================================================! end module optimize_utils diff --git a/src/optimize/rfo.f90 b/src/optimize/rfo.f90 index 8fee7146..6b65a778 100644 --- a/src/optimize/rfo.f90 +++ b/src/optimize/rfo.f90 @@ -316,20 +316,21 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !>--- if we are close to convergence we can take larger steps alpold = alp - alp = 1.0d-1 - if (gnorm .lt. 0.002) then ! 0.002 - alp = 1.5d-1 ! 1.5 - end if - if (gnorm .lt. 0.0006) then - alp = 2.0d-1 ! 2 - end if - if (gnorm .lt. 0.0003) then - alp = 3.0d-1 ! 3 - end if - - !if (calc%optlev>0) then - alp = alp_generate(gnorm, calc) - !endif + !alp = 1.0d0 + !if (gnorm .lt. 0.002) then ! 0.002 + ! alp = 1.5d0 ! 1.5 + !end if + !if (gnorm .lt. 0.0006) then + ! alp = 2.0d0 ! 2 + !end if + !if (gnorm .lt. 0.0003) then + ! alp = 3.0d0 ! 3 + !end if + + + alp = alp_generate(gnorm, calc%optlev,calc%opt_engine) + !write(stdout,*) alp + !>------------------------------------------------------------------------ !> Update the Hessian @@ -382,7 +383,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) ! dsnrm = sqrt(ddot(nvar1,Uaug,1,Uaug,1)) ! Uaug = Uaug/dsnrm !else - call solver_dspevx(nvar1,0.0_wp,Aaug,Uaug,eaug,fail) + call solver_dspevx(nvar1,r4dum,Aaug,Uaug,eaug,fail) !endif else !>--- steepest decent guess for displacement @@ -512,32 +513,6 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) return end subroutine rfopt - function alp_generate(gnorm,calc) result(alp) - type(calcdata),intent(in) :: calc - real(wp), intent(in) :: gnorm - real(wp) :: alp, shift, l, k, scaling - - if (calc%optlev == 1) then - L = 2.0_wp - k = 2000.0_wp - shift = 0.0005_wp - scaling = 0.12_wp - else if (calc%optlev == 2) then - L = 1.0_wp - k = 8000.0_wp - shift = 0.0009_wp - scaling = 0.12_wp - else - L = calc%L - k = calc%k - shift = calc%shift - scaling = calc%scaling - endif - - alp = scaling*(L/(1+euler**(k*(gnorm-shift)))+1) - - end function alp_generate - !========================================================================================! !========================================================================================! end module rfo_module From 4248c9cb78667d239d0cc2a7f26611dae3bbf07c Mon Sep 17 00:00:00 2001 From: LukasRindt Date: Wed, 28 Jan 2026 13:24:29 +0100 Subject: [PATCH 149/374] correct parameters ancopt --- src/optimize/optutils.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/optimize/optutils.f90 b/src/optimize/optutils.f90 index b2281fef..a452ad82 100644 --- a/src/optimize/optutils.f90 +++ b/src/optimize/optutils.f90 @@ -462,7 +462,7 @@ function alp_generate(gnorm,optlev,optimizer) result(alp) !**************************************************** integer, intent(in) :: optlev, optimizer real(wp), intent(in) :: gnorm - real(wp) :: alp, shift, l, k, scaling + real(wp) :: alp, shift, l, k alp = 1.0_wp if (gnorm .lt. 0.002) then ! 0.002 @@ -491,9 +491,9 @@ function alp_generate(gnorm,optlev,optimizer) result(alp) k=6000_wp shift=0.0007_wp case(2) !vtight - L=2.0_wp + L=1.5_wp k=2000_wp - shift=0.0001_wp + shift=0.0007_wp end select case (2) !rfo select case(optlev) From 274ecb7e6750df81323be923fb671d3eb267988a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 30 Jan 2026 13:29:29 +0100 Subject: [PATCH 150/374] Fix issues with "natural" zmat setup --- src/algos/playground.f90 | 22 +----- src/molbuilder/classify_type.f90 | 125 ++++++++++++++++++++++++++++++- 2 files changed, 124 insertions(+), 23 deletions(-) diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index 5f8d4a7e..c59dff77 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -45,7 +45,7 @@ subroutine crest_playground(env,tim) integer,allocatable :: A(:,:) logical,allocatable :: rings(:,:) integer,allocatable :: tmp(:) - logical :: connected,fail + logical :: connected,fail,doreturn real(wp) :: energy real(wp),allocatable :: grad(:,:),geo(:,:),csv(:,:),q(:) @@ -76,25 +76,9 @@ subroutine crest_playground(env,tim) ! call engrad(mol,calc,energy,grad,io) ! call calculation_summary(calc,mol,energy,grad) !========================================================================================! - block - use molbuilder_classify - type(coord) :: new - type(coord_classify) :: newc - call env%ref%to(new) - call setup_classify(new,newc) - !call atinfo_classify(newc) - call functional_group_classify(newc) - - do i=1,newc%nat - write(*,'(a,i0,3(1x,i0),1x,a)') trim(i2e(newc%at(i),'nc')),i,& - & newc%hyb(i),newc%nhn(i),newc%prio(i),trim(newc%atinfo(i)) - enddo - - call newc%print_funcgroups(stdout) - - write(*,*) newc%sumform() - end block + env%alkylize = .true. + call crest_proxy_nalkane(env,doreturn) !========================================================================================! call tim%stop(14) diff --git a/src/molbuilder/classify_type.f90 b/src/molbuilder/classify_type.f90 index cebd0fef..2cea3144 100644 --- a/src/molbuilder/classify_type.f90 +++ b/src/molbuilder/classify_type.f90 @@ -61,6 +61,7 @@ module molbuilder_classify_type real(wp),allocatable :: zmat(:,:) integer,allocatable :: zmap(:,:) !> na,nb,nc integer,allocatable :: ztod(:) + integer,allocatable :: hatsort(:,:) !> utility storage logical,allocatable :: lwork(:) @@ -314,6 +315,13 @@ subroutine coord_classify_calculate_zmat(molc,natural) if (allocated(molc%zmap)) deallocate (molc%zmap) if (allocated(molc%ztod)) deallocate (molc%ztod) + if (present(natural)) then + if (natural) then + write (stdout,'(/,a)') 'NOTE: atom order will temporarily be changed!' + call coord_classify_hatsort(molc) + end if + end if + allocate (molc%zmap(molc%nat,3),source=0) allocate (molc%zmat(3,molc%nat),source=0.0_wp) call BETTER_XYZINT(molc%nat,molc%xyz,molc%bond, & @@ -329,6 +337,7 @@ subroutine coord_classify_calculate_zmat(molc,natural) !call molc%print_zmat(stdout) call prune_zmat_dihedrals(molc,molc%zmat, & & molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3),molc%ztod) + call coord_classify_hatsort_restore(molc) end if end subroutine coord_classify_calculate_zmat @@ -336,19 +345,127 @@ end subroutine coord_classify_calculate_zmat subroutine coord_classify_reconstruct_from_zmat(molc,mol) implicit none class(coord_classify),intent(inout) :: molc - type(coord),intent(out) :: mol - - mol = molc%as_coord() + type(coord),intent(out),optional :: mol if (.not.allocated(molc%zmat)) then write (stdout,*) '** ERROR ** in coord_classify_reconstruct_from_zmat(): zmat not allocated!' return end if call GMETRY2(molc%nat,molc%zmat, & - & mol%xyz, & + & molc%xyz, & & molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3)) + + if (present(mol)) then + mol = molc%as_coord() + end if end subroutine coord_classify_reconstruct_from_zmat + subroutine coord_classify_hatsort(molc) + !************************************************************** + !* a routine that resorts the atomorder in molc so that + !* hydrogen atoms come last. required for natural z-mat setup + !* Also mapps the order to restore it later on + !************************************************************** + implicit none + class(coord_classify),intent(inout) :: molc + + real(wp),allocatable :: xyztmp(:,:) + integer,allocatable :: attmp(:),bondtmp(:,:) + + integer :: ii,kk,jj + if (allocated(molc%hatsort)) deallocate (molc%hatsort) + allocate (molc%hatsort(molc%nat,2),source=0) + allocate (attmp(molc%nat),source=0) + allocate (xyztmp(3,molc%nat),source=0.0_wp) + + kk = 0 + !> heavy atoms + do ii = 1,molc%nat + if (molc%at(ii) .ne. 1) then + kk = kk+1 + molc%hatsort(kk,1) = ii + molc%hatsort(ii,2) = kk + xyztmp(1:3,kk) = molc%xyz(1:3,ii) + attmp(kk) = molc%at(ii) + end if + end do + !> hydrogen + do ii = 1,molc%nat + if (molc%at(ii) .eq. 1) then + kk = kk+1 + molc%hatsort(kk,1) = ii + molc%hatsort(ii,2) = kk + xyztmp(1:3,kk) = molc%xyz(1:3,ii) + attmp(kk) = molc%at(ii) + end if + end do + + call move_alloc(xyztmp,molc%xyz) + call move_alloc(attmp,molc%at) + + if (allocated(molc%bond)) then + allocate (bondtmp(molc%nat,molc%nat),source=0) + do ii = 1,molc%nat + do jj = 1,molc%nat + bondtmp(molc%hatsort(jj,2),molc%hatsort(ii,2)) = molc%bond(jj,ii) + end do + end do + call move_alloc(bondtmp,molc%bond) + end if + end subroutine coord_classify_hatsort + + subroutine coord_classify_hatsort_restore(molc) + !********************************************** + !* Restore original order from h-atom sorting + !********************************************* + implicit none + class(coord_classify),intent(inout) :: molc + + real(wp),allocatable :: xyztmp(:,:) + integer,allocatable :: attmp(:),bondtmp(:,:) + integer,allocatable :: ztodtmp(:),zmaptmp(:,:) + real(wp),allocatable :: zmattmp(:,:) + integer :: ii,kk,jj + if (.not.allocated(molc%hatsort)) return + + allocate (attmp(molc%nat),source=0) + allocate (xyztmp(3,molc%nat),source=0.0_wp) + do ii = 1,molc%nat + kk = molc%hatsort(ii,1) + xyztmp(1:3,kk) = molc%xyz(1:3,ii) + attmp(kk) = molc%at(ii) + end do + call move_alloc(xyztmp,molc%xyz) + call move_alloc(attmp,molc%at) + if (allocated(molc%bond)) then + allocate (bondtmp(molc%nat,molc%nat),source=0) + do ii = 1,molc%nat + do jj = 1,molc%nat + bondtmp(molc%hatsort(jj,1),molc%hatsort(ii,1)) = molc%bond(jj,ii) + end do + end do + call move_alloc(bondtmp,molc%bond) + end if + + allocate (ztodtmp(molc%nat),source=0) + allocate (zmaptmp(molc%nat,3),source=0) + allocate (zmattmp(3,molc%nat),source=0.0_wp) + do ii = 1,molc%nat + ztodtmp(molc%hatsort(ii,1)) = molc%ztod(ii) + zmattmp(1:3,molc%hatsort(ii,1)) = molc%zmat(1:3,ii) + do jj = 1,3 + if (molc%zmap(ii,jj) > 0) then + zmaptmp(molc%hatsort(ii,1),jj) = molc%hatsort(molc%zmap(ii,jj),1) + else + zmaptmp(molc%hatsort(ii,1),jj) = 0 + end if + end do + end do + call move_alloc(ztodtmp,molc%ztod) + call move_alloc(zmaptmp,molc%zmap) + call move_alloc(zmattmp,molc%zmat) + end subroutine coord_classify_hatsort_restore + !=============================================================================! !#############################################################################! !=============================================================================! From f88a8d767440ea13c721168e0f586ab2a2329211 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 30 Jan 2026 20:03:17 +0100 Subject: [PATCH 151/374] Change splitting function to always produce just 2 fragments --- src/algos/queueing.f90 | 2 +- src/molbuilder/construct.f90 | 287 +++++++++++++++++++++++++++++++++++ 2 files changed, 288 insertions(+), 1 deletion(-) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 0c50ca83..7b2a7319 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -86,7 +86,7 @@ subroutine crest_queue_setup(env,iterate) call reference_mol%get_cn(layer(ii)%refcn) allocate (layer(ii)%reficn(reference_mol%nat)) layer(ii)%reficn(:) = nint(layer(ii)%refcn(:)) - call split(reference_mol,splitatms,layer(ii)%node,layer(ii)%alignmap, & + call binarysplit(reference_mol,splitatms,layer(ii)%node,layer(ii)%alignmap, & & ncap=layer(ii)%ncapped,position_mapping=layer(ii)%position_mapping) deallocate (splitatms) layer(ii)%nnodes = size(layer(ii)%node,1) diff --git a/src/molbuilder/construct.f90 b/src/molbuilder/construct.f90 index 11592220..4f00765e 100644 --- a/src/molbuilder/construct.f90 +++ b/src/molbuilder/construct.f90 @@ -19,6 +19,11 @@ module molbuilder_construct_mod module procedure split_onshared end interface split + public :: binarysplit + interface binarysplit + module procedure binarysplit_onshared + end interface binarysplit + !=============================================================================! contains !> MODULE PROCEDURES START HERE !=============================================================================! @@ -719,6 +724,288 @@ subroutine split_onshared(input,sharedlist,structures,sharedmap,& if (allocated(Anew)) deallocate (Anew) if (allocated(frag)) deallocate (frag) end subroutine split_onshared +!==============================================================================! + subroutine binarysplit_onshared(input,sharedlist,structures,sharedmap,& + & wbo,ncap,position_mapping) + implicit none + !> IN/OUTPUTS + type(coord),intent(in) :: input + integer,intent(in) :: sharedlist(:) + type(coord),intent(out),allocatable :: structures(:) + integer,intent(out),allocatable :: sharedmap(:,:) + !> OPTIONAL + real(wp),intent(in),optional :: wbo(input%nat,input%nat) + integer,intent(out),allocatable,optional :: ncap(:) + integer,intent(out),allocatable,optional :: position_mapping(:,:) + !> LOCAL + type(coord) :: shared + real(wp),allocatable :: cn(:),wbofake(:,:) + integer :: V,fbase,fside,nshared,ftmp + integer,allocatable :: A(:,:),Anew(:,:) + integer,allocatable :: frag(:),fragnew(:),molassign(:) + integer,allocatable :: ncapped(:) + integer,allocatable :: pos_map(:,:) + logical,allocatable :: in_ring(:,:) + integer,allocatable :: path_tmp(:) + integer,allocatable :: number_of_neighbours(:) + logical,allocatable :: terminal_atom(:) + logical,allocatable :: connected_to_share(:) + logical,allocatable :: assign_to_mols(:,:) + logical,allocatable :: unassigned_fragments(:) + logical,allocatable :: capping_mapping(:,:) + logical,allocatable :: methylizemapping(:,:) + + integer :: npath,nfrag,nfragnew,nbonds + real(wp) :: distcap,methylproxy(3,3) + integer :: ii,jj,jjj,kk,sii,sjj,M,mm,nn,ll,lll + + integer :: bond(2) + + character(len=*),parameter :: source = "binarysplit_onshared()" + + !> we will be working with graphs. define number of vertices = #atoms + V = input%nat + !> how many atoms are shared + nshared = size(sharedlist,1) + + !> checks + if (any(sharedlist(:) > input%nat).or.(nshared < 1)) then + + error stop source//": sharedlist() has invalid atom specification" + end if + + !> set up adjacency matrix + if (present(wbo)) then + call wbo2adjacency(V,wbo,A,0.01_wp) + else + call input%cn_to_bond(cn,wbofake) + call wbo2adjacency(V,wbofake,A,0.01_wp) + deallocate (wbofake,cn) + end if + +!> ---------------------------------------------------------------------------- +!> BOOKKEEPING START +!> ---------------------------------------------------------------------------- + !> get fragment array (indicates which atom is on which fragment) + call setup_fragments(V,A,frag) + + !> some other mappings + allocate (number_of_neighbours(V),source=0) + do ii = 1,V + number_of_neighbours(ii) = sum(A(:,ii)) + end do + allocate (terminal_atom(V),source=.false.) + do ii = 1,V + terminal_atom(ii) = (number_of_neighbours(ii) == 1) + end do + + !> The cutting logic starts here. + !> First, we need to identify all atoms actually sharing fragments with the shared atoms + allocate (connected_to_share(V),source=.false.) + do ii = 1,V + ftmp = frag(ii) + do jj = 1,nshared + if (ftmp == frag(sharedlist(jj))) then + connected_to_share(ii) = .true. + exit + end if + end do + end do + !> all atoms NOT part of that list will be present in both output fragments + + !> Then, we take the graph and construct a new one with detachted "shared" atoms + nfrag = maxval(frag) + allocate (Anew(V,V),source=A) + iiloop1: do ii = 1,nshared + sii = sharedlist(ii) + do jj = 1,V + if (jj == sii) cycle + if ((A(jj,sii) == 1).and. & !> look at existing bonds to shared section + & any(sharedlist(:) == jj).and. & !> must be connected to other shared section atoms + & .not.terminal_atom(jj)) then !> and except terminal atoms (directly bound to shared section) + Anew(jj,sii) = 0 + Anew(sii,jj) = 0 + + !> get new fragments + call setup_fragments(V,Anew,fragnew) + nfragnew = maxval(fragnew) + if ((nfragnew-nfrag) == 1) then + exit iiloop1 + end if + end if + end do + end do iiloop1 + + M = 2 + if (nfragnew == nfrag) then + error stop source//": system fragmentation yields currently unhandled edge-case" + else + !> now we can check asignment to new, split-up fragments + !> we distinguish between the shared secion (:,1), and all M others (:,2:M) + allocate (assign_to_mols(V,M+1),source=.false.) + allocate (unassigned_fragments(nfragnew),source=.true.) + !> distribute the separated fragments. Also assign the shared atoms themselves + mm = 1 + do ii = 1,nshared + sii = fragnew(sharedlist(ii)) + assign_to_mols(sharedlist(ii),:) = .true. + if (.not.unassigned_fragments(sii)) cycle + mm = mm+1 + unassigned_fragments(sii) = .false. + do jj = 1,V + if (fragnew(jj) == sii) then + assign_to_mols(jj,mm) = .true. + end if + end do + end do + !> then, all atoms that had no connection to the shared region + !> and hence are present everywhere (except the shard region) + do ii = 1,V + if (.not.connected_to_share(ii)) then + sii = fragnew(ii) + unassigned_fragments(sii) = .false. + do jj = 1,V + if (fragnew(jj) == sii) then + assign_to_mols(jj,2:mm) = .true. + end if + end do + end if + end do + + !!> exactly 0 fragments should be remaining because we had the even split + if (count(unassigned_fragments) .ne. 0) then + error stop source//": wrong number of unassigned_fragments" + end if + end if + + !> prepare mapping and capping. + allocate (capping_mapping(V,M),source=.false.) + allocate (methylizemapping(nshared,M),source=.false.) + !> First, simple, chemoinformatic rules + do ii = 1,M + mm = ii+1 + do jj = 1,nshared + nbonds = 0 + sii = sharedlist(jj) + do ll = 1,V + if ((A(ll,sii) == 1).and.assign_to_mols(ll,mm)) then + nbonds = nbonds+1 + end if + end do + if (nbonds == 1.and.input%at(sii) == 6) then + methylizemapping(jj,ii) = .true. + end if + end do + end do + !> then "regular" capping, we determine original atoms as proxy for + !> the cap (and later adjust the bondlength) + !> Entries will be .true. for atoms that need to be added to fragment + do ii = 1,M + mm = ii+1 + do jj = 1,nshared + if (methylizemapping(jj,ii)) cycle + do kk = 1,V + if (A(kk,sharedlist(jj)) == 1.and..not.assign_to_mols(kk,mm)) then + capping_mapping(kk,ii) = .true. + end if + end do + end do + end do + +!> ---------------------------------------------------------------------------- +!> BOOKKEEPING END +!> ---------------------------------------------------------------------------- +!> MOLECULE CONSTRUCTION START +!> ---------------------------------------------------------------------------- + + allocate (structures(M)) !> we know that splitting produces M fragment + allocate (sharedmap(nshared,M),source=0) + allocate (ncapped(M),source=0) + allocate (pos_map(V,M),source=0) + + do ii = 1,M + mm = ii+1 + !> count atoms, allocate + nn = count(assign_to_mols(:,mm),1)+ & + & count(capping_mapping(:,ii),1)+ & + & count(methylizemapping(:,ii),1)*3 + structures(ii)%nat = nn + allocate (structures(ii)%at(nn),source=2) + allocate (structures(ii)%xyz(3,nn),source=0.0_wp) + kk = 0 + jjj = 0 + !> directly assigned atoms + do jj = 1,V + if (assign_to_mols(jj,mm)) then + kk = kk+1 + structures(ii)%at(kk) = input%at(jj) + structures(ii)%xyz(1:3,kk) = input%xyz(1:3,jj) + if (any(sharedlist(:) == jj)) then + jjj = jjj+1 + sharedmap(jjj,ii) = kk + end if + pos_map(jj,ii) = kk + end if + end do + !> capping atoms + do jj = 1,V + if (capping_mapping(jj,ii)) then + kk = kk+1 + ncapped(ii) = ncapped(ii)+1 + structures(ii)%at(kk) = 1 !input%at(jj) + structures(ii)%xyz(1:3,kk) = input%xyz(1:3,jj) + !> repair distance for capping atoms + do ll = 1,V + if ((A(ll,jj) == 1).and.assign_to_mols(ll,mm)) then + distcap = (rcov(1)+rcov(input%at(ll)))*(3.0_wp/4.0_wp) + call place_at_distance(input%xyz(1:3,ll),structures(ii)%xyz(1:3,kk),distcap) + end if + end do + end if + end do + !> methylation atoms + do jj = 1,nshared + if (methylizemapping(jj,ii)) then + sjj = sharedlist(jj) + do ll = 1,V + if (A(ll,sjj) == 1.and.assign_to_mols(ll,mm)) then + call methylize(input%xyz(1:3,sjj),input%xyz(1:3,ll),methylproxy) + do lll = 1,3 + kk = kk+1 + ncapped(ii) = ncapped(ii)+1 + structures(ii)%at(kk) = 1 + structures(ii)%xyz(1:3,kk) = methylproxy(1:3,lll) + end do + exit + end if + end do + end if + end do + end do + +!> ---------------------------------------------------------------------------- +!> MOLECULE CONSTRUCTION END +!> ---------------------------------------------------------------------------- + + if (present(ncap)) then + call move_alloc(ncapped,ncap) + end if + + if (present(position_mapping)) then + call move_alloc(pos_map,position_mapping) + end if + + if (allocated(pos_map)) deallocate (pos_map) + if (allocated(ncapped)) deallocate (ncapped) + if (allocated(assign_to_mols)) deallocate (assign_to_mols) + if (allocated(capping_mapping)) deallocate (capping_mapping) + if (allocated(unassigned_fragments)) deallocate (unassigned_fragments) + if (allocated(number_of_neighbours)) deallocate (number_of_neighbours) + if (allocated(terminal_atom)) deallocate (terminal_atom) + if (allocated(connected_to_share)) deallocate (connected_to_share) + if (allocated(Anew)) deallocate (Anew) + if (allocated(frag)) deallocate (frag) + end subroutine binarysplit_onshared !=============================================================================! pure subroutine place_at_distance(ref,moving,dist,tol,ierr) From cbc6a4d7c7a693eb364b6dac3aa1c748bda37c49 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 2 Feb 2026 14:52:54 +0100 Subject: [PATCH 152/374] Update irmsd routines from irmsd project --- src/sorting/canonical.f90 | 84 +++-- src/sorting/hungarian.f90 | 26 +- src/sorting/irmsd_module.f90 | 641 +++++++++++++++++++++++------------ 3 files changed, 492 insertions(+), 259 deletions(-) diff --git a/src/sorting/canonical.f90 b/src/sorting/canonical.f90 index 3931c5b4..15770559 100644 --- a/src/sorting/canonical.f90 +++ b/src/sorting/canonical.f90 @@ -21,7 +21,7 @@ module canonical_mod use strucrd use adjacency use geo - use utilities, only: nth_prime + use utilities,only:nth_prime implicit none private @@ -51,6 +51,7 @@ module canonical_mod procedure :: deallocate => deallocate_canonical_sorter procedure :: shrink => shrink_canonical_sorter procedure :: init => init_canonical_sorter + procedure :: init_connect => init_canonical_sorter_connect procedure :: update_ranks procedure :: update_invariants procedure :: iterate @@ -125,7 +126,7 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype,heavy) integer :: counth,countb,countbo real(wp) :: countbo2 real(wp),allocatable :: cn(:),Bmat(:,:) - integer :: i,j,k,l,ii,ati,atj,maxnei + integer :: i,j,k,l,ii,ati,maxnei integer,allocatable :: ichrgs(:),frag(:) character(len=:),allocatable :: myinvtype logical :: use_icharges,include_H,anyH @@ -141,7 +142,7 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype,heavy) else include_H = .false. end if - anyH = any(mol%at(:).eq.1) + anyH = any(mol%at(:) .eq. 1) !>--- all atoms of the full mol. graph are nodes nodes = mol%nat @@ -161,16 +162,19 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype,heavy) if (.not.allocated(self%rank)) allocate (self%rank(k),source=1) if (.not.allocated(self%hadjac)) allocate (self%hadjac(k,k),source=0) + if (present(wbo)) then +!>--- get connectivity. Easiest is just via WBO (allocates Amat) + call wbo2adjacency(nodes,wbo,Amat,0.02_wp) + else !>--- determine number of subgraphs via CN - call mol%cn_to_bond(cn,Bmat,'cov') - call wbo2adjacency(nodes,Bmat,Amat,0.02_wp) + call mol%cn_to_bond(cn,Bmat,'cov') + call wbo2adjacency(nodes,Bmat,Amat,0.02_wp) + deallocate (Bmat,cn) + end if allocate (frag(nodes),source=0) call setup_fragments(nodes,Amat,frag) self%nfrag = maxval(frag(:),1) - deallocate (frag,cn,Bmat) - -!>--- get connectivity. Easiest is just via WBO (allocates Amat) -! call wbo2adjacency(nodes,wbo,Amat,0.02_wp) + deallocate (frag) !>--- documment neighbour list maxnei = 0 @@ -235,7 +239,7 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype,heavy) end do self%invariants0(i) = update_invariant0_apsp(self%invariants0(i),ati,counth) end do - self%invariants(:) = real(self%invariants0(:)) + self%invariants(:) = int(self%invariants0(:)) case default !> CANGEN @@ -291,7 +295,7 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype,heavy) call self%iterate(mol) !> iterate recursively until ranking doesn't change !>--- finally, if required, add H atoms - if (include_H .and. anyH) then + if (include_H.and.anyH) then !> sinc H's will have been added with rank 1, shift all ranks self%rank(:) = self%rank(:)-1 call self%add_h_ranks(mol) @@ -299,6 +303,31 @@ subroutine init_canonical_sorter(self,mol,wbo,invtype,heavy) end subroutine init_canonical_sorter + subroutine init_canonical_sorter_connect(self,at,wbo,invtype,heavy) +!***************************************************************** +!* Initializes the canonical_sorter provided only atom types and +!* connectivity. No CN calculation etc. +!***************************************************************** + implicit none + !> IN-/OUTPUTS + class(canonical_sorter),intent(inout) :: self + integer,intent(in) :: at(:) + real(wp),intent(in) :: wbo(size(at,1),size(at,1)) + character(len=*),intent(in),optional :: invtype + logical,intent(in),optional :: heavy + !> LOCAL + integer :: nat + type(coord) :: tmpmol + + nat = size(at,1) + allocate(tmpmol%at(nat)) + tmpmol%at(:) = at(:) + tmpmol%nat = nat + + call self%init(tmpmol,wbo=wbo,invtype=invtype,heavy=heavy) +end subroutine init_canonical_sorter_connect + + !========================================================================================! subroutine get_invariant0_apsp(hatms,hadjac,inv) @@ -310,7 +339,7 @@ subroutine get_invariant0_apsp(hatms,hadjac,inv) real(wp),allocatable :: dist(:,:) real(wp),allocatable :: rinv(:),tmprinv(:) integer,allocatable :: tmp(:,:) - integer :: i,j,k,l,maxdist,lpath + integer :: i,j,k,maxdist real(wp) :: maxrinv inv(:) = 1 @@ -398,7 +427,7 @@ subroutine update_ranks(self) !>---update ranks and primes implicit none class(canonical_sorter) :: self - integer :: maxrank,i,j,k,ii + integer :: maxrank,i,j,ii integer :: newrank,ngroup integer(int64) :: mincurr maxrank = maxval(self%rank,1) @@ -439,7 +468,7 @@ subroutine update_invariants(self) !>---update invariants implicit none class(canonical_sorter) :: self - integer :: i,j,k,ii + integer :: i,j integer(int64) :: invprod do i = 1,self%hatms invprod = 1 @@ -484,7 +513,7 @@ subroutine analyze_stereo(self,mol) class(canonical_sorter) :: self type(coord),intent(in) :: mol integer :: i,ii,zero,nei,j,jj,maxrank - integer :: k,l,rs + integer :: k,rs integer,allocatable :: neiranks(:,:) real(wp) :: coords(3,4) logical,allocatable :: isstereo(:) @@ -542,9 +571,7 @@ function has_stereo(self,mol) result(yesno) class(canonical_sorter),intent(in) :: self type(coord),intent(in) :: mol integer :: i,ii,zero,nei,j,jj,maxrank - integer :: k,l,rs integer,allocatable :: neiranks(:,:) - real(wp) :: coords(3,4) logical,allocatable :: isstereo(:) allocate (isstereo(mol%nat),source=.false.) allocate (neiranks(4,mol%nat),source=0) @@ -636,10 +663,8 @@ subroutine add_h_ranks(self,mol) implicit none class(canonical_sorter),intent(inout) :: self type(coord),intent(in) :: mol - integer,allocatable :: rankh(:) integer,allocatable :: rankmap(:) - integer :: i,ii,zero,nei,j,jj,maxrank,rr,maxrank2 - logical :: hneigh + integer :: i,ii,jj,maxrank,rr !>--- self%rank must already have the correct dimension! if (size(self%rank,1) .ne. mol%nat) then stop 'wrong dimension for adding H to canonical ranks!' @@ -654,6 +679,10 @@ subroutine add_h_ranks(self,mol) do i = 1,self%hatms if (mol%at(i) .ne. 1) cycle ii = self%neigh(1,i) + if(ii < 1)then + !> Edge-case: "unbound"" hydrogens (H⁺,H2, etc.), skip those here + cycle + endif jj = self%rank(ii) rankmap(jj) = 1 end do @@ -663,9 +692,16 @@ subroutine add_h_ranks(self,mol) rankmap(i) = maxrank+rr end if end do + !> new maxrank(+1) + maxrank = maxval(rankmap(:),1) do i = 1,self%hatms if (mol%at(i) .ne. 1) cycle ii = self%neigh(1,i) + if(ii < 1)then + !> again, taking care of the "unbound" H edge-case --> separate maxrank+1 for all of them + self%rank(i) = maxrank + cycle + endif jj = self%rank(ii) self%rank(i) = rankmap(jj) end do @@ -679,7 +715,7 @@ subroutine debugprint(can,mol) implicit none type(canonical_sorter) :: can type(coord) :: mol - integer :: i,k,ii,ati + integer :: i,ii,ati write (stdout,'(a10,a5,a15,a10,a10)') 'heavy-atom','type','invariant','rank','prime' do i = 1,can%hatms ii = can%hmap(i) @@ -692,7 +728,7 @@ subroutine rankprint(can,mol) implicit none class(canonical_sorter) :: can type(coord) :: mol - integer :: i,k,ii,ati + integer :: i,ii,ati write (stdout,'(a10,a10,a12,a10,2x,a)') 'heavy-atom','type','invariant0','rank','neighbours' do i = 1,can%hatms ii = can%hmap(i) @@ -707,7 +743,7 @@ function print_neighbours(mol,neigh) result(btmp) integer,intent(in) :: neigh(:) character(len=:),allocatable :: btmp character(len=20) :: atmp - integer :: i,j,k + integer :: i btmp = '' if (neigh(1) == 0) then btmp = ' ---' @@ -749,7 +785,7 @@ function determineRS(coords) result(RS) real(wp),intent(inout) :: coords(3,4) real(wp) :: theta real(wp) :: vec(3),uec(3) - integer :: k,l,m,n + integer :: k,l k = 4 !> rotate the highest prio atom onto z axis (0,0,1) diff --git a/src/sorting/hungarian.f90 b/src/sorting/hungarian.f90 index dd9b1d5c..54b89cc4 100644 --- a/src/sorting/hungarian.f90 +++ b/src/sorting/hungarian.f90 @@ -63,7 +63,7 @@ module hungarian_module end type assignment_cache interface ckmin - module procedure ckmin_int + ! module procedure ckmin_int module procedure ckmin_sp end interface ckmin @@ -140,16 +140,16 @@ end subroutine deallocate_assignment_cache !========================================================================================! - logical function ckmin_int(a,b) result(yesno) - !> Helper function to compute the minimum and update - integer,intent(inout) :: a - integer,intent(in) :: b - yesno = .false. - if (b < a) then - a = b - yesno = .true. - end if - end function ckmin_int + !logical function ckmin_int(a,b) result(yesno) + ! !> Helper function to compute the minimum and update + ! integer,intent(inout) :: a + ! integer,intent(in) :: b + ! yesno = .false. + ! if (b < a) then + ! a = b + ! yesno = .true. + ! end if + !end function ckmin_int logical function ckmin_sp(a,b) result(yesno) !> Helper function to compute the minimum and update @@ -425,10 +425,8 @@ subroutine lsap_cached(lcache,nr,nc,maximize,iostatus) integer,intent(in) :: nr,nc logical,intent(in) :: maximize integer :: iostatus - integer :: curRow,curRow_iter,currowtmp,i,j,jj,sink + integer :: curRow,currowtmp,i,j,jj,sink real(sp) :: minValue - logical :: transposed - integer :: tmpx !> error codes integer,parameter :: RECTANGULAR_LSAP_TRANSPOSED = 1 integer,parameter :: RECTANGULAR_LSAP_INFEASIBLE = 2 diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index 3e07e896..3433e10d 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -14,7 +14,8 @@ module irmsd_module public :: rmsd public :: min_rmsd - public :: checkranks,fallbackranks,molatomsort + public :: checkranks,fallbackranks + public :: molatomsort real(wp),parameter :: bigval = huge(bigval) @@ -37,24 +38,28 @@ module irmsd_module !* and enable shared-memory parallelism !**************************************************** real(wp),allocatable :: xyzscratch(:,:,:) - integer,allocatable :: rank(:,:) - integer,allocatable :: best_order(:,:) - integer,allocatable :: current_order(:) - integer,allocatable :: target_order(:) - integer,allocatable :: order_bkup(:,:) - integer,allocatable :: iwork(:) - integer,allocatable :: iwork2(:,:) - logical,allocatable :: assigned(:) !> atom-wise - logical,allocatable :: rassigned(:) !> rank-wise + integer,allocatable :: rank(:,:) + integer,allocatable :: best_order(:,:) + integer,allocatable :: current_order(:) + integer,allocatable :: target_order(:) + integer,allocatable :: order_bkup(:,:) + integer,allocatable :: iwork(:) + integer,allocatable :: iwork2(:,:) + logical,allocatable :: assigned(:) !> atom-wise + logical,allocatable :: rassigned(:) !> rank-wise + logical,allocatable :: lwork(:) integer :: nranks = 0 integer,allocatable :: ngroup(:) logical :: stereocheck = .false. + integer,allocatable :: proxy_topo_ref(:,:) + integer,allocatable :: proxy_topo(:,:) type(rmsd_core_cache),allocatable :: ccache type(assignment_cache),allocatable :: acache contains procedure :: allocate => allocate_rmsd_cache + procedure :: check_proxy_topo end type rmsd_cache real(wp),parameter :: inf = huge(1.0_wp) @@ -73,29 +78,29 @@ module irmsd_module & 0.0_wp,0.0_wp,-1.0_wp], & & [3,3]) - real(wp),parameter :: Rz180(3,3) = reshape([-1.0_wp,0.0_wp,0.0_wp, & - & 0.0_wp,-1.0_wp,0.0_wp, & - & 0.0_wp,0.0_wp,1.0_wp], & - & [3,3]) + !real(wp),parameter :: Rz180(3,3) = reshape([-1.0_wp,0.0_wp,0.0_wp, & + ! & 0.0_wp,-1.0_wp,0.0_wp, & + ! & 0.0_wp,0.0_wp,1.0_wp], & + ! & [3,3]) - real(wp), parameter :: Rx90(3,3) = reshape([ & - & 1.0_wp, 0.0_wp, 0.0_wp, & - & 0.0_wp, 0.0_wp, 1.0_wp, & - & 0.0_wp, -1.0_wp, 0.0_wp & + real(wp),parameter :: Rx90(3,3) = reshape([ & + & 1.0_wp,0.0_wp,0.0_wp, & + & 0.0_wp,0.0_wp,1.0_wp, & + & 0.0_wp,-1.0_wp,0.0_wp & & ], [3,3]) - real(wp),parameter :: Rx90T(3,3) = transpose(Rx90) + real(wp),parameter :: Rx90T(3,3) = transpose(Rx90) - real(wp), parameter :: Ry90(3,3) = reshape([ & - & 0.0_wp, 0.0_wp, -1.0_wp, & - & 0.0_wp, 1.0_wp, 0.0_wp, & - & 1.0_wp, 0.0_wp, 0.0_wp & + real(wp),parameter :: Ry90(3,3) = reshape([ & + & 0.0_wp,0.0_wp,-1.0_wp, & + & 0.0_wp,1.0_wp,0.0_wp, & + & 1.0_wp,0.0_wp,0.0_wp & & ], [3,3]) real(wp),parameter :: Ry90T(3,3) = transpose(Ry90) - real(wp), parameter :: Rz90(3,3) = reshape([ & - & 0.0_wp, 1.0_wp, 0.0_wp, & - & -1.0_wp, 0.0_wp, 0.0_wp, & - & 0.0_wp, 0.0_wp, 1.0_wp & + real(wp),parameter :: Rz90(3,3) = reshape([ & + & 0.0_wp,1.0_wp,0.0_wp, & + & -1.0_wp,0.0_wp,0.0_wp, & + & 0.0_wp,0.0_wp,1.0_wp & & ], [3,3]) real(wp),parameter :: Rz90T(3,3) = transpose(Rz90) @@ -133,7 +138,10 @@ subroutine allocate_rmsd_cache(self,nat) if (allocated(self%iwork2)) deallocate (self%iwork2) if (allocated(self%assigned)) deallocate (self%assigned) if (allocated(self%rassigned)) deallocate (self%rassigned) + if (allocated(self%lwork)) deallocate (self%lwork) if (allocated(self%ngroup)) deallocate (self%ngroup) + if (allocated(self%proxy_topo_ref)) deallocate (self%proxy_topo_ref) + if (allocated(self%proxy_topo)) deallocate (self%proxy_topo) if (allocated(self%ccache)) deallocate (self%ccache) if (allocated(self%acache)) deallocate (self%acache) allocate (self%assigned(nat),source=.false.) @@ -147,6 +155,8 @@ subroutine allocate_rmsd_cache(self,nat) allocate (self%rank(nat,2),source=0) self%nranks = 0 allocate (self%ngroup(nat),source=0) + allocate (self%proxy_topo(nat,2),source=0) + allocate (self%proxy_topo_ref(nat,2),source=0) allocate (self%xyzscratch(3,nat,2),source=0.0_wp) allocate (self%ccache) allocate (self%acache) @@ -159,33 +169,33 @@ end subroutine allocate_rmsd_cache !========================================================================================! function rmsd(ref,mol,mask,scratch,rotmat,gradient,ccache) result(rmsdval) -!************************************************************************ -!* function rmsd -!* Calculate the molecular RMSD via a quaternion algorithm -!* -!* Optional arguments are -!* mask - boolean array to select a substructure for RMSD calculation -!* scratch - workspace to create the substructures -!* rotmat - rotation matrix as return argument -!* gradient - Cartesian gradient of the RMSD -!************************************************************************ + !************************************************************************ + !* function rmsd + !* Calculate the molecular RMSD via a quaternion algorithm + !* + !* Optional arguments are + !* mask - boolean array to select a substructure for RMSD calculation + !* scratch - workspace to create the substructures + !* rotmat - rotation matrix as return argument + !* gradient - Cartesian gradient of the RMSD + !************************************************************************ implicit none real(wp) :: rmsdval type(coord),intent(in) :: ref type(coord),intent(in) :: mol !> OPTIONAL arguments - logical,intent(in),optional :: mask(ref%nat) + logical,intent(in),optional :: mask(ref%nat) real(wp),intent(inout),target,optional :: scratch(3,ref%nat,2) - real(wp),intent(out),optional :: rotmat(3,3) - real(wp),intent(out),target,optional :: gradient(3,ref%nat) + real(wp),intent(out),optional :: rotmat(3,3) + real(wp),intent(out),target,optional :: gradient(3,ref%nat) type(rmsd_core_cache),intent(inout),optional,target :: ccache !> variables type(rmsd_core_cache),allocatable,target :: ccachetmp type(rmsd_core_cache),pointer :: ccptr - real(wp) :: x_center(3),y_center(3),Udum(3,3) + real(wp) :: Udum(3,3) real(wp),target :: gdum(3,3) - integer :: nat,getrotmat - logical :: calc_u + integer :: nat,getrotmat + logical :: calc_u real(wp),allocatable,target :: tmpscratch(:,:,:) logical :: getgrad real(wp),pointer :: grdptr(:,:) @@ -265,7 +275,7 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient,ccache) result(rmsdval) if (allocated(tmpscratch)) deallocate (tmpscratch) else -!>--- standard calculation (Quarternion algorithm) +!>--- standard calculation (quaternion algorithm, no mask) call rmsd_core(ref%nat,mol%xyz,ref%xyz, & & calc_u,Udum,rmsdval,getgrad,grdptr,ccptr) end if @@ -278,12 +288,12 @@ end function rmsd !========================================================================================! subroutine rmsd_core(nat,xyz1,xyz2,calc_u,U,error,calc_g,grad,ccache) -!********************************************************** -!* Rewrite or RMSD code with modified memory management -!* Adapted from ls_rmsd, and using some of its subroutines -!* The goal is to offload memory allocation to outside -!* the routine in case it is repeadetly called -!********************************************************** + !********************************************************** + !* Rewrite or RMSD code with modified memory management + !* Adapted from ls_rmsd, and using some of its subroutines + !* The goal is to offload memory allocation to outside + !* the routine in case it is repeadetly called + !********************************************************** use ls_rmsd,only:dstmev,rotation_matrix implicit none integer,intent(in) :: nat @@ -311,22 +321,22 @@ subroutine rmsd_core(nat,xyz1,xyz2,calc_u,U,error,calc_g,grad,ccache) associate (x => ccache%x,y => ccache%y,xi => ccache%xi,yi => ccache%yi) !> make copies of the original coordinates - x(:,:) = xyz1(:,:) - y(:,:) = xyz2(:,:) + x(1:3,1:nat) = xyz1(1:3,1:nat) + y(1:3,1:nat) = xyz2(1:3,1:nat) !> calculate the barycenters, centroidal coordinates, and the norms x_norm = 0.0_wp y_norm = 0.0_wp rnat = 1.0_wp/real(nat,wp) do i = 1,3 - xi(:) = x(i,:) - yi(:) = y(i,:) + xi(:nat) = x(i,1:nat) + yi(:nat) = y(i,1:nat) x_center(i) = sum(xi(1:nat))*rnat y_center(i) = sum(yi(1:nat))*rnat - xi(:) = xi(:)-x_center(i) - yi(:) = yi(:)-y_center(i) - x(i,:) = xi(:) - y(i,:) = yi(:) + xi(1:nat) = xi(1:nat)-x_center(i) + yi(1:nat) = yi(1:nat)-y_center(i) + x(i,1:nat) = xi(1:nat) + y(i,1:nat) = yi(1:nat) x_norm = x_norm+dot_product(xi,xi) y_norm = y_norm+dot_product(yi,yi) end do @@ -334,7 +344,7 @@ subroutine rmsd_core(nat,xyz1,xyz2,calc_u,U,error,calc_g,grad,ccache) !> calculate the R matrix do i = 1,3 do j = 1,3 - Rmatrix(i,j) = dot_product(x(i,:),y(j,:)) + Rmatrix(i,j) = dot_product(x(i,1:nat),y(j,1:nat)) end do end do @@ -392,38 +402,48 @@ end subroutine rmsd_core !========================================================================================! - subroutine min_rmsd(ref,mol,rcache,rmsdout,align) -!********************************************************************* -!* Main routine to determine minium RMSD considering atom permutation -!* Input -!* ref - the reference structure -!* mol - the structure to be matched to ref -!* Optinal arguments -!* rcache - memory cache -!* rmsdout - the calculated RMSD scalar -!* align - quarternion-align mol in the last stage -!********************************************************************* + subroutine min_rmsd(ref,mol,rcache,rmsdout,align,topocheck,io) + !**************************************************************************** + !* Main routine to determine minium RMSD considering atom permutation + !* Input + !* ref - the reference structure + !* mol - the structure to be matched to ref + !* Optinal arguments + !* rcache - memory cache + !* rmsdout - the calculated RMSD scalar + !* align - quarternion-align mol in the last stage + !* topocheck - check molecule topology? if absent, doing check is default + !* io - return status + !**************************************************************************** implicit none !> IN & OUTPUT - type(coord),intent(in) :: ref + type(coord),intent(in) :: ref type(coord),intent(inout) :: mol type(rmsd_cache),intent(inout),optional,target :: rcache real(wp),intent(out),optional :: rmsdout logical,intent(in),optional :: align + logical,intent(in),optional :: topocheck + integer,intent(out),optional :: io !> LOCAL type(rmsd_cache),pointer :: cptr type(rmsd_cache),allocatable,target :: local_rcache - integer :: nat,ii,rnk,dumpunit,uniquenesscase + integer :: nat,ii,rnk,dumpunit,uniquenesscase,ioloc + integer :: nunique real(wp) :: calc_rmsd - real(wp) :: tmprmsd_sym(32),dum - real(wp) :: rotmat(3,3),rotconst(3) + real(wp) :: tmprmsd_sym(32) + real(wp) :: rotmat(3,3),rotconst(3),shift(3) + logical :: topocheck_l = .true. logical,parameter :: debug = .false. +!>--- defaults + ioloc = 0 + !>--- Initialization if (present(rcache)) then cptr => rcache else + write (stdout,*) "WARNING: No iRMSD-cache provided. Attempting to fall back to atom types for sorting ranks." allocate (local_rcache) if (ref%nat .ne. mol%nat) then error stop 'Unequal molecule size in min_rmsd()' @@ -433,11 +453,27 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout,align) call fallbackranks(ref,mol,nat,local_rcache%rank) cptr => local_rcache end if - -!>-- Consistency check + if (present(topocheck)) then + topocheck_l = topocheck + end if cptr%nranks = maxval(cptr%rank(:,1)) - if (cptr%nranks .ne. maxval(cptr%rank(:,2))) then - error stop "Different atom identities in min_rmsd, can't restore an atom order!" + +!>-- Consistency (topology) check + if (topocheck_l) then + ioloc = cptr%check_proxy_topo(ref,mol) + if (ioloc > 0) then + write (stdout,'(1x,a)') "WARNING: Different atom topologies detected in min_rmsd(), can't restore an atom order!" + if (present(rmsdout)) then + if (ioloc > 2) then !> topo check identified at least the same system size and maxrank --> quaternion RMSD may be feasible + write (stdout,'(10x,a)') "Falling back to quaternion RMSD without reordering atoms. Values may be nonsensical." + rmsdout = rmsd(ref,mol,ccache=cptr%ccache) + else + rmsdout = huge(rmsdout) + end if + end if + if (present(io)) io = ioloc + return + end if end if !>--- First sorting, to at least restore rank order (only if that's not the case!) @@ -503,67 +539,118 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout,align) open (newunit=dumpunit,file='debugirmsd.xyz') call ref%append(dumpunit) end if - !> initialize to huge - tmprmsd_sym(:) = inf - !> initial alignment of mol - call axis(mol%nat,mol%at,mol%xyz,rotconst) - call min_rmsd_rotcheck_unique(mol,rotconst,uniquenesscase) - - !> Running the checks and check of uniqueness of rotational axes - call min_rmsd_rotcheck_permute(ref,mol,cptr,tmprmsd_sym,1,uniquenesscase) - if (debug) then - write (*,*) 'Total LSAP cost:',minval(tmprmsd_sym(1:16)) - call mol%append(dumpunit) - end if - !> mirror z and re-run the same checks (i.e. the false rotamer inversion) - if (cptr%stereocheck) then - mol%xyz(3,:) = -mol%xyz(3,:) !> mirror z - call axis(mol%nat,mol%at,mol%xyz) !> align +!>--- Check how many indices are unique + cptr%lwork = unique_rank_mask(cptr%rank(:,1)) + nunique = count(cptr%lwork) + +!> -------------------------------------------------------- +!> SUBSTRUCTURE-BASED ALIGNMENT with enough unique indices +!> -------------------------------------------------------- + + !> The logic here is: if we have enough unique atoms + !> we can align the molecule with them and identify + !> symmetry equivalent atoms via LSAP in those thereafter + IF (nunique >= 3)then + !> mol still needs a first alignment and CMA shift + call CMAtrf(mol%nat,mol%nat,mol%at,mol%xyz) + + tmprmsd_sym(:) = inf + tmprmsd_sym(1) = rmsd(ref,mol,cptr%lwork, & + & cptr%xyzscratch,rotmat=rotmat, & + & ccache=cptr%ccache) + mol%xyz = matmul(rotmat,mol%xyz) + call min_rmsd_iterate_through_groups(ref,mol,cptr,tmprmsd_sym(1)) + cptr%order_bkup(:,1) = cptr%iwork(:) + if (cptr%stereocheck) then + mol%xyz(3,:) = -mol%xyz(3,:) + + tmprmsd_sym(2) = rmsd(ref,mol,cptr%lwork, & + & cptr%xyzscratch,rotmat=rotmat, & + & ccache=cptr%ccache) + mol%xyz = matmul(rotmat,mol%xyz) + call min_rmsd_iterate_through_groups(ref,mol,cptr,tmprmsd_sym(2)) + cptr%order_bkup(:,2) = cptr%iwork(:) + mol%xyz(3,:) = -mol%xyz(3,:) + end if - !> Running the checks - call min_rmsd_rotcheck_permute(ref,mol,cptr,tmprmsd_sym,2,uniquenesscase) + ii = minloc(tmprmsd_sym,1) + if (ii == 2) then + !> if the non-mirrored check was lower, revert the mirroring + mol%xyz(3,:) = -mol%xyz(3,:) + end if +!> ---------------------------------------------------- + ELSE +!> ---------------------------------------------------- +!> ROTATIONAL AXIS ALIGNMENT AND LSAP CHECKS - START +!> ---------------------------------------------------- + + !> initialize to huge + tmprmsd_sym(:) = inf + !> initial alignment of mol + call axis(mol%nat,mol%at,mol%xyz,rotconst) + call min_rmsd_rotcheck_unique(rotconst,uniquenesscase) + + !> Running the checks and check of uniqueness of rotational axes + call min_rmsd_rotcheck_permute(ref,mol,cptr,tmprmsd_sym,1,uniquenesscase) if (debug) then - write (*,*) 'Total LSAP cost (inverted):',minval(tmprmsd_sym(17:32)) + write (*,*) 'Total LSAP cost:',minval(tmprmsd_sym(1:16)) call mol%append(dumpunit) end if - mol%xyz(3,:) = -mol%xyz(3,:) !> restore z - end if + + !> mirror z and re-run the same checks (i.e. the false rotamer inversion) + if (cptr%stereocheck) then + mol%xyz(3,:) = -mol%xyz(3,:) !> mirror z + call axis(mol%nat,mol%at,mol%xyz) !> align + + !> Running the checks + call min_rmsd_rotcheck_permute(ref,mol,cptr,tmprmsd_sym,2,uniquenesscase) + if (debug) then + write (*,*) 'Total LSAP cost (inverted):',minval(tmprmsd_sym(17:32)) + call mol%append(dumpunit) + end if + mol%xyz(3,:) = -mol%xyz(3,:) !> restore z + end if !>--- select the best match among the ones after symmetry operations and use its ordering - ii = minloc(tmprmsd_sym(1:32),1) - if (debug) then - write (*,*) 'final alignment:',ii,"/ 32" - end if - if (ii > 16) then - mol%xyz(3,:) = -mol%xyz(3,:) - if (debug) write (*,*) 'inverting' - end if - if ((ii > 4 .and. ii < 9) .or. (ii > 20 .and. ii < 25))then - if(uniquenesscase == 1) mol%xyz = matmul(Rx90,mol%xyz) - if(uniquenesscase == 2) mol%xyz = matmul(Rz90,mol%xyz) - if(uniquenesscase == 3) mol%xyz = matmul(Rz90,mol%xyz) - if(debug) write (*,*) '90° tilt' - else if ((ii > 8 .and. ii < 13) .or. (ii > 24 .and. ii < 29))then - mol%xyz = matmul(Ry90,mol%xyz) - else if ((ii > 12 .and. ii < 17) .or. (ii > 28))then - mol%xyz = matmul(Rx90,mol%xyz) - endif - select case (ii) !> 180° rotations - case (1,5,9,13,17,21,25,29) - continue - case (2,6,10,14,18,22,26,30) - mol%xyz = matmul(Rx180,mol%xyz) - if (debug) write (*,*) '180°x' - case (3,7,11,15,19,23,27,31) - mol%xyz = matmul(Rx180,mol%xyz) - mol%xyz = matmul(Ry180,mol%xyz) - if (debug) write (*,*) '180°x, 180°y' - case (4,8,12,16,20,24,28,32) - mol%xyz = matmul(Ry180,mol%xyz) - if (debug) write (*,*) '180°y' - end select + ii = minloc(tmprmsd_sym(1:32),1) + if (debug) then + write (*,*) 'final alignment:',ii,"/ 32" + end if + if (ii > 16) then + mol%xyz(3,:) = -mol%xyz(3,:) + if (debug) write (*,*) 'inverting' + end if + if ((ii > 4.and.ii < 9).or.(ii > 20.and.ii < 25)) then + if (uniquenesscase == 1) mol%xyz = matmul(Rx90,mol%xyz) + if (uniquenesscase == 2) mol%xyz = matmul(Rz90,mol%xyz) + if (uniquenesscase == 3) mol%xyz = matmul(Rz90,mol%xyz) + if (debug) write (*,*) '90° tilt' + else if ((ii > 8.and.ii < 13).or.(ii > 24.and.ii < 29)) then + mol%xyz = matmul(Ry90,mol%xyz) + else if ((ii > 12.and.ii < 17).or.(ii > 28)) then + mol%xyz = matmul(Rx90,mol%xyz) + end if + select case (ii) !> 180° rotations + case (1,5,9,13,17,21,25,29) + continue + case (2,6,10,14,18,22,26,30) + mol%xyz = matmul(Rx180,mol%xyz) + if (debug) write (*,*) '180°x' + case (3,7,11,15,19,23,27,31) + mol%xyz = matmul(Rx180,mol%xyz) + mol%xyz = matmul(Ry180,mol%xyz) + if (debug) write (*,*) '180°x, 180°y' + case (4,8,12,16,20,24,28,32) + mol%xyz = matmul(Ry180,mol%xyz) + if (debug) write (*,*) '180°y' + end select +!> ---------------------------------------------------- +!> rotational axis alignment and LSAP checks - END +!> ---------------------------------------------------- + END IF cptr%current_order(:) = cptr%order_bkup(:,ii) +!> ---------------------------------------------------- if (debug) then write (*,*) 'Determined remapping' @@ -589,6 +676,7 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout,align) end if if (present(rmsdout)) rmsdout = calc_rmsd + if (present(io)) io = ioloc end subroutine min_rmsd !========================================================================================! @@ -599,7 +687,7 @@ subroutine min_rmsd_iterate_through_groups(ref,mol,rcache,val) type(coord),intent(inout) :: mol type(rmsd_cache),intent(inout),target :: rcache real(wp),intent(out) :: val - integer :: rr,ii,jj + integer :: rr,ii real(wp) :: val0 type(assignment_cache),pointer :: aptr logical,parameter :: debug = .false. @@ -632,30 +720,29 @@ end subroutine min_rmsd_iterate_through_groups !========================================================================================! - subroutine min_rmsd_rotcheck_unique(mol,rot,uniquenesscase,thr) -!******************************************************* -!* Based on the rotational constants, determine what we -!* need to do with the molecule in the following -!******************************************************* + subroutine min_rmsd_rotcheck_unique(rot,uniquenesscase,thr) + !******************************************************* + !* Based on the rotational constants, determine what we + !* need to do with the molecule in the following + !******************************************************* implicit none - type(coord),intent(inout) :: mol real(wp),intent(in) :: rot(3) integer,intent(out) :: uniquenesscase real(wp),intent(in),optional :: thr - logical :: unique(3) + logical :: unique(3) integer :: nunique - + uniquenesscase = 0 - call uniqueax(rot,unique,thr) + call uniqueax(rot,unique,thr) nunique = count(unique,1) - select case(nunique) - case ( 3 ) !> 3 unique principal axes + select case (nunique) + case (3) !> 3 unique principal axes uniquenesscase = 0 - case ( 1 ) !> one unique principal axis - if(unique(1)) uniquenesscase = 1 !> A unique (long axis) - if(unique(3)) uniquenesscase = 2 !> C unique (short axis) - case ( 0 ) !> rotationally ambiguous system + case (1) !> one unique principal axis + if (unique(1)) uniquenesscase = 1 !> A unique (long axis) + if (unique(3)) uniquenesscase = 2 !> C unique (short axis) + case (0) !> rotationally ambiguous system uniquenesscase = 3 end select end subroutine min_rmsd_rotcheck_unique @@ -669,7 +756,7 @@ subroutine min_rmsd_rotcheck_permute(ref,mol,cptr,values,step,uniquenesscase) type(rmsd_cache),intent(inout),target :: cptr real(wp),intent(inout) :: values(:) integer,intent(in) :: step,uniquenesscase - integer :: rr,ii,jj,debugunit2 + integer :: ii,debugunit2 real(wp) :: vals(16),dum logical,parameter :: debug = .false. @@ -681,66 +768,64 @@ subroutine min_rmsd_rotcheck_permute(ref,mol,cptr,values,step,uniquenesscase) call ref%append(debugunit2) end if - ALIGNLOOP : do ii=1,4 - call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) - vals(1+4*(ii-1)) = dum - if (debug) call mol%append(debugunit2) - cptr%order_bkup(:,1+4*(ii-1)+16*(step-1)) = cptr%iwork(:) - - mol%xyz = matmul(Rx180,mol%xyz) - call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) - vals(2+4*(ii-1)) = dum - if (debug) call mol%append(debugunit2) - cptr%order_bkup(:,2+4*(ii-1)+16*(step-1)) = cptr%iwork(:) - - mol%xyz = matmul(Ry180,mol%xyz) - call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) - vals(3+4*(ii-1)) = dum - if (debug) call mol%append(debugunit2) - cptr%order_bkup(:,3+4*(ii-1)+16*(step-1)) = cptr%iwork(:) - - mol%xyz = matmul(Rx180,mol%xyz) - call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) - vals(4+4*(ii-1)) = dum - if (debug) call mol%append(debugunit2) - cptr%order_bkup(:,4+4*(ii-1)+16*(step-1)) = cptr%iwork(:) - - mol%xyz = matmul(Ry180,mol%xyz) !> restore - - !exit ALIGNLOOP - select case(uniquenesscase) - case( 0 ) !> 3 Unique moments of inertia - exit ALIGNLOOP - case( 1 ) !> only one unique moment of inertia (A) - if( ii == 2 )then + ALIGNLOOP: do ii = 1,4 + call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) + vals(1+4*(ii-1)) = dum + if (debug) call mol%append(debugunit2) + cptr%order_bkup(:,1+4*(ii-1)+16*(step-1)) = cptr%iwork(:) + + mol%xyz = matmul(Rx180,mol%xyz) + call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) + vals(2+4*(ii-1)) = dum + if (debug) call mol%append(debugunit2) + cptr%order_bkup(:,2+4*(ii-1)+16*(step-1)) = cptr%iwork(:) + + mol%xyz = matmul(Ry180,mol%xyz) + call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) + vals(3+4*(ii-1)) = dum + if (debug) call mol%append(debugunit2) + cptr%order_bkup(:,3+4*(ii-1)+16*(step-1)) = cptr%iwork(:) + + mol%xyz = matmul(Rx180,mol%xyz) + call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) + vals(4+4*(ii-1)) = dum + if (debug) call mol%append(debugunit2) + cptr%order_bkup(:,4+4*(ii-1)+16*(step-1)) = cptr%iwork(:) + + mol%xyz = matmul(Ry180,mol%xyz) !> restore + + !exit ALIGNLOOP + select case (uniquenesscase) + case (0) !> 3 Unique moments of inertia + exit ALIGNLOOP + case (1) !> only one unique moment of inertia (A) + if (ii == 2) then mol%xyz = matmul(Rx90T,mol%xyz) - exit ALIGNLOOP - endif - mol%xyz = matmul(Rx90,mol%xyz) - case (2) !> only one unique moment of inertia (C) - if( ii == 2 )then + exit ALIGNLOOP + end if + mol%xyz = matmul(Rx90,mol%xyz) + case (2) !> only one unique moment of inertia (C) + if (ii == 2) then mol%xyz = matmul(Rz90T,mol%xyz) exit ALIGNLOOP - endif - mol%xyz = matmul(Rz90,mol%xyz) - case (3) - if( ii == 1)then - mol%xyz = matmul(Rz90,mol%xyz) - else if(ii == 2)then - mol%xyz = matmul(Rz90T,mol%xyz) - mol%xyz = matmul(Ry90,mol%xyz) - else if(ii == 3)then - mol%xyz = matmul(Ry90T,mol%xyz) - mol%xyz = matmul(Rx90,mol%xyz) - else - mol%xyz = matmul(Rx90T,mol%xyz) - exit ALIGNLOOP - endif - end select - - - enddo ALIGNLOOP + end if + mol%xyz = matmul(Rz90,mol%xyz) + case (3) + if (ii == 1) then + mol%xyz = matmul(Rz90,mol%xyz) + else if (ii == 2) then + mol%xyz = matmul(Rz90T,mol%xyz) + mol%xyz = matmul(Ry90,mol%xyz) + else if (ii == 3) then + mol%xyz = matmul(Ry90T,mol%xyz) + mol%xyz = matmul(Rx90,mol%xyz) + else + mol%xyz = matmul(Rx90T,mol%xyz) + exit ALIGNLOOP + end if + end select + end do ALIGNLOOP if (debug) then close (debugunit2) @@ -755,14 +840,14 @@ end subroutine min_rmsd_rotcheck_permute !========================================================================================! subroutine fallbackranks(ref,mol,nat,ranks) -!***************************************************************** -!* If we are doing ranks on-the-fly (i.e. without canonical algo) -!* we can fall back to just using the atom types -!***************************************************************** + !***************************************************************** + !* If we are doing ranks on-the-fly (i.e. without canonical algo) + !* we can fall back to just using the atom types + !***************************************************************** implicit none type(coord),intent(in) :: ref,mol - integer,intent(in) :: nat - integer,intent(inout) :: ranks(nat,2) + integer,intent(in) :: nat + integer,intent(inout) :: ranks(nat,2) integer,allocatable :: typemap(:),rtypemap(:) integer :: k,ii @@ -801,13 +886,13 @@ end subroutine fallbackranks subroutine compute_linear_sum_assignment(ref,mol,ranks, & & ngroups,targetrank,iwork2,acache,val0) -!************************************************************** -!* Run the linear assignment algorithm on the desired subset -!* of atoms (via rank and targetrank) -!************************************************************** + !************************************************************** + !* Run the linear assignment algorithm on the desired subset + !* of atoms (via rank and targetrank) + !************************************************************** implicit none !> IN & OUTPUT - type(coord),intent(in) :: ref + type(coord),intent(in) :: ref type(coord),intent(inout) :: mol integer,intent(in) :: ranks(:,:) integer,intent(in) :: ngroups(:) @@ -854,7 +939,7 @@ subroutine compute_linear_sum_assignment(ref,mol,ranks, & do j = 1,mol%nat if (ranks(j,2) .ne. targetrank) cycle jj = jj+1 - dists(:) = (ref%xyz(:,i)-mol%xyz(:,j))**2 !> use i and j + dists(:) = real((ref%xyz(:,i)-mol%xyz(:,j))**2,sp) !> use i and j aptr%Cost(jj+(ii-1)*rnknat) = sum(dists) end do end do @@ -875,7 +960,7 @@ subroutine compute_linear_sum_assignment(ref,mol,ranks, & do i = 1,rnknat jj = aptr%a(i) ii = aptr%b(i) - if(ii == -1 .or. jj == -1) cycle !> cycle bad assignments + if (ii == -1.or.jj == -1) cycle !> cycle bad assignments val0 = val0+aptr%Cost(jj+(ii-1)*rnknat) iwork2(i,2) = iwork2(aptr%b(i),1) end do @@ -911,10 +996,10 @@ end subroutine rank_2_order !========================================================================================! function checkranks(nat,ranks1,ranks2) result(yesno) -!*********************************************************************** -!* Check two rank arrays to see if we have the same amount of -!* atoms in the same ranks (a condition to bein able to work with them) -!*********************************************************************** + !*********************************************************************** + !* Check two rank arrays to see if we have the same amount of + !* atoms in the same ranks (a condition to bein able to work with them) + !*********************************************************************** implicit none logical :: yesno integer,intent(in) :: nat @@ -944,6 +1029,26 @@ function checkranks(nat,ranks1,ranks2) result(yesno) yesno = .true. end function checkranks +!========================================================================================! + function unique_rank_mask(ranks) result(mask) + !********************************************* + !* Takes a rank array and creates a mask that + !* contains .true. if the respective rank + !* appears only a single time + !********************************************* + implicit none + integer,intent(in) :: ranks(:) + logical,allocatable :: mask(:) + integer :: ii,jj,n,k,rii + n = size(ranks,1) + allocate (mask(n),source=.false.) + do ii = 1,n + rii = ranks(ii) + k = count(ranks == rii) + if (k == 1) mask(ii) = .true. + end do + end function unique_rank_mask + !========================================================================================! subroutine molatomsort(mol,n,current_order,target_order,index_map) @@ -981,6 +1086,100 @@ subroutine molatomsort(mol,n,current_order,target_order,index_map) end do end subroutine molatomsort +!==========================================================================================! + + function check_proxy_topo(self,ref,mol) result(io) + !****************************************************** + !* Attempt to compare the "topology" for the molecules ref and mol + !* Assumes that ranks have been computed already. + !* Checks are in order (cheap to expensive): + !* 1) system size + !* 2) max rank + !* 3) joint sorted ranks and atom types + !* Returns "io" with value 0 if successfull, or a number indatinc faliure condition + implicit none + class(rmsd_cache) :: self + type(coord),intent(in) :: ref + type(coord),intent(in) :: mol + integer :: io + integer :: n1,n2,m1,m2 + + io = 0 + + !> Check 1 + n1 = ref%nat + n2 = mol%nat + if (n1 .ne. n2) then + io = 1 + return + end if + + !> Check 2 + m1 = maxval(self%rank(:,1)) + m2 = maxval(self%rank(:,2)) + if (m1 .ne. m2) then + io = 2; return + end if + + !> Check 3 + self%proxy_topo_ref(:,1) = ref%at(:) + self%proxy_topo_ref(:,2) = self%rank(:,1) + call qsortm(self%proxy_topo_ref,2,self%iwork) + + self%proxy_topo(:,1) = mol%at(:) + self%proxy_topo(:,2) = self%rank(:,2) + call qsortm(self%proxy_topo,2,self%iwork) + if (.not.all(self%proxy_topo .eq. self%proxy_topo_ref)) then + io = 3 + return !> some difference in the sorting, return before setting passing to true + end if + + !> All checks passed, io should still be 0 + end function check_proxy_topo + + recursive subroutine qsorti(v,ix,l,r) + !********************* + !* idx'ed quicksort + !********************* + integer,intent(in) :: v(:) + integer,intent(inout) :: ix(:) + integer,intent(in) :: l,r + integer :: i,j,p,t,n + if (l >= r) return + p = v(ix((l+r)/2)) + n = size(v,1) + i = l; j = r + do + do while (v(ix(i)) < p); i = i+1; end do + do while (v(ix(j)) > p); j = j-1; end do + if (i <= j) then + t = ix(i); ix(i) = ix(j); ix(j) = t + i = min(i+1,n); j = max(j-1,1) + else + exit + end if + end do + if (l < j) call qsorti(v,ix,l,j) + if (i < r) call qsorti(v,ix,i,r) + end subroutine qsorti + + subroutine qsortm(a,k,ix) + !************************************ + !* matrix wrapper to qsorti + !* order is reflected to all columns + !************************************ + integer,intent(inout) :: a(:,:) + integer,intent(in) :: k + integer :: n,i + integer,intent(inout) :: ix(size(a,1)) + n = size(a,1) + do i = 1,n + ix(i) = i + end do + call qsorti(a(:,k),ix,1,n) + a = a(ix,:) + end subroutine qsortm + !========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Date: Mon, 2 Feb 2026 18:35:49 +0100 Subject: [PATCH 153/374] start building charge distribution for fragment split --- src/algos/queueing.f90 | 92 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 91 insertions(+), 1 deletion(-) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 7b2a7319..1f20c8fe 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -35,6 +35,8 @@ subroutine crest_queue_setup(env,iterate) integer,allocatable :: splitatms(:) integer :: parentlayer,parentnode character(len=1024) :: thispath + real(wp),allocatable :: qat(:) + integer,allocatable :: lq(:) iterate = .true. @@ -55,6 +57,13 @@ subroutine crest_queue_setup(env,iterate) env%substructure_queue = .true. splitlayers = size(env%splitqueue,1) + !> we may need to calculate charges to distribute them: + if (env%chrg .ne. 0) then + call calc_charges(env,qat) + else + allocate (qat(env%ref%nat),source=0.0_wp) + end if + !> start constructing the splitheap env%splitheap%nlayer = splitlayers allocate (env%splitheap%layer(splitlayers)) @@ -91,6 +100,7 @@ subroutine crest_queue_setup(env,iterate) deallocate (splitatms) layer(ii)%nnodes = size(layer(ii)%node,1) call heap%map_origins_for_layer(ii) + call sum_charges_layer(env,heap,ii,qat,lq) end do call heap%setup_queue() @@ -103,6 +113,7 @@ subroutine crest_queue_setup(env,iterate) iterate = .true. end if + stop return contains subroutine pick_parent(heap,current_layer,splitatms,parentlayer,parentnode) @@ -157,6 +168,85 @@ subroutine pick_parent(heap,current_layer,splitatms,parentlayer,parentnode) end if end subroutine pick_parent + subroutine calc_charges(env,qat) + use tblite_api,only:tblite_quick_ceh_q + implicit none + type(systemdata),intent(inout) :: env + real(wp),intent(out),allocatable :: qat(:) + real(wp),allocatable :: qat0(:) + character(len=256) :: atmp + type(coord) :: mol + integer :: ii + write (atmp,'(a)') 'Calculating atomic charges under consideration of molecular charge' + call underline(trim(atmp)) + write(stdout,'(a,i0)') 'Molecular charge : ',env%chrg + call env%ref%to(mol) + call tblite_quick_ceh_q(mol,qat, & + & chrg=env%chrg,uhf=env%uhf,pr=.true.,prch=stdout) + !call tblite_quick_ceh_q(mol,qat0, & + ! & chrg=0,uhf=env%uhf,pr=.true.,prch=stdout) + write (stdout,'(a)') 'Obtained CEH charges for full structure:' + do ii = 1,mol%nat + write (stdout,'(3x,a3,2x,f10.6)') i2e(mol%at(ii)),qat(ii)!,qat0(ii),qat(ii)-qat0(ii) + end do + + write(stdout,'(/,a)') 'NOTE: Total charge for each fragment will be selected automatically by' + write(stdout,'(a)') ' matching the best atomic charge MAE to these charges.' + end subroutine calc_charges + subroutine sum_charges_layer(env,heap,lay,qat,lq) + use tblite_api,only:tblite_quick_ceh_q + implicit none + type(systemdata) :: env + type(construct_heap) :: heap + integer,intent(in) :: lay + real(wp),intent(in) :: qat(:) + integer,intent(out),allocatable :: lq(:) + integer :: ii,jj,nat,nnodes,kk,nnat + real(wp) :: qtmp,qtmp0,qtmpc + real(wp),allocatable :: qattmp0(:),qattmpc(:),qattmpref(:) + + nat = size(qat,1) + nnodes = heap%layer(lay)%nnodes + allocate (lq(nnodes),source=0) + + if (env%chrg == 0) return + + do ii = 1,nnodes + qtmp = 0.0_wp + qtmp0 = 0.0_wp + qtmpc = 0.0_wp + !write (*,*) 'layer',lay,'node',ii + nnat = heap%layer(lay)%node(ii)%nat + allocate (qattmpref(nnat),source=0.0_wp) + + call tblite_quick_ceh_q(heap%layer(lay)%node(ii),qattmp0, & + & chrg=0,uhf=env%uhf,pr=.false.,prch=stdout) + call tblite_quick_ceh_q(heap%layer(lay)%node(ii),qattmpc, & + & chrg=env%chrg,uhf=env%uhf,pr=.false.,prch=stdout) + + do jj = 1,nnat + kk = heap%layer(lay)%origin(ii)%map(jj) + if (kk > 0) then + qattmpref(jj) = qat(kk) + qtmp = qtmp+qat(kk) + else + qattmp0(jj) = 0.0_wp + qattmpc(jj) = 0.0_wp + end if + !write (*,*) jj,qattmpref(jj),qattmp0(jj),qattmpc(jj) + qtmp0 = qtmp0+abs(qattmp0(jj)-qattmpref(jj)) + qtmpc = qtmpc+abs(qattmpc(jj)-qattmpref(jj)) + end do + + deallocate (qattmpc,qattmp0,qattmpref) + if (qtmpc < qtmp0) then + lq(ii) = env%chrg + else + lq(ii) = 0 + end if + !write (*,*) 'sum charge on frag:',qtmp,qtmp0,qtmpc + end do + end subroutine sum_charges_layer end subroutine crest_queue_setup !=============================================================================! @@ -304,7 +394,7 @@ subroutine crest_queue_reconstruct(env,tim) use strucrd use iomod use crest_calculator - use utilities, only: checkname_xyz + use utilities,only:checkname_xyz implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim From f044843ee0602e020c541894bf1584bd5f66fddc Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 3 Feb 2026 21:50:02 +0100 Subject: [PATCH 154/374] Working automatic charge distribution --- src/algos/queueing.f90 | 101 +++++++++++++++++++++-------------- src/calculator/calc_type.f90 | 19 +++++++ 2 files changed, 79 insertions(+), 41 deletions(-) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 1f20c8fe..1e46ef2c 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -100,12 +100,18 @@ subroutine crest_queue_setup(env,iterate) deallocate (splitatms) layer(ii)%nnodes = size(layer(ii)%node,1) call heap%map_origins_for_layer(ii) + !> determening charges for fragments call sum_charges_layer(env,heap,ii,qat,lq) + do jj=1,layer(ii)%nnodes + layer(ii)%node(jj)%chrg = lq(jj) + enddo end do call heap%setup_queue() call getcwd(thispath) + !> some backups call env%ref%to(heap%originmol) + heap%originmol%chrg = env%chrg heap%origindir = trim(thispath) heap%origincalc => env%calc @@ -113,7 +119,6 @@ subroutine crest_queue_setup(env,iterate) iterate = .true. end if - stop return contains subroutine pick_parent(heap,current_layer,splitatms,parentlayer,parentnode) @@ -179,19 +184,17 @@ subroutine calc_charges(env,qat) integer :: ii write (atmp,'(a)') 'Calculating atomic charges under consideration of molecular charge' call underline(trim(atmp)) - write(stdout,'(a,i0)') 'Molecular charge : ',env%chrg + write (stdout,'(a,i0)') 'Molecular charge : ',env%chrg call env%ref%to(mol) call tblite_quick_ceh_q(mol,qat, & & chrg=env%chrg,uhf=env%uhf,pr=.true.,prch=stdout) - !call tblite_quick_ceh_q(mol,qat0, & - ! & chrg=0,uhf=env%uhf,pr=.true.,prch=stdout) write (stdout,'(a)') 'Obtained CEH charges for full structure:' do ii = 1,mol%nat write (stdout,'(3x,a3,2x,f10.6)') i2e(mol%at(ii)),qat(ii)!,qat0(ii),qat(ii)-qat0(ii) end do - write(stdout,'(/,a)') 'NOTE: Total charge for each fragment will be selected automatically by' - write(stdout,'(a)') ' matching the best atomic charge MAE to these charges.' + write (stdout,'(/,a)') 'NOTE: Total charge for each fragment will be selected automatically by' + write (stdout,'(a)') ' matching the best atomic charge MAE to these charges.' end subroutine calc_charges subroutine sum_charges_layer(env,heap,lay,qat,lq) use tblite_api,only:tblite_quick_ceh_q @@ -201,51 +204,64 @@ subroutine sum_charges_layer(env,heap,lay,qat,lq) integer,intent(in) :: lay real(wp),intent(in) :: qat(:) integer,intent(out),allocatable :: lq(:) - integer :: ii,jj,nat,nnodes,kk,nnat - real(wp) :: qtmp,qtmp0,qtmpc - real(wp),allocatable :: qattmp0(:),qattmpc(:),qattmpref(:) + integer :: ii,jj,nat,nnodes,kk,nnat,sign,cc,cc2,chrgs + integer,allocatable :: ichrgs(:) + real(wp) :: qtmp0,qtmpc + real(wp),allocatable :: qtmp(:) + real(wp),allocatable :: qattmp0(:),qattmpc(:),qattmpref(:),qdum(:) + real(wp),allocatable :: qattmp(:,:) nat = size(qat,1) nnodes = heap%layer(lay)%nnodes - allocate (lq(nnodes),source=0) - - if (env%chrg == 0) return + allocate (lq(nnodes),source=0) !> default chrg of 0 + + if (env%chrg == 0) return !> return for neutral systems (may need some implementation for zwitter ions) + + write(stdout,'(a,i0,a)') 'Calculating charges for fragments in layer ',lay,' ...' + sign = 1 + if (env%chrg < 0) sign = -1 + chrgs = abs(env%chrg)+1 + allocate (qtmp(chrgs), source=0.0_wp) + allocate (ichrgs(chrgs),source=0) + cc2 = 0 + do cc = 0,env%chrg,sign + cc2 = cc2+1 + ichrgs(cc2) = cc + end do do ii = 1,nnodes - qtmp = 0.0_wp + qtmp(:) = 0.0_wp qtmp0 = 0.0_wp qtmpc = 0.0_wp - !write (*,*) 'layer',lay,'node',ii nnat = heap%layer(lay)%node(ii)%nat allocate (qattmpref(nnat),source=0.0_wp) - - call tblite_quick_ceh_q(heap%layer(lay)%node(ii),qattmp0, & - & chrg=0,uhf=env%uhf,pr=.false.,prch=stdout) - call tblite_quick_ceh_q(heap%layer(lay)%node(ii),qattmpc, & - & chrg=env%chrg,uhf=env%uhf,pr=.false.,prch=stdout) - - do jj = 1,nnat - kk = heap%layer(lay)%origin(ii)%map(jj) - if (kk > 0) then - qattmpref(jj) = qat(kk) - qtmp = qtmp+qat(kk) - else - qattmp0(jj) = 0.0_wp - qattmpc(jj) = 0.0_wp - end if - !write (*,*) jj,qattmpref(jj),qattmp0(jj),qattmpc(jj) - qtmp0 = qtmp0+abs(qattmp0(jj)-qattmpref(jj)) - qtmpc = qtmpc+abs(qattmpc(jj)-qattmpref(jj)) + allocate (qattmp(nnat,chrgs)) + !> check different charge settings + cc2 = 0 + do cc = 0,env%chrg,sign + cc2 = cc2+1 + call tblite_quick_ceh_q(heap%layer(lay)%node(ii),qdum, & + & chrg=cc,uhf=env%uhf,pr=.false.,prch=stdout) + qattmp(:,cc2) = qdum(:) + do jj = 1,nnat + kk = heap%layer(lay)%origin(ii)%map(jj) + if (kk > 0) then + qattmpref(jj) = qat(kk) + else + qattmp(jj,cc2) = 0.0_wp + end if + qtmp(cc2) = qtmp(cc2)+abs(qattmp(jj,cc2)-qattmpref(jj)) + end do end do - - deallocate (qattmpc,qattmp0,qattmpref) - if (qtmpc < qtmp0) then - lq(ii) = env%chrg - else - lq(ii) = 0 - end if - !write (*,*) 'sum charge on frag:',qtmp,qtmp0,qtmpc + !> select best charge + cc = minloc(qtmp,1) + lq(ii) = ichrgs(cc) + deallocate (qattmp,qattmpref) + !write (*,*) 'charge MAEs on frag:',qtmp + !write (*,*) 'selected charge:',lq(ii) end do + write(stdout,'(2x,a)',advance='no') 'determined charges:' + write(stdout,*) lq end subroutine sum_charges_layer end subroutine crest_queue_setup @@ -314,15 +330,17 @@ subroutine crest_queue_iter(env,iterate) !> for constraints we must be careful and map them to the new order call update_constraints_queue(heap,jj,kk,env%calc,queue%calc) - call queue%calc%info(stdout) mol = env%splitheap%layer(jj)%node(kk) call env%ref%load(mol) call mol%write('coord') + call queue%calc%set_charge(mol%chrg) !> the nodes may have different charges saved + call queue%calc%info(stdout) if (allocated(env%ref%wbo)) deallocate (env%ref%wbo) env%nat = mol%nat env%rednat = mol%nat + env%chrg = mol%chrg if (.not.env%user_mdtime) then env%mdtime = -1.0_wp env%mddat%length_ps = -1.0_wp @@ -422,6 +440,7 @@ subroutine crest_queue_reconstruct(env,tim) call env%ref%load(mol) env%nat = mol%nat env%rednat = mol%nat + env%chrg = mol%chrg env%calc => env%splitheap%origincalc call chdir(env%splitheap%origindir) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index d694e01e..fa27076c 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -288,6 +288,7 @@ module calc_type generic,public :: set_freeze => calculation_set_freeze_range,calculation_set_freeze_bools procedure,private :: calculation_set_freeze_range,calculation_set_freeze_bools procedure :: freezegrad => calculation_freezegrad + procedure :: set_charge => calculation_set_charge procedure :: increase_charge => calculation_increase_charge procedure :: decrease_charge => calculation_decrease_charge procedure :: dealloc_params => calculation_deallocate_params @@ -643,6 +644,24 @@ end subroutine calculation_freezegrad !=========================================================================================! + subroutine calculation_set_charge(self,dchrg) +!*********************************************************** +!* set the charge of all calculation_settings objects to +!* the specified dchrg +!*********************************************************** + implicit none + class(calcdata) :: self + integer,intent(in) :: dchrg + integer :: i,j + if (self%ncalculations > 0) then + j = dchrg + do i = 1,self%ncalculations + self%calcs(i)%chrg = j + end do + end if + return + end subroutine calculation_set_charge + subroutine calculation_increase_charge(self,dchrg) !****************************************************************** !* increase the charge of all calculation_settings objects by one From 09a4acb7c877ef1ef80e9ff2cc6cf28fcf4bad36 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 4 Feb 2026 13:33:40 +0100 Subject: [PATCH 155/374] test --- src/algos/playground.f90 | 43 +++++++++++++++++++++++++++++++++------- 1 file changed, 36 insertions(+), 7 deletions(-) diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index c59dff77..2f5f5225 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -61,11 +61,11 @@ subroutine crest_playground(env,tim) write (*,*) " \_/\_/ \___|_|\___\___/|_| |_| |_|\___|" write (*,*) !========================================================================================! -! call env%ref%to(mol) -! write (*,*) -! write (*,*) 'Input structure:' -! call mol%append(stdout) -! write (*,*) + call env%ref%to(mol) + write (*,*) + write (*,*) 'Input structure:' + call mol%append(stdout) + write (*,*) !!========================================================================================! ! ! allocate (grad(3,mol%nat),source=0.0_wp) @@ -76,9 +76,38 @@ subroutine crest_playground(env,tim) ! call engrad(mol,calc,energy,grad,io) ! call calculation_summary(calc,mol,energy,grad) !========================================================================================! + block + use modelhessian_module + use hessian_tools + type(mhparam) :: mh + real(wp),allocatable :: h(:),hess(:,:),freq(:) + integer :: ndim,n3 + n3 = mol%nat*3 + ndim = (mol%nat*3)*((mol%nat*3)+1)/2 + allocate (h(ndim),source=0.0_wp) + call modhes(env%calc,mh,mol%nat,mol%xyz,mol%at,h,.true.) + allocate (hess(n3,n3),source=0.0_wp) + call dhtosq(n3,hess,h) + + allocate (freq(n3),source=0.0_wp) + + call print_hessian(hess,n3,'','modhess') + + !>-- Projects and mass-weights the Hessian + call prj_mw_hess(mol%nat,mol%at,n3,mol%xyz,hess) + + !>-- Computes the Frequencies + call frequencies(mol%nat,mol%at,mol%xyz,n3,env%calc,hess,freq,io) + + call numhess_thermostat(env,mol,n3,hess,freq,0.0_wp) + + call print_g98_fake(mol%nat,mol%at,n3,mol%xyz,freq,hess, & + & '','g98.out') + call print_vib_spectrum(mol%nat,mol%at,n3,mol%xyz,freq, & + & '','vibspectrum.modh') + - env%alkylize = .true. - call crest_proxy_nalkane(env,doreturn) + end block !========================================================================================! call tim%stop(14) From 055df2d709e9d7ffd1f4c1dda7424a0b3ec284d5 Mon Sep 17 00:00:00 2001 From: LukasRindt Date: Wed, 4 Feb 2026 13:34:15 +0100 Subject: [PATCH 156/374] new bugfix attempt omp hrutils --- src/calculator/hr_utils.f90 | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/src/calculator/hr_utils.f90 b/src/calculator/hr_utils.f90 index 207d1f0b..2fe20001 100644 --- a/src/calculator/hr_utils.f90 +++ b/src/calculator/hr_utils.f90 @@ -14,7 +14,7 @@ module hr_utils subroutine initialize_hessian(calc,type,xyz,nat,at,hess,hguess,pr) !>Matrix is forced to be positive definite type(calcdata),intent(inout) :: calc - type(calcdata) :: newcalc + type(calcdata),allocatable :: newcalc type(calculation_settings) :: clevel type(mhparam) :: mhset integer :: k,i,j,idx,io, nat3 @@ -31,8 +31,13 @@ subroutine initialize_hessian(calc,type,xyz,nat,at,hess,hguess,pr) !>Matrix is f nat3 = 3*nat + !!$omp critical + !allocate (pmode(nat3,1)) ! dummy allocated + !!$omp end critical + !$omp critical - allocate (pmode(nat3,1)) ! dummy allocated + allocate(newcalc) + allocate(hess_full(nat3,nat3),source=0.0_wp) !$omp end critical select case (type) @@ -53,27 +58,31 @@ subroutine initialize_hessian(calc,type,xyz,nat,at,hess,hguess,pr) !>Matrix is f write(stdout,*) "No hguess provided" endif case(1) - allocate(hess_full(nat3,nat3),source=0.0_wp) + !$omp critical call clevel%create('gfnff', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? call newcalc%add(clevel) + !$omp end critical call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) call dsqtoh(nat3,hess_full(:,:),hess(:)) !>Pack Hessian case(2) - allocate(hess_full(nat3,nat3),source=0.0_wp) + !$omp critical call clevel%create('gfn0', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? call newcalc%add(clevel) + !$omp end critical call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) call dsqtoh(nat3,hess_full(:,:),hess(:)) case(3) - allocate(hess_full(nat3,nat3),source=0.0_wp) + !$omp critical call clevel%create('gfn1', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? call newcalc%add(clevel) + !$omp end critical call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) call dsqtoh(nat3,hess_full(:,:),hess(:)) case(4) - allocate(hess_full(nat3,nat3),source=0.0_wp) + !$omp critical call clevel%create('gfn2', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? call newcalc%add(clevel) + !$omp end critical call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) call dsqtoh(nat3,hess_full(:,:),hess(:)) case(5) From 0495169ef01cf81268d68dd99c3a1a7a342edea3 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 4 Feb 2026 23:15:38 +0100 Subject: [PATCH 157/374] Work on required CREGEN refactor 1 --- src/legacy_algos/cregen_old.f90 | 20 --- src/sorting/CMakeLists.txt | 2 + src/sorting/cregen.f90 | 227 ++++++++++++-------------------- src/sorting/meson.build | 2 + 4 files changed, 88 insertions(+), 163 deletions(-) diff --git a/src/legacy_algos/cregen_old.f90 b/src/legacy_algos/cregen_old.f90 index 5d788bae..df3efb3d 100644 --- a/src/legacy_algos/cregen_old.f90 +++ b/src/legacy_algos/cregen_old.f90 @@ -1367,26 +1367,6 @@ subroutine compare(n,nall,s1,s2,dist,athr,relat) end subroutine compare -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -logical function distcheck(n,xyz) - implicit none - real*8,allocatable :: rij(:) - integer :: n - real*8 :: xyz(3,n) - integer i,j - distcheck=.true. - allocate(rij(3)) - do i=1,n-1 - do j=i+1,n - rij=xyz(:,j)-xyz(:,i) - if(sum(rij*rij).lt.1.d-3) distcheck=.false. - enddo - enddo - deallocate(rij) - return -end function distcheck - !==========================================================! ! bactrack is used to find the element "val" of array "arr" diff --git a/src/sorting/CMakeLists.txt b/src/sorting/CMakeLists.txt index c4f3ac04..57107db4 100644 --- a/src/sorting/CMakeLists.txt +++ b/src/sorting/CMakeLists.txt @@ -19,7 +19,9 @@ set(dir "${CMAKE_CURRENT_SOURCE_DIR}") list(APPEND srcs "${dir}/canonical.f90" "${dir}/ccegen.f90" + "${dir}/cregen_interfaces.f90" "${dir}/cregen.f90" + "${dir}/cregen_utils.f90" "${dir}/ensemblecomp.f90" "${dir}/hungarian.f90" "${dir}/irmsd_module.f90" diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 8f9f978f..739282ae 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -32,52 +32,6 @@ !=========================================================================================! !=========================================================================================! -module cregen_interface -!******************************************************* -!* module to load an interface to the newcregen routine -!* mandatory to handle the optional input arguments -!******************************************************* - use unionize_module - implicit none - interface - subroutine newcregen(env,quickset,infile) - use crest_parameters - use crest_data - use crest_restartlog - use strucrd - implicit none - type(systemdata),intent(inout) :: env - integer,intent(in),optional :: quickset - character(len=*),intent(in),optional :: infile - end subroutine newcregen - - subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) - use strucrd - implicit none - !> INPUT - integer,intent(in) :: nall - type(coord),intent(inout),target :: structures(nall) - integer,intent(in),optional :: printlvl - integer,intent(in),optional :: iinversion - end subroutine cregen_irmsd_all - - subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) - use crest_data - use strucrd - implicit none - !> INPUT - type(systemdata),intent(inout) :: env - integer,intent(in) :: nall - type(coord),intent(inout),target :: structures(nall) - integer,intent(inout) :: groups(nall) - logical,intent(in),optional :: allcanon - integer,intent(in),optional :: printlvl - end subroutine cregen_irmsd_sort - - end interface -!>--- Additional Related RE-EXPORTS - public :: unionizeEnsembles -end module cregen_interface subroutine newcregen(env,quickset,infile) !**************************** @@ -87,6 +41,7 @@ subroutine newcregen(env,quickset,infile) use crest_data use crest_restartlog use strucrd + use cregen_subroutines implicit none !> INPUT type(systemdata),intent(inout) :: env !> MAIN STORAGE OS SYSTEM DATA @@ -187,28 +142,23 @@ subroutine newcregen(env,quickset,infile) if (pr1) call cregen_pr1(prch,env,nat,nallref,rthr,bthr,pthr,ewin) !>--- allocate space and read in the ensemble - allocate (at(nat),comments(nallref),xyz(3,nat,nallref)) - call rdensemble(fname,nat,nallref,at,xyz,comments) - !call rdensemble(fname,nallref,structures) + !allocate (at(nat),comments(nallref),xyz(3,nat,nallref)) + !call rdensemble(fname,nat,nallref,at,xyz,comments) + call rdensemble(fname,nallref,structures) !allocate(references, source=structures) !>--- track ensemble for restart - call trackensemble(fname,nat,nallref,at,xyz,comments) + !call trackensemble(fname,nat,nallref,at,xyz,comments) !>--- check if the ensemble contains broken structures? i.e., fusion or dissociation if (checkbroken) then - call discardbroken(prch,env,topocheck,nat,nallref,at,xyz,comments,nall) -!>--- if structures were discarded, resize xyz - if (nall .lt. nallref) then - xyzref = xyz(:,:,1:nall) - call move_alloc(xyzref,xyz) - comref = comments(1:nall) - call move_alloc(comref,comments) - end if + call discardbroken(prch,env,topocheck,structures,nall) else nall = nallref end if + stop + !>--- compare neighbourlists to sort out chemically transformed structures if (topocheck) then call cregen_topocheck(prch,env,checkez,nat,nall,at,xyz,comments,nallnew) @@ -273,7 +223,7 @@ subroutine newcregen(env,quickset,infile) ng = nall if (ng > 0) then allocate (degen(3,ng)) - do i = 1, ng + do i = 1,ng degen(1,i) = 1 degen(2,i) = i degen(3,i) = i @@ -638,13 +588,11 @@ subroutine cregen_groupinfo(nall,ng,group,degen) !* subroutine cregen_groupinfo !* get info about each conformer group and save it to "degen" !************************************************************* - use crest_parameters implicit none integer :: nall,ng integer :: group(0:nall) integer :: degen(3,ng) - integer :: i,j,k - integer :: a,b + integer :: i,j,k,a,b do i = 1,ng a = 0; b = 0; k = 0 do j = 1,nall @@ -667,7 +615,8 @@ end subroutine cregen_groupinfo !=========================================================================================! !=========================================================================================! -subroutine discardbroken(ch,env,topocheck,nat,nall,at,xyz,comments,newnall) +!subroutine discardbroken(ch,env,topocheck,nat,nall,at,xyz,comments,newnall) +subroutine discardbroken(ch,env,topocheck,structures,newnall) !************************************************** !* subroutine discardbroken !* analyze an ensemble and track broken structures @@ -676,123 +625,115 @@ subroutine discardbroken(ch,env,topocheck,nat,nall,at,xyz,comments,newnall) use crest_parameters use crest_data use strucrd - use miscdata,only:rcov - use quicksort_interface + use adjacency + use cregen_utils implicit none !> INPUT - type(systemdata) :: env ! MAIN STORAGE OS SYSTEM DATA + type(systemdata),intent(in) :: env ! MAIN STORAGE OS SYSTEM DATA integer,intent(in) :: ch ! printout channel - integer,intent(in) :: nat,nall - integer,intent(in) :: at(nat) logical,intent(in) :: topocheck - !> OUTPUT - real(wp),intent(inout) :: xyz(3,nat,nall) - character(len=*),intent(inout) :: comments(nall) + type(coord),intent(inout),allocatable,target :: structures(:) integer,intent(out) :: newnall !> LOCAL - integer :: llan + integer :: llan,nall integer,allocatable :: order(:),orderref(:) integer :: nat0 real(wp),allocatable :: cref(:,:),c0(:,:),c1(:,:) integer,allocatable :: at0(:),atdum(:) real(wp),allocatable :: cn(:),bond(:,:) + integer,allocatable :: ibond(:,:),ifrag(:) integer :: frag,frag0 real(wp) :: erj - integer :: j + integer :: ii,jj logical :: substruc - logical :: distok,distcheck real(wp) :: cnorm - logical :: dissoc + logical :: dissoc,distok,distok2 + logical,allocatable :: broke(:) + type(coord) :: mol0 + type(coord),pointer :: mol + type(coord),allocatable :: tmpstructures(:) - !>--- if we don't wish to include all atoms: - substruc = (nat .ne. env%rednat.and.env%subRMSD) - - !>--- read the reference structure - allocate (cref(3,nat),atdum(nat)) - call rdcoord('coord',nat,atdum,cref) - !>--- check fragements - allocate (bond(nat,nat),cn(nat),source=0.0_wp) - call mreclm(frag0,nat,at,cref,atdum,bond,rcov,cn) - deallocate (bond,cn) + logical,external :: distcheck + !>--- if we don't wish to include all atoms: + substruc = (structures(1)%nat .ne. env%rednat.and.env%subRMSD) + nall = size(structures,1) + !> Check fragments + call env%ref%to(mol0) + call cregen_calculate_fragments(mol0,nfrag=frag0) write (ch,'('' # fragment in coord :'',i6)') frag0 - deallocate (atdum) - if (substruc) then - nat0 = env%rednat - allocate (c0(3,nat0),at0(nat0),c1(3,nat0),atdum(nat0)) - call maskedxyz(nat,nat0,cref,c0,at,at0,env%includeRMSD) - else - allocate (c0(3,nat),at0(nat),c1(3,nat),atdum(nat)) - c0 = cref - at0 = at - nat0 = nat - end if - !>--- fragments for actual reference - allocate (bond(nat0,nat0),cn(nat0)) - call mreclm(frag0,nat0,at0,c0,atdum,bond,rcov,cn) - allocate (order(nall),orderref(nall)) !>--- loop over the structures + allocate (broke(nall),source=.false.) newnall = 0 llan = nall - do j = 1,nall - erj = grepenergy(comments(j)) !> get energy of structure j - if (.not.substruc) then - c1(:,:) = xyz(:,:,j)/bohr - else - call maskedxyz(nat,nat0,xyz(:,:,j),c1,at,at0,env%includeRMSD) - c1 = c1/bohr - end if - distok = distcheck(nat0,c1) !> distance check - cnorm = sum(abs(c1)) !> clash check + do ii = 1,nall + mol => structures(ii) + erj = mol%energy + !if (substruc) then + ! !... + !end if + + !>--- close contact checks + cnorm = sum(abs(mol%xyz)) !> clash check + distok = distcheck(mol%nat,mol%xyz) !> distance check + distok2 = (cnorm .gt. 1.0d-6) !>--- further checks: dissociation? dissoc = .false. - if (abs(erj) .gt. 1.0d-6.and.cnorm .gt. 1.0d-6 & - & .and.distok.and.topocheck) then - dissoc = .false. - call mreclm(frag,nat0,at0,c1,atdum,bond,rcov,cn) - if (frag .gt. frag0) then - dissoc = .true. - end if + if (abs(erj) .gt. 1.0d-6.and. & + & distok.and.distok2.and.topocheck) then + call cregen_calculate_fragments(mol,nfrag=frag) + dissoc = (frag .gt. frag0) end if - if (dissoc.or.(cnorm .lt. 1.0d-6).or.(.not.distok)) then + if (dissoc.or.(.not.distok).or.(.not.distok2)) then !>--- move broken structures to the end of the matrix - orderref(j) = llan - llan = llan-1 - !write(ch,*) 'removing structure',j + broke(ii) = .true. + !write(ch,*) 'removing structure',ii else newnall = newnall+1 - orderref(j) = newnall end if end do !>--- sort the xyz array (only if structures have been discarded) if (newnall .lt. nall) then - order = orderref - call xyzqsort(nat,nall,xyz,c0,order,1,nall) - order = orderref - !call stringqsort(nall,comments,1,nall,order) - call stringqsort(nall,len(comments(1)),comments,1,nall,order) - + allocate (tmpstructures(newnall)) + jj = 0 + do ii = 1,nall + if (.not.broke(ii)) then + jj = jj+1 + tmpstructures(jj) = structures(ii) + end if + end do + call move_alloc(tmpstructures,structures) llan = nall-newnall write (ch,'('' number of removed clashes :'',i6)') llan end if !>--- otherwise the ensemble is ok - - if (allocated(orderref)) deallocate (orderref) - if (allocated(order)) deallocate (order) - if (allocated(cn)) deallocate (cn) - if (allocated(bond)) deallocate (bond) - if (allocated(atdum)) deallocate (atdum) - if (allocated(c1)) deallocate (c1) - if (allocated(at0)) deallocate (at0) - if (allocated(c0)) deallocate (c0) - if (allocated(cref)) deallocate (cref) return end subroutine discardbroken +logical function distcheck(n,xyz) + use crest_parameters,only:wp + implicit none + integer,intent(in) :: n + real(wp),intent(in) :: xyz(3,n) + real(wp) :: rij(3) + integer :: i,j + distcheck = .true. + do i = 1,n-1 + do j = i+1,n + rij = xyz(:,j)-xyz(:,i) + if (sum(rij*rij) .lt. 1.d-3) then + distcheck = .false. + return + end if + end do + end do + return +end function distcheck + !=========================================================================================! subroutine cregen_topocheck(ch,env,checkez,nat,nall,at,xyz,comments,newnall) @@ -1802,13 +1743,13 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) write (stdout,'(2x,a,i9)') 'OpenMP threads :',T write (stdout,'(2x,a,a9)') 'Individual atom IDs? :',to_str(individual_IDs) write (stdout,'(2x,a)',advance='no') 'False rotamer check? :' - select case(env%iinversion) + select case (env%iinversion) case (0) - write(stdout,'(a9)') 'auto' + write (stdout,'(a9)') 'auto' case (1) - write(stdout,'(a9)') 'on' + write (stdout,'(a9)') 'on' case (2) - write(stdout,'(a9)') 'off' + write (stdout,'(a9)') 'off' end select write (stdout,*) end if @@ -2633,7 +2574,7 @@ subroutine cregen_conffile(env,cname,nat,nall,at,xyz,comments,ng,degen) open (newunit=ich,file=trim(cname)) do i = 1,ng k = degen(2,i) - if (k <= 0 .or. k > nall) cycle + if (k <= 0.or.k > nall) cycle if (i .eq. 1.or.env%printscoords) then !write a scoord.* for each conformer? scoord.1 is always written call getname1(i,newcomment) c0(:,:) = xyz(:,:,k)/bohr diff --git a/src/sorting/meson.build b/src/sorting/meson.build index bda805ab..a74f7911 100644 --- a/src/sorting/meson.build +++ b/src/sorting/meson.build @@ -17,7 +17,9 @@ srcs += files( 'canonical.f90', 'ccegen.f90', + 'cregen_interfaces.f90', 'cregen.f90', + 'cregen_utils.f90', 'ensemblecomp.f90', 'hungarian.f90', 'irmsd_module.f90', From 92c59a13653bcf0147f48d1e16438b0fb762f04b Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 5 Feb 2026 12:39:47 +0100 Subject: [PATCH 158/374] Work on required CREGEN refactor 2 --- src/legacy_algos/cregen_old.f90 | 3 +- src/sorting/cregen.f90 | 167 +----------------- src/sorting/cregen_interfaces.f90 | 79 +++++++++ src/sorting/cregen_utils.f90 | 280 ++++++++++++++++++++++++++++++ src/sorting/ztopology.f90 | 150 +--------------- 5 files changed, 373 insertions(+), 306 deletions(-) create mode 100644 src/sorting/cregen_interfaces.f90 create mode 100644 src/sorting/cregen_utils.f90 diff --git a/src/legacy_algos/cregen_old.f90 b/src/legacy_algos/cregen_old.f90 index df3efb3d..1d01eaa2 100644 --- a/src/legacy_algos/cregen_old.f90 +++ b/src/legacy_algos/cregen_old.f90 @@ -34,6 +34,7 @@ subroutine cregen2(env) use utilities use omp_lib use crest_cn_module + use cregen_utils, only: distcheck implicit none type(systemdata) :: env ! MAIN STORAGE OS SYSTEM DATA @@ -81,7 +82,7 @@ subroutine cregen2(env) logical :: fail logical :: substruc logical :: ttag - logical, external :: distcheck,equalrot,equalrotall + logical, external :: equalrot,equalrotall settingNames: associate( crestver => env%crestver, confgo => env%confgo, & & methautocorr => env%methautocorr, printscoords => env%printscoords, & diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 739282ae..c4680c9e 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -32,7 +32,6 @@ !=========================================================================================! !=========================================================================================! - subroutine newcregen(env,quickset,infile) !**************************** !* The main CREGEN routine @@ -615,7 +614,6 @@ end subroutine cregen_groupinfo !=========================================================================================! !=========================================================================================! -!subroutine discardbroken(ch,env,topocheck,nat,nall,at,xyz,comments,newnall) subroutine discardbroken(ch,env,topocheck,structures,newnall) !************************************************** !* subroutine discardbroken @@ -635,26 +633,16 @@ subroutine discardbroken(ch,env,topocheck,structures,newnall) type(coord),intent(inout),allocatable,target :: structures(:) integer,intent(out) :: newnall !> LOCAL - integer :: llan,nall - integer,allocatable :: order(:),orderref(:) - integer :: nat0 - real(wp),allocatable :: cref(:,:),c0(:,:),c1(:,:) - integer,allocatable :: at0(:),atdum(:) - real(wp),allocatable :: cn(:),bond(:,:) - integer,allocatable :: ibond(:,:),ifrag(:) - integer :: frag,frag0 - real(wp) :: erj + integer :: llan,nall,frag,frag0 + real(wp) :: erj,cnorm integer :: ii,jj logical :: substruc - real(wp) :: cnorm logical :: dissoc,distok,distok2 logical,allocatable :: broke(:) type(coord) :: mol0 type(coord),pointer :: mol type(coord),allocatable :: tmpstructures(:) - logical,external :: distcheck - !>--- if we don't wish to include all atoms: substruc = (structures(1)%nat .ne. env%rednat.and.env%subRMSD) nall = size(structures,1) @@ -711,29 +699,10 @@ subroutine discardbroken(ch,env,topocheck,structures,newnall) write (ch,'('' number of removed clashes :'',i6)') llan end if !>--- otherwise the ensemble is ok + if (allocated(broke)) deallocate (broke) return end subroutine discardbroken -logical function distcheck(n,xyz) - use crest_parameters,only:wp - implicit none - integer,intent(in) :: n - real(wp),intent(in) :: xyz(3,n) - real(wp) :: rij(3) - integer :: i,j - distcheck = .true. - do i = 1,n-1 - do j = i+1,n - rij = xyz(:,j)-xyz(:,i) - if (sum(rij*rij) .lt. 1.d-3) then - distcheck = .false. - return - end if - end do - end do - return -end function distcheck - !=========================================================================================! subroutine cregen_topocheck(ch,env,checkez,nat,nall,at,xyz,comments,newnall) @@ -749,6 +718,7 @@ subroutine cregen_topocheck(ch,env,checkez,nat,nall,at,xyz,comments,newnall) use utilities use crest_cn_module use quicksort_interface + use cregen_utils implicit none type(systemdata) :: env ! MAIN STORAGE OS SYSTEM DATA integer,intent(in) :: ch ! printout channel @@ -789,7 +759,7 @@ subroutine cregen_topocheck(ch,env,checkez,nat,nall,at,xyz,comments,newnall) call calc_ncoord(nat,atdum,cref,rcov,cn,400.0_wp,bond) if (allocated(env%excludeTOPO)) then - call bondtotopo_excl(nat,at,bond,cn,ntopo,toporef,neighmat,env%excludeTOPO) + call bondtotopo(nat,at,bond,cn,ntopo,toporef,neighmat,excl=env%excludeTOPO) else call bondtotopo(nat,at,bond,cn,ntopo,toporef,neighmat) end if @@ -826,7 +796,7 @@ subroutine cregen_topocheck(ch,env,checkez,nat,nall,at,xyz,comments,newnall) bond = 0.0d0 call calc_ncoord(nat,at,c1,rcov,cn,400.0_wp,bond) if (allocated(env%excludeTOPO)) then - call bondtotopo_excl(nat,at,bond,cn,ntopo,topo,neighmat,env%excludeTOPO) + call bondtotopo(nat,at,bond,cn,ntopo,topo,neighmat,excl=env%excludeTOPO) else call bondtotopo(nat,at,bond,cn,ntopo,topo,neighmat) end if @@ -892,131 +862,6 @@ subroutine cregen_topocheck(ch,env,checkez,nat,nall,at,xyz,comments,newnall) deallocate (atdum) deallocate (cref) return - -contains - subroutine nezcc(nat,at,xyz,cn,ntopo,topo,ncc) - !*************************************************** - !* Check how many (potential) C=C bonds are present - !*************************************************** - use crest_parameters - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - real(wp),intent(in) :: xyz(3,nat) - real(wp),intent(in) :: cn(nat) - integer,intent(in) :: ntopo - integer,intent(in) :: topo(ntopo) - integer,intent(out) :: ncc - real(wp) :: dist - integer :: l - integer :: ci,cj - real(wp),parameter :: distcc = 1.384_wp - ncc = 0 - do ci = 1,nat - do cj = 1,ci-1 - if (ci == cj) cycle - l = lin(ci,cj) - if (topo(l) == 0) cycle - if (at(ci) == 6.and.at(cj) == 6.and. & - & nint(cn(ci)) == 3.and.nint(cn(cj)) == 3) then - dist = (xyz(1,ci)-xyz(1,cj))**2+ & - & (xyz(2,ci)-xyz(2,cj))**2+ & - & (xyz(3,ci)-xyz(3,cj))**2 - dist = sqrt(dist) - if (dist < distcc) then - ncc = ncc+1 - end if - end if - end do - end do - return - end subroutine nezcc - subroutine ezccat(nat,at,xyz,cn,ntopo,topo,ncc,ezat) - !******************************************************** - !* Check which atoms can be used for C=C dihedral angles - !******************************************************** - use crest_parameters - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - real(wp),intent(in) :: xyz(3,nat) - real(wp),intent(in) :: cn(nat) - integer,intent(in) :: ntopo - integer,intent(in) :: topo(ntopo) - integer,intent(in) :: ncc - integer,intent(out) :: ezat(4,ncc) - real(wp) :: dist - integer :: i,j,k,l - integer :: ci,cj - real(wp),parameter :: distcc = 1.384_wp - if (ncc < 1) return - k = 0 - do ci = 1,nat - do cj = 1,ci-1 - if (ci == cj) cycle - l = lin(ci,cj) - if (topo(l) == 0) cycle - if (at(ci) == 6.and.at(cj) == 6.and. & - & nint(cn(ci)) == 3.and.nint(cn(cj)) == 3) then - dist = (xyz(1,ci)-xyz(1,cj))**2+ & - & (xyz(2,ci)-xyz(2,cj))**2+ & - & (xyz(3,ci)-xyz(3,cj))**2 - dist = sqrt(dist) - if (dist < distcc) then - k = k+1 - ezat(2,k) = ci - ezat(3,k) = cj - !>-- get a neighbour for ci - do i = 1,nat - if (i == cj.or.i == ci) cycle - l = lin(ci,i) - if (topo(l) == 1) then - ezat(1,k) = i - exit - end if - end do - !>-- get a neighbour for cj - do j = 1,nat - if (j == cj.or.j == ci) cycle - l = lin(cj,j) - if (topo(l) == 1) then - ezat(4,k) = j - exit - end if - end do - end if - end if - end do - end do - return - end subroutine ezccat - subroutine ezccdihed(nat,xyz,ncc,ezat,ezdihed) - !******************************************************** - !* Check which atoms can be used for C=C dihedral angles - !******************************************************** - use crest_parameters - integer,intent(in) :: nat - real(wp),intent(in) :: xyz(3,nat) - integer,intent(in) :: ncc - integer,intent(in) :: ezat(4,ncc) - real(wp),intent(out) :: ezdihed(ncc) - integer :: i,k - integer :: a,b,c,d - real(wp) :: winkel - if (ncc < 1) return - k = 0 - do i = 1,ncc - a = ezat(1,i) - b = ezat(2,i) - c = ezat(3,i) - d = ezat(4,i) - call DIHED(xyz,a,b,c,d,winkel) !>-- from intmodes.f - winkel = abs(winkel*(180.0_wp/pi)) - if (winkel > 180.0_wp) then - winkel = 360.0_wp-winkel - end if - ezdihed(i) = winkel - end do - return - end subroutine ezccdihed end subroutine cregen_topocheck !=========================================================================================! diff --git a/src/sorting/cregen_interfaces.f90 b/src/sorting/cregen_interfaces.f90 new file mode 100644 index 00000000..1b58279a --- /dev/null +++ b/src/sorting/cregen_interfaces.f90 @@ -0,0 +1,79 @@ + +!=========================================================================================! +!=========================================================================================! +!> Interfaces for use CREGEN (and related) +!=========================================================================================! +!=========================================================================================! + +module cregen_interface +!******************************************************* +!* module to load an interface to the newcregen routine +!* mandatory to handle the optional input arguments +!******************************************************* + use unionize_module + implicit none + interface + subroutine newcregen(env,quickset,infile) + use crest_parameters + use crest_data + use crest_restartlog + use strucrd + implicit none + type(systemdata),intent(inout) :: env + integer,intent(in),optional :: quickset + character(len=*),intent(in),optional :: infile + end subroutine newcregen + + subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) + use strucrd + implicit none + !> INPUT + integer,intent(in) :: nall + type(coord),intent(inout),target :: structures(nall) + integer,intent(in),optional :: printlvl + integer,intent(in),optional :: iinversion + end subroutine cregen_irmsd_all + + subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) + use crest_data + use strucrd + implicit none + !> INPUT + type(systemdata),intent(inout) :: env + integer,intent(in) :: nall + type(coord),intent(inout),target :: structures(nall) + integer,intent(inout) :: groups(nall) + logical,intent(in),optional :: allcanon + integer,intent(in),optional :: printlvl + end subroutine cregen_irmsd_sort + + end interface +!>--- Additional Related RE-EXPORTS + public :: unionizeEnsembles +end module cregen_interface + +!=========================================================================================! +!=========================================================================================! +!> Interfaces for routines used WITHIN CREGEN +!=========================================================================================! +!=========================================================================================! + +module cregen_subroutines +!************************************* +!* interfaces for cregen subroutines +!************************************* + implicit none + interface + subroutine discardbroken(ch,env,topocheck,structures,newnall) + use crest_data + use strucrd + use cregen_utils + type(systemdata),intent(in) :: env + integer,intent(in) :: ch + logical,intent(in) :: topocheck + type(coord),intent(inout),allocatable,target :: structures(:) + integer,intent(out) :: newnall + end subroutine discardbroken + + end interface +end module cregen_subroutines diff --git a/src/sorting/cregen_utils.f90 b/src/sorting/cregen_utils.f90 new file mode 100644 index 00000000..6b7fe8a8 --- /dev/null +++ b/src/sorting/cregen_utils.f90 @@ -0,0 +1,280 @@ + +module cregen_utils +!***************************************** +!* Module that implements a utility routines +!* mainly used in CREGEN +!***************************************** + use crest_parameters + use strucrd + use adjacency + use axis_module + use internals_mod + use utilities + implicit none + public + + real(wp),parameter :: bigval = huge(bigval) + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + subroutine cregen_calculate_fragments(mol,frag,nfrag) +!******************************************************* +!* Assign each atom in a molecule to a fragment +!* based on CN connectivity +!* The fragment assignment array and the total number +!* of fragments are both optional return arguments +!******************************************************* + class(coord),intent(in) :: mol + integer,intent(out),allocatable,optional :: frag(:) + integer,intent(out),optional :: nfrag + integer,allocatable :: tmp(:),A(:,:) + real(wp),allocatable :: cn(:),bond(:,:) + integer :: nat + + call mol%cn_to_bond(cn,bond) + nat = mol%nat + allocate (A(nat,nat),source=0) + call wbo2adjacency(mol%nat,bond,A,0.01_wp) + call setup_fragments(mol%nat,A,tmp) + if (present(nfrag)) then + nfrag = maxval(tmp,1) + end if + if (present(frag)) then + call move_alloc(tmp,frag) + end if + end subroutine cregen_calculate_fragments + + logical function distcheck(n,xyz) + integer,intent(in) :: n + real(wp),intent(in) :: xyz(3,n) + real(wp) :: rij(3) + integer :: i,j + distcheck = .true. + do i = 1,n-1 + do j = i+1,n + rij = xyz(:,j)-xyz(:,i) + if (sum(rij*rij) .lt. 1.d-3) then + distcheck = .false. + return + end if + end do + end do + return + end function distcheck + +!================================================================================! +!================================================================================! +!> Simplified "topology"-related routines +!================================================================================! +!================================================================================! + + subroutine bondtotopo(nat,at,bond,cn,ntopo,topo,neighbourmat,excl) + !******************************************************************** + !* generate the topo array for a given structure + !* This includes some empirical hacks for use in CREGEN + !******************************************************************** + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(inout) :: bond(nat,nat) + real(wp),intent(in) :: cn(nat) + integer,intent(inout) :: ntopo + integer,intent(inout),allocatable :: topo(:) + real(wp),allocatable :: cn2(:) + logical,intent(inout),allocatable :: neighbourmat(:,:) + logical,intent(in),optional :: excl(nat) + integer :: i,j,k,l + integer :: icn + real(wp) :: rcn + + ntopo = nat*(nat+1)/2 + if (.not.allocated(topo)) allocate (topo(ntopo),source=0) + if (.not.allocated(neighbourmat)) allocate (neighbourmat(nat,nat)) + allocate (cn2(nat),source=0.0_wp) + topo(1:ntopo) = 0 + neighbourmat(:,:) = .false. + + !--- some heuristic rules and CN array setup + do i = 1,nat + cn2(i) = cn(i) + rcn = real(floor(cn(i)),wp) + select case (at(i)) !additional empirical topology rules + ! case( 5 ) !B + ! if( nint(cn(i)) > 4) cn2(i)=4.0_wp + ! case( 9,17,35,53 ) !F,Cl,Br,I + ! cn2(i) = min(cn(i),1.0_wp) + case (6) !C + if ((cn(i)-rcn) < 0.7_wp) then + cn2(i) = rcn + end if + end select + !-- extreme CN cases + if (nint(cn(i)) > 8) cn2(i) = 8.0_wp + !empirical: rounding down up to .6 is better for topo setup + if ((cn(i)-rcn) < 0.6_wp) then + cn2(i) = rcn + end if + end do + !--- build the topology + do i = 1,nat + icn = nint(cn2(i)) + do k = 1,icn + j = maxloc(bond(:,i),1) + bond(j,i) = 0.0d0 + if (i .eq. j) cycle + neighbourmat(i,j) = .true. !--important: not automatically (i,j)=(j,i) + if (present(excl)) then + if (excl(i).or.excl(j)) neighbourmat(i,j) = .false. + end if + end do + end do + do i = 1,nat + do j = 1,nat + if (i == j) cycle + l = lin(i,j) + !-- only save matching topology --> prevent high CN failures + if (neighbourmat(i,j).and.neighbourmat(j,i)) then + topo(l) = 1 + else + ! special case for carbon (because the carbon CN is typically correct) + ! this helps, e.g. with eta-coordination in ferrocene + ! (used, except if both are carbon) + if (.not. (at(i) == 6.and.at(j) == 6)) then + if (at(i) == 6.and.neighbourmat(i,j)) topo(l) = 1 + if (at(j) == 6.and.neighbourmat(j,i)) topo(l) = 1 + end if + end if + end do + end do + deallocate (cn2) + return + end subroutine bondtotopo + + subroutine nezcc(nat,at,xyz,cn,ntopo,topo,ncc) + !*************************************************** + !* Check how many (potential) C=C bonds are present + !*************************************************** + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(in) :: xyz(3,nat) + real(wp),intent(in) :: cn(nat) + integer,intent(in) :: ntopo + integer,intent(in) :: topo(ntopo) + integer,intent(out) :: ncc + real(wp) :: dist + integer :: l + integer :: ci,cj + real(wp),parameter :: distcc = 1.384_wp + ncc = 0 + do ci = 1,nat + do cj = 1,ci-1 + if (ci == cj) cycle + l = lin(ci,cj) + if (topo(l) == 0) cycle + if (at(ci) == 6.and.at(cj) == 6.and. & + & nint(cn(ci)) == 3.and.nint(cn(cj)) == 3) then + dist = (xyz(1,ci)-xyz(1,cj))**2+ & + & (xyz(2,ci)-xyz(2,cj))**2+ & + & (xyz(3,ci)-xyz(3,cj))**2 + dist = sqrt(dist) + if (dist < distcc) then + ncc = ncc+1 + end if + end if + end do + end do + return + end subroutine nezcc + subroutine ezccat(nat,at,xyz,cn,ntopo,topo,ncc,ezat) + !******************************************************** + !* Check which atoms can be used for C=C dihedral angles + !******************************************************** + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(in) :: xyz(3,nat) + real(wp),intent(in) :: cn(nat) + integer,intent(in) :: ntopo + integer,intent(in) :: topo(ntopo) + integer,intent(in) :: ncc + integer,intent(out) :: ezat(4,ncc) + real(wp) :: dist + integer :: i,j,k,l + integer :: ci,cj + real(wp),parameter :: distcc = 1.384_wp + if (ncc < 1) return + k = 0 + do ci = 1,nat + do cj = 1,ci-1 + if (ci == cj) cycle + l = lin(ci,cj) + if (topo(l) == 0) cycle + if (at(ci) == 6.and.at(cj) == 6.and. & + & nint(cn(ci)) == 3.and.nint(cn(cj)) == 3) then + dist = (xyz(1,ci)-xyz(1,cj))**2+ & + & (xyz(2,ci)-xyz(2,cj))**2+ & + & (xyz(3,ci)-xyz(3,cj))**2 + dist = sqrt(dist) + if (dist < distcc) then + k = k+1 + ezat(2,k) = ci + ezat(3,k) = cj + !>-- get a neighbour for ci + do i = 1,nat + if (i == cj.or.i == ci) cycle + l = lin(ci,i) + if (topo(l) == 1) then + ezat(1,k) = i + exit + end if + end do + !>-- get a neighbour for cj + do j = 1,nat + if (j == cj.or.j == ci) cycle + l = lin(cj,j) + if (topo(l) == 1) then + ezat(4,k) = j + exit + end if + end do + end if + end if + end do + end do + return + end subroutine ezccat + subroutine ezccdihed(nat,xyz,ncc,ezat,ezdihed) + !******************************************************** + !* Check which atoms can be used for C=C dihedral angles + !******************************************************** + integer,intent(in) :: nat + real(wp),intent(in) :: xyz(3,nat) + integer,intent(in) :: ncc + integer,intent(in) :: ezat(4,ncc) + real(wp),intent(out) :: ezdihed(ncc) + integer :: i,k + integer :: a,b,c,d + real(wp) :: winkel + if (ncc < 1) return + k = 0 + do i = 1,ncc + a = ezat(1,i) + b = ezat(2,i) + c = ezat(3,i) + d = ezat(4,i) + call DIHED2(xyz,a,b,c,d,winkel) !>-- from intmodes.f + winkel = abs(winkel*(180.0_wp/pi)) + if (winkel > 180.0_wp) then + winkel = 360.0_wp-winkel + end if + ezdihed(i) = winkel + end do + return + end subroutine ezccdihed + +!========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< generate the topo array for a given structure -!===================================================! -subroutine bondtotopo(nat,at,bond,cn,ntopo,topo,neighbourmat) - use iso_fortran_env,only:wp => real64 - use utilities - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - real(wp),intent(inout) :: bond(nat,nat) - real(wp),intent(in) :: cn(nat) - integer,intent(in) :: ntopo - integer,intent(out) :: topo(ntopo) - real(wp),allocatable :: cn2(:) - logical,intent(inout) :: neighbourmat(nat,nat) - integer :: i,j,k,l - integer :: icn,rcn - allocate (cn2(nat),source=0.0_wp) - topo = 0 - neighbourmat = .false. - !>--- some heuristic rules and CN array setup - do i = 1,nat - cn2(i) = cn(i) - rcn = floor(cn(i)) - select case (at(i)) !additional empirical topology rules - ! case( 5 ) !B - ! if( nint(cn(i)) > 4) cn2(i)=4.0_wp - ! case( 9,17,35,53 ) !F,Cl,Br,I - ! cn2(i) = min(cn(i),1.0_wp) - case (6) !C - if ((cn(i)-rcn) < 0.7_wp) then - cn2(i) = rcn - end if - end select - !-- extreme CN cases - if (nint(cn(i)) > 8) cn2(i) = 8.0_wp - !empirical: rounding down up to .6 is better for topo setup - if ((cn(i)-rcn) < 0.6_wp) then - cn2(i) = rcn - end if - end do - !>--- build the topology - do i = 1,nat - icn = nint(cn2(i)) - do k = 1,icn - j = maxloc(bond(:,i),1) - bond(j,i) = 0.0d0 - if (i .eq. j) cycle - neighbourmat(i,j) = .true. !--important: not automatically (i,j)=(j,i) - end do - end do - do i = 1,nat - do j = 1,nat - if (i == j) cycle - l = lin(i,j) - !>-- only save matching topology --> prevent high CN failures - if (neighbourmat(i,j).and.neighbourmat(j,i)) then - topo(l) = 1 - else - !> special case for carbon (because the carbon CN is typically correct) - !> this helps, e.g. with eta-coordination in ferrocene - !> (used, except if both are carbon) - if (.not. (at(i) == 6.and.at(j) == 6)) then - if (at(i) == 6.and.neighbourmat(i,j)) topo(l) = 1 - if (at(j) == 6.and.neighbourmat(j,i)) topo(l) = 1 - end if - end if - end do - end do - deallocate (cn2) - return -end subroutine bondtotopo - -subroutine bondtotopo_excl(nat,at,bond,cn,ntopo,topo,neighbourmat,excl) - use iso_fortran_env,only:wp => real64 - use utilities - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - real(wp),intent(inout) :: bond(nat,nat) - real(wp),intent(in) :: cn(nat) - integer,intent(in) :: ntopo - integer,intent(out) :: topo(ntopo) - real(wp),allocatable :: cn2(:) - logical,intent(inout) :: neighbourmat(nat,nat) - logical,intent(in) :: excl(nat) - integer :: i,j,k,l - integer :: icn,rcn - allocate (cn2(nat),source=0.0_wp) - topo = 0 - neighbourmat = .false. - !--- some heuristic rules and CN array setup - do i = 1,nat - cn2(i) = cn(i) - rcn = floor(cn(i)) - select case (at(i)) !additional empirical topology rules - ! case( 5 ) !B - ! if( nint(cn(i)) > 4) cn2(i)=4.0_wp - ! case( 9,17,35,53 ) !F,Cl,Br,I - ! cn2(i) = min(cn(i),1.0_wp) - case (6) !C - if ((cn(i)-rcn) < 0.7_wp) then - cn2(i) = rcn - end if - end select - !-- extreme CN cases - if (nint(cn(i)) > 8) cn2(i) = 8.0_wp - !empirical: rounding down up to .6 is better for topo setup - if ((cn(i)-rcn) < 0.6_wp) then - cn2(i) = rcn - end if - end do - !--- build the topology - do i = 1,nat - icn = nint(cn2(i)) - do k = 1,icn - j = maxloc(bond(:,i),1) - bond(j,i) = 0.0d0 - if (i .eq. j) cycle - neighbourmat(i,j) = .true. !--important: not automatically (i,j)=(j,i) - if (excl(i).or.excl(j)) neighbourmat(i,j) = .false. - end do - end do - do i = 1,nat - do j = 1,nat - if (i == j) cycle - l = lin(i,j) - !-- only save matching topology --> prevent high CN failures - if (neighbourmat(i,j).and.neighbourmat(j,i)) then - topo(l) = 1 - else - ! special case for carbon (because the carbon CN is typically correct) - ! this helps, e.g. with eta-coordination in ferrocene - ! (used, except if both are carbon) - if (.not. (at(i) == 6.and.at(j) == 6)) then - if (at(i) == 6.and.neighbourmat(i,j)) topo(l) = 1 - if (at(j) == 6.and.neighbourmat(j,i)) topo(l) = 1 - end if - end if - end do - end do - deallocate (cn2) - return -end subroutine bondtotopo_excl subroutine quicktopo(nat,at,xyz,ntopo,topovec) use iso_fortran_env,only:wp => real64 use miscdata,only:rcov use crest_cn_module + use cregen_utils,only:bondtotopo implicit none integer :: nat integer :: at(nat) real(wp) :: xyz(3,nat) !must be in Bohrs integer :: ntopo - integer :: topovec(ntopo) + integer,intent(inout) :: topovec(ntopo) real(wp),allocatable :: cn(:),bond(:,:) logical,allocatable :: neighmat(:,:) + integer,allocatable :: tmp(:) allocate (bond(nat,nat),cn(nat),source=0.0_wp) allocate (neighmat(nat,nat),source=.false.) cn = 0.0d0 bond = 0.0d0 call calc_ncoord(nat,at,xyz,rcov,cn,900.0_wp,bond) - call bondtotopo(nat,at,bond,cn,ntopo,topovec,neighmat) + call bondtotopo(nat,at,bond,cn,ntopo,tmp,neighmat) + topovec(:) = tmp(:) deallocate (neighmat,cn,bond) return end subroutine quicktopo From c2a990a95a3c5ce4326cbcf0dcfda27ab6d7c27c Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 5 Feb 2026 13:25:31 +0100 Subject: [PATCH 159/374] Work on required CREGEN refactor 3 --- src/sorting/cregen.f90 | 123 +++++++++++++----------------- src/sorting/cregen_interfaces.f90 | 31 +++++--- src/sorting/cregen_utils.f90 | 6 +- 3 files changed, 77 insertions(+), 83 deletions(-) diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index c4680c9e..4f549739 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -151,36 +151,23 @@ subroutine newcregen(env,quickset,infile) !>--- check if the ensemble contains broken structures? i.e., fusion or dissociation if (checkbroken) then - call discardbroken(prch,env,topocheck,structures,nall) + call cregen_discardbroken(prch,env,topocheck,structures,nall) else nall = nallref end if - stop - !>--- compare neighbourlists to sort out chemically transformed structures if (topocheck) then - call cregen_topocheck(prch,env,checkez,nat,nall,at,xyz,comments,nallnew) + call cregen_topocheck(prch,env,checkez,structures,nallnew) + nall = nallnew !>--- if structures were discarded, resize xyz - if (nallnew .lt. nall) then -!>-- special fallback if all are discared - if (nallnew == 0) then - call rdcoord('coord',nat,at,xyz(:,:,1)) - xyz = xyz*bohr - write (comments(1),'(f18.8)') env%elowest - nallnew = 1 - end if - nall = nallnew - xyzref = xyz(:,:,1:nall) - call move_alloc(xyzref,xyz) - comref = comments(1:nall) - call move_alloc(comref,comments) - end if end if if (topocheck.or.checkbroken) then write (prch,'('' number of reliable points :'',i6)') nall end if + stop + !>--- sort the ensemble by its energies and make a cut (EWIN) if (sortE) then call cregen_esort(prch,nat,nall,xyz,comments,nallnew,ewin) @@ -614,9 +601,9 @@ end subroutine cregen_groupinfo !=========================================================================================! !=========================================================================================! -subroutine discardbroken(ch,env,topocheck,structures,newnall) +subroutine cregen_discardbroken(ch,env,topocheck,structures,newnall) !************************************************** -!* subroutine discardbroken +!* subroutine cregen_discardbroken !* analyze an ensemble and track broken structures !* to be discarded. !************************************************** @@ -701,11 +688,11 @@ subroutine discardbroken(ch,env,topocheck,structures,newnall) !>--- otherwise the ensemble is ok if (allocated(broke)) deallocate (broke) return -end subroutine discardbroken +end subroutine cregen_discardbroken !=========================================================================================! -subroutine cregen_topocheck(ch,env,checkez,nat,nall,at,xyz,comments,newnall) +subroutine cregen_topocheck(ch,env,checkez,structures,newnall) !************************************************************* !* subroutine cregen_topocheck !* analyze an ensemble and compare topology (neighbourlist) @@ -723,11 +710,9 @@ subroutine cregen_topocheck(ch,env,checkez,nat,nall,at,xyz,comments,newnall) type(systemdata) :: env ! MAIN STORAGE OS SYSTEM DATA integer,intent(in) :: ch ! printout channel logical,intent(in) :: checkez - integer,intent(in) :: nat,nall - integer,intent(in) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat,nall) - character(len=*),intent(inout) :: comments(nall) + type(coord),intent(inout),allocatable,target :: structures(:) integer,intent(out) :: newnall + integer :: nat,nall integer :: llan integer,allocatable :: order(:),orderref(:) real(wp),allocatable :: cref(:,:),c1(:,:) @@ -737,7 +722,7 @@ subroutine cregen_topocheck(ch,env,checkez,nat,nall,at,xyz,comments,newnall) integer,allocatable :: topo(:) logical,allocatable :: neighmat(:,:) integer :: nbonds - integer :: j,l + integer :: ii,jj,l integer :: ntopo,ncc,ccfail logical :: discard integer,allocatable :: ezat(:,:) @@ -745,60 +730,54 @@ subroutine cregen_topocheck(ch,env,checkez,nat,nall,at,xyz,comments,newnall) real(wp),allocatable :: ezdihed(:) real(wp) :: winkeldiff - !>--- read the reference structure - allocate (cref(3,nat),atdum(nat)) - call rdcoord('coord',nat,atdum,cref) - - !>--- get the reference topology matrix (bonds) - ntopo = nat*(nat+1)/2 - allocate (toporef(ntopo),topo(ntopo)) - allocate (neighmat(nat,nat),source=.false.) - allocate (bond(nat,nat),cn(nat),source=0.0_wp) - cn = 0.0d0 - bond = 0.0d0 - call calc_ncoord(nat,atdum,cref,rcov,cn,400.0_wp,bond) + type(coord) :: mol0 + type(coord),pointer :: mol + type(coord),allocatable :: tmpstructures(:) + logical,allocatable :: broke(:) + !>--- read the reference structure + call env%ref%to(mol0) + nat = mol0%nat + nall = size(structures,1) + call mol0%cn_to_bond(cn,bond) + !>--- calculate reference "topology" if (allocated(env%excludeTOPO)) then - call bondtotopo(nat,at,bond,cn,ntopo,toporef,neighmat,excl=env%excludeTOPO) + call bondtotopo(nat,mol0%at,bond,cn,ntopo,toporef,neighmat,excl=env%excludeTOPO) else - call bondtotopo(nat,at,bond,cn,ntopo,toporef,neighmat) + call bondtotopo(nat,mol0%at,bond,cn,ntopo,toporef,neighmat) end if nbonds = sum(toporef) write (ch,'('' # bonds in reference structure :'',i6)') nbonds !>--- if required, check for C=C bonds (based only on structure!) if (checkez) then - cref = cref*bohr - call nezcc(nat,atdum,cref,cn,ntopo,toporef,ncc) + call nezcc(nat,mol0%at,mol0%xyz,cn,ntopo,toporef,ncc) if (ncc > 0) then write (ch,'('' => # of C=C bonds :'',i6)') ncc allocate (ezat(4,ncc)) allocate (ezdihedref(ncc),ezdihed(ncc),source=0.0d0) - call ezccat(nat,atdum,cref,cn,ntopo,toporef,ncc,ezat) - call ezccdihed(nat,cref,ncc,ezat,ezdihedref) + call ezccat(nat,mol0%at,mol0%xyz,cn,ntopo,toporef,ncc,ezat) + call ezccdihed(nat,mol0%xyz,ncc,ezat,ezdihedref) !do i=1,ncc ! write(*,'(1x,a,4i4,a,f6.2)') 'C=C bond atoms:',ezat(1:4,i)," angle: ",ezdihedref(i) !enddo end if end if - allocate (order(nall),orderref(nall)) - allocate (c1(3,nat)) + allocate (broke(nall),source=.false.) !>--- loop over the structures ccfail = 0 newnall = 0 llan = nall - do j = 1,nall - c1(1:3,1:nat) = xyz(1:3,1:nat,j)/bohr + do jj = 1,nall !>--- generate topo and compare discard = .false. - cn = 0.0d0 - bond = 0.0d0 - call calc_ncoord(nat,at,c1,rcov,cn,400.0_wp,bond) + mol => structures(jj) + call mol%cn_to_bond(cn,bond) if (allocated(env%excludeTOPO)) then - call bondtotopo(nat,at,bond,cn,ntopo,topo,neighmat,excl=env%excludeTOPO) + call bondtotopo(mol%nat,mol%at,bond,cn,ntopo,topo,neighmat,excl=env%excludeTOPO) else - call bondtotopo(nat,at,bond,cn,ntopo,topo,neighmat) + call bondtotopo(mol%nat,mol%at,bond,cn,ntopo,topo,neighmat) end if do l = 1,ntopo if (toporef(l) .ne. topo(l)) then @@ -808,8 +787,7 @@ subroutine cregen_topocheck(ch,env,checkez,nat,nall,at,xyz,comments,newnall) end do !>--- get E/Z info of C=C, discard isomers if (checkez.and..not.discard.and.ncc > 0) then - c1 = c1*bohr - call ezccdihed(nat,c1,ncc,ezat,ezdihed) + call ezccdihed(mol%nat,mol%xyz,ncc,ezat,ezdihed) do l = 1,ncc winkeldiff = ezdihedref(l)-ezdihed(l) winkeldiff = abs(winkeldiff) @@ -822,23 +800,14 @@ subroutine cregen_topocheck(ch,env,checkez,nat,nall,at,xyz,comments,newnall) end if if (discard) then - !>-- move broken structures to the end of the matrix - orderref(j) = llan - llan = llan-1 + broke(jj) = .true. else newnall = newnall+1 - orderref(j) = newnall end if end do !>--- sort the xyz array (only if structures have been discarded) if (newnall .lt. nall) then - order = orderref - call xyzqsort(nat,nall,xyz,c1,order,1,nall) - order = orderref - !call stringqsort(nall,comments,1,nall,order) - call stringqsort(nall,len(comments(1)),comments,1,nall,order) - llan = nall-newnall write (ch,'('' number of topology mismatches :'',i6)') llan !>--- report the removals during a run @@ -848,19 +817,31 @@ subroutine cregen_topocheck(ch,env,checkez,nat,nall,at,xyz,comments,newnall) if (checkez.and.ccfail > 0) then write (ch,'('' => discared due to E/Z isom. :'',i6)') ccfail end if + if (newnall >= 1) then + allocate (tmpstructures(newnall)) + jj = 0 + do ii = 1,nall + if (.not.broke(ii)) then + jj = jj+1 + tmpstructures(jj) = structures(ii) + end if + end do + call move_alloc(tmpstructures,structures) + else + if (ch .ne. stdout) then + write (stdout,'("CREGEN> ** WARNING ** Full removal of ensemble! Falling back to reference structure.")') + end if + allocate(tmpstructures(1), source=mol0) + call move_alloc(tmpstructures,structures) + end if end if !>--- otherwise the ensemble is ok - - deallocate (c1) - deallocate (orderref,order) if (allocated(ezdihedref)) deallocate (ezdihedref) if (allocated(ezdihed)) deallocate (ezdihed) if (allocated(ezat)) deallocate (ezat) deallocate (cn,bond) deallocate (neighmat) deallocate (topo,toporef) - deallocate (atdum) - deallocate (cref) return end subroutine cregen_topocheck diff --git a/src/sorting/cregen_interfaces.f90 b/src/sorting/cregen_interfaces.f90 index 1b58279a..392f6838 100644 --- a/src/sorting/cregen_interfaces.f90 +++ b/src/sorting/cregen_interfaces.f90 @@ -1,9 +1,9 @@ -!=========================================================================================! -!=========================================================================================! +!=========================================================================================! +!=========================================================================================! !> Interfaces for use CREGEN (and related) -!=========================================================================================! -!=========================================================================================! +!=========================================================================================! +!=========================================================================================! module cregen_interface !******************************************************* @@ -52,11 +52,11 @@ end subroutine cregen_irmsd_sort public :: unionizeEnsembles end module cregen_interface -!=========================================================================================! -!=========================================================================================! +!=========================================================================================! +!=========================================================================================! !> Interfaces for routines used WITHIN CREGEN -!=========================================================================================! -!=========================================================================================! +!=========================================================================================! +!=========================================================================================! module cregen_subroutines !************************************* @@ -64,7 +64,7 @@ module cregen_subroutines !************************************* implicit none interface - subroutine discardbroken(ch,env,topocheck,structures,newnall) + subroutine cregen_discardbroken(ch,env,topocheck,structures,newnall) use crest_data use strucrd use cregen_utils @@ -73,7 +73,18 @@ subroutine discardbroken(ch,env,topocheck,structures,newnall) logical,intent(in) :: topocheck type(coord),intent(inout),allocatable,target :: structures(:) integer,intent(out) :: newnall - end subroutine discardbroken + end subroutine cregen_discardbroken + subroutine cregen_topocheck(ch,env,checkez,structures,newnall) + use crest_data + use strucrd + use cregen_utils + implicit none + type(systemdata) :: env + integer,intent(in) :: ch + logical,intent(in) :: checkez + type(coord),intent(inout),allocatable,target :: structures(:) + integer,intent(out) :: newnall + end subroutine cregen_topocheck end interface end module cregen_subroutines diff --git a/src/sorting/cregen_utils.f90 b/src/sorting/cregen_utils.f90 index 6b7fe8a8..ae2f4a38 100644 --- a/src/sorting/cregen_utils.f90 +++ b/src/sorting/cregen_utils.f90 @@ -156,6 +156,7 @@ end subroutine bondtotopo subroutine nezcc(nat,at,xyz,cn,ntopo,topo,ncc) !*************************************************** !* Check how many (potential) C=C bonds are present + !* Expecting xyz in BOHR !*************************************************** integer,intent(in) :: nat integer,intent(in) :: at(nat) @@ -167,7 +168,7 @@ subroutine nezcc(nat,at,xyz,cn,ntopo,topo,ncc) real(wp) :: dist integer :: l integer :: ci,cj - real(wp),parameter :: distcc = 1.384_wp + real(wp),parameter :: distcc = 1.384_wp*aatoau ncc = 0 do ci = 1,nat do cj = 1,ci-1 @@ -191,6 +192,7 @@ end subroutine nezcc subroutine ezccat(nat,at,xyz,cn,ntopo,topo,ncc,ezat) !******************************************************** !* Check which atoms can be used for C=C dihedral angles + !* Expecting xyz in BOHR !******************************************************** integer,intent(in) :: nat integer,intent(in) :: at(nat) @@ -203,7 +205,7 @@ subroutine ezccat(nat,at,xyz,cn,ntopo,topo,ncc,ezat) real(wp) :: dist integer :: i,j,k,l integer :: ci,cj - real(wp),parameter :: distcc = 1.384_wp + real(wp),parameter :: distcc = 1.384_wp*aatoau if (ncc < 1) return k = 0 do ci = 1,nat From 13cbddd0fe2bf8fc9edddbe19206afe6834a572a Mon Sep 17 00:00:00 2001 From: LukasRindt Date: Thu, 5 Feb 2026 16:53:25 +0100 Subject: [PATCH 160/374] modelhessians and different hu for hr implemented --- src/calculator/calc_type.f90 | 2 + src/calculator/hessian_reconstruct.f90 | 48 +- src/calculator/hr_utils.f90 | 180 +- src/optimize/ancopt.f90 | 9 +- src/optimize/modelhessian.f90 | 2794 ++++++++++++++++++++---- src/optimize/optimize_module.f90 | 5 +- src/parsing/parse_calcdata.f90 | 38 +- 7 files changed, 2530 insertions(+), 546 deletions(-) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 162d3501..8e7f49fd 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -281,6 +281,8 @@ module calc_type real(wp),allocatable :: et(:),ht(:),gt(:),stot(:) real(wp) :: ithr,fscal,sthr integer :: initialize_hr_type !> case defining initialization + integer :: mh_type = 0 + integer :: hr_hu_type = 0 !>--- Parameters for smooth function within optimizer real(wp) :: L = 1.50_wp diff --git a/src/calculator/hessian_reconstruct.f90 b/src/calculator/hessian_reconstruct.f90 index 4e965b56..7eb89015 100644 --- a/src/calculator/hessian_reconstruct.f90 +++ b/src/calculator/hessian_reconstruct.f90 @@ -20,28 +20,31 @@ module hessian_reconstruct real(wp) :: hguess = 0.02_wp real(wp),allocatable ::hess(:) logical :: track_step = .true. - integer :: initialize_type = 0 + integer :: initialize_type != 0 + integer :: hu_type != 0 contains procedure :: alloc => cashed_hessian_allocate procedure :: dealloc => cashed_hessian_deallocate procedure :: update => update_cashed_hessian - procedure :: construct_hessian_bfgs + procedure :: construct_hessian end type cashed_hessian contains - subroutine cashed_hessian_allocate(self,N,steps,hguess,initialize_type) !> maybe make keywords optional later - integer,intent(in) :: N,steps, initialize_type + subroutine cashed_hessian_allocate(self,N,steps,hguess,initialize_type, hu_type) !> maybe make keywords optional later + integer,intent(in) :: N,steps, initialize_type, hu_type class(cashed_hessian),intent(inout) :: self real(wp),intent(in) :: hguess + self%steps = steps self%hguess = hguess self%natm = N self%initialize_type = initialize_type + self%hu_type = hu_type allocate (self%gradient(steps,3,N)) allocate (self%coords(steps,3,N)) allocate (self%energy(steps)) @@ -77,7 +80,7 @@ subroutine update_cashed_hessian(self,gradient,energy,coords) end subroutine update_cashed_hessian - subroutine construct_hessian_bfgs(self) + subroutine construct_hessian(self) class(cashed_hessian),intent(inout) :: self integer :: i,j,k,nat3 real(wp),allocatable :: tmp(:),tmp_coords(:,:),tmp_grads(:,:),dx(:) @@ -120,10 +123,10 @@ subroutine construct_hessian_bfgs(self) j = minloc(tmp,1) !> This only happens if made_iters>steps if (j == 1) then !> => Not affected if too many steps requested dx = tmp_coords(j,:)-tmp_coords(self%steps,:) - call bfgs(nat3,gnorm,tmp_grads(j,:),tmp_grads(self%steps,:),dx,self%hess(:)) + call update_hessian(nat3,gnorm,tmp_grads(j,:),tmp_grads(self%steps,:),dx,self%hess(:),self%hu_type) else dx = tmp_coords(j,:)-tmp_coords(j-1,:) - call bfgs(nat3,gnorm,tmp_grads(j,:),tmp_grads(j-1,:),dx,self%hess(:)) + call update_hessian(nat3,gnorm,tmp_grads(j,:),tmp_grads(j-1,:),dx,self%hess(:),self%hu_type) end if tmp(j) = HUGE(tmp(j)) end if @@ -131,6 +134,35 @@ subroutine construct_hessian_bfgs(self) call dhtosq(nat3,self%H(:,:),self%hess(:)) !>B needs to be renamed eventually! - end subroutine construct_hessian_bfgs + end subroutine construct_hessian + + subroutine update_hessian(nat3,gnorm,grd1,gold,dx,hess,hu_type) + !============================================== + !Wrapper for hessian update scheme selection + !============================================== + !class(cashed_hessian),intent(inout) :: self + integer,intent(in) :: nat3 + real(wp),intent(in) :: dx(:), grd1(:),gold(:) + real(wp),intent(in) :: gnorm + real(wp),intent(inout) :: hess(:) + integer,intent(in) :: hu_type + + select case (hu_type) + case (0) + call bfgs(nat3,gnorm,grd1,gold,dx,hess) + case (1) + call powell(nat3,gnorm,grd1,gold,dx,hess) + case (2) + call sr1(nat3,gnorm,grd1,gold,dx,hess) + case (3) + call bofill(nat3,gnorm,grd1,gold,dx,hess) + case (4) + call schlegel(nat3,gnorm,grd1,gold,dx,hess) + case default + write (*,*) 'invalid update selection for hessian reconstruction' + stop + end select + + end subroutine update_hessian end module hessian_reconstruct diff --git a/src/calculator/hr_utils.f90 b/src/calculator/hr_utils.f90 index 2fe20001..29c611e7 100644 --- a/src/calculator/hr_utils.f90 +++ b/src/calculator/hr_utils.f90 @@ -5,6 +5,7 @@ module hr_utils use optimize_maths use modelhessian_module use axis_module + use strucrd implicit none private @@ -12,23 +13,26 @@ module hr_utils contains -subroutine initialize_hessian(calc,type,xyz,nat,at,hess,hguess,pr) !>Matrix is forced to be positive definite - type(calcdata),intent(inout) :: calc - type(calcdata),allocatable :: newcalc - type(calculation_settings) :: clevel - type(mhparam) :: mhset - integer :: k,i,j,idx,io, nat3 - integer, intent(in) :: at(:), nat - real(wp),intent(inout) :: hess(:) - real(wp),allocatable :: hess_full(:,:) - real(wp),optional, intent(in) :: hguess - integer,intent(in) :: type - real(wp),intent(in) :: xyz(:,:) - logical,intent(in) :: pr - real(wp),allocatable :: pmode(:,:) - real(wp) :: rot(3), dumi - logical :: linear - + subroutine initialize_hessian(calc,type,xyz,nat,at,hess,hguess,pr) !>Matrix is forced to be positive definite + type(calcdata),intent(inout) :: calc + integer,intent(in) :: type + real(wp),intent(in) :: xyz(3,nat) + integer,intent(in) :: at(nat),nat + real(wp),intent(inout) :: hess(:) + real(wp),optional,intent(in) :: hguess + logical,intent(in) :: pr + type(calcdata),allocatable :: newcalc + type(calculation_settings) :: clevel + type(mhparam) :: mhset + integer :: k,i,j,idx,io,nat3 + + real(wp),allocatable :: hess_full(:,:) + + real(wp),allocatable :: pmode(:,:),grad(:,:) + real(wp) :: rot(3),dumi + logical :: linear + type(coord) :: mol + nat3 = 3*nat !!$omp critical @@ -36,57 +40,58 @@ subroutine initialize_hessian(calc,type,xyz,nat,at,hess,hguess,pr) !>Matrix is f !!$omp end critical !$omp critical - allocate(newcalc) - allocate(hess_full(nat3,nat3),source=0.0_wp) + allocate (newcalc) + allocate (hess_full(nat3,nat3),source=0.0_wp) !$omp end critical select case (type) - case(0) !>Initialize as a scaled identity - if (present(hguess)) then - k = 0 - do i = 1,nat3 - do j = 1,i - k = k+1 - if (i /= j) then - hess(k) = 0.0_wp - else - hess(k) = hguess - end if - end do - end do - else - write(stdout,*) "No hguess provided" - endif - case(1) - !$omp critical - call clevel%create('gfnff', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? - call newcalc%add(clevel) - !$omp end critical - call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) - call dsqtoh(nat3,hess_full(:,:),hess(:)) !>Pack Hessian - case(2) + case (0) !>Initialize as a scaled identity + if (present(hguess)) then + k = 0 + do i = 1,nat3 + do j = 1,i + k = k+1 + if (i /= j) then + hess(k) = 0.0_wp + else + hess(k) = hguess + end if + end do + end do + else + write (stdout,*) "No hguess provided" + end if + case (1) + !$omp critical + call clevel%create('gfnff',chrg=calc%calcs(1)%chrg,uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? + call newcalc%add(clevel) + !$omp end critical + call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) + call dsqtoh(nat3,hess_full(:,:),hess(:)) !>Pack Hessian + case (2) !$omp critical - call clevel%create('gfn0', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? - call newcalc%add(clevel) - !$omp end critical - call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) - call dsqtoh(nat3,hess_full(:,:),hess(:)) - case(3) + call clevel%create('gfn0',chrg=calc%calcs(1)%chrg,uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? + call newcalc%add(clevel) + !$omp end critical + call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) + call dsqtoh(nat3,hess_full(:,:),hess(:)) + case (3) !$omp critical - call clevel%create('gfn1', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? - call newcalc%add(clevel) - !$omp end critical - call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) - call dsqtoh(nat3,hess_full(:,:),hess(:)) - case(4) + call clevel%create('gfn1',chrg=calc%calcs(1)%chrg,uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? + call newcalc%add(clevel) + !$omp end critical + call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) + call dsqtoh(nat3,hess_full(:,:),hess(:)) + case (4) !$omp critical - call clevel%create('gfn2', chrg=calc%calcs(1)%chrg, uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? - call newcalc%add(clevel) - !$omp end critical - call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) - call dsqtoh(nat3,hess_full(:,:),hess(:)) - case(5) - call modhes(calc,mhset,nat,xyz,at,hess(:),pr) + call clevel%create('gfn2',chrg=calc%calcs(1)%chrg,uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? + call newcalc%add(clevel) + !$omp end critical + call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) + call dsqtoh(nat3,hess_full(:,:),hess(:)) + case (5) + mhset%model = calc%mh_type + call modhes(calc,mhset,nat,xyz,at,hess(:),pr) end select !call axis(nat,at,xyz,rot,dumi) @@ -100,51 +105,50 @@ subroutine initialize_hessian(calc,type,xyz,nat,at,hess,hguess,pr) !>Matrix is f ! end if !end if - call force_positive_definiteness(hess, nat3) + call force_positive_definiteness(hess,nat3) -end subroutine initialize_hessian + end subroutine initialize_hessian -subroutine force_positive_definiteness(hess,nat3) - real(wp), intent(inout) :: hess(:) + subroutine force_positive_definiteness(hess,nat3) + real(wp),intent(inout) :: hess(:) integer,intent(in) :: nat3 - real(wp), allocatable :: eigvec(:,:), eigval(:) - real(wp), allocatable :: work(:) - integer, allocatable :: iwork(:) - integer :: lwork, liwork, info, i, j, k, l - real(wp) :: elow, damp - - allocate(eigvec(nat3,nat3), eigval(nat3)) - lwork = 1 + 6*nat3 + 2*nat3*nat3 + real(wp),allocatable :: eigvec(:,:),eigval(:) + real(wp),allocatable :: work(:) + integer,allocatable :: iwork(:) + integer :: lwork,liwork,info,i,j,k,l + real(wp) :: elow,damp + + allocate (eigvec(nat3,nat3),eigval(nat3)) + lwork = 1+6*nat3+2*nat3*nat3 liwork = 8*nat3 - allocate(work(lwork), iwork(liwork)) + allocate (work(lwork),iwork(liwork)) call dspevd('V','U',nat3,hess(:),eigval,eigvec,nat3, & - work,lwork,iwork,liwork,info) - + work,lwork,iwork,liwork,info) + if (info /= 0) then - write(*,*) "dspevd failed, info = ", info + write (*,*) "dspevd failed, info = ",info stop end if - elow = minval(eigval) - damp = max(1.0e-4_wp - elow, 0.0_wp) - eigval = eigval + damp + damp = max(1.0e-4_wp-elow,0.0_wp) + eigval = eigval+damp hess(:) = 0.0_wp k = 0 do j = 1,nat3 do i = 1,j - k = k + 1 - hess(k) = 0.0_wp - do l = 1,nat3 - hess(k) = hess(k) + eigval(l)*eigvec(i,l)*eigvec(j,l) - end do + k = k+1 + hess(k) = 0.0_wp + do l = 1,nat3 + hess(k) = hess(k)+eigval(l)*eigvec(i,l)*eigvec(j,l) + end do end do end do - deallocate(eigvec, eigval, work, iwork) + deallocate (eigvec,eigval,work,iwork) -end subroutine force_positive_definiteness + end subroutine force_positive_definiteness end module hr_utils \ No newline at end of file diff --git a/src/optimize/ancopt.f90 b/src/optimize/ancopt.f90 index d432556d..c9b3d9ea 100644 --- a/src/optimize/ancopt.f90 +++ b/src/optimize/ancopt.f90 @@ -122,6 +122,7 @@ subroutine ancopt(mol,calc,etot,grd,pr,wr,iostatus) hmax = calc%hmax_opt maxdispl = calc%maxdispl_opt s6 = mhset%s6 !> slightly better than 30 for various proteins + mhset%model=calc%mh_type !> initial number of steps in relax() routine before !> new ANC are made by model Hessian @@ -351,13 +352,13 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & real(wp),allocatable :: Uaug(:,:) real(wp),allocatable :: Aaug(:) real(wp),parameter :: r4dum = 1.e-8 - real(wp), allocatable :: test_hess(:,:) + real(wp),allocatable :: test_hess(:,:) !> LAPACK & BLAS external :: dgemv real(wp),external :: ddot integer :: q,r,s,nat3 !> ONLY for testing! nat3 = 3*mol%nat - allocate(test_hess(nat3,nat3)) + allocate (test_hess(nat3,nat3)) iostatus = 0 @@ -475,7 +476,7 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & ! alp = 3.0d0 ! 3 !end if - alp = alp_generate(gnorm, calc%optlev,calc%opt_engine) + alp = alp_generate(gnorm,calc%optlev,calc%opt_engine) !write(stdout,*) alp !>------------------------------------------------------------------------ @@ -517,7 +518,7 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & !>--- choose solver for the RF eigenvalue problem if (exact.or.nvar1 .lt. 50) then - call solver_dspevx(nvar1,r4dum,Aaug,Uaug,eaug,fail) + call solver_dspevx(nvar1,r4dum,Aaug,Uaug,eaug,fail) else !>--- steepest decent guess for displacement if (ii .eq. 1) then diff --git a/src/optimize/modelhessian.f90 b/src/optimize/modelhessian.f90 index 4bd9b522..bc89bccc 100644 --- a/src/optimize/modelhessian.f90 +++ b/src/optimize/modelhessian.f90 @@ -20,7 +20,7 @@ ! under the Open-source software LGPL-3.0 Licencse. !================================================================================! module modelhessian_module - use iso_fortran_env,only:wp => real64 + use iso_fortran_env,only:wp => real64,stdout => output_unit use crest_calculator,only:calcdata,constrhess implicit none @@ -40,6 +40,7 @@ module modelhessian_module !> Parameters & constants real(wp),parameter :: bohr = 0.52917726_wp + real(wp),parameter :: aatoau = 1.0/bohr real(wp),parameter :: pi = 3.141592653589793_wp real(wp),parameter :: Zero = 0.0_wp real(wp),parameter :: One = 1.0_wp @@ -97,25 +98,58 @@ module modelhessian_module & 50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp, & & 50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp/) ! Tl-Rn +!&< + integer, private, parameter :: max_elem = 118 + !> covalent radii (taken from Pyykko and Atsumi, Chem. Eur. J. 15, 2009, + ! 188-197), values for metals decreased by 10 % + real(wp),parameter :: covrad_2009(max_elem) = aatoau * [ & + & 0.32_wp,0.46_wp, & ! H,He + & 1.20_wp,0.94_wp,0.77_wp,0.75_wp,0.71_wp,0.63_wp,0.64_wp,0.67_wp, & ! Li-Ne + & 1.40_wp,1.25_wp,1.13_wp,1.04_wp,1.10_wp,1.02_wp,0.99_wp,0.96_wp, & ! Na-Ar + & 1.76_wp,1.54_wp, & ! K,Ca + & 1.33_wp,1.22_wp,1.21_wp,1.10_wp,1.07_wp, & ! Sc- + & 1.04_wp,1.00_wp,0.99_wp,1.01_wp,1.09_wp, & ! -Zn + & 1.12_wp,1.09_wp,1.15_wp,1.10_wp,1.14_wp,1.17_wp, & ! Ga-Kr + & 1.89_wp,1.67_wp, & ! Rb,Sr + & 1.47_wp,1.39_wp,1.32_wp,1.24_wp,1.15_wp, & ! Y- + & 1.13_wp,1.13_wp,1.08_wp,1.15_wp,1.23_wp, & ! -Cd + & 1.28_wp,1.26_wp,1.26_wp,1.23_wp,1.32_wp,1.31_wp, & ! In-Xe + & 2.09_wp,1.76_wp, & ! Cs,Ba + & 1.62_wp,1.47_wp,1.58_wp,1.57_wp,1.56_wp,1.55_wp,1.51_wp, & ! La-Eu + & 1.52_wp,1.51_wp,1.50_wp,1.49_wp,1.49_wp,1.48_wp,1.53_wp, & ! Gd-Yb + & 1.46_wp,1.37_wp,1.31_wp,1.23_wp,1.18_wp, & ! Lu- + & 1.16_wp,1.11_wp,1.12_wp,1.13_wp,1.32_wp, & ! -Hg + & 1.30_wp,1.30_wp,1.36_wp,1.31_wp,1.38_wp,1.42_wp, & ! Tl-Rn + & 2.01_wp,1.81_wp, & ! Fr,Ra + & 1.67_wp,1.58_wp,1.52_wp,1.53_wp,1.54_wp,1.55_wp,1.49_wp, & ! Ac-Am + & 1.49_wp,1.51_wp,1.51_wp,1.48_wp,1.50_wp,1.56_wp,1.58_wp, & ! Cm-No + & 1.45_wp,1.41_wp,1.34_wp,1.29_wp,1.27_wp, & ! Lr- + & 1.21_wp,1.16_wp,1.15_wp,1.09_wp,1.22_wp, & ! -Cn + & 1.36_wp,1.43_wp,1.46_wp,1.58_wp,1.48_wp,1.57_wp ] ! Nh-Og +!&> + public :: modhes -contains -!========================================================================================! -!> subroutine modhes -!> create a model Hessian for a given molecule -!> -!> Input: -!> natoms - number of atoms -!> xyz - Cartesian coordinates -!> at - atom types as integers -!> modh - model Hessian settings (see above) -!> calc - calculation settings (for constraints) -!> pr - printout selection -!> -!> Output: -!> Hess - the (packed) model Hessian -!>-------------------------------------------------------- +!==============================================================================! +contains !> MODULE PROCEDURES START HERE +!==============================================================================! +! subroutine modhes(calc,modh,natoms,xyz,at,Hess,pr) +!********************************************************** +!* subroutine modhes +!* create a model Hessian for a given molecule +!* +!* Input: +!* natoms - number of atoms +!* xyz - Cartesian coordinates +!* at - atom types as integers +!* modh - model Hessian settings (see above) +!* calc - calculation settings (for constraints) +!* pr - printout selection +!* +!* Output: +!* Hess - the (packed) model Hessian +!********************************************************** implicit none type(calcdata),intent(in) :: calc type(mhparam),intent(in) :: modh @@ -124,27 +158,27 @@ subroutine modhes(calc,modh,natoms,xyz,at,Hess,pr) integer :: nhess integer,intent(in) :: natoms real(wp),intent(in) :: xyz(3,natoms) - real(wp),intent(out) :: hess((natoms * 3) * ((natoms * 3) + 1) / 2) + real(wp),intent(out) :: hess((natoms*3)*((natoms*3)+1)/2) integer,intent(in) :: at(natoms) !> initialize - nhess = 3 * natoms + nhess = 3*natoms Hess = 0.0_wp select case (modh%model) - case default !case (p_modh_old) - if (pr) write (*,'(a)') "Using Lindh-Hessian (1995)" + case (0) + if (pr) write (stdout,'(a)') "Using Lindh-Hessian (1995)" call ddvopt(xyz,natoms,Hess,at,modh) -!> other model hessians currently not implemented - !case (p_modh_lindh_d2) - ! if (pr) write (*,'(a)') "Using Lindh-Hessian" - ! call mh_lindh_d2(xyz,natoms,Hess,at,modh) - !case (p_modh_lindh) - ! if (pr) write (*,'(a)') "Using Lindh-Hessian (2007)" - ! call mh_lindh(xyz,natoms,Hess,at,modh) - !case (p_modh_swart) - ! if (pr) write (*,'(a)') "Using Swart-Hessian" - ! call mh_swart(xyz,natoms,Hess,at,modh) +!> other model hessians currently not tested + case (1) + if (pr) write (stdout,'(a)') "Using Lindh-Hessian" + call mh_lindh_d2(xyz,natoms,Hess,at,modh) + case (2) + if (pr) write (stdout,'(a)') "Using Lindh-Hessian (2007)" + call mh_lindh(xyz,natoms,Hess,at,modh) + case (3) + if (pr) write (stdout,'(a)') "Using Swart-Hessian" + call mh_swart(xyz,natoms,Hess,at,modh) end select !> add user-set constraint contributions to modelhessian @@ -154,29 +188,33 @@ subroutine modhes(calc,modh,natoms,xyz,at,Hess,pr) end subroutine modhes !========================================================================================! -!> subroutine ddvopt -!> generates a Lindh Model Hessian -!> Chem. Phys. Let. 241(1995) 423-428 -!> -!> Input: -!> Cart - cartesian coordinates -!> nAtoms - number of atoms -!> iANr - atom types as integers -!> mhset - model Hessian parameters -!> -!> Output: -!> Hess - the (packed) model Hessian -!>------------------------------------------------------ +!########################################################################################! +!========================================================================================! + subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) - Implicit Integer(i - n) - Implicit Real(wp) (a - h,o - z) +!*********************************************************** +!* subroutine ddvopt +!* generates a Lindh Model Hessian +!* Chem. Phys. Let. 241(1995) 423-428 +!* +!* Input: +!* Cart - cartesian coordinates +!* nAtoms - number of atoms +!* iANr - atom types as integers +!* mhset - model Hessian parameters +!* +!* Output: +!* Hess - the (packed) model Hessian +!********************************************************** + Implicit Integer(i-n) + Implicit Real(wp) (a-h,o-z) type(mhparam) :: mhset real(wp) :: s6 real(wp) :: rcut Real(wp) :: Cart(3,nAtoms),rij(3),rjk(3),rkl(3), & - & Hess((3 * nAtoms) * (3 * nAtoms + 1) / 2),si(3),sj(3),sk(3), & + & Hess((3*nAtoms)*(3*nAtoms+1)/2),si(3),sj(3),sk(3), & & sl(3),sm(3),x(2),y(2),z(2), & & xyz(3,4),C(3,4),Dum(3,4,3,4) Integer iANr(nAtoms) @@ -226,7 +264,7 @@ subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) Fact = One !hjw threshold reduced rZero = 1.0d-10 - n3 = 3 * nAtoms + n3 = 3*nAtoms Hess = 0.0d0 ! @@ -236,21 +274,21 @@ subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) kr = iTabRow(iANr(kAtom)) ! If (kr.eq.0) Go To 5 - Do lAtom = 1,kAtom - 1 + Do lAtom = 1,kAtom-1 lr = iTabRow(iANr(lAtom)) ! If (lr.eq.0) Go To 10 - xkl = Cart(1,kAtom) - Cart(1,lAtom) - ykl = Cart(2,kAtom) - Cart(2,lAtom) - zkl = Cart(3,kAtom) - Cart(3,lAtom) - rkl2 = xkl**2 + ykl**2 + zkl**2 + xkl = Cart(1,kAtom)-Cart(1,lAtom) + ykl = Cart(2,kAtom)-Cart(2,lAtom) + zkl = Cart(3,kAtom)-Cart(3,lAtom) + rkl2 = xkl**2+ykl**2+zkl**2 r0 = rAv(kr,lr) alpha = aAv(kr,lr) !cccccc VDWx ccccccccccccccccccccccccccccccccc c6k = c6(iANr(katom)) c6l = c6(iANr(latom)) - c66 = sqrt(c6k * c6l) - Rv = (vander(iANr(katom)) + vander(iANr(latom))) / bohr + c66 = sqrt(c6k*c6l) + Rv = (vander(iANr(katom))+vander(iANr(latom)))/bohr call getvdwxx(xkl,ykl,zkl,c66,s6,Rv,vdw(1,1)) call getvdwxy(xkl,ykl,zkl,c66,s6,Rv,vdw(1,2)) @@ -260,40 +298,40 @@ subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) call getvdwxx(zkl,xkl,ykl,c66,s6,Rv,vdw(3,3)) !cccccc Ende VDWx ccccccccccccccccccccccccccccccc - gamma = rkr * Exp(alpha * r0**2) + gamma = rkr*Exp(alpha*r0**2) ! not better: *sqrt(abs(wb(kAtom,lAtom))) - gmm = gamma * Exp(-alpha * rkl2) - Hxx = gmm * xkl * xkl / rkl2 - vdw(1,1) - Hxy = gmm * xkl * ykl / rkl2 - vdw(1,2) - Hxz = gmm * xkl * zkl / rkl2 - vdw(1,3) - Hyy = gmm * ykl * ykl / rkl2 - vdw(2,2) - Hyz = gmm * ykl * zkl / rkl2 - vdw(2,3) - Hzz = gmm * zkl * zkl / rkl2 - vdw(3,3) - -! - Hess(Ind(1,kAtom,1,kAtom)) = Hess(Ind(1,kAtom,1,kAtom)) + Hxx - Hess(Ind(2,kAtom,1,kAtom)) = Hess(Ind(2,kAtom,1,kAtom)) + Hxy - Hess(Ind(2,kAtom,2,kAtom)) = Hess(Ind(2,kAtom,2,kAtom)) + Hyy - Hess(Ind(3,kAtom,1,kAtom)) = Hess(Ind(3,kAtom,1,kAtom)) + Hxz - Hess(Ind(3,kAtom,2,kAtom)) = Hess(Ind(3,kAtom,2,kAtom)) + Hyz - Hess(Ind(3,kAtom,3,kAtom)) = Hess(Ind(3,kAtom,3,kAtom)) + Hzz -! - Hess(Ind(1,kAtom,1,lAtom)) = Hess(Ind(1,kAtom,1,lAtom)) - Hxx - Hess(Ind(1,kAtom,2,lAtom)) = Hess(Ind(1,kAtom,2,lAtom)) - Hxy - Hess(Ind(1,kAtom,3,lAtom)) = Hess(Ind(1,kAtom,3,lAtom)) - Hxz - Hess(Ind(2,kAtom,1,lAtom)) = Hess(Ind(2,kAtom,1,lAtom)) - Hxy - Hess(Ind(2,kAtom,2,lAtom)) = Hess(Ind(2,kAtom,2,lAtom)) - Hyy - Hess(Ind(2,kAtom,3,lAtom)) = Hess(Ind(2,kAtom,3,lAtom)) - Hyz - Hess(Ind(3,kAtom,1,lAtom)) = Hess(Ind(3,kAtom,1,lAtom)) - Hxz - Hess(Ind(3,kAtom,2,lAtom)) = Hess(Ind(3,kAtom,2,lAtom)) - Hyz - Hess(Ind(3,kAtom,3,lAtom)) = Hess(Ind(3,kAtom,3,lAtom)) - Hzz -! - Hess(Ind(1,lAtom,1,lAtom)) = Hess(Ind(1,lAtom,1,lAtom)) + Hxx - Hess(Ind(2,lAtom,1,lAtom)) = Hess(Ind(2,lAtom,1,lAtom)) + Hxy - Hess(Ind(2,lAtom,2,lAtom)) = Hess(Ind(2,lAtom,2,lAtom)) + Hyy - Hess(Ind(3,lAtom,1,lAtom)) = Hess(Ind(3,lAtom,1,lAtom)) + Hxz - Hess(Ind(3,lAtom,2,lAtom)) = Hess(Ind(3,lAtom,2,lAtom)) + Hyz - Hess(Ind(3,lAtom,3,lAtom)) = Hess(Ind(3,lAtom,3,lAtom)) + Hzz + gmm = gamma*Exp(-alpha*rkl2) + Hxx = gmm*xkl*xkl/rkl2-vdw(1,1) + Hxy = gmm*xkl*ykl/rkl2-vdw(1,2) + Hxz = gmm*xkl*zkl/rkl2-vdw(1,3) + Hyy = gmm*ykl*ykl/rkl2-vdw(2,2) + Hyz = gmm*ykl*zkl/rkl2-vdw(2,3) + Hzz = gmm*zkl*zkl/rkl2-vdw(3,3) + +! + Hess(Ind(1,kAtom,1,kAtom)) = Hess(Ind(1,kAtom,1,kAtom))+Hxx + Hess(Ind(2,kAtom,1,kAtom)) = Hess(Ind(2,kAtom,1,kAtom))+Hxy + Hess(Ind(2,kAtom,2,kAtom)) = Hess(Ind(2,kAtom,2,kAtom))+Hyy + Hess(Ind(3,kAtom,1,kAtom)) = Hess(Ind(3,kAtom,1,kAtom))+Hxz + Hess(Ind(3,kAtom,2,kAtom)) = Hess(Ind(3,kAtom,2,kAtom))+Hyz + Hess(Ind(3,kAtom,3,kAtom)) = Hess(Ind(3,kAtom,3,kAtom))+Hzz +! + Hess(Ind(1,kAtom,1,lAtom)) = Hess(Ind(1,kAtom,1,lAtom))-Hxx + Hess(Ind(1,kAtom,2,lAtom)) = Hess(Ind(1,kAtom,2,lAtom))-Hxy + Hess(Ind(1,kAtom,3,lAtom)) = Hess(Ind(1,kAtom,3,lAtom))-Hxz + Hess(Ind(2,kAtom,1,lAtom)) = Hess(Ind(2,kAtom,1,lAtom))-Hxy + Hess(Ind(2,kAtom,2,lAtom)) = Hess(Ind(2,kAtom,2,lAtom))-Hyy + Hess(Ind(2,kAtom,3,lAtom)) = Hess(Ind(2,kAtom,3,lAtom))-Hyz + Hess(Ind(3,kAtom,1,lAtom)) = Hess(Ind(3,kAtom,1,lAtom))-Hxz + Hess(Ind(3,kAtom,2,lAtom)) = Hess(Ind(3,kAtom,2,lAtom))-Hyz + Hess(Ind(3,kAtom,3,lAtom)) = Hess(Ind(3,kAtom,3,lAtom))-Hzz +! + Hess(Ind(1,lAtom,1,lAtom)) = Hess(Ind(1,lAtom,1,lAtom))+Hxx + Hess(Ind(2,lAtom,1,lAtom)) = Hess(Ind(2,lAtom,1,lAtom))+Hxy + Hess(Ind(2,lAtom,2,lAtom)) = Hess(Ind(2,lAtom,2,lAtom))+Hyy + Hess(Ind(3,lAtom,1,lAtom)) = Hess(Ind(3,lAtom,1,lAtom))+Hxz + Hess(Ind(3,lAtom,2,lAtom)) = Hess(Ind(3,lAtom,2,lAtom))+Hyz + Hess(Ind(3,lAtom,3,lAtom)) = Hess(Ind(3,lAtom,3,lAtom))+Hzz ! 10 Continue End Do @@ -313,7 +351,7 @@ subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) ! If (ir.eq.0) Go To 30 if (rcutoff(cart,iatom,matom,rcut)) cycle ! if(wb(iatom,matom).lt.wthr) cycle - Do jAtom = 1,iAtom - 1 + Do jAtom = 1,iAtom-1 If (jAtom .eq. mAtom) Go To 40 jr = iTabRow(iANr(jAtom)) ! If (jr.eq.0) Go To 40 @@ -322,41 +360,41 @@ subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) ! if(wb(jatom,iatom).lt.wthr) cycle ! if(wb(jatom,matom).lt.wthr) cycle - xmi = (Cart(1,iAtom) - Cart(1,mAtom)) - ymi = (Cart(2,iAtom) - Cart(2,mAtom)) - zmi = (Cart(3,iAtom) - Cart(3,mAtom)) - rmi2 = xmi**2 + ymi**2 + zmi**2 + xmi = (Cart(1,iAtom)-Cart(1,mAtom)) + ymi = (Cart(2,iAtom)-Cart(2,mAtom)) + zmi = (Cart(3,iAtom)-Cart(3,mAtom)) + rmi2 = xmi**2+ymi**2+zmi**2 rmi = sqrt(rmi2) r0mi = rAv(mr,ir) ami = aAv(mr,ir) ! - xmj = (Cart(1,jAtom) - Cart(1,mAtom)) - ymj = (Cart(2,jAtom) - Cart(2,mAtom)) - zmj = (Cart(3,jAtom) - Cart(3,mAtom)) - rmj2 = xmj**2 + ymj**2 + zmj**2 + xmj = (Cart(1,jAtom)-Cart(1,mAtom)) + ymj = (Cart(2,jAtom)-Cart(2,mAtom)) + zmj = (Cart(3,jAtom)-Cart(3,mAtom)) + rmj2 = xmj**2+ymj**2+zmj**2 rmj = sqrt(rmj2) r0mj = rAv(mr,jr) amj = aAv(mr,jr) ! !---------- Test if zero angle ! - Test = xmi * xmj + ymi * ymj + zmi * zmj - Test = Test / (rmi * rmj) + Test = xmi*xmj+ymi*ymj+zmi*zmj + Test = Test/(rmi*rmj) If (Test .eq. One) Go To 40 ! - xij = (Cart(1,jAtom) - Cart(1,iAtom)) - yij = (Cart(2,jAtom) - Cart(2,iAtom)) - zij = (Cart(3,jAtom) - Cart(3,iAtom)) - rij2 = xij**2 + yij**2 + zij**2 + xij = (Cart(1,jAtom)-Cart(1,iAtom)) + yij = (Cart(2,jAtom)-Cart(2,iAtom)) + zij = (Cart(3,jAtom)-Cart(3,iAtom)) + rij2 = xij**2+yij**2+zij**2 rrij = sqrt(rij2) ! - alpha = rkf * exp((ami * r0mi**2 + amj * r0mj**2)) + alpha = rkf*exp((ami*r0mi**2+amj*r0mj**2)) ! - r = sqrt(rmj2 + rmi2) - gij = alpha * exp(-(ami * rmi2 + amj * rmj2)) + r = sqrt(rmj2+rmi2) + gij = alpha*exp(-(ami*rmi2+amj*rmj2)) ! Write (*,*) ' gij=',gij - rL2 = (ymi * zmj - zmi * ymj)**2 + (zmi * xmj - xmi * zmj)**2 + & - & (xmi * ymj - ymi * xmj)**2 + rL2 = (ymi*zmj-zmi*ymj)**2+(zmi*xmj-xmi*zmj)**2+ & + & (xmi*ymj-ymi*xmj)**2 !hjw modified if (rL2 .lt. 1.d-14) then rL = 0 @@ -364,53 +402,53 @@ subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) rL = sqrt(rL2) end if ! - if ((rmj .gt. rZero) .and. (rmi .gt. rZero) .and. & + if ((rmj .gt. rZero).and.(rmi .gt. rZero).and. & & (rrij .gt. rZero)) Then - SinPhi = rL / (rmj * rmi) - rmidotrmj = xmi * xmj + ymi * ymj + zmi * zmj - CosPhi = rmidotrmj / (rmj * rmi) + SinPhi = rL/(rmj*rmi) + rmidotrmj = xmi*xmj+ymi*ymj+zmi*zmj + CosPhi = rmidotrmj/(rmj*rmi) ! !-------------None linear case ! If (SinPhi .gt. rZero) Then ! Write (*,*) ' None linear case' - si(1) = (xmi / rmi * cosphi - xmj / rmj) / (rmi * sinphi) - si(2) = (ymi / rmi * cosphi - ymj / rmj) / (rmi * sinphi) - si(3) = (zmi / rmi * cosphi - zmj / rmj) / (rmi * sinphi) - sj(1) = (cosphi * xmj / rmj - xmi / rmi) / (rmj * sinphi) - sj(2) = (cosphi * ymj / rmj - ymi / rmi) / (rmj * sinphi) - sj(3) = (cosphi * zmj / rmj - zmi / rmi) / (rmj * sinphi) - sm(1) = -si(1) - sj(1) - sm(2) = -si(2) - sj(2) - sm(3) = -si(3) - sj(3) + si(1) = (xmi/rmi*cosphi-xmj/rmj)/(rmi*sinphi) + si(2) = (ymi/rmi*cosphi-ymj/rmj)/(rmi*sinphi) + si(3) = (zmi/rmi*cosphi-zmj/rmj)/(rmi*sinphi) + sj(1) = (cosphi*xmj/rmj-xmi/rmi)/(rmj*sinphi) + sj(2) = (cosphi*ymj/rmj-ymi/rmi)/(rmj*sinphi) + sj(3) = (cosphi*zmj/rmj-zmi/rmi)/(rmj*sinphi) + sm(1) = -si(1)-sj(1) + sm(2) = -si(2)-sj(2) + sm(3) = -si(3)-sj(3) Do icoor = 1,3 Do jCoor = 1,3 If (mAtom .gt. iAtom) Then Hess(Ind(icoor,mAtom,jcoor,iAtom)) = & & Hess(Ind(icoor,mAtom,jcoor,iAtom)) & - & + gij * sm(icoor) * si(jcoor) + & +gij*sm(icoor)*si(jcoor) else Hess(Ind(icoor,iAtom,jcoor,mAtom)) = & & Hess(Ind(icoor,iAtom,jcoor,mAtom)) & - & + gij * si(icoor) * sm(jcoor) + & +gij*si(icoor)*sm(jcoor) End If If (mAtom .gt. jAtom) Then Hess(Ind(icoor,mAtom,jcoor,jAtom)) = & & Hess(Ind(icoor,mAtom,jcoor,jAtom)) & - & + gij * sm(icoor) * sj(jcoor) + & +gij*sm(icoor)*sj(jcoor) else Hess(Ind(icoor,jAtom,jcoor,mAtom)) = & & Hess(Ind(icoor,jAtom,jcoor,mAtom)) & - & + gij * sj(icoor) * sm(jcoor) + & +gij*sj(icoor)*sm(jcoor) End If If (iAtom .gt. jAtom) Then Hess(Ind(icoor,iAtom,jcoor,jAtom)) = & & Hess(Ind(icoor,iAtom,jcoor,jAtom)) & - & + gij * si(icoor) * sj(jcoor) + & +gij*si(icoor)*sj(jcoor) else Hess(Ind(icoor,jAtom,jcoor,iAtom)) = & & Hess(Ind(icoor,jAtom,jcoor,iAtom)) & - & + gij * sj(icoor) * si(jcoor) + & +gij*sj(icoor)*si(jcoor) End If End Do End Do @@ -418,13 +456,13 @@ subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) Do jCoor = 1,icoor Hess(Ind(icoor,iAtom,jcoor,iAtom)) = & & Hess(Ind(icoor,iAtom,jcoor,iAtom)) & - & + gij * si(icoor) * si(jcoor) + & +gij*si(icoor)*si(jcoor) Hess(Ind(icoor,mAtom,jcoor,mAtom)) = & & Hess(Ind(icoor,mAtom,jcoor,mAtom)) & - & + gij * sm(icoor) * sm(jcoor) + & +gij*sm(icoor)*sm(jcoor) Hess(Ind(icoor,jAtom,jcoor,jAtom)) = & & Hess(Ind(icoor,jAtom,jcoor,jAtom)) & - & + gij * sj(icoor) * sj(jcoor) + & +gij*sj(icoor)*sj(jcoor) ! End Do @@ -433,14 +471,14 @@ subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) ! !----------------Linear case ! - if ((abs(ymi) .gt. rZero) .or. & + if ((abs(ymi) .gt. rZero).or. & & (abs(xmi) .gt. rZero)) Then x(1) = -ymi y(1) = xmi z(1) = Zero - x(2) = -xmi * zmi - y(2) = -ymi * zmi - z(2) = xmi * xmi + ymi * ymi + x(2) = -xmi*zmi + y(2) = -ymi*zmi + z(2) = xmi*xmi+ymi*ymi Else x(1) = One y(1) = Zero @@ -450,48 +488,48 @@ subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) z(2) = Zero End If Do i = 1,2 - r1 = sqrt(x(i)**2 + y(i)**2 + z(i)**2) - cosThetax = x(i) / r1 - cosThetay = y(i) / r1 - cosThetaz = z(i) / r1 - si(1) = -cosThetax / rmi - si(2) = -cosThetay / rmi - si(3) = -cosThetaz / rmi - sj(1) = -cosThetax / rmj - sj(2) = -cosThetay / rmj - sj(3) = -cosThetaz / rmj - sm(1) = -(si(1) + sj(1)) - sm(2) = -(si(2) + sj(2)) - sm(3) = -(si(3) + sj(3)) + r1 = sqrt(x(i)**2+y(i)**2+z(i)**2) + cosThetax = x(i)/r1 + cosThetay = y(i)/r1 + cosThetaz = z(i)/r1 + si(1) = -cosThetax/rmi + si(2) = -cosThetay/rmi + si(3) = -cosThetaz/rmi + sj(1) = -cosThetax/rmj + sj(2) = -cosThetay/rmj + sj(3) = -cosThetaz/rmj + sm(1) = -(si(1)+sj(1)) + sm(2) = -(si(2)+sj(2)) + sm(3) = -(si(3)+sj(3)) ! Do icoor = 1,3 Do jCoor = 1,3 If (mAtom .gt. iAtom) Then Hess(Ind(icoor,mAtom,jcoor,iAtom)) = & & Hess(Ind(icoor,mAtom,jcoor,iAtom)) & - & + gij * sm(icoor) * si(jcoor) + & +gij*sm(icoor)*si(jcoor) else Hess(Ind(icoor,iAtom,jcoor,mAtom)) = & & Hess(Ind(icoor,iAtom,jcoor,mAtom)) & -& + gij * si(icoor) * sm(jcoor) +& +gij*si(icoor)*sm(jcoor) End If If (mAtom .gt. jAtom) Then Hess(Ind(icoor,mAtom,jcoor,jAtom)) = & & Hess(Ind(icoor,mAtom,jcoor,jAtom)) & - & + gij * sm(icoor) * sj(jcoor) + & +gij*sm(icoor)*sj(jcoor) else Hess(Ind(icoor,jAtom,jcoor,mAtom)) = & & Hess(Ind(icoor,jAtom,jcoor,mAtom)) & - & + gij * sj(icoor) * sm(jcoor) + & +gij*sj(icoor)*sm(jcoor) End If If (iAtom .gt. jAtom) Then Hess(Ind(icoor,iAtom,jcoor,jAtom)) = & & Hess(Ind(icoor,iAtom,jcoor,jAtom)) & -& + gij * si(icoor) * sj(jcoor) +& +gij*si(icoor)*sj(jcoor) else Hess(Ind(icoor,jAtom,jcoor,iAtom)) = & & Hess(Ind(icoor,jAtom,jcoor,iAtom)) & -& + gij * sj(icoor) * si(jcoor) +& +gij*sj(icoor)*si(jcoor) End If End Do End Do @@ -499,13 +537,13 @@ subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) Do jCoor = 1,icoor Hess(Ind(icoor,iAtom,jcoor,iAtom)) = & & Hess(Ind(icoor,iAtom,jcoor,iAtom)) & -& + gij * si(icoor) * si(jcoor) +& +gij*si(icoor)*si(jcoor) Hess(Ind(icoor,mAtom,jcoor,mAtom)) = & & Hess(Ind(icoor,mAtom,jcoor,mAtom)) & -& + gij * sm(icoor) * sm(jcoor) +& +gij*sm(icoor)*sm(jcoor) Hess(Ind(icoor,jAtom,jcoor,jAtom)) = & & Hess(Ind(icoor,jAtom,jcoor,jAtom)) & -& + gij * sj(icoor) * sj(jcoor) +& +gij*sj(icoor)*sj(jcoor) End Do End Do End Do @@ -538,7 +576,7 @@ subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) Call DCopy(3,Cart(1,kAtom),1,xyz(1,3),1) ! Do iAtom = 1,nAtoms - ij_ = nAtoms * (jAtom - 1) + iAtom + ij_ = nAtoms*(jAtom-1)+iAtom If (iAtom .eq. jAtom) Go To 333 If (iAtom .eq. kAtom) Go To 333 ir = iTabRow(iANr(iAtom)) @@ -552,7 +590,7 @@ subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) Call DCopy(3,Cart(1,iAtom),1,xyz(1,1),1) ! Do lAtom = 1,nAtoms - lk_ = nAtoms * (kAtom - 1) + lAtom + lk_ = nAtoms*(kAtom-1)+lAtom If (ij_ .le. lk_) Go To 222 If (lAtom .eq. iAtom) Go To 222 If (lAtom .eq. jAtom) Go To 222 @@ -569,40 +607,40 @@ subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) Call DCopy(3,Cart(1,lAtom),1,xyz(1,4),1) ! - rij(1) = Cart(1,iAtom) - Cart(1,jAtom) - rij(2) = Cart(2,iAtom) - Cart(2,jAtom) - rij(3) = Cart(3,iAtom) - Cart(3,jAtom) + rij(1) = Cart(1,iAtom)-Cart(1,jAtom) + rij(2) = Cart(2,iAtom)-Cart(2,jAtom) + rij(3) = Cart(3,iAtom)-Cart(3,jAtom) rij0 = rAv(ir,jr)**2 aij = aAv(ir,jr) ! - rjk(1) = Cart(1,jAtom) - Cart(1,kAtom) - rjk(2) = Cart(2,jAtom) - Cart(2,kAtom) - rjk(3) = Cart(3,jAtom) - Cart(3,kAtom) + rjk(1) = Cart(1,jAtom)-Cart(1,kAtom) + rjk(2) = Cart(2,jAtom)-Cart(2,kAtom) + rjk(3) = Cart(3,jAtom)-Cart(3,kAtom) rjk0 = rAv(jr,kr)**2 ajk = aAv(jr,kr) ! - rkl(1) = Cart(1,kAtom) - Cart(1,lAtom) - rkl(2) = Cart(2,kAtom) - Cart(2,lAtom) - rkl(3) = Cart(3,kAtom) - Cart(3,lAtom) + rkl(1) = Cart(1,kAtom)-Cart(1,lAtom) + rkl(2) = Cart(2,kAtom)-Cart(2,lAtom) + rkl(3) = Cart(3,kAtom)-Cart(3,lAtom) rkl0 = rAv(kr,lr)**2 akl = aAv(kr,lr) ! - rij2 = rij(1)**2 + rij(2)**2 + rij(3)**2 - rjk2 = rjk(1)**2 + rjk(2)**2 + rjk(3)**2 - rkl2 = rkl(1)**2 + rkl(2)**2 + rkl(3)**2 + rij2 = rij(1)**2+rij(2)**2+rij(3)**2 + rjk2 = rjk(1)**2+rjk(2)**2+rjk(3)**2 + rkl2 = rkl(1)**2+rkl(2)**2+rkl(3)**2 ! Allow only angles in the range of 35-145 - A35 = (35.0D0 / 180.D0) * Pi + A35 = (35.0D0/180.D0)*Pi CosFi_Max = Cos(A35) - CosFi2 = (rij(1) * rjk(1) + rij(2) * rjk(2) + rij(3) * rjk(3)) & - & / Sqrt(rij2 * rjk2) + CosFi2 = (rij(1)*rjk(1)+rij(2)*rjk(2)+rij(3)*rjk(3)) & + & /Sqrt(rij2*rjk2) If (Abs(CosFi2) .gt. CosFi_Max) Go To 222 - CosFi3 = (rkl(1) * rjk(1) + rkl(2) * rjk(2) + rkl(3) * rjk(3)) & - & / Sqrt(rkl2 * rjk2) + CosFi3 = (rkl(1)*rjk(1)+rkl(2)*rjk(2)+rkl(3)*rjk(3)) & + & /Sqrt(rkl2*rjk2) If (Abs(CosFi3) .gt. CosFi_Max) Go To 222 - beta = rkt * & - & exp((aij * rij0 + ajk * rjk0 + akl * rkl0)) - tij = beta * exp(-(aij * rij2 + ajk * rjk2 + akl * rkl2)) + beta = rkt* & + & exp((aij*rij0+ajk*rjk0+akl*rkl0)) + tij = beta*exp(-(aij*rij2+ajk*rjk2+akl*rkl2)) Call Trsn(xyz,4,Tau,C,.False.,.False.,' ', & & Dum,.False.) @@ -617,22 +655,22 @@ subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) Do jCoor = 1,3 Hess(Ind(icoor,iAtom,jcoor,jAtom)) = & & Hess(Ind(icoor,iAtom,jcoor,jAtom)) & - & + tij * si(icoor) * sj(jcoor) + & +tij*si(icoor)*sj(jcoor) Hess(Ind(icoor,iAtom,jcoor,kAtom)) = & & Hess(Ind(icoor,iAtom,jcoor,kAtom)) & - & + tij * si(icoor) * sk(jcoor) + & +tij*si(icoor)*sk(jcoor) Hess(Ind(icoor,iAtom,jcoor,lAtom)) = & & Hess(Ind(icoor,iAtom,jcoor,lAtom)) & - & + tij * si(icoor) * sl(jcoor) + & +tij*si(icoor)*sl(jcoor) Hess(Ind(icoor,jAtom,jcoor,kAtom)) = & & Hess(Ind(icoor,jAtom,jcoor,kAtom)) & - & + tij * sj(icoor) * sk(jcoor) + & +tij*sj(icoor)*sk(jcoor) Hess(Ind(icoor,jAtom,jcoor,lAtom)) = & & Hess(Ind(icoor,jAtom,jcoor,lAtom)) & - & + tij * sj(icoor) * sl(jcoor) + & +tij*sj(icoor)*sl(jcoor) Hess(Ind(icoor,kAtom,jcoor,lAtom)) = & & Hess(Ind(icoor,kAtom,jcoor,lAtom)) & - & + tij * sk(icoor) * sl(jcoor) + & +tij*sk(icoor)*sl(jcoor) End Do End Do @@ -643,16 +681,16 @@ subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) Do jCoor = 1,icoor Hess(Ind(icoor,iAtom,jcoor,iAtom)) = & & Hess(Ind(icoor,iAtom,jcoor,iAtom)) & - & + tij * si(icoor) * si(jcoor) + & +tij*si(icoor)*si(jcoor) Hess(Ind(icoor,jAtom,jcoor,jAtom)) = & & Hess(Ind(icoor,jAtom,jcoor,jAtom)) & - & + tij * sj(icoor) * sj(jcoor) + & +tij*sj(icoor)*sj(jcoor) Hess(Ind(icoor,kAtom,jcoor,kAtom)) = & & Hess(Ind(icoor,kAtom,jcoor,kAtom)) & - & + tij * sk(icoor) * sk(jcoor) + & +tij*sk(icoor)*sk(jcoor) Hess(Ind(icoor,lAtom,jcoor,lAtom)) = & & Hess(Ind(icoor,lAtom,jcoor,lAtom)) & - & + tij * sl(icoor) * sl(jcoor) + & +tij*sl(icoor)*sl(jcoor) ! End Do @@ -671,12 +709,12 @@ subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) function ixyz(i,iatom) integer :: ixyz integer,intent(in) :: i,iatom - ixyz = (iatom - 1) * 3 + i + ixyz = (iatom-1)*3+i end function ixyz function jnd(i,j) integer :: jnd integer,intent(in) :: i,j - jnd = i * (i - 1) / 2 + j + jnd = i*(i-1)/2+j end function jnd function ind(i,iatom,j,jatom) integer :: ind @@ -686,35 +724,1360 @@ end function ind end subroutine ddvopt !========================================================================================! - logical function rcutoff(cart,katom,latom,rcut) +!########################################################################################! +!========================================================================================! + + subroutine mh_swart(xyz,n,hess,at,modh) +!**************************************************************************** +!* Swart's Model Hessian augmented with D2 +!* ------------------------------------------------------------------------ +!* Implemented after: +!* M. Swart, F. M. Bickelhaupt, Int. J. Quantum Chem., 2006, 106, 2536–2544. +!* DOI:10.1002/qua.21049 +!* +!* gij = exp[-(Rij/Cij-1)] +!* kij = rkr·gij +!* kijk = rkf·gij·gjk +!* kijkl = rkt·gij·gjk·gkl +!* +!* The proposed force constants by Swart are: +!* rkr = 0.35, rkf = 0.15, rkt = 0.005 +!* +!* This Hessian is additionally augmented with D2, please note that D2 +!* is not implemented in atomic units and requires some magical conversion +!* factor somewhere hidden in the implementation below. +!**************************************************************************** implicit none - Real(wp) :: Cart(3,*),xkl,ykl,zkl,rkl2 - real(wp) :: rcut - integer :: katom,latom + + integer,intent(in) :: n + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(out) :: hess((3*n)*(3*n+1)/2) + integer,intent(in) :: at(n) + type(mhparam),intent(in) :: modh + + integer :: n3 + real(wp),parameter :: rzero = 1.0e-10_wp + logical,allocatable :: lcutoff(:,:) + real(wp) :: kd + + allocate (lcutoff(n,n),source=.false.) + + n3 = 3*n + hess = 0.0d0 + +! the dispersion force constant is used relative to the stretch force constant + kd = modh%kd/modh%kr + + associate (rad => covrad_2009) + + call mh_swart_stretch(n,at,xyz,hess,modh%kr,kd,modh%s6,rad,rad,lcutoff,modh%rcut) + if (modh%kf .ne. 0.0_wp) & + call mh_swart_bend(n,at,xyz,hess,modh%kf,kd,rad,rad,lcutoff) + if (modh%kt .ne. 0.0_wp) & + call mh_swart_torsion(n,at,xyz,hess,modh%kt,kd,rad,rad,lcutoff) + if (modh%ko .ne. 0.0_wp) & + call mh_swart_outofp(n,at,xyz,hess,modh%ko,kd,rad,rad,lcutoff) + if (modh%kq .ne. 0.0_wp) then +! call new_charge_model_2019(chrgeq,n,at) + call mh_eeq(n,at,xyz,0.0_wp,modh%kq,hess) + end if + + end associate + + end subroutine mh_swart + + pure subroutine mh_swart_stretch(n,at,xyz,hess,kr,kd,s6,rcov,rvdw,lcutoff,rcut) + implicit none + + integer,intent(in) :: n + integer,intent(in) :: at(n) + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) + real(wp),intent(in) :: kr + real(wp),intent(in) :: kd + real(wp),intent(in) :: s6 + real(wp),intent(in) :: rcov(:) + real(wp),intent(in) :: rvdw(:) + logical,intent(out) :: lcutoff(n,n) + real(wp),intent(in) :: rcut + + integer :: i,j + real(wp) :: xij,yij,zij,rij2,r0,d0 + real(wp) :: gmm + real(wp) :: c6i,c6j,c6ij,rv + real(wp) :: hxx,hxy,hxz,hyy,hyz,hzz + real(wp) :: vdw(3,3) + +!! ------------------------------------------------------------------------ +! Hessian for stretch +!! ------------------------------------------------------------------------ + stretch_iAt: do i = 1,n + + stretch_jAt: do j = 1,i-1 + + ! save for later + lcutoff(i,j) = rcutoff(xyz,i,j,rcut) + lcutoff(j,i) = lcutoff(i,j) + + xij = xyz(1,i)-xyz(1,j) + yij = xyz(2,i)-xyz(2,j) + zij = xyz(3,i)-xyz(3,j) + rij2 = xij**2+yij**2+zij**2 + r0 = rcov(at(i))+rcov(at(j)) + d0 = rvdw(at(i))+rvdw(at(j)) + + !cccccc vdwx ccccccccccccccccccccccccccccccccc + c6i = c6(at(i)) + c6j = c6(at(j)) + c6ij = sqrt(c6i*c6j) + rv = (vander(at(i))+vander(at(j)))*aatoau + + call getvdwxx(xij,yij,zij,c6ij,s6,rv,vdw(1,1)) + call getvdwxy(xij,yij,zij,c6ij,s6,rv,vdw(1,2)) + call getvdwxy(xij,zij,yij,c6ij,s6,rv,vdw(1,3)) + call getvdwxx(yij,xij,zij,c6ij,s6,rv,vdw(2,2)) + call getvdwxy(yij,zij,xij,c6ij,s6,rv,vdw(2,3)) + call getvdwxx(zij,xij,yij,c6ij,s6,rv,vdw(3,3)) + !cccccc ende vdwx ccccccccccccccccccccccccccccccc + + gmm = kr*fk_swart(1.0_wp,r0,rij2) & + +kr*kd*fk_vdw(5.0_wp,d0,rij2) + + !gmm = max(gmm,min_fk) + + hxx = gmm*xij*xij/rij2-vdw(1,1) + hxy = gmm*xij*yij/rij2-vdw(1,2) + hxz = gmm*xij*zij/rij2-vdw(1,3) + hyy = gmm*yij*yij/rij2-vdw(2,2) + hyz = gmm*yij*zij/rij2-vdw(2,3) + hzz = gmm*zij*zij/rij2-vdw(3,3) + + ! save diagonal elements for atom i + hess(ind(1,i,1,i)) = hess(ind(1,i,1,i))+hxx + hess(ind(2,i,1,i)) = hess(ind(2,i,1,i))+hxy + hess(ind(2,i,2,i)) = hess(ind(2,i,2,i))+hyy + hess(ind(3,i,1,i)) = hess(ind(3,i,1,i))+hxz + hess(ind(3,i,2,i)) = hess(ind(3,i,2,i))+hyz + hess(ind(3,i,3,i)) = hess(ind(3,i,3,i))+hzz + ! save elements between atom i and atom j + hess(ind(1,i,1,j)) = hess(ind(1,i,1,j))-hxx + hess(ind(1,i,2,j)) = hess(ind(1,i,2,j))-hxy + hess(ind(1,i,3,j)) = hess(ind(1,i,3,j))-hxz + hess(ind(2,i,1,j)) = hess(ind(2,i,1,j))-hxy + hess(ind(2,i,2,j)) = hess(ind(2,i,2,j))-hyy + hess(ind(2,i,3,j)) = hess(ind(2,i,3,j))-hyz + hess(ind(3,i,1,j)) = hess(ind(3,i,1,j))-hxz + hess(ind(3,i,2,j)) = hess(ind(3,i,2,j))-hyz + hess(ind(3,i,3,j)) = hess(ind(3,i,3,j))-hzz + ! save diagonal elements for atom j + hess(ind(1,j,1,j)) = hess(ind(1,j,1,j))+hxx + hess(ind(2,j,1,j)) = hess(ind(2,j,1,j))+hxy + hess(ind(2,j,2,j)) = hess(ind(2,j,2,j))+hyy + hess(ind(3,j,1,j)) = hess(ind(3,j,1,j))+hxz + hess(ind(3,j,2,j)) = hess(ind(3,j,2,j))+hyz + hess(ind(3,j,3,j)) = hess(ind(3,j,3,j))+hzz + + end do stretch_jAt + end do stretch_iAt + + end subroutine mh_swart_stretch + + pure subroutine mh_swart_bend(n,at,xyz,hess,kf,kd,rcov,rvdw,lcutoff) + implicit none + + integer,intent(in) :: n + integer,intent(in) :: at(n) + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) + real(wp),intent(in) :: kf + real(wp),intent(in) :: kd + real(wp),intent(in) :: rcov(:) + real(wp),intent(in) :: rvdw(:) + logical,intent(in) :: lcutoff(n,n) + + integer :: i,j,m,ic,jc,ii + real(wp),parameter :: rzero = 1.0e-10_wp + real(wp) :: xij,yij,zij,rij2,rrij,r1 + real(wp) :: xmi,ymi,zmi,rmi2,rmi,r0mi,d0mj,gmi + real(wp) :: xmj,ymj,zmj,rmj2,rmj,r0mj,d0mi,gmj + real(wp) :: test,gij,rl2,rl,rmidotrmj + real(wp) :: sinphi,cosphi,costhetax,costhetay,costhetaz + real(wp) :: alpha + real(wp) :: si(3),sj(3),sm(3),x(2),y(2),z(2) + +!! ------------------------------------------------------------------------ +! Hessian for bending +!! ------------------------------------------------------------------------ + bend_mAt: do m = 1,n + bend_iAt: do i = 1,n + if (i .eq. m) cycle bend_iAt + if (lcutoff(i,m)) cycle bend_iAt + + xmi = (xyz(1,i)-xyz(1,m)) + ymi = (xyz(2,i)-xyz(2,m)) + zmi = (xyz(3,i)-xyz(3,m)) + rmi2 = xmi**2+ymi**2+zmi**2 + rmi = sqrt(rmi2) + r0mi = rcov(at(m))+rcov(at(i)) + d0mi = rvdw(at(m))+rvdw(at(i)) + + bend_jAt: do j = 1,i-1 + if (j .eq. m) cycle bend_jAt + if (lcutoff(j,i)) cycle bend_jAt + if (lcutoff(j,m)) cycle bend_jAt + + xmj = (xyz(1,j)-xyz(1,m)) + ymj = (xyz(2,j)-xyz(2,m)) + zmj = (xyz(3,j)-xyz(3,m)) + rmj2 = xmj**2+ymj**2+zmj**2 + rmj = sqrt(rmj2) + r0mj = rcov(at(m))+rcov(at(j)) + d0mj = rvdw(at(m))+rvdw(at(j)) + + ! test if zero angle + test = xmi*xmj+ymi*ymj+zmi*zmj + test = test/(rmi*rmj) + if (abs(test-1.0_wp) .lt. 1.0e-12_wp) cycle bend_jAt + + xij = (xyz(1,j)-xyz(1,i)) + yij = (xyz(2,j)-xyz(2,i)) + zij = (xyz(3,j)-xyz(3,i)) + rij2 = xij**2+yij**2+zij**2 + rrij = sqrt(rij2) + + gmi = fk_swart(1.0_wp,r0mi,rmi2) & + +0.5_wp*kd*fk_vdw(5.0_wp,d0mi,rmi2) + gmj = fk_swart(1.0_wp,r0mj,rmj2) & + +0.5_wp*kd*fk_vdw(5.0_wp,d0mj,rmj2) + + gij = kf*gmi*gmj + + rl2 = (ymi*zmj-zmi*ymj)**2+(zmi*xmj-xmi*zmj)**2+(xmi*ymj-ymi*xmj)**2 + + if (rl2 .lt. 1.e-14_wp) then + rl = 0.0_wp + else + rl = sqrt(rl2) + end if + + !gij = max(gij,min_fk) + + if ((rmj .gt. rzero).and.(rmi .gt. rzero).and.(rrij .gt. rzero)) then + sinphi = rl/(rmj*rmi) + rmidotrmj = xmi*xmj+ymi*ymj+zmi*zmj + cosphi = rmidotrmj/(rmj*rmi) + ! none linear case + if (sinphi .gt. rzero) then + si(1) = (xmi/rmi*cosphi-xmj/rmj)/(rmi*sinphi) + si(2) = (ymi/rmi*cosphi-ymj/rmj)/(rmi*sinphi) + si(3) = (zmi/rmi*cosphi-zmj/rmj)/(rmi*sinphi) + sj(1) = (cosphi*xmj/rmj-xmi/rmi)/(rmj*sinphi) + sj(2) = (cosphi*ymj/rmj-ymi/rmi)/(rmj*sinphi) + sj(3) = (cosphi*zmj/rmj-zmi/rmi)/(rmj*sinphi) + sm(1) = -si(1)-sj(1) + sm(2) = -si(2)-sj(2) + sm(3) = -si(3)-sj(3) + do ic = 1,3 + do jc = 1,3 + if (m .gt. i) then + hess(ind(ic,m,jc,i)) = hess(ind(ic,m,jc,i)) & + +gij*sm(ic)*si(jc) + else + hess(ind(ic,i,jc,m)) = hess(ind(ic,i,jc,m)) & + +gij*si(ic)*sm(jc) + end if + if (m .gt. j) then + hess(ind(ic,m,jc,j)) = hess(ind(ic,m,jc,j)) & + +gij*sm(ic)*sj(jc) + else + hess(ind(ic,j,jc,m)) = hess(ind(ic,j,jc,m)) & + +gij*sj(ic)*sm(jc) + end if + if (i .gt. j) then + hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j)) & + +gij*si(ic)*sj(jc) + else + hess(ind(ic,j,jc,i)) = hess(ind(ic,j,jc,i)) & + +gij*sj(ic)*si(jc) + end if + end do + end do + do ic = 1,3 + do jc = 1,ic + hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+gij*si(ic)*si(jc) + hess(ind(ic,m,jc,m)) = hess(ind(ic,m,jc,m))+gij*sm(ic)*sm(jc) + hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+gij*sj(ic)*sj(jc) + end do + end do + else + ! linear case + if ((abs(ymi) .gt. rzero).or.(abs(xmi) .gt. rzero)) then + x(1) = -ymi + y(1) = xmi + z(1) = 0.0_wp + x(2) = -xmi*zmi + y(2) = -ymi*zmi + z(2) = xmi*xmi+ymi*ymi + else + x(1) = 1.0_wp + y(1) = 0.0_wp + z(1) = 0.0_wp + x(2) = 0.0_wp + y(2) = 1.0_wp + z(2) = 0.0_wp + end if + do ii = 1,2 + r1 = sqrt(x(ii)**2+y(ii)**2+z(ii)**2) + costhetax = x(ii)/r1 + costhetay = y(ii)/r1 + costhetaz = z(ii)/r1 + si(1) = -costhetax/rmi + si(2) = -costhetay/rmi + si(3) = -costhetaz/rmi + sj(1) = -costhetax/rmj + sj(2) = -costhetay/rmj + sj(3) = -costhetaz/rmj + sm(1) = -(si(1)+sj(1)) + sm(2) = -(si(2)+sj(2)) + sm(3) = -(si(3)+sj(3)) + ! + do ic = 1,3 + do jc = 1,3 + if (m .gt. i) then + hess(ind(ic,m,jc,i)) = hess(ind(ic,m,jc,i)) & + +gij*sm(ic)*si(jc) + else + hess(ind(ic,i,jc,m)) = hess(ind(ic,i,jc,m)) & + +gij*si(ic)*sm(jc) + end if + if (m .gt. j) then + hess(ind(ic,m,jc,j)) = hess(ind(ic,m,jc,j)) & + +gij*sm(ic)*sj(jc) + else + hess(ind(ic,j,jc,m)) = hess(ind(ic,j,jc,m)) & + +gij*sj(ic)*sm(jc) + end if + if (i .gt. j) then + hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j)) & + +gij*si(ic)*sj(jc) + else + hess(ind(ic,j,jc,i)) = hess(ind(ic,j,jc,i)) & + +gij*sj(ic)*si(jc) + end if + end do + end do + do ic = 1,3 + do jc = 1,ic + hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i)) & + +gij*si(ic)*si(jc) + hess(ind(ic,m,jc,m)) = hess(ind(ic,m,jc,m)) & + +gij*sm(ic)*sm(jc) + hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j)) & + +gij*sj(ic)*sj(jc) + end do + end do + end do + + end if + end if + + end do bend_jAt + end do bend_iAt + end do bend_mAt + + end subroutine mh_swart_bend + + pure subroutine mh_swart_torsion(n,at,xyz,hess,kt,kd,rcov,rvdw,lcutoff) + implicit none + + integer,intent(in) :: n + integer,intent(in) :: at(n) + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) + real(wp),intent(in) :: kt + real(wp),intent(in) :: kd + real(wp),intent(in) :: rcov(:) + real(wp),intent(in) :: rvdw(:) + logical,intent(in) :: lcutoff(n,n) + + integer :: i,j,k,l,ic,jc,ij,kl +! allow only angles in the range of 35-145 + real(wp),parameter :: a35 = (35.0d0/180.d0)*pi + real(wp),parameter :: cosfi_max = cos(a35) + real(wp) :: txyz(3,4),c(3,4) + real(wp) :: rij(3),rij0,aij,rij2,d0ij,gij + real(wp) :: rjk(3),rjk0,ajk,rjk2,d0jk,gjk + real(wp) :: rkl(3),rkl0,akl,rkl2,d0kl,gkl + real(wp) :: cosfi2,cosfi3,cosfi4 + real(wp) :: beta,tij,tau + real(wp) :: si(3),sj(3),sk(3),sl(3) + +!! ------------------------------------------------------------------------ +! Hessian for torsion +!! ------------------------------------------------------------------------ + torsion_jAt: do j = 1,n + txyz(:,2) = xyz(:,j) + torsion_kAt: do k = 1,n + if (k .eq. j) cycle torsion_kAt + if (lcutoff(k,j)) cycle torsion_kAt + txyz(:,3) = xyz(:,k) + torsion_iAt: do i = 1,n + ij = n*(j-1)+i + if (i .eq. j) cycle torsion_iAt + if (i .eq. k) cycle torsion_iAt + if (lcutoff(i,k)) cycle torsion_iAt + if (lcutoff(i,j)) cycle torsion_iAt + + txyz(:,1) = xyz(:,i) + torsion_lAt: do l = 1,n + kl = n*(l-1)+k + if (ij .le. kl) cycle torsion_lAt + if (l .eq. i) cycle torsion_lAt + if (l .eq. j) cycle torsion_lAt + if (l .eq. k) cycle torsion_lAt +! + if (lcutoff(l,i)) cycle torsion_lAt + if (lcutoff(l,k)) cycle torsion_lAt + if (lcutoff(l,j)) cycle torsion_lAt + + txyz(:,4) = xyz(:,l) + + rij = xyz(:,i)-xyz(:,j) + d0ij = rvdw(at(i))+rvdw(at(j)) + rij0 = rcov(at(i))+rcov(at(j)) + + rjk = xyz(:,j)-xyz(:,k) + d0jk = rvdw(at(j))+rvdw(at(k)) + rjk0 = rcov(at(j))+rcov(at(k)) + + rkl = xyz(:,k)-xyz(:,l) + d0kl = rvdw(at(k))+rvdw(at(l)) + rkl0 = rcov(at(k))+rcov(at(l)) + + rij2 = sum(rij**2) + rjk2 = sum(rjk**2) + rkl2 = sum(rjk**2) + + cosfi2 = dot_product(rij,rjk)/sqrt(rij2*rjk2) + if (abs(cosfi2) .gt. cosfi_max) cycle + cosfi3 = dot_product(rkl,rjk)/sqrt(rkl2*rjk2) + if (abs(cosfi3) .gt. cosfi_max) cycle + + gij = fk_swart(1.0_wp,rij0,rij2) & + +0.5_wp*kd*fk_vdw(5.0_wp,d0ij,rij2) + gjk = fk_swart(1.0_wp,rjk0,rjk2) & + +0.5_wp*kd*fk_vdw(5.0_wp,d0jk,rjk2) + gkl = fk_swart(1.0_wp,rkl0,rkl2) & + +0.5_wp*kd*fk_vdw(5.0_wp,d0kl,rkl2) + + tij = kt*gij*gjk*gkl + + !tij = max(tij,10*min_fk) + + call trsn2(txyz,tau,c) + si = c(:,1) + sj = c(:,2) + sk = c(:,3) + sl = c(:,4) + + ! off diagonal block + do ic = 1,3 + do jc = 1,3 + hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j))+tij*si(ic)*sj(jc) + hess(ind(ic,i,jc,k)) = hess(ind(ic,i,jc,k))+tij*si(ic)*sk(jc) + hess(ind(ic,i,jc,l)) = hess(ind(ic,i,jc,l))+tij*si(ic)*sl(jc) + hess(ind(ic,j,jc,k)) = hess(ind(ic,j,jc,k))+tij*sj(ic)*sk(jc) + hess(ind(ic,j,jc,l)) = hess(ind(ic,j,jc,l))+tij*sj(ic)*sl(jc) + hess(ind(ic,k,jc,l)) = hess(ind(ic,k,jc,l))+tij*sk(ic)*sl(jc) + end do + end do + + ! diagonal block + do ic = 1,3 + do jc = 1,ic + hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+tij*si(ic)*si(jc) + hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+tij*sj(ic)*sj(jc) + hess(ind(ic,k,jc,k)) = hess(ind(ic,k,jc,k))+tij*sk(ic)*sk(jc) + hess(ind(ic,l,jc,l)) = hess(ind(ic,l,jc,l))+tij*sl(ic)*sl(jc) + end do + end do + + end do torsion_lAt + end do torsion_iAt + end do torsion_kAt + end do torsion_jAt + + end subroutine mh_swart_torsion + + pure subroutine mh_swart_outofp(n,at,xyz,hess,ko,kd,rcov,rvdw,lcutoff) + implicit none + + integer,intent(in) :: n + integer,intent(in) :: at(n) + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) + real(wp),intent(in) :: ko + real(wp),intent(in) :: kd + real(wp),intent(in) :: rcov(:) + real(wp),intent(in) :: rvdw(:) + logical,intent(in) :: lcutoff(n,n) + + integer :: i,ir,j,jr,k,kr,l,lr,ic,jc + real(wp) :: txyz(3,4),c(3,4) + real(wp) :: rij(3),rij0,d0ij,rij2,gij + real(wp) :: rik(3),rik0,d0ik,rik2,gik + real(wp) :: ril(3),ril0,d0il,ril2,gil + real(wp) :: cosfi2,cosfi3,cosfi4 + real(wp) :: beta,tij,tau + real(wp) :: si(3),sj(3),sk(3),sl(3) + +!! ------------------------------------------------------------------------ +! Hessian for out-of-plane +!! ------------------------------------------------------------------------ + outofplane_iAt: do i = 1,n + txyz(:,4) = xyz(:,i) + outofplane_jAt: do j = 1,n + if (j .eq. i) cycle outofplane_jAt + if (lcutoff(j,i)) cycle outofplane_jAt + txyz(:,1) = xyz(:,j) + outofplane_kAt: do k = 1,n + if (i .eq. k) cycle outofplane_kAt + if (j .eq. k) cycle outofplane_kat + if (lcutoff(k,i)) cycle outofplane_kAt + if (lcutoff(k,j)) cycle outofplane_kAt + txyz(:,2) = xyz(:,k) + outofplane_lAt: do l = 1,n + txyz(:,3) = xyz(:,l) + if (l .eq. i) cycle outofplane_lAt + if (l .eq. j) cycle outofplane_lAt + if (l .eq. k) cycle outofplane_lAt + if (lcutoff(l,i)) cycle outofplane_lAt + if (lcutoff(l,k)) cycle outofplane_lAt + if (lcutoff(l,j)) cycle outofplane_lAt + + rij = xyz(:,i)-xyz(:,j) + rij0 = rcov(at(i))+rcov(at(j)) + d0ij = rvdw(at(i))+rvdw(at(j)) + + rik = xyz(:,i)-xyz(:,k) + rik0 = rcov(at(i))+rcov(at(k)) + d0ik = rvdw(at(i))+rvdw(at(k)) + + ril = xyz(:,i)-xyz(:,l) + ril0 = rcov(at(i))+rcov(at(l)) + d0il = rvdw(at(i))+rvdw(at(l)) + + rij2 = sum(rij**2) + rik2 = sum(rik**2) + ril2 = sum(ril**2) + + cosfi2 = dot_product(rij,rik)/sqrt(rij2*rik2) + if (abs(abs(cosfi2)-1.0_wp) .lt. 1.0e-1_wp) cycle + cosfi3 = dot_product(rij,ril)/sqrt(rij2*ril2) + if (abs(abs(cosfi3)-1.0_wp) .lt. 1.0e-1_wp) cycle + cosfi4 = dot_product(rik,ril)/sqrt(rik2*ril2) + if (abs(abs(cosfi4)-1.0_wp) .lt. 1.0e-1_wp) cycle + + gij = fk_swart(1.0_wp,rij0,rij2) & + +0.5_wp*kd*fk_vdw(5.0_wp,d0ij,rij2) + gik = fk_swart(1.0_wp,rik0,rik2) & + +0.5_wp*kd*fk_vdw(5.0_wp,d0ik,rik2) + gil = fk_swart(1.0_wp,ril0,ril2) & + +0.5_wp*kd*fk_vdw(5.0_wp,d0il,ril2) + + tij = ko*gij*gik*gil + + !tij = max(tij,10*min_fk) + + call outofp2(xyz,tau,c) + If (abs(tau) .gt. 45.0d0*(pi/180.d0)) cycle + + si = c(:,4) + sj = c(:,1) + sk = c(:,2) + sl = c(:,3) + + ! off diagonal block + do ic = 1,3 + do jc = 1,3 + hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j))+tij*si(ic)*sj(jc) + hess(ind(ic,i,jc,k)) = hess(ind(ic,i,jc,k))+tij*si(ic)*sk(jc) + hess(ind(ic,i,jc,l)) = hess(ind(ic,i,jc,l))+tij*si(ic)*sl(jc) + hess(ind(ic,j,jc,k)) = hess(ind(ic,j,jc,k))+tij*sj(ic)*sk(jc) + hess(ind(ic,j,jc,l)) = hess(ind(ic,j,jc,l))+tij*sj(ic)*sl(jc) + hess(ind(ic,k,jc,l)) = hess(ind(ic,k,jc,l))+tij*sk(ic)*sl(jc) + end do + end do + + ! diagonal block + do ic = 1,3 + do jc = 1,ic + hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+tij*si(ic)*si(jc) + hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+tij*sj(ic)*sj(jc) + hess(ind(ic,k,jc,k)) = hess(ind(ic,k,jc,k))+tij*sk(ic)*sk(jc) + hess(ind(ic,l,jc,l)) = hess(ind(ic,l,jc,l))+tij*sl(ic)*sl(jc) + end do + end do + + end do outofplane_lAt + end do outofplane_kAt + end do outofplane_jAt + end do outofplane_iAt + + end subroutine mh_swart_outofp + +!========================================================================================! +!########################################################################################! +!========================================================================================! + + subroutine mh_lindh(xyz,n,hess,at,modh) +!************************************************************************** +!* Lindh's Model Hessian updated around 2007 +!* ------------------------------------------------------------------------ +!* R. Lindh, personal communication. +!* +!* gij = exp[αij(R²ref - R²ij)] +!* dij = exp[-4·(Rvdw - Rij)²] +!* kij = rkr·gij + rkd·dij +!* kijk = rkf·(gij+½·rkd/rkr·dij)·(gjk+½·rkd/rkr·djk) +!* kijkl = rkt·(gij+½·rkd/rkr·dij)·(gjk+½·rkd/rkr·djk)·(gkl+½·rkd/rkr·dkl) +!* +!* parameters tweaked by R. Lindh in 2007: +!* rkr = 0.45, rkf = 0.10, rkt = 0.0025, rko = 0.16, rkd = 0.05 +!* +!* the reference distances are divided by rows in the PSE: +!* rAv: 1 2 3 aAv: 1 2 3 +!* 1 1.3500 2.1000 2.5300 1 1.0000 0.3949 0.3949 +!* 2 2.1000 2.8700 3.8000 2 0.3949 0.2800 0.1200 +!* 3 2.5300 3.8000 4.5000 3 0.3949 0.1200 0.0600 +!* +!* dAv: 1 2 3 +!* 1 0.0000 3.6000 3.6000 +!* 2 3.6000 5.3000 5.3000 +!* 3 3.6000 5.3000 5.3000 +!* +!************************************************************************** + implicit none + + integer,intent(in) :: n + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(out) :: hess((3*n)*(3*n+1)/2) + integer,intent(in) :: at(n) + type(mhparam),intent(in) :: modh + + real(wp),parameter :: rAv(3,3) = reshape( & + (/1.3500_wp,2.1000_wp,2.5300_wp, & + 2.1000_wp,2.8700_wp,3.8000_wp, & + 2.5300_wp,3.8000_wp,4.5000_wp/),shape(rAv)) + real(wp),parameter :: aAv(3,3) = reshape( & + (/1.0000_wp,0.3949_wp,0.3949_wp, & + 0.3949_wp,0.2800_wp,0.1200_wp, & + 0.3949_wp,0.1200_wp,0.0600_wp/),shape(aAv)) + real(wp),parameter :: dAv(3,3) = reshape( & + (/0.0000_wp,3.6000_wp,3.6000_wp, & + 3.6000_wp,5.3000_wp,5.3000_wp, & + 3.6000_wp,5.3000_wp,5.3000_wp/),shape(aAv)) + + integer :: n3 + real(wp) :: kd + logical,allocatable :: lcutoff(:,:) + !type(chrg_parameter) :: chrgeq + + allocate (lcutoff(n,n),source=.false.) + + n3 = 3*n + hess = 0.0d0 + +! the dispersion force constant is used relative to the stretch force constant + kd = modh%kd/modh%kr + + call mh_lindh_stretch(n,at,xyz,hess,modh%kr,kd,modh%s6,aav,rav,dav,lcutoff,modh%rcut) + if (modh%kf .ne. 0.0_wp) & + call mh_lindh_bend(n,at,xyz,hess,modh%kf,kd,aav,rav,dav,lcutoff) + if (modh%kt .ne. 0.0_wp) & + call mh_lindh_torsion(n,at,xyz,hess,modh%kt,kd,aav,rav,dav,lcutoff) + if (modh%ko .ne. 0.0_wp) & + call mh_lindh_outofp(n,at,xyz,hess,modh%ko,0.0_wp,aav,rav,dav,lcutoff) + if (modh%kq .ne. 0.0_wp) then + !call new_charge_model_2019(chrgeq,n,at) + call mh_eeq(n,at,xyz,0.0_wp,modh%kq,hess) + end if + + end subroutine mh_lindh + + subroutine mh_lindh_d2(xyz,n,hess,at,modh) +!************************************************************************** +!* Lindh's Model Hessian augmented with D2 +!* ------------------------------------------------------------------------ +!* Implemented after: +!* Lindh, R., Bernhardsson, A., Karlström, G., & Malmqvist, P.-Å. (1995). +!* On the use of a Hessian model function in molecular geometry optimizations. +!* Chem. Phys. Lett., 241(4), 423–428. doi:10.1016/0009-2614(95)00646-l +!* +!* gij = exp[αij(R²ref - R²ij)] +!* kij = rkr·gij +!* kijk = rkf·gij·gjk +!* kijkl = rkt·gij·gjk·gkl +!* +!* Originally Lindh proposed (we tweaked those a little bit): +!* rkr = 0.45, rkf = 0.15, rkt = 0.005 +!* +!* the reference distances are divided by rows in the PSE: +!* rAv: 1 2 3 aAv: 1 2 3 +!* 1 1.3500 2.1000 2.5300 1 1.0000 0.3949 0.3949 +!* 2 2.1000 2.8700 3.4000 2 0.3949 0.2800 0.2800 +!* 3 2.5300 3.4000 3.4000 3 0.3949 0.2800 0.2800 +!* +!* This Hessian is additionally augmented with D2, please note that D2 +!* is not implemented in atomic units and requires some magical conversion +!* factor somewhere hidden in the implementation below. +!************************************************************************* + implicit none + + integer,intent(in) :: n + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(out) :: hess((3*n)*(3*n+1)/2) + integer,intent(in) :: at(n) + type(mhparam),intent(in) :: modh + + real(wp),parameter :: rAv(3,3) = reshape( & + (/1.3500_wp,2.1000_wp,2.5300_wp, & + 2.1000_wp,2.8700_wp,3.4000_wp, & + 2.5300_wp,3.4000_wp,3.4000_wp/),shape(rAv)) + real(wp),parameter :: aAv(3,3) = reshape( & + (/1.0000_wp,0.3949_wp,0.3949_wp, & + 0.3949_wp,0.2800_wp,0.2800_wp, & + 0.3949_wp,0.2800_wp,0.2800_wp/),shape(aAv)) + real(wp),parameter :: dAv(3,3) = reshape( & + (/0.0000_wp,0.0000_wp,0.0000_wp, & + 0.0000_wp,0.0000_wp,0.0000_wp, & + 0.0000_wp,0.0000_wp,0.0000_wp/),shape(aAv)) + + integer :: n3 + real(wp) :: kd + logical,allocatable :: lcutoff(:,:) + + allocate (lcutoff(n,n),source=.false.) + + n3 = 3*n + hess = 0.0d0 + +! the dispersion force constant is used relative to the stretch force constant + kd = modh%kd/modh%kr + + call mh_lindh_stretch(n,at,xyz,hess,modh%kr,kd,modh%s6,aav,rav,dav,lcutoff,modh%rcut) + if (modh%kf .ne. 0.0_wp) & + call mh_lindh_bend(n,at,xyz,hess,modh%kf,kd,aav,rav,dav,lcutoff) + if (modh%kt .ne. 0.0_wp) & + call mh_lindh_torsion(n,at,xyz,hess,modh%kt,kd,aav,rav,dav,lcutoff) + if (modh%ko .ne. 0.0_wp) & + call mh_lindh_outofp(n,at,xyz,hess,modh%ko,kd,aav,rav,dav,lcutoff) + if (modh%kq .ne. 0.0_wp) then + call mh_eeq(n,at,xyz,0.0_wp,modh%kq,hess) + end if + end subroutine mh_lindh_d2 + + pure subroutine mh_lindh_stretch(n,at,xyz,hess,kr,kd,s6,aav,rav,dav,lcutoff,rcut) + implicit none + + integer,intent(in) :: n + integer,intent(in) :: at(n) + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) + real(wp),intent(in) :: kr + real(wp),intent(in) :: kd + real(wp),intent(in) :: s6 + real(wp),intent(in) :: aav(3,3) + real(wp),intent(in) :: rav(3,3) + real(wp),intent(in) :: dav(3,3) + logical,intent(out) :: lcutoff(n,n) + real(wp),intent(in) :: rcut + + integer :: i,ir,j,jr + real(wp) :: xij,yij,zij,rij2,r0,d0 + real(wp) :: alpha,gmm + real(wp) :: c6i,c6j,c6ij,rv + real(wp) :: hxx,hxy,hxz,hyy,hyz,hzz + real(wp) :: vdw(3,3) + +!! ------------------------------------------------------------------------ +! Hessian for stretch +!! ------------------------------------------------------------------------ + stretch_iAt: do i = 1,n + ir = itabrow(at(i)) + + stretch_jAt: do j = 1,i-1 + jr = itabrow(at(j)) + + ! save for later + lcutoff(i,j) = rcutoff(xyz,i,j,rcut) + lcutoff(j,i) = lcutoff(i,j) + + xij = xyz(1,i)-xyz(1,j) + yij = xyz(2,i)-xyz(2,j) + zij = xyz(3,i)-xyz(3,j) + rij2 = xij**2+yij**2+zij**2 + r0 = rav(ir,jr) + d0 = dav(ir,jr) + alpha = aav(ir,jr) + + !cccccc vdwx ccccccccccccccccccccccccccccccccc + c6i = c6(at(i)) + c6j = c6(at(j)) + c6ij = sqrt(c6i*c6j) + rv = (vander(at(i))+vander(at(j)))*aatoau + + call getvdwxx(xij,yij,zij,c6ij,s6,rv,vdw(1,1)) + call getvdwxy(xij,yij,zij,c6ij,s6,rv,vdw(1,2)) + call getvdwxy(xij,zij,yij,c6ij,s6,rv,vdw(1,3)) + call getvdwxx(yij,xij,zij,c6ij,s6,rv,vdw(2,2)) + call getvdwxy(yij,zij,xij,c6ij,s6,rv,vdw(2,3)) + call getvdwxx(zij,xij,yij,c6ij,s6,rv,vdw(3,3)) + !cccccc ende vdwx ccccccccccccccccccccccccccccccc + + gmm = kr*fk_lindh(alpha,r0,rij2) & + +kr*kd*fk_vdw(4.0_wp,d0,rij2) + + !gmm = max(gmm,min_fk) + + hxx = gmm*xij*xij/rij2-vdw(1,1) + hxy = gmm*xij*yij/rij2-vdw(1,2) + hxz = gmm*xij*zij/rij2-vdw(1,3) + hyy = gmm*yij*yij/rij2-vdw(2,2) + hyz = gmm*yij*zij/rij2-vdw(2,3) + hzz = gmm*zij*zij/rij2-vdw(3,3) + + ! save diagonal elements for atom i + hess(ind(1,i,1,i)) = hess(ind(1,i,1,i))+hxx + hess(ind(2,i,1,i)) = hess(ind(2,i,1,i))+hxy + hess(ind(2,i,2,i)) = hess(ind(2,i,2,i))+hyy + hess(ind(3,i,1,i)) = hess(ind(3,i,1,i))+hxz + hess(ind(3,i,2,i)) = hess(ind(3,i,2,i))+hyz + hess(ind(3,i,3,i)) = hess(ind(3,i,3,i))+hzz + ! save elements between atom i and atom j + hess(ind(1,i,1,j)) = hess(ind(1,i,1,j))-hxx + hess(ind(1,i,2,j)) = hess(ind(1,i,2,j))-hxy + hess(ind(1,i,3,j)) = hess(ind(1,i,3,j))-hxz + hess(ind(2,i,1,j)) = hess(ind(2,i,1,j))-hxy + hess(ind(2,i,2,j)) = hess(ind(2,i,2,j))-hyy + hess(ind(2,i,3,j)) = hess(ind(2,i,3,j))-hyz + hess(ind(3,i,1,j)) = hess(ind(3,i,1,j))-hxz + hess(ind(3,i,2,j)) = hess(ind(3,i,2,j))-hyz + hess(ind(3,i,3,j)) = hess(ind(3,i,3,j))-hzz + ! save diagonal elements for atom j + hess(ind(1,j,1,j)) = hess(ind(1,j,1,j))+hxx + hess(ind(2,j,1,j)) = hess(ind(2,j,1,j))+hxy + hess(ind(2,j,2,j)) = hess(ind(2,j,2,j))+hyy + hess(ind(3,j,1,j)) = hess(ind(3,j,1,j))+hxz + hess(ind(3,j,2,j)) = hess(ind(3,j,2,j))+hyz + hess(ind(3,j,3,j)) = hess(ind(3,j,3,j))+hzz + + end do stretch_jAt + end do stretch_iAt + + end subroutine mh_lindh_stretch + + pure subroutine mh_lindh_bend(n,at,xyz,hess,kf,kd,aav,rav,dav,lcutoff) + implicit none + + integer,intent(in) :: n + integer,intent(in) :: at(n) + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) + real(wp),intent(in) :: kf + real(wp),intent(in) :: kd + real(wp),intent(in) :: aav(3,3) + real(wp),intent(in) :: rav(3,3) + real(wp),intent(in) :: dav(3,3) + logical,intent(in) :: lcutoff(n,n) + + integer :: i,ir,j,jr,m,mr,ic,jc,ii + real(wp),parameter :: rzero = 1.0e-10_wp + real(wp) :: xij,yij,zij,rij2,rrij,r1 + real(wp) :: xmi,ymi,zmi,rmi2,rmi,r0mi,ami,d0mj,gmi + real(wp) :: xmj,ymj,zmj,rmj2,rmj,r0mj,amj,d0mi,gmj + real(wp) :: test,gij,rl2,rl,rmidotrmj + real(wp) :: sinphi,cosphi,costhetax,costhetay,costhetaz + real(wp) :: alpha + real(wp) :: si(3),sj(3),sm(3),x(2),y(2),z(2) + +!! ------------------------------------------------------------------------ +! Hessian for bending +!! ------------------------------------------------------------------------ + bend_mAt: do m = 1,n + mr = itabrow(at(m)) + bend_iAt: do i = 1,n + if (i .eq. m) cycle bend_iAt + ir = itabrow(at(i)) + if (lcutoff(i,m)) cycle bend_iAt + + xmi = (xyz(1,i)-xyz(1,m)) + ymi = (xyz(2,i)-xyz(2,m)) + zmi = (xyz(3,i)-xyz(3,m)) + rmi2 = xmi**2+ymi**2+zmi**2 + rmi = sqrt(rmi2) + r0mi = rav(mr,ir) + d0mi = dav(mr,ir) + ami = aav(mr,ir) + + bend_jAt: do j = 1,i-1 + if (j .eq. m) cycle bend_jAt + jr = itabrow(at(j)) + if (lcutoff(j,i)) cycle bend_jAt + if (lcutoff(j,m)) cycle bend_jAt + + xmj = (xyz(1,j)-xyz(1,m)) + ymj = (xyz(2,j)-xyz(2,m)) + zmj = (xyz(3,j)-xyz(3,m)) + rmj2 = xmj**2+ymj**2+zmj**2 + rmj = sqrt(rmj2) + r0mj = rav(mr,jr) + d0mj = dav(mr,jr) + amj = aav(mr,jr) + + ! test if zero angle + test = xmi*xmj+ymi*ymj+zmi*zmj + test = test/(rmi*rmj) + if (abs(test-1.0_wp) .lt. 1.0e-12_wp) cycle bend_jAt + + xij = (xyz(1,j)-xyz(1,i)) + yij = (xyz(2,j)-xyz(2,i)) + zij = (xyz(3,j)-xyz(3,i)) + rij2 = xij**2+yij**2+zij**2 + rrij = sqrt(rij2) + + gmi = fk_lindh(ami,r0mi,rmi2) & + +0.5_wp*kd*fk_vdw(4.0_wp,d0mi,rmi2) + gmj = fk_lindh(amj,r0mj,rmj2) & + +0.5_wp*kd*fk_vdw(4.0_wp,d0mj,rmj2) + + gij = kf*gmi*gmj + + rl2 = (ymi*zmj-zmi*ymj)**2+(zmi*xmj-xmi*zmj)**2+(xmi*ymj-ymi*xmj)**2 + + if (rl2 .lt. 1.e-14_wp) then + rl = 0.0_wp + else + rl = sqrt(rl2) + end if + + !gij = max(gij,min_fk) + + if ((rmj .gt. rzero).and.(rmi .gt. rzero).and.(rrij .gt. rzero)) then + sinphi = rl/(rmj*rmi) + rmidotrmj = xmi*xmj+ymi*ymj+zmi*zmj + cosphi = rmidotrmj/(rmj*rmi) + ! none linear case + if (sinphi .gt. rzero) then + si(1) = (xmi/rmi*cosphi-xmj/rmj)/(rmi*sinphi) + si(2) = (ymi/rmi*cosphi-ymj/rmj)/(rmi*sinphi) + si(3) = (zmi/rmi*cosphi-zmj/rmj)/(rmi*sinphi) + sj(1) = (cosphi*xmj/rmj-xmi/rmi)/(rmj*sinphi) + sj(2) = (cosphi*ymj/rmj-ymi/rmi)/(rmj*sinphi) + sj(3) = (cosphi*zmj/rmj-zmi/rmi)/(rmj*sinphi) + sm(1) = -si(1)-sj(1) + sm(2) = -si(2)-sj(2) + sm(3) = -si(3)-sj(3) + do ic = 1,3 + do jc = 1,3 + if (m .gt. i) then + hess(ind(ic,m,jc,i)) = hess(ind(ic,m,jc,i)) & + +gij*sm(ic)*si(jc) + else + hess(ind(ic,i,jc,m)) = hess(ind(ic,i,jc,m)) & + +gij*si(ic)*sm(jc) + end if + if (m .gt. j) then + hess(ind(ic,m,jc,j)) = hess(ind(ic,m,jc,j)) & + +gij*sm(ic)*sj(jc) + else + hess(ind(ic,j,jc,m)) = hess(ind(ic,j,jc,m)) & + +gij*sj(ic)*sm(jc) + end if + if (i .gt. j) then + hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j)) & + +gij*si(ic)*sj(jc) + else + hess(ind(ic,j,jc,i)) = hess(ind(ic,j,jc,i)) & + +gij*sj(ic)*si(jc) + end if + end do + end do + do ic = 1,3 + do jc = 1,ic + hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+gij*si(ic)*si(jc) + hess(ind(ic,m,jc,m)) = hess(ind(ic,m,jc,m))+gij*sm(ic)*sm(jc) + hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+gij*sj(ic)*sj(jc) + end do + end do + else + ! linear case + if ((abs(ymi) .gt. rzero).or.(abs(xmi) .gt. rzero)) then + x(1) = -ymi + y(1) = xmi + z(1) = 0.0_wp + x(2) = -xmi*zmi + y(2) = -ymi*zmi + z(2) = xmi*xmi+ymi*ymi + else + x(1) = 1.0_wp + y(1) = 0.0_wp + z(1) = 0.0_wp + x(2) = 0.0_wp + y(2) = 1.0_wp + z(2) = 0.0_wp + end if + do ii = 1,2 + r1 = sqrt(x(ii)**2+y(ii)**2+z(ii)**2) + costhetax = x(ii)/r1 + costhetay = y(ii)/r1 + costhetaz = z(ii)/r1 + si(1) = -costhetax/rmi + si(2) = -costhetay/rmi + si(3) = -costhetaz/rmi + sj(1) = -costhetax/rmj + sj(2) = -costhetay/rmj + sj(3) = -costhetaz/rmj + sm(1) = -(si(1)+sj(1)) + sm(2) = -(si(2)+sj(2)) + sm(3) = -(si(3)+sj(3)) + ! + do ic = 1,3 + do jc = 1,3 + if (m .gt. i) then + hess(ind(ic,m,jc,i)) = hess(ind(ic,m,jc,i)) & + +gij*sm(ic)*si(jc) + else + hess(ind(ic,i,jc,m)) = hess(ind(ic,i,jc,m)) & + +gij*si(ic)*sm(jc) + end if + if (m .gt. j) then + hess(ind(ic,m,jc,j)) = hess(ind(ic,m,jc,j)) & + +gij*sm(ic)*sj(jc) + else + hess(ind(ic,j,jc,m)) = hess(ind(ic,j,jc,m)) & + +gij*sj(ic)*sm(jc) + end if + if (i .gt. j) then + hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j)) & + +gij*si(ic)*sj(jc) + else + hess(ind(ic,j,jc,i)) = hess(ind(ic,j,jc,i)) & + +gij*sj(ic)*si(jc) + end if + end do + end do + do ic = 1,3 + do jc = 1,ic + hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i)) & + +gij*si(ic)*si(jc) + hess(ind(ic,m,jc,m)) = hess(ind(ic,m,jc,m)) & + +gij*sm(ic)*sm(jc) + hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j)) & + +gij*sj(ic)*sj(jc) + end do + end do + end do + + end if + end if + + end do bend_jAt + end do bend_iAt + end do bend_mAt + + end subroutine mh_lindh_bend + + subroutine mh_lindh_torsion(n,at,xyz,hess,kt,kd,aav,rav,dav,lcutoff) + implicit none + + integer,intent(in) :: n + integer,intent(in) :: at(n) + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) + real(wp),intent(in) :: kt + real(wp),intent(in) :: kd + real(wp),intent(in) :: aav(3,3) + real(wp),intent(in) :: rav(3,3) + real(wp),intent(in) :: dav(3,3) + logical,intent(in) :: lcutoff(n,n) + + integer :: i,ir,j,jr,k,kr,l,lr,ic,jc,ij,kl +! allow only angles in the range of 35-145 + real(wp),parameter :: a35 = (35.0d0/180.d0)*pi + real(wp),parameter :: cosfi_max = cos(a35) + real(wp) :: txyz(3,4),c(3,4) + real(wp) :: rij(3),rij0,aij,rij2,d0ij,gij + real(wp) :: rjk(3),rjk0,ajk,rjk2,d0jk,gjk + real(wp) :: rkl(3),rkl0,akl,rkl2,d0kl,gkl + real(wp) :: cosfi2,cosfi3,cosfi4 + real(wp) :: beta,tij,tau,dum(3,4,3,4) + real(wp) :: si(3),sj(3),sk(3),sl(3) + +!! ------------------------------------------------------------------------ +! Hessian for torsion +!! ------------------------------------------------------------------------ + torsion_jAt: do j = 1,n + jr = itabrow(at(j)) + txyz(:,2) = xyz(:,j) + torsion_kAt: do k = 1,n + if (k .eq. j) cycle torsion_kAt + kr = itabrow(at(k)) + if (lcutoff(k,j)) cycle torsion_kAt + txyz(:,3) = xyz(:,k) + torsion_iAt: do i = 1,n + ij = n*(j-1)+i + if (i .eq. j) cycle torsion_iAt + if (i .eq. k) cycle torsion_iAt + ir = itabrow(at(i)) + if (lcutoff(i,k)) cycle torsion_iAt + if (lcutoff(i,j)) cycle torsion_iAt + + txyz(:,1) = xyz(:,i) + torsion_lAt: do l = 1,n + kl = n*(k-1)+l + if (ij .le. kl) cycle torsion_lAt + if (l .eq. i) cycle torsion_lAt + if (l .eq. j) cycle torsion_lAt + if (l .eq. k) cycle torsion_lAt + lr = itabrow(at(l)) +! + if (lcutoff(l,i)) cycle torsion_lAt + if (lcutoff(l,k)) cycle torsion_lAt + if (lcutoff(l,j)) cycle torsion_lAt + + txyz(:,4) = xyz(:,l) + + rij = xyz(:,i)-xyz(:,j) + d0ij = dav(ir,jr) + rij0 = rav(ir,jr) + aij = aav(ir,jr) + + rjk = xyz(:,j)-xyz(:,k) + d0jk = dav(jr,kr) + rjk0 = rav(jr,kr) + ajk = aav(jr,kr) + + rkl = xyz(:,k)-xyz(:,l) + d0kl = dav(kr,lr) + rkl0 = rav(kr,lr) + akl = aav(kr,lr) + + rij2 = sum(rij**2) + rjk2 = sum(rjk**2) + rkl2 = sum(rjk**2) + + cosfi2 = dot_product(rij,rjk)/sqrt(rij2*rjk2) + if (abs(cosfi2) .gt. cosfi_max) cycle + cosfi3 = dot_product(rkl,rjk)/sqrt(rkl2*rjk2) + if (abs(cosfi3) .gt. cosfi_max) cycle + + gij = fk_lindh(aij,rij0,rij2) & + +0.5_wp*kd*fk_vdw(4.0_wp,d0ij,rij2) + gjk = fk_lindh(ajk,rjk0,rjk2) & + +0.5_wp*kd*fk_vdw(4.0_wp,d0jk,rjk2) + gkl = fk_lindh(akl,rkl0,rkl2) & + +0.5_wp*kd*fk_vdw(4.0_wp,d0kl,rkl2) + + tij = kt*gij*gjk*gkl + + !tij = max(tij,10*min_fk) + + !call trsn2(txyz,tau,c) + Call Trsn(txyz,4,Tau,C,.False.,.False.,' ', & + & Dum,.False.) + si = c(:,1) + sj = c(:,2) + sk = c(:,3) + sl = c(:,4) + + ! off diagonal block + do ic = 1,3 + do jc = 1,3 + hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j))+tij*si(ic)*sj(jc) + hess(ind(ic,i,jc,k)) = hess(ind(ic,i,jc,k))+tij*si(ic)*sk(jc) + hess(ind(ic,i,jc,l)) = hess(ind(ic,i,jc,l))+tij*si(ic)*sl(jc) + hess(ind(ic,j,jc,k)) = hess(ind(ic,j,jc,k))+tij*sj(ic)*sk(jc) + hess(ind(ic,j,jc,l)) = hess(ind(ic,j,jc,l))+tij*sj(ic)*sl(jc) + hess(ind(ic,k,jc,l)) = hess(ind(ic,k,jc,l))+tij*sk(ic)*sl(jc) + end do + end do + + ! diagonal block + do ic = 1,3 + do jc = 1,ic + hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+tij*si(ic)*si(jc) + hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+tij*sj(ic)*sj(jc) + hess(ind(ic,k,jc,k)) = hess(ind(ic,k,jc,k))+tij*sk(ic)*sk(jc) + hess(ind(ic,l,jc,l)) = hess(ind(ic,l,jc,l))+tij*sl(ic)*sl(jc) + end do + end do + + end do torsion_lAt + end do torsion_iAt + end do torsion_kAt + end do torsion_jAt + + end subroutine mh_lindh_torsion + + pure subroutine mh_lindh_outofp(n,at,xyz,hess,ko,kd,aav,rav,dav,lcutoff) + implicit none + + integer,intent(in) :: n + integer,intent(in) :: at(n) + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) + real(wp),intent(in) :: ko + real(wp),intent(in) :: kd + real(wp),intent(in) :: aav(3,3) + real(wp),intent(in) :: rav(3,3) + real(wp),intent(in) :: dav(3,3) + logical,intent(in) :: lcutoff(n,n) + + integer :: i,ir,j,jr,k,kr,l,lr,ic,jc + real(wp) :: txyz(3,4),c(3,4) + real(wp) :: rij(3),rij0,aij,rij2,gij,d0ij + real(wp) :: rik(3),rik0,aik,rik2,gik,d0ik + real(wp) :: ril(3),ril0,ail,ril2,gil,d0il + real(wp) :: cosfi2,cosfi3,cosfi4 + real(wp) :: beta,tij,tau + real(wp) :: si(3),sj(3),sk(3),sl(3) + +!! ------------------------------------------------------------------------ +! Hessian for out-of-plane +!! ------------------------------------------------------------------------ + outofplane_iAt: do i = 1,n + ir = itabrow(at(i)) + txyz(:,4) = xyz(:,i) + outofplane_jAt: do j = 1,n + if (j .eq. i) cycle outofplane_jAt + if (lcutoff(j,i)) cycle outofplane_jAt + jr = itabrow(at(j)) + txyz(:,1) = xyz(:,j) + outofplane_kAt: do k = 1,n + if (i .eq. k) cycle outofplane_kAt + if (j .eq. k) cycle outofplane_kat + if (lcutoff(k,i)) cycle outofplane_kAt + if (lcutoff(k,j)) cycle outofplane_kAt + kr = itabrow(at(k)) + txyz(:,2) = xyz(:,k) + outofplane_lAt: do l = 1,n + lr = itabrow(at(l)) + txyz(:,3) = xyz(:,l) + if (l .eq. i) cycle outofplane_lAt + if (l .eq. j) cycle outofplane_lAt + if (l .eq. k) cycle outofplane_lAt + if (lcutoff(l,i)) cycle outofplane_lAt + if (lcutoff(l,k)) cycle outofplane_lAt + if (lcutoff(l,j)) cycle outofplane_lAt + + rij = xyz(:,i)-xyz(:,j) + d0ij = dav(ir,jr) + rij0 = rav(ir,jr) + aij = aav(ir,jr) + + rik = xyz(:,i)-xyz(:,k) + d0ik = dav(ir,kr) + rik0 = rav(ir,kr) + aik = aav(ir,kr) + + ril = xyz(:,i)-xyz(:,l) + d0il = dav(ir,lr) + ril0 = rav(ir,lr) + ail = aav(ir,lr) + + rij2 = sum(rij**2) + rik2 = sum(rik**2) + ril2 = sum(ril**2) + + cosfi2 = dot_product(rij,rik)/sqrt(rij2*rik2) + if (abs(abs(cosfi2)-1.0_wp) .lt. 1.0e-1_wp) cycle + cosfi3 = dot_product(rij,ril)/sqrt(rij2*ril2) + if (abs(abs(cosfi3)-1.0_wp) .lt. 1.0e-1_wp) cycle + cosfi4 = dot_product(rik,ril)/sqrt(rik2*ril2) + if (abs(abs(cosfi4)-1.0_wp) .lt. 1.0e-1_wp) cycle + + gij = fk_lindh(aij,rij0,rij2) & + +0.5_wp*kd*fk_vdw(4.0_wp,d0ij,rij2) + gik = fk_lindh(aik,rik0,rik2) & + +0.5_wp*kd*fk_vdw(4.0_wp,d0ik,rik2) + gil = fk_lindh(ail,ril0,ril2) & + +0.5_wp*kd*fk_vdw(4.0_wp,d0il,ril2) + + tij = ko*gij*gik*gil + + !tij = max(tij,10*min_fk) + + call outofp2(xyz,tau,c) + If (abs(tau) .gt. 45.0d0*(pi/180.d0)) cycle + + si = c(:,4) + sj = c(:,1) + sk = c(:,2) + sl = c(:,3) + + ! off diagonal block + do ic = 1,3 + do jc = 1,3 + hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j))+tij*si(ic)*sj(jc) + hess(ind(ic,i,jc,k)) = hess(ind(ic,i,jc,k))+tij*si(ic)*sk(jc) + hess(ind(ic,i,jc,l)) = hess(ind(ic,i,jc,l))+tij*si(ic)*sl(jc) + hess(ind(ic,j,jc,k)) = hess(ind(ic,j,jc,k))+tij*sj(ic)*sk(jc) + hess(ind(ic,j,jc,l)) = hess(ind(ic,j,jc,l))+tij*sj(ic)*sl(jc) + hess(ind(ic,k,jc,l)) = hess(ind(ic,k,jc,l))+tij*sk(ic)*sl(jc) + end do + end do + + ! diagonal block + do ic = 1,3 + do jc = 1,ic + hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+tij*si(ic)*si(jc) + hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+tij*sj(ic)*sj(jc) + hess(ind(ic,k,jc,k)) = hess(ind(ic,k,jc,k))+tij*sk(ic)*sk(jc) + hess(ind(ic,l,jc,l)) = hess(ind(ic,l,jc,l))+tij*sl(ic)*sl(jc) + end do + end do + + end do outofplane_lAt + end do outofplane_kAt + end do outofplane_jAt + end do outofplane_iAt + + end subroutine mh_lindh_outofp + +!========================================================================================! +!########################################################################################! +!========================================================================================! + + pure function rcutoff(xyz,katom,latom,rcut) + implicit none + logical :: rcutoff + real(wp),intent(in) :: xyz(3,*) + real(wp),intent(in) :: rcut + real(wp) :: rkl(3),rkl2 + integer,intent(in) :: katom,latom rcutoff = .false. - xkl = Cart(1,kAtom) - Cart(1,lAtom) - ykl = Cart(2,kAtom) - Cart(2,lAtom) - zkl = Cart(3,kAtom) - Cart(3,lAtom) - rkl2 = xkl**2 + ykl**2 + zkl**2 + rkl = xyz(:,kAtom)-xyz(:,lAtom) + rkl2 = sum(rkl**2) if (rkl2 .gt. rcut) rcutoff = .true. - end function + end function rcutoff - function itabrow(i) + pure elemental function itabrow(i) integer :: itabrow integer,intent(in) :: i itabrow = 0 - if (i .gt. 0 .and. i .le. 2) then + if (i .gt. 0.and.i .le. 2) then itabrow = 1 - else if (i .gt. 2 .and. i .le. 10) then + else if (i .gt. 2.and.i .le. 10) then itabrow = 2 - else if (i .gt. 10 .and. i .le. 18) then + else if (i .gt. 10.and.i .le. 18) then itabrow = 3 - else if (i .gt. 18 .and. i .le. 36) then + else if (i .gt. 18.and.i .le. 36) then itabrow = 3 - else if (i .gt. 36 .and. i .le. 54) then + else if (i .gt. 36.and.i .le. 54) then itabrow = 3 - else if (i .gt. 54 .and. i .le. 86) then + else if (i .gt. 54.and.i .le. 86) then itabrow = 3 else if (i .gt. 86) then itabrow = 3 @@ -723,66 +2086,74 @@ function itabrow(i) return end function itabrow - subroutine getvdwxy(rx,ry,rz,c66,s6,r0,vdw) + pure subroutine getvdwxy(rx,ry,rz,c66,s6,r0,vdw) !cc Ableitung nach rx und ry - Implicit Real * 8(a - h,o - z) - integer k,l + implicit none + real(wp),intent(in) :: rx,ry,rz,c66,s6,r0 + real(wp),intent(out) :: vdw + real(wp) :: t1,t2,t3,t4,t5,t6,t7,t11,t12,t16,t17,t25,t26,t35 + real(wp) :: t40,t41,t43,t44,t56,avdw + ! write(*,*) 's6:', s6 avdw = 20.0 - t1 = s6 * C66 + t1 = s6*C66 t2 = rx**2 t3 = ry**2 t4 = rz**2 - t5 = t2 + t3 + t4 + t5 = t2+t3+t4 t6 = t5**2 t7 = t6**2 t11 = sqrt(t5) - t12 = 0.1D1 / r0 - t16 = exp(-avdw * (t11 * t12 - 0.1D1)) - t17 = 0.1D1 + t16 + t12 = 0.1D1/r0 + t16 = exp(-avdw*(t11*t12-0.1D1)) + t17 = 0.1D1+t16 t25 = t17**2 - t26 = 0.1D1 / t25 - t35 = 0.1D1 / t7 + t26 = 0.1D1/t25 + t35 = 0.1D1/t7 t40 = avdw**2 t41 = r0**2 - t43 = t40 / t41 + t43 = t40/t41 t44 = t16**2 - t56 = -0.48D2 * t1 / t7 / t5 / t17 * rx * ry + 0.13D2 * t1 / t11 /& - & t7 * t26 * rx * avdw * t12 * ry * t16 - 0.2D1 * t1 * t35 / t25 /& - &t17 * t43 * rx * t44 * ry + t1 * t35 * t26 * t43 * rx * ry * t16 + t56 = -0.48D2*t1/t7/t5/t17*rx*ry+0.13D2*t1/t11/& + & t7*t26*rx*avdw*t12*ry*t16-0.2D1*t1*t35/t25/& + &t17*t43*rx*t44*ry+t1*t35*t26*t43*rx*ry*t16 vdw = t56 return end subroutine getvdwxy - subroutine getvdwxx(rx,ry,rz,c66,s6,r0,vdw) + pure subroutine getvdwxx(rx,ry,rz,c66,s6,r0,vdw) !cc Ableitung nach rx und rx - Implicit Real * 8(a - h,o - z) + Implicit none + real(wp),intent(in) :: rx,ry,rz,c66,s6,r0 + real(wp),intent(out) :: vdw + real(wp) :: t1,t2,t3,t4,t5,t6,t7,t10,t11,t15,t16,t17,t24,t25,t29 + real(wp) :: t33,t41,t42,t44,t45,t62,avdw avdw = 20.0 ! write(*,*) 's6:', s6 - t1 = s6 * C66 + t1 = s6*C66 t2 = rx**2 t3 = ry**2 t4 = rz**2 - t5 = t2 + t3 + t4 + t5 = t2+t3+t4 t6 = t5**2 t7 = t6**2 t10 = sqrt(t5) - t11 = 0.1D1 / r0 - t15 = exp(-avdw * (t10 * t11 - 0.1D1)) - t16 = 0.1D1 + t15 - t17 = 0.1D1 / t16 + t11 = 0.1D1/r0 + t15 = exp(-avdw*(t10*t11-0.1D1)) + t16 = 0.1D1+t15 + t17 = 0.1D1/t16 t24 = t16**2 - t25 = 0.1D1 / t24 - t29 = t11 * t15 - t33 = 0.1D1 / t7 + t25 = 0.1D1/t24 + t29 = t11*t15 + t33 = 0.1D1/t7 t41 = avdw**2 t42 = r0**2 - t44 = t41 / t42 + t44 = t41/t42 t45 = t15**2 - t62 = -0.48D2 * t1 / t7 / t5 * t17 * t2 + 0.13D2 * t1 / t10 / t7 *& - & t25 * t2 * avdw * t29 + 0.6D1 * t1 * t33 * t17 - 0.2D1 * t1 * t33& - & / t24 / t16 * t44 * t2 * t45 - t1 / t10 / t6 / t5 * t25 * avdw *& - &t29 + t1 * t33 * t25 * t44 * t2 * t15 + t62 = -0.48D2*t1/t7/t5*t17*t2+0.13D2*t1/t10/t7*& + & t25*t2*avdw*t29+0.6D1*t1*t33*t17-0.2D1*t1*t33& + & /t24/t16*t44*t2*t45-t1/t10/t6/t5*t25*avdw*& + &t29+t1*t33*t25*t44*t2*t15 vdw = t62 end subroutine getvdwxx @@ -807,93 +2178,191 @@ pure subroutine trsn2(xyz,tau,bt) call bend2(xyz(1,2),fi3,bf3) sinfi3 = sin(fi3) cosfi3 = cos(fi3) - costau = ((brij(2,1) * brjk(3,2) - brij(3,1) * brjk(2,2)) * & - (brjk(2,1) * brkl(3,2) - brjk(3,1) * brkl(2,2)) + & - (brij(3,1) * brjk(1,2) - brij(1,1) * brjk(3,2)) * & - (brjk(3,1) * brkl(1,2) - brjk(1,1) * brkl(3,2)) + & - (brij(1,1) * brjk(2,2) - brij(2,1) * brjk(1,2)) * & - (brjk(1,1) * brkl(2,2) - brjk(2,1) * brkl(1,2))) & - / (sinfi2 * sinfi3) - sintau = (brij(1,2) * (brjk(2,1) * brkl(3,2) - brjk(3,1) * brkl(2,2)) & - + brij(2,2) * (brjk(3,1) * brkl(1,2) - brjk(1,1) * brkl(3,2)) & - + brij(3,2) * (brjk(1,1) * brkl(2,2) - brjk(2,1) * brkl(1,2))) & - / (sinfi2 * sinfi3) + costau = ((brij(2,1)*brjk(3,2)-brij(3,1)*brjk(2,2))* & + (brjk(2,1)*brkl(3,2)-brjk(3,1)*brkl(2,2))+ & + (brij(3,1)*brjk(1,2)-brij(1,1)*brjk(3,2))* & + (brjk(3,1)*brkl(1,2)-brjk(1,1)*brkl(3,2))+ & + (brij(1,1)*brjk(2,2)-brij(2,1)*brjk(1,2))* & + (brjk(1,1)*brkl(2,2)-brjk(2,1)*brkl(1,2))) & + /(sinfi2*sinfi3) + sintau = (brij(1,2)*(brjk(2,1)*brkl(3,2)-brjk(3,1)*brkl(2,2)) & + +brij(2,2)*(brjk(3,1)*brkl(1,2)-brjk(1,1)*brkl(3,2)) & + +brij(3,2)*(brjk(1,1)*brkl(2,2)-brjk(2,1)*brkl(1,2))) & + /(sinfi2*sinfi3) tau = atan2(sintau,costau) if (abs(tau) .eq. pi) tau = pi do ix = 1,3 - iy = ix + 1 - if (iy .gt. 3) iy = iy - 3 - iz = iy + 1 - if (iz .gt. 3) iz = iz - 3 - bt(ix,1) = (brij(iy,2) * brjk(iz,2) - brij(iz,2) * brjk(iy,2)) & - & / (rij1 * sinfi2**2) - bt(ix,4) = (brkl(iy,1) * brjk(iz,1) - brkl(iz,1) * brjk(iy,1)) & - & / (rkl1 * sinfi3**2) - bt(ix,2) = -((rjk1 - rij1 * cosfi2) * bt(ix,1) & - & + rkl1 * cosfi3 * bt(ix,4)) / rjk1 - bt(ix,3) = -(bt(ix,1) + bt(ix,2) + bt(ix,4)) + iy = ix+1 + if (iy .gt. 3) iy = iy-3 + iz = iy+1 + if (iz .gt. 3) iz = iz-3 + bt(ix,1) = (brij(iy,2)*brjk(iz,2)-brij(iz,2)*brjk(iy,2)) & + & /(rij1*sinfi2**2) + bt(ix,4) = (brkl(iy,1)*brjk(iz,1)-brkl(iz,1)*brjk(iy,1)) & + & /(rkl1*sinfi3**2) + bt(ix,2) = -((rjk1-rij1*cosfi2)*bt(ix,1) & + & +rkl1*cosfi3*bt(ix,4))/rjk1 + bt(ix,3) = -(bt(ix,1)+bt(ix,2)+bt(ix,4)) end do - contains - pure subroutine strtch2(xyz,avst,b) - implicit none - real(wp),intent(out) :: b(3,2) - real(wp),intent(in) :: xyz(3,2) - real(wp) :: r(3) - real(wp) :: rr - real(wp),intent(out) :: avst - r = xyz(:,2) - xyz(:,1) - rr = norm2(r) - avst = rr - b(:,1) = -r / rr - b(:,2) = -b(:,1) - end subroutine strtch2 - pure subroutine bend2(xyz,fir,bf) - implicit none - real(wp),intent(out) :: bf(3,3) - real(wp),intent(in) :: xyz(3,3) - real(wp) :: brij(3,2) - real(wp) :: brjk(3,2) - real(wp) :: co,crap - real(wp),intent(out) :: fir - real(wp) :: si - real(wp) :: rij1,rjk1 - integer :: i - call strtch2(xyz(1,1),rij1,brij) - call strtch2(xyz(1,2),rjk1,brjk) - co = 0.0_wp - crap = 0.0_wp - do i = 1,3 - co = co + brij(i,1) * brjk(i,2) - crap = crap + (brjk(i,2) + brij(i,1))**2 - end do - if (sqrt(crap) .lt. 1.0d-6) then - fir = pi - asin(sqrt(crap)) - si = sqrt(crap) - else - fir = acos(co) - si = sqrt(1.0_wp - co**2) - end if - if (abs(fir - pi) .lt. 1.0d-13) then - fir = pi - return - end if - do i = 1,3 - bf(i,1) = (co * brij(i,1) - brjk(i,2)) / (si * rij1) - bf(i,3) = (co * brjk(i,2) - brij(i,1)) / (si * rjk1) - bf(i,2) = -(bf(i,1) + bf(i,3)) - end do - end subroutine bend2 end subroutine trsn2 + pure subroutine strtch2(xyz,avst,b) + implicit none + real(wp),intent(out) :: b(3,2) + real(wp),intent(in) :: xyz(3,2) + real(wp) :: r(3) + real(wp) :: rr + real(wp),intent(out) :: avst + r = xyz(:,2)-xyz(:,1) + rr = norm2(r) + avst = rr + b(:,1) = -r/rr + b(:,2) = -b(:,1) + end subroutine strtch2 + pure subroutine bend2(xyz,fir,bf) + implicit none + real(wp),intent(out) :: bf(3,3) + real(wp),intent(in) :: xyz(3,3) + real(wp) :: brij(3,2) + real(wp) :: brjk(3,2) + real(wp) :: co,crap + real(wp),intent(out) :: fir + real(wp) :: si + real(wp) :: rij1,rjk1 + integer :: i + call strtch2(xyz(1,1),rij1,brij) + call strtch2(xyz(1,2),rjk1,brjk) + co = 0.0_wp + crap = 0.0_wp + do i = 1,3 + co = co+brij(i,1)*brjk(i,2) + crap = crap+(brjk(i,2)+brij(i,1))**2 + end do + if (sqrt(crap) .lt. 1.0d-6) then + fir = pi-asin(sqrt(crap)) + si = sqrt(crap) + else + fir = acos(co) + si = sqrt(1.0_wp-co**2) + end if + if (abs(fir-pi) .lt. 1.0d-13) then + fir = pi + return + end if + do i = 1,3 + bf(i,1) = (co*brij(i,1)-brjk(i,2))/(si*rij1) + bf(i,3) = (co*brjk(i,2)-brij(i,1))/(si*rjk1) + bf(i,2) = -(bf(i,1)+bf(i,3)) + end do + end subroutine bend2 + + pure subroutine outofp2(xyz,teta,bt) + implicit none + real(wp),intent(out) :: teta + real(wp),intent(out) :: bt(3,4) + real(wp),intent(in) :: xyz(3,4) + real(wp) :: r1(3),r2(3),r3(3) + real(wp) :: q41,q42,q43,e41(3),e42(3),e43(3) + real(wp) :: cosfi1,fi1,dfi1,cosfi2,fi2,dfi2,cosfi3,fi3,dfi3 + real(wp) :: c14(3,3),br14(3,3) + real(wp) :: r42(3),r43(3) + integer :: ix,iy,iz +! 4 -> 1 (bond) + r1 = xyz(:,1)-xyz(:,4) + q41 = norm2(r1) + e41 = r1/q41 +! 4 -> 2 (bond in plane) + r2 = xyz(:,2)-xyz(:,4) + q42 = norm2(r2) + e42 = r2/q42 +! 4 -> 3 (bond in plane) + r3 = xyz(:,3)-xyz(:,4) + q43 = norm2(r3) + e43 = r3/q43 +! +! get the angle between e43 and e42 +! + cosfi1 = dot_product(e43,e42) + + fi1 = acos(cosfi1) + dfi1 = 180.d0*fi1/pi +! +! dirty exit! this happens when an earlier structure is ill defined. +! + if (abs(fi1-pi) .lt. 1.0d-13) then + teta = 0.0_wp + bt = 0.0_wp + return + end if +! +! get the angle between e41 and e43 +! + cosfi2 = dot_product(e41,e43) + + fi2 = acos(cosfi2) + dfi2 = 180.d0*fi2/pi +! +! get the angle between e41 and e42 +! + cosfi3 = dot_product(e41,e42) + + fi3 = acos(cosfi3) + dfi3 = 180.d0*fi3/pi +! +! the first two centers are trivially +! + c14(:,1) = xyz(:,1) + c14(:,2) = xyz(:,4) +! +! the 3rd is +! + r42 = xyz(:,2)-xyz(:,4) + r43 = xyz(:,3)-xyz(:,4) + c14(1,3) = r42(2)*r43(3)-r42(3)*r43(2) + c14(2,3) = r42(3)*r43(1)-r42(1)*r43(3) + c14(3,3) = r42(1)*r43(2)-r42(2)*r43(1) +! +! exit if 2-3-4 are collinear +! (equivalent to the above check, but this is more concrete) +! + if ((c14(1,3)**2+c14(2,3)**2+c14(3,3)**2) .lt. 1.0d-10) then + teta = 0.0d0 + bt = 0.0_wp + return + end if + c14(1,3) = c14(1,3)+xyz(1,4) + c14(2,3) = c14(2,3)+xyz(2,4) + c14(3,3) = c14(3,3)+xyz(3,4) + + call bend2(c14,teta,br14) + + teta = teta-0.5_wp*pi +! +!--compute the wdc matrix +! + do ix = 1,3 + iy = mod(ix+1,4)+(ix+1)/4 + iz = mod(iy+1,4)+(iy+1)/4 + + bt(ix,1) = -br14(ix,1) + bt(ix,2) = r43(iz)*br14(iy,3)-r43(iy)*br14(iz,3) + bt(ix,3) = -r42(iz)*br14(iy,3)+r42(iy)*br14(iz,3) + + bt(ix,4) = -(bt(ix,1)+bt(ix,2)+bt(ix,3)) + + end do + + bt = -bt + end subroutine outofp2 Subroutine Trsn(xyz,nCent,Tau,Bt,lWrite,lWarn,Label,dBt,ldB) - !*********************************************************************** - ! * - ! Reference: Molecular Vibrations, E. Bright Wilson, Jr, J. C. Decicius* - ! nd Paul C. Cross, Sec. 4-1, Eq. 20-24 * - ! * - ! R.Lindh May-June '96 * - !*********************************************************************** - Implicit Real(wp) (a - h,o - z) +!************************************************************************ +!* * +!* Reference: Molecular Vibrations, E. Bright Wilson, Jr, J. C. Decicius* +!* nd Paul C. Cross, Sec. 4-1, Eq. 20-24 * +!* * +!* R.Lindh May-June '96 * +!************************************************************************ + Implicit Real(wp) (a-h,o-z) integer :: nCent,mCent,i,j,ix,iy,iz,jx,jy,jz Real(wp) Bt(3,nCent),xyz(3,nCent),Rij(3),Eij(3),Rjk(3),Ejk(3),& @@ -924,13 +2393,13 @@ Subroutine Trsn(xyz,nCent,Tau,Bt,lWrite,lWarn,Label,dBt,ldB) ! ! r123 * r234 = CosTau ! - CosTau = ((BRij(2,1) * BRjk(3,2) - BRij(3,1) * BRjk(2,2)) *& - & (BRjk(2,1) * BRkl(3,2) - BRjk(3,1) * BRkl(2,2)) +& - & (BRij(3,1) * BRjk(1,2) - BRij(1,1) * BRjk(3,2)) *& - & (BRjk(3,1) * BRkl(1,2) - BRjk(1,1) * BRkl(3,2)) +& - & (BRij(1,1) * BRjk(2,2) - BRij(2,1) * BRjk(1,2)) *& - & (BRjk(1,1) * BRkl(2,2) - BRjk(2,1) * BRkl(1,2)))& - & / (SinFi2 * SinFi3) + CosTau = ((BRij(2,1)*BRjk(3,2)-BRij(3,1)*BRjk(2,2))*& + & (BRjk(2,1)*BRkl(3,2)-BRjk(3,1)*BRkl(2,2))+& + & (BRij(3,1)*BRjk(1,2)-BRij(1,1)*BRjk(3,2))*& + & (BRjk(3,1)*BRkl(1,2)-BRjk(1,1)*BRkl(3,2))+& + & (BRij(1,1)*BRjk(2,2)-BRij(2,1)*BRjk(1,2))*& + & (BRjk(1,1)*BRkl(2,2)-BRjk(2,1)*BRkl(1,2)))& + & /(SinFi2*SinFi3) ! ! For the vector product of the two vectors. This ! will give a vector parallell to e23. The direction @@ -938,51 +2407,51 @@ Subroutine Trsn(xyz,nCent,Tau,Bt,lWrite,lWarn,Label,dBt,ldB) ! ! e123 X e234 = SinTau * e23 ! - SinTau = (BRij(1,2) * (BRjk(2,1) * BRkl(3,2) - BRjk(3,1) * BRkl(2,2))& - & + BRij(2,2) * (BRjk(3,1) * BRkl(1,2) - BRjk(1,1) * BRkl(3,2))& - & + BRij(3,2) * (BRjk(1,1) * BRkl(2,2) - BRjk(2,1) * BRkl(1,2)))& - & / (SinFi2 * SinFi3) + SinTau = (BRij(1,2)*(BRjk(2,1)*BRkl(3,2)-BRjk(3,1)*BRkl(2,2))& + & +BRij(2,2)*(BRjk(3,1)*BRkl(1,2)-BRjk(1,1)*BRkl(3,2))& + & +BRij(3,2)*(BRjk(1,1)*BRkl(2,2)-BRjk(2,1)*BRkl(1,2)))& + & /(SinFi2*SinFi3) ! ! (-Pi < Tau <= Pi) ! Tau = ATan2(SinTau,CosTau) If (Abs(Tau) .eq. Pi) Tau = Pi ! - dTau = 180.0D+00 * Tau / Pi - dFi2 = 180.0D+00 * Fi2 / Pi - dFi3 = 180.0D+00 * Fi3 / Pi + dTau = 180.0D+00*Tau/Pi + dFi2 = 180.0D+00*Fi2/Pi + dFi3 = 180.0D+00*Fi3/Pi If (lWarn) Then - If (dTau .gt. 177.5 .or. dTau .lt. -177.5) Then + If (dTau .gt. 177.5.or.dTau .lt. -177.5) Then Write (*,*) ' Warning: dihedral angle close to'& & //' end of range' End If - If (dFi2 .gt. 177.5 .or. dFi2 .lt. 2.5) Then + If (dFi2 .gt. 177.5.or.dFi2 .lt. 2.5) Then Write (*,*) ' Warning: bond angle close to'& & //' end of range' End If - If (dFi3 .gt. 177.5 .or. dFi3 .lt. 2.5) Then + If (dFi3 .gt. 177.5.or.dFi3 .lt. 2.5) Then Write (*,*) ' Warning: bond angle close to'& & //' end of range' End If End If If (LWRITE) Write (*,1) Label,dTau,Tau 1 FORMAT(1X,A,' : Dihedral Angle=',F10.4,& - & '/degree,',F10.4,'/rad') + & '/degree,',F10.4,'/rad') ! !---- Compute the WDC matrix. ! Do ix = 1,3 - iy = ix + 1 - If (iy .gt. 3) iy = iy - 3 - iz = iy + 1 - If (iz .gt. 3) iz = iz - 3 - Bt(ix,1) = (BRij(iy,2) * BRjk(iz,2) - BRij(iz,2) * BRjk(iy,2))& - & / (Rij1 * SinFi2**2) - Bt(ix,4) = (BRkl(iy,1) * BRjk(iz,1) - BRkl(iz,1) * BRjk(iy,1))& - & / (Rkl1 * SinFi3**2) - Bt(ix,2) = -((Rjk1 - Rij1 * CosFi2) * Bt(ix,1)& - & + Rkl1 * CosFi3 * Bt(ix,4)) / Rjk1 - Bt(ix,3) = -(Bt(ix,1) + Bt(ix,2) + Bt(ix,4)) + iy = ix+1 + If (iy .gt. 3) iy = iy-3 + iz = iy+1 + If (iz .gt. 3) iz = iz-3 + Bt(ix,1) = (BRij(iy,2)*BRjk(iz,2)-BRij(iz,2)*BRjk(iy,2))& + & /(Rij1*SinFi2**2) + Bt(ix,4) = (BRkl(iy,1)*BRjk(iz,1)-BRkl(iz,1)*BRjk(iy,1))& + & /(Rkl1*SinFi3**2) + Bt(ix,2) = -((Rjk1-Rij1*CosFi2)*Bt(ix,1)& + & +Rkl1*CosFi3*Bt(ix,4))/Rjk1 + Bt(ix,3) = -(Bt(ix,1)+Bt(ix,2)+Bt(ix,4)) End Do ! If (ldB) Then @@ -990,78 +2459,78 @@ Subroutine Trsn(xyz,nCent,Tau,Bt,lWrite,lWarn,Label,dBt,ldB) !------- Compute the derivative of the WDC matrix. ! Do ix = 1,3 - iy = ix + 1 - If (iy .gt. 3) iy = iy - 3 - iz = iy + 1 - If (iz .gt. 3) iz = iz - 3 + iy = ix+1 + If (iy .gt. 3) iy = iy-3 + iz = iy+1 + If (iz .gt. 3) iz = iz-3 Do jx = 1,ix - jy = jx + 1 - If (jy .gt. 3) jy = jy - 3 - jz = jy + 1 - If (jz .gt. 3) jz = jz - 3 + jy = jx+1 + If (jy .gt. 3) jy = jy-3 + jz = jy+1 + If (jz .gt. 3) jz = jz-3 ! - dBt(ix,1,jx,1) = (dBRij(ix,1,jy,2) * BRjk(jz,2)& - & - dBRij(ix,1,jz,2) * BRjk(jy,2)& - & - Bt(jx,1) * (BRij(ix,1) * SinFi2**2& - & + Rij1 * Two * SinFi2 * CosFi2 * Bf2(ix,1)))& - & / (Rij1 * SinFi2**2) - dBt(ix,1,jx,2) = -((-BRij(ix,1) * CosFi2& - & + Rij1 * SinFi2 * Bf2(ix,1)) * Bt(jx,1)& - & + (Rjk1 - Rij1 * CosFi2) * dBt(ix,1,jx,1))& - & / Rjk1 + dBt(ix,1,jx,1) = (dBRij(ix,1,jy,2)*BRjk(jz,2)& + & -dBRij(ix,1,jz,2)*BRjk(jy,2)& + & -Bt(jx,1)*(BRij(ix,1)*SinFi2**2& + & +Rij1*Two*SinFi2*CosFi2*Bf2(ix,1)))& + & /(Rij1*SinFi2**2) + dBt(ix,1,jx,2) = -((-BRij(ix,1)*CosFi2& + & +Rij1*SinFi2*Bf2(ix,1))*Bt(jx,1)& + & +(Rjk1-Rij1*CosFi2)*dBt(ix,1,jx,1))& + & /Rjk1 dBt(jx,2,ix,1) = dBt(ix,1,jx,2) dBt(ix,1,jx,4) = Zero dBt(jx,4,ix,1) = dBt(ix,1,jx,4) - dBt(ix,1,jx,3) = -(dBt(ix,1,jx,1) + dBt(ix,1,jx,2)) + dBt(ix,1,jx,3) = -(dBt(ix,1,jx,1)+dBt(ix,1,jx,2)) dBt(jx,3,ix,1) = dBt(ix,1,jx,3) - dBt(ix,4,jx,4) = (dBRkl(ix,2,jy,1) * BRjk(jz,1)& - & - dBRkl(ix,2,jz,1) * BRjk(jy,1)& - & - Bt(jx,4) * (BRkl(ix,2) * SinFi3**2& - & + Rkl1 * Two * SinFi3 * CosFi3 * Bf3(ix,3)))& - & / (Rkl1 * SinFi3**2) - dBt(ix,4,jx,3) = -((-BRkl(ix,2) * CosFi3& - & + Rkl1 * SinFi3 * Bf3(ix,3)) * Bt(jx,4)& - & + (Rjk1 - Rkl1 * CosFi3) * dBt(ix,4,jx,4))& - & / Rjk1 + dBt(ix,4,jx,4) = (dBRkl(ix,2,jy,1)*BRjk(jz,1)& + & -dBRkl(ix,2,jz,1)*BRjk(jy,1)& + & -Bt(jx,4)*(BRkl(ix,2)*SinFi3**2& + & +Rkl1*Two*SinFi3*CosFi3*Bf3(ix,3)))& + & /(Rkl1*SinFi3**2) + dBt(ix,4,jx,3) = -((-BRkl(ix,2)*CosFi3& + & +Rkl1*SinFi3*Bf3(ix,3))*Bt(jx,4)& + & +(Rjk1-Rkl1*CosFi3)*dBt(ix,4,jx,4))& + & /Rjk1 dBt(jx,3,ix,4) = dBt(ix,4,jx,3) - dBt(ix,4,jx,2) = -(dBt(ix,4,jx,4) + dBt(ix,4,jx,3)) + dBt(ix,4,jx,2) = -(dBt(ix,4,jx,4)+dBt(ix,4,jx,3)) dBt(jx,2,ix,4) = dBt(ix,4,jx,2) If (ix .ne. jx) Then dBt(jx,1,ix,1) = dBt(ix,1,jx,1) dBt(ix,4,jx,1) = Zero dBt(jx,4,ix,4) = dBt(ix,4,jx,4) dBt(jx,1,ix,4) = dBt(ix,4,jx,1) - dBt(jx,1,ix,2) = -((-BRij(jx,1) * CosFi2& - & + Rij1 * SinFi2 * Bf2(jx,1)) * Bt(ix,1)& - & + (Rjk1 - Rij1 * CosFi2) * dBt(jx,1,ix,1))& - & / Rjk1 + dBt(jx,1,ix,2) = -((-BRij(jx,1)*CosFi2& + & +Rij1*SinFi2*Bf2(jx,1))*Bt(ix,1)& + & +(Rjk1-Rij1*CosFi2)*dBt(jx,1,ix,1))& + & /Rjk1 dBt(ix,2,jx,1) = dBt(jx,1,ix,2) - dBt(ix,3,jx,1) = -(dBt(ix,1,jx,1) + dBt(ix,2,jx,1)& - & + dBt(ix,4,jx,1)) + dBt(ix,3,jx,1) = -(dBt(ix,1,jx,1)+dBt(ix,2,jx,1)& + & +dBt(ix,4,jx,1)) dBt(jx,1,ix,3) = dBt(ix,3,jx,1) - dBt(jx,4,ix,3) = -((-BRkl(jx,2) * CosFi3& - & + Rkl1 * SinFi3 * Bf3(jx,3)) * Bt(ix,4)& - & + (Rjk1 - Rkl1 * CosFi3) * dBt(jx,4,ix,4))& - & / Rjk1 + dBt(jx,4,ix,3) = -((-BRkl(jx,2)*CosFi3& + & +Rkl1*SinFi3*Bf3(jx,3))*Bt(ix,4)& + & +(Rjk1-Rkl1*CosFi3)*dBt(jx,4,ix,4))& + & /Rjk1 dBt(ix,3,jx,4) = dBt(jx,4,ix,3) - dBt(ix,2,jx,4) = -(dBt(ix,4,jx,4) + dBt(ix,3,jx,4)) + dBt(ix,2,jx,4) = -(dBt(ix,4,jx,4)+dBt(ix,3,jx,4)) dBt(jx,4,ix,2) = dBt(ix,2,jx,4) End If dBt(ix,2,jx,3) = -((BRjk(ix,1)& - & + Rkl1 * SinFi3 * Bf3(ix,1)) * Bt(jx,4)& - & + (Rjk1 - Rkl1 * CosFi3) * dBt(ix,2,jx,4)& - & + (BRij(ix,2) * CosFi2& - & - Rij1 * SinFi2 * Bf2(ix,2)) * Bt(jx,1)& - & + Rij1 * CosFi2 * dBt(ix,2,jx,1)& - & + Bt(jx,3) * BRjk(ix,1)) / Rjk1 + & +Rkl1*SinFi3*Bf3(ix,1))*Bt(jx,4)& + & +(Rjk1-Rkl1*CosFi3)*dBt(ix,2,jx,4)& + & +(BRij(ix,2)*CosFi2& + & -Rij1*SinFi2*Bf2(ix,2))*Bt(jx,1)& + & +Rij1*CosFi2*dBt(ix,2,jx,1)& + & +Bt(jx,3)*BRjk(ix,1))/Rjk1 dBt(jx,3,ix,2) = dBt(ix,2,jx,3) - dBt(ix,2,jx,2) = -(dBt(ix,2,jx,1) + dBt(ix,2,jx,4)& - & + dBt(ix,2,jx,3)) - dBt(ix,3,jx,3) = -(dBt(ix,2,jx,3) + dBt(ix,1,jx,3)& - & + dBt(ix,4,jx,3)) + dBt(ix,2,jx,2) = -(dBt(ix,2,jx,1)+dBt(ix,2,jx,4)& + & +dBt(ix,2,jx,3)) + dBt(ix,3,jx,3) = -(dBt(ix,2,jx,3)+dBt(ix,1,jx,3)& + & +dBt(ix,4,jx,3)) If (ix .ne. jx) Then - dBt(ix,3,jx,2) = -(dBt(ix,2,jx,2) + dBt(ix,1,jx,2)& - & + dBt(ix,4,jx,2)) + dBt(ix,3,jx,2) = -(dBt(ix,2,jx,2)+dBt(ix,1,jx,2)& + & +dBt(ix,4,jx,2)) dBt(jx,2,ix,3) = dBt(ix,3,jx,2) dBt(jx,2,ix,2) = dBt(ix,2,jx,2) dBt(jx,3,ix,3) = dBt(ix,3,jx,3) @@ -1075,7 +2544,7 @@ Subroutine Trsn(xyz,nCent,Tau,Bt,lWrite,lWarn,Label,dBt,ldB) Return contains Subroutine Strtch(xyz,nCent,Avst,B,lWrite,Label,dB,ldB) - Implicit Real(wp) (a - h,o - z) + Implicit Real(wp) (a-h,o-z) ! include "common/real.inc" !comdeck real.inc $Revision: 2002.3 $ Real(wp) :: Zero,One,Two,Three,Four,Five,Six,Seven,& @@ -1107,22 +2576,22 @@ Subroutine Strtch(xyz,nCent,Avst,B,lWrite,Label,dB,ldB) ! Data Angstr/0.529177249D+00/ ! - R(1) = xyz(1,2) - xyz(1,1) - R(2) = xyz(2,2) - xyz(2,1) - R(3) = xyz(3,2) - xyz(3,1) - R2 = R(1)**2 + R(2)**2 + R(3)**2 + R(1) = xyz(1,2)-xyz(1,1) + R(2) = xyz(2,2)-xyz(2,1) + R(3) = xyz(3,2)-xyz(3,1) + R2 = R(1)**2+R(2)**2+R(3)**2 RR = Sqrt(R2) Avst = RR ! - aRR = RR * Angstr + aRR = RR*Angstr If (lWrite) Write (*,'(1X,A,A,2(F10.6,A))') Label,& & ' : Bond Length=',aRR,' / Angstrom',RR,' / bohr' ! !---- Compute the WDC B-matrix. ! - B(1,1) = -R(1) / RR - B(2,1) = -R(2) / RR - B(3,1) = -R(3) / RR + B(1,1) = -R(1)/RR + B(2,1) = -R(2)/RR + B(3,1) = -R(3)/RR !.... Utilize translational invariance. B(1,2) = -B(1,1) B(2,2) = -B(2,1) @@ -1135,9 +2604,9 @@ Subroutine Strtch(xyz,nCent,Avst,B,lWrite,Label,dB,ldB) Do i = 1,3 Do j = 1,i If (i .eq. j) Then - dB(i,1,j,1) = (One - B(j,1) * B(i,1)) / RR + dB(i,1,j,1) = (One-B(j,1)*B(i,1))/RR Else - dB(i,1,j,1) = (-B(j,1) * B(i,1)) / RR + dB(i,1,j,1) = (-B(j,1)*B(i,1))/RR End If dB(j,1,i,1) = dB(i,1,j,1) ! @@ -1158,7 +2627,7 @@ Subroutine Strtch(xyz,nCent,Avst,B,lWrite,Label,dB,ldB) Return End subroutine strtch Subroutine Bend(xyz,nCent,Fir,Bf,lWrite,lWarn,Label,dBf,ldB) - Implicit Real(wp) (a - h,o - z) + Implicit Real(wp) (a-h,o-z) integer :: nCent !Real(wp) :: Bf(3,nCent),xyz(3,nCent),dBf(3,nCent,3,nCent),& @@ -1176,26 +2645,26 @@ Subroutine Bend(xyz,nCent,Fir,Bf,lWrite,lWarn,Label,dBf,ldB) Co = Zero Crap = Zero Do i = 1,3 - Co = Co + BRij(i,1) * BRjk(i,2) - Crap = Crap + (BRjk(i,2) + BRij(i,1))**2 + Co = Co+BRij(i,1)*BRjk(i,2) + Crap = Crap+(BRjk(i,2)+BRij(i,1))**2 End Do ! !.... Special care for cases close to linearity ! If (Sqrt(Crap) .lt. 1.0D-6) Then - Fir = Pi - ArSin(Sqrt(Crap)) + Fir = Pi-ArSin(Sqrt(Crap)) Si = Sqrt(Crap) Else Fir = ArCos(Co) - Si = Sqrt(One - Co**2) + Si = Sqrt(One-Co**2) End If ! - If (Abs(Fir - Pi) .lt. 1.0d-13) Then + If (Abs(Fir-Pi) .lt. 1.0d-13) Then Fir = Pi Return End If - dFir = 180.0D0 * Fir / Pi - If ((Abs(dFir) .gt. 177.5 .or. Abs(dFir) .lt. 2.5) .and. lWarn)& + dFir = 180.0D0*Fir/Pi + If ((Abs(dFir) .gt. 177.5.or.Abs(dFir) .lt. 2.5).and.lWarn)& & Write (*,*) ' Valence angle close to end in '//& & 'range of definition' If (lWrite) Write (*,'(1X,A,A,F10.4,A,F10.6,A)') Label,& @@ -1205,10 +2674,10 @@ Subroutine Bend(xyz,nCent,Fir,Bf,lWrite,lWarn,Label,dBf,ldB) ! ! Bf=-11.1111 Do i = 1,3 - Bf(i,1) = (Co * BRij(i,1) - BRjk(i,2)) / (Si * Rij1) - Bf(i,3) = (Co * BRjk(i,2) - BRij(i,1)) / (Si * Rjk1) + Bf(i,1) = (Co*BRij(i,1)-BRjk(i,2))/(Si*Rij1) + Bf(i,3) = (Co*BRjk(i,2)-BRij(i,1))/(Si*Rjk1) !....... Utilize translational invariance. - Bf(i,2) = -(Bf(i,1) + Bf(i,3)) + Bf(i,2) = -(Bf(i,1)+Bf(i,3)) End Do ! Call RecPrt('Bf',' ',Bf,9,1) ! @@ -1219,39 +2688,39 @@ Subroutine Bend(xyz,nCent,Fir,Bf,lWrite,lWarn,Label,dBf,ldB) ! dBf=-11.11111 Do i = 1,3 Do j = 1,i - dBf(i,1,j,1) = (-Si * Bf(i,1) * BRij(j,1)& - & + Co * dBRij(i,1,j,1)& - & - Bf(j,1) * (Co * Bf(i,1) * Rij1& - & + Si * BRij(i,1))) / (Si * Rij1) - dBf(i,1,j,3) = (-Si * Bf(i,1) * BRjk(j,2)& - & + dBRij(i,1,j,2)& - & - Bf(j,3) * Co * Bf(i,1) * Rjk1)& - & / (Si * Rjk1) + dBf(i,1,j,1) = (-Si*Bf(i,1)*BRij(j,1)& + & +Co*dBRij(i,1,j,1)& + & -Bf(j,1)*(Co*Bf(i,1)*Rij1& + & +Si*BRij(i,1)))/(Si*Rij1) + dBf(i,1,j,3) = (-Si*Bf(i,1)*BRjk(j,2)& + & +dBRij(i,1,j,2)& + & -Bf(j,3)*Co*Bf(i,1)*Rjk1)& + & /(Si*Rjk1) ! Write (*,*) '13',dBf(i,1,j,3), i, j - dBf(i,3,j,1) = (-Si * Bf(i,3) * BRij(j,1)& - & + dBRjk(i,2,j,1)& - & - Bf(j,1) * Co * Bf(i,3) * Rij1)& - & / (Si * Rij1) - dBf(i,3,j,3) = (-Si * Bf(i,3) * BRjk(j,2)& - & + Co * dBRjk(i,2,j,2)& - & - Bf(j,3) * (Co * Bf(i,3) * Rjk1& - & + Si * BRjk(i,2))) / (Si * Rjk1) + dBf(i,3,j,1) = (-Si*Bf(i,3)*BRij(j,1)& + & +dBRjk(i,2,j,1)& + & -Bf(j,1)*Co*Bf(i,3)*Rij1)& + & /(Si*Rij1) + dBf(i,3,j,3) = (-Si*Bf(i,3)*BRjk(j,2)& + & +Co*dBRjk(i,2,j,2)& + & -Bf(j,3)*(Co*Bf(i,3)*Rjk1& + & +Si*BRjk(i,2)))/(Si*Rjk1) ! dBf(j,1,i,1) = dBf(i,1,j,1) dBf(j,3,i,1) = dBf(i,1,j,3) dBf(j,1,i,3) = dBf(i,3,j,1) dBf(j,3,i,3) = dBf(i,3,j,3) ! - dBf(i,1,j,2) = -(dBf(i,1,j,1) + dBf(i,1,j,3)) + dBf(i,1,j,2) = -(dBf(i,1,j,1)+dBf(i,1,j,3)) dBf(j,2,i,1) = dBf(i,1,j,2) - dBf(j,1,i,2) = -(dBf(j,1,i,1) + dBf(j,1,i,3)) + dBf(j,1,i,2) = -(dBf(j,1,i,1)+dBf(j,1,i,3)) dBf(i,2,j,1) = dBf(j,1,i,2) - dBf(i,3,j,2) = -(dBf(i,3,j,1) + dBf(i,3,j,3)) + dBf(i,3,j,2) = -(dBf(i,3,j,1)+dBf(i,3,j,3)) dBf(j,2,i,3) = dBf(i,3,j,2) - dBf(j,3,i,2) = -(dBf(j,3,i,1) + dBf(j,3,i,3)) + dBf(j,3,i,2) = -(dBf(j,3,i,1)+dBf(j,3,i,3)) dBf(i,2,j,3) = dBf(j,3,i,2) ! - dBf(i,2,j,2) = -(dBf(i,2,j,1) + dBf(i,2,j,3)) + dBf(i,2,j,2) = -(dBf(i,2,j,1)+dBf(i,2,j,3)) dBf(j,2,i,2) = dBf(i,2,j,2) ! End Do @@ -1264,8 +2733,8 @@ Subroutine Bend(xyz,nCent,Fir,Bf,lWrite,lWarn,Label,dBf,ldB) Return End subroutine bend Function arSin(Arg) - Implicit Real * 8(a - h,o - z) - Real * 8 ArSin + Implicit Real*8(a-h,o-z) + Real*8 ArSin A = Arg IF (ABS(A) .GT. One) Then @@ -1278,7 +2747,7 @@ Function arSin(Arg) Return End function arSin Function arCos(Arg) - Implicit Real(wp) (a - h,o - z) + Implicit Real(wp) (a-h,o-z) Real(wp) :: ArCos A = Arg IF (ABS(A) .GT. One) Then @@ -1289,5 +2758,446 @@ Function arCos(Arg) End function arCos End subroutine trsn + pure elemental function ixyz(i,iatom) + integer :: ixyz + integer,intent(in) :: i,iatom + ixyz = (iatom-1)*3+i + end function ixyz + pure elemental function jnd(i,j) + integer :: jnd + integer,intent(in) :: i,j + jnd = i*(i-1)/2+j + end function jnd + pure elemental function ind(i,iatom,j,jatom) + integer :: ind + integer,intent(in) :: i,iatom,j,jatom + ind = jnd(max(ixyz(i,iatom),ixyz(j,jatom)),min(ixyz(i,iatom),ixyz(j,jatom))) + end function ind + + pure elemental function fk_lindh(alpha,r0,r2) result(gmm) + implicit none + real(wp),intent(in) :: alpha,r0,r2 + real(wp) :: gmm + gmm = exp(alpha*(r0**2-r2)) + end function fk_lindh + + pure elemental function fk_swart(alpha,r0,r2) result(gmm) + implicit none + real(wp),intent(in) :: alpha,r0,r2 + real(wp) :: gmm + gmm = exp(-alpha*(sqrt(r2)/r0-1.0_wp)) + end function fk_swart + + pure elemental function fk_vdw(alpha,r0,r2) result(gmm) + implicit none + real(wp),intent(in) :: alpha,r0,r2 + real(wp) :: gmm + gmm = exp(-alpha*(r0-sqrt(r2))**2) + end function fk_vdw + +!========================================================================================! +!########################################################################################! +!========================================================================================! + + subroutine mh_eeq(n,at,xyz,chrg,kq,hess) + implicit none + +!! ------------------------------------------------------------------------ +! Input +!! ------------------------------------------------------------------------ + integer,intent(in) :: n ! number of atoms + integer,intent(in) :: at(n) ! ordinal numbers + real(wp),intent(in) :: xyz(3,n) ! geometry + real(wp),intent(in) :: chrg ! total charge + real(wp),intent(in) :: kq ! scaling parameter +! type(chrg_parameter),intent(in) :: chrgeq ! charge model +!! ------------------------------------------------------------------------ +! Output +!! ------------------------------------------------------------------------ + real(wp),intent(out) :: hess((3*n)*(3*n+1)/2) + real(wp),allocatable :: hessian(:,:,:,:) ! molecular hessian of IES + +! π itself + real(wp),parameter :: pi = 3.1415926535897932384626433832795029_wp +! √π + real(wp),parameter :: sqrtpi = sqrt(pi) +! √(2/π) + real(wp),parameter :: sqrt2pi = sqrt(2.0_wp/pi) +! +!! ------------------------------------------------------------------------ +! charge model +!! ------------------------------------------------------------------------ + integer :: m ! dimension of the Lagrangian + real(wp),allocatable :: Amat(:,:) + real(wp),allocatable :: Xvec(:) + real(wp),allocatable :: Ainv(:,:) + real(wp),allocatable :: dAmat(:,:,:) + real(wp),allocatable :: dqdr(:,:,:) + +!! ------------------------------------------------------------------------ +! local variables +!! ------------------------------------------------------------------------ + integer :: i,j,k,l + real(wp) :: r,rij(3),r2 + real(wp) :: gamij,gamij2 + real(wp) :: arg,arg2,tmp,dtmp + real(wp) :: lambda + real(wp) :: es,expterm,erfterm + real(wp) :: htmp,rxr(3,3) + real(wp) :: rcovij,rr + +!! ------------------------------------------------------------------------ +! scratch variables +!! ------------------------------------------------------------------------ + real(wp),allocatable :: alpha(:) + real(wp),allocatable :: xtmp(:) + real(wp),allocatable :: atmp(:,:) + +!! ------------------------------------------------------------------------ +! Lapack work variables +!! ------------------------------------------------------------------------ + integer,allocatable :: ipiv(:) + real(wp),allocatable :: temp(:) + real(wp),allocatable :: work(:) + integer :: lwork + integer :: info + real(wp) :: test(1) + +!! ------------------------------------------------------------------------ +! EEQ parameters +! PARAMETRISATION BY S. SPICHER (Fri, 14 Dec 2018 16:13:08 +0100) +!! ------------------------------------------------------------------------ + integer,parameter :: max_elem = 86 +!&< + real(wp),parameter :: enparam(max_elem) = (/ & + 1.23695041_wp, 1.26590957_wp, 0.54341808_wp, 0.99666991_wp, 1.26691604_wp, & + 1.40028282_wp, 1.55819364_wp, 1.56866440_wp, 1.57540015_wp, 1.15056627_wp, & + 0.55936220_wp, 0.72373742_wp, 1.12910844_wp, 1.12306840_wp, 1.52672442_wp, & + 1.40768172_wp, 1.48154584_wp, 1.31062963_wp, 0.40374140_wp, 0.75442607_wp, & + 0.76482096_wp, 0.98457281_wp, 0.96702598_wp, 1.05266584_wp, 0.93274875_wp, & + 1.04025281_wp, 0.92738624_wp, 1.07419210_wp, 1.07900668_wp, 1.04712861_wp, & + 1.15018618_wp, 1.15388455_wp, 1.36313743_wp, 1.36485106_wp, 1.39801837_wp, & + 1.18695346_wp, 0.36273870_wp, 0.58797255_wp, 0.71961946_wp, 0.96158233_wp, & + 0.89585296_wp, 0.81360499_wp, 1.00794665_wp, 0.92613682_wp, 1.09152285_wp, & + 1.14907070_wp, 1.13508911_wp, 1.08853785_wp, 1.11005982_wp, 1.12452195_wp, & + 1.21642129_wp, 1.36507125_wp, 1.40340000_wp, 1.16653482_wp, 0.34125098_wp, & + 0.58884173_wp, 0.68441115_wp, 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, & + 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, & + 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, & + 0.56999999_wp, 0.87936784_wp, 1.02761808_wp, 0.93297476_wp, 1.10172128_wp, & + 0.97350071_wp, 1.16695666_wp, 1.23997927_wp, 1.18464453_wp, 1.14191734_wp, & + 1.12334192_wp, 1.01485321_wp, 1.12950808_wp, 1.30804834_wp, 1.33689961_wp, & + 1.27465977_wp /) + real(wp),parameter :: gamparam(max_elem) = (/ & + -0.35015861_wp, 1.04121227_wp, 0.09281243_wp, 0.09412380_wp, 0.26629137_wp, & + 0.19408787_wp, 0.05317918_wp, 0.03151644_wp, 0.32275132_wp, 1.30996037_wp, & + 0.24206510_wp, 0.04147733_wp, 0.11634126_wp, 0.13155266_wp, 0.15350650_wp, & + 0.15250997_wp, 0.17523529_wp, 0.28774450_wp, 0.42937314_wp, 0.01896455_wp, & + 0.07179178_wp,-0.01121381_wp,-0.03093370_wp, 0.02716319_wp,-0.01843812_wp, & + -0.15270393_wp,-0.09192645_wp,-0.13418723_wp,-0.09861139_wp, 0.18338109_wp, & + 0.08299615_wp, 0.11370033_wp, 0.19005278_wp, 0.10980677_wp, 0.12327841_wp, & + 0.25345554_wp, 0.58615231_wp, 0.16093861_wp, 0.04548530_wp,-0.02478645_wp, & + 0.01909943_wp, 0.01402541_wp,-0.03595279_wp, 0.01137752_wp,-0.03697213_wp, & + 0.08009416_wp, 0.02274892_wp, 0.12801822_wp,-0.02078702_wp, 0.05284319_wp, & + 0.07581190_wp, 0.09663758_wp, 0.09547417_wp, 0.07803344_wp, 0.64913257_wp, & + 0.15348654_wp, 0.05054344_wp, 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, & + 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, & + 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, & + 0.11000000_wp,-0.02786741_wp, 0.01057858_wp,-0.03892226_wp,-0.04574364_wp, & + -0.03874080_wp,-0.03782372_wp,-0.07046855_wp, 0.09546597_wp, 0.21953269_wp, & + 0.02522348_wp, 0.15263050_wp, 0.08042611_wp, 0.01878626_wp, 0.08715453_wp, & + 0.10500484_wp /) + real(wp),parameter :: kappa(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, & + 0.07126660_wp, 0.13682750_wp, 0.14877121_wp,-0.10219289_wp,-0.08979338_wp, & + -0.08273597_wp,-0.01754829_wp,-0.02765460_wp,-0.02558926_wp,-0.08010286_wp, & + -0.04163215_wp,-0.09369631_wp,-0.03774117_wp,-0.05759708_wp, 0.02431998_wp, & + -0.01056270_wp,-0.02692862_wp, 0.07657769_wp, 0.06561608_wp, 0.08006749_wp, & + 0.14139200_wp,-0.05351029_wp,-0.06701705_wp,-0.07377246_wp,-0.02927768_wp, & + -0.03867291_wp,-0.06929825_wp,-0.04485293_wp,-0.04800824_wp,-0.01484022_wp, & + 0.07917502_wp, 0.06619243_wp, 0.02434095_wp,-0.01505548_wp,-0.03030768_wp, & + 0.01418235_wp, 0.08953411_wp, 0.08967527_wp, 0.07277771_wp,-0.02129476_wp, & + -0.06188828_wp,-0.06568203_wp,-0.11000000_wp,-0.11000000_wp,-0.11000000_wp, & + -0.11000000_wp,-0.11000000_wp,-0.11000000_wp,-0.11000000_wp,-0.11000000_wp, & + -0.11000000_wp,-0.11000000_wp,-0.11000000_wp,-0.11000000_wp,-0.11000000_wp, & + -0.11000000_wp,-0.03585873_wp,-0.03132400_wp,-0.05902379_wp,-0.02827592_wp, & + -0.07606260_wp,-0.02123839_wp, 0.03814822_wp, 0.02146834_wp, 0.01580538_wp, & + -0.00894298_wp,-0.05864876_wp,-0.01817842_wp, 0.07721851_wp, 0.07936083_wp, & + 0.05849285_wp /) + real(wp),parameter :: alphaparam(max_elem) = (/ & + 0.55159092_wp, 0.66205886_wp, 0.90529132_wp, 1.51710827_wp, 2.86070364_wp, & + 1.88862966_wp, 1.32250290_wp, 1.23166285_wp, 1.77503721_wp, 1.11955204_wp, & + 1.28263182_wp, 1.22344336_wp, 1.70936266_wp, 1.54075036_wp, 1.38200579_wp, & + 2.18849322_wp, 1.36779065_wp, 1.27039703_wp, 1.64466502_wp, 1.58859404_wp, & + 1.65357953_wp, 1.50021521_wp, 1.30104175_wp, 1.46301827_wp, 1.32928147_wp, & + 1.02766713_wp, 1.02291377_wp, 0.94343886_wp, 1.14881311_wp, 1.47080755_wp, & + 1.76901636_wp, 1.98724061_wp, 2.41244711_wp, 2.26739524_wp, 2.95378999_wp, & + 1.20807752_wp, 1.65941046_wp, 1.62733880_wp, 1.61344972_wp, 1.63220728_wp, & + 1.60899928_wp, 1.43501286_wp, 1.54559205_wp, 1.32663678_wp, 1.37644152_wp, & + 1.36051851_wp, 1.23395526_wp, 1.65734544_wp, 1.53895240_wp, 1.97542736_wp, & + 1.97636542_wp, 2.05432381_wp, 3.80138135_wp, 1.43893803_wp, 1.75505957_wp, & + 1.59815118_wp, 1.76401732_wp, 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, & + 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, & + 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, & + 1.63999999_wp, 1.47055223_wp, 1.81127084_wp, 1.40189963_wp, 1.54015481_wp, & + 1.33721475_wp, 1.57165422_wp, 1.04815857_wp, 1.78342098_wp, 2.79106396_wp, & + 1.78160840_wp, 2.47588882_wp, 2.37670734_wp, 1.76613217_wp, 2.66172302_wp, & + 2.82773085_wp /) +!&> + +!! ------------------------------------------------------------------------ +! initizialization +!! ------------------------------------------------------------------------ + m = n+1 + allocate (ipiv(m),source=0) + allocate (Amat(m,m),Xvec(m),alpha(n),dqdr(3,n,m),source=0.0_wp) + +!! ------------------------------------------------------------------------ +! set up the A matrix and X vector +!! ------------------------------------------------------------------------ +! αi -> alpha(i), ENi -> xi(i), κi -> kappa(i), Jii -> gam(i) +! γij = 1/√(αi+αj) +! Xi = -ENi + κi·√CNi +! Aii = Jii + 2/√π·γii +! Aij = erf(γij·Rij)/Rij = 2/√π·F0(γ²ij·R²ij) +!! ------------------------------------------------------------------------ +! prepare some arrays +!$omp parallel default(none) & +!!$omp shared(n,at,chrgeq) & +!$omp shared(n,at) & +!$omp private(i) & +!$omp shared(Xvec,alpha) +!$omp do schedule(dynamic) + do i = 1,n +! Xvec(i) = -chrgeq%en(i) +! alpha(i) = chrgeq%alpha(i)**2 + Xvec(i) = -enparam(at(i)) + alpha(i) = alphaparam(at(i))**2 + end do +!$omp enddo +!$omp endparallel + +!$omp parallel default(none) & +!!$omp shared(n,at,xyz,chrgeq,alpha) & +!$omp shared(n,at,xyz,alpha) & +!$omp private(i,j,r,gamij) & +!$omp shared(Amat) +!$omp do schedule(dynamic) + ! prepare A matrix + do i = 1,n + ! EN of atom i + do j = 1,i-1 + r = sqrt(sum((xyz(:,j)-xyz(:,i))**2)) + gamij = 1.0_wp/sqrt(alpha(i)+alpha(j)) + Amat(j,i) = erf(gamij*r)/r + Amat(i,j) = Amat(j,i) + end do +! Amat(i,i) = chrgeq%gam(i)+sqrt2pi/sqrt(alpha(i)) + Amat(i,i) = gamparam(at(i))+sqrt2pi/sqrt(alpha(i)) + end do +!$omp enddo +!$omp endparallel + +!! ------------------------------------------------------------------------ +! solve the linear equations to obtain partial charges +!! ------------------------------------------------------------------------ + Amat(m,1:m) = 1.0_wp + Amat(1:m,m) = 1.0_wp + Amat(m,m) = 0.0_wp + Xvec(m) = chrg + ! generate temporary copy + allocate (Atmp(m,m),source=Amat) + allocate (Xtmp(m),source=Xvec) + + ! assume work space query, set best value to test after first dsysv call + call dsysv('u',m,1,Atmp,m,ipiv,Xtmp,m,test,-1,info) + lwork = int(test(1)) + allocate (work(lwork),source=0.0_wp) + + call dsysv('u',m,1,Atmp,m,ipiv,Xtmp,m,work,lwork,info) + if (info > 0) error stop '** ERROR ** (goedecker_solve) DSYSV failed' + + if (abs(sum(Xtmp(:n))-chrg) > 1.e-6_wp) & + error stop '** ERROR ** (goedecker_solve) charge constrain error' + !print'(3f20.14)',Xtmp + +!! ------------------------------------------------------------------------ +! calculate isotropic electrostatic (IES) energy +!! ------------------------------------------------------------------------ +! E = ∑i (ENi - κi·√CNi)·qi + ∑i (Jii + 2/√π·γii)·q²i +! + ½ ∑i ∑j,j≠i qi·qj·2/√π·F0(γ²ij·R²ij) +! = q·(½A·q - X) +!! ------------------------------------------------------------------------ +! work(:m) = Xvec +! call dsymv('u',m,0.5_wp,Amat,m,Xtmp,1,-1.0_wp,work,1) +! es = dot_product(Xtmp,work(:m)) +! energy = es + energy + +!! ------------------------------------------------------------------------ +! calculate molecular gradient of the IES energy +!! ------------------------------------------------------------------------ +! dE/dRj -> g(:,j), ∂Xi/∂Rj -> -dcn(:,i,j), ½∂Aij/∂Rj -> dAmat(:,j,i) +! dE/dR = (½∂A/∂R·q - ∂X/∂R)·q +! ∂Aij/∂Rj = ∂Aij/∂Ri +!! ------------------------------------------------------------------------ + allocate (dAmat(3,n,m),source=0.0_wp) +!$omp parallel default(none) & +!$omp shared(n,xyz,alpha,Amat,Xtmp) & +!$omp private(i,j,rij,r2,gamij,arg,dtmp) & +!$omp reduction(+:dAmat) +!$omp do schedule(dynamic) + do i = 1,n + do j = 1,i-1 + rij = xyz(:,i)-xyz(:,j) + r2 = sum(rij**2) + gamij = 1.0_wp/sqrt(alpha(i)+alpha(j)) + arg = gamij**2*r2 + dtmp = 2.0_wp*gamij*exp(-arg)/(sqrtpi*r2)-Amat(j,i)/r2 + dAmat(:,i,i) = +dtmp*rij*Xtmp(j)+dAmat(:,i,i) + dAmat(:,j,j) = -dtmp*rij*Xtmp(i)+dAmat(:,j,j) + dAmat(:,i,j) = +dtmp*rij*Xtmp(i) + dAmat(:,j,i) = -dtmp*rij*Xtmp(j) + end do + end do +!$omp enddo +!$omp endparallel + +!! ------------------------------------------------------------------------ +! invert the A matrix using a Bunch-Kaufman factorization +! A⁻¹ = (L·D·L^T)⁻¹ = L^T·D⁻¹·L +!! ------------------------------------------------------------------------ + allocate (Ainv(m,m),source=Amat) + + ! assume work space query, set best value to test after first dsytrf call + call dsytrf('L',m,Ainv,m,ipiv,test,-1,info) + if (int(test(1)) > lwork) then + deallocate (work) + lwork = int(test(1)) + allocate (work(lwork),source=0.0_wp) + end if + + ! Bunch-Kaufman factorization A = L*D*L**T + call dsytrf('L',m,Ainv,m,ipiv,work,lwork,info) + if (info > 0) then + error stop '** ERROR ** (goedecker_inversion) DSYTRF failed' + + end if + + ! A⁻¹ from factorized L matrix, save lower part of A⁻¹ in Ainv matrix + ! Ainv matrix is overwritten with lower triangular part of A⁻¹ + call dsytri('L',m,Ainv,m,ipiv,work,info) + if (info > 0) then + error stop '** ERROR ** (goedecker_inversion) DSYTRI failed' + end if + + ! symmetrizes A⁻¹ matrix from lower triangular part of inverse matrix + do i = 1,m + do j = i+1,m + Ainv(i,j) = Ainv(j,i) + end do + end do + +!! ------------------------------------------------------------------------ +! calculate gradient of the partial charge w.r.t. the nuclear coordinates +!! ------------------------------------------------------------------------ + !call dsymm('r','l',3*n,m,-1.0_wp,Ainv,m,dAmat,3*n,1.0_wp,dqdr,3*n) + call dgemm('n','n',3*n,m,m,-1.0_wp,dAmat,3*n,Ainv,m,1.0_wp,dqdr,3*n) + !print'(/,"analytical gradient")' + !print'(3f20.14)',dqdr(:,:,:n) + +!! ------------------------------------------------------------------------ +! molecular Hessian calculation +!! ------------------------------------------------------------------------ + do i = 1,n + do j = 1,i-1 + rij = xyz(:,j)-xyz(:,i) + r2 = sum(rij**2) + r = sqrt(r2) + gamij = 1.0_wp/sqrt(alpha(i)+alpha(j)) + gamij2 = gamij**2 + arg2 = gamij2*r2 + arg = sqrt(arg2) + erfterm = Xtmp(i)*Xtmp(j)*erf(arg)/r + expterm = Xtmp(i)*Xtmp(j)*2*gamij*exp(-arg2)/sqrtpi + ! ∂²(qAq)/(∂Ri∂Rj): + ! ∂²(qAq)/(∂Xi∂Xi) = (1-3X²ij/R²ij-2γ²ijX²ij) 2γij/√π exp[-γ²ij·R²ij]/R²ij + ! - (R²ij-3X²ij) erf[γij·Rij]/R⁵ij + ! ∂²(qAq)/(∂Xi∂Xj) = (R²ij-3X²ij) erf[γij·Rij]/R⁵ij + ! - (1-3X²ij/R²ij-2γ²ijX²ij) 2γij/√π exp[-γ²ij·R²ij]/R²ij + ! ∂²(qAq)/(∂Xi∂Yi) = 3X²ij erf[γij·Rij]/R⁵ij + ! - (3X²ij/R²ij+2γ²ijX²ij) 2γij/√π exp[-γ²ij·R²ij]/R²ij + ! ∂²(qAq)/(∂Xi∂Yj) = (3X²ij/R²ij+2γ²ijX²ij) 2γij/√π exp[-γ²ij·R²ij]/R²ij + ! - 3X²ij erf[γij·Rij]/R⁵ij + rxr(1,1) = erfterm*(3*rij(1)**2/r2**2-1.0_wp/r2) & + -expterm*(3*rij(1)**2/r2**2+2*gamij2*rij(1)**2/r2-1/r2) + rxr(2,2) = erfterm*(3*rij(2)**2/r2**2-1.0_wp/r2) & + -expterm*(3*rij(2)**2/r2**2+2*gamij2*rij(2)**2/r2-1/r2) + rxr(3,3) = erfterm*(3*rij(3)**2/r2**2-1.0_wp/r2) & + -expterm*(3*rij(3)**2/r2**2+2*gamij2*rij(3)**2/r2-1/r2) + rxr(2,1) = erfterm*3*rij(2)*rij(1)/r2**2 & + -expterm*(3*rij(2)*rij(1)/r2**2+2*gamij2*rij(2)*rij(1)/r2) + rxr(3,1) = erfterm*3*rij(3)*rij(1)/r2**2 & + -expterm*(3*rij(3)*rij(1)/r2**2+2*gamij2*rij(3)*rij(1)/r2) + rxr(3,2) = erfterm*3*rij(3)*rij(2)/r2**2 & + -expterm*(3*rij(3)*rij(2)/r2**2+2*gamij2*rij(3)*rij(2)/r2) + + do k = 1,m + rxr(1,1) = rxr(1,1)+0.5_wp*dqdr(1,i,k)*dAmat(1,j,k) & + +0.5_wp*dqdr(1,j,k)*dAmat(1,i,k) + rxr(2,1) = rxr(2,1)+0.5_wp*dqdr(2,i,k)*dAmat(1,j,k) & + +0.5_wp*dqdr(2,j,k)*dAmat(1,i,k) + rxr(3,1) = rxr(3,1)+0.5_wp*dqdr(3,i,k)*dAmat(1,j,k) & + +0.5_wp*dqdr(3,j,k)*dAmat(1,i,k) + rxr(2,2) = rxr(2,2)+0.5_wp*dqdr(2,i,k)*dAmat(2,j,k) & + +0.5_wp*dqdr(2,j,k)*dAmat(2,i,k) + rxr(3,2) = rxr(3,2)+0.5_wp*dqdr(3,i,k)*dAmat(2,j,k) & + +0.5_wp*dqdr(3,j,k)*dAmat(2,i,k) + rxr(3,3) = rxr(3,3)+0.5_wp*dqdr(3,i,k)*dAmat(3,j,k) & + +0.5_wp*dqdr(3,j,k)*dAmat(3,i,k) + end do + ! symmetrize + rxr(1,2) = rxr(2,1) + rxr(1,3) = rxr(3,1) + rxr(2,3) = rxr(3,2) + + ! save diagonal elements for atom i + hess(ind(1,i,1,i)) = hess(ind(1,i,1,i))+kq*rxr(1,1) + hess(ind(2,i,1,i)) = hess(ind(2,i,1,i))+kq*rxr(2,1) + hess(ind(2,i,2,i)) = hess(ind(2,i,2,i))+kq*rxr(2,2) + hess(ind(3,i,1,i)) = hess(ind(3,i,1,i))+kq*rxr(3,1) + hess(ind(3,i,2,i)) = hess(ind(3,i,2,i))+kq*rxr(3,2) + hess(ind(3,i,3,i)) = hess(ind(3,i,3,i))+kq*rxr(3,3) + ! save elements between atom i and atom j + hess(ind(1,i,1,j)) = hess(ind(1,i,1,j))-kq*rxr(1,1) + hess(ind(1,i,2,j)) = hess(ind(1,i,2,j))-kq*rxr(2,1) + hess(ind(1,i,3,j)) = hess(ind(1,i,3,j))-kq*rxr(3,1) + hess(ind(2,i,1,j)) = hess(ind(2,i,1,j))-kq*rxr(2,1) + hess(ind(2,i,2,j)) = hess(ind(2,i,2,j))-kq*rxr(2,2) + hess(ind(2,i,3,j)) = hess(ind(2,i,3,j))-kq*rxr(3,2) + hess(ind(3,i,1,j)) = hess(ind(3,i,1,j))-kq*rxr(3,1) + hess(ind(3,i,2,j)) = hess(ind(3,i,2,j))-kq*rxr(3,2) + hess(ind(3,i,3,j)) = hess(ind(3,i,3,j))-kq*rxr(3,3) + ! save diagonal elements for atom j + hess(ind(1,j,1,j)) = hess(ind(1,j,1,j))+kq*rxr(1,1) + hess(ind(2,j,1,j)) = hess(ind(2,j,1,j))+kq*rxr(2,1) + hess(ind(2,j,2,j)) = hess(ind(2,j,2,j))+kq*rxr(2,2) + hess(ind(3,j,1,j)) = hess(ind(3,j,1,j))+kq*rxr(3,1) + hess(ind(3,j,2,j)) = hess(ind(3,j,2,j))+kq*rxr(3,2) + hess(ind(3,j,3,j)) = hess(ind(3,j,3,j))+kq*rxr(3,3) + end do + end do + + ! ∂²(qA)/(∂Ri∂q)·∂q/∂Rj + ! hessian = hessian + reshape(matmul(reshape(dqdr,(/3*n,m/)),& + ! transpose(reshape(dAmat,(/3*n,m/)))),(/3,n,3,n/)) + !call dgemm('n','t',3*n,m,3*n,+1.0_wp,dqdr,3*n,dAmat,3*n,1.0_wp,hessian,3*n) + !call dgemm('n','t',3*n,m,3*n,+1.0_wp,dAmat,3*n,dqdr,3*n,1.0_wp,hessian,3*n) + + end subroutine mh_eeq + +!========================================================================================! +!########################################################################################! !========================================================================================! end module modelhessian_module diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index 9c323eb2..f1692c7c 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -87,7 +87,7 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) if (calc%do_HR) then allocate (calc%chess) allocate (H_init(nat3,nat3)) - call calc%chess%alloc(mol%nat,calc%hu_steps,calc%hguess,calc%initialize_hr_type) + call calc%chess%alloc(mol%nat,calc%hu_steps,calc%hguess,calc%initialize_hr_type, calc%hr_hu_type) end if !> initial singlepoint @@ -131,6 +131,7 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) else idx = minloc(calc%chess%order,1) + if (minval(calc%chess%order) .eq. 0) idx = 1 call initialize_hessian(calc,calc%chess%initialize_type,calc%chess%coords(idx,:,:),molnew%nat,molnew%at,calc%chess%hess(:),calc%chess%hguess,pr) !> This hguess is set through the hguess variable of the optimizer and needs to be hardcoded/set explicitly before initialization for benchmarking!! call dhtosq(nat3,H_init,calc%chess%hess) !> maybe this should all be inside the construct bfgs function later? -> cannot due to circular import!!! @@ -141,7 +142,7 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & & calc%ht,calc%gt,calc%stot,etot) - call calc%chess%construct_hessian_bfgs() + call calc%chess%construct_hessian() write (stdout,*) write (stdout,*) "THERMO FROM RECONSTRUCTED HESSIAN:" diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index de4bb8dc..61bc897f 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -610,7 +610,7 @@ subroutine parse_calc_auto(env,calc,kv,rd) calc%initialize_hr_type = 3 case('gfn2') calc%initialize_hr_type = 4 - case('lindh') + case('modhess') calc%initialize_hr_type = 5 case default !>--- keyword was recognized, but invalid argument supplied @@ -618,6 +618,22 @@ subroutine parse_calc_auto(env,calc,kv,rd) call creststop(status_config) end select + case ('modhess_type','mh_type') !> here we set how the matrix for hessian reconstruction is initialized + select case (kv%value_c) !>maybe need to add another keywort for crosstesting hr and geopt + case('lindh95') + calc%mh_type = 0 + case('lindh') + calc%mh_type = 1 + case('lindh07') + calc%mh_type = 2 + case('swart') + calc%mh_type = 3 + case default + !>--- keyword was recognized, but invalid argument supplied + write (stdout,fmtura) kv%value_c + call creststop(status_config) + end select + case ('hess_init','hess_initialization') !> here we set how the hessian for optimization select case (kv%value_c) case('identity') @@ -630,7 +646,7 @@ subroutine parse_calc_auto(env,calc,kv,rd) calc%hess_init = 3 case('gfn2') calc%hess_init = 4 - case('lindh') + case('modhess') calc%hess_init = 5 case default !>--- keyword was recognized, but invalid argument supplied @@ -638,6 +654,24 @@ subroutine parse_calc_auto(env,calc,kv,rd) call creststop(status_config) end select + case ('hr_hess_update','hr_hu_update') + select case (kv%value_c) !> Hessian updates in hessian reconstruction + case ('bfgs') + calc%hr_hu_type = 0 + case ('powell') + calc%hr_hu_type = 1 + case ('sr1') + calc%hr_hu_type = 2 + case ('bofill') + calc%hr_hu_type = 3 + case ('schlegel') + calc%hr_hu_type = 4 + case default + !>--- keyword was recognized, but invalid argument supplied + write (stdout,fmtura) kv%value_c + call creststop(status_config) + end select + case ('freeze') call get_atlist(env%ref%nat,atlist,kv%value_c,env%ref%at) calc%nfreeze = count(atlist) From f5887d1a18e81e549eb4364b1f81ff6efb5cebea Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 5 Feb 2026 23:22:18 +0100 Subject: [PATCH 161/374] Work on required CREGEN refactor 4 --- src/minitools.f90 | 5 +- src/sorting/cregen.f90 | 544 +++++++++++++++++++++++------- src/sorting/cregen_interfaces.f90 | 32 +- src/sorting/rotcompare.f90 | 184 +++++----- 4 files changed, 533 insertions(+), 232 deletions(-) diff --git a/src/minitools.f90 b/src/minitools.f90 index fec05bce..b19342c0 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -96,6 +96,7 @@ subroutine printaniso(fname,bmin,bmax,bshift) use crest_parameters use strucrd use axis_module + use rotaniso_mod implicit none character(len=*) :: fname type(coord),allocatable :: structures(:) @@ -106,11 +107,9 @@ subroutine printaniso(fname,bmin,bmax,bshift) integer,allocatable :: at(:) real(wp),allocatable :: rot(:,:) - real(wp) :: rotaniso !function real(wp),allocatable :: anis(:) real(wp) :: evec(3,3),evecavg(3,3) - real(wp) :: bthrerf real(wp) :: bmin,bmax,bshift real(wp) :: thr real(wp) :: dum @@ -135,7 +134,7 @@ subroutine printaniso(fname,bmin,bmax,bshift) do i = 1,nall c1(1:3,:) = structures(i)%xyz(1:3,:)*autoaa call axis(nat,at,c1,rot(1:3,i),dum,evec) - anis(i) = rotaniso(i,nall,rot) + anis(i) = rotaniso(rot(1:3,i)) thr = bthrerf(bmin,anis(i),bmax,bshift) write (*,'(3f10.2,2x,f8.4,2x,f8.4)') rot(1:3,i),anis(i),thr end do diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 4f549739..1b66f88f 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -141,14 +141,16 @@ subroutine newcregen(env,quickset,infile) if (pr1) call cregen_pr1(prch,env,nat,nallref,rthr,bthr,pthr,ewin) !>--- allocate space and read in the ensemble - !allocate (at(nat),comments(nallref),xyz(3,nat,nallref)) - !call rdensemble(fname,nat,nallref,at,xyz,comments) call rdensemble(fname,nallref,structures) - !allocate(references, source=structures) !>--- track ensemble for restart !call trackensemble(fname,nat,nallref,at,xyz,comments) +!> NOTE: We check topology and broken structures FIRST before +!> sorting by the energy an making a cut, because chemical changes +!> may produce isomers that are lower in energy at the given +!> level of theory. We do not want that when looking for conformers specifically. + !>--- check if the ensemble contains broken structures? i.e., fusion or dissociation if (checkbroken) then call cregen_discardbroken(prch,env,topocheck,structures,nall) @@ -159,48 +161,42 @@ subroutine newcregen(env,quickset,infile) !>--- compare neighbourlists to sort out chemically transformed structures if (topocheck) then call cregen_topocheck(prch,env,checkez,structures,nallnew) - nall = nallnew + nall = nallnew !> update !>--- if structures were discarded, resize xyz end if if (topocheck.or.checkbroken) then - write (prch,'('' number of reliable points :'',i6)') nall + write (prch,'(" number of reliable points",t35,":",i10)') nall end if - stop - !>--- sort the ensemble by its energies and make a cut (EWIN) if (sortE) then - call cregen_esort(prch,nat,nall,xyz,comments,nallnew,ewin) - !>--- if structures were discarded, resize xyz - if (nallnew .lt. nall) then - nall = nallnew - xyzref = xyz(:,:,1:nall) - call move_alloc(xyzref,xyz) - comref = comments(1:nall) - call move_alloc(comref,comments) - end if + call cregen_esort(prch,structures,nallnew,ewin=ewin) + nall = nallnew !> update end if !>--- do the rotational constants and RMSD check if (sortRMSD) then - allocate (group(0:nall)) - call cregen_CRE(prch,env,nat,nall,at,xyz,comments,nallnew,group,.false.) -!>--- if structures were discarded, resize xyz - if (nallnew .lt. nall) then - nall = nallnew - xyzref = xyz(:,:,1:nall) - call move_alloc(xyzref,xyz) - comref = comments(1:nall) - call move_alloc(comref,comments) - allocate (gref(0:nallnew)) - gref(0:nallnew) = group(0:nallnew) - call move_alloc(gref,group) - nall = nallnew - end if -!>--- repair the order - if (repairord) then - call cregen_repairorder(nat,nall,xyz,comments,group) - end if +! allocate (group(0:nall)) +! call cregen_CRE(prch,env,nat,nall,at,xyz,comments,nallnew,group,.false.) +!!>--- if structures were discarded, resize xyz +! if (nallnew .lt. nall) then +! nall = nallnew +! xyzref = xyz(:,:,1:nall) +! call move_alloc(xyzref,xyz) +! comref = comments(1:nall) +! call move_alloc(comref,comments) +! allocate (gref(0:nallnew)) +! gref(0:nallnew) = group(0:nallnew) +! call move_alloc(gref,group) +! nall = nallnew +! end if +!!>--- repair the order +! if (repairord) then +! call cregen_repairorder(nat,nall,xyz,comments,group) +! end if + + call cregen_CRE_new(env,nall,structures,group,rthr, & + & ethr/autokcal,bthr,printlvl=2,ch=prch) !>--- get group info to degen ng = group(0) allocate (degen(3,ng)) @@ -219,10 +215,12 @@ subroutine newcregen(env,quickset,infile) degen = 0 end if end if - if (sortRMSD2) then - allocate (group(0:nall)) - call cregen_CRE(prch,env,nat,nall,at,xyz,comments,nallnew,group,.true.) - end if +! if (sortRMSD2) then +! allocate (group(0:nall)) +! call cregen_CRE(prch,env,nat,nall,at,xyz,comments,nallnew,group,.true.) +! end if + + stop !=====================================================================! !> E N S E M B L E O U T P U T @@ -636,7 +634,7 @@ subroutine cregen_discardbroken(ch,env,topocheck,structures,newnall) !> Check fragments call env%ref%to(mol0) call cregen_calculate_fragments(mol0,nfrag=frag0) - write (ch,'('' # fragment in coord :'',i6)') frag0 + write (ch,'(" # fragment in coord",t35,":",i10)') frag0 !>--- loop over the structures allocate (broke(nall),source=.false.) @@ -683,7 +681,7 @@ subroutine cregen_discardbroken(ch,env,topocheck,structures,newnall) end do call move_alloc(tmpstructures,structures) llan = nall-newnall - write (ch,'('' number of removed clashes :'',i6)') llan + write (ch,'(" number of removed clashes",t35,":",i10)') llan end if !>--- otherwise the ensemble is ok if (allocated(broke)) deallocate (broke) @@ -712,11 +710,7 @@ subroutine cregen_topocheck(ch,env,checkez,structures,newnall) logical,intent(in) :: checkez type(coord),intent(inout),allocatable,target :: structures(:) integer,intent(out) :: newnall - integer :: nat,nall - integer :: llan - integer,allocatable :: order(:),orderref(:) - real(wp),allocatable :: cref(:,:),c1(:,:) - integer,allocatable :: atdum(:) + integer :: nat,nall,llan real(wp),allocatable :: cn(:),bond(:,:) integer,allocatable :: toporef(:) integer,allocatable :: topo(:) @@ -748,12 +742,12 @@ subroutine cregen_topocheck(ch,env,checkez,structures,newnall) end if nbonds = sum(toporef) - write (ch,'('' # bonds in reference structure :'',i6)') nbonds + write (ch,'(" # bonds in reference structure",t35,":",i10)') nbonds !>--- if required, check for C=C bonds (based only on structure!) if (checkez) then call nezcc(nat,mol0%at,mol0%xyz,cn,ntopo,toporef,ncc) if (ncc > 0) then - write (ch,'('' => # of C=C bonds :'',i6)') ncc + write (ch,'(" => # of C=C bonds : ",i0)') ncc allocate (ezat(4,ncc)) allocate (ezdihedref(ncc),ezdihed(ncc),source=0.0d0) call ezccat(nat,mol0%at,mol0%xyz,cn,ntopo,toporef,ncc,ezat) @@ -809,13 +803,13 @@ subroutine cregen_topocheck(ch,env,checkez,structures,newnall) !>--- sort the xyz array (only if structures have been discarded) if (newnall .lt. nall) then llan = nall-newnall - write (ch,'('' number of topology mismatches :'',i6)') llan + write (ch,'(" number of topology mismatches",t35,":",i10)') llan !>--- report the removals during a run if (ch .ne. stdout) then write (stdout,'("CREGEN> number of topology-based structure removals: ",i0)') llan end if if (checkez.and.ccfail > 0) then - write (ch,'('' => discared due to E/Z isom. :'',i6)') ccfail + write (ch,'('' => discared due to E/Z isom. : '',i0)') ccfail end if if (newnall >= 1) then allocate (tmpstructures(newnall)) @@ -831,7 +825,7 @@ subroutine cregen_topocheck(ch,env,checkez,structures,newnall) if (ch .ne. stdout) then write (stdout,'("CREGEN> ** WARNING ** Full removal of ensemble! Falling back to reference structure.")') end if - allocate(tmpstructures(1), source=mol0) + allocate (tmpstructures(1),source=mol0) call move_alloc(tmpstructures,structures) end if end if @@ -847,16 +841,14 @@ end subroutine cregen_topocheck !=========================================================================================! -subroutine cregen_esort(ch,nat,nall,xyz,comments,nallout,ewin) +subroutine cregen_esort(ch,structures,nallout,ewin) !************************************************************** !* subroutine cregen_esort !* sort the ensemble by energy and determine the new !* ensemble size within the energy threshold. !* On Input: ch - printout channel -!* nat - number of atoms -!* nall - number of structure in ensemble -!* xyz - Cartesian coordinates -!* comments - commentary lines containing the energy +!* structures - the list of structures +!* nallout - number of surviving structures !* ewin - energy window in kcal/mol !* On Output: nallout - number of strucutres after cutoff !************************************************************** @@ -865,72 +857,60 @@ subroutine cregen_esort(ch,nat,nall,xyz,comments,nallout,ewin) use quicksort_interface implicit none integer,intent(in) :: ch - integer,intent(in) :: nat - integer,intent(in) :: nall - real(wp),intent(inout) :: xyz(3,nat,nall) - character(len=*) :: comments(nall) - integer :: nallout - real(wp),intent(in) :: ewin + type(coord),intent(inout),allocatable :: structures(:) + integer,intent(out) :: nallout + real(wp),intent(in),optional :: ewin + integer :: nall,nat real(wp),allocatable :: energies(:) - integer,allocatable :: orderref(:) - integer,allocatable :: order(:) - real(wp),allocatable :: c0(:,:) - integer :: i + type(coord),allocatable :: tmpstructures(:) + integer :: ii,jj real(wp) :: de,emax - allocate (energies(nall)) - allocate (orderref(nall),order(nall)) - do i = 1,nall - energies(i) = grepenergy(comments(i)) - orderref(i) = i - order(i) = i - end do - !>-- sort the energies and obtain the order - call qsort(energies,1,nall,orderref) - !>-- after the sorting orderref contains information: - !> before the sorting element "i" WAS at position "orderref(i)" - !> but to use it as a mask, we need to invert it, - !> so that it is: element "i" IS NOW at position "orderref(i)" - call maskinvert(nall,orderref) - - !>-- sort structures and comments based on the order - order = orderref - allocate (c0(3,nat)) - call xyzqsort(nat,nall,xyz,c0,order,1,nall) - deallocate (c0) - order = orderref + nall = size(structures,1) + nallout = nall + call ensemble_qsort(nall,structures,1,nall) - !call stringqsort(nall,comments,1,nall,order) - call stringqsort(nall,len(comments(1)),comments,1,nall,order) + !>-- determine cut-off of energies (optional) + if (present(ewin)) then - !>-- determine cut-off of energies - if (ewin < 9999.9_wp) then - write (ch,'('' sorting energy window (EWIN) :'',1x,f9.4,a)') ewin,' / kcal*mol⁻¹' - else - write (ch,'('' sorting energy window (EWIN) :'',3x,a,a)') '+∞',' / kcal*mol⁻¹' - end if - emax = maxval(energies(:),1) - de = (emax-energies(1))*autokcal - if (de .gt. ewin) then - nallout = 1 !> lowest is always taken - do i = 2,nall - de = (energies(i)-energies(1))*autokcal - if (de .lt. ewin) then - nallout = nallout+1 - else - exit - end if + allocate (energies(nall)) + do ii = 1,nall + energies(ii) = structures(ii)%energy end do - write (ch,'('' number of removed by energy :'',3x,i0)') (nall-nallout) - write (ch,'('' number of remaining points :'',3x,i0)') nallout - else - nallout = nall + + if (ewin < 9999.9_wp) then + write (ch,'(" sorting energy window (EWIN)",t32,":",1x,f9.4,a)') ewin,' / kcal*mol⁻¹' + else + write (ch,'(" sorting energy window (EWIN)",t32,":",3x,a,a)') '+∞',' / kcal*mol⁻¹' + end if + emax = maxval(energies(:),1) + de = (emax-energies(1))*autokcal + if (de .gt. ewin) then + nallout = 1 !> lowest is always taken + do ii = 2,nall + de = (energies(ii)-energies(1))*autokcal + if (de .lt. ewin) then + nallout = nallout+1 + else + exit + end if + end do + write (ch,'(" number of removed by energy",t32,":",3x,i0)') (nall-nallout) + write (ch,'(" number of remaining points",t32,":",3x,i0)') nallout + + allocate (tmpstructures(nallout)) + do ii = 1,nallout + tmpstructures(ii) = structures(ii) + end do + call move_alloc(tmpstructures,structures) + else + nallout = nall + end if + write (ch,'(" reference state Etot",t32,":",2x,es14.6)') energies(1) + deallocate (energies) end if - write (ch,*) 'reference state Etot :',energies(1) - deallocate (order,orderref) - deallocate (energies) return end subroutine cregen_esort @@ -938,6 +918,9 @@ end subroutine cregen_esort subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) !************************************************************* +!* NOTE: +!* This routine is deprecated, see crest_CRE_new below for current version +!* !* subroutine cregen_CRE !* sort the ensemble based on rotational constants,RMSD and !* energy to determine rotamers and duplicates. @@ -958,6 +941,7 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) use axis_module use utilities use quicksort_interface + use rotaniso_mod implicit none type(systemdata) :: env integer,intent(in) :: ch @@ -997,7 +981,6 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) logical :: l1,l2,l3 !>--- CRE comparison data integer,allocatable :: double(:) - logical :: equalrotaniso !> this is a function logical,allocatable :: mask(:) real(wp) :: couthr real(wp),allocatable :: enuc(:) @@ -1320,6 +1303,329 @@ subroutine heavymask(nat,at,mask) end subroutine heavymask end subroutine cregen_CRE +!=========================================================================================! +subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & + & printlvl,ch) +!************************************************************************************** +!* Re-ractored implementaiton of the original CREGEN workflow, classifying conformers +!* according to their quaternion RMSD, rotational constants, energy, +!* and pair-distance sum +!* "structures" will be updated so that all true duplicates are pruned and +!* molecules are clustered by their group. "group" and "nall" are also updated. +!* +!* Input arguments: +!* env - CREST systemdata +!* nall - total number of structures +!* structures - the structures +!* groups - group assignment for each structure (dimension 0:nall), group(0) = maxval(group(1:nall)) +!* rthresh - RMSD threshold (in ANGSTRÖM) for conformer distinction +!* ethr - inter-conformer energy threshold (in HARTREE) for pre-sorting +!* bthr - rotational constant similarity threshold (percentage based) +!* +!* Optionals: +!* printlvl - integer to direct the print verbosity. (0=minimal, 1=verbose) +!* ch - integer for print channel +!* +!* Output: +!* groups - integer array assigning each structure to a group +!************************************************************************************* + use crest_parameters + use crest_data + use rotaniso_mod + use axis_module + use strucrd + use canonical_mod + use irmsd_module + implicit none + !> INPUT + type(systemdata),intent(inout) :: env + integer,intent(inout) :: nall + type(coord),intent(inout),allocatable,target :: structures(:) + integer,intent(out),allocatable :: groups(:) + real(wp),intent(in) :: RTHRESH + real(wp),intent(in) :: ETHR + real(wp),intent(in) :: BTHR + integer,intent(in),optional :: printlvl + integer,intent(in),optional :: ch + + !> LOCAL + integer :: i,ii,jj,kk,T,cc,nat,io + integer :: gcount,ggcount,nallnew + integer :: prlvl,prch + type(rmsd_cache),allocatable :: rcaches(:) + type(coord),allocatable,target :: workmols(:) + type(canonical_sorter),allocatable :: sorters(:) + type(coord),pointer :: ref,mol + real(wp) :: rmsdval,RTHR,ediff,eii,avmom,rsq + real(wp),allocatable :: rot(:,:) + integer,allocatable :: prune_table(:) + real(wp),allocatable :: enuc(:) + logical :: l1,l2 + character(len=:),allocatable :: tmpstr + logical :: heavy,substruc + logical,allocatable :: mask(:) + integer,allocatable :: tmpgroups(:),double(:) + type(coord),allocatable :: tmpstructures(:) + !type(progress_state) :: ps + + !> defaults that are practically never touched + real(wp),parameter :: bthrmax = 0.025_wp + real(wp),parameter :: bthrshift = 0.5_wp + real(wp),parameter :: enuc_thr = 1.0d-3 + + logical,parameter :: debug = .false. + +!>--- handle optional arguments + if (present(printlvl)) then + prlvl = printlvl + else + prlvl = 1 + end if + + if (present(ch)) then + prch = ch + else + prch = stdout + end if + +!>--- set up parallelization +! ... + T = 1 !> doing it serial for now + +!>--- set up parameters (NOTE, we are working with BOHR internally) + RTHR = RTHRESH*aatoau + +!>--- reference structure (the first one) for some setup + ref => structures(1) + nat = ref%nat + +!>--- print some sorting data + if (prlvl > 0) then + tmpstr = 'Info for CREGEN sorting:' + if (prlvl > 1.and.prch == stdout) then + ! call printc(style(S_BOLD)//fg(YELLOW,bright=.true.)//trim(tmpstr)//reset()) + else + write (prch,'(a)') 'Info for CREGEN sorting:' + end if + !write (prch,'(2x,a,i10)') 'number of structures :',nall + write (prch,'(2x,a,t32,a,f10.5,a)') 'RTHR (RMSD threshold)',':',RTHR*autoaa,' Å' + write (prch,'(2x,a,t32,a,es10.2,a)') 'ETHR (energy threshold)',':',ETHR,' Ha' + write (prch,'(2x,a,t32,a,f10.2,a)') 'BTHR (rot. threshold)',':',BTHR*100,' %' + !write (prch,'(2x,a,i9)') 'OpenMP threads :',T + end if + +!>--- mask setup: We may not include all atoms in the checks + heavy = env%heavyrmsd + substruc = (nat .ne. env%rednat.and.env%subRMSD.and.allocated(env%includeRMSD)) + if (heavy.or.substruc) then + allocate (mask(nat),source=.false.) + end if + if (heavy) then + do ii = 1,nat + if (structures(1)%at(ii) .ne. 1) mask(ii) = .true. + end do + end if + if (substruc) then + do ii = 1,nat + mask(ii) = (env%includeRMSD(ii) .eq. 1) + end do + end if + if((heavy.or.substruc).and.(prlvl > 0))then + write(prch,'(" Heavy/masked atoms",t32,":",i10," / ",i0)') count(mask),nat + endif + + if (prlvl > 0) then + tmpstr = "Starting calculations..." + if (prlvl > 1.and.prch == stdout) then + ! call printc(style(S_BOLD)//fg(YELLOW,bright=.true.)//trim(tmpstr)//reset()) + else + write (stdout,'(a)') trim(tmpstr) + end if + end if +!>--- allocate work cache + if (prlvl > 0) then + write (prch,'(a)',advance='no') 'Allocating RMSD work cache ... ' + flush (prch) + end if + allocate (rcaches(T)) + allocate (workmols(T)) + do i = 1,T + mol => workmols(i) + allocate (mol%at(ref%nat)) + allocate (mol%xyz(3,ref%nat)) + nullify (mol) + call rcaches(i)%allocate(ref%nat) + end do + if (prlvl > 0) then + write (prch,'(a)') 'done.' + end if + +!> ---------------------------------------------- +!> PRE-PROCESSING for more efficient sorting +!> ---------------------------------------------- + !> prune_table keeps track of which structure to compare to + !> so for a list of structures (1...j...k...nall), the entry + !> prune_table(k) = j, tells us structure k is compared to all + !> structures j up to k-1. The table is initialized to 1, so + !> the full comparison list is used. + allocate (prune_table(nall),source=1) + !> conveniently, we can use the energy threshold to set a better + !> comparison table, as in the original CREGEN routine. + do ii = 1,nall + eii = structures(ii)%energy + do jj = 1,ii + ediff = abs(eii-structures(jj)%energy) + if (ediff <= ETHR) then + prune_table(ii) = jj + exit + end if + end do + end do + + !> Prepare axis comparison + !> axis alignment and rotational constant calculation + allocate (rot(3,nall),source=0.0_wp) + do ii = 1,nall + mol => structures(ii) + call axis(mol%nat,mol%at,mol%xyz) !> all coordinates to CMA + call axis(mol%nat,mol%at,moL%xyz*autoaa,rot(1:3,ii),avmom)!> B_0 in MHz + end do + + !> Scaled sum of atom-atom-distances (empirical measure) + allocate (enuc(nall),source=0.0_wp) + do ii = 1,nall + mol => structures(ii) + do jj = 1,mol%nat-1 + do kk = jj+1,mol%nat + rsq = (mol%xyz(1,jj)-mol%xyz(1,kk))**2 & + & +(mol%xyz(2,jj)-mol%xyz(2,kk))**2 & + & +(mol%xyz(3,jj)-mol%xyz(3,kk))**2+1.d-12 + enuc(ii) = enuc(ii)+real(mol%at(jj)*mol%at(kk),wp)/rsq + end do + end do + end do + +!> -------------------------------------------- +!> pre-processing end +!> -------------------------------------------- + +!>--- run the checks + if (prlvl > 0) then + write (prch,'(a,6x,a)',advance='no') 'Running CREGEN checks','... ' + flush (prch) + if (prlvl > 1.and.prch == stdout) then + ! write (stdout,*) + ! call progress_init(ps,width=50,prefix=" ↳", & + ! & suffix="",show_time=.true.,show_eta=.false.) + ! call progress_update(ps,0,nall) + else + write (stdout,'(a)',advance='no') 'CREGEN> running RMSDs ...' + flush (stdout) + end if + end if + allocate (groups(nall),source=0) + gcount = maxval(groups(:)) + do ii = 1,nall +!>--- find next unassigned conformer and assign a new group + if (groups(ii) .ne. 0) cycle + gcount = gcount+1 + groups(ii) = gcount + +!>--- Then, cross-check all other unassigned conformers + cc = 1 !> again, serial implementation for now + ! !$omp parallel & + ! !$omp shared(nall, nat, groups, sorters, rcaches, rot) & + ! !$omp shared(workmols, structures, ii, prune_table,heavy,substruc,mask) & + ! !$omp private(jj,rmsdval,cc,io, l1, l2) + ! !$omp do schedule(dynamic) + do jj = ii+1,nall + !cc = omp_get_thread_num()+1 + if (groups(jj) .ne. 0) cycle + if (ii < prune_table(jj)) cycle + workmols(cc)%nat = structures(jj)%nat + workmols(cc)%at(:) = structures(jj)%at(:) + workmols(cc)%xyz(:,:) = structures(jj)%xyz(:,:) + if (heavy.or.substruc) then + rmsdval = rmsd(structures(ii),workmols(cc),mask=mask,& + & scratch=rcaches(cc)%xyzscratch,ccache=rcaches(cc)%ccache) + else + rmsdval = rmsd(structures(ii),workmols(cc), & + & scratch=rcaches(cc)%xyzscratch,ccache=rcaches(cc)%ccache) + end if + if (rmsdval < RTHR) then + !> only "true" duplicates will have tiny RMSD, assign negative gcount for pruning + groups(jj) = -gcount + else + l1 = equalrotaniso(ii,jj,nall,rot,BTHR,bthrmax,bthrshift) + l2 = (2.0_wp*abs(enuc(ii)-enuc(jj))/(enuc(ii)+enuc(jj))) .lt. enuc_thr + if (l1.and.l2) groups(jj) = gcount + end if + end do + if (prlvl > 1) then + ! call progress_update(ps,ii,nall) + end if + ! !$omp end do + ! !$omp end parallel + end do + if (prlvl > 0) then + if (prlvl > 1.and.prch == stdout) then + ! call progress_update(ps,nall,nall) + ! call progress_finish(ps) + write (prch,'(a)') 'done.' + else + write (stdout,'(a)') 'done.' + end if + end if + +!> finally, resizing the ensemble with remaining unique conformers+rotamers +!> Note, structures are grouped by assigned group and within group are ordered +!> with increasing energy (because the initial ensemble was energy-sorted) + if (prlvl > 0) then + write (prch,'(a,6x,a)',advance='no') 'Discarding duplicates','...' + flush (prch) + end if + gcount = maxval(groups(1:nall)) + nallnew = count(groups(1:nall) > 0) + allocate (tmpstructures(nallnew)) + allocate (tmpgroups(0:nallnew),source=0) + allocate (double(nallnew),source=0) + cc = 0 + do ii = 1,gcount + do jj = 1,nall + ggcount = groups(jj) + if (ggcount .eq. ii.and.ggcount > 0) then + cc = cc+1 + tmpstructures(cc) = structures(jj) + tmpgroups(cc) = ggcount + do kk = 1,cc-1 + if (tmpgroups(kk) .eq. ggcount) then + double(cc) = kk + exit + end if + end do + end if + end do + end do + tmpgroups(0) = gcount + call move_alloc(tmpgroups,groups) + call move_alloc(tmpstructures,structures) + if (prlvl > 0) then + write (prch,'(a)') ' done.' + write (prch,'(1x,a,t40,a,i10)') "number of doubles removed by rot/RMSD",":",nall-nallnew + write (prch,'(1x,a,t40,a,i10)') "number of unique conformers remaining",":",gcount + end if + nall = nallnew + + !>-- for ENSO write a file with duplicate info (if required) + call enso_duplicates(env,nall,double) + + if (allocated(prune_table)) deallocate (prune_table) + if (allocated(mask)) deallocate (mask) + if (allocated(enuc)) deallocate (enuc) + if (allocated(rot)) deallocate (rot) + if (allocated(prune_table)) deallocate (prune_table) +end subroutine cregen_CRE_new + !=========================================================================================! subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) @@ -2555,14 +2861,14 @@ subroutine cregen_pr1(ch,env,nat,nall,rthr,bthr,pthr,ewin) real(wp) :: rthr,bthr,pthr,ewin logical :: substruc substruc = (nat .ne. env%rednat.and.env%subRMSD) - write (ch,'('' number of atoms :'',3x,i0)') nat + write (ch,'(" number of atoms",t35,":",i10)') nat if (substruc) then - write (ch,'('' atoms included in RMSD :'',3x,i0)') env%rednat + write (ch,'(" atoms included in RMSD",t35,":",i10)') env%rednat end if - write (ch,'('' number of points on xyz files :'',3x,i0)') nall - write (ch,'('' RMSD threshold :'',f9.4)') rthr - write (ch,'('' Bconst threshold :'',f9.4)') bthr - write (ch,'('' population threshold :'',f9.4)') pthr + write (ch,'(" number of points on xyz files",t35,":",i10)') nall + !write (ch,'('' RMSD threshold :'',f9.4)') rthr + !write (ch,'('' Bconst threshold :'',f9.4)') bthr + !write (ch,'('' population threshold :'',f9.4)') pthr return end subroutine cregen_pr1 diff --git a/src/sorting/cregen_interfaces.f90 b/src/sorting/cregen_interfaces.f90 index 392f6838..0cf36f63 100644 --- a/src/sorting/cregen_interfaces.f90 +++ b/src/sorting/cregen_interfaces.f90 @@ -80,11 +80,39 @@ subroutine cregen_topocheck(ch,env,checkez,structures,newnall) use strucrd use cregen_utils implicit none - type(systemdata) :: env - integer,intent(in) :: ch + type(systemdata) :: env + integer,intent(in) :: ch logical,intent(in) :: checkez type(coord),intent(inout),allocatable,target :: structures(:) integer,intent(out) :: newnall end subroutine cregen_topocheck + + subroutine cregen_esort(ch,structures,nallout,ewin) + use crest_parameters + use strucrd + use quicksort_interface + implicit none + integer,intent(in) :: ch + type(coord),intent(inout),allocatable :: structures(:) + integer,intent(out) :: nallout + real(wp),intent(in),optional :: ewin + end subroutine cregen_esort + + subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & + & printlvl,ch) + use crest_parameters + use crest_data + use strucrd + implicit none + type(systemdata),intent(inout) :: env + integer,intent(inout) :: nall + type(coord),intent(inout),allocatable,target :: structures(:) + integer,intent(out),allocatable :: groups(:) + real(wp),intent(in) :: RTHRESH + real(wp),intent(in) :: ETHR + real(wp),intent(in) :: BTHR + integer,intent(in),optional :: printlvl + integer,intent(in),optional :: ch + end subroutine cregen_CRE_new end interface end module cregen_subroutines diff --git a/src/sorting/rotcompare.f90 b/src/sorting/rotcompare.f90 index 312d8dc5..11c2fadf 100644 --- a/src/sorting/rotcompare.f90 +++ b/src/sorting/rotcompare.f90 @@ -17,11 +17,85 @@ ! along with crest. If not, see . !===============================================================================! +module rotaniso_mod + use crest_parameters + implicit none + public + +contains + + function rotaniso(rot) result(aniso) +!*********************************************************** +!* calculate rot.const. anisotropy for a single structure +!*********************************************************** + implicit none + real(wp) :: aniso + real(wp),intent(in) :: rot(3) + real(wp) :: a,b,c,av + a = rot(1); b = rot(2); c = rot(3) + !av = (a+b+c)/3.0_wp + !aniso = sqrt((a-av)**2+(b-av)**2+(c-av)**2) + !aniso = rotaniso/av + !aniso = rotaniso/(3.0_wp*sqrt(2.0_wp/3.0_wp)) + + !> the following is identical to the commented out part + aniso = sqrt(a**2+b**2+c**2-a*b-a*c-b*c)/(a+b+c) + return + end function rotaniso + + function bthrerf(bthr,aniso,bthrmax,bthrshift) result(thr) +!*************************************************************** +!* the threshold used for the rotational constant comparison is +!* is modified based on the anisotropy of the rot. constants +!* the scaling function is an error function +!*************************************************************** + implicit none + real(wp) :: bthr,bthrmax,bthrshift + real(wp) :: aniso + real(wp) :: thr + real(wp) :: a,b,c,d + thr = bthr + c = ((bthrmax*100.0_wp)-(bthr*100.0_wp))/2.0_wp + a = -erf(-2.5_wp)*c+(bthr*100.0_wp) ! the y-axis shift + b = 4.0_wp/0.8_wp ! x-axis range from bthr to bthrmax + d = bthrshift/0.15_wp + thr = erf(aniso*b-d)*c+a + thr = thr/100.0_wp + return + end function bthrerf + + logical function equalrotaniso(i,j,nall,rot,bthr,bthrmax,bthrshift) +!********************************************************************* +!* compare each rotational constant with a modified bthr threshold +!* bthr is a relative value (fraction) threshold +!********************************************************************* + implicit none + integer i,j,nall + real(wp) :: rot(3,nall) + real(wp) :: bthr + real(wp) :: bthrmax,bthrshift + real(wp) :: anisoi,anisoj,av + real(wp) :: thr + logical :: r1,r2,r3 + equalrotaniso = .false. + anisoi = rotaniso(rot(:,i)) + anisoj = rotaniso(rot(:,j)) + av = (anisoi+anisoj)/2.0d0 + !av=min(anisoi,anisoj) + thr = bthrerf(bthr,av,bthrmax,bthrshift) + r1 = abs((rot(1,i)/rot(1,j))-1.0d0) .le. thr + r2 = abs((rot(2,i)/rot(2,j))-1.0d0) .le. thr + r3 = abs((rot(3,i)/rot(3,j))-1.0d0) .le. thr + equalrotaniso = r1.and.r2.and.r3 + return + end function equalrotaniso + +end module rotaniso_mod + !===============================================================================! -! Routines for the comparison of two structures based +! LEGACY Routines for the comparison of two structures based ! on their rotational constants. !===============================================================================! -!--- formerly in "eqrot.f" logical function equalrot(i,j,nall,thr,rot) implicit none @@ -36,19 +110,6 @@ logical function equalrot(i,j,nall,thr,rot) if (sqrt(r)/sqrt(r1) .lt. thr) equalrot = .true. end function equalrot -logical function equalrot2(i,j,nall,thr,rot) - implicit none - integer i,j,nall - real*8 rot(3,0:nall),r,r1,r2,thr - equalrot2 = .false. - r1 = rot(1,i)**2+rot(2,i)**2+rot(3,i)**2 - r2 = rot(1,j)**2+rot(2,j)**2+rot(3,j)**2 - r = (rot(1,i)-rot(1,j))**2 & - & +(rot(2,i)-rot(2,j))**2 & - & +(rot(3,i)-rot(3,j))**2 - if (2.*sqrt(r)/(sqrt(r1)+sqrt(r2)) .lt. thr) equalrot2 = .true. -end function equalrot2 - real*8 function rotdiff(i,j,nall,rot) implicit none integer i,j,nall @@ -75,96 +136,3 @@ logical function equalrotall(i,j,nall,thr,rot) return end function equalrotall -!- use a relative value as threshold -logical function equalrotallrel(i,j,nall,thr,rot) - implicit none - integer i,j,nall - real*8 rot(3,nall),thr - logical :: r1,r2,r3 - equalrotallrel = .false. - r1 = abs((rot(1,i)/rot(1,j))-1.0d0) .le. thr - r2 = abs((rot(2,i)/rot(2,j))-1.0d0) .le. thr - r3 = abs((rot(3,i)/rot(3,j))-1.0d0) .le. thr - equalrotallrel = r1.and.r2.and.r3 - return -end function equalrotallrel - -logical function equalrotmean(i,j,nall,thr,rot) - implicit none - integer i,j,nall - real*8 rot(3,nall),r,thr - equalrotmean = .false. - r = abs(rot(1,i)-rot(1,j)) - r = r+abs(rot(2,i)-rot(2,j)) - r = r+abs(rot(3,i)-rot(3,j)) - r = r/3.0d0 - equalrotmean = r .le. thr - return -end function equalrotmean - -!===========================================================! -! anisotropy related functions - -! calculate rot.const. anisotropy for a single structure -function rotaniso(i,nall,rot) - use iso_fortran_env,wp => real64 - implicit none - real(wp) :: rotaniso - real(wp) :: rot(3,nall) - integer :: i,nall - real(wp) :: a,b,c,av - a = rot(1,i); b = rot(2,i); c = rot(3,i) - av = (a+b+c)/3.0_wp - rotaniso = sqrt((a-av)**2+(b-av)**2+(c-av)**2) - rotaniso = rotaniso/av - rotaniso = rotaniso/(3.0_wp*sqrt(2.0_wp/3.0_wp)) - return -end function rotaniso - -!the threshold used for the rotational constant comparison is -!is modified based on the anisotropy of the rot. constants -!the scaling function is an error function -function bthrerf(bthr,aniso,bthrmax,bthrshift) result(thr) - use iso_fortran_env,wp => real64 - implicit none - real(wp) :: bthr,bthrmax,bthrshift - real(wp) :: aniso - real(wp) :: thr - real(wp) :: a,b,c,d - thr = bthr - c = ((bthrmax*100.0_wp)-(bthr*100.0_wp))/2.0_wp - a = -erf(-2.5_wp)*c+(bthr*100.0_wp) ! the y-axis shift - b = 4.0_wp/0.8_wp ! x-axis range from bthr to bthrmax - d = bthrshift/0.15_wp - thr = erf(aniso*b-d)*c+a - thr = thr/100.0_wp - return -end function bthrerf - -! compare each rotational constant with a modified bthr threshold -! bthr is a relative value threshold -logical function equalrotaniso(i,j,nall,rot,bthr,bthrmax,bthrshift) - use iso_fortran_env,wp => real64 - implicit none - integer i,j,nall - real(wp) :: rot(3,nall) - real(wp) :: bthr - real(wp) :: bthrmax,bthrshift - real(wp) :: anisoi,anisoj,av - real(wp) :: thr - real(wp) :: rotaniso !this is a function - real(wp) :: bthrerf !this is a function - logical :: r1,r2,r3 - equalrotaniso = .false. - anisoi = rotaniso(i,nall,rot) - anisoj = rotaniso(j,nall,rot) - av = (anisoi+anisoj)/2.0d0 - !av=min(anisoi,anisoj) - thr = bthrerf(bthr,av,bthrmax,bthrshift) - r1 = abs((rot(1,i)/rot(1,j))-1.0d0) .le. thr - r2 = abs((rot(2,i)/rot(2,j))-1.0d0) .le. thr - r3 = abs((rot(3,i)/rot(3,j))-1.0d0) .le. thr - equalrotaniso = r1.and.r2.and.r3 - return -end function equalrotaniso - From d0a84fe2e6539a22f3a7624ad3754213e4df7de2 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 6 Feb 2026 17:38:27 +0100 Subject: [PATCH 162/374] Work on required CREGEN refactor 5 --- src/sorting/cregen.f90 | 463 ++++++++++++++---------------- src/sorting/cregen_interfaces.f90 | 9 + src/sorting/irmsd_module.f90 | 166 +++++++---- 3 files changed, 335 insertions(+), 303 deletions(-) diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 1b66f88f..52d14fad 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -54,7 +54,7 @@ subroutine newcregen(env,quickset,infile) !>--- ensemble arguments integer :: nat !> number of atoms integer :: nall !> number of structures - integer,allocatable :: at(:) !> atom numbers + integer,allocatable :: at(:) !> atom numbers real(wp),allocatable :: xyz(:,:,:) !> Cartesian coordinates character(len=128),allocatable :: comments(:) character(len=128),allocatable :: comref(:) @@ -164,7 +164,7 @@ subroutine newcregen(env,quickset,infile) nall = nallnew !> update !>--- if structures were discarded, resize xyz end if - if (topocheck.or.checkbroken) then + if (topocheck .or. checkbroken) then write (prch,'(" number of reliable points",t35,":",i10)') nall end if @@ -196,7 +196,7 @@ subroutine newcregen(env,quickset,infile) ! end if call cregen_CRE_new(env,nall,structures,group,rthr, & - & ethr/autokcal,bthr,printlvl=2,ch=prch) + & ethr / autokcal,bthr,printlvl=2,ch=prch) !>--- get group info to degen ng = group(0) allocate (degen(3,ng)) @@ -220,14 +220,14 @@ subroutine newcregen(env,quickset,infile) ! call cregen_CRE(prch,env,nat,nall,at,xyz,comments,nallnew,group,.true.) ! end if - stop - !=====================================================================! !> E N S E M B L E O U T P U T !=====================================================================! !>--- align all structures to the first structure using the RMSD - call cregen_rmsdalign(nat,nall,at,xyz) + call cregen_rmsdalign(nall,structures) + + stop !>--- write new file with ALL remaining structures if (newfile) then @@ -242,7 +242,7 @@ subroutine newcregen(env,quickset,infile) if (saveelow) then env%elowest = grepenergy(comments(1)) !>-- and update reference geometry (in Bohr) - env%ref%xyz = xyz(:,:,1)/bohr + env%ref%xyz = xyz(:,:,1) / bohr end if !>--- additional files for entropy mode @@ -266,7 +266,7 @@ subroutine newcregen(env,quickset,infile) !>--- analyze nuclear equivalencies, e.g. for NMR and Entropy if (anal) then - call cregen_EQUAL(prch,nat,nall,at,xyz,group,athr,.not.env%entropic) + call cregen_EQUAL(prch,nat,nall,at,xyz,group,athr,.not. env%entropic) end if !>--- deallocate data @@ -320,15 +320,15 @@ subroutine cregen_files(env,fname,oname,cname,simpleset,userinput,iounit) case default open (newunit=iounit,file=outfile) end select - else if (env%confgo.and..not. (env%properties .eq. -2).and..not.env%relax) then + else if (env%confgo .and. .not. (env%properties .eq. -2) .and. .not. env%relax) then iounit = stdout else open (newunit=iounit,file=outfile) end if - if ((env%confgo.and.(index(trim(fname),'none selected') .eq. 0)) & - & .OR.userinput) then - if (.not.userinput) then + if ((env%confgo .and. (index(trim(fname),'none selected') .eq. 0)) & + & .OR. userinput) then + if (.not. userinput) then fname = trim(env%ensemblename) end if oname = trim(fname)//'.sorted' @@ -364,7 +364,7 @@ subroutine cregen_files(env,fname,oname,cname,simpleset,userinput,iounit) end select inquire (file=fname,exist=ex) - if (.not.ex) then + if (.not. ex) then write (0,*) 'Warning, file ',trim(fname),' does not exist!' error stop end if @@ -393,7 +393,7 @@ subroutine cregen_prout(env,simpleset,pr1,pr2,pr3,pr4) pr3 = .false. !> plain energy list pr4 = .false. !> group list printout - if (any(simpleset == (/6,7/)).or.env%esort) then + if (any(simpleset == (/6,7/)) .or. env%esort) then pr1 = .false. pr2 = .false. if (env%crestver .ne. crest_solv) pr3 = .true. @@ -460,25 +460,25 @@ subroutine cregen_director(env,simpleset,checkbroken,sortE,sortRMSD,sortRMSD2, & end if bonusfiles = .false. - if (env%entropic.or.env%doNMR) then + if (env%entropic .or. env%doNMR) then bonusfiles = .true. end if anal = .false. - if (env%doNMR.or.env%cgf(3).or.simpleset == 2) then + if (env%doNMR .or. env%cgf(3) .or. simpleset == 2) then anal = .true. end if if (simpleset == 3) then anal = .false. end if - if (any(simpleset == (/6,7/)).or.env%esort) then !energy sorting only + if (any(simpleset == (/6,7/)) .or. env%esort) then !energy sorting only checkbroken = .false. sortE = .true. sortRMSD = .false. repairord = .false. newfile = .true. - if ((env%crestver .eq. crest_solv).and.(.not.env%QCG)) then + if ((env%crestver .eq. crest_solv) .and. (.not. env%QCG)) then conffile = .true. !Conffile is needed for confscript in QCG else conffile = .false. @@ -581,7 +581,7 @@ subroutine cregen_groupinfo(nall,ng,group,degen) a = 0; b = 0; k = 0 do j = 1,nall if (group(j) .eq. i) then - k = k+1 + k = k + 1 if (a == 0) a = j b = j end if @@ -629,7 +629,7 @@ subroutine cregen_discardbroken(ch,env,topocheck,structures,newnall) type(coord),allocatable :: tmpstructures(:) !>--- if we don't wish to include all atoms: - substruc = (structures(1)%nat .ne. env%rednat.and.env%subRMSD) + substruc = (structures(1)%nat .ne. env%rednat .and. env%subRMSD) nall = size(structures,1) !> Check fragments call env%ref%to(mol0) @@ -654,18 +654,18 @@ subroutine cregen_discardbroken(ch,env,topocheck,structures,newnall) !>--- further checks: dissociation? dissoc = .false. - if (abs(erj) .gt. 1.0d-6.and. & - & distok.and.distok2.and.topocheck) then + if (abs(erj) .gt. 1.0d-6 .and. & + & distok .and. distok2 .and. topocheck) then call cregen_calculate_fragments(mol,nfrag=frag) dissoc = (frag .gt. frag0) end if - if (dissoc.or.(.not.distok).or.(.not.distok2)) then + if (dissoc .or. (.not. distok) .or. (.not. distok2)) then !>--- move broken structures to the end of the matrix broke(ii) = .true. !write(ch,*) 'removing structure',ii else - newnall = newnall+1 + newnall = newnall + 1 end if end do @@ -674,13 +674,13 @@ subroutine cregen_discardbroken(ch,env,topocheck,structures,newnall) allocate (tmpstructures(newnall)) jj = 0 do ii = 1,nall - if (.not.broke(ii)) then - jj = jj+1 + if (.not. broke(ii)) then + jj = jj + 1 tmpstructures(jj) = structures(ii) end if end do call move_alloc(tmpstructures,structures) - llan = nall-newnall + llan = nall - newnall write (ch,'(" number of removed clashes",t35,":",i10)') llan end if !>--- otherwise the ensemble is ok @@ -724,8 +724,8 @@ subroutine cregen_topocheck(ch,env,checkez,structures,newnall) real(wp),allocatable :: ezdihed(:) real(wp) :: winkeldiff - type(coord) :: mol0 - type(coord),pointer :: mol + type(coord) :: mol0 + type(coord),pointer :: mol type(coord),allocatable :: tmpstructures(:) logical,allocatable :: broke(:) @@ -780,14 +780,14 @@ subroutine cregen_topocheck(ch,env,checkez,structures,newnall) end if end do !>--- get E/Z info of C=C, discard isomers - if (checkez.and..not.discard.and.ncc > 0) then + if (checkez .and. .not. discard .and. ncc > 0) then call ezccdihed(mol%nat,mol%xyz,ncc,ezat,ezdihed) do l = 1,ncc - winkeldiff = ezdihedref(l)-ezdihed(l) + winkeldiff = ezdihedref(l) - ezdihed(l) winkeldiff = abs(winkeldiff) if (winkeldiff > 90.0_wp) then discard = .true. - ccfail = ccfail+1 + ccfail = ccfail + 1 exit end if end do @@ -796,27 +796,27 @@ subroutine cregen_topocheck(ch,env,checkez,structures,newnall) if (discard) then broke(jj) = .true. else - newnall = newnall+1 + newnall = newnall + 1 end if end do !>--- sort the xyz array (only if structures have been discarded) if (newnall .lt. nall) then - llan = nall-newnall + llan = nall - newnall write (ch,'(" number of topology mismatches",t35,":",i10)') llan !>--- report the removals during a run if (ch .ne. stdout) then write (stdout,'("CREGEN> number of topology-based structure removals: ",i0)') llan end if - if (checkez.and.ccfail > 0) then + if (checkez .and. ccfail > 0) then write (ch,'('' => discared due to E/Z isom. : '',i0)') ccfail end if if (newnall >= 1) then allocate (tmpstructures(newnall)) jj = 0 do ii = 1,nall - if (.not.broke(ii)) then - jj = jj+1 + if (.not. broke(ii)) then + jj = jj + 1 tmpstructures(jj) = structures(ii) end if end do @@ -885,18 +885,18 @@ subroutine cregen_esort(ch,structures,nallout,ewin) write (ch,'(" sorting energy window (EWIN)",t32,":",3x,a,a)') '+∞',' / kcal*mol⁻¹' end if emax = maxval(energies(:),1) - de = (emax-energies(1))*autokcal + de = (emax - energies(1)) * autokcal if (de .gt. ewin) then nallout = 1 !> lowest is always taken do ii = 2,nall - de = (energies(ii)-energies(1))*autokcal + de = (energies(ii) - energies(1)) * autokcal if (de .lt. ewin) then - nallout = nallout+1 + nallout = nallout + 1 else exit end if end do - write (ch,'(" number of removed by energy",t32,":",3x,i0)') (nall-nallout) + write (ch,'(" number of removed by energy",t32,":",3x,i0)') (nall - nallout) write (ch,'(" number of remaining points",t32,":",3x,i0)') nallout allocate (tmpstructures(nallout)) @@ -965,7 +965,7 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) integer,allocatable :: includeRMSD(:) real(wp),allocatable :: c0(:,:),c1(:,:),cdum(:,:) real(wp),allocatable :: c0h(:,:),c1h(:,:) - integer,allocatable :: maskheavy(:) + integer,allocatable :: maskheavy(:) integer,allocatable :: at0(:) logical :: substruc integer :: nat0 @@ -993,7 +993,7 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) call cregen_filldata1(env,ewin,rthr,ethr,bthr,athr,pthr,T,couthr) if (env%entropic) enantio = .false. heavy = env%heavyrmsd - substruc = (nat .ne. env%rednat.and.env%subRMSD) + substruc = (nat .ne. env%rednat .and. env%subRMSD) if (substruc) then nat0 = env%rednat includeRMSD = env%includeRMSD @@ -1040,11 +1040,11 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) do i = 1,nall rmap1(i) = klong l1 = .true. - do j = 1,i-1 + do j = 1,i - 1 !> ekcal(j) should always be smaller than ekcal(i) because i>j - de = (er(i)-er(j))*autokcal + de = (er(i) - er(j)) * autokcal if (de .lt. ethr) then !>-- we only need RMSDs for structures close in energy - klong = klong+1 + klong = klong + 1 if (l1) then rmap2(i) = j l1 = .false. @@ -1062,15 +1062,15 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) write (stdout,'(a)',advance='no') 'CREGEN> running RMSDs ...' flush (stdout) !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - if (.not.substruc) then !regular case, all atoms included in RMSD - if (.not.heavy) then !really, the regular case + if (.not. substruc) then !regular case, all atoms included in RMSD + if (.not. heavy) then !really, the regular case do i = 1,nall c0(1:3,1:nat) = xyz(1:3,1:nat,i) !$OMP PARALLEL PRIVATE ( j,klong,c1,xdum,ydum,Udum,gdum,rdum,rdum2,de) & !$OMP SHARED ( i,c0,rmat,nat,xyz,rmap1,rmap2,er,ethr,enantio) !$OMP DO - do j = 1,i-1 - de = (er(i)-er(j))*autokcal + do j = 1,i - 1 + de = (er(i) - er(j)) * autokcal if (de .lt. ethr) then c1(1:3,1:nat) = xyz(1:3,1:nat,j) call rmsd(nat,c0,c1,0,Udum,xdum,ydum,rdum,.false.,gdum) ! all atoms @@ -1088,7 +1088,7 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) !$OMP END PARALLEL end do else !> heavy atom case - natnoh = nat-counth(nat,at) + natnoh = nat - counth(nat,at) allocate (c0h(3,natnoh),c1h(3,natnoh),source=0.0_wp) allocate (maskheavy(nat),source=0) call heavymask(nat,at,maskheavy) @@ -1098,8 +1098,8 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) !$OMP PARALLEL PRIVATE ( j,klong,c1h,xdum,ydum,Udum,gdum,rdum,rdum2,de) & !$OMP SHARED ( i,c0h,rmat,nat,xyz,rmap1,rmap2,er,ethr,enantio,maskheavy) !$OMP DO - do j = 1,i-1 - de = (er(i)-er(j))*autokcal + do j = 1,i - 1 + de = (er(i) - er(j)) * autokcal if (de .lt. ethr) then call maskedxyz2(nat,natnoh,xyz(:,:,j),c1h,maskheavy) call rmsd(natnoh,c0h,c1h,0,Udum,xdum,ydum,rdum,.false.,gdum) ! all atoms @@ -1126,8 +1126,8 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) !$OMP PARALLEL PRIVATE ( j,klong,c1,xdum,ydum,Udum,gdum,rdum,rdum2,de) & !$OMP SHARED ( i,c0,rmat,nat,nat0,xyz,rmap1,rmap2,er,ethr,includeRMSD,enantio ) !$OMP DO - do j = 1,i-1 - de = (er(i)-er(j))*autokcal + do j = 1,i - 1 + de = (er(i) - er(j)) * autokcal if (de .lt. ethr) then call maskedxyz2(nat,nat0,xyz(:,:,j),c1,includeRMSD) call rmsd(nat0,c0,c1,0,Udum,xdum,ydum,rdum,.false.,gdum) ! all atoms @@ -1149,9 +1149,9 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! !>-- Now, with the RMSDs and rotational constants we can kick out duplicates do i = 1,nall - do j = 1,i-1 + do j = 1,i - 1 !>-- only check for structures in energy range - de = (er(i)-er(j))*autokcal + de = (er(i) - er(j)) * autokcal if (de .lt. ethr) then klong = linr(rmap1(i),rmap2(i),j) dr = rmat(klong) @@ -1162,8 +1162,8 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) if (dr .lt. rthr) then double(i) = j !>-- "i" is the same structure as "j" !>-- slightly larger RMSD, but same rot. constants --> same structure - elseif (dr .lt. 2.0_wp*rthr) then - l1 = equalrotaniso(i,j,nall,rot,0.5d0*bthr,env%bthrmax,env%bthrshift) + elseif (dr .lt. 2.0_wp * rthr) then + l1 = equalrotaniso(i,j,nall,rot,0.5d0 * bthr,env%bthrmax,env%bthrshift) if (l1) then double(i) = j !>-- "i" is the same structure as "j" end if @@ -1183,24 +1183,24 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) allocate (mask(nall)) mask(:) = double(:) .ne. 0 k = count(mask,1) - nallout = nall-k + nallout = nall - k deallocate (mask) write (ch,*) 'number of doubles removed by rot/RMSD :',k - if (.not.nosort) then + if (.not. nosort) then write (ch,*) 'total number unique points considered further :',nallout else nallout = nall end if !>-- sort structures, energies, rot const. and comments - if (.not.nosort) then + if (.not. nosort) then j = 0 - l = nall+1 + l = nall + 1 do i = 1,nall if (double(i) .eq. 0) then - j = j+1 + j = j + 1 orderref(i) = j else - l = l-1 + l = l - 1 orderref(i) = l end if end do @@ -1222,29 +1222,29 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) do k = 1,nallout c1(1:3,1:nat) = xyz(1:3,1:nat,k) enuc(k) = 0.0_wp - do i = 1,nat-1 - do j = i+1,nat - r = (c1(1,i)-c1(1,j))**2 & - & +(c1(2,i)-c1(2,j))**2 & - & +(c1(3,i)-c1(3,j))**2+1.d-12 - enuc(k) = enuc(k)+at(i)*at(j)/r + do i = 1,nat - 1 + do j = i + 1,nat + r = (c1(1,i) - c1(1,j))**2 & + & + (c1(2,i) - c1(2,j))**2 & + & + (c1(3,i) - c1(3,j))**2 + 1.d-12 + enuc(k) = enuc(k) + at(i) * at(j) / r end do end do end do !>-- check energy, rot. const. and nuclear permutation double = 0 !>-- re-use "double" SORTI: do i = 1,nallout - SORTJ: do j = 1,i-1 + SORTJ: do j = 1,i - 1 !>-- energy difference - de = (er(i)-er(j))*autokcal + de = (er(i) - er(j)) * autokcal l3 = double(j) .eq. 0 - if (.not.l3) cycle + if (.not. l3) cycle if (abs(de) .lt. ethr) then !>-- rotational constant difference l1 = equalrotaniso(i,j,nall,rot,bthr,env%bthrmax,env%bthrshift) !>-- nuclear permutation - l2 = 2.0d0*abs(enuc(i)-enuc(j))/(enuc(i)+enuc(j)) .lt. 1.d-3 - if (l1.and.l2.and.l3) then + l2 = 2.0d0 * abs(enuc(i) - enuc(j)) / (enuc(i) + enuc(j)) .lt. 1.d-3 + if (l1 .and. l2 .and. l3) then double(i) = j !>-- "i" is a rotamer of "j" call backtrack(double,i,k) cycle SORTI @@ -1257,7 +1257,7 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) group = 0 do i = 1,nallout if (double(i) .eq. 0) then - k = k+1 + k = k + 1 group(i) = k else j = double(i) @@ -1266,7 +1266,7 @@ subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) end do group(0) = k !>-- total number of groups if (nosort) then - write (ch,'(1x,a,i10)') 'number of removed rotamers :', (nallout-k) + write (ch,'(1x,a,i10)') 'number of removed rotamers :', (nallout - k) nallout = k write (ch,'(1x,a,i10)') 'total number unique points remaining :',nallout end if @@ -1285,7 +1285,7 @@ function counth(nat,at) result(nh) integer :: nh,i nh = 0 do i = 1,nat - if (at(i) == 1) nh = nh+1 + if (at(i) == 1) nh = nh + 1 end do return end function counth @@ -1393,7 +1393,7 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & T = 1 !> doing it serial for now !>--- set up parameters (NOTE, we are working with BOHR internally) - RTHR = RTHRESH*aatoau + RTHR = RTHRESH * aatoau !>--- reference structure (the first one) for some setup ref => structures(1) @@ -1402,22 +1402,22 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & !>--- print some sorting data if (prlvl > 0) then tmpstr = 'Info for CREGEN sorting:' - if (prlvl > 1.and.prch == stdout) then + if (prlvl > 1 .and. prch == stdout) then ! call printc(style(S_BOLD)//fg(YELLOW,bright=.true.)//trim(tmpstr)//reset()) else write (prch,'(a)') 'Info for CREGEN sorting:' end if !write (prch,'(2x,a,i10)') 'number of structures :',nall - write (prch,'(2x,a,t32,a,f10.5,a)') 'RTHR (RMSD threshold)',':',RTHR*autoaa,' Å' + write (prch,'(2x,a,t32,a,f10.5,a)') 'RTHR (RMSD threshold)',':',RTHR * autoaa,' Å' write (prch,'(2x,a,t32,a,es10.2,a)') 'ETHR (energy threshold)',':',ETHR,' Ha' - write (prch,'(2x,a,t32,a,f10.2,a)') 'BTHR (rot. threshold)',':',BTHR*100,' %' + write (prch,'(2x,a,t32,a,f10.2,a)') 'BTHR (rot. threshold)',':',BTHR * 100,' %' !write (prch,'(2x,a,i9)') 'OpenMP threads :',T end if !>--- mask setup: We may not include all atoms in the checks heavy = env%heavyrmsd - substruc = (nat .ne. env%rednat.and.env%subRMSD.and.allocated(env%includeRMSD)) - if (heavy.or.substruc) then + substruc = (nat .ne. env%rednat .and. env%subRMSD .and. allocated(env%includeRMSD)) + if (heavy .or. substruc) then allocate (mask(nat),source=.false.) end if if (heavy) then @@ -1430,13 +1430,13 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & mask(ii) = (env%includeRMSD(ii) .eq. 1) end do end if - if((heavy.or.substruc).and.(prlvl > 0))then - write(prch,'(" Heavy/masked atoms",t32,":",i10," / ",i0)') count(mask),nat - endif + if ((heavy .or. substruc) .and. (prlvl > 0)) then + write (prch,'(" Heavy/masked atoms",t32,":",i10," / ",i0)') count(mask),nat + end if if (prlvl > 0) then tmpstr = "Starting calculations..." - if (prlvl > 1.and.prch == stdout) then + if (prlvl > 1 .and. prch == stdout) then ! call printc(style(S_BOLD)//fg(YELLOW,bright=.true.)//trim(tmpstr)//reset()) else write (stdout,'(a)') trim(tmpstr) @@ -1474,7 +1474,7 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & do ii = 1,nall eii = structures(ii)%energy do jj = 1,ii - ediff = abs(eii-structures(jj)%energy) + ediff = abs(eii - structures(jj)%energy) if (ediff <= ETHR) then prune_table(ii) = jj exit @@ -1488,19 +1488,19 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & do ii = 1,nall mol => structures(ii) call axis(mol%nat,mol%at,mol%xyz) !> all coordinates to CMA - call axis(mol%nat,mol%at,moL%xyz*autoaa,rot(1:3,ii),avmom)!> B_0 in MHz + call axis(mol%nat,mol%at,moL%xyz * autoaa,rot(1:3,ii),avmom)!> B_0 in MHz end do !> Scaled sum of atom-atom-distances (empirical measure) allocate (enuc(nall),source=0.0_wp) do ii = 1,nall mol => structures(ii) - do jj = 1,mol%nat-1 - do kk = jj+1,mol%nat - rsq = (mol%xyz(1,jj)-mol%xyz(1,kk))**2 & - & +(mol%xyz(2,jj)-mol%xyz(2,kk))**2 & - & +(mol%xyz(3,jj)-mol%xyz(3,kk))**2+1.d-12 - enuc(ii) = enuc(ii)+real(mol%at(jj)*mol%at(kk),wp)/rsq + do jj = 1,mol%nat - 1 + do kk = jj + 1,mol%nat + rsq = (mol%xyz(1,jj) - mol%xyz(1,kk))**2 & + & + (mol%xyz(2,jj) - mol%xyz(2,kk))**2 & + & + (mol%xyz(3,jj) - mol%xyz(3,kk))**2 + 1.d-12 + enuc(ii) = enuc(ii) + real(mol%at(jj) * mol%at(kk),wp) / rsq end do end do end do @@ -1513,7 +1513,7 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & if (prlvl > 0) then write (prch,'(a,6x,a)',advance='no') 'Running CREGEN checks','... ' flush (prch) - if (prlvl > 1.and.prch == stdout) then + if (prlvl > 1 .and. prch == stdout) then ! write (stdout,*) ! call progress_init(ps,width=50,prefix=" ↳", & ! & suffix="",show_time=.true.,show_eta=.false.) @@ -1528,7 +1528,7 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & do ii = 1,nall !>--- find next unassigned conformer and assign a new group if (groups(ii) .ne. 0) cycle - gcount = gcount+1 + gcount = gcount + 1 groups(ii) = gcount !>--- Then, cross-check all other unassigned conformers @@ -1538,14 +1538,14 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & ! !$omp shared(workmols, structures, ii, prune_table,heavy,substruc,mask) & ! !$omp private(jj,rmsdval,cc,io, l1, l2) ! !$omp do schedule(dynamic) - do jj = ii+1,nall + do jj = ii + 1,nall !cc = omp_get_thread_num()+1 if (groups(jj) .ne. 0) cycle if (ii < prune_table(jj)) cycle workmols(cc)%nat = structures(jj)%nat workmols(cc)%at(:) = structures(jj)%at(:) workmols(cc)%xyz(:,:) = structures(jj)%xyz(:,:) - if (heavy.or.substruc) then + if (heavy .or. substruc) then rmsdval = rmsd(structures(ii),workmols(cc),mask=mask,& & scratch=rcaches(cc)%xyzscratch,ccache=rcaches(cc)%ccache) else @@ -1557,8 +1557,8 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & groups(jj) = -gcount else l1 = equalrotaniso(ii,jj,nall,rot,BTHR,bthrmax,bthrshift) - l2 = (2.0_wp*abs(enuc(ii)-enuc(jj))/(enuc(ii)+enuc(jj))) .lt. enuc_thr - if (l1.and.l2) groups(jj) = gcount + l2 = (2.0_wp * abs(enuc(ii) - enuc(jj)) / (enuc(ii) + enuc(jj))) .lt. enuc_thr + if (l1 .and. l2) groups(jj) = gcount end if end do if (prlvl > 1) then @@ -1568,7 +1568,7 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & ! !$omp end parallel end do if (prlvl > 0) then - if (prlvl > 1.and.prch == stdout) then + if (prlvl > 1 .and. prch == stdout) then ! call progress_update(ps,nall,nall) ! call progress_finish(ps) write (prch,'(a)') 'done.' @@ -1593,11 +1593,11 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & do ii = 1,gcount do jj = 1,nall ggcount = groups(jj) - if (ggcount .eq. ii.and.ggcount > 0) then - cc = cc+1 + if (ggcount .eq. ii .and. ggcount > 0) then + cc = cc + 1 tmpstructures(cc) = structures(jj) tmpgroups(cc) = ggcount - do kk = 1,cc-1 + do kk = 1,cc - 1 if (tmpgroups(kk) .eq. ggcount) then double(cc) = kk exit @@ -1611,7 +1611,7 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & call move_alloc(tmpstructures,structures) if (prlvl > 0) then write (prch,'(a)') ' done.' - write (prch,'(1x,a,t40,a,i10)') "number of doubles removed by rot/RMSD",":",nall-nallnew + write (prch,'(1x,a,t40,a,i10)') "number of doubles removed by rot/RMSD",":",nall - nallnew write (prch,'(1x,a,t40,a,i10)') "number of unique conformers remaining",":",gcount end if nall = nallnew @@ -1676,7 +1676,7 @@ subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) call profiler%init(3) !> prepare workspace - nallpairs = (nall*(nall+1))/2 + nallpairs = (nall * (nall + 1)) / 2 allocate (rmsds(nallpairs),source=0.0_wp) if (debug) then allocate (debugrmsds(nallpairs),source=0.0_wp) @@ -1714,7 +1714,7 @@ subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) call profiler%stop(1) if (prlvl > 0) then call profiler%write_timing(stdout,1,'done.',.true.) - runtime = (profiler%get(1)/real(nall,wp))*1000.0_wp + runtime = (profiler%get(1) / real(nall,wp)) * 1000.0_wp write (stdout,'(a,f0.3,a)') 'CREGEN> Corresponding to approximately ',runtime, & & ' ms per processed structure' end if @@ -1745,7 +1745,7 @@ subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) do ii = 1,nall rcaches(cc)%stereocheck = stereocheck rcaches(cc)%rank(1:nat,1) = sorters(ii)%rank(1:nat) - do jj = ii+1,nall + do jj = ii + 1,nall workmols(cc)%nat = structures(jj)%nat workmols(cc)%at(:) = structures(jj)%at(:) workmols(cc)%xyz(:,:) = structures(jj)%xyz(:,:) @@ -1760,7 +1760,7 @@ subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) if (prlvl > 0) then call profiler%write_timing(stdout,2,'done.',.true.) !write (stdout,'(a)',advance='yes') 'done.' - runtime = (profiler%get(2)/real(nallpairs,wp))*1000.0_wp + runtime = (profiler%get(2) / real(nallpairs,wp)) * 1000.0_wp write (stdout,'(a,f0.3,a)') 'CREGEN> Corresponding to approximately ',runtime, & & ' ms per processed RMSD' @@ -1769,7 +1769,7 @@ subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) if (debug) then !> RMSD without permutation do ii = 1,nall - do jj = ii+1,nall + do jj = ii + 1,nall rmsdval = rmsd(structures(ii),structures(jj)) debugrmsds(lin(ii,jj)) = rmsdval end do @@ -1782,16 +1782,16 @@ subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) if (debug) then write (iunit,'(a,3(",",a))') 'A','B','rmsd','rmsdref' do ii = 1,nall - do jj = ii+1,nall + do jj = ii + 1,nall write (iunit,'(i0,",",i0,2(",",f0.7))') & - & min(ii,jj),max(ii,jj),rmsds(lin(ii,jj))*autoaa,debugrmsds(lin(ii,jj))*autoaa + & min(ii,jj),max(ii,jj),rmsds(lin(ii,jj)) * autoaa,debugrmsds(lin(ii,jj)) * autoaa end do end do else write (iunit,'(a,",",a,",",a)') 'A','B','rmsd' do ii = 1,nall - do jj = ii+1,nall - write (iunit,'(i0,",",i0,",",f0.7)') min(ii,jj),max(ii,jj),rmsds(lin(ii,jj))*autoaa + do jj = ii + 1,nall + write (iunit,'(i0,",",i0,",",f0.7)') min(ii,jj),max(ii,jj),rmsds(lin(ii,jj)) * autoaa end do end do end if @@ -1865,13 +1865,13 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) call profiler%init(3) !>--- set up parameters (note we are working with BOHR internally) - RTHR = env%rthr*aatoau + RTHR = env%rthr * aatoau !>--- print some sorting data if (prlvl > 0) then write (stdout,'(a)') 'CREGEN> Info for iRMSD sorting:' write (stdout,'(2x,a,i9)') 'number of structures :',nall - write (stdout,'(2x,a,f9.5,a)') 'RTHR (RMSD threshold) :',RTHR*autoaa,' Å' + write (stdout,'(2x,a,f9.5,a)') 'RTHR (RMSD threshold) :',RTHR * autoaa,' Å' write (stdout,'(2x,a,i9)') 'OpenMP threads :',T write (stdout,'(2x,a,a9)') 'Individual atom IDs? :',to_str(individual_IDs) write (stdout,'(2x,a)',advance='no') 'False rotamer check? :' @@ -1905,13 +1905,13 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) do ii = 1,nall mol => structures(ii) call axis(mol%nat,mol%at,mol%xyz) - if (individual_IDs.or.ii == 1) then + if (individual_IDs .or. ii == 1) then call sorters(ii)%init(mol,invtype='apsp+',heavy=.false.) end if if (ii == 1) then stereocheck = .not. (sorters(ii)%hasstereo(ref)) end if - if (individual_IDs.or.ii == 1) then + if (individual_IDs .or. ii == 1) then call sorters(ii)%shrink() end if end do @@ -1920,7 +1920,7 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) if (prlvl > 0) then call profiler%stop(1) call profiler%write_timing(stdout,1,'done.',.true.) - runtime = (profiler%get(1)/real(nall,wp))*1000.0_wp + runtime = (profiler%get(1) / real(nall,wp)) * 1000.0_wp write (stdout,'(1x,a,f0.3,a)') '* Corresponding to approximately ',runtime, & & ' ms per processed RMSD' write (stdout,*) @@ -1971,7 +1971,7 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) do ii = 1,nall !>--- find next unassigned conformer and assign a new group if (groups(ii) .ne. 0) cycle - gcount = gcount+1 + gcount = gcount + 1 groups(ii) = gcount !>--- Then, cross-check all other unassigned conformers @@ -1980,8 +1980,8 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) !$omp shared(workmols, structures, ii) & !$omp private(jj,rmsdval,cc) !$omp do schedule(dynamic) - do jj = ii+1,nall - cc = omp_get_thread_num()+1 + do jj = ii + 1,nall + cc = omp_get_thread_num() + 1 if (groups(jj) .ne. 0) cycle if (individual_IDs) then rcaches(cc)%rank(1:nat,1) = sorters(ii)%rank(1:nat) @@ -2057,12 +2057,12 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) integer :: current real(wp) :: dum real(wp) :: shortest_distance - integer,allocatable :: equiv(:,:,:) - integer,allocatable :: pair(:),pre(:),nb(:,:) - logical,allocatable :: vis(:) + integer,allocatable :: equiv(:,:,:) + integer,allocatable :: pair(:),pre(:),nb(:,:) + logical,allocatable :: vis(:) real(wp),allocatable :: metric(:,:) real(wp),allocatable :: dist(:,:,:) - integer,allocatable :: relat(:,:) + integer,allocatable :: relat(:,:) real(wp),allocatable :: tmp2(:) integer :: m,m1,m2,s1,s2,iat,j1,k2 @@ -2082,7 +2082,7 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) do i = 1,ng k = 0 do j = 1,nall - if (group(j) == i) k = k+1 + if (group(j) == i) k = k + 1 end do if (k .gt. gmax) gmax = k end do @@ -2091,7 +2091,7 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) k = 0 do j = 1,nall if (group(j) == i) then - k = k+1 + k = k + 1 glist(k,i) = j !> the k-th member of group i is structure j end if end do @@ -2102,20 +2102,20 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) allocate (cdum(3,nat)) !>--- set up the "pair" array --> how many bonds are between two nuclei? - allocate (pair(n*(n+1)/2),metric(n,n),vis(n),pre(n),nb(200,n)) - cdum(1:3,1:n) = xyz(1:3,1:n,1)/bohr + allocate (pair(n * (n + 1) / 2),metric(n,n),vis(n),pre(n),nb(200,n)) + cdum(1:3,1:n) = xyz(1:3,1:n,1) / bohr call neighdist(n,at,cdum,nb,metric) k = 0 pair = 0 - do i = 1,n-1 - do j = i+1,n + do i = 1,n - 1 + do j = i + 1,n !>---the shortest bond path current = j dum = shortest_distance(n,i,j,nb,metric,vis,pre) k = 0 do while (pre(current) /= 0) current = pre(current) - k = k+1 + k = k + 1 end do !> End loop: while precessor(current) /= 0 pair(lin(j,i)) = k !> # of bonds between i and j end do @@ -2131,7 +2131,7 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) call distance(n,xyz(:,:,i),dist(:,:,i)) !> distance matrix do j = 1,n do k = 1,n - tmp2(k) = dist(k,j,i)*dble(at(k)) !> the distance of j to all atoms * Z to distinguish + tmp2(k) = dist(k,j,i) * dble(at(k)) !> the distance of j to all atoms * Z to distinguish end do call qqsort(tmp2,1,n) dist(1:n,j,i) = tmp2(1:n) @@ -2145,7 +2145,7 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) do m1 = 1,m !$OMP PARALLEL PRIVATE ( m2, s1, s2 ) SHARED ( relat ) !$OMP DO - do m2 = 1,m1-1 !> compare all members + do m2 = 1,m1 - 1 !> compare all members s1 = glist(m1,i) !> struc 1 s2 = glist(m2,i) !> struc 2 call compare(n,nall,s1,s2,dist,athr,relat) !> athr is distance vector equivalence threshold @@ -2169,8 +2169,8 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) do k2 = 1,m2 if (j1 .eq. equiv(k2,iat,i)) ex = .true. end do - if (.not.ex) then - equiv(0,iat,i) = equiv(0,iat,i)+1 + if (.not. ex) then + equiv(0,iat,i) = equiv(0,iat,i) + 1 equiv(equiv(0,iat,i),iat,i) = j1 end if end do @@ -2191,7 +2191,7 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) cycle MLOOP end if end do M1LOOP - equiv(0,j,0) = equiv(0,j,0)+1 !> append + equiv(0,j,0) = equiv(0,j,0) + 1 !> append equiv(equiv(0,j,0),j,0) = k end do MLOOP end do JLOOP @@ -2223,7 +2223,7 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) do i = 1,n do j = 1,equiv(0,i,ig) k = equiv(j,i,ig) - elist(1:n,k) = elist(1:n,k)+elist(1:n,i) + elist(1:n,k) = elist(1:n,k) + elist(1:n,i) end do end do !>--- prepare write out @@ -2233,7 +2233,7 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) elist(i,i) = 0 do j = 1,n if (elist(j,i) .ne. 0) then - k = k+1 + k = k + 1 equiv(k,i,ig) = j end if end do @@ -2254,7 +2254,7 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) end if end do if (nmract(at(j)) .eq. 0) cycle - if (m .gt. 1.and.jnd(j) .eq. 1) then ! just print + if (m .gt. 1 .and. jnd(j) .eq. 1) then ! just print write (ch,'(''reference atom'',i4,'' # :'',i2)') equiv(1,j,ig),m do k = 1,m jnd(equiv(k,j,ig)) = 0 @@ -2283,7 +2283,7 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) l = equiv(k,i,ig) if (l .eq. i) cycle do j = 1,n - if (flist(j,i) .eq. 1.or.nmract(at(j)) .eq. 0) cycle !> don't check non-magnetic nuclei + if (flist(j,i) .eq. 1 .or. nmract(at(j)) .eq. 0) cycle !> don't check non-magnetic nuclei !c write(*,*) l,j,pair(lin(i,j)),pair(lin(l,j)) !> and chem. equiv. ones (ie in the same if (pair(lin(i,j)) .ne. pair(lin(l,j))) elist(l,i) = 0 !> group end do @@ -2296,7 +2296,7 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) elist(i,i) = 0 do j = 1,n if (elist(j,i) .ne. 0) then - k = k+1 + k = k + 1 equiv(k,i,ig) = j end if end do @@ -2305,7 +2305,7 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) do i = 1,n do j = 1,equiv(0,i,ig) k = equiv(j,i,ig) - elist(1:n,k) = elist(1:n,k)+elist(1:n,i) + elist(1:n,k) = elist(1:n,k) + elist(1:n,i) end do end do !>--- prepare write out @@ -2315,7 +2315,7 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) elist(i,i) = 0 do j = 1,n if (elist(j,i) .ne. 0) then - k = k+1 + k = k + 1 equiv(k,i,ig) = j end if end do @@ -2332,7 +2332,7 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) write (3,*) j,m write (3,'(20i5)') (equiv(l,j,ig),l=1,m) !> include the atom ie if there are no equiv. if (nmract(at(j)) .eq. 0) cycle - if (m .gt. 1.and.jnd(j) .eq. 1) then !> just print + if (m .gt. 1 .and. jnd(j) .eq. 1) then !> just print write (ch,'(''reference atom'',i4,'' # :'',i2)') equiv(1,j,ig),m do k = 1,m jnd(equiv(k,j,ig)) = 0 @@ -2345,7 +2345,7 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) !c J averaging matrix !ccccccccccccccccccccc if (rotfil) then - allocate (jfake(n*(n+1)/2),sd(n,n),cn(n)) + allocate (jfake(n * (n + 1) / 2),sd(n,n),cn(n)) atmp = 'anmr_rotamer' open (unit=112,file=atmp,form='unformatted') write (112) ng @@ -2358,15 +2358,15 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) call distance(n,xyz(:,:,irr),sd) !> distance matrix cdum(1:3,1:n) = xyz(1:3,1:n,irr) call calculate_CN(n,at,cdum,cn) - do i = 1,n-1 - do j = i+1,n - jfake(lin(j,i)) = cn(i)*cn(j)*sqrt(dble(at(i)*at(j))) & - & /(dble(pair(lin(j,i)))*sd(j,i)**5) !> the approx. "J" is topologically equivalent to J + do i = 1,n - 1 + do j = i + 1,n + jfake(lin(j,i)) = cn(i) * cn(j) * sqrt(dble(at(i) * at(j))) & + & / (dble(pair(lin(j,i))) * sd(j,i)**5) !> the approx. "J" is topologically equivalent to J !> R^3 was wrong in one case because Hs were artificially paired !> R^5 seems to be save end do end do - write (112) jfake(1:n*(n+1)/2) !> read by anmr + write (112) jfake(1:n * (n + 1) / 2) !> read by anmr end do end do close (112) @@ -2478,8 +2478,8 @@ subroutine cregen_repairorder(nat,nall,xyz,comments,group) do i = 1,ng do l = 1,tmax !>-- with timetag info do j = 1,nall - if (group(j) .eq. i.and.timetag(j) .eq. l) then - k = k+1 + if (group(j) .eq. i .and. timetag(j) .eq. l) then + k = k + 1 orderref(k) = j order(k) = i end if @@ -2490,7 +2490,7 @@ subroutine cregen_repairorder(nat,nall,xyz,comments,group) do i = 1,ng do j = 1,nall !>-- without timetag info if (group(j) .eq. i) then - k = k+1 + k = k + 1 orderref(k) = j order(k) = i end if @@ -2541,26 +2541,26 @@ recursive subroutine xyzqsort(nat,nall,xyz,c0,ord,first,last) integer :: first,last integer :: x,t integer :: i,j - x = ord((first+last)/2) + x = ord((first + last) / 2) i = first j = last do do while (ord(i) < x) - i = i+1 + i = i + 1 end do do while (x < ord(j)) - j = j-1 + j = j - 1 end do if (i >= j) exit t = ord(i); ord(i) = ord(j); ord(j) = t c0(:,:) = xyz(:,:,i) xyz(:,:,i) = xyz(:,:,j) xyz(:,:,j) = c0(:,:) - i = i+1 - j = j-1 + i = i + 1 + j = j - 1 end do - if (first < i-1) call xyzqsort(nat,nall,xyz,c0,ord,first,i-1) - if (j+1 < last) call xyzqsort(nat,nall,xyz,c0,ord,j+1,last) + if (first < i - 1) call xyzqsort(nat,nall,xyz,c0,ord,first,i - 1) + if (j + 1 < last) call xyzqsort(nat,nall,xyz,c0,ord,j + 1,last) end subroutine xyzqsort !=========================================================================================! @@ -2584,7 +2584,7 @@ subroutine maskedxyz(n,nm,c,cm,at,atm,mask) if (mask(i) .gt. 0) then cm(1:3,k) = c(1:3,i) atm(k) = at(i) - k = k+1 + k = k + 1 end if end do return @@ -2606,7 +2606,7 @@ subroutine maskedxyz2(n,nm,c,cm,mask) do i = 1,n if (mask(i) .gt. 0) then cm(1:3,k) = c(1:3,i) - k = k+1 + k = k + 1 end if end do return @@ -2642,7 +2642,7 @@ subroutine cregen_file_wr(env,fname,nat,nall,at,xyz,comments) eref = grepenergy(comments(1)) do i = 1,nall er(i) = grepenergy(comments(i)) - erel(i) = (er(i)-eref)*autokcal + erel(i) = (er(i) - eref) * autokcal if (env%trackorigin) then call getorigin(comments(i),origin(i)) end if @@ -2706,10 +2706,10 @@ subroutine cregen_conffile(env,cname,nat,nall,at,xyz,comments,ng,degen) open (newunit=ich,file=trim(cname)) do i = 1,ng k = degen(2,i) - if (k <= 0.or.k > nall) cycle - if (i .eq. 1.or.env%printscoords) then !write a scoord.* for each conformer? scoord.1 is always written + if (k <= 0 .or. k > nall) cycle + if (i .eq. 1 .or. env%printscoords) then !write a scoord.* for each conformer? scoord.1 is always written call getname1(i,newcomment) - c0(:,:) = xyz(:,:,k)/bohr + c0(:,:) = xyz(:,:,k) / bohr call wrc0(newcomment,nat,at,c0) end if write (newcomment,'(2x,f18.8)') er(k) @@ -2739,59 +2739,30 @@ end subroutine cregen_conffile !=========================================================================================! -subroutine cregen_rmsdalign(nat,nall,at,xyz) +subroutine cregen_rmsdalign(nall,structures) !***************************************************** -!* Algin all structures in xyz to the first structure -!* in the ensemble based on the heavy-atom RMSD +!* Algin all structures in an array to the first one +!* in the ensemble, based on the heavy-atom RMSD !***************************************************** - use crest_parameters,only:wp - use crest_data - use ls_rmsd - use iomod + use crest_parameters + use irmsd_module + use strucrd implicit none - integer :: nat,nall - integer :: at(nat) - real(wp),intent(inout) :: xyz(3,nat,nall) - integer :: nath - integer :: i,j,k - real(wp),allocatable :: c0(:,:) - real(wp),allocatable :: c1(:,:) - real(wp),allocatable :: c2(:,:) - real(wp) :: g(3,3),U(3,3),x_center(3),y_center(3),rmsdval + integer,intent(in) :: nall + type(coord),intent(inout) :: structures(nall) + integer :: ii,nat + logical,allocatable :: mask(:) - nath = 0 - do j = 1,nat - if (at(j) > 2) nath = nath+1 - end do - allocate (c0(3,nath),c1(3,nath),source=0.0d0) - - allocate (c2(3,nat)) - !>--- get the reference structure (the first one) - i = 0 - do j = 1,nat - if (at(j) > 2) then - i = i+1 - c0(1:3,i) = xyz(1:3,j,1) - end if + nat = structures(1)%nat + allocate (mask(nat),source=.false.) + do ii = 1,nat + if (structures(1)%at(ii) > 1) mask(ii) = .true. end do - do k = 2,nall - !>--- and the other strucutres into c1 - i = 0 - do j = 1,nat - if (at(j) > 2) then - i = i+1 - c1(1:3,i) = xyz(1:3,j,k) - end if - end do - call rmsd(i,c1,c0,1,U,x_center,y_center,rmsdval,.false.,g) - - c2 = matmul(U(1:3,1:3),xyz(1:3,1:nat,k)) - xyz(1:3,1:nat,k) = c2 + do ii = 2,nall + call rmsd_align(structures(1),structures(ii),mask=mask) end do - deallocate (c2) - deallocate (c1,c0) return end subroutine cregen_rmsdalign @@ -2839,7 +2810,7 @@ subroutine cregen_setthreads(ch,env,pr) call new_ompautoset(env,'max',0,T,Tn) !$OMP PARALLEL PRIVATE(TID) TID = OMP_GET_THREAD_NUM() - IF (TID .EQ. 0.and.pr) THEN + IF (TID .EQ. 0 .and. pr) THEN nproc = OMP_GET_NUM_THREADS() write (ch,*) '=============================' write (ch,*) ' # threads =',nproc @@ -2860,7 +2831,7 @@ subroutine cregen_pr1(ch,env,nat,nall,rthr,bthr,pthr,ewin) integer :: nall real(wp) :: rthr,bthr,pthr,ewin logical :: substruc - substruc = (nat .ne. env%rednat.and.env%subRMSD) + substruc = (nat .ne. env%rednat .and. env%subRMSD) write (ch,'(" number of atoms",t35,":",i10)') nat if (substruc) then write (ch,'(" atoms included in RMSD",t35,":",i10)') env%rednat @@ -2881,7 +2852,7 @@ subroutine enso_duplicates(env,nall,double) integer :: double(nall) integer :: i,j,ich - if (.not.env%ENSO.or..not.env%confgo) return + if (.not. env%ENSO .or. .not. env%confgo) return j = sum(double) open (newunit=ich,file='cregen.enso') @@ -2946,7 +2917,7 @@ subroutine cregen_pr2(ch,env,nall,comments,ng,degen,er) env%elowest = eref do i = 1,nall er(i) = grepenergy(comments(i)) - erel(i) = (er(i)-eref)*autokcal + erel(i) = (er(i) - eref) * autokcal if (env%trackorigin) then call getorigin(comments(i),origin(i)) else @@ -2960,34 +2931,34 @@ subroutine cregen_pr2(ch,env,nall,comments,ng,degen,er) a = degen(2,i) b = degen(3,i) do j = a,b - pg(i) = pg(i)+p(j) + pg(i) = pg(i) + p(j) end do end do !>-- really long energy list write (ch,'(7x,a,8x,a,1x,a,2x,a,5x,a,3x,a,5x,a)') 'Erel/kcal','Etot', & & 'weight/tot','conformer','set','degen','origin' - if (env%entropic.and.ng > 50000) then + if (env%entropic .and. ng > 50000) then write (ch,'(1x,a)') '' chref = ch open (newunit=ch,file='crest.conformerlist') end if k = 0 do i = 1,ng - k = k+1 + k = k + 1 a = degen(2,i) b = degen(3,i) write (ch,'(i8,f8.3,1x,3f11.5,2i8,5x,a)') & & k,erel(a),er(a),p(a),pg(i),i,degen(1,i),trim(origin(a)) - if (.not.env%entropic) then - do j = a+1,b - k = k+1 + if (.not. env%entropic) then + do j = a + 1,b + k = k + 1 write (ch,'(i8,f8.3,1x,2f11.5,32x,a)') & & k,erel(j),er(j),p(j),trim(origin(j)) end do end if end do - if (env%entropic.and.ng > 50000) then + if (env%entropic .and. ng > 50000) then close (ch) ch = chref end if @@ -3006,18 +2977,18 @@ subroutine cregen_pr2(ch,env,nall,comments,ng,degen,er) A0 = 0 eav = 0 do i = 1,nall - A0 = A0+p(i)*log(p(i)+1.d-12) - eav = eav+p(i)*erel(i) + A0 = A0 + p(i) * log(p(i) + 1.d-12) + eav = eav + p(i) * erel(i) end do - beta = 1.0d0/(T*8.314510/4.184/1000.+1.d-14) - g = (1.0d0/beta)*A0 - s = -1000.0d0*4.184*g/T - ss = -1000.0d0*g/T + beta = 1.0d0 / (T * 8.314510 / 4.184 / 1000.+1.d-14) + g = (1.0d0 / beta) * A0 + s = -1000.0d0 * 4.184 * g / T + ss = -1000.0d0 * g / T write (ch,'(''T /K :'', F9.2)') T write (ch,'(''E lowest :'',f12.5)') eref !>---- elow printout in between routines - if (.not.env%confgo) then + if (.not. env%confgo) then write (stdout,'("CREGEN> E lowest :",f12.5)') eref end if if (env%QCG) then @@ -3029,27 +3000,27 @@ subroutine cregen_pr2(ch,env,nall,comments,ng,degen,er) write (ch,'(''ensemble entropy (J/mol K, cal/mol K) :'',2F9.3)') s,ss write (ch,'(''ensemble free energy (kcal/mol) : '',F8.3)') g end if - write (ch,'(''population of lowest in % : '',F8.3)') pg(1)*100.d0 + write (ch,'(''population of lowest in % : '',F8.3)') pg(1) * 100.d0 !>-- some ensemble data, entropy and G (including only unique conformers) allocate (egrp(ng),source=0.0_wp) do i = 1,ng a = degen(2,i) - egrp(i) = (er(a)-eref)*autokcal + egrp(i) = (er(a) - eref) * autokcal end do call boltz(ng,T,egrp,pg) A0 = 0 do i = 1,ng - A0 = A0+pg(i)*log(pg(i)+1.d-12) + A0 = A0 + pg(i) * log(pg(i) + 1.d-12) end do deallocate (egrp) - beta = 1.0d0/(T*8.314510/4.184/1000.+1.d-14) - g = (1.0d0/beta)*A0 - ss = -1000.0d0*g/T + beta = 1.0d0 / (T * 8.314510 / 4.184 / 1000.+1.d-14) + g = (1.0d0 / beta) * A0 + ss = -1000.0d0 * g / T env%emtd%sapprox = ss !> save for entropy mode !>-- MF-MD-GC legacy option - if ((env%crestver .eq. 1).and.(.not.env%confgo)) then + if ((env%crestver .eq. 1) .and. (.not. env%confgo)) then inquire (file='.tmpxtbmodef',exist=ex) if (ex) then open (unit=66,file='.tmpxtbmodef') @@ -3059,11 +3030,11 @@ subroutine cregen_pr2(ch,env,nall,comments,ng,degen,er) else elow = er(1) end if - if ((elow-eref)*autokcal .lt. -0.2) then + if ((elow - eref) * autokcal .lt. -0.2) then write (ch,*) '...............................................' write (ch,*) 'WARNING: new (best) energy less than that from ' write (ch,*) 'WARNING: preceding Hessian calculation: ' - write (ch,*) 'Improved by ',elow-eref,' Eh or ', (elow-eref)*autokcal,'kcal' + write (ch,*) 'Improved by ',elow - eref,' Eh or ', (elow - eref) * autokcal,'kcal' write (ch,*) '...............................................' call touch('LOWER_FOUND') end if @@ -3090,8 +3061,8 @@ subroutine cregen_econf_list(ch,nall,er,ng,degen) eref = er(1) do i = 1,ng j = degen(2,i) - ewrt = er(j)-eref - ewrt = ewrt*autokcal + ewrt = er(j) - eref + ewrt = ewrt * autokcal write (ich2,'(2x,i0,2x,f12.3)') i,ewrt end do close (ich2) @@ -3125,7 +3096,7 @@ subroutine cregen_pr3(ch,infile,nall,comments) write (ch,'(a10,4x,a15,a25)') 'structure','ΔE(kcal/mol)','Etot(Eh)' !write (ch,'('' structure ΔE(kcal/mol) Etot(Eh)'')') do i = 1,nall - dE = (er(i)-er(1))*autokcal + dE = (er(i) - er(1)) * autokcal write (ch,'(i10,3x,F15.4,F25.10)') i,dE,er(i) end do write (ch,*) diff --git a/src/sorting/cregen_interfaces.f90 b/src/sorting/cregen_interfaces.f90 index 0cf36f63..fa9f2aca 100644 --- a/src/sorting/cregen_interfaces.f90 +++ b/src/sorting/cregen_interfaces.f90 @@ -114,5 +114,14 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & integer,intent(in),optional :: printlvl integer,intent(in),optional :: ch end subroutine cregen_CRE_new + + subroutine cregen_rmsdalign(nall,structures) + use crest_parameters + use irmsd_module + use strucrd + implicit none + integer,intent(in) :: nall + type(coord),intent(inout) :: structures(nall) + end subroutine cregen_rmsdalign end interface end module cregen_subroutines diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index 3433e10d..bfb0407f 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -14,6 +14,7 @@ module irmsd_module public :: rmsd public :: min_rmsd + public :: rmsd_align public :: checkranks,fallbackranks public :: molatomsort @@ -249,7 +250,7 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient,ccache) result(rmsdval) k = 0 do ic = 1,ref%nat if (mask(ic)) then - k = k+1 + k = k + 1 scratchptr(1:3,k,1) = mol%xyz(1:3,ic) scratchptr(1:3,k,2) = ref%xyz(1:3,ic) end if @@ -266,7 +267,7 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient,ccache) result(rmsdval) if (mask(ic)) then grdptr(1:3,ic) = grdptr(1:3,k) grdptr(1:3,k) = 0.0_wp - k = k-1 + k = k - 1 end if end do end if @@ -327,18 +328,18 @@ subroutine rmsd_core(nat,xyz1,xyz2,calc_u,U,error,calc_g,grad,ccache) !> calculate the barycenters, centroidal coordinates, and the norms x_norm = 0.0_wp y_norm = 0.0_wp - rnat = 1.0_wp/real(nat,wp) + rnat = 1.0_wp / real(nat,wp) do i = 1,3 xi(:nat) = x(i,1:nat) yi(:nat) = y(i,1:nat) - x_center(i) = sum(xi(1:nat))*rnat - y_center(i) = sum(yi(1:nat))*rnat - xi(1:nat) = xi(1:nat)-x_center(i) - yi(1:nat) = yi(1:nat)-y_center(i) + x_center(i) = sum(xi(1:nat)) * rnat + y_center(i) = sum(yi(1:nat)) * rnat + xi(1:nat) = xi(1:nat) - x_center(i) + yi(1:nat) = yi(1:nat) - y_center(i) x(i,1:nat) = xi(1:nat) y(i,1:nat) = yi(1:nat) - x_norm = x_norm+dot_product(xi,xi) - y_norm = y_norm+dot_product(yi,yi) + x_norm = x_norm + dot_product(xi,xi) + y_norm = y_norm + dot_product(yi,yi) end do !> calculate the R matrix @@ -349,25 +350,25 @@ subroutine rmsd_core(nat,xyz1,xyz2,calc_u,U,error,calc_g,grad,ccache) end do !> S matrix - S(1,1) = Rmatrix(1,1)+Rmatrix(2,2)+Rmatrix(3,3) - S(2,1) = Rmatrix(2,3)-Rmatrix(3,2) - S(3,1) = Rmatrix(3,1)-Rmatrix(1,3) - S(4,1) = Rmatrix(1,2)-Rmatrix(2,1) + S(1,1) = Rmatrix(1,1) + Rmatrix(2,2) + Rmatrix(3,3) + S(2,1) = Rmatrix(2,3) - Rmatrix(3,2) + S(3,1) = Rmatrix(3,1) - Rmatrix(1,3) + S(4,1) = Rmatrix(1,2) - Rmatrix(2,1) S(1,2) = S(2,1) - S(2,2) = Rmatrix(1,1)-Rmatrix(2,2)-Rmatrix(3,3) - S(3,2) = Rmatrix(1,2)+Rmatrix(2,1) - S(4,2) = Rmatrix(1,3)+Rmatrix(3,1) + S(2,2) = Rmatrix(1,1) - Rmatrix(2,2) - Rmatrix(3,3) + S(3,2) = Rmatrix(1,2) + Rmatrix(2,1) + S(4,2) = Rmatrix(1,3) + Rmatrix(3,1) S(1,3) = S(3,1) S(2,3) = S(3,2) - S(3,3) = -Rmatrix(1,1)+Rmatrix(2,2)-Rmatrix(3,3) - S(4,3) = Rmatrix(2,3)+Rmatrix(3,2) + S(3,3) = -Rmatrix(1,1) + Rmatrix(2,2) - Rmatrix(3,3) + S(4,3) = Rmatrix(2,3) + Rmatrix(3,2) S(1,4) = S(4,1) S(2,4) = S(4,2) S(3,4) = S(4,3) - S(4,4) = -Rmatrix(1,1)-Rmatrix(2,2)+Rmatrix(3,3) + S(4,4) = -Rmatrix(1,1) - Rmatrix(2,2) + Rmatrix(3,3) !> Calculate eigenvalues and eigenvectors, and !> take the maximum eigenvalue lambda and the corresponding eigenvector q. @@ -385,14 +386,14 @@ subroutine rmsd_core(nat,xyz1,xyz2,calc_u,U,error,calc_g,grad,ccache) end if !> RMS Deviation - error = sqrt(max(0.0_wp, ((x_norm+y_norm)-2.0_wp*lambda))*rnat) + error = sqrt(max(0.0_wp, ((x_norm + y_norm) - 2.0_wp * lambda)) * rnat) if (calc_g) then !> Gradient of the error of xyz1 w.r.t xyz2 do i = 1,nat do j = 1,3 tmp(:) = matmul(transpose(U(:,:)),y(:,i)) - grad(j,i) = ((x(j,i)-tmp(j))/error)*rnat + grad(j,i) = ((x(j,i) - tmp(j)) / error) * rnat end do end do end if @@ -400,6 +401,57 @@ subroutine rmsd_core(nat,xyz1,xyz2,calc_u,U,error,calc_g,grad,ccache) end associate end subroutine rmsd_core +!========================================================================================! + subroutine rmsd_align(ref,mol,mask) + !******************************************************** + !* Routine to align the structure "mol" + !* to a reference structure "ref" + !* via the quternion RMSD + !* Input: + !* ref - reference structure + !* mask - (optional) only consider specific atoms + !* In/Output: + !* mol - structure to have it's coordinates aligned + !******************************************************** + + implicit none + type(coord),intent(in) :: ref + type(coord),intent(inout) :: mol + logical,intent(in),optional :: mask(:) + + real(wp) :: Umat(3,3),tmp + real(wp) :: cref(3),cmol(3),shift(3) + integer :: ii,jj,nn + + !> barycenter shift + cref(:) = 0.0_wp + cmol(:) = 0.0_wp + shift(:) = 0.0_wp + do ii = 1,ref%nat + if (present(mask)) then + if (mask(ii)) then + cref(:) = cref(:) + ref%xyz(:,ii) + cmol(:) = cmol(:) + mol%xyz(:,ii) + end if + else + cref(:) = cref(:) + ref%xyz(:,ii) + cmol(:) = cmol(:) + mol%xyz(:,ii) + end if + end do + nn = ref%nat + if (present(mask)) nn = count(mask) + shift = cref - cmol + do ii = 1,mol%nat + mol%xyz(:,ii) = mol%xyz(:,ii) + shift(:) + end do + + Umat(:,:) = 0.0_wp + tmp = rmsd(ref,mol,mask=mask,rotmat=Umat) + + mol%xyz = matmul(Umat,mol%xyz) + + end subroutine rmsd_align + !========================================================================================! subroutine min_rmsd(ref,mol,rcache,rmsdout,align,topocheck,io) @@ -477,7 +529,7 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout,align,topocheck,io) end if !>--- First sorting, to at least restore rank order (only if that's not the case!) - if (.not.all(cptr%rank(:,1) .eq. cptr%rank(:,2))) then + if (.not. all(cptr%rank(:,1) .eq. cptr%rank(:,2))) then call rank_2_order(ref%nat,cptr%rank(:,1),cptr%target_order) call rank_2_order(mol%nat,cptr%rank(:,2),cptr%current_order) if (debug) then @@ -502,14 +554,14 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout,align,topocheck,io) do ii = 1,ref%nat rnk = cptr%rank(ii,1) if (rnk > 0) then - cptr%ngroup(rnk) = cptr%ngroup(rnk)+1 + cptr%ngroup(rnk) = cptr%ngroup(rnk) + 1 end if end do end if !> assignment reset cptr%assigned(:) = .false. cptr%rassigned(:) = .false. - cptr%rassigned(cptr%nranks+1:) = .true. !> skip unneeded allocation space + cptr%rassigned(cptr%nranks + 1:) = .true. !> skip unneeded allocation space do ii = 1,ref%nat cptr%iwork(ii) = ii !> also init iwork cptr%target_order(ii) = ii !> also init target_order @@ -551,9 +603,9 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout,align,topocheck,io) !> The logic here is: if we have enough unique atoms !> we can align the molecule with them and identify !> symmetry equivalent atoms via LSAP in those thereafter - IF (nunique >= 3)then + IF (nunique >= 3) then !> mol still needs a first alignment and CMA shift - call CMAtrf(mol%nat,mol%nat,mol%at,mol%xyz) + call CMAtrf(mol%nat,mol%nat,mol%at,mol%xyz) tmprmsd_sym(:) = inf tmprmsd_sym(1) = rmsd(ref,mol,cptr%lwork, & @@ -621,14 +673,14 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout,align,topocheck,io) mol%xyz(3,:) = -mol%xyz(3,:) if (debug) write (*,*) 'inverting' end if - if ((ii > 4.and.ii < 9).or.(ii > 20.and.ii < 25)) then + if ((ii > 4 .and. ii < 9) .or. (ii > 20 .and. ii < 25)) then if (uniquenesscase == 1) mol%xyz = matmul(Rx90,mol%xyz) if (uniquenesscase == 2) mol%xyz = matmul(Rz90,mol%xyz) if (uniquenesscase == 3) mol%xyz = matmul(Rz90,mol%xyz) if (debug) write (*,*) '90° tilt' - else if ((ii > 8.and.ii < 13).or.(ii > 24.and.ii < 29)) then + else if ((ii > 8 .and. ii < 13) .or. (ii > 24 .and. ii < 29)) then mol%xyz = matmul(Ry90,mol%xyz) - else if ((ii > 12.and.ii < 17).or.(ii > 28)) then + else if ((ii > 12 .and. ii < 17) .or. (ii > 28)) then mol%xyz = matmul(Rx90,mol%xyz) end if select case (ii) !> 180° rotations @@ -713,7 +765,7 @@ subroutine min_rmsd_iterate_through_groups(ref,mol,rcache,val) !> add up the total LSAP cost (of considered ranks) !> we need this if we have to decide on a mapping in case of false enantiomers - val = val+val0 + val = val + val0 end do end subroutine min_rmsd_iterate_through_groups @@ -770,27 +822,27 @@ subroutine min_rmsd_rotcheck_permute(ref,mol,cptr,values,step,uniquenesscase) ALIGNLOOP: do ii = 1,4 call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) - vals(1+4*(ii-1)) = dum + vals(1 + 4 * (ii - 1)) = dum if (debug) call mol%append(debugunit2) - cptr%order_bkup(:,1+4*(ii-1)+16*(step-1)) = cptr%iwork(:) + cptr%order_bkup(:,1 + 4 * (ii - 1) + 16 * (step - 1)) = cptr%iwork(:) mol%xyz = matmul(Rx180,mol%xyz) call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) - vals(2+4*(ii-1)) = dum + vals(2 + 4 * (ii - 1)) = dum if (debug) call mol%append(debugunit2) - cptr%order_bkup(:,2+4*(ii-1)+16*(step-1)) = cptr%iwork(:) + cptr%order_bkup(:,2 + 4 * (ii - 1) + 16 * (step - 1)) = cptr%iwork(:) mol%xyz = matmul(Ry180,mol%xyz) call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) - vals(3+4*(ii-1)) = dum + vals(3 + 4 * (ii - 1)) = dum if (debug) call mol%append(debugunit2) - cptr%order_bkup(:,3+4*(ii-1)+16*(step-1)) = cptr%iwork(:) + cptr%order_bkup(:,3 + 4 * (ii - 1) + 16 * (step - 1)) = cptr%iwork(:) mol%xyz = matmul(Rx180,mol%xyz) call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) - vals(4+4*(ii-1)) = dum + vals(4 + 4 * (ii - 1)) = dum if (debug) call mol%append(debugunit2) - cptr%order_bkup(:,4+4*(ii-1)+16*(step-1)) = cptr%iwork(:) + cptr%order_bkup(:,4 + 4 * (ii - 1) + 16 * (step - 1)) = cptr%iwork(:) mol%xyz = matmul(Ry180,mol%xyz) !> restore @@ -833,7 +885,7 @@ subroutine min_rmsd_rotcheck_permute(ref,mol,cptr,values,step,uniquenesscase) end if do ii = 1,16 - values(ii+16*(step-1)) = vals(ii) + values(ii + 16 * (step - 1)) = vals(ii) end do end subroutine min_rmsd_rotcheck_permute @@ -854,14 +906,14 @@ subroutine fallbackranks(ref,mol,nat,ranks) allocate (typemap(nat),source=0) k = 0 do ii = 1,ref%nat - if (.not.any(typemap(:) .eq. ref%at(ii))) then - k = k+1 + if (.not. any(typemap(:) .eq. ref%at(ii))) then + k = k + 1 typemap(k) = ref%at(ii) end if end do do ii = 1,mol%nat - if (.not.any(typemap(:) .eq. mol%at(ii))) then - k = k+1 + if (.not. any(typemap(:) .eq. mol%at(ii))) then + k = k + 1 typemap(k) = mol%at(ii) end if end do @@ -933,14 +985,14 @@ subroutine compute_linear_sum_assignment(ref,mol,ranks, & ii = 0 do i = 1,ref%nat if (ranks(i,1) .ne. targetrank) cycle - ii = ii+1 + ii = ii + 1 iwork2(ii,1) = i !> mapping using the first column of iwork2 jj = 0 do j = 1,mol%nat if (ranks(j,2) .ne. targetrank) cycle - jj = jj+1 - dists(:) = real((ref%xyz(:,i)-mol%xyz(:,j))**2,sp) !> use i and j - aptr%Cost(jj+(ii-1)*rnknat) = sum(dists) + jj = jj + 1 + dists(:) = real((ref%xyz(:,i) - mol%xyz(:,j))**2,sp) !> use i and j + aptr%Cost(jj + (ii - 1) * rnknat) = sum(dists) end do end do @@ -960,8 +1012,8 @@ subroutine compute_linear_sum_assignment(ref,mol,ranks, & do i = 1,rnknat jj = aptr%a(i) ii = aptr%b(i) - if (ii == -1.or.jj == -1) cycle !> cycle bad assignments - val0 = val0+aptr%Cost(jj+(ii-1)*rnknat) + if (ii == -1 .or. jj == -1) cycle !> cycle bad assignments + val0 = val0 + aptr%Cost(jj + (ii - 1) * rnknat) iwork2(i,2) = iwork2(aptr%b(i),1) end do else @@ -986,7 +1038,7 @@ subroutine rank_2_order(nat,rank,order) do ii = 1,maxrank do jj = 1,nat if (rank(jj) == ii) then - k = k+1 + k = k + 1 order(jj) = k end if end do @@ -1018,8 +1070,8 @@ function checkranks(nat,ranks1,ranks2) result(yesno) count1 = 0 count2 = 0 do jj = 1,nat - if (ranks1(jj) .eq. ii) count1 = count1+1 - if (ranks2(jj) .eq. ii) count2 = count2+1 + if (ranks1(jj) .eq. ii) count1 = count1 + 1 + if (ranks2(jj) .eq. ii) count2 = count2 + 1 end do !> not the same amount of atoms in rank ii, return from function if (count1 .ne. count2) return @@ -1129,7 +1181,7 @@ function check_proxy_topo(self,ref,mol) result(io) self%proxy_topo(:,1) = mol%at(:) self%proxy_topo(:,2) = self%rank(:,2) call qsortm(self%proxy_topo,2,self%iwork) - if (.not.all(self%proxy_topo .eq. self%proxy_topo_ref)) then + if (.not. all(self%proxy_topo .eq. self%proxy_topo_ref)) then io = 3 return !> some difference in the sorting, return before setting passing to true end if @@ -1146,15 +1198,15 @@ recursive subroutine qsorti(v,ix,l,r) integer,intent(in) :: l,r integer :: i,j,p,t,n if (l >= r) return - p = v(ix((l+r)/2)) + p = v(ix((l + r) / 2)) n = size(v,1) i = l; j = r do - do while (v(ix(i)) < p); i = i+1; end do - do while (v(ix(j)) > p); j = j-1; end do + do while (v(ix(i)) < p); i = i + 1; end do + do while (v(ix(j)) > p); j = j - 1; end do if (i <= j) then t = ix(i); ix(i) = ix(j); ix(j) = t - i = min(i+1,n); j = max(j-1,1) + i = min(i + 1,n); j = max(j - 1,1) else exit end if From 86e2c2a209da9cb6d660ebd8095f376c90ba30ed Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 6 Feb 2026 20:10:26 +0100 Subject: [PATCH 163/374] Work on required CREGEN refactor 6 --- src/sorting/cregen.f90 | 126 +++++++++++++----------------- src/sorting/cregen_interfaces.f90 | 23 ++++++ src/strucreader.f90 | 11 +-- 3 files changed, 85 insertions(+), 75 deletions(-) diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 52d14fad..fb33ff09 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -227,24 +227,24 @@ subroutine newcregen(env,quickset,infile) !>--- align all structures to the first structure using the RMSD call cregen_rmsdalign(nall,structures) - stop - !>--- write new file with ALL remaining structures if (newfile) then - call cregen_file_wr(env,oname,nat,nall,at,xyz,comments) + call cregen_file_wr(env,oname,structures) !>--- track ensemble for restart - call trackensemble(oname,nat,nall,at,xyz,comments) +! call trackensemble(oname,nat,nall,at,xyz,comments) end if !>--- write a file containing only conformers (no rotamers) if (conffile) then - call cregen_conffile(env,cname,nat,nall,at,xyz,comments,ng,degen) + call cregen_conffile(env,cname,structures,ng,degen) end if if (saveelow) then - env%elowest = grepenergy(comments(1)) + env%elowest = structures(1)%energy !>-- and update reference geometry (in Bohr) - env%ref%xyz = xyz(:,:,1) / bohr + env%ref%xyz = structures(1)%xyz end if + stop + !>--- additional files for entropy mode if (bonusfiles) then call cregen_bonusfiles(ng,degen) @@ -2614,62 +2614,59 @@ end subroutine maskedxyz2 !=========================================================================================! -subroutine cregen_file_wr(env,fname,nat,nall,at,xyz,comments) -!********************************* -!* write the output ensemble file -!********************************* - use crest_parameters,only:wp +subroutine cregen_file_wr(env,fname,structures) +!********************************************************************* +!* write the output ensemble file with all structures (rotamer file) +!********************************************************************* + use crest_parameters use crest_data use strucrd use utilities,only:boltz implicit none - type(systemdata) :: env - character(len=*) :: fname + type(systemdata),intent(inout) :: env + character(len=*),intent(in) :: fname + type(coord),intent(inout) :: structures(:) integer :: nat,nall - integer :: at(nat) - real(wp) :: xyz(3,nat,nall) - character(len=*) :: comments(nall) character(len=128) :: newcomment - integer :: ich,i - real(wp),allocatable :: c0(:,:),xdum(:) + integer :: ich,ii real(wp) :: eref,T real(wp),allocatable :: er(:),erel(:),p(:) character(len=40),allocatable :: origin(:) - real(wp),parameter :: autokcal = 627.509541_wp - allocate (er(nall),erel(nall),p(nall),origin(nall)) - eref = grepenergy(comments(1)) - do i = 1,nall - er(i) = grepenergy(comments(i)) - erel(i) = (er(i) - eref) * autokcal - if (env%trackorigin) then - call getorigin(comments(i),origin(i)) - end if + nall = size(structures,1) + allocate (er(nall),erel(nall),p(nall))!,origin(nall)) + eref = structures(1)%energy + do ii = 1,nall + er(ii) = structures(ii)%energy + erel(ii) = (er(ii) - eref) * autokcal + !if (env%trackorigin) then + ! call getorigin(comments(i),origin(i)) + !end if end do T = env%tboltz call boltz(nall,T,erel,p) - allocate (c0(3,nat),xdum(3)) open (newunit=ich,file=fname) - do i = 1,nall - c0(:,:) = xyz(:,:,i) - if (env%trackorigin) then - write (newcomment,*) er(i),p(i),'!'//trim(origin(i)) - else - write (newcomment,*) er(i),p(i) - end if - call wrxyz(ich,nat,at,c0,newcomment) + do ii = 1,nall + !if (env%trackorigin) then + !write (newcomment,'(a,f10.8,1x,a)') 'population=',p(ii),trim(origin(ii)) + !else + write (newcomment,'(a,f10.8)') 'population=',p(ii) + !end if + structures(ii)%comment = trim(newcomment) + call structures(ii)%append(ich) end do close (ich) - deallocate (xdum,c0) - deallocate (origin,p,erel,er) + !deallocate (origin,p,erel,er) + if (allocated(origin)) deallocate (origin) + deallocate (p,erel,er) return end subroutine cregen_file_wr !=========================================================================================! -subroutine cregen_conffile(env,cname,nat,nall,at,xyz,comments,ng,degen) +subroutine cregen_conffile(env,cname,structures,ng,degen) !********************************* !* write the output ensemble file !********************************* @@ -2679,50 +2676,39 @@ subroutine cregen_conffile(env,cname,nat,nall,at,xyz,comments,ng,degen) use iomod use utilities implicit none - type(systemdata) :: env - character(len=*) :: cname + type(systemdata),intent(inout) :: env + character(len=*),intent(in) :: cname + type(coord),intent(inout) :: structures(:) + integer,intent(in) :: ng + integer,intent(in) :: degen(3,ng) integer :: nat,nall - integer :: at(nat) - real(wp) :: xyz(3,nat,nall) - character(len=*) :: comments(nall) - integer :: ng - integer :: degen(3,ng) - character(len=128) :: newcomment integer :: ich,ich3,ichenso - integer :: i,k - real(wp),allocatable :: c0(:,:) + integer :: i,k,ii real(wp),allocatable :: er(:) + + nall = size(structures,1) allocate (er(nall)) - do i = 1,nall - er(i) = grepenergy(comments(i)) + do ii = 1,nall + er(ii) = structures(ii)%energy + if (allocated(structures(ii)%comment)) & + & deallocate (structures(ii)%comment) end do - allocate (c0(3,nat)) if (env%enso) then open (newunit=ichenso,file='enso.tags') end if - c0(:,:) = xyz(:,:,1) - write (newcomment,'(2x,f18.8)') er(1) - call wrxyz('crest_best.xyz',nat,at,xyz(:,:,1),newcomment) + call structures(1)%write('crest_best.xyz') open (newunit=ich,file=trim(cname)) - do i = 1,ng - k = degen(2,i) + do ii = 1,ng + k = degen(2,ii) if (k <= 0 .or. k > nall) cycle - if (i .eq. 1 .or. env%printscoords) then !write a scoord.* for each conformer? scoord.1 is always written - call getname1(i,newcomment) - c0(:,:) = xyz(:,:,k) / bohr - call wrc0(newcomment,nat,at,c0) - end if - write (newcomment,'(2x,f18.8)') er(k) - call wrxyz(ich,nat,at,xyz(:,:,k),newcomment) - if (env%enso) write (ichenso,*) trim(comments(k)) + call structures(k)%append(ich) + if (env%enso) write (ichenso,'(2x,f18.8)') er(k) end do close (ich) - deallocate (c0) - deallocate (er) - if (env%enso) then close (ichenso) end if + deallocate (er) call remove('cre_members') open (newunit=ich3,file='cre_members') @@ -2836,7 +2822,7 @@ subroutine cregen_pr1(ch,env,nat,nall,rthr,bthr,pthr,ewin) if (substruc) then write (ch,'(" atoms included in RMSD",t35,":",i10)') env%rednat end if - write (ch,'(" number of points on xyz files",t35,":",i10)') nall + write (ch,'(" number of points on xyz file",t35,":",i10)') nall !write (ch,'('' RMSD threshold :'',f9.4)') rthr !write (ch,'('' Bconst threshold :'',f9.4)') bthr !write (ch,'('' population threshold :'',f9.4)') pthr diff --git a/src/sorting/cregen_interfaces.f90 b/src/sorting/cregen_interfaces.f90 index fa9f2aca..deae7857 100644 --- a/src/sorting/cregen_interfaces.f90 +++ b/src/sorting/cregen_interfaces.f90 @@ -123,5 +123,28 @@ subroutine cregen_rmsdalign(nall,structures) integer,intent(in) :: nall type(coord),intent(inout) :: structures(nall) end subroutine cregen_rmsdalign + + subroutine cregen_file_wr(env,fname,structures) + use crest_parameters + use crest_data + use strucrd + use utilities,only:boltz + implicit none + type(systemdata),intent(inout) :: env + character(len=*),intent(in) :: fname + type(coord),intent(inout) :: structures(:) + end subroutine cregen_file_wr + + subroutine cregen_conffile(env,cname,structures,ng,degen) + use crest_parameters + use crest_data + use strucrd + implicit none + type(systemdata),intent(inout) :: env + character(len=*),intent(in) :: cname + type(coord),intent(inout) :: structures(:) + integer,intent(in) :: ng + integer,intent(in) :: degen(3,ng) + end subroutine cregen_conffile end interface end module cregen_subroutines diff --git a/src/strucreader.f90 b/src/strucreader.f90 index d9a8b0fc..25a67d0a 100644 --- a/src/strucreader.f90 +++ b/src/strucreader.f90 @@ -2036,14 +2036,15 @@ subroutine appendcoord(self,io) class(coord) :: self integer :: io character(len=64) :: atmp + character(len=32) :: btmp self%xyz = self%xyz*bohr !to Angström + write(btmp,'(f22.10)') self%energy + write (atmp,'(a,a)') ' energy= ',adjustl(btmp) if (allocated(self%comment)) then - call wrxyz(io,self%nat,self%at,self%xyz,trim(self%comment)) - else if (self%energy .ne. 0.0_wp) then - write (atmp,'(a,f22.10)') ' energy= ',self%energy - call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) + call wrxyz(io,self%nat,self%at,self%xyz, & + & trim(atmp)//' '//trim(self%comment)) else - call wrxyz(io,self%nat,self%at,self%xyz) + call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) end if self%xyz = self%xyz/bohr !back return From 60f2ef6255b2cfe2f69550f557178f1e64232f21 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 7 Feb 2026 22:27:17 +0100 Subject: [PATCH 164/374] CREGEN refactor (likely) finished. Plus nicer printout --- src/sorting/cregen.f90 | 666 +++++++++-------------------------------- 1 file changed, 138 insertions(+), 528 deletions(-) diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index fb33ff09..55543e97 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -68,7 +68,7 @@ subroutine newcregen(env,quickset,infile) !>--- sorting arguments integer,allocatable :: gref(:),group(:) integer :: ng - integer :: i + integer :: i,ii integer,allocatable :: degen(:,:) !>--- float data @@ -176,25 +176,6 @@ subroutine newcregen(env,quickset,infile) !>--- do the rotational constants and RMSD check if (sortRMSD) then -! allocate (group(0:nall)) -! call cregen_CRE(prch,env,nat,nall,at,xyz,comments,nallnew,group,.false.) -!!>--- if structures were discarded, resize xyz -! if (nallnew .lt. nall) then -! nall = nallnew -! xyzref = xyz(:,:,1:nall) -! call move_alloc(xyzref,xyz) -! comref = comments(1:nall) -! call move_alloc(comref,comments) -! allocate (gref(0:nallnew)) -! gref(0:nallnew) = group(0:nallnew) -! call move_alloc(gref,group) -! nall = nallnew -! end if -!!>--- repair the order -! if (repairord) then -! call cregen_repairorder(nat,nall,xyz,comments,group) -! end if - call cregen_CRE_new(env,nall,structures,group,rthr, & & ethr / autokcal,bthr,printlvl=2,ch=prch) !>--- get group info to degen @@ -215,10 +196,6 @@ subroutine newcregen(env,quickset,infile) degen = 0 end if end if -! if (sortRMSD2) then -! allocate (group(0:nall)) -! call cregen_CRE(prch,env,nat,nall,at,xyz,comments,nallnew,group,.true.) -! end if !=====================================================================! !> E N S E M B L E O U T P U T @@ -243,22 +220,25 @@ subroutine newcregen(env,quickset,infile) env%ref%xyz = structures(1)%xyz end if - stop - !>--- additional files for entropy mode if (bonusfiles) then call cregen_bonusfiles(ng,degen) end if !>--- several printouts - if (pr2) then + if (pr2 .or. pr3 .or. pr4) then allocate (er(nall)) - call cregen_pr2(prch,env,nall,comments,ng,degen,er) + do ii = 1,nall + er(ii) = structures(ii)%energy + end do + end if + + if (pr2) then + call cregen_pr2(prch,env,nall,ng,degen,er) call cregen_econf_list(prch,nall,er,ng,degen) - deallocate (er) end if if (pr3) then !> alternative to pr2 - call cregen_pr3(prch,oname,nall,comments) + call cregen_pr3(prch,oname,nall,er) end if if (pr4) then !> group dara printout call cregen_pr4(prch,fname,nall,group) @@ -266,7 +246,7 @@ subroutine newcregen(env,quickset,infile) !>--- analyze nuclear equivalencies, e.g. for NMR and Entropy if (anal) then - call cregen_EQUAL(prch,nat,nall,at,xyz,group,athr,.not. env%entropic) + call cregen_EQUAL(prch,nall,structures,group,athr,.not. env%entropic) end if !>--- deallocate data @@ -276,7 +256,6 @@ subroutine newcregen(env,quickset,infile) if (allocated(er)) deallocate (er) if (allocated(degen)) deallocate (degen) if (allocated(group)) deallocate (group) - deallocate (xyz,comments,at) return end subroutine newcregen @@ -880,9 +859,9 @@ subroutine cregen_esort(ch,structures,nallout,ewin) end do if (ewin < 9999.9_wp) then - write (ch,'(" sorting energy window (EWIN)",t32,":",1x,f9.4,a)') ewin,' / kcal*mol⁻¹' + write (ch,'(" sorting energy window (EWIN)",t32,":",1x,f9.4,a)') ewin,' / kcal/mol' else - write (ch,'(" sorting energy window (EWIN)",t32,":",3x,a,a)') '+∞',' / kcal*mol⁻¹' + write (ch,'(" sorting energy window (EWIN)",t32,":",3x,a,a)') '+∞',' / kcal/mol' end if emax = maxval(energies(:),1) de = (emax - energies(1)) * autokcal @@ -915,394 +894,7 @@ subroutine cregen_esort(ch,structures,nallout,ewin) end subroutine cregen_esort !=========================================================================================! - -subroutine cregen_CRE(ch,env,nat,nall,at,xyz,comments,nallout,group,nosort) -!************************************************************* -!* NOTE: -!* This routine is deprecated, see crest_CRE_new below for current version -!* -!* subroutine cregen_CRE -!* sort the ensemble based on rotational constants,RMSD and -!* energy to determine rotamers and duplicates. -!* On Input: ch - printout channel -!* nat - number of atoms -!* nall - number of structure in ensemble -!* at - atom types -!* xyz - Cartesian coordinates -!* comments - commentary lines containing the energy -!* nosort - don't actually sort -!* On Output: nallout - new total number of structures -!* group - to which group every structure belongs -!************************************************************** - use crest_parameters,id => dp - use crest_data - use strucrd - use ls_rmsd - use axis_module - use utilities - use quicksort_interface - use rotaniso_mod - implicit none - type(systemdata) :: env - integer,intent(in) :: ch - integer,intent(in) :: nat - integer,intent(in) :: nall - integer,intent(in) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat,nall) - integer,intent(inout) :: group(0:nall) - logical,intent(in) :: nosort - character(len=*) :: comments(nall) - integer :: nallout - logical :: enantio = .true. !check for enantiomers? - - !>--- float data - real(wp) :: ewin,rthr,bthr,pthr,ethr,athr,T - !>--- energy data - real(wp),allocatable :: er(:) - integer,allocatable :: orderref(:),order(:) - real(wp) :: de - !>--- dummy structure data - integer,allocatable :: includeRMSD(:) - real(wp),allocatable :: c0(:,:),c1(:,:),cdum(:,:) - real(wp),allocatable :: c0h(:,:),c1h(:,:) - integer,allocatable :: maskheavy(:) - integer,allocatable :: at0(:) - logical :: substruc - integer :: nat0 - real(wp),allocatable :: rot(:,:) - real(wp) :: rotdum(3),bdum - !>--- RMSD data - real(sp),allocatable :: rmat(:) !SINGLE PRECISION - real(wp) :: rdum,dr,rdum2 - real(wp),allocatable :: gdum(:,:),Udum(:,:),xdum(:),ydum(:) !dummy tensors - integer(id) :: klong - integer(id),allocatable :: rmap1(:) - integer,allocatable :: rmap2(:) - logical :: l1,l2,l3 - !>--- CRE comparison data - integer,allocatable :: double(:) - logical,allocatable :: mask(:) - real(wp) :: couthr - real(wp),allocatable :: enuc(:) - real(wp),allocatable :: ecoul(:) - real(wp) :: r - integer :: i,j,k,l,natnoh - logical :: heavy - -!>--- set parameters - call cregen_filldata1(env,ewin,rthr,ethr,bthr,athr,pthr,T,couthr) - if (env%entropic) enantio = .false. - heavy = env%heavyrmsd - substruc = (nat .ne. env%rednat .and. env%subRMSD) - if (substruc) then - nat0 = env%rednat - includeRMSD = env%includeRMSD - end if - allocate (rot(3,nall)) - -!>--- get energies from the comment line - allocate (er(nall)) - allocate (orderref(nall),order(nall)) - do i = 1,nall - er(i) = grepenergy(comments(i)) - orderref(i) = i - end do - -!>--- get dummy structure memory space - if (substruc) then - allocate (c0(3,nat0),c1(3,nat0),at0(nat0)) - else - allocate (c0(3,nat),c1(3,nat),at0(nat)) - at0 = at - nat0 = nat - end if - -!>--- transform the coordinates to CMA and get rot.constants - do i = 1,nall - call axis(nat,at,xyz(:,:,i)) !>-- all coordinates to CMA - if (substruc) then - call maskedxyz(nat,nat0,xyz(:,:,i),c1,at,at0,includeRMSD) - else - c1(:,:) = xyz(:,:,i) - end if - call axis(nat0,at0,c1,rot(1:3,i),bdum) !>-- B0 in MHz - end do - -!>--- RMSD part - allocate (double(nall),source=0) - !========================================================! - !>-- crucial point: rmat is huge. VERY huge, potentially. - !>-- for large ensembles the size of rmat can be strongly reduced - !> but this requires additional tracking and counting. - !> It will pay off, however. - allocate (rmap1(nall),rmap2(nall)) - klong = 0 - do i = 1,nall - rmap1(i) = klong - l1 = .true. - do j = 1,i - 1 - !> ekcal(j) should always be smaller than ekcal(i) because i>j - de = (er(i) - er(j)) * autokcal - if (de .lt. ethr) then !>-- we only need RMSDs for structures close in energy - klong = klong + 1 - if (l1) then - rmap2(i) = j - l1 = .false. - end if - end if - end do - end do - - !>-- now klong is the size of rmat with only the minimum required RMSDs - !> rmat itself can be single precision. - allocate (rmat(klong),source=0.0_sp) - allocate (gdum(3,3),Udum(3,3),xdum(3),ydum(3)) - !>-- begin calculation of RMSDs - klong = 0 - write (stdout,'(a)',advance='no') 'CREGEN> running RMSDs ...' - flush (stdout) - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - if (.not. substruc) then !regular case, all atoms included in RMSD - if (.not. heavy) then !really, the regular case - do i = 1,nall - c0(1:3,1:nat) = xyz(1:3,1:nat,i) -!$OMP PARALLEL PRIVATE ( j,klong,c1,xdum,ydum,Udum,gdum,rdum,rdum2,de) & -!$OMP SHARED ( i,c0,rmat,nat,xyz,rmap1,rmap2,er,ethr,enantio) -!$OMP DO - do j = 1,i - 1 - de = (er(i) - er(j)) * autokcal - if (de .lt. ethr) then - c1(1:3,1:nat) = xyz(1:3,1:nat,j) - call rmsd(nat,c0,c1,0,Udum,xdum,ydum,rdum,.false.,gdum) ! all atoms - if (enantio) then !also check for enantiomer by inverting a coordinate - c1(1,:) = -c1(1,:) - call rmsd(nat,c0,c1,0,Udum,xdum,ydum,rdum2,.false.,gdum) ! all atoms - else - rdum2 = rdum - end if - klong = linr(rmap1(i),rmap2(i),j) - rmat(klong) = real(min(rdum,rdum2),sp) - end if - end do -!$OMP END DO -!$OMP END PARALLEL - end do - else !> heavy atom case - natnoh = nat - counth(nat,at) - allocate (c0h(3,natnoh),c1h(3,natnoh),source=0.0_wp) - allocate (maskheavy(nat),source=0) - call heavymask(nat,at,maskheavy) - write (*,*) 'doing heavy atom rmsds with ',natnoh,' atoms' - do i = 1,nall - call maskedxyz2(nat,natnoh,xyz(:,:,i),c0h,maskheavy) -!$OMP PARALLEL PRIVATE ( j,klong,c1h,xdum,ydum,Udum,gdum,rdum,rdum2,de) & -!$OMP SHARED ( i,c0h,rmat,nat,xyz,rmap1,rmap2,er,ethr,enantio,maskheavy) -!$OMP DO - do j = 1,i - 1 - de = (er(i) - er(j)) * autokcal - if (de .lt. ethr) then - call maskedxyz2(nat,natnoh,xyz(:,:,j),c1h,maskheavy) - call rmsd(natnoh,c0h,c1h,0,Udum,xdum,ydum,rdum,.false.,gdum) ! all atoms - if (enantio) then !also check for enantiomer by inverting a coordinate - c1h(1,:) = -c1h(1,:) - call rmsd(natnoh,c0h,c1h,0,Udum,xdum,ydum,rdum2,.false.,gdum) ! all atoms - else - rdum2 = rdum - end if - klong = linr(rmap1(i),rmap2(i),j) - rmat(klong) = real(min(rdum,rdum2),sp) - end if - end do -!$OMP END DO -!$OMP END PARALLEL - end do - deallocate (maskheavy,c1h,c0h) - end if - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - else !substruc == .true., RMSDs only on a part of the structure - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - do i = 1,nall - call maskedxyz2(nat,nat0,xyz(:,:,i),c0,includeRMSD) -!$OMP PARALLEL PRIVATE ( j,klong,c1,xdum,ydum,Udum,gdum,rdum,rdum2,de) & -!$OMP SHARED ( i,c0,rmat,nat,nat0,xyz,rmap1,rmap2,er,ethr,includeRMSD,enantio ) -!$OMP DO - do j = 1,i - 1 - de = (er(i) - er(j)) * autokcal - if (de .lt. ethr) then - call maskedxyz2(nat,nat0,xyz(:,:,j),c1,includeRMSD) - call rmsd(nat0,c0,c1,0,Udum,xdum,ydum,rdum,.false.,gdum) ! all atoms - if (enantio) then !also check for enantiomer by inverting a coordinate - c1(1,:) = -c1(1,:) - call rmsd(nat0,c0,c1,0,Udum,xdum,ydum,rdum2,.false.,gdum) ! all atoms - else - rdum2 = rdum - end if - klong = linr(rmap1(i),rmap2(i),j) - rmat(klong) = real(min(rdum,rdum2),sp) - end if - end do -!$OMP END DO -!$OMP END PARALLEL - end do - end if - write (stdout,'(1x,a)') 'done.' - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! -!>-- Now, with the RMSDs and rotational constants we can kick out duplicates - do i = 1,nall - do j = 1,i - 1 - !>-- only check for structures in energy range - de = (er(i) - er(j)) * autokcal - if (de .lt. ethr) then - klong = linr(rmap1(i),rmap2(i),j) - dr = rmat(klong) - else - cycle - end if - !>-- very small RMSD --> same structure - if (dr .lt. rthr) then - double(i) = j !>-- "i" is the same structure as "j" - !>-- slightly larger RMSD, but same rot. constants --> same structure - elseif (dr .lt. 2.0_wp * rthr) then - l1 = equalrotaniso(i,j,nall,rot,0.5d0 * bthr,env%bthrmax,env%bthrshift) - if (l1) then - double(i) = j !>-- "i" is the same structure as "j" - end if - end if - end do - !>-- find the original reference. k is a dummy variable - call backtrack(double,i,k) - end do - deallocate (c0,c1,at0) - deallocate (ydum,xdum,Udum,gdum) - deallocate (rmat,rmap2,rmap1) - - !>-- for ENSO write a file with duplicate info (if required) - call enso_duplicates(env,nall,double) - -!>-- count how many duplicates we have found - allocate (mask(nall)) - mask(:) = double(:) .ne. 0 - k = count(mask,1) - nallout = nall - k - deallocate (mask) - write (ch,*) 'number of doubles removed by rot/RMSD :',k - if (.not. nosort) then - write (ch,*) 'total number unique points considered further :',nallout - else - nallout = nall - end if -!>-- sort structures, energies, rot const. and comments - if (.not. nosort) then - j = 0 - l = nall + 1 - do i = 1,nall - if (double(i) .eq. 0) then - j = j + 1 - orderref(i) = j - else - l = l - 1 - orderref(i) = l - end if - end do - order = orderref - allocate (cdum(3,nat)) - call xyzqsort(nat,nall,xyz,cdum,order,1,nall) - deallocate (cdum) - order = orderref - call maskqsort(er,1,nall,order) - order = orderref - call stringqsort(nall,len(comments(1)),comments,1,nall,order) - order = orderref - call matqsort(3,nall,rot,rotdum,1,nall,order) - end if - -!>-- finally, determine conformer groups and their rotamers - allocate (c1(3,nat)) - allocate (enuc(nallout)) - do k = 1,nallout - c1(1:3,1:nat) = xyz(1:3,1:nat,k) - enuc(k) = 0.0_wp - do i = 1,nat - 1 - do j = i + 1,nat - r = (c1(1,i) - c1(1,j))**2 & - & + (c1(2,i) - c1(2,j))**2 & - & + (c1(3,i) - c1(3,j))**2 + 1.d-12 - enuc(k) = enuc(k) + at(i) * at(j) / r - end do - end do - end do -!>-- check energy, rot. const. and nuclear permutation - double = 0 !>-- re-use "double" - SORTI: do i = 1,nallout - SORTJ: do j = 1,i - 1 - !>-- energy difference - de = (er(i) - er(j)) * autokcal - l3 = double(j) .eq. 0 - if (.not. l3) cycle - if (abs(de) .lt. ethr) then - !>-- rotational constant difference - l1 = equalrotaniso(i,j,nall,rot,bthr,env%bthrmax,env%bthrshift) - !>-- nuclear permutation - l2 = 2.0d0 * abs(enuc(i) - enuc(j)) / (enuc(i) + enuc(j)) .lt. 1.d-3 - if (l1 .and. l2 .and. l3) then - double(i) = j !>-- "i" is a rotamer of "j" - call backtrack(double,i,k) - cycle SORTI - end if - end if - end do SORTJ - end do SORTI -!>-- assign conformer groups - k = 0 - group = 0 - do i = 1,nallout - if (double(i) .eq. 0) then - k = k + 1 - group(i) = k - else - j = double(i) - group(i) = group(j) - end if - end do - group(0) = k !>-- total number of groups - if (nosort) then - write (ch,'(1x,a,i10)') 'number of removed rotamers :', (nallout - k) - nallout = k - write (ch,'(1x,a,i10)') 'total number unique points remaining :',nallout - end if - - deallocate (enuc,c1,double) - deallocate (order,orderref) - if (allocated(ecoul)) deallocate (ecoul) - deallocate (er) - deallocate (rot) - return -contains - function counth(nat,at) result(nh) - implicit none - integer :: nat - integer :: at(nat) - integer :: nh,i - nh = 0 - do i = 1,nat - if (at(i) == 1) nh = nh + 1 - end do - return - end function counth - subroutine heavymask(nat,at,mask) - implicit none - integer :: nat - integer :: at(nat) - integer :: mask(nat) - integer :: i - mask = 0 - do i = 1,nat - if (at(i) .ne. 1) mask(i) = 1 - end do - return - end subroutine heavymask -end subroutine cregen_CRE - +!> The actual core of CREGEN: Conformer/Rotamer Classification !=========================================================================================! subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & & printlvl,ch) @@ -2017,15 +1609,13 @@ end subroutine cregen_irmsd_sort !=========================================================================================! -subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) +subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) !**************************************************************** !* subroutine cregen_EQUAL !* subroutine for the generation of nuclear equivalencies !* On Input: ch - printout channel -!* nat - number of atoms -!* nall - number of structure in ensemble -!* at - atom types -!* xyz - Cartesian coordinates +!* nall - number of structures +!* structures - the list of structures !* group - to which group does every strucutre belong !* athr - threshold for equivalency comparison !* rotfil - wirte anmr_rotamer file? @@ -2039,15 +1629,14 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) use utilities implicit none integer,intent(in) :: ch - integer,intent(in) :: nat integer,intent(in) :: nall - integer,intent(in) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat,nall) + type(coord),intent(in) :: structures(nall) integer,intent(inout) :: group(0:nall) real(wp),intent(in) :: athr logical,intent(in) :: rotfil + integer,allocatable :: at(:) real(wp),allocatable :: cdum(:,:) - integer :: ng,n + integer :: ng,n,nat integer :: i,j,k,l logical :: ex @@ -2075,6 +1664,11 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) character(len=:),allocatable :: atmp integer :: ig,ir,irr,nr +!>--- infer from structure list + nat = structures(1)%nat + allocate(at(nat)) + at(:) = structures(1)%at(:) + !>--- variable declarations n = nat !> other variable name for number of atoms ng = group(0) !> number of different groups (conformers) @@ -2103,7 +1697,8 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) !>--- set up the "pair" array --> how many bonds are between two nuclei? allocate (pair(n * (n + 1) / 2),metric(n,n),vis(n),pre(n),nb(200,n)) - cdum(1:3,1:n) = xyz(1:3,1:n,1) / bohr + !cdum(1:3,1:n) = xyz(1:3,1:n,1) / bohr + cdum(1:3,1:n) = structures(1)%xyz(1:3,1:n) call neighdist(n,at,cdum,nb,metric) k = 0 pair = 0 @@ -2128,7 +1723,8 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) !>-- (costly) symmetry analyis of all rotamers for NMR. this is complicated stuff also !> and the end of the program where this is completed... do i = 1,nall - call distance(n,xyz(:,:,i),dist(:,:,i)) !> distance matrix + !call distance(n,xyz(:,:,i),dist(:,:,i)) !> distance matrix + call distance(n,structures(i)%xyz(:,:),dist(:,:,i)) !> distance matrix do j = 1,n do k = 1,n tmp2(k) = dist(k,j,i) * dble(at(k)) !> the distance of j to all atoms * Z to distinguish @@ -2355,8 +1951,8 @@ subroutine cregen_EQUAL(ch,nat,nall,at,xyz,group,athr,rotfil) write (112) nr do ir = 1,nr irr = glist(ir,ig) - call distance(n,xyz(:,:,irr),sd) !> distance matrix - cdum(1:3,1:n) = xyz(1:3,1:n,irr) + call distance(n,structures(irr)%xyz(:,:),sd) !> distance matrix + cdum(1:3,1:n) = structures(irr)%xyz(1:3,1:n) call calculate_CN(n,at,cdum,cn) do i = 1,n - 1 do j = i + 1,n @@ -2874,80 +2470,109 @@ subroutine create_anmr_dummy(nat) return end subroutine create_anmr_dummy -subroutine cregen_pr2(ch,env,nall,comments,ng,degen,er) +subroutine cregen_pr2(ch,env,nall,ng,degen,er) use crest_parameters use crest_data use strucrd - use iomod,only:touch + use iomod,only:touch,remove use utilities,only:boltz implicit none - integer :: ch - type(systemdata) :: env - integer :: nall - character(len=*) :: comments(nall) - integer :: ng - integer :: degen(3,ng) - real(wp) :: er(nall) - integer :: ich,chref + integer,intent(in) :: ch + type(systemdata),intent(inout) :: env + integer,intent(in) :: nall + integer,intent(in) :: ng + integer,intent(in) :: degen(3,ng) + real(wp),intent(in) :: er(nall) + integer :: ich,chref,och,och2 integer :: i,j,k real(wp),allocatable :: erel(:),egrp(:) - real(wp),allocatable :: p(:),pg(:) + real(wp),allocatable :: p(:),pg(:),paccu(:) real(wp) :: eref,T character(len=40),allocatable :: origin(:) integer :: a,b - logical :: ex + logical :: ex,abbrev,print_placeholder real(wp) :: A0,eav,g,s,ss,beta,elow + integer,parameter :: printlimit = 100 allocate (origin(nall),erel(nall),p(nall)) - eref = grepenergy(comments(1)) + eref = minval(er,1) env%elowest = eref do i = 1,nall - er(i) = grepenergy(comments(i)) + !er(i) = grepenergy(comments(i)) erel(i) = (er(i) - eref) * autokcal - if (env%trackorigin) then - call getorigin(comments(i),origin(i)) - else - origin(i) = '' - end if + !if (env%trackorigin) then + ! call getorigin(comments(i),origin(i)) + !else + origin(i) = '' + !end if end do T = env%tboltz call boltz(nall,T,erel,p) allocate (pg(ng),source=0.0_wp) + allocate (paccu(0:nall),source=0.0_wp) do i = 1,ng a = degen(2,i) b = degen(3,i) do j = a,b pg(i) = pg(i) + p(j) + paccu(j) = paccu(j - 1) + p(j) end do end do + och = ch + abbrev = nall > printlimit + !>-- really long energy list - write (ch,'(7x,a,8x,a,1x,a,2x,a,5x,a,3x,a,5x,a)') 'Erel/kcal','Etot', & - & 'weight/tot','conformer','set','degen','origin' - if (env%entropic .and. ng > 50000) then - write (ch,'(1x,a)') '' - chref = ch - open (newunit=ch,file='crest.conformerlist') + write (och,'(75("*"))') + write (och,'(1x,a8,1x,a8,3(1x,a12),1x,a9,1x,a5)') & + & ' ','ΔE','Etot','weight','conf.weight','conformer','' + write (och,'(a8,1x,a8,3(1x,a12),1x,a9,1x,a5,1x,a6)') & + & 'id ','kcal/mol','hartree','p(i)','p(group)','group','degen','origin' + write (och,'(4x,4("-"),1x,8("-"),3(1x,12("-")),1x,9("-"),1x,5("-"),1x,6("-"))') + if (abbrev) then + open (newunit=och2,file='cregen.full') + write (och2,'(1x,a8,1x,a8,3(1x,a12),1x,a9,1x,a5)') & + & ' ','ΔE','Etot','weight','conf.weight','conformer','' + write (och2,'(a8,1x,a8,3(1x,a12),1x,a9,1x,a5,1x,a6)') & + & 'id ','kcal/mol','hartree','p(i)','p(group)','group','degen','origin' + write (och2,'(4x,4("-"),1x,8("-"),3(1x,12("-")),1x,9("-"),1x,5("-"),1x,6("-"))') + else + call remove('cregen.full') end if + + print_placeholder = .true. k = 0 do i = 1,ng k = k + 1 a = degen(2,i) b = degen(3,i) - write (ch,'(i8,f8.3,1x,3f11.5,2i8,5x,a)') & - & k,erel(a),er(a),p(a),pg(i),i,degen(1,i),trim(origin(a)) - if (.not. env%entropic) then - do j = a + 1,b - k = k + 1 - write (ch,'(i8,f8.3,1x,2f11.5,32x,a)') & - & k,erel(j),er(j),p(j),trim(origin(j)) - end do + if (k <= printlimit .or. k > nall - 10) then + write (och,'(i8,1x,f8.4,1x,f12.6,2(1x,f12.5),1x,i9,1x,i5,a)') & + & a,erel(a),er(a),p(a),pg(i),i,degen(1,i),trim(origin(a)) + else if (print_placeholder) then + print_placeholder = .false. + write (och,'(5x,"...",1x," ...")') + end if + if (abbrev) then + write (och2,'(i8,1x,f8.4,1x,f12.6,2(1x,f12.5),1x,i9,1x,i5,a)') & + & a,erel(a),er(a),p(a),pg(i),i,degen(1,i),trim(origin(a)) end if +! if (.not. env%entropic) then + do j = a + 1,b + k = k + 1 + if (k <= printlimit .or. k > nall - 10) then + write (och,'(i8,1x,f8.4,1x,f12.6,1x,f12.5,1x,a12,1x,a9,1x,a5,1x,a)') & + & k,erel(j),er(j),p(j),'.','.','.',trim(origin(j)) + else if (print_placeholder) then + print_placeholder = .false. + write (och,'(5x,"...",1x," ...")') + end if + if (abbrev) then + write (och2,'(i8,1x,f8.4,1x,f12.6,1x,f12.5,1x,a12,1x,a9,1x,a5,1x,a)') & + & k,erel(j),er(j),p(j),'.','.','.',trim(origin(j)) + end if + end do end do - if (env%entropic .and. ng > 50000) then - close (ch) - ch = chref - end if !>-- file for the '-compare' mode if (env%compareens) then @@ -2971,22 +2596,33 @@ subroutine cregen_pr2(ch,env,nall,comments,ng,degen,er) s = -1000.0d0 * 4.184 * g / T ss = -1000.0d0 * g / T - write (ch,'(''T /K :'', F9.2)') T - write (ch,'(''E lowest :'',f12.5)') eref + write (och,'(75("*"))') + write (och,'("Statistics for *THIS* ensemble:")') + write (och,'(35("-"))') + write (och,'(" Temperature used for populations",t40,":", F9.2," K")') T + write (och,'(" Energy of lowest structure",t40,":",es14.6)') eref !>---- elow printout in between routines if (.not. env%confgo) then write (stdout,'("CREGEN> E lowest :",f12.5)') eref end if + write (och,'(" Ensemble average energy (kcal/mol)",t40,":",F14.8)') eav if (env%QCG) then - write (ch,'(''ensemble average energy (kcal) :'', F14.8)') eav - write (ch,'(''ensemble entropy (cal/mol K) :'',F14.8)') ss - write (ch,'(''ensemble free energy (kcal/mol) : '',F14.8)') g + write (och,'(" Ensemble entropy (cal/mol K)",t40,":",F14.8)') ss else - write (ch,'(''ensemble average energy (kcal) :'', F9.3)') eav - write (ch,'(''ensemble entropy (J/mol K, cal/mol K) :'',2F9.3)') s,ss - write (ch,'(''ensemble free energy (kcal/mol) : '',F8.3)') g + write (och,'(" Ensemble entropy (J/mol K, cal/mol K)",t40,":",2F9.3)') s,ss end if - write (ch,'(''population of lowest in % : '',F8.3)') pg(1) * 100.d0 + write (och,'(" Ensemble free energy (kcal/mol)",t40,":",F14.8)') g + write (och,'(" Population of lowest strucure",t40,":",F9.3," %")') pg(1) * 100.d0 + write (och,'(" Highest population & group",t40,":",F9.3," %, ",i0)') maxval(pg,1) * 100.d0,maxloc(pg,1) + + j = min(10,ng) + i = degen(3,j) + write (och,'(" Accum.population of lowest 10 groups",t40,":",F9.3," %")') paccu(i) * 100.d0 + do i = 1,ng + j = degen(3,i) + if (paccu(j) >= 0.95_wp) exit + end do + write (och,'(" 95% accum.population for groups",t40,":",4x,"1 - ",i0)') i !>-- some ensemble data, entropy and G (including only unique conformers) allocate (egrp(ng),source=0.0_wp) @@ -3005,28 +2641,10 @@ subroutine cregen_pr2(ch,env,nall,comments,ng,degen,er) ss = -1000.0d0 * g / T env%emtd%sapprox = ss !> save for entropy mode - !>-- MF-MD-GC legacy option - if ((env%crestver .eq. 1) .and. (.not. env%confgo)) then - inquire (file='.tmpxtbmodef',exist=ex) - if (ex) then - open (unit=66,file='.tmpxtbmodef') - read (66,*) i - read (66,*) elow - close (66) - else - elow = er(1) - end if - if ((elow - eref) * autokcal .lt. -0.2) then - write (ch,*) '...............................................' - write (ch,*) 'WARNING: new (best) energy less than that from ' - write (ch,*) 'WARNING: preceding Hessian calculation: ' - write (ch,*) 'Improved by ',elow - eref,' Eh or ', (elow - eref) * autokcal,'kcal' - write (ch,*) '...............................................' - call touch('LOWER_FOUND') - end if - end if - deallocate (pg) + write(och,'(75("*"))') + + deallocate (paccu,pg) deallocate (p,erel,origin) return end subroutine cregen_pr2 @@ -3034,45 +2652,39 @@ end subroutine cregen_pr2 subroutine cregen_econf_list(ch,nall,er,ng,degen) use crest_parameters implicit none - integer :: nall - real(wp) :: er(nall) - integer :: ng - integer :: degen(3,ng) - integer :: ch,ich2,i,j + integer,intent(in) :: ch + integer,intent(in) :: nall + real(wp),intent(in) :: er(nall) + integer,intent(in) :: ng + integer,intent(in) :: degen(3,ng) + integer :: ich2,i,j real(wp) :: eref,ewrt - write (ch,*) 'number of unique conformers for further calc ',ng - write (ch,*) 'list of relative energies saved as "crest.energies"' + write (ch,'(a,i0)') 'number of unique conformers for further calculation: ',ng + write (ch,'(a)') 'list of relative energies (kcal/mol) saved as "crest.energies"' open (newunit=ich2,file='crest.energies') - eref = er(1) + eref = minval(er,1) do i = 1,ng j = degen(2,i) ewrt = er(j) - eref ewrt = ewrt * autokcal - write (ich2,'(2x,i0,2x,f12.3)') i,ewrt + write (ich2,'(i10,1x,f12.4,es20.10)') i,ewrt,er(i) end do close (ich2) return end subroutine cregen_econf_list -subroutine cregen_pr3(ch,infile,nall,comments) +subroutine cregen_pr3(ch,infile,nall,er) use crest_parameters use strucrd implicit none - integer :: ch - character(len=*) :: infile - integer :: nall - character(len=*) :: comments(nall) - real(wp),allocatable :: er(:) - real(wp) :: dE + integer,intent(in) :: ch + character(len=*),intent(in) :: infile + integer,intent(in) :: nall + real(wp),intent(in) :: er(nall) + real(wp) :: dE,eref integer :: i - allocate (er(nall)) - - do i = 1,nall - er(i) = grepenergy(comments(i)) - end do - write (ch,*) write (ch,'(a)') '=====================================================' write (ch,'(a)') '============== ordered structure list ===============' @@ -3080,14 +2692,13 @@ subroutine cregen_pr3(ch,infile,nall,comments) write (ch,'(a,a,a)') ' written to file <',trim(infile),'>' write (ch,*) write (ch,'(a10,4x,a15,a25)') 'structure','ΔE(kcal/mol)','Etot(Eh)' + eref = minval(er,1) !write (ch,'('' structure ΔE(kcal/mol) Etot(Eh)'')') do i = 1,nall - dE = (er(i) - er(1)) * autokcal + dE = (er(i) - eref) * autokcal write (ch,'(i10,3x,F15.4,F25.10)') i,dE,er(i) end do write (ch,*) - - deallocate (er) return end subroutine cregen_pr3 @@ -3105,7 +2716,6 @@ subroutine cregen_pr4(ch,infile,nall,group) maxgroup = group(0) write (ch,'(1x,i0,a,i0,a,a,a)') maxgroup,' unique groups for ', & & nall,' structures in file <',trim(infile),'>' - open (newunit=ich,file='.groups') write (ich,'(5x,i0,3x,i0)') nall,maxgroup do i = 1,nall From c9d9de9cad6357f8f825992067b9811d545849af Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 7 Feb 2026 23:01:35 +0100 Subject: [PATCH 165/374] Some prettier printout for CREGEN --- src/sorting/cregen.f90 | 57 +++++++++++++++++++++++++----------------- 1 file changed, 34 insertions(+), 23 deletions(-) diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 55543e97..42509a5b 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -1,7 +1,7 @@ !===============================================================================! ! This file is part of crest. ! -! Copyright (C) 2018-2024 Philipp Pracht +! Copyright (C) 2018-2026 Philipp Pracht ! ! crest is free software: you can redistribute it and/or modify it under ! the terms of the GNU Lesser General Public License as published by @@ -19,23 +19,25 @@ !=========================================================================================! !=========================================================================================! -!> CREGEN is the universal ensemble sorting routine of CREST. -!> This is a rewrite of the original routines since the old ones -!> got a bit messy over time. -!> the quickset variable can be used for some special runtypes: -!> quickset: 2 - do symmetry analysis -!> 3 - switch off equivalency analysis -!> 6,7 - energy sorting only with (7) or without (6) ewin energy cut-off -!> 9 - no sorting, only check groups -!> 12 - no topology check, turn ewin to infty -!> 13 - no topology check, ewin and rmsd checking (msreact settings) +!> CREGEN - also see cregen_interfaces.f90 for importable interfaces !=========================================================================================! !=========================================================================================! subroutine newcregen(env,quickset,infile) -!**************************** +!**************************************************************************************** !* The main CREGEN routine -!**************************** +!* +!* CREGEN is the universal ensemble sorting routine of CREST. +!* This is a rewrite of the original routines since the old ones +!* got a bit messy over time. +!* The quickset variable can be used for some special runtypes: +!* quickset: 2 - do symmetry analysis +!* 3 - switch off equivalency analysis +!* 6,7 - energy sorting only with (7) or without (6) ewin energy cut-off +!* 9 - no sorting, only check groups +!* 12 - no topology check, turn ewin to infty +!* 13 - no topology check, ewin and rmsd checking (msreact settings) +!**************************************************************************************** use crest_parameters use crest_data use crest_restartlog @@ -844,7 +846,7 @@ subroutine cregen_esort(ch,structures,nallout,ewin) real(wp),allocatable :: energies(:) type(coord),allocatable :: tmpstructures(:) integer :: ii,jj - real(wp) :: de,emax + real(wp) :: de,emax,frac nall = size(structures,1) nallout = nall @@ -852,7 +854,7 @@ subroutine cregen_esort(ch,structures,nallout,ewin) !>-- determine cut-off of energies (optional) if (present(ewin)) then - + write (ch,'(75("*"))') allocate (energies(nall)) do ii = 1,nall energies(ii) = structures(ii)%energy @@ -875,8 +877,11 @@ subroutine cregen_esort(ch,structures,nallout,ewin) exit end if end do - write (ch,'(" number of removed by energy",t32,":",3x,i0)') (nall - nallout) - write (ch,'(" number of remaining points",t32,":",3x,i0)') nallout + frac = real(nall-nallout,wp)/real(nall,wp) + write (ch,'(" number of removed by energy",t32,":",3x,i10,a,f6.2,a)') & + & (nall - nallout),' (',frac*100.d0,'%)' + write (ch,'(" number of remaining points",t32,":",3x,i10,a,f6.2,a)') & + & nallout,' (',(1.0d0-frac)*100.d0,'%)' allocate (tmpstructures(nallout)) do ii = 1,nallout @@ -948,7 +953,7 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & type(coord),allocatable,target :: workmols(:) type(canonical_sorter),allocatable :: sorters(:) type(coord),pointer :: ref,mol - real(wp) :: rmsdval,RTHR,ediff,eii,avmom,rsq + real(wp) :: rmsdval,RTHR,ediff,eii,avmom,rsq,frac real(wp),allocatable :: rot(:,:) integer,allocatable :: prune_table(:) real(wp),allocatable :: enuc(:) @@ -1203,8 +1208,14 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & call move_alloc(tmpstructures,structures) if (prlvl > 0) then write (prch,'(a)') ' done.' - write (prch,'(1x,a,t40,a,i10)') "number of doubles removed by rot/RMSD",":",nall - nallnew - write (prch,'(1x,a,t40,a,i10)') "number of unique conformers remaining",":",gcount + frac=real(nall-nallnew,wp)/real(nall,wp) + write (prch,'(1x,a,t40,a,i10,a,f6.2,a)') & + & "number of doubles removed by rot/RMSD",":",nall - nallnew,' (',frac*100.d0,'%)' + write (prch,'(1x,a,t40,a,i10,a,f6.2,a)') & + & "number of unique structures remaining",":",nallnew,' (',(1.0d0-frac)*100.d0,'%)' + frac = real(gcount,wp)/real(nallnew,wp) + write (prch,'(1x,a,t40,a,i10,a,f6.2,a,i0,a)') & + & "number of unique conformers identified",":",gcount,' (',(frac)*100.d0,'% of ',nallnew,')' end if nall = nallnew @@ -1666,7 +1677,7 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) !>--- infer from structure list nat = structures(1)%nat - allocate(at(nat)) + allocate (at(nat)) at(:) = structures(1)%at(:) !>--- variable declarations @@ -2414,6 +2425,7 @@ subroutine cregen_pr1(ch,env,nat,nall,rthr,bthr,pthr,ewin) real(wp) :: rthr,bthr,pthr,ewin logical :: substruc substruc = (nat .ne. env%rednat .and. env%subRMSD) + write (ch,'(75("*"))') write (ch,'(" number of atoms",t35,":",i10)') nat if (substruc) then write (ch,'(" atoms included in RMSD",t35,":",i10)') env%rednat @@ -2641,8 +2653,7 @@ subroutine cregen_pr2(ch,env,nall,ng,degen,er) ss = -1000.0d0 * g / T env%emtd%sapprox = ss !> save for entropy mode - - write(och,'(75("*"))') + write (och,'(75("*"))') deallocate (paccu,pg) deallocate (p,erel,origin) From 30f446afa9953b9b2b8ce1de40ef3259534787ee Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 8 Feb 2026 00:07:08 +0100 Subject: [PATCH 166/374] Enable internal structure list input for newcregen --- src/algos/sorting.f90 | 6 +-- src/sorting/cregen.f90 | 81 +++++++++++++++++++------------ src/sorting/cregen_interfaces.f90 | 17 ++++++- 3 files changed, 68 insertions(+), 36 deletions(-) diff --git a/src/algos/sorting.f90 b/src/algos/sorting.f90 index 9e05cbd1..d928eb47 100644 --- a/src/algos/sorting.f90 +++ b/src/algos/sorting.f90 @@ -93,13 +93,13 @@ subroutine crest_sort(env,tim) case ('cregen') !>--- the original CREGEN procedure (fallback, needs nicer implementations) - if (allocated(structures)) deallocate (structures) - call newcregen(env,infile=env%ensemblename) + env%confgo = .true. + call newcregen(env,structurelist=structures) call catdel('cregen.out.tmp') case default !>--- all unique pairs of the ensemble (only suitable for small ensembles) - call cregen_irmsd_all(nall,structures,printlvl=2,iinversion=env%iinversion) + call cregen_irmsd_sort(env,nall,structures,groups,allcanon=.true.,printlvl=2) end select !========================================================================================! diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 42509a5b..4d258c45 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -23,7 +23,7 @@ !=========================================================================================! !=========================================================================================! -subroutine newcregen(env,quickset,infile) +subroutine newcregen(env,quickset,infile,structurelist) !**************************************************************************************** !* The main CREGEN routine !* @@ -48,25 +48,21 @@ subroutine newcregen(env,quickset,infile) type(systemdata),intent(inout) :: env !> MAIN STORAGE OS SYSTEM DATA integer,intent(in),optional :: quickset !> quick access to predefined CREGEN modes character(len=*),intent(in),optional :: infile + type(coord),allocatable,intent(inout),optional :: structurelist(:) !> LOCAL integer :: simpleset - character(len=258) :: fname !> input file - character(len=258) :: oname !> sorted output file - character(len=258) :: cname !> unique structure file + character(len=:),allocatable :: fname !> input file + character(len=:),allocatable :: oname !> sorted output file + character(len=:),allocatable :: cname !> unique structure file !>--- ensemble arguments integer :: nat !> number of atoms integer :: nall !> number of structures - integer,allocatable :: at(:) !> atom numbers - real(wp),allocatable :: xyz(:,:,:) !> Cartesian coordinates character(len=128),allocatable :: comments(:) - character(len=128),allocatable :: comref(:) real(wp),allocatable :: er(:) !> energies type(coord),allocatable :: structures(:) !> a list of structures using the coord type - type(coord),allocatable :: references(:) !> the reference structure list !>--- dummy ensemble arguments integer :: nallref integer :: nallnew - real(wp),allocatable :: xyzref(:,:,:) !>--- sorting arguments integer,allocatable :: gref(:),group(:) integer :: ng @@ -78,6 +74,7 @@ subroutine newcregen(env,quickset,infile) real(wp) :: T,couthr !>--- boolean data + logical :: ensembleinput = .false. logical :: checkbroken logical :: topocheck logical :: checkez @@ -108,6 +105,11 @@ subroutine newcregen(env,quickset,infile) simpleset = 0 end if +!>-- was an actual list of structures (rather than a file name) provided? + if (present(structurelist)) then + if (size(structurelist,1) > 0) ensembleinput = .true. + end if + !>-- determine filenames and output channel if (present(infile)) then fname = trim(infile) @@ -116,7 +118,7 @@ subroutine newcregen(env,quickset,infile) fname = trim(env%ensemblename) userinput = .false. end if - call cregen_files(env,fname,oname,cname,simpleset,userinput,prch) + call cregen_files(env,fname,oname,cname,simpleset,userinput,ensembleinput,prch) !>-- determine which printouts are required call cregen_prout(env,simpleset,pr1,pr2,pr3,pr4) @@ -137,13 +139,22 @@ subroutine newcregen(env,quickset,infile) !=====================================================================! !>--- read in the ensemble parameters - call rdensembleparam(fname,nat,nallref) + if (.not. ensembleinput) then + call rdensembleparam(fname,nat,nallref) + else + nat = structurelist(1)%nat + nallref = size(structurelist,1) + end if !>--- print a summary about the ensemble and thresholds if (pr1) call cregen_pr1(prch,env,nat,nallref,rthr,bthr,pthr,ewin) !>--- allocate space and read in the ensemble - call rdensemble(fname,nallref,structures) + if (.not. ensembleinput) then + call rdensemble(fname,nallref,structures) + else + call move_alloc(structurelist,structures) + end if !>--- track ensemble for restart !call trackensemble(fname,nat,nallref,at,xyz,comments) @@ -251,6 +262,11 @@ subroutine newcregen(env,quickset,infile) call cregen_EQUAL(prch,nall,structures,group,athr,.not. env%entropic) end if +!>-- in case we had a structurelist given, move the (sorted) memory space back there + if (ensembleinput) then + call move_alloc(structures,structurelist) + end if + !>--- deallocate data if (prch .ne. stdout) then close (prch) @@ -267,7 +283,7 @@ end subroutine newcregen !=========================================================================================! !=========================================================================================! -subroutine cregen_files(env,fname,oname,cname,simpleset,userinput,iounit) +subroutine cregen_files(env,fname,oname,cname,simpleset,userinput,ensembleinput,iounit) !************************************************************* !* subroutine cregen_files !* handle all settings regarding input and output file names @@ -278,12 +294,13 @@ subroutine cregen_files(env,fname,oname,cname,simpleset,userinput,iounit) use iomod use utilities implicit none - type(systemdata) :: env !> MAIN STORAGE OS SYSTEM DATA - character(len=*) :: fname !> name of the ensemble to be read - character(len=*) :: oname !> output ensemble name (including rotamers) - character(len=*) :: cname !> output ensemble name (only conformers) + type(systemdata),intent(inout) :: env !> MAIN STORAGE OS SYSTEM DATA + character(len=:),allocatable,intent(inout) :: fname !> name of the ensemble to be read + character(len=:),allocatable,intent(inout) :: oname !> output ensemble name (including rotamers) + character(len=:),allocatable,intent(inout) :: cname !> output ensemble name (only conformers) integer,intent(in) :: simpleset logical,intent(in) :: userinput !> was an input file given via the optional subroutine arg? + logical,intent(in) :: ensembleinput !> was an structure list provided? integer,intent(out) :: iounit character(len=:),allocatable :: outfile logical :: ex @@ -308,12 +325,12 @@ subroutine cregen_files(env,fname,oname,cname,simpleset,userinput,iounit) end if if ((env%confgo .and. (index(trim(fname),'none selected') .eq. 0)) & - & .OR. userinput) then - if (.not. userinput) then + & .OR. userinput .OR. ensembleinput) then + if (.not. userinput .and. .not. ensembleinput) then fname = trim(env%ensemblename) end if - oname = trim(fname)//'.sorted' cname = 'crest_ensemble.xyz' + oname = trim(fname)//'.sorted' if (env%fullcre) then env%ensemblename = trim(oname) end if @@ -336,17 +353,17 @@ subroutine cregen_files(env,fname,oname,cname,simpleset,userinput,iounit) cname = trim(fname)//'.unique' end if - write (iounit,*) 'input file name : ',trim(fname) + write (iounit,'(1x,a,a)') 'input file name : ',trim(fname) select case (simpleset) case (9) continue case default - write (iounit,*) 'output file name : ',trim(oname) + write (iounit,'(1x,a,a)') 'output file name : ',trim(oname) end select inquire (file=fname,exist=ex) - if (.not. ex) then - write (0,*) 'Warning, file ',trim(fname),' does not exist!' + if (.not. ex .and. .not. ensembleinput) then + write (stdout,'(a)') 'CREGEN> **WARNING** file ',trim(fname),' does not exist!' error stop end if @@ -877,11 +894,11 @@ subroutine cregen_esort(ch,structures,nallout,ewin) exit end if end do - frac = real(nall-nallout,wp)/real(nall,wp) + frac = real(nall - nallout,wp) / real(nall,wp) write (ch,'(" number of removed by energy",t32,":",3x,i10,a,f6.2,a)') & - & (nall - nallout),' (',frac*100.d0,'%)' + & (nall - nallout),' (',frac * 100.d0,'%)' write (ch,'(" number of remaining points",t32,":",3x,i10,a,f6.2,a)') & - & nallout,' (',(1.0d0-frac)*100.d0,'%)' + & nallout,' (', (1.0d0 - frac) * 100.d0,'%)' allocate (tmpstructures(nallout)) do ii = 1,nallout @@ -1208,14 +1225,14 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & call move_alloc(tmpstructures,structures) if (prlvl > 0) then write (prch,'(a)') ' done.' - frac=real(nall-nallnew,wp)/real(nall,wp) + frac = real(nall - nallnew,wp) / real(nall,wp) write (prch,'(1x,a,t40,a,i10,a,f6.2,a)') & - & "number of doubles removed by rot/RMSD",":",nall - nallnew,' (',frac*100.d0,'%)' + & "number of doubles removed by rot/RMSD",":",nall - nallnew,' (',frac * 100.d0,'%)' write (prch,'(1x,a,t40,a,i10,a,f6.2,a)') & - & "number of unique structures remaining",":",nallnew,' (',(1.0d0-frac)*100.d0,'%)' - frac = real(gcount,wp)/real(nallnew,wp) + & "number of unique structures remaining",":",nallnew,' (', (1.0d0 - frac) * 100.d0,'%)' + frac = real(gcount,wp) / real(nallnew,wp) write (prch,'(1x,a,t40,a,i10,a,f6.2,a,i0,a)') & - & "number of unique conformers identified",":",gcount,' (',(frac)*100.d0,'% of ',nallnew,')' + & "number of unique conformers identified",":",gcount,' (', (frac) * 100.d0,'% of ',nallnew,')' end if nall = nallnew diff --git a/src/sorting/cregen_interfaces.f90 b/src/sorting/cregen_interfaces.f90 index deae7857..5072e6b8 100644 --- a/src/sorting/cregen_interfaces.f90 +++ b/src/sorting/cregen_interfaces.f90 @@ -13,7 +13,7 @@ module cregen_interface use unionize_module implicit none interface - subroutine newcregen(env,quickset,infile) + subroutine newcregen(env,quickset,infile,structurelist) use crest_parameters use crest_data use crest_restartlog @@ -22,6 +22,7 @@ subroutine newcregen(env,quickset,infile) type(systemdata),intent(inout) :: env integer,intent(in),optional :: quickset character(len=*),intent(in),optional :: infile + type(coord),allocatable,intent(inout),optional :: structurelist(:) end subroutine newcregen subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) @@ -64,6 +65,20 @@ module cregen_subroutines !************************************* implicit none interface + + subroutine cregen_files(env,fname,oname,cname,simpleset,userinput,ensembleinput,iounit) + use crest_data + implicit none + type(systemdata),intent(inout) :: env + character(len=:),allocatable,intent(inout) :: fname + character(len=:),allocatable,intent(inout) :: oname + character(len=:),allocatable,intent(inout) :: cname + integer,intent(in) :: simpleset + logical,intent(in) :: userinput + logical,intent(in) :: ensembleinput + integer,intent(out) :: iounit + end subroutine cregen_files + subroutine cregen_discardbroken(ch,env,topocheck,structures,newnall) use crest_data use strucrd From e7cfae2327925214db2be9d3ca0c6f78612ef274 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 8 Feb 2026 22:16:27 +0100 Subject: [PATCH 167/374] alkylize rotamerfile for reconstruction --- src/algos/queueing.f90 | 60 +++++++++++++++++++++++++++++++++++------- src/crest_main.f90 | 3 +++ src/iomod.F90 | 9 +++++++ src/sorting/cregen.f90 | 2 ++ src/utilmod.f90 | 14 +++++++--- 5 files changed, 75 insertions(+), 13 deletions(-) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 1e46ef2c..ea2b60cf 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -102,9 +102,9 @@ subroutine crest_queue_setup(env,iterate) call heap%map_origins_for_layer(ii) !> determening charges for fragments call sum_charges_layer(env,heap,ii,qat,lq) - do jj=1,layer(ii)%nnodes + do jj = 1,layer(ii)%nnodes layer(ii)%node(jj)%chrg = lq(jj) - enddo + end do end do call heap%setup_queue() @@ -217,11 +217,11 @@ subroutine sum_charges_layer(env,heap,lay,qat,lq) if (env%chrg == 0) return !> return for neutral systems (may need some implementation for zwitter ions) - write(stdout,'(a,i0,a)') 'Calculating charges for fragments in layer ',lay,' ...' + write (stdout,'(a,i0,a)') 'Calculating charges for fragments in layer ',lay,' ...' sign = 1 if (env%chrg < 0) sign = -1 chrgs = abs(env%chrg)+1 - allocate (qtmp(chrgs), source=0.0_wp) + allocate (qtmp(chrgs),source=0.0_wp) allocate (ichrgs(chrgs),source=0) cc2 = 0 do cc = 0,env%chrg,sign @@ -260,8 +260,8 @@ subroutine sum_charges_layer(env,heap,lay,qat,lq) !write (*,*) 'charge MAEs on frag:',qtmp !write (*,*) 'selected charge:',lq(ii) end do - write(stdout,'(2x,a)',advance='no') 'determined charges:' - write(stdout,*) lq + write (stdout,'(2x,a)',advance='no') 'determined charges:' + write (stdout,*) lq end subroutine sum_charges_layer end subroutine crest_queue_setup @@ -313,7 +313,7 @@ subroutine crest_queue_iter(env,iterate) !> selecting output file depending on runtype select case (env%crestver) case (crest_imtd,crest_imtd2) - queue%file = 'crest_conformers.xyz' + queue%file = 'crest_ensemble.xyz' case (crest_optimize) queue%file = 'crestopt.xyz' case (crest_moldyn) @@ -330,12 +330,11 @@ subroutine crest_queue_iter(env,iterate) !> for constraints we must be careful and map them to the new order call update_constraints_queue(heap,jj,kk,env%calc,queue%calc) - mol = env%splitheap%layer(jj)%node(kk) call env%ref%load(mol) call mol%write('coord') call queue%calc%set_charge(mol%chrg) !> the nodes may have different charges saved - call queue%calc%info(stdout) + call queue%calc%info(stdout) if (allocated(env%ref%wbo)) deallocate (env%ref%wbo) env%nat = mol%nat @@ -400,6 +399,49 @@ subroutine update_constraints_queue(heap,layer,node,refcalc,newcalc) end subroutine update_constraints_queue end subroutine crest_queue_iter +subroutine crest_queue_iter_resort(env,iterate) + use crest_parameters + use crest_data + use iomod + use cregen_interface + implicit none + type(systemdata),intent(inout) :: env + logical,intent(in) :: iterate + + character(len=:),allocatable :: file + logical :: heavytmp,confgotmp,ex + + if (.not. (allocated(env%splitqueue).and.env%splitheap%nqueue > 0)) return + + select case (env%crestver) + case (crest_imtd,crest_imtd2) + + write (stdout,'(/,75("*"))') + write (stdout,'(a,i0)') "*** CREGEN heavy-atom resorting for QUEUE iteration ",env%queue_iter + write (stdout,'(75("*"))') + ex = .false. + if (file_exists(crefile//'.xyz')) then + ex = .true. + file = crefile//'.xyz' + else if (file_exists(conformerfile)) then + ex = .true. + file = conformerfile + end if + heavytmp = env%heavyrmsd + confgotmp = env%confgo + env%heavyrmsd = .true. + env%confgo = .true. + call newcregen(env,infile=file) + env%heavyrmsd = heavytmp + env%confgo = confgotmp + if(file_exists(file//'.sorted'))then + call rename(file//'.sorted',ensemblefile) + endif + case default + end select + +end subroutine crest_queue_iter_resort + !=============================================================================! !#############################################################################! !=============================================================================! diff --git a/src/crest_main.f90 b/src/crest_main.f90 index aa3faa9b..30069a69 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -320,6 +320,9 @@ program CREST continue end select + !> additional processing + call crest_queue_iter_resort(env,iterate) + end do ITERATOR env%calc => calc_origin diff --git a/src/iomod.F90 b/src/iomod.F90 index e2bddd67..31d1c4d8 100644 --- a/src/iomod.F90 +++ b/src/iomod.F90 @@ -762,6 +762,15 @@ function filechecker(fin,fout) result(have) return end function filechecker + function file_exists(fin) result(have) + implicit none + logical :: have + character(len=*),intent(in) :: fin + have = .false. + inquire (file=fin,exist=have) + return + end function file_exists + !=========================================================================================! !=========================================================================================! !=========================================================================================! diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 4d258c45..a9728662 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -335,6 +335,8 @@ subroutine cregen_files(env,fname,oname,cname,simpleset,userinput,ensembleinput, env%ensemblename = trim(oname) end if else !> internal mode for conformational search + fname = repeat(' ',256) !> need initialization because checkname_xyz + oname = repeat(' ',256) !> can't handle allocatable names call checkname_xyz(crefile,fname,oname) cname = conformerfile end if diff --git a/src/utilmod.f90 b/src/utilmod.f90 index a33251b1..f38d0d06 100644 --- a/src/utilmod.f90 +++ b/src/utilmod.f90 @@ -349,13 +349,18 @@ subroutine checkname_xyz(base,fname,checkname) !* _.xyz as !* and _.xyz as !************************************************ - character(len=*) :: base,fname,checkname + character(len=*),intent(in) :: base + character(len=*),intent(inout) :: fname,checkname + character(len=256) :: atmp,btmp integer :: i,j logical :: ex i = 0 + !write(*,*) trim(fname) + !write(*,*) trim(base) do - write (checkname,'(a,''_'',i0,''.xyz'')') trim(base),i - inquire (file=trim(checkname),exist=ex) + write (atmp,'(a,''_'',i0,''.xyz'')') trim(base),i + inquire (file=trim(atmp),exist=ex) + checkname = trim(atmp) if (ex) then i = i+1 else @@ -363,7 +368,8 @@ subroutine checkname_xyz(base,fname,checkname) end if end do j = max(0,i-1) - write (fname,'(a,''_'',i0,''.xyz'')') trim(base),j + write (btmp,'(a,''_'',i0,''.xyz'')') trim(base),j + fname = trim(btmp) end subroutine checkname_xyz !========================================================================================! From 9149222adab85b6cf75bf40f95dec5c25482955a Mon Sep 17 00:00:00 2001 From: LukasRindt Date: Mon, 9 Feb 2026 09:41:23 +0100 Subject: [PATCH 168/374] deform_opt_hess added --- src/algos/CMakeLists.txt | 1 + src/algos/deform_opt_hess.f90 | 38 +++++++++++++++++++++++++++++++++++ src/algos/optimization.f90 | 10 +++++++++ src/basinhopping/takestep.f90 | 20 +++++++++++++++++- 4 files changed, 68 insertions(+), 1 deletion(-) create mode 100644 src/algos/deform_opt_hess.f90 diff --git a/src/algos/CMakeLists.txt b/src/algos/CMakeLists.txt index 40277f7f..121f23bd 100644 --- a/src/algos/CMakeLists.txt +++ b/src/algos/CMakeLists.txt @@ -35,6 +35,7 @@ list(APPEND srcs "${dir}/search_conformers.f90" "${dir}/search_entropy.f90" "${dir}/parallel.f90" + "${dir}/deform_opt_hess.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/algos/deform_opt_hess.f90 b/src/algos/deform_opt_hess.f90 new file mode 100644 index 00000000..80107942 --- /dev/null +++ b/src/algos/deform_opt_hess.f90 @@ -0,0 +1,38 @@ +subroutine deform_opt_hess(calc,mol) + use crest_calculator + use strucrd + use irmsd_module + use bh_step_module + use crest_parameters + use optimize_module + implicit none + type(calcdata),intent(inout) :: calc + type(coord),intent(in) :: mol + type(coord) :: molnew,mol_reopt + real(wp) :: energy,stepsize,rmsdval + real(wp) :: grad(3,mol%nat) + logical :: pr,wr + integer :: io + + if (allocated(calc%chess)) deallocate(calc%chess) + + !allocate (calc%chess) + !call calc%chess%alloc(mol%nat,calc%hu_steps,calc%hguess,calc%initialize_hr_type, calc%hr_hu_type) !Maybe in future just reset the cash here, or if this works we only call this here + + molnew=mol + + stepsize = 0.25_wp + + call take_fixed_stepsize_cart(molnew,stepsize,calc) + + pr = .true. + wr = .true. + + call optimize_geometry(molnew,mol_reopt,calc,energy,grad,pr,wr,io) + + rmsdval = rmsd(mol,mol_reopt) + + write(stdout,*) 'VALUE OF RMSD FOR REOPTIMISED STRUCTURE',rmsdval + + +end subroutine deform_opt_hess \ No newline at end of file diff --git a/src/algos/optimization.f90 b/src/algos/optimization.f90 index 161804fd..5a5ffbc8 100644 --- a/src/algos/optimization.f90 +++ b/src/algos/optimization.f90 @@ -123,6 +123,16 @@ subroutine crest_optimization(env,tim) endif !========================================================================================! + +!========================================================================================! +!>--- append numerical hessian calculation + if( io == 0) then !.and. calc%do_HR )then + call env%ref%load(molnew) !> load the optimized geometry + call deform_opt_hess(calc,molnew) !> run the hessian reconstruction + endif + +!========================================================================================! + return end subroutine crest_optimization diff --git a/src/basinhopping/takestep.f90 b/src/basinhopping/takestep.f90 index 16671f5f..2bd84773 100644 --- a/src/basinhopping/takestep.f90 +++ b/src/basinhopping/takestep.f90 @@ -28,7 +28,7 @@ module bh_step_module logical,parameter :: debug = .true. ! logical,parameter :: debug = .false. - public :: takestep,steptypestr + public :: takestep,steptypestr,takestep_cart,take_fixed_stepsize_cart !========================================================================================! !========================================================================================! @@ -92,6 +92,24 @@ subroutine takestep_cart(newmol,stepsize,calc) end do end subroutine takestep_cart + subroutine take_fixed_stepsize_cart(newmol,stepsize,calc) + implicit none + type(coord),intent(inout) :: newmol + real(wp),intent(in) :: stepsize + type(calcdata),intent(inout) :: calc + real(wp) :: r(3),len + integer :: i + do i = 1,newmol%nat + if (calc%nfreeze > 0) then + if (calc%freezelist(i)) cycle + end if + call random_number(r) + r(:) = (r(:)-0.5_wp)*2.0_wp + len=norm2(r) + newmol%xyz(:,i) = newmol%xyz(:,i)+r(:)*stepsize/len + end do + end subroutine take_fixed_stepsize_cart + !=========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Date: Tue, 10 Feb 2026 17:12:48 +0100 Subject: [PATCH 169/374] double track fixed and deform opt hess changes (still buggy) --- src/algos/deform_opt_hess.f90 | 54 +++++++++++++++++++++++--- src/algos/optimization.f90 | 4 +- src/calculator/calc_type.f90 | 2 + src/calculator/calculator.F90 | 7 +++- src/calculator/hessian_reconstruct.f90 | 14 +++++-- src/optimize/optimize_module.f90 | 8 ++-- src/parsing/parse_calcdata.f90 | 6 +++ 7 files changed, 79 insertions(+), 16 deletions(-) diff --git a/src/algos/deform_opt_hess.f90 b/src/algos/deform_opt_hess.f90 index 80107942..0b9f1dcd 100644 --- a/src/algos/deform_opt_hess.f90 +++ b/src/algos/deform_opt_hess.f90 @@ -5,23 +5,35 @@ subroutine deform_opt_hess(calc,mol) use bh_step_module use crest_parameters use optimize_module + use thermochem_module + use hr_utils + use optimize_maths implicit none - type(calcdata),intent(inout) :: calc - type(coord),intent(in) :: mol + type(calcdata) :: calc + type(coord) :: mol type(coord) :: molnew,mol_reopt real(wp) :: energy,stepsize,rmsdval real(wp) :: grad(3,mol%nat) logical :: pr,wr - integer :: io + integer :: io, nat3,idx + + real(wp) :: etot + real(wp), allocatable :: h_init(:,:) if (allocated(calc%chess)) deallocate(calc%chess) !allocate (calc%chess) !call calc%chess%alloc(mol%nat,calc%hu_steps,calc%hguess,calc%initialize_hr_type, calc%hr_hu_type) !Maybe in future just reset the cash here, or if this works we only call this here - molnew=mol + nat3 = 3*mol%nat + molnew%nat = mol%nat + molnew%at = mol%at + molnew%xyz = mol%xyz + + allocate(h_init(nat3,nat3)) + + stepsize = calc%doh_stepsize - stepsize = 0.25_wp call take_fixed_stepsize_cart(molnew,stepsize,calc) @@ -30,9 +42,41 @@ subroutine deform_opt_hess(calc,mol) call optimize_geometry(molnew,mol_reopt,calc,energy,grad,pr,wr,io) + pr = .true. + wr = .true. + rmsdval = rmsd(mol,mol_reopt) write(stdout,*) 'VALUE OF RMSD FOR REOPTIMISED STRUCTURE',rmsdval + if (rmsdval .le. 0.1_wp) then + + idx = minloc(calc%chess%order,1) + if (minval(calc%chess%order) .eq. 0) idx = 1 + + call initialize_hessian(calc,calc%chess%initialize_type,calc%chess%coords(idx,:,:),mol_reopt%nat,mol_reopt%at,calc%chess%hess(:),calc%chess%hguess,pr) !> This hguess is set through the hguess variable of the optimizer and needs to be hardcoded/set explicitly before initialization for benchmarking!! + call dhtosq(nat3,H_init,calc%chess%hess) !> maybe this should all be inside the construct bfgs function later? -> cannot due to circular import!!! + write(stdout,*) !> Hessian type (gfnff,mod,identity) is set through input file and is already encoded into the calc object + write(stdout,*)"THERMO FROM INITIALIZED HESSIAN:" + write(stdout,*) + call calc_thermo_from_hess(molnew,H_init,pr, & + & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & + & calc%ht,calc%gt,calc%stot,etot) + + call calc%chess%construct_hessian() + + write (stdout,*) + write (stdout,*) "THERMO FROM RECONSTRUCTED HESSIAN:" + write (stdout,*) + + call calc_thermo_from_hess(molnew,calc%chess%H(:,:),pr, & + & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & + & calc%ht,calc%gt,calc%stot,etot) + + else + write(stdout,*) "Reoptimised Geometry not equal to initial structure" + + endif + end subroutine deform_opt_hess \ No newline at end of file diff --git a/src/algos/optimization.f90 b/src/algos/optimization.f90 index 5a5ffbc8..cd9ec4b7 100644 --- a/src/algos/optimization.f90 +++ b/src/algos/optimization.f90 @@ -125,8 +125,8 @@ subroutine crest_optimization(env,tim) !========================================================================================! !========================================================================================! -!>--- append numerical hessian calculation - if( io == 0) then !.and. calc%do_HR )then +!>--- append deform opt hessian calculation + if( io == 0 .and. calc%deform_opt_hess) then !.and. calc%do_HR )then call env%ref%load(molnew) !> load the optimized geometry call deform_opt_hess(calc,molnew) !> run the hessian reconstruction endif diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 8e7f49fd..f5dbcc71 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -283,6 +283,8 @@ module calc_type integer :: initialize_hr_type !> case defining initialization integer :: mh_type = 0 integer :: hr_hu_type = 0 + logical :: deform_opt_hess = .false. + real(wp) :: doh_stepsize = 0.10_wp !>stepsize for the deformation/reoptimization hessian generation !>--- Parameters for smooth function within optimizer real(wp) :: L = 1.50_wp diff --git a/src/calculator/calculator.F90 b/src/calculator/calculator.F90 index 819a3f73..1c5dbdc5 100644 --- a/src/calculator/calculator.F90 +++ b/src/calculator/calculator.F90 @@ -301,8 +301,9 @@ subroutine engrad_mol(mol,calc,energy,gradient,iostatus) !>--- Hessian Reconstruct !********************************************** - if (calc%do_HR .and. allocated(calc%chess)) then + if (calc%do_HR .and. allocated(calc%chess) .and. calc%chess%track_step) then call calc%chess%update(gradient,energy,mol%xyz) + write(stdout,*) "HESSIAN CASH UPDATED" end if return @@ -551,6 +552,8 @@ subroutine numhess1(nat,at,xyz,calc,hess,io) allocate (gradr(3,mol%nat),source=0.0_wp) !dummy allocate (gradl(3,mol%nat),source=0.0_wp) !dummy + if (allocated(calc%chess)) calc%chess%track_step = .false. + do i = 1,mol%nat do j = 1,3 ii = (i-1)*3+j @@ -585,6 +588,8 @@ subroutine numhess1(nat,at,xyz,calc,hess,io) call engrad(mol,calc,el,gradl,io) !>- to get the gradient of the non-displaced structure + if (allocated(calc%chess)) calc%chess%track_step = .true. + deallocate (gradl,gradr) call mol%deallocate() return diff --git a/src/calculator/hessian_reconstruct.f90 b/src/calculator/hessian_reconstruct.f90 index 7eb89015..34a7f1b9 100644 --- a/src/calculator/hessian_reconstruct.f90 +++ b/src/calculator/hessian_reconstruct.f90 @@ -85,9 +85,10 @@ subroutine construct_hessian(self) integer :: i,j,k,nat3 real(wp),allocatable :: tmp(:),tmp_coords(:,:),tmp_grads(:,:),dx(:) real(wp) :: gnorm - integer :: unit,iter,made_iters + integer :: unit,iter,made_iters,update_iteration nat3 = 3*self%natm + update_iteration = 0 allocate (tmp_coords(self%steps,nat3)) allocate (tmp_grads(self%steps,nat3)) @@ -123,10 +124,10 @@ subroutine construct_hessian(self) j = minloc(tmp,1) !> This only happens if made_iters>steps if (j == 1) then !> => Not affected if too many steps requested dx = tmp_coords(j,:)-tmp_coords(self%steps,:) - call update_hessian(nat3,gnorm,tmp_grads(j,:),tmp_grads(self%steps,:),dx,self%hess(:),self%hu_type) + call update_hessian(nat3,gnorm,tmp_grads(j,:),tmp_grads(self%steps,:),dx,self%hess(:),self%hu_type,update_iteration) else dx = tmp_coords(j,:)-tmp_coords(j-1,:) - call update_hessian(nat3,gnorm,tmp_grads(j,:),tmp_grads(j-1,:),dx,self%hess(:),self%hu_type) + call update_hessian(nat3,gnorm,tmp_grads(j,:),tmp_grads(j-1,:),dx,self%hess(:),self%hu_type,update_iteration) end if tmp(j) = HUGE(tmp(j)) end if @@ -136,7 +137,7 @@ subroutine construct_hessian(self) end subroutine construct_hessian - subroutine update_hessian(nat3,gnorm,grd1,gold,dx,hess,hu_type) + subroutine update_hessian(nat3,gnorm,grd1,gold,dx,hess,hu_type,iter) !============================================== !Wrapper for hessian update scheme selection !============================================== @@ -145,7 +146,12 @@ subroutine update_hessian(nat3,gnorm,grd1,gold,dx,hess,hu_type) real(wp),intent(in) :: dx(:), grd1(:),gold(:) real(wp),intent(in) :: gnorm real(wp),intent(inout) :: hess(:) + integer,intent(inout) :: iter integer,intent(in) :: hu_type + + iter = iter +1 + + write(stdout,*) "Hessian updated", iter select case (hu_type) case (0) diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index f1692c7c..3fffdbdb 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -84,16 +84,16 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) end if !> Check if Hessian Reconstruct is called and initialize the type - if (calc%do_HR) then + if (calc%do_HR .or. calc%deform_opt_hess) then allocate (calc%chess) allocate (H_init(nat3,nat3)) call calc%chess%alloc(mol%nat,calc%hu_steps,calc%hguess,calc%initialize_hr_type, calc%hr_hu_type) end if !> initial singlepoint - if (calc%do_HR) calc%chess%track_step = .false. !this is not tracked to avoid duplicate + if (calc%do_HR .or. calc%deform_opt_hess) calc%chess%track_step = .false. !this is not tracked to avoid duplicate call engrad(molnew,calc,etot,grd,iostatus) - if (calc%do_HR) calc%chess%track_step = .true. + if (calc%do_HR .or. calc%deform_opt_hess) calc%chess%track_step = .true. !> optimization select case (calc%opt_engine) case (0) @@ -117,7 +117,7 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) end select molnew%energy = etot - if (calc%do_HR .and. iostatus .eq. 0) then !> Hessian reconstruction and post-processing happen here, only do it if geometry relaxation successful + if (calc%do_HR .and. iostatus .eq. 0) then !> Hessian reconstruction and post-processing happen here, only do it if geometry relaxation successful if (calc%full_HR) then write (stdout,*) diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 61bc897f..98eaf965 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -536,6 +536,9 @@ subroutine parse_calc_auto(env,calc,kv,rd) case('scaling') calc%scaling = kv%value_f + case('doh_stepsize') + calc%doh_stepsize = kv%value_f + !>--- integers case ('maxcycle') calc%maxcycle = kv%value_i !> optimization max cycles @@ -689,6 +692,9 @@ subroutine parse_calc_auto(env,calc,kv,rd) case ('full_chess') !> Do Hessian Reconstruct with all optimization steps calc%full_HR = kv%value_b + + case ('deform_opt_hess') + calc%deform_opt_hess = kv%value_b case default rd = .false. From bc853a2d86f48cc77820bf7201ec7b5aab0b725b Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 10 Feb 2026 23:18:53 +0100 Subject: [PATCH 170/374] smarter pre-sorting in queue reconstruction --- src/algos/queueing.f90 | 87 ++++++++++--- src/classes.f90 | 2 +- src/sorting/irmsd_module.f90 | 234 +++++++++++++++++++++++++---------- 3 files changed, 244 insertions(+), 79 deletions(-) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index ea2b60cf..3c0ff827 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -418,7 +418,7 @@ subroutine crest_queue_iter_resort(env,iterate) write (stdout,'(/,75("*"))') write (stdout,'(a,i0)') "*** CREGEN heavy-atom resorting for QUEUE iteration ",env%queue_iter - write (stdout,'(75("*"))') + write (stdout,'(75("*"))') ex = .false. if (file_exists(crefile//'.xyz')) then ex = .true. @@ -434,9 +434,9 @@ subroutine crest_queue_iter_resort(env,iterate) call newcregen(env,infile=file) env%heavyrmsd = heavytmp env%confgo = confgotmp - if(file_exists(file//'.sorted'))then + if (file_exists(file//'.sorted')) then call rename(file//'.sorted',ensemblefile) - endif + end if case default end select @@ -529,6 +529,7 @@ subroutine crest_queue_reconstruct(env,tim) contains recursive subroutine recusrive_construct(env,heap,targetlayer) + use irmsd_module,only:irmsd,rmsd,rmsd_cache,rmsd_core_cache implicit none type(systemdata),intent(inout) :: env type(construct_heap),intent(inout) :: heap @@ -541,8 +542,12 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) type(coord),allocatable :: structures_s(:) type(coord) :: mol integer :: nall_b,nall_s,id_b,id_s,nallsq,sss - integer :: iliml,ilimu,jliml,jlimu - logical :: ex,clash + integer :: iliml,ilimu,jliml,jlimu,rr,io + integer :: duplicates + logical :: ex,clash,duplicate + real(wp) :: RTHR,rmsval,ETHR,deltaE + type(rmsd_cache) :: rcache + type(rmsd_core_cache) :: ccache character(len=*),parameter :: subdir_tmp = 'crest_queue_' character(len=:),allocatable :: subdirfile @@ -623,13 +628,23 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) write (stdout,*) write (stdout,'(a,i0)') 'Reconstructing layer : ',targetlayer - write (stdout,'(2x,a,i0)') 'Base structures : ',nall_b - write (stdout,'(2x,a,i0)') 'Side chain structures : ',nall_s - write (stdout,'(2x,a,i0)') 'Max. combinations : ',nall_b*nall_s + write (stdout,'(2x,a,i0)') 'Base structures : ',nall_b + write (stdout,'(2x,a,i0)') 'Side chain structures : ',nall_s + write (stdout,'(2x,a,i0)') 'Max. combinations : ',nall_b*nall_s + write (stdout,'(2x,a,f7.5,a)') 'Similarity threshold : ',env%rthr,' Å' + write (stdout,'(2x,a,f7.5,a)') 'ΔE threshold (ETHR) : ',env%ethr,' kcal/mol' layer%nmols = 0 kk = min(nall_b*nall_s,env%queue_maxreconstruct) allocate (layer%mols(kk)) + write (stdout,'(2x,a,i0)') 'Max. new structs stored : ',kk + + RTHR = env%rthr*aatoau !> RMSD threshold in Bohr + ETHR = env%ethr/autokcal !> deltaE threshold in hartree + duplicates = 0 + call ccache%allocate(layer%refmol%nat) + write (stdout,'(2x,a)',advance='no') 'Recombining under RMSD consideration (this may take a while) ... ' + flush (stdout) !> NOTE: !> we want a balanced amount of combinations, sourcing @@ -667,15 +682,33 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) call attach(structures_b(ii),structures_s(jj),layer%alignmap,mol, & & remove_lastx=layer%ncapped,original_map=layer%position_mapping, & & clash=clash,reficn=layer%reficn) + !> proxy energy as sum of fragments + mol%energy = structures_b(ii)%energy+structures_s(jj)%energy if (.not.clash) then - layer%nmols = layer%nmols+1 - layer%mols(layer%nmols) = mol - if (layer%nmols == kk) exit sssloop + !> check for duplicates + duplicate = .false. + rrloop: do rr = 2,layer%nmols + deltaE = abs(mol%energy-layer%mols(rr)%energy) + if (deltaE < ETHR) then +! rmsval = irmsd(layer%mols(rr),mol,rcache=rcache,topocheck=.false.,allcanon=.true.) + rmsval = rmsd(layer%mols(rr),mol,ccache=ccache) + if (rmsval < RTHR) then + duplicate = .true. + duplicates = duplicates+1 + exit rrloop + end if + end if + end do rrloop + if (.not.duplicate) then + layer%nmols = layer%nmols+1 + layer%mols(layer%nmols) = mol + if (layer%nmols == kk) exit sssloop + end if end if end do jjloop end do iiloop end do sssloop - else + else ! i.e., nall_b <= nall_s sssloop2: do sss = 1,3 select case (sss) @@ -702,16 +735,38 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) call attach(structures_b(ii),structures_s(jj),layer%alignmap,mol, & & remove_lastx=layer%ncapped,original_map=layer%position_mapping, & & clash=clash,reficn=layer%reficn) + !> proxy energy as sum of fragments + mol%energy = structures_b(ii)%energy+structures_s(jj)%energy if (.not.clash) then - layer%nmols = layer%nmols+1 - layer%mols(layer%nmols) = mol - if (layer%nmols == kk) exit sssloop2 + !> check for duplicates + duplicate = .false. + rrloop2: do rr = 2,layer%nmols + deltaE = abs(mol%energy-layer%mols(rr)%energy) + if (deltaE < ETHR) then +! rmsval = irmsd(layer%mols(rr),mol,rcache=rcache,topocheck=.false.,allcanon=.true.) + rmsval = rmsd(layer%mols(rr),mol,ccache=ccache) + if (rmsval < RTHR) then + duplicate = .true. + duplicates = duplicates+1 + exit rrloop2 + end if + end if + end do rrloop2 + if (.not.duplicate) then + layer%nmols = layer%nmols+1 + layer%mols(layer%nmols) = mol + if (layer%nmols == kk) exit sssloop2 + end if end if end do iiloop2 end do jjloop2 end do sssloop2 end if - write (stdout,'(2x,a,i0)') 'Successful combinations : ',layer%nmols + write (stdout,'(a)') 'done.' + if (duplicates > 0) then + write (stdout,'(2x,a,i0)') 'Avoided duplicates : ',duplicates + end if + write (stdout,'(2x,a,i0)') 'Successful combinations : ',layer%nmols end associate end subroutine recusrive_construct diff --git a/src/classes.f90 b/src/classes.f90 index fa25628b..ab085f44 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -467,7 +467,7 @@ module crest_data type(split_atms),allocatable :: splitqueue(:) type(construct_heap) :: splitheap integer :: queue_iter = 0 - integer :: queue_maxreconstruct = 10000 + integer :: queue_maxreconstruct = 7500 !>--- QCG data integer :: qcg_runtype = 0 !> Default is grow, 1= ensemble & opt, 2= e_solv, 3= g_solv diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index bfb0407f..d82f419a 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -11,7 +11,7 @@ module irmsd_module implicit none private - public :: rmsd + public :: rmsd,irmsd public :: min_rmsd public :: rmsd_align @@ -20,6 +20,7 @@ module irmsd_module real(wp),parameter :: bigval = huge(bigval) + public :: rmsd_core_cache type :: rmsd_core_cache !************************************* !* Memory cache for rmsd_core routine @@ -38,6 +39,7 @@ module irmsd_module !* cache implementation to avoid repeated allocation !* and enable shared-memory parallelism !**************************************************** + logical :: initialized = .false. real(wp),allocatable :: xyzscratch(:,:,:) integer,allocatable :: rank(:,:) integer,allocatable :: best_order(:,:) @@ -61,6 +63,7 @@ module irmsd_module contains procedure :: allocate => allocate_rmsd_cache procedure :: check_proxy_topo + procedure :: initialize => initialize_rmsd_cache end type rmsd_cache real(wp),parameter :: inf = huge(1.0_wp) @@ -165,6 +168,17 @@ subroutine allocate_rmsd_cache(self,nat) call self%acache%allocate(nat,nat,.true.) !> assume we are only using the LSAP implementation end subroutine allocate_rmsd_cache + subroutine initialize_rmsd_cache(self,nat) + implicit none + class(rmsd_cache) :: self + integer,intent(in) :: nat + + if (.not.self%initialized.or.size(self%xyzscratch,2) .ne. nat) then + call self%allocate(nat) + self%initialized = .true. + end if + end subroutine initialize_rmsd_cache + !========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< calculate the barycenters, centroidal coordinates, and the norms x_norm = 0.0_wp y_norm = 0.0_wp - rnat = 1.0_wp / real(nat,wp) + rnat = 1.0_wp/real(nat,wp) do i = 1,3 xi(:nat) = x(i,1:nat) yi(:nat) = y(i,1:nat) - x_center(i) = sum(xi(1:nat)) * rnat - y_center(i) = sum(yi(1:nat)) * rnat - xi(1:nat) = xi(1:nat) - x_center(i) - yi(1:nat) = yi(1:nat) - y_center(i) + x_center(i) = sum(xi(1:nat))*rnat + y_center(i) = sum(yi(1:nat))*rnat + xi(1:nat) = xi(1:nat)-x_center(i) + yi(1:nat) = yi(1:nat)-y_center(i) x(i,1:nat) = xi(1:nat) y(i,1:nat) = yi(1:nat) - x_norm = x_norm + dot_product(xi,xi) - y_norm = y_norm + dot_product(yi,yi) + x_norm = x_norm+dot_product(xi,xi) + y_norm = y_norm+dot_product(yi,yi) end do !> calculate the R matrix @@ -350,25 +364,25 @@ subroutine rmsd_core(nat,xyz1,xyz2,calc_u,U,error,calc_g,grad,ccache) end do !> S matrix - S(1,1) = Rmatrix(1,1) + Rmatrix(2,2) + Rmatrix(3,3) - S(2,1) = Rmatrix(2,3) - Rmatrix(3,2) - S(3,1) = Rmatrix(3,1) - Rmatrix(1,3) - S(4,1) = Rmatrix(1,2) - Rmatrix(2,1) + S(1,1) = Rmatrix(1,1)+Rmatrix(2,2)+Rmatrix(3,3) + S(2,1) = Rmatrix(2,3)-Rmatrix(3,2) + S(3,1) = Rmatrix(3,1)-Rmatrix(1,3) + S(4,1) = Rmatrix(1,2)-Rmatrix(2,1) S(1,2) = S(2,1) - S(2,2) = Rmatrix(1,1) - Rmatrix(2,2) - Rmatrix(3,3) - S(3,2) = Rmatrix(1,2) + Rmatrix(2,1) - S(4,2) = Rmatrix(1,3) + Rmatrix(3,1) + S(2,2) = Rmatrix(1,1)-Rmatrix(2,2)-Rmatrix(3,3) + S(3,2) = Rmatrix(1,2)+Rmatrix(2,1) + S(4,2) = Rmatrix(1,3)+Rmatrix(3,1) S(1,3) = S(3,1) S(2,3) = S(3,2) - S(3,3) = -Rmatrix(1,1) + Rmatrix(2,2) - Rmatrix(3,3) - S(4,3) = Rmatrix(2,3) + Rmatrix(3,2) + S(3,3) = -Rmatrix(1,1)+Rmatrix(2,2)-Rmatrix(3,3) + S(4,3) = Rmatrix(2,3)+Rmatrix(3,2) S(1,4) = S(4,1) S(2,4) = S(4,2) S(3,4) = S(4,3) - S(4,4) = -Rmatrix(1,1) - Rmatrix(2,2) + Rmatrix(3,3) + S(4,4) = -Rmatrix(1,1)-Rmatrix(2,2)+Rmatrix(3,3) !> Calculate eigenvalues and eigenvectors, and !> take the maximum eigenvalue lambda and the corresponding eigenvector q. @@ -386,14 +400,14 @@ subroutine rmsd_core(nat,xyz1,xyz2,calc_u,U,error,calc_g,grad,ccache) end if !> RMS Deviation - error = sqrt(max(0.0_wp, ((x_norm + y_norm) - 2.0_wp * lambda)) * rnat) + error = sqrt(max(0.0_wp, ((x_norm+y_norm)-2.0_wp*lambda))*rnat) if (calc_g) then !> Gradient of the error of xyz1 w.r.t xyz2 do i = 1,nat do j = 1,3 tmp(:) = matmul(transpose(U(:,:)),y(:,i)) - grad(j,i) = ((x(j,i) - tmp(j)) / error) * rnat + grad(j,i) = ((x(j,i)-tmp(j))/error)*rnat end do end do end if @@ -430,19 +444,19 @@ subroutine rmsd_align(ref,mol,mask) do ii = 1,ref%nat if (present(mask)) then if (mask(ii)) then - cref(:) = cref(:) + ref%xyz(:,ii) - cmol(:) = cmol(:) + mol%xyz(:,ii) + cref(:) = cref(:)+ref%xyz(:,ii) + cmol(:) = cmol(:)+mol%xyz(:,ii) end if else - cref(:) = cref(:) + ref%xyz(:,ii) - cmol(:) = cmol(:) + mol%xyz(:,ii) + cref(:) = cref(:)+ref%xyz(:,ii) + cmol(:) = cmol(:)+mol%xyz(:,ii) end if end do nn = ref%nat if (present(mask)) nn = count(mask) - shift = cref - cmol + shift = cref-cmol do ii = 1,mol%nat - mol%xyz(:,ii) = mol%xyz(:,ii) + shift(:) + mol%xyz(:,ii) = mol%xyz(:,ii)+shift(:) end do Umat(:,:) = 0.0_wp @@ -529,7 +543,7 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout,align,topocheck,io) end if !>--- First sorting, to at least restore rank order (only if that's not the case!) - if (.not. all(cptr%rank(:,1) .eq. cptr%rank(:,2))) then + if (.not.all(cptr%rank(:,1) .eq. cptr%rank(:,2))) then call rank_2_order(ref%nat,cptr%rank(:,1),cptr%target_order) call rank_2_order(mol%nat,cptr%rank(:,2),cptr%current_order) if (debug) then @@ -554,14 +568,14 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout,align,topocheck,io) do ii = 1,ref%nat rnk = cptr%rank(ii,1) if (rnk > 0) then - cptr%ngroup(rnk) = cptr%ngroup(rnk) + 1 + cptr%ngroup(rnk) = cptr%ngroup(rnk)+1 end if end do end if !> assignment reset cptr%assigned(:) = .false. cptr%rassigned(:) = .false. - cptr%rassigned(cptr%nranks + 1:) = .true. !> skip unneeded allocation space + cptr%rassigned(cptr%nranks+1:) = .true. !> skip unneeded allocation space do ii = 1,ref%nat cptr%iwork(ii) = ii !> also init iwork cptr%target_order(ii) = ii !> also init target_order @@ -673,14 +687,14 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout,align,topocheck,io) mol%xyz(3,:) = -mol%xyz(3,:) if (debug) write (*,*) 'inverting' end if - if ((ii > 4 .and. ii < 9) .or. (ii > 20 .and. ii < 25)) then + if ((ii > 4.and.ii < 9).or.(ii > 20.and.ii < 25)) then if (uniquenesscase == 1) mol%xyz = matmul(Rx90,mol%xyz) if (uniquenesscase == 2) mol%xyz = matmul(Rz90,mol%xyz) if (uniquenesscase == 3) mol%xyz = matmul(Rz90,mol%xyz) if (debug) write (*,*) '90° tilt' - else if ((ii > 8 .and. ii < 13) .or. (ii > 24 .and. ii < 29)) then + else if ((ii > 8.and.ii < 13).or.(ii > 24.and.ii < 29)) then mol%xyz = matmul(Ry90,mol%xyz) - else if ((ii > 12 .and. ii < 17) .or. (ii > 28)) then + else if ((ii > 12.and.ii < 17).or.(ii > 28)) then mol%xyz = matmul(Rx90,mol%xyz) end if select case (ii) !> 180° rotations @@ -731,6 +745,102 @@ subroutine min_rmsd(ref,mol,rcache,rmsdout,align,topocheck,io) if (present(io)) io = ioloc end subroutine min_rmsd + function irmsd(ref,mol,rcache, & + & iinversion,align,topocheck,allcanon,io) result(rmsdval) +!*************************************************************** +!* irmsd function +!* Standalone implementation to compare two structures +!* with the iRMSD method analog to the rmsd function +!* the optional rcache will get allocated if it not already is. +!*************************************************************** + use canonical_mod + implicit none + + type(coord),intent(inout) :: mol,ref + integer,intent(in),optional :: iinversion + type(rmsd_cache),intent(inout),optional,target :: rcache + logical,intent(in),optional :: align + logical,intent(in),optional :: topocheck + logical,intent(in),optional :: allcanon + integer,intent(out),optional :: io + real(wp) :: rmsdval + !> LOCAL + type(rmsd_cache),pointer :: cptr + type(rmsd_cache),allocatable,target :: local_rcache + logical :: align_l = .true. + logical :: topocheck_l = .true. + logical :: allcanon_l = .false. + integer :: io_l = 0 + real(wp) ::tmpd(3),tmpdist + integer :: i,ich + type(canonical_sorter) :: canmol + type(canonical_sorter) :: canref + logical :: mirror + logical,parameter :: debug = .false. + + !> move ref to CMA and align rotational axes + call axis(ref%nat,ref%at,ref%xyz) + + !> optional args + if (present(align)) align_l = align + if (present(topocheck)) topocheck_l = topocheck + if (present(allcanon)) allcanon_l = allcanon + if (present(rcache)) then + cptr => rcache + else + allocate (local_rcache) + cptr => local_rcache + end if + call cptr%initialize(ref%nat) + !call rcache%allocate(ref%nat) + + !> canonical atom ranks + if (.not.allcanon_l) then + call canref%init(ref,invtype='apsp+',heavy=.false.) + cptr%stereocheck = .not. (canref%hasstereo(ref)) + call canref%shrink() + else + cptr%stereocheck = .false. + end if + if (present(iinversion)) then + select case (iinversion) + case (0) + mirror = .true. + case (1) + mirror = .true. + cptr%stereocheck = .true. + case (2) + mirror = .false. + cptr%stereocheck = .false. + end select + end if + + if (.not.allcanon_l) then + call canmol%init(mol,invtype='apsp+',heavy=.false.) + call canmol%shrink() + end if + + if (.not.allcanon_l) then + !> check if we can work with the determined ranks + if (checkranks(ref%nat,canref%rank,canmol%rank)) then + cptr%rank(:,1) = canref%rank(:) + cptr%rank(:,2) = canmol%rank(:) + else + !> if not, fall back to atom types + call fallbackranks(ref,mol,ref%nat,cptr%rank) + end if + else + call fallbackranks(ref,mol,ref%nat,cptr%rank) + end if + + call min_rmsd(ref,mol,rcache=cptr,rmsdout=rmsdval, & + & align=align_l,topocheck=topocheck_l,io=io_l) + + if (present(io)) io = io_l + + return + end function irmsd + !========================================================================================! subroutine min_rmsd_iterate_through_groups(ref,mol,rcache,val) @@ -765,7 +875,7 @@ subroutine min_rmsd_iterate_through_groups(ref,mol,rcache,val) !> add up the total LSAP cost (of considered ranks) !> we need this if we have to decide on a mapping in case of false enantiomers - val = val + val0 + val = val+val0 end do end subroutine min_rmsd_iterate_through_groups @@ -822,27 +932,27 @@ subroutine min_rmsd_rotcheck_permute(ref,mol,cptr,values,step,uniquenesscase) ALIGNLOOP: do ii = 1,4 call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) - vals(1 + 4 * (ii - 1)) = dum + vals(1+4*(ii-1)) = dum if (debug) call mol%append(debugunit2) - cptr%order_bkup(:,1 + 4 * (ii - 1) + 16 * (step - 1)) = cptr%iwork(:) + cptr%order_bkup(:,1+4*(ii-1)+16*(step-1)) = cptr%iwork(:) mol%xyz = matmul(Rx180,mol%xyz) call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) - vals(2 + 4 * (ii - 1)) = dum + vals(2+4*(ii-1)) = dum if (debug) call mol%append(debugunit2) - cptr%order_bkup(:,2 + 4 * (ii - 1) + 16 * (step - 1)) = cptr%iwork(:) + cptr%order_bkup(:,2+4*(ii-1)+16*(step-1)) = cptr%iwork(:) mol%xyz = matmul(Ry180,mol%xyz) call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) - vals(3 + 4 * (ii - 1)) = dum + vals(3+4*(ii-1)) = dum if (debug) call mol%append(debugunit2) - cptr%order_bkup(:,3 + 4 * (ii - 1) + 16 * (step - 1)) = cptr%iwork(:) + cptr%order_bkup(:,3+4*(ii-1)+16*(step-1)) = cptr%iwork(:) mol%xyz = matmul(Rx180,mol%xyz) call min_rmsd_iterate_through_groups(ref,mol,cptr,dum) - vals(4 + 4 * (ii - 1)) = dum + vals(4+4*(ii-1)) = dum if (debug) call mol%append(debugunit2) - cptr%order_bkup(:,4 + 4 * (ii - 1) + 16 * (step - 1)) = cptr%iwork(:) + cptr%order_bkup(:,4+4*(ii-1)+16*(step-1)) = cptr%iwork(:) mol%xyz = matmul(Ry180,mol%xyz) !> restore @@ -885,7 +995,7 @@ subroutine min_rmsd_rotcheck_permute(ref,mol,cptr,values,step,uniquenesscase) end if do ii = 1,16 - values(ii + 16 * (step - 1)) = vals(ii) + values(ii+16*(step-1)) = vals(ii) end do end subroutine min_rmsd_rotcheck_permute @@ -906,14 +1016,14 @@ subroutine fallbackranks(ref,mol,nat,ranks) allocate (typemap(nat),source=0) k = 0 do ii = 1,ref%nat - if (.not. any(typemap(:) .eq. ref%at(ii))) then - k = k + 1 + if (.not.any(typemap(:) .eq. ref%at(ii))) then + k = k+1 typemap(k) = ref%at(ii) end if end do do ii = 1,mol%nat - if (.not. any(typemap(:) .eq. mol%at(ii))) then - k = k + 1 + if (.not.any(typemap(:) .eq. mol%at(ii))) then + k = k+1 typemap(k) = mol%at(ii) end if end do @@ -985,14 +1095,14 @@ subroutine compute_linear_sum_assignment(ref,mol,ranks, & ii = 0 do i = 1,ref%nat if (ranks(i,1) .ne. targetrank) cycle - ii = ii + 1 + ii = ii+1 iwork2(ii,1) = i !> mapping using the first column of iwork2 jj = 0 do j = 1,mol%nat if (ranks(j,2) .ne. targetrank) cycle - jj = jj + 1 - dists(:) = real((ref%xyz(:,i) - mol%xyz(:,j))**2,sp) !> use i and j - aptr%Cost(jj + (ii - 1) * rnknat) = sum(dists) + jj = jj+1 + dists(:) = real((ref%xyz(:,i)-mol%xyz(:,j))**2,sp) !> use i and j + aptr%Cost(jj+(ii-1)*rnknat) = sum(dists) end do end do @@ -1012,8 +1122,8 @@ subroutine compute_linear_sum_assignment(ref,mol,ranks, & do i = 1,rnknat jj = aptr%a(i) ii = aptr%b(i) - if (ii == -1 .or. jj == -1) cycle !> cycle bad assignments - val0 = val0 + aptr%Cost(jj + (ii - 1) * rnknat) + if (ii == -1.or.jj == -1) cycle !> cycle bad assignments + val0 = val0+aptr%Cost(jj+(ii-1)*rnknat) iwork2(i,2) = iwork2(aptr%b(i),1) end do else @@ -1038,7 +1148,7 @@ subroutine rank_2_order(nat,rank,order) do ii = 1,maxrank do jj = 1,nat if (rank(jj) == ii) then - k = k + 1 + k = k+1 order(jj) = k end if end do @@ -1070,8 +1180,8 @@ function checkranks(nat,ranks1,ranks2) result(yesno) count1 = 0 count2 = 0 do jj = 1,nat - if (ranks1(jj) .eq. ii) count1 = count1 + 1 - if (ranks2(jj) .eq. ii) count2 = count2 + 1 + if (ranks1(jj) .eq. ii) count1 = count1+1 + if (ranks2(jj) .eq. ii) count2 = count2+1 end do !> not the same amount of atoms in rank ii, return from function if (count1 .ne. count2) return @@ -1181,7 +1291,7 @@ function check_proxy_topo(self,ref,mol) result(io) self%proxy_topo(:,1) = mol%at(:) self%proxy_topo(:,2) = self%rank(:,2) call qsortm(self%proxy_topo,2,self%iwork) - if (.not. all(self%proxy_topo .eq. self%proxy_topo_ref)) then + if (.not.all(self%proxy_topo .eq. self%proxy_topo_ref)) then io = 3 return !> some difference in the sorting, return before setting passing to true end if @@ -1198,15 +1308,15 @@ recursive subroutine qsorti(v,ix,l,r) integer,intent(in) :: l,r integer :: i,j,p,t,n if (l >= r) return - p = v(ix((l + r) / 2)) + p = v(ix((l+r)/2)) n = size(v,1) i = l; j = r do - do while (v(ix(i)) < p); i = i + 1; end do - do while (v(ix(j)) > p); j = j - 1; end do + do while (v(ix(i)) < p); i = i+1; end do + do while (v(ix(j)) > p); j = j-1; end do if (i <= j) then t = ix(i); ix(i) = ix(j); ix(j) = t - i = min(i + 1,n); j = max(j - 1,1) + i = min(i+1,n); j = max(j-1,1) else exit end if From ad16cd651c9dc37470f3fca99c80fdd7846a626a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 11 Feb 2026 13:36:25 +0100 Subject: [PATCH 171/374] CREGEN printout changes --- src/crest_main.f90 | 2 +- src/sorting/cregen.f90 | 505 ++++++++++++----------------------- src/sorting/irmsd_module.f90 | 1 + 3 files changed, 169 insertions(+), 339 deletions(-) diff --git a/src/crest_main.f90 b/src/crest_main.f90 index 30069a69..6e00313f 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -105,7 +105,7 @@ program CREST !>--- only CREGEN routine case (p_cregen) call tim%start(1,'CREGEN') - write (*,*) 'Using only the cregen sorting routine.' + write (*,*) 'Using only the CREGEN sorting routine.' env%cgf(6) = .true. !write confg output to file if (env%doNMR) then env%cgf(3) = .true. diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index a9728662..79595ad7 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -139,7 +139,7 @@ subroutine newcregen(env,quickset,infile,structurelist) !=====================================================================! !>--- read in the ensemble parameters - if (.not. ensembleinput) then + if (.not.ensembleinput) then call rdensembleparam(fname,nat,nallref) else nat = structurelist(1)%nat @@ -150,7 +150,7 @@ subroutine newcregen(env,quickset,infile,structurelist) if (pr1) call cregen_pr1(prch,env,nat,nallref,rthr,bthr,pthr,ewin) !>--- allocate space and read in the ensemble - if (.not. ensembleinput) then + if (.not.ensembleinput) then call rdensemble(fname,nallref,structures) else call move_alloc(structurelist,structures) @@ -177,7 +177,7 @@ subroutine newcregen(env,quickset,infile,structurelist) nall = nallnew !> update !>--- if structures were discarded, resize xyz end if - if (topocheck .or. checkbroken) then + if (topocheck.or.checkbroken) then write (prch,'(" number of reliable points",t35,":",i10)') nall end if @@ -190,7 +190,7 @@ subroutine newcregen(env,quickset,infile,structurelist) !>--- do the rotational constants and RMSD check if (sortRMSD) then call cregen_CRE_new(env,nall,structures,group,rthr, & - & ethr / autokcal,bthr,printlvl=2,ch=prch) + & ethr/autokcal,bthr,printlvl=2,ch=prch) !>--- get group info to degen ng = group(0) allocate (degen(3,ng)) @@ -239,7 +239,7 @@ subroutine newcregen(env,quickset,infile,structurelist) end if !>--- several printouts - if (pr2 .or. pr3 .or. pr4) then + if (pr2.or.pr3.or.pr4) then allocate (er(nall)) do ii = 1,nall er(ii) = structures(ii)%energy @@ -259,7 +259,7 @@ subroutine newcregen(env,quickset,infile,structurelist) !>--- analyze nuclear equivalencies, e.g. for NMR and Entropy if (anal) then - call cregen_EQUAL(prch,nall,structures,group,athr,.not. env%entropic) + call cregen_EQUAL(prch,nall,structures,group,athr,.not.env%entropic) end if !>-- in case we had a structurelist given, move the (sorted) memory space back there @@ -267,6 +267,13 @@ subroutine newcregen(env,quickset,infile,structurelist) call move_alloc(structures,structurelist) end if + if(newfile)then + write(prch,'(a,a)') 'Full ensemble file written to: ',trim(oname) + endif + if(conffile)then + write(prch,'(a,a)') 'Unique-structure file written to: ',trim(cname) + endif + !>--- deallocate data if (prch .ne. stdout) then close (prch) @@ -318,15 +325,15 @@ subroutine cregen_files(env,fname,oname,cname,simpleset,userinput,ensembleinput, case default open (newunit=iounit,file=outfile) end select - else if (env%confgo .and. .not. (env%properties .eq. -2) .and. .not. env%relax) then + else if (env%confgo.and..not. (env%properties .eq. -2).and..not.env%relax) then iounit = stdout else open (newunit=iounit,file=outfile) end if - if ((env%confgo .and. (index(trim(fname),'none selected') .eq. 0)) & - & .OR. userinput .OR. ensembleinput) then - if (.not. userinput .and. .not. ensembleinput) then + if ((env%confgo.and.(index(trim(fname),'none selected') .eq. 0)) & + & .OR.userinput.OR.ensembleinput) then + if (.not.userinput.and..not.ensembleinput) then fname = trim(env%ensemblename) end if cname = 'crest_ensemble.xyz' @@ -336,7 +343,7 @@ subroutine cregen_files(env,fname,oname,cname,simpleset,userinput,ensembleinput, end if else !> internal mode for conformational search fname = repeat(' ',256) !> need initialization because checkname_xyz - oname = repeat(' ',256) !> can't handle allocatable names + oname = repeat(' ',256) !> can't handle allocatable names call checkname_xyz(crefile,fname,oname) cname = conformerfile end if @@ -364,7 +371,7 @@ subroutine cregen_files(env,fname,oname,cname,simpleset,userinput,ensembleinput, end select inquire (file=fname,exist=ex) - if (.not. ex .and. .not. ensembleinput) then + if (.not.ex.and..not.ensembleinput) then write (stdout,'(a)') 'CREGEN> **WARNING** file ',trim(fname),' does not exist!' error stop end if @@ -393,7 +400,7 @@ subroutine cregen_prout(env,simpleset,pr1,pr2,pr3,pr4) pr3 = .false. !> plain energy list pr4 = .false. !> group list printout - if (any(simpleset == (/6,7/)) .or. env%esort) then + if (any(simpleset == (/6,7/)).or.env%esort) then pr1 = .false. pr2 = .false. if (env%crestver .ne. crest_solv) pr3 = .true. @@ -460,25 +467,25 @@ subroutine cregen_director(env,simpleset,checkbroken,sortE,sortRMSD,sortRMSD2, & end if bonusfiles = .false. - if (env%entropic .or. env%doNMR) then + if (env%entropic.or.env%doNMR) then bonusfiles = .true. end if anal = .false. - if (env%doNMR .or. env%cgf(3) .or. simpleset == 2) then + if (env%doNMR.or.env%cgf(3).or.simpleset == 2) then anal = .true. end if if (simpleset == 3) then anal = .false. end if - if (any(simpleset == (/6,7/)) .or. env%esort) then !energy sorting only + if (any(simpleset == (/6,7/)).or.env%esort) then !energy sorting only checkbroken = .false. sortE = .true. sortRMSD = .false. repairord = .false. newfile = .true. - if ((env%crestver .eq. crest_solv) .and. (.not. env%QCG)) then + if ((env%crestver .eq. crest_solv).and.(.not.env%QCG)) then conffile = .true. !Conffile is needed for confscript in QCG else conffile = .false. @@ -581,7 +588,7 @@ subroutine cregen_groupinfo(nall,ng,group,degen) a = 0; b = 0; k = 0 do j = 1,nall if (group(j) .eq. i) then - k = k + 1 + k = k+1 if (a == 0) a = j b = j end if @@ -629,7 +636,7 @@ subroutine cregen_discardbroken(ch,env,topocheck,structures,newnall) type(coord),allocatable :: tmpstructures(:) !>--- if we don't wish to include all atoms: - substruc = (structures(1)%nat .ne. env%rednat .and. env%subRMSD) + substruc = (structures(1)%nat .ne. env%rednat.and.env%subRMSD) nall = size(structures,1) !> Check fragments call env%ref%to(mol0) @@ -654,18 +661,18 @@ subroutine cregen_discardbroken(ch,env,topocheck,structures,newnall) !>--- further checks: dissociation? dissoc = .false. - if (abs(erj) .gt. 1.0d-6 .and. & - & distok .and. distok2 .and. topocheck) then + if (abs(erj) .gt. 1.0d-6.and. & + & distok.and.distok2.and.topocheck) then call cregen_calculate_fragments(mol,nfrag=frag) dissoc = (frag .gt. frag0) end if - if (dissoc .or. (.not. distok) .or. (.not. distok2)) then + if (dissoc.or.(.not.distok).or.(.not.distok2)) then !>--- move broken structures to the end of the matrix broke(ii) = .true. !write(ch,*) 'removing structure',ii else - newnall = newnall + 1 + newnall = newnall+1 end if end do @@ -674,13 +681,13 @@ subroutine cregen_discardbroken(ch,env,topocheck,structures,newnall) allocate (tmpstructures(newnall)) jj = 0 do ii = 1,nall - if (.not. broke(ii)) then - jj = jj + 1 + if (.not.broke(ii)) then + jj = jj+1 tmpstructures(jj) = structures(ii) end if end do call move_alloc(tmpstructures,structures) - llan = nall - newnall + llan = nall-newnall write (ch,'(" number of removed clashes",t35,":",i10)') llan end if !>--- otherwise the ensemble is ok @@ -780,14 +787,14 @@ subroutine cregen_topocheck(ch,env,checkez,structures,newnall) end if end do !>--- get E/Z info of C=C, discard isomers - if (checkez .and. .not. discard .and. ncc > 0) then + if (checkez.and..not.discard.and.ncc > 0) then call ezccdihed(mol%nat,mol%xyz,ncc,ezat,ezdihed) do l = 1,ncc - winkeldiff = ezdihedref(l) - ezdihed(l) + winkeldiff = ezdihedref(l)-ezdihed(l) winkeldiff = abs(winkeldiff) if (winkeldiff > 90.0_wp) then discard = .true. - ccfail = ccfail + 1 + ccfail = ccfail+1 exit end if end do @@ -796,27 +803,27 @@ subroutine cregen_topocheck(ch,env,checkez,structures,newnall) if (discard) then broke(jj) = .true. else - newnall = newnall + 1 + newnall = newnall+1 end if end do !>--- sort the xyz array (only if structures have been discarded) if (newnall .lt. nall) then - llan = nall - newnall + llan = nall-newnall write (ch,'(" number of topology mismatches",t35,":",i10)') llan !>--- report the removals during a run if (ch .ne. stdout) then write (stdout,'("CREGEN> number of topology-based structure removals: ",i0)') llan end if - if (checkez .and. ccfail > 0) then + if (checkez.and.ccfail > 0) then write (ch,'('' => discared due to E/Z isom. : '',i0)') ccfail end if if (newnall >= 1) then allocate (tmpstructures(newnall)) jj = 0 do ii = 1,nall - if (.not. broke(ii)) then - jj = jj + 1 + if (.not.broke(ii)) then + jj = jj+1 tmpstructures(jj) = structures(ii) end if end do @@ -873,7 +880,7 @@ subroutine cregen_esort(ch,structures,nallout,ewin) !>-- determine cut-off of energies (optional) if (present(ewin)) then - write (ch,'(75("*"))') + write (ch,'(80("*"))') allocate (energies(nall)) do ii = 1,nall energies(ii) = structures(ii)%energy @@ -885,22 +892,22 @@ subroutine cregen_esort(ch,structures,nallout,ewin) write (ch,'(" sorting energy window (EWIN)",t32,":",3x,a,a)') '+∞',' / kcal/mol' end if emax = maxval(energies(:),1) - de = (emax - energies(1)) * autokcal + de = (emax-energies(1))*autokcal if (de .gt. ewin) then nallout = 1 !> lowest is always taken do ii = 2,nall - de = (energies(ii) - energies(1)) * autokcal + de = (energies(ii)-energies(1))*autokcal if (de .lt. ewin) then - nallout = nallout + 1 + nallout = nallout+1 else exit end if end do - frac = real(nall - nallout,wp) / real(nall,wp) + frac = real(nall-nallout,wp)/real(nall,wp) write (ch,'(" number of removed by energy",t32,":",3x,i10,a,f6.2,a)') & - & (nall - nallout),' (',frac * 100.d0,'%)' + & (nall-nallout),' (',frac*100.d0,'%)' write (ch,'(" number of remaining points",t32,":",3x,i10,a,f6.2,a)') & - & nallout,' (', (1.0d0 - frac) * 100.d0,'%)' + & nallout,' (', (1.0d0-frac)*100.d0,'%)' allocate (tmpstructures(nallout)) do ii = 1,nallout @@ -1009,7 +1016,7 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & T = 1 !> doing it serial for now !>--- set up parameters (NOTE, we are working with BOHR internally) - RTHR = RTHRESH * aatoau + RTHR = RTHRESH*aatoau !>--- reference structure (the first one) for some setup ref => structures(1) @@ -1018,22 +1025,22 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & !>--- print some sorting data if (prlvl > 0) then tmpstr = 'Info for CREGEN sorting:' - if (prlvl > 1 .and. prch == stdout) then + if (prlvl > 1.and.prch == stdout) then ! call printc(style(S_BOLD)//fg(YELLOW,bright=.true.)//trim(tmpstr)//reset()) else write (prch,'(a)') 'Info for CREGEN sorting:' end if !write (prch,'(2x,a,i10)') 'number of structures :',nall - write (prch,'(2x,a,t32,a,f10.5,a)') 'RTHR (RMSD threshold)',':',RTHR * autoaa,' Å' + write (prch,'(2x,a,t32,a,f10.5,a)') 'RTHR (RMSD threshold)',':',RTHR*autoaa,' Å' write (prch,'(2x,a,t32,a,es10.2,a)') 'ETHR (energy threshold)',':',ETHR,' Ha' - write (prch,'(2x,a,t32,a,f10.2,a)') 'BTHR (rot. threshold)',':',BTHR * 100,' %' + write (prch,'(2x,a,t32,a,f10.2,a)') 'BTHR (rot. threshold)',':',BTHR*100,' %' !write (prch,'(2x,a,i9)') 'OpenMP threads :',T end if !>--- mask setup: We may not include all atoms in the checks heavy = env%heavyrmsd - substruc = (nat .ne. env%rednat .and. env%subRMSD .and. allocated(env%includeRMSD)) - if (heavy .or. substruc) then + substruc = (nat .ne. env%rednat.and.env%subRMSD.and.allocated(env%includeRMSD)) + if (heavy.or.substruc) then allocate (mask(nat),source=.false.) end if if (heavy) then @@ -1046,13 +1053,13 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & mask(ii) = (env%includeRMSD(ii) .eq. 1) end do end if - if ((heavy .or. substruc) .and. (prlvl > 0)) then + if ((heavy.or.substruc).and.(prlvl > 0)) then write (prch,'(" Heavy/masked atoms",t32,":",i10," / ",i0)') count(mask),nat end if if (prlvl > 0) then tmpstr = "Starting calculations..." - if (prlvl > 1 .and. prch == stdout) then + if (prlvl > 1.and.prch == stdout) then ! call printc(style(S_BOLD)//fg(YELLOW,bright=.true.)//trim(tmpstr)//reset()) else write (stdout,'(a)') trim(tmpstr) @@ -1090,7 +1097,7 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & do ii = 1,nall eii = structures(ii)%energy do jj = 1,ii - ediff = abs(eii - structures(jj)%energy) + ediff = abs(eii-structures(jj)%energy) if (ediff <= ETHR) then prune_table(ii) = jj exit @@ -1104,19 +1111,19 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & do ii = 1,nall mol => structures(ii) call axis(mol%nat,mol%at,mol%xyz) !> all coordinates to CMA - call axis(mol%nat,mol%at,moL%xyz * autoaa,rot(1:3,ii),avmom)!> B_0 in MHz + call axis(mol%nat,mol%at,moL%xyz*autoaa,rot(1:3,ii),avmom)!> B_0 in MHz end do !> Scaled sum of atom-atom-distances (empirical measure) allocate (enuc(nall),source=0.0_wp) do ii = 1,nall mol => structures(ii) - do jj = 1,mol%nat - 1 - do kk = jj + 1,mol%nat - rsq = (mol%xyz(1,jj) - mol%xyz(1,kk))**2 & - & + (mol%xyz(2,jj) - mol%xyz(2,kk))**2 & - & + (mol%xyz(3,jj) - mol%xyz(3,kk))**2 + 1.d-12 - enuc(ii) = enuc(ii) + real(mol%at(jj) * mol%at(kk),wp) / rsq + do jj = 1,mol%nat-1 + do kk = jj+1,mol%nat + rsq = (mol%xyz(1,jj)-mol%xyz(1,kk))**2 & + & +(mol%xyz(2,jj)-mol%xyz(2,kk))**2 & + & +(mol%xyz(3,jj)-mol%xyz(3,kk))**2+1.d-12 + enuc(ii) = enuc(ii)+real(mol%at(jj)*mol%at(kk),wp)/rsq end do end do end do @@ -1129,7 +1136,7 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & if (prlvl > 0) then write (prch,'(a,6x,a)',advance='no') 'Running CREGEN checks','... ' flush (prch) - if (prlvl > 1 .and. prch == stdout) then + if (prlvl > 1.and.prch == stdout) then ! write (stdout,*) ! call progress_init(ps,width=50,prefix=" ↳", & ! & suffix="",show_time=.true.,show_eta=.false.) @@ -1144,7 +1151,7 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & do ii = 1,nall !>--- find next unassigned conformer and assign a new group if (groups(ii) .ne. 0) cycle - gcount = gcount + 1 + gcount = gcount+1 groups(ii) = gcount !>--- Then, cross-check all other unassigned conformers @@ -1154,14 +1161,14 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & ! !$omp shared(workmols, structures, ii, prune_table,heavy,substruc,mask) & ! !$omp private(jj,rmsdval,cc,io, l1, l2) ! !$omp do schedule(dynamic) - do jj = ii + 1,nall + do jj = ii+1,nall !cc = omp_get_thread_num()+1 if (groups(jj) .ne. 0) cycle if (ii < prune_table(jj)) cycle workmols(cc)%nat = structures(jj)%nat workmols(cc)%at(:) = structures(jj)%at(:) workmols(cc)%xyz(:,:) = structures(jj)%xyz(:,:) - if (heavy .or. substruc) then + if (heavy.or.substruc) then rmsdval = rmsd(structures(ii),workmols(cc),mask=mask,& & scratch=rcaches(cc)%xyzscratch,ccache=rcaches(cc)%ccache) else @@ -1173,8 +1180,8 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & groups(jj) = -gcount else l1 = equalrotaniso(ii,jj,nall,rot,BTHR,bthrmax,bthrshift) - l2 = (2.0_wp * abs(enuc(ii) - enuc(jj)) / (enuc(ii) + enuc(jj))) .lt. enuc_thr - if (l1 .and. l2) groups(jj) = gcount + l2 = (2.0_wp*abs(enuc(ii)-enuc(jj))/(enuc(ii)+enuc(jj))) .lt. enuc_thr + if (l1.and.l2) groups(jj) = gcount end if end do if (prlvl > 1) then @@ -1184,7 +1191,7 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & ! !$omp end parallel end do if (prlvl > 0) then - if (prlvl > 1 .and. prch == stdout) then + if (prlvl > 1.and.prch == stdout) then ! call progress_update(ps,nall,nall) ! call progress_finish(ps) write (prch,'(a)') 'done.' @@ -1209,11 +1216,11 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & do ii = 1,gcount do jj = 1,nall ggcount = groups(jj) - if (ggcount .eq. ii .and. ggcount > 0) then - cc = cc + 1 + if (ggcount .eq. ii.and.ggcount > 0) then + cc = cc+1 tmpstructures(cc) = structures(jj) tmpgroups(cc) = ggcount - do kk = 1,cc - 1 + do kk = 1,cc-1 if (tmpgroups(kk) .eq. ggcount) then double(cc) = kk exit @@ -1227,14 +1234,14 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & call move_alloc(tmpstructures,structures) if (prlvl > 0) then write (prch,'(a)') ' done.' - frac = real(nall - nallnew,wp) / real(nall,wp) + frac = real(nall-nallnew,wp)/real(nall,wp) write (prch,'(1x,a,t40,a,i10,a,f6.2,a)') & - & "number of doubles removed by rot/RMSD",":",nall - nallnew,' (',frac * 100.d0,'%)' + & "number of doubles removed by rot/RMSD",":",nall-nallnew,' (',frac*100.d0,'%)' write (prch,'(1x,a,t40,a,i10,a,f6.2,a)') & - & "number of unique structures remaining",":",nallnew,' (', (1.0d0 - frac) * 100.d0,'%)' - frac = real(gcount,wp) / real(nallnew,wp) + & "number of unique structures remaining",":",nallnew,' (', (1.0d0-frac)*100.d0,'%)' + frac = real(gcount,wp)/real(nallnew,wp) write (prch,'(1x,a,t40,a,i10,a,f6.2,a,i0,a)') & - & "number of unique conformers identified",":",gcount,' (', (frac) * 100.d0,'% of ',nallnew,')' + & "number of unique conformers identified",":",gcount,' (', (frac)*100.d0,'% of ',nallnew,')' end if nall = nallnew @@ -1298,7 +1305,7 @@ subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) call profiler%init(3) !> prepare workspace - nallpairs = (nall * (nall + 1)) / 2 + nallpairs = (nall*(nall+1))/2 allocate (rmsds(nallpairs),source=0.0_wp) if (debug) then allocate (debugrmsds(nallpairs),source=0.0_wp) @@ -1336,7 +1343,7 @@ subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) call profiler%stop(1) if (prlvl > 0) then call profiler%write_timing(stdout,1,'done.',.true.) - runtime = (profiler%get(1) / real(nall,wp)) * 1000.0_wp + runtime = (profiler%get(1)/real(nall,wp))*1000.0_wp write (stdout,'(a,f0.3,a)') 'CREGEN> Corresponding to approximately ',runtime, & & ' ms per processed structure' end if @@ -1367,7 +1374,7 @@ subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) do ii = 1,nall rcaches(cc)%stereocheck = stereocheck rcaches(cc)%rank(1:nat,1) = sorters(ii)%rank(1:nat) - do jj = ii + 1,nall + do jj = ii+1,nall workmols(cc)%nat = structures(jj)%nat workmols(cc)%at(:) = structures(jj)%at(:) workmols(cc)%xyz(:,:) = structures(jj)%xyz(:,:) @@ -1382,7 +1389,7 @@ subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) if (prlvl > 0) then call profiler%write_timing(stdout,2,'done.',.true.) !write (stdout,'(a)',advance='yes') 'done.' - runtime = (profiler%get(2) / real(nallpairs,wp)) * 1000.0_wp + runtime = (profiler%get(2)/real(nallpairs,wp))*1000.0_wp write (stdout,'(a,f0.3,a)') 'CREGEN> Corresponding to approximately ',runtime, & & ' ms per processed RMSD' @@ -1391,7 +1398,7 @@ subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) if (debug) then !> RMSD without permutation do ii = 1,nall - do jj = ii + 1,nall + do jj = ii+1,nall rmsdval = rmsd(structures(ii),structures(jj)) debugrmsds(lin(ii,jj)) = rmsdval end do @@ -1404,16 +1411,16 @@ subroutine cregen_irmsd_all(nall,structures,printlvl,iinversion) if (debug) then write (iunit,'(a,3(",",a))') 'A','B','rmsd','rmsdref' do ii = 1,nall - do jj = ii + 1,nall + do jj = ii+1,nall write (iunit,'(i0,",",i0,2(",",f0.7))') & - & min(ii,jj),max(ii,jj),rmsds(lin(ii,jj)) * autoaa,debugrmsds(lin(ii,jj)) * autoaa + & min(ii,jj),max(ii,jj),rmsds(lin(ii,jj))*autoaa,debugrmsds(lin(ii,jj))*autoaa end do end do else write (iunit,'(a,",",a,",",a)') 'A','B','rmsd' do ii = 1,nall - do jj = ii + 1,nall - write (iunit,'(i0,",",i0,",",f0.7)') min(ii,jj),max(ii,jj),rmsds(lin(ii,jj)) * autoaa + do jj = ii+1,nall + write (iunit,'(i0,",",i0,",",f0.7)') min(ii,jj),max(ii,jj),rmsds(lin(ii,jj))*autoaa end do end do end if @@ -1487,13 +1494,13 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) call profiler%init(3) !>--- set up parameters (note we are working with BOHR internally) - RTHR = env%rthr * aatoau + RTHR = env%rthr*aatoau !>--- print some sorting data if (prlvl > 0) then write (stdout,'(a)') 'CREGEN> Info for iRMSD sorting:' write (stdout,'(2x,a,i9)') 'number of structures :',nall - write (stdout,'(2x,a,f9.5,a)') 'RTHR (RMSD threshold) :',RTHR * autoaa,' Å' + write (stdout,'(2x,a,f9.5,a)') 'RTHR (RMSD threshold) :',RTHR*autoaa,' Å' write (stdout,'(2x,a,i9)') 'OpenMP threads :',T write (stdout,'(2x,a,a9)') 'Individual atom IDs? :',to_str(individual_IDs) write (stdout,'(2x,a)',advance='no') 'False rotamer check? :' @@ -1527,13 +1534,13 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) do ii = 1,nall mol => structures(ii) call axis(mol%nat,mol%at,mol%xyz) - if (individual_IDs .or. ii == 1) then + if (individual_IDs.or.ii == 1) then call sorters(ii)%init(mol,invtype='apsp+',heavy=.false.) end if if (ii == 1) then stereocheck = .not. (sorters(ii)%hasstereo(ref)) end if - if (individual_IDs .or. ii == 1) then + if (individual_IDs.or.ii == 1) then call sorters(ii)%shrink() end if end do @@ -1542,7 +1549,7 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) if (prlvl > 0) then call profiler%stop(1) call profiler%write_timing(stdout,1,'done.',.true.) - runtime = (profiler%get(1) / real(nall,wp)) * 1000.0_wp + runtime = (profiler%get(1)/real(nall,wp))*1000.0_wp write (stdout,'(1x,a,f0.3,a)') '* Corresponding to approximately ',runtime, & & ' ms per processed RMSD' write (stdout,*) @@ -1593,7 +1600,7 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) do ii = 1,nall !>--- find next unassigned conformer and assign a new group if (groups(ii) .ne. 0) cycle - gcount = gcount + 1 + gcount = gcount+1 groups(ii) = gcount !>--- Then, cross-check all other unassigned conformers @@ -1602,8 +1609,8 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) !$omp shared(workmols, structures, ii) & !$omp private(jj,rmsdval,cc) !$omp do schedule(dynamic) - do jj = ii + 1,nall - cc = omp_get_thread_num() + 1 + do jj = ii+1,nall + cc = omp_get_thread_num()+1 if (groups(jj) .ne. 0) cycle if (individual_IDs) then rcaches(cc)%rank(1:nat,1) = sorters(ii)%rank(1:nat) @@ -1706,7 +1713,7 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) do i = 1,ng k = 0 do j = 1,nall - if (group(j) == i) k = k + 1 + if (group(j) == i) k = k+1 end do if (k .gt. gmax) gmax = k end do @@ -1715,7 +1722,7 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) k = 0 do j = 1,nall if (group(j) == i) then - k = k + 1 + k = k+1 glist(k,i) = j !> the k-th member of group i is structure j end if end do @@ -1726,21 +1733,21 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) allocate (cdum(3,nat)) !>--- set up the "pair" array --> how many bonds are between two nuclei? - allocate (pair(n * (n + 1) / 2),metric(n,n),vis(n),pre(n),nb(200,n)) + allocate (pair(n*(n+1)/2),metric(n,n),vis(n),pre(n),nb(200,n)) !cdum(1:3,1:n) = xyz(1:3,1:n,1) / bohr cdum(1:3,1:n) = structures(1)%xyz(1:3,1:n) call neighdist(n,at,cdum,nb,metric) k = 0 pair = 0 - do i = 1,n - 1 - do j = i + 1,n + do i = 1,n-1 + do j = i+1,n !>---the shortest bond path current = j dum = shortest_distance(n,i,j,nb,metric,vis,pre) k = 0 do while (pre(current) /= 0) current = pre(current) - k = k + 1 + k = k+1 end do !> End loop: while precessor(current) /= 0 pair(lin(j,i)) = k !> # of bonds between i and j end do @@ -1757,7 +1764,7 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) call distance(n,structures(i)%xyz(:,:),dist(:,:,i)) !> distance matrix do j = 1,n do k = 1,n - tmp2(k) = dist(k,j,i) * dble(at(k)) !> the distance of j to all atoms * Z to distinguish + tmp2(k) = dist(k,j,i)*dble(at(k)) !> the distance of j to all atoms * Z to distinguish end do call qqsort(tmp2,1,n) dist(1:n,j,i) = tmp2(1:n) @@ -1771,7 +1778,7 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) do m1 = 1,m !$OMP PARALLEL PRIVATE ( m2, s1, s2 ) SHARED ( relat ) !$OMP DO - do m2 = 1,m1 - 1 !> compare all members + do m2 = 1,m1-1 !> compare all members s1 = glist(m1,i) !> struc 1 s2 = glist(m2,i) !> struc 2 call compare(n,nall,s1,s2,dist,athr,relat) !> athr is distance vector equivalence threshold @@ -1795,8 +1802,8 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) do k2 = 1,m2 if (j1 .eq. equiv(k2,iat,i)) ex = .true. end do - if (.not. ex) then - equiv(0,iat,i) = equiv(0,iat,i) + 1 + if (.not.ex) then + equiv(0,iat,i) = equiv(0,iat,i)+1 equiv(equiv(0,iat,i),iat,i) = j1 end if end do @@ -1817,7 +1824,7 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) cycle MLOOP end if end do M1LOOP - equiv(0,j,0) = equiv(0,j,0) + 1 !> append + equiv(0,j,0) = equiv(0,j,0)+1 !> append equiv(equiv(0,j,0),j,0) = k end do MLOOP end do JLOOP @@ -1849,7 +1856,7 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) do i = 1,n do j = 1,equiv(0,i,ig) k = equiv(j,i,ig) - elist(1:n,k) = elist(1:n,k) + elist(1:n,i) + elist(1:n,k) = elist(1:n,k)+elist(1:n,i) end do end do !>--- prepare write out @@ -1859,7 +1866,7 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) elist(i,i) = 0 do j = 1,n if (elist(j,i) .ne. 0) then - k = k + 1 + k = k+1 equiv(k,i,ig) = j end if end do @@ -1880,7 +1887,7 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) end if end do if (nmract(at(j)) .eq. 0) cycle - if (m .gt. 1 .and. jnd(j) .eq. 1) then ! just print + if (m .gt. 1.and.jnd(j) .eq. 1) then ! just print write (ch,'(''reference atom'',i4,'' # :'',i2)') equiv(1,j,ig),m do k = 1,m jnd(equiv(k,j,ig)) = 0 @@ -1909,7 +1916,7 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) l = equiv(k,i,ig) if (l .eq. i) cycle do j = 1,n - if (flist(j,i) .eq. 1 .or. nmract(at(j)) .eq. 0) cycle !> don't check non-magnetic nuclei + if (flist(j,i) .eq. 1.or.nmract(at(j)) .eq. 0) cycle !> don't check non-magnetic nuclei !c write(*,*) l,j,pair(lin(i,j)),pair(lin(l,j)) !> and chem. equiv. ones (ie in the same if (pair(lin(i,j)) .ne. pair(lin(l,j))) elist(l,i) = 0 !> group end do @@ -1922,7 +1929,7 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) elist(i,i) = 0 do j = 1,n if (elist(j,i) .ne. 0) then - k = k + 1 + k = k+1 equiv(k,i,ig) = j end if end do @@ -1931,7 +1938,7 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) do i = 1,n do j = 1,equiv(0,i,ig) k = equiv(j,i,ig) - elist(1:n,k) = elist(1:n,k) + elist(1:n,i) + elist(1:n,k) = elist(1:n,k)+elist(1:n,i) end do end do !>--- prepare write out @@ -1941,7 +1948,7 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) elist(i,i) = 0 do j = 1,n if (elist(j,i) .ne. 0) then - k = k + 1 + k = k+1 equiv(k,i,ig) = j end if end do @@ -1958,7 +1965,7 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) write (3,*) j,m write (3,'(20i5)') (equiv(l,j,ig),l=1,m) !> include the atom ie if there are no equiv. if (nmract(at(j)) .eq. 0) cycle - if (m .gt. 1 .and. jnd(j) .eq. 1) then !> just print + if (m .gt. 1.and.jnd(j) .eq. 1) then !> just print write (ch,'(''reference atom'',i4,'' # :'',i2)') equiv(1,j,ig),m do k = 1,m jnd(equiv(k,j,ig)) = 0 @@ -1971,7 +1978,7 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) !c J averaging matrix !ccccccccccccccccccccc if (rotfil) then - allocate (jfake(n * (n + 1) / 2),sd(n,n),cn(n)) + allocate (jfake(n*(n+1)/2),sd(n,n),cn(n)) atmp = 'anmr_rotamer' open (unit=112,file=atmp,form='unformatted') write (112) ng @@ -1984,15 +1991,15 @@ subroutine cregen_EQUAL(ch,nall,structures,group,athr,rotfil) call distance(n,structures(irr)%xyz(:,:),sd) !> distance matrix cdum(1:3,1:n) = structures(irr)%xyz(1:3,1:n) call calculate_CN(n,at,cdum,cn) - do i = 1,n - 1 - do j = i + 1,n - jfake(lin(j,i)) = cn(i) * cn(j) * sqrt(dble(at(i) * at(j))) & - & / (dble(pair(lin(j,i))) * sd(j,i)**5) !> the approx. "J" is topologically equivalent to J + do i = 1,n-1 + do j = i+1,n + jfake(lin(j,i)) = cn(i)*cn(j)*sqrt(dble(at(i)*at(j))) & + & /(dble(pair(lin(j,i)))*sd(j,i)**5) !> the approx. "J" is topologically equivalent to J !> R^3 was wrong in one case because Hs were artificially paired !> R^5 seems to be save end do end do - write (112) jfake(1:n * (n + 1) / 2) !> read by anmr + write (112) jfake(1:n*(n+1)/2) !> read by anmr end do end do close (112) @@ -2059,185 +2066,6 @@ subroutine cregen_nmract(ch,nmract) end subroutine cregen_nmract !=========================================================================================! - -subroutine cregen_repairorder(nat,nall,xyz,comments,group) -!*************************************************************** -!* subroutine cregen_repairorder -!* resort the ensemble to have groups grouped together -!* (can be important for small energy diff. between conformers) -!* On Input: ch - printout channel -!* nat - number of atoms -!* nall - number of structure in ensemble -!* xyz - Cartesian coordinates -!* comments - commentary lines containing the energy -!* group - to which group does every strucutre belong -!* On Output: resorted xyz and comments -!*************************************************************** - use crest_parameters,id => dp - use crest_data - use strucrd - use utilities - use quicksort_interface - implicit none - integer,intent(in) :: nat - integer,intent(in) :: nall - real(wp),intent(inout) :: xyz(3,nat,nall) - integer,intent(inout) :: group(0:nall) - character(len=*) :: comments(nall) - real(wp),allocatable :: cdum(:,:) - integer,allocatable :: order(:),orderref(:) - character(len=128) :: btmp - real(wp) :: edum - logical :: ttag - integer,allocatable :: timetag(:) - integer :: ng,tmax - integer :: i,j,k,l - - !>-- check if timetag info is present? - ttag = .false. - - ng = group(0) - allocate (order(nall),orderref(nall)) - !>-- determine new order - k = 0 - if (ttag) then - do i = 1,ng - do l = 1,tmax !>-- with timetag info - do j = 1,nall - if (group(j) .eq. i .and. timetag(j) .eq. l) then - k = k + 1 - orderref(k) = j - order(k) = i - end if - end do - end do - end do - else - do i = 1,ng - do j = 1,nall !>-- without timetag info - if (group(j) .eq. i) then - k = k + 1 - orderref(k) = j - order(k) = i - end if - end do - end do - end if - - !>-- sort xyz and comments - group(1:nall) = order(1:nall) - order = orderref - allocate (cdum(3,nat)) - call xyzqsort(nat,nall,xyz,cdum,order,1,nall) - deallocate (cdum) - order = orderref - !call stringqsort(nall,comments,1,nall,order) - call stringqsort(nall,len(comments(1)),comments,1,nall,order) - if (ttag) then - edum = grepenergy(comments(1)) - write (btmp,*) edum,'!t1' - comments(1) = trim(btmp) - end if - - deallocate (orderref,order) - if (allocated(timetag)) deallocate (timetag) - return -end subroutine cregen_repairorder - -!=========================================================================================! - -recursive subroutine xyzqsort(nat,nall,xyz,c0,ord,first,last) -!************************************************************* -!* recursive subroutine xyzqsort -!* A quicksort derivative for sorting an ensemble. -!* On Input: nat - number of atoms -!* nall - number of structures -!* xyz - the ensemble ( xyz(3,nat,nall) ) -!* c0 - a dummy coord field for sorting -!* ord - order of the ensemble ( ord(nall) ) -!* first - lower limit of sorting (nall dimension) -!* last - upperl limit of sorting (nall dimension) -!************************************************************* - use crest_parameters - implicit none - integer :: nat,nall - real(wp) :: xyz(3,nat,nall) - real(wp) :: c0(3,nat) - integer :: ord(nall) - integer :: first,last - integer :: x,t - integer :: i,j - x = ord((first + last) / 2) - i = first - j = last - do - do while (ord(i) < x) - i = i + 1 - end do - do while (x < ord(j)) - j = j - 1 - end do - if (i >= j) exit - t = ord(i); ord(i) = ord(j); ord(j) = t - c0(:,:) = xyz(:,:,i) - xyz(:,:,i) = xyz(:,:,j) - xyz(:,:,j) = c0(:,:) - i = i + 1 - j = j - 1 - end do - if (first < i - 1) call xyzqsort(nat,nall,xyz,c0,ord,first,i - 1) - if (j + 1 < last) call xyzqsort(nat,nall,xyz,c0,ord,j + 1,last) -end subroutine xyzqsort - -!=========================================================================================! - -subroutine maskedxyz(n,nm,c,cm,at,atm,mask) -!************************************************ -!* a small routine to get masked xyz coordinates -!************************************************ - use crest_parameters,only:wp - implicit none - integer,intent(in) :: n - integer,intent(in) :: nm - real(wp),intent(in) :: c(3,n) - real(wp),intent(out) :: cm(3,nm) - integer,intent(in) :: at(n) - integer,intent(out) :: atm(nm) - integer,intent(in) :: mask(n) - integer :: i,k - k = 1 - do i = 1,n - if (mask(i) .gt. 0) then - cm(1:3,k) = c(1:3,i) - atm(k) = at(i) - k = k + 1 - end if - end do - return -end subroutine maskedxyz -subroutine maskedxyz2(n,nm,c,cm,mask) -!************************************************ -!* a small routine to get masked xyz coordinates -!* version without at array -!************************************************ - use crest_parameters,only:wp - implicit none - integer,intent(in) :: n - integer,intent(in) :: nm - real(wp),intent(in) :: c(3,n) - real(wp),intent(out) :: cm(3,nm) - integer,intent(in) :: mask(n) - integer :: i,k - k = 1 - do i = 1,n - if (mask(i) .gt. 0) then - cm(1:3,k) = c(1:3,i) - k = k + 1 - end if - end do - return -end subroutine maskedxyz2 - !=========================================================================================! subroutine cregen_file_wr(env,fname,structures) @@ -2265,7 +2093,7 @@ subroutine cregen_file_wr(env,fname,structures) eref = structures(1)%energy do ii = 1,nall er(ii) = structures(ii)%energy - erel(ii) = (er(ii) - eref) * autokcal + erel(ii) = (er(ii)-eref)*autokcal !if (env%trackorigin) then ! call getorigin(comments(i),origin(i)) !end if @@ -2326,7 +2154,7 @@ subroutine cregen_conffile(env,cname,structures,ng,degen) open (newunit=ich,file=trim(cname)) do ii = 1,ng k = degen(2,ii) - if (k <= 0 .or. k > nall) cycle + if (k <= 0.or.k > nall) cycle call structures(k)%append(ich) if (env%enso) write (ichenso,'(2x,f18.8)') er(k) end do @@ -2422,7 +2250,7 @@ subroutine cregen_setthreads(ch,env,pr) call new_ompautoset(env,'max',0,T,Tn) !$OMP PARALLEL PRIVATE(TID) TID = OMP_GET_THREAD_NUM() - IF (TID .EQ. 0 .and. pr) THEN + IF (TID .EQ. 0.and.pr) THEN nproc = OMP_GET_NUM_THREADS() write (ch,*) '=============================' write (ch,*) ' # threads =',nproc @@ -2443,8 +2271,8 @@ subroutine cregen_pr1(ch,env,nat,nall,rthr,bthr,pthr,ewin) integer :: nall real(wp) :: rthr,bthr,pthr,ewin logical :: substruc - substruc = (nat .ne. env%rednat .and. env%subRMSD) - write (ch,'(75("*"))') + substruc = (nat .ne. env%rednat.and.env%subRMSD) + write (ch,'(80("*"))') write (ch,'(" number of atoms",t35,":",i10)') nat if (substruc) then write (ch,'(" atoms included in RMSD",t35,":",i10)') env%rednat @@ -2465,7 +2293,7 @@ subroutine enso_duplicates(env,nall,double) integer :: double(nall) integer :: i,j,ich - if (.not. env%ENSO .or. .not. env%confgo) return + if (.not.env%ENSO.or..not.env%confgo) return j = sum(double) open (newunit=ich,file='cregen.enso') @@ -2530,7 +2358,7 @@ subroutine cregen_pr2(ch,env,nall,ng,degen,er) env%elowest = eref do i = 1,nall !er(i) = grepenergy(comments(i)) - erel(i) = (er(i) - eref) * autokcal + erel(i) = (er(i)-eref)*autokcal !if (env%trackorigin) then ! call getorigin(comments(i),origin(i)) !else @@ -2545,8 +2373,8 @@ subroutine cregen_pr2(ch,env,nall,ng,degen,er) a = degen(2,i) b = degen(3,i) do j = a,b - pg(i) = pg(i) + p(j) - paccu(j) = paccu(j - 1) + p(j) + pg(i) = pg(i)+p(j) + paccu(j) = paccu(j-1)+p(j) end do end do @@ -2554,7 +2382,7 @@ subroutine cregen_pr2(ch,env,nall,ng,degen,er) abbrev = nall > printlimit !>-- really long energy list - write (och,'(75("*"))') + write (och,'(80("*"))') write (och,'(1x,a8,1x,a8,3(1x,a12),1x,a9,1x,a5)') & & ' ','ΔE','Etot','weight','conf.weight','conformer','' write (och,'(a8,1x,a8,3(1x,a12),1x,a9,1x,a5,1x,a6)') & @@ -2574,10 +2402,10 @@ subroutine cregen_pr2(ch,env,nall,ng,degen,er) print_placeholder = .true. k = 0 do i = 1,ng - k = k + 1 + k = k+1 a = degen(2,i) b = degen(3,i) - if (k <= printlimit .or. k > nall - 10) then + if (k <= printlimit.or.k > nall-10) then write (och,'(i8,1x,f8.4,1x,f12.6,2(1x,f12.5),1x,i9,1x,i5,a)') & & a,erel(a),er(a),p(a),pg(i),i,degen(1,i),trim(origin(a)) else if (print_placeholder) then @@ -2589,9 +2417,9 @@ subroutine cregen_pr2(ch,env,nall,ng,degen,er) & a,erel(a),er(a),p(a),pg(i),i,degen(1,i),trim(origin(a)) end if ! if (.not. env%entropic) then - do j = a + 1,b - k = k + 1 - if (k <= printlimit .or. k > nall - 10) then + do j = a+1,b + k = k+1 + if (k <= printlimit.or.k > nall-10) then write (och,'(i8,1x,f8.4,1x,f12.6,1x,f12.5,1x,a12,1x,a9,1x,a5,1x,a)') & & k,erel(j),er(j),p(j),'.','.','.',trim(origin(j)) else if (print_placeholder) then @@ -2619,60 +2447,61 @@ subroutine cregen_pr2(ch,env,nall,ng,degen,er) A0 = 0 eav = 0 do i = 1,nall - A0 = A0 + p(i) * log(p(i) + 1.d-12) - eav = eav + p(i) * erel(i) + A0 = A0+p(i)*log(p(i)+1.d-12) + eav = eav+p(i)*erel(i) end do - beta = 1.0d0 / (T * 8.314510 / 4.184 / 1000.+1.d-14) - g = (1.0d0 / beta) * A0 - s = -1000.0d0 * 4.184 * g / T - ss = -1000.0d0 * g / T + beta = 1.0d0/(T*8.314510/4.184/1000.+1.d-14) + g = (1.0d0/beta)*A0 + s = -1000.0d0*4.184*g/T + ss = -1000.0d0*g/T - write (och,'(75("*"))') + write (och,'(80("*"))') write (och,'("Statistics for *THIS* ensemble:")') write (och,'(35("-"))') - write (och,'(" Temperature used for populations",t40,":", F9.2," K")') T - write (och,'(" Energy of lowest structure",t40,":",es14.6)') eref + write (och,'(" Number of groups & total",t42,":",2x, i9,", ",i0)') ng,nall + write (och,'(" Temperature used for populations",t42,":",2x,F9.2," K")') T + write (och,'(" Energy of lowest structure",t42,":",2x,es14.6)') eref !>---- elow printout in between routines - if (.not. env%confgo) then - write (stdout,'("CREGEN> E lowest :",f12.5)') eref + if (.not.env%confgo) then + write (stdout,'("CREGEN> E lowest :",f20.10,a)') eref,' Ha' end if - write (och,'(" Ensemble average energy (kcal/mol)",t40,":",F14.8)') eav + write (och,'(" Ensemble average energy (kcal/mol)",t42,":",2x,F14.8)') eav if (env%QCG) then - write (och,'(" Ensemble entropy (cal/mol K)",t40,":",F14.8)') ss + write (och,'(" Ensemble entropy (cal/mol K)",t42,":",2x,F14.8)') ss else - write (och,'(" Ensemble entropy (J/mol K, cal/mol K)",t40,":",2F9.3)') s,ss + write (och,'(" Ensemble entropy (J/mol K, cal/mol K)",t42,":",2x,2F9.3)') s,ss end if - write (och,'(" Ensemble free energy (kcal/mol)",t40,":",F14.8)') g - write (och,'(" Population of lowest strucure",t40,":",F9.3," %")') pg(1) * 100.d0 - write (och,'(" Highest population & group",t40,":",F9.3," %, ",i0)') maxval(pg,1) * 100.d0,maxloc(pg,1) + write (och,'(" Ensemble free energy (kcal/mol)",t42,":",2x,F14.8)') g + write (och,'(" Population of lowest strucure",t42,":",2x,F9.3," %")') pg(1)*100.d0 + write (och,'(" Highest population & group",t42,":",2x,F9.3," %, ",i0)') maxval(pg,1)*100.d0,maxloc(pg,1) j = min(10,ng) i = degen(3,j) - write (och,'(" Accum.population of lowest 10 groups",t40,":",F9.3," %")') paccu(i) * 100.d0 + write (och,'(" Accum.population of lowest 10 groups",t42,":",2x,F9.3," %")') paccu(i)*100.d0 do i = 1,ng j = degen(3,i) if (paccu(j) >= 0.95_wp) exit end do - write (och,'(" 95% accum.population for groups",t40,":",4x,"1 - ",i0)') i + write (och,'(" 95% accum.population for groups",t42,":",6x,"1 - ",i0)') i !>-- some ensemble data, entropy and G (including only unique conformers) allocate (egrp(ng),source=0.0_wp) do i = 1,ng a = degen(2,i) - egrp(i) = (er(a) - eref) * autokcal + egrp(i) = (er(a)-eref)*autokcal end do call boltz(ng,T,egrp,pg) A0 = 0 do i = 1,ng - A0 = A0 + pg(i) * log(pg(i) + 1.d-12) + A0 = A0+pg(i)*log(pg(i)+1.d-12) end do deallocate (egrp) - beta = 1.0d0 / (T * 8.314510 / 4.184 / 1000.+1.d-14) - g = (1.0d0 / beta) * A0 - ss = -1000.0d0 * g / T + beta = 1.0d0/(T*8.314510/4.184/1000.+1.d-14) + g = (1.0d0/beta)*A0 + ss = -1000.0d0*g/T env%emtd%sapprox = ss !> save for entropy mode - write (och,'(75("*"))') + write (och,'(80("*"))') deallocate (paccu,pg) deallocate (p,erel,origin) @@ -2690,14 +2519,14 @@ subroutine cregen_econf_list(ch,nall,er,ng,degen) integer :: ich2,i,j real(wp) :: eref,ewrt - write (ch,'(a,i0)') 'number of unique conformers for further calculation: ',ng - write (ch,'(a)') 'list of relative energies (kcal/mol) saved as "crest.energies"' + write (ch,'(a,i0)') 'Number of unique conformers for further calculation: ',ng + write (ch,'(a)') 'List of relative energies (kcal/mol) saved as "crest.energies"' open (newunit=ich2,file='crest.energies') eref = minval(er,1) do i = 1,ng j = degen(2,i) - ewrt = er(j) - eref - ewrt = ewrt * autokcal + ewrt = er(j)-eref + ewrt = ewrt*autokcal write (ich2,'(i10,1x,f12.4,es20.10)') i,ewrt,er(i) end do close (ich2) @@ -2725,7 +2554,7 @@ subroutine cregen_pr3(ch,infile,nall,er) eref = minval(er,1) !write (ch,'('' structure ΔE(kcal/mol) Etot(Eh)'')') do i = 1,nall - dE = (er(i) - eref) * autokcal + dE = (er(i)-eref)*autokcal write (ch,'(i10,3x,F15.4,F25.10)') i,dE,er(i) end do write (ch,*) diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index d82f419a..ee5e7940 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -455,6 +455,7 @@ subroutine rmsd_align(ref,mol,mask) nn = ref%nat if (present(mask)) nn = count(mask) shift = cref-cmol + shift = shift/nn do ii = 1,mol%nat mol%xyz(:,ii) = mol%xyz(:,ii)+shift(:) end do From 39bbf90bb1464f2c2dc04dce9fdeb600a1ea0ec5 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 11 Feb 2026 16:16:02 +0100 Subject: [PATCH 172/374] parallelization in reconstruction, cregen printout changes --- src/algos/queueing.f90 | 53 +++++++++++++++++++++++++++----- src/sorting/cregen.f90 | 59 +++++++++++++++++++++++++++++------- src/sorting/irmsd_module.f90 | 12 +++++++- 3 files changed, 104 insertions(+), 20 deletions(-) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 3c0ff827..9f26e696 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -530,6 +530,7 @@ subroutine crest_queue_reconstruct(env,tim) contains recursive subroutine recusrive_construct(env,heap,targetlayer) use irmsd_module,only:irmsd,rmsd,rmsd_cache,rmsd_core_cache + use omp_lib implicit none type(systemdata),intent(inout) :: env type(construct_heap),intent(inout) :: heap @@ -547,7 +548,10 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) logical :: ex,clash,duplicate real(wp) :: RTHR,rmsval,ETHR,deltaE type(rmsd_cache) :: rcache - type(rmsd_core_cache) :: ccache + type(rmsd_core_cache),allocatable :: ccache(:) + real(wp),allocatable :: xyzscratch(:,:,:,:) + logical,allocatable :: mask(:) + integer :: T,Tn,tt character(len=*),parameter :: subdir_tmp = 'crest_queue_' character(len=:),allocatable :: subdirfile @@ -642,8 +646,18 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) RTHR = env%rthr*aatoau !> RMSD threshold in Bohr ETHR = env%ethr/autokcal !> deltaE threshold in hartree duplicates = 0 - call ccache%allocate(layer%refmol%nat) - write (stdout,'(2x,a)',advance='no') 'Recombining under RMSD consideration (this may take a while) ... ' + T = 1 + call new_ompautoset(env,'max',kk,T,Tn) + write (stdout,'(2x,a,i0)') 'OpenMP threads : ',T + allocate (ccache(T)) + allocate (mask(layer%refmol%nat),source=.true.) + do tt = 1,T + call ccache(tt)%allocate(layer%refmol%nat,scratch=.true.) + end do + do ii = 1,layer%refmol%nat + if (layer%refmol%at(ii) == 1) mask(ii) = .false. + end do + write (stdout,'(2x,a)',advance='no') 'Recombining under heavy-atom RMSD consideration (this may take a while) ... ' flush (stdout) !> NOTE: @@ -687,18 +701,30 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) if (.not.clash) then !> check for duplicates duplicate = .false. + + !$omp parallel & + !$omp shared(duplicate,duplicates,mol,ccache,mask,ETHR) & + !$omp private(rr,tt,deltaE,rmsval) + !$omp do schedule(dynamic) rrloop: do rr = 2,layer%nmols + if (duplicate) cycle + tt = omp_get_thread_num()+1 deltaE = abs(mol%energy-layer%mols(rr)%energy) if (deltaE < ETHR) then ! rmsval = irmsd(layer%mols(rr),mol,rcache=rcache,topocheck=.false.,allcanon=.true.) - rmsval = rmsd(layer%mols(rr),mol,ccache=ccache) - if (rmsval < RTHR) then + rmsval = rmsd(layer%mols(rr),mol,ccache=ccache(tt),mask=mask) + !$omp critical + if (rmsval < RTHR.and..not.duplicate) then duplicate = .true. duplicates = duplicates+1 - exit rrloop + !exit rrloop end if + !$omp end critical end if end do rrloop + !$omp end do + !$omp end parallel + if (.not.duplicate) then layer%nmols = layer%nmols+1 layer%mols(layer%nmols) = mol @@ -740,18 +766,29 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) if (.not.clash) then !> check for duplicates duplicate = .false. + + !$omp parallel & + !$omp shared(duplicate,duplicates,mol,ccache,mask,ETHR) & + !$omp private(rr,tt,deltaE,rmsval) + !$omp do schedule(dynamic) rrloop2: do rr = 2,layer%nmols + if (duplicate) cycle + tt = omp_get_thread_num()+1 deltaE = abs(mol%energy-layer%mols(rr)%energy) if (deltaE < ETHR) then ! rmsval = irmsd(layer%mols(rr),mol,rcache=rcache,topocheck=.false.,allcanon=.true.) - rmsval = rmsd(layer%mols(rr),mol,ccache=ccache) + rmsval = rmsd(layer%mols(rr),mol,ccache=ccache(tt),mask=mask) + !$omp critical if (rmsval < RTHR) then duplicate = .true. duplicates = duplicates+1 - exit rrloop2 + !exit rrloop2 end if + !$omp end critical end if end do rrloop2 + !$omp end do + !$omp end parallel if (.not.duplicate) then layer%nmols = layer%nmols+1 layer%mols(layer%nmols) = mol diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 79595ad7..e43f6b19 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -253,7 +253,7 @@ subroutine newcregen(env,quickset,infile,structurelist) if (pr3) then !> alternative to pr2 call cregen_pr3(prch,oname,nall,er) end if - if (pr4) then !> group dara printout + if (pr4) then !> group data printout call cregen_pr4(prch,fname,nall,group) end if @@ -267,12 +267,12 @@ subroutine newcregen(env,quickset,infile,structurelist) call move_alloc(structures,structurelist) end if - if(newfile)then - write(prch,'(a,a)') 'Full ensemble file written to: ',trim(oname) - endif - if(conffile)then - write(prch,'(a,a)') 'Unique-structure file written to: ',trim(cname) - endif + if (newfile) then + write (prch,'(a,a)') 'Full ensemble file written to: ',trim(oname) + end if + if (conffile) then + write (prch,'(a,a)') 'Unique-structure file written to: ',trim(cname) + end if !>--- deallocate data if (prch .ne. stdout) then @@ -1460,7 +1460,7 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) integer,intent(in),optional :: printlvl !> LOCAL - integer :: i,j,ii,jj,T,Tn,nallpairs,cc,nat + integer :: i,j,ii,jj,T,Tn,nallpairs,cc,nat,k integer :: gcount integer :: prlvl,iunit type(rmsd_cache),allocatable :: rcaches(:) @@ -1472,8 +1472,12 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) real(wp) :: rmsdval,runtime,RTHR logical :: stereocheck,individual_IDs type(timer) :: profiler + integer :: ng + integer,allocatable :: group(:),degen(:,:) + real(wp),allocatable :: er(:) + type(coord),allocatable :: structures_new(:) - logical,parameter :: debug = .true. + logical,parameter :: debug = .false. !>--- handle optional arguments if (present(allcanon)) then @@ -1592,7 +1596,7 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) !>--- run the checks if (prlvl > 0) then - write (stdout,'(a)',advance='no') 'CREGEN> Running all pair RMSDs ... ' + write (stdout,'(a)',advance='no') 'CREGEN> Running all-pair iRMSDs ... ' flush (stdout) call profiler%start(2) end if @@ -1642,6 +1646,39 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) end do end if + allocate (group(0:nall),source=0) + allocate (structures_new(nall)) + ng = maxval(groups(:)) + k = 0 + do ii = 1,ng + do jj = 1,nall + if (groups(jj) == ii) then + k = k+1 + group(k) = ii + structures_new(k) = structures(jj) + end if + end do + end do + group(0) = maxval(groups(:)) + allocate (degen(3,ng)) + call cregen_groupinfo(nall,ng,group,degen) + allocate (er(nall)) + do ii = 1,nall + er(ii) = structures_new(ii)%energy + structures(ii) = structures_new(ii) + end do + if (prlvl > 0) then + call cregen_pr2(stdout,env,nall,ng,degen,er) + call cregen_econf_list(stdout,nall,er,ng,degen) + end if + if (prlvl > 1) then + write (stdout,'(a,a)') 'Unique-structure file written to: ',ensemblefile + block + use cregen_subroutines,only:cregen_conffile + call cregen_conffile(env,ensemblefile,structures,ng,degen) + end block + end if + end subroutine cregen_irmsd_sort !=========================================================================================! @@ -2458,7 +2495,7 @@ subroutine cregen_pr2(ch,env,nall,ng,degen,er) write (och,'(80("*"))') write (och,'("Statistics for *THIS* ensemble:")') write (och,'(35("-"))') - write (och,'(" Number of groups & total",t42,":",2x, i9,", ",i0)') ng,nall + write (och,'(" Number of groups & total",t42,":",2x, i9,", ",i0)') ng,nall write (och,'(" Temperature used for populations",t42,":",2x,F9.2," K")') T write (och,'(" Energy of lowest structure",t42,":",2x,es14.6)') eref !>---- elow printout in between routines diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index ee5e7940..5c73daba 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -29,6 +29,7 @@ module irmsd_module real(wp),allocatable :: y(:,:) real(wp),allocatable :: xi(:) real(wp),allocatable :: yi(:) + real(wp),allocatable :: xyzscratch(:,:,:) contains procedure :: allocate => allocate_rmsd_core_cache end type rmsd_core_cache @@ -114,10 +115,11 @@ module irmsd_module !========================================================================================! !========================================================================================! - subroutine allocate_rmsd_core_cache(self,nat) + subroutine allocate_rmsd_core_cache(self,nat,scratch) implicit none class(rmsd_core_cache),intent(inout) :: self integer,intent(in) :: nat + logical,intent(in),optional :: scratch if (allocated(self%x)) deallocate (self%x) if (allocated(self%y)) deallocate (self%y) if (allocated(self%xi)) deallocate (self%xi) @@ -126,6 +128,12 @@ subroutine allocate_rmsd_core_cache(self,nat) allocate (self%yi(nat),source=0.0_wp) allocate (self%x(3,nat),source=0.0_wp) allocate (self%y(3,nat),source=0.0_wp) + if(present(scratch))then + if(scratch)then + if(allocated(self%xyzscratch)) deallocate(self%xyzscratch) + allocate(self%xyzscratch(3,nat,2),source=0.0_wp) + endif + endif end subroutine allocate_rmsd_core_cache subroutine allocate_rmsd_cache(self,nat) @@ -255,6 +263,8 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient,ccache) result(rmsdval) !> scratch workspace to use? if (present(scratch)) then scratchptr => scratch + else if(allocated(ccptr%xyzscratch))then + scratchptr => ccptr%xyzscratch else allocate (tmpscratch(3,nat,2)) scratchptr => tmpscratch From 03903e8048e272f89f77a0423b63175ad2987b94 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 11 Feb 2026 16:31:06 +0100 Subject: [PATCH 173/374] More cregen printout changes --- src/algos/sorting.f90 | 2 +- src/sorting/cregen.f90 | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/src/algos/sorting.f90 b/src/algos/sorting.f90 index d928eb47..b1592793 100644 --- a/src/algos/sorting.f90 +++ b/src/algos/sorting.f90 @@ -59,6 +59,7 @@ subroutine crest_sort(env,tim) end select write (stdout,*) + env%confgo = .true. !========================================================================================! call tim%start(11,'Sorting') @@ -93,7 +94,6 @@ subroutine crest_sort(env,tim) case ('cregen') !>--- the original CREGEN procedure (fallback, needs nicer implementations) - env%confgo = .true. call newcregen(env,structurelist=structures) call catdel('cregen.out.tmp') diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index e43f6b19..ed8d8f1a 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -1449,6 +1449,7 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) use canonical_mod use irmsd_module use utilities,only:lin + use quicksort_interface use omp_lib implicit none !> INPUT @@ -1519,6 +1520,12 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) write (stdout,*) end if +!>--- sorting by energy + write (stdout,'(a)',advance='no') 'CREGEN> Sorting ensemble by energy ... ' + flush (stdout) + call ensemble_qsort(nall,structures,1,nall) + write (stdout,'(a)') 'done.' + !>--- Set up atom identities (either for all, or just the first structure) if (individual_IDs) then allocate (sorters(nall)) From 11267e0a5295172cb783b433e27c518f241db1ef Mon Sep 17 00:00:00 2001 From: LukasRindt Date: Thu, 12 Feb 2026 15:51:35 +0100 Subject: [PATCH 174/374] deform opt hess fixed finally --- src/algos/deform_opt_hess.f90 | 4 +++- src/calculator/calculator.F90 | 2 +- src/calculator/hr_utils.f90 | 1 + 3 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/algos/deform_opt_hess.f90 b/src/algos/deform_opt_hess.f90 index 0b9f1dcd..afc2cedf 100644 --- a/src/algos/deform_opt_hess.f90 +++ b/src/algos/deform_opt_hess.f90 @@ -53,8 +53,10 @@ subroutine deform_opt_hess(calc,mol) idx = minloc(calc%chess%order,1) if (minval(calc%chess%order) .eq. 0) idx = 1 + + write(stdout,*)calc%chess%coords(idx,:,:) - molnew%xyz(:,:) - call initialize_hessian(calc,calc%chess%initialize_type,calc%chess%coords(idx,:,:),mol_reopt%nat,mol_reopt%at,calc%chess%hess(:),calc%chess%hguess,pr) !> This hguess is set through the hguess variable of the optimizer and needs to be hardcoded/set explicitly before initialization for benchmarking!! + call initialize_hessian(calc,calc%chess%initialize_type,molnew%xyz,molnew%nat,molnew%at,calc%chess%hess(:),calc%chess%hguess,pr) !> This hguess is set through the hguess variable of the optimizer and needs to be hardcoded/set explicitly before initialization for benchmarking!! call dhtosq(nat3,H_init,calc%chess%hess) !> maybe this should all be inside the construct bfgs function later? -> cannot due to circular import!!! write(stdout,*) !> Hessian type (gfnff,mod,identity) is set through input file and is already encoded into the calc object write(stdout,*)"THERMO FROM INITIALIZED HESSIAN:" diff --git a/src/calculator/calculator.F90 b/src/calculator/calculator.F90 index 1c5dbdc5..f0acdf33 100644 --- a/src/calculator/calculator.F90 +++ b/src/calculator/calculator.F90 @@ -301,7 +301,7 @@ subroutine engrad_mol(mol,calc,energy,gradient,iostatus) !>--- Hessian Reconstruct !********************************************** - if (calc%do_HR .and. allocated(calc%chess) .and. calc%chess%track_step) then + if ((calc%do_HR .or. calc%deform_opt_hess) .and. allocated(calc%chess) .and. calc%chess%track_step) then call calc%chess%update(gradient,energy,mol%xyz) write(stdout,*) "HESSIAN CASH UPDATED" end if diff --git a/src/calculator/hr_utils.f90 b/src/calculator/hr_utils.f90 index 29c611e7..13df966e 100644 --- a/src/calculator/hr_utils.f90 +++ b/src/calculator/hr_utils.f90 @@ -63,6 +63,7 @@ subroutine initialize_hessian(calc,type,xyz,nat,at,hess,hguess,pr) !>Matrix is f end if case (1) !$omp critical + write(stdout,*) calc%calcs(1)%chrg call clevel%create('gfnff',chrg=calc%calcs(1)%chrg,uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? call newcalc%add(clevel) !$omp end critical From bb81f8c76b19fc68a2b1da1adadf4bf34a18be1b Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 12 Feb 2026 23:48:56 +0100 Subject: [PATCH 175/374] Fix zmat-issue, prettify some printouts --- src/algos/queueing.f90 | 27 +++++++++++++++++++++------ src/molbuilder/analyze.f90 | 26 +++++++++++++++++++++++++- src/molbuilder/classify_type.f90 | 22 ++++++++++++++-------- src/sorting/cregen.f90 | 2 +- 4 files changed, 61 insertions(+), 16 deletions(-) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 9f26e696..9b116044 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -496,7 +496,7 @@ subroutine crest_queue_reconstruct(env,tim) deallocate (env%splitheap%layer) deallocate (env%splitheap%queue) - write (stdout,'(/,1x,a)') 'Wrting reconstructed structures to: "'//recfile//'"' + write (stdout,'(/,1x,a)') 'Writing reconstructed structures to: "'//recfile//'"' call wrensemble(recfile,nall,structures) write (stdout,*) @@ -552,10 +552,12 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) real(wp),allocatable :: xyzscratch(:,:,:,:) logical,allocatable :: mask(:) integer :: T,Tn,tt + type(timer) :: profiler character(len=*),parameter :: subdir_tmp = 'crest_queue_' character(len=:),allocatable :: subdirfile character(len=10) :: atmp + character(len=60) :: btmp associate (layer => heap%layer(targetlayer)) if (layer%nnodes > 2) then @@ -634,12 +636,12 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) write (stdout,'(a,i0)') 'Reconstructing layer : ',targetlayer write (stdout,'(2x,a,i0)') 'Base structures : ',nall_b write (stdout,'(2x,a,i0)') 'Side chain structures : ',nall_s - write (stdout,'(2x,a,i0)') 'Max. combinations : ',nall_b*nall_s + write (stdout,'(2x,a,es9.2)') 'Max. combinations : ',real(nall_b,wp)*real(nall_s,wp) write (stdout,'(2x,a,f7.5,a)') 'Similarity threshold : ',env%rthr,' Å' write (stdout,'(2x,a,f7.5,a)') 'ΔE threshold (ETHR) : ',env%ethr,' kcal/mol' layer%nmols = 0 - kk = min(nall_b*nall_s,env%queue_maxreconstruct) + kk = nint(min(real(nall_b,wp)*real(nall_s,wp),real(env%queue_maxreconstruct,wp))) allocate (layer%mols(kk)) write (stdout,'(2x,a,i0)') 'Max. new structs stored : ',kk @@ -657,8 +659,11 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) do ii = 1,layer%refmol%nat if (layer%refmol%at(ii) == 1) mask(ii) = .false. end do - write (stdout,'(2x,a)',advance='no') 'Recombining under heavy-atom RMSD consideration (this may take a while) ... ' - flush (stdout) + write (stdout,'(2x,a)') 'Recombining under heavy-atom RMSD consideration (this may take a while) ... ' + call crest_oloop_pr_progress(env,kk,0) + + call profiler%init(1) + call profiler%start(1) !> NOTE: !> we want a balanced amount of combinations, sourcing @@ -728,6 +733,7 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) if (.not.duplicate) then layer%nmols = layer%nmols+1 layer%mols(layer%nmols) = mol + call crest_oloop_pr_progress(env,kk,layer%nmols) if (layer%nmols == kk) exit sssloop end if end if @@ -792,6 +798,7 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) if (.not.duplicate) then layer%nmols = layer%nmols+1 layer%mols(layer%nmols) = mol + call crest_oloop_pr_progress(env,kk,layer%nmols) if (layer%nmols == kk) exit sssloop2 end if end if @@ -799,11 +806,19 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) end do jjloop2 end do sssloop2 end if - write (stdout,'(a)') 'done.' + if (layer%nmols < kk) then + call crest_oloop_pr_progress(env,1,1) + end if + !call crest_oloop_pr_progress(env,kk,-1) + write (stdout,'(2x,a)') 'done!' if (duplicates > 0) then write (stdout,'(2x,a,i0)') 'Avoided duplicates : ',duplicates end if write (stdout,'(2x,a,i0)') 'Successful combinations : ',layer%nmols + call profiler%stop(1) + write (btmp,'(2x,a)') 'Total runtime for recombination step:' + call profiler%write_timing(stdout,1,trim(btmp),.true.) + write (stdout,*) end associate end subroutine recusrive_construct diff --git a/src/molbuilder/analyze.f90 b/src/molbuilder/analyze.f90 index 99c26751..83b022e2 100644 --- a/src/molbuilder/analyze.f90 +++ b/src/molbuilder/analyze.f90 @@ -142,7 +142,7 @@ subroutine rigidconf_count_fallback(nat,na,nb,nc,A,ndieder,ztod) end subroutine rigidconf_count_fallback !========================================================================================! - subroutine prune_zmat_dihedrals(mol,zmat,na,nb,nc,ztod) + subroutine prune_zmat_dihedrals(mol,zmat,na,nb,nc,ztod,hpyrad,bond) !******************************************************** !* Remove zmat entries that correspond !* to the same bond and replace them with internal @@ -154,6 +154,8 @@ subroutine prune_zmat_dihedrals(mol,zmat,na,nb,nc,ztod) real(wp),intent(inout) :: zmat(3,mol%nat) integer,intent(inout) :: na(mol%nat),nb(mol%nat),nc(mol%nat) integer,intent(inout) :: ztod(mol%nat) + logical,intent(in),optional :: hpyrad + integer,intent(in),optional :: bond(mol%nat,mol%nat) integer :: i,j,k,l integer :: maxgroup,nmembers,refi @@ -186,6 +188,28 @@ subroutine prune_zmat_dihedrals(mol,zmat,na,nb,nc,ztod) end if end do end do + if (present(hpyrad).and.present(bond)) then + if (hpyrad) then + k = maxgroup + iloop : do i=1,nat + !> select H entries with full zmat entries (to avoid collaps) + if(at(i) .eq. 1 .and.nc(i).ne.0)then + refi=na(i) + do j=1,nat + if(at(j).eq.1) cycle + !> search to replace the dihedral with a pyramidal angle + if(bond(j,refi) > 0 .and. .not.(nb(i)==j))then + nc(i) = j + call DIHED2(xyz,i,na(i),nb(i),nc(i),zmat(3,i)) + k = k + 1 + ztod(i) = k + cycle iloop + endif + enddo + endif + enddo iloop + end if + end if end associate end subroutine prune_zmat_dihedrals diff --git a/src/molbuilder/classify_type.f90 b/src/molbuilder/classify_type.f90 index 2cea3144..0eeb54c4 100644 --- a/src/molbuilder/classify_type.f90 +++ b/src/molbuilder/classify_type.f90 @@ -327,17 +327,19 @@ subroutine coord_classify_calculate_zmat(molc,natural) call BETTER_XYZINT(molc%nat,molc%xyz,molc%bond, & & molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3),molc%zmat) + allocate (molc%ztod(molc%nat),source=0) + call rigidconf_count_fallback(molc%nat, & + & molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3), & + & molc%bond,molc%ndieder,molc%ztod) if (present(natural)) then if (natural) then - allocate (molc%ztod(molc%nat),source=0) - call rigidconf_count_fallback(molc%nat, & - & molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3), & - & molc%bond,molc%ndieder,molc%ztod) + call prune_zmat_dihedrals(molc,molc%zmat, & + & molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3),molc%ztod, & + hpyrad=.true., bond=molc%bond) + !call molc%print_zmat(stdout) + call coord_classify_hatsort_restore(molc) + deallocate (molc%hatsort) end if - !call molc%print_zmat(stdout) - call prune_zmat_dihedrals(molc,molc%zmat, & - & molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3),molc%ztod) - call coord_classify_hatsort_restore(molc) end if end subroutine coord_classify_calculate_zmat @@ -355,6 +357,10 @@ subroutine coord_classify_reconstruct_from_zmat(molc,mol) & molc%xyz, & & molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3)) + !if (allocated(molc%hatsort)) then + ! call coord_classify_hatsort_restore(molc) + ! deallocate (molc%hatsort) + !end if if (present(mol)) then mol = molc%as_coord() end if diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index ed8d8f1a..8b82f022 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -2502,7 +2502,7 @@ subroutine cregen_pr2(ch,env,nall,ng,degen,er) write (och,'(80("*"))') write (och,'("Statistics for *THIS* ensemble:")') write (och,'(35("-"))') - write (och,'(" Number of groups & total",t42,":",2x, i9,", ",i0)') ng,nall + write (och,'(" Number of groups & total",t42,":",2x, i0,", ",i0)') ng,nall write (och,'(" Temperature used for populations",t42,":",2x,F9.2," K")') T write (och,'(" Energy of lowest structure",t42,":",2x,es14.6)') eref !>---- elow printout in between routines From c8e13fa8b5955786e67e39ebf69961de4a230695 Mon Sep 17 00:00:00 2001 From: LukasRindt Date: Wed, 18 Feb 2026 11:33:53 +0100 Subject: [PATCH 176/374] g_sampling added --- src/calculator/calc_type.f90 | 2 ++ src/calculator/calculator.F90 | 2 +- src/calculator/hessian_reconstruct.f90 | 14 ++++------- src/entropy/thermochem_module.f90 | 2 ++ src/optimize/ancopt.f90 | 2 +- src/optimize/newton_raphson.f90 | 4 ++-- src/optimize/optimize_module.f90 | 32 +++++++++++++++++++++----- src/optimize/optutils.f90 | 7 +++--- src/optimize/rfo.f90 | 4 ++-- src/parsing/parse_calcdata.f90 | 8 ++++++- 10 files changed, 51 insertions(+), 26 deletions(-) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index f5dbcc71..738b2af8 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -285,6 +285,8 @@ module calc_type integer :: hr_hu_type = 0 logical :: deform_opt_hess = .false. real(wp) :: doh_stepsize = 0.10_wp !>stepsize for the deformation/reoptimization hessian generation + real(wp) :: chess_id_guess = 0.1_wp + logical :: g_sampling = .false. !>Do sampling on free energy surface as approximated using the lindh95 hessian !>--- Parameters for smooth function within optimizer real(wp) :: L = 1.50_wp diff --git a/src/calculator/calculator.F90 b/src/calculator/calculator.F90 index f0acdf33..a244e2fa 100644 --- a/src/calculator/calculator.F90 +++ b/src/calculator/calculator.F90 @@ -303,7 +303,7 @@ subroutine engrad_mol(mol,calc,energy,gradient,iostatus) if ((calc%do_HR .or. calc%deform_opt_hess) .and. allocated(calc%chess) .and. calc%chess%track_step) then call calc%chess%update(gradient,energy,mol%xyz) - write(stdout,*) "HESSIAN CASH UPDATED" + !write(stdout,*) "HESSIAN CASH UPDATED" end if return diff --git a/src/calculator/hessian_reconstruct.f90 b/src/calculator/hessian_reconstruct.f90 index 34a7f1b9..20db7311 100644 --- a/src/calculator/hessian_reconstruct.f90 +++ b/src/calculator/hessian_reconstruct.f90 @@ -85,10 +85,9 @@ subroutine construct_hessian(self) integer :: i,j,k,nat3 real(wp),allocatable :: tmp(:),tmp_coords(:,:),tmp_grads(:,:),dx(:) real(wp) :: gnorm - integer :: unit,iter,made_iters,update_iteration + integer :: unit,iter,made_iters nat3 = 3*self%natm - update_iteration = 0 allocate (tmp_coords(self%steps,nat3)) allocate (tmp_grads(self%steps,nat3)) @@ -124,10 +123,10 @@ subroutine construct_hessian(self) j = minloc(tmp,1) !> This only happens if made_iters>steps if (j == 1) then !> => Not affected if too many steps requested dx = tmp_coords(j,:)-tmp_coords(self%steps,:) - call update_hessian(nat3,gnorm,tmp_grads(j,:),tmp_grads(self%steps,:),dx,self%hess(:),self%hu_type,update_iteration) + call update_hessian(nat3,gnorm,tmp_grads(j,:),tmp_grads(self%steps,:),dx,self%hess(:),self%hu_type) else dx = tmp_coords(j,:)-tmp_coords(j-1,:) - call update_hessian(nat3,gnorm,tmp_grads(j,:),tmp_grads(j-1,:),dx,self%hess(:),self%hu_type,update_iteration) + call update_hessian(nat3,gnorm,tmp_grads(j,:),tmp_grads(j-1,:),dx,self%hess(:),self%hu_type) end if tmp(j) = HUGE(tmp(j)) end if @@ -137,7 +136,7 @@ subroutine construct_hessian(self) end subroutine construct_hessian - subroutine update_hessian(nat3,gnorm,grd1,gold,dx,hess,hu_type,iter) + subroutine update_hessian(nat3,gnorm,grd1,gold,dx,hess,hu_type) !============================================== !Wrapper for hessian update scheme selection !============================================== @@ -146,13 +145,8 @@ subroutine update_hessian(nat3,gnorm,grd1,gold,dx,hess,hu_type,iter) real(wp),intent(in) :: dx(:), grd1(:),gold(:) real(wp),intent(in) :: gnorm real(wp),intent(inout) :: hess(:) - integer,intent(inout) :: iter integer,intent(in) :: hu_type - iter = iter +1 - - write(stdout,*) "Hessian updated", iter - select case (hu_type) case (0) call bfgs(nat3,gnorm,grd1,gold,dx,hess) diff --git a/src/entropy/thermochem_module.f90 b/src/entropy/thermochem_module.f90 index a252c344..dc010e26 100644 --- a/src/entropy/thermochem_module.f90 +++ b/src/entropy/thermochem_module.f90 @@ -315,6 +315,7 @@ subroutine calc_thermo_from_hess(mol,hess,pr,nt,temps,ithr,& & et,ht,gt,stot) zpve = et(nrt)-ht(nrt) + if (pr) then write (stdout,*) write (stdout,'(10x,a)') repeat(':',50) write (stdout,'(10x,"::",7x,a,f12.2,1x,a,8x,"::")') "THERMODYNAMICS at",temps(nrt),'K' @@ -326,6 +327,7 @@ subroutine calc_thermo_from_hess(mol,hess,pr,nt,temps,ithr,& write (stdout,outfmt) 'G(RRHO) w/o ZPVE ',gt(nrt)-zpve,'Eh' write (stdout,outfmt) 'G(RRHO) total ',gt(nrt),'Eh' write (stdout,'(10x,a)') repeat(':',50) + endif end subroutine calc_thermo_from_hess diff --git a/src/optimize/ancopt.f90 b/src/optimize/ancopt.f90 index c9b3d9ea..6a65e9be 100644 --- a/src/optimize/ancopt.f90 +++ b/src/optimize/ancopt.f90 @@ -476,7 +476,7 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & ! alp = 3.0d0 ! 3 !end if - alp = alp_generate(gnorm,calc%optlev,calc%opt_engine) + alp = alp_generate(gnorm,calc%optlev,calc%opt_engine, calc%hess_init) !write(stdout,*) alp !>------------------------------------------------------------------------ diff --git a/src/optimize/newton_raphson.f90 b/src/optimize/newton_raphson.f90 index 90854359..f2257a4b 100644 --- a/src/optimize/newton_raphson.f90 +++ b/src/optimize/newton_raphson.f90 @@ -20,7 +20,7 @@ ! under the Open-source software LGPL-3.0 Licencse. !================================================================================! -!> This module implements a standard RFO algorithm (in Cart. coords) +!> This module implements a standard NR algorithm (in Cart. coords) module newton_raphson_module use iso_fortran_env,only:wp => real64,sp => real32 @@ -310,7 +310,7 @@ subroutine newton_raphson(mol,calc,etot,grd,pr,wr,iostatus) !end if - alp = alp_generate(gnorm, calc%optlev,calc%opt_engine) + alp = alp_generate(gnorm, calc%optlev,calc%opt_engine, calc%hess_init) !write(stdout,*) alp !>------------------------------------------------------------------------ diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index 3fffdbdb..9d6bd910 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -63,8 +63,9 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) real(wp),intent(inout) :: etot real(wp),intent(inout) :: grd(3,mol%nat) real(wp),allocatable :: H_init(:,:),freq(:) - integer :: nat3,io,idx - real(wp),allocatable :: hess(:) + integer :: nat3,io,idx,nrt + real(wp),allocatable :: hess(:),g_hess(:), g_hess_full(:,:), int_temps(:) + logical :: pr2 iostatus = -1 @@ -87,7 +88,7 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) if (calc%do_HR .or. calc%deform_opt_hess) then allocate (calc%chess) allocate (H_init(nat3,nat3)) - call calc%chess%alloc(mol%nat,calc%hu_steps,calc%hguess,calc%initialize_hr_type, calc%hr_hu_type) + call calc%chess%alloc(mol%nat,calc%hu_steps,calc%chess_id_guess,calc%initialize_hr_type, calc%hr_hu_type) end if !> initial singlepoint @@ -133,9 +134,9 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) idx = minloc(calc%chess%order,1) if (minval(calc%chess%order) .eq. 0) idx = 1 - call initialize_hessian(calc,calc%chess%initialize_type,calc%chess%coords(idx,:,:),molnew%nat,molnew%at,calc%chess%hess(:),calc%chess%hguess,pr) !> This hguess is set through the hguess variable of the optimizer and needs to be hardcoded/set explicitly before initialization for benchmarking!! - call dhtosq(nat3,H_init,calc%chess%hess) !> maybe this should all be inside the construct bfgs function later? -> cannot due to circular import!!! - write(stdout,*) !> Hessian type (gfnff,mod,identity) is set through input file and is already encoded into the calc object + call initialize_hessian(calc,calc%chess%initialize_type,calc%chess%coords(idx,:,:),molnew%nat,molnew%at,calc%chess%hess(:),calc%chess%hguess,pr) + call dhtosq(nat3,H_init,calc%chess%hess) + write(stdout,*) write(stdout,*)"THERMO FROM INITIALIZED HESSIAN:" write(stdout,*) call calc_thermo_from_hess(molnew,H_init,pr, & @@ -157,6 +158,25 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) deallocate (calc%chess) end if + if (calc%g_sampling) then + pr2 = .false. + !write(stdout,*) "Energy pre correction", etot + allocate(g_hess(nat3*(nat3+1)/2),g_hess_full(nat3,nat3)) + call initialize_hessian(calc,5,molnew%xyz,molnew%nat,molnew%at,g_hess,calc%chess%hguess,pr2) + call dhtosq(nat3,g_hess_full,g_hess) + call calc_thermo_from_hess(molnew,g_hess_full,pr2, & + & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & + & calc%ht,calc%gt,calc%stot,etot) + + + allocate (int_temps(calc%nt)) + + int_temps = abs(calc%temperatures-298.15_wp) + nrt = minloc(int_temps(:),1) + etot = etot+calc%gt(nrt) + !write(stdout,*) "Energy post correction", etot + endif + return end subroutine optimize_geometry diff --git a/src/optimize/optutils.f90 b/src/optimize/optutils.f90 index a452ad82..f935101f 100644 --- a/src/optimize/optutils.f90 +++ b/src/optimize/optutils.f90 @@ -455,13 +455,13 @@ end subroutine print_convd !========================================================================================! - function alp_generate(gnorm,optlev,optimizer) result(alp) + function alp_generate(gnorm,optlev,optimizer, hessian_init) result(alp) !**************************************************** !* Computes stepsize scaling factor depending on optimizer !* and optlev !**************************************************** - integer, intent(in) :: optlev, optimizer real(wp), intent(in) :: gnorm + integer, intent(in) :: optlev, optimizer, hessian_init real(wp) :: alp, shift, l, k alp = 1.0_wp @@ -534,10 +534,11 @@ function alp_generate(gnorm,optlev,optimizer) result(alp) shift=0.0003_wp end select end select - alp = L/(1+euler**(k*(gnorm-shift)))+1 + if (hessian_init .eq. 0) alp = 1.0_wp + end function alp_generate !========================================================================================! diff --git a/src/optimize/rfo.f90 b/src/optimize/rfo.f90 index 6b65a778..216080f3 100644 --- a/src/optimize/rfo.f90 +++ b/src/optimize/rfo.f90 @@ -211,7 +211,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) ! end do !end do - call initialize_hessian(calc,calc%hess_init,mol%xyz,mol%nat,mol%at,OPT%hess(:),calc%hguess,pr) !>Need to add printout about how hessian is initialized! Potentially also force positive definiteness by eigenvalue shifting! + call initialize_hessian(calc,calc%hess_init,mol%xyz,mol%nat,mol%at,OPT%hess(:),calc%hguess,pr) !>Need to add printout about how hessian is initialized! !>--- backup coordinates, and starting energy molopt%nat = mol%nat @@ -328,7 +328,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !end if - alp = alp_generate(gnorm, calc%optlev,calc%opt_engine) + alp = alp_generate(gnorm, calc%optlev,calc%opt_engine, calc%hess_init) !write(stdout,*) alp diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 98eaf965..fac0ebcd 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -539,6 +539,9 @@ subroutine parse_calc_auto(env,calc,kv,rd) case('doh_stepsize') calc%doh_stepsize = kv%value_f + case('chess_id_guess') + calc%chess_id_guess = kv%value_f + !>--- integers case ('maxcycle') calc%maxcycle = kv%value_i !> optimization max cycles @@ -622,7 +625,7 @@ subroutine parse_calc_auto(env,calc,kv,rd) end select case ('modhess_type','mh_type') !> here we set how the matrix for hessian reconstruction is initialized - select case (kv%value_c) !>maybe need to add another keywort for crosstesting hr and geopt + select case (kv%value_c) !>maybe need to add another keywort for crosstesting hr and geopt -> No, case('lindh95') calc%mh_type = 0 case('lindh') @@ -696,6 +699,9 @@ subroutine parse_calc_auto(env,calc,kv,rd) case ('deform_opt_hess') calc%deform_opt_hess = kv%value_b + case("g_sampling") !> Do sampling on free energy surface as approximated by lindh95 hessian + calc%g_sampling = kv%value_b + case default rd = .false. end select From 00b05a1f165b2fbbb84049ee4f8cb19f35fc2627 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 18 Feb 2026 11:57:07 +0100 Subject: [PATCH 177/374] Add 50% accumulative population printout to cregen --- src/sorting/cregen.f90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 8b82f022..9d607491 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -2522,6 +2522,11 @@ subroutine cregen_pr2(ch,env,nall,ng,degen,er) j = min(10,ng) i = degen(3,j) write (och,'(" Accum.population of lowest 10 groups",t42,":",2x,F9.3," %")') paccu(i)*100.d0 + do i = 1,ng + j = degen(3,i) + if (paccu(j) >= 0.5_wp) exit + end do + write (och,'(" 50% accum.population for groups",t42,":",6x,"1 - ",i0)') i do i = 1,ng j = degen(3,i) if (paccu(j) >= 0.95_wp) exit From 54bfacd56dfc2d345648f0c3b5f5e1e18d1bbe46 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 18 Feb 2026 12:17:56 +0100 Subject: [PATCH 178/374] Temporarily disable intel builds on CI (needs fixing) --- .github/workflows/build-CI.yml | 8 ++++---- .github/workflows/build-upload.yml | 6 +++--- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/.github/workflows/build-CI.yml b/.github/workflows/build-CI.yml index f86fd599..4ce283a1 100644 --- a/.github/workflows/build-CI.yml +++ b/.github/workflows/build-CI.yml @@ -41,7 +41,7 @@ jobs: - { compiler: gcc, version: '11', build: cmake } - { compiler: gcc, version: '12', build: cmake } - { compiler: gcc, version: '14', build: cmake } - - { compiler: intel, version: '2023.1.0', build: cmake } + #- { compiler: intel, version: '2023.1.0', build: cmake } include: # ---- Linux GCC CMake debugoptimized build ------------------------ @@ -51,8 +51,8 @@ jobs: # ---- Linux static builds ----------------------------------------- - { os: ubuntu-latest, build-type: static, toolchain: { compiler: gcc, version: '12', build: cmake } } - - { os: ubuntu-latest, build-type: static, - toolchain: { compiler: intel, version: '2023.1.0', build: meson } } + #- { os: ubuntu-latest, build-type: static, + # toolchain: { compiler: intel, version: '2023.1.0', build: meson } } # ---- macOS GCC CMake debug builds -------------------------------- - { os: macos-latest, build-type: debug, @@ -74,7 +74,7 @@ jobs: - name: Setup Python uses: actions/setup-python@v5 with: - python-version: "3.9" + python-version: "3.10" # ---------------------------------------------------------------------- # Compiler setup (GCC via setup-fortran, Intel via oneAPI on Linux) diff --git a/.github/workflows/build-upload.yml b/.github/workflows/build-upload.yml index 344072d5..25effbea 100644 --- a/.github/workflows/build-upload.yml +++ b/.github/workflows/build-upload.yml @@ -33,9 +33,9 @@ jobs: build-type: [static] toolchain: # GNU static CMake build - - { compiler: gcc, version: '12', build: cmake } + - { compiler: gcc, version: '14', build: cmake } # Intel static Meson build - - { compiler: intel, version: '2023.1.0', build: meson } + #- { compiler: intel, version: '2023.1.0', build: meson } defaults: run: @@ -48,7 +48,7 @@ jobs: - name: Setup Python uses: actions/setup-python@v5 with: - python-version: "3.9" + python-version: "3.10" # --- Compiler setup ---------------------------------------------------- From 9fc4b92eeb78a919270080a7cbc80fc59dec9881 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 18 Feb 2026 15:29:33 +0100 Subject: [PATCH 179/374] Implement Truhlar frequency cut-off for thermochem --- src/algos/numhess.f90 | 14 +- src/calculator/calc_type.f90 | 3 +- src/classes.f90 | 1 + src/confparse.f90 | 11 +- src/entropy/thermo.f90 | 680 ++++++++++++++++-------------- src/entropy/thermocalc.f90 | 15 +- src/entropy/thermochem_module.f90 | 90 ++-- src/legacy_wrappers.f90 | 15 + src/parsing/confparse2.f90 | 22 +- src/parsing/parse_maindata.f90 | 13 + src/qcg/qcg_misc.f90 | 5 +- 11 files changed, 503 insertions(+), 366 deletions(-) diff --git a/src/algos/numhess.f90 b/src/algos/numhess.f90 index 0b722dfd..795d5366 100644 --- a/src/algos/numhess.f90 +++ b/src/algos/numhess.f90 @@ -283,6 +283,7 @@ subroutine numhess_thermostat(env,mol,nat3,hess,freq,etot) real(wp),intent(in) :: etot !> LOCAL real(wp) :: ithr,fscal,sthr + character(len=:),allocatable :: emodel integer :: nt,nfreq,nrt real(wp),allocatable :: temps(:),et(:),ht(:),stot(:),gt(:) real(wp) :: zpve @@ -294,8 +295,10 @@ subroutine numhess_thermostat(env,mol,nat3,hess,freq,etot) ithr = env%thermo%ithr !> frequency scaling factor fscal = env%thermo%fscal - !> RR-HO interpolation + !> RR-HO interpolation (or cut-off) sthr = env%thermo%sthr + !> Svib model + emodel = env%thermo%emodel if (.not.allocated(env%thermo%temps)) then call env%thermo%get_temps() @@ -310,7 +313,7 @@ subroutine numhess_thermostat(env,mol,nat3,hess,freq,etot) !> calcthermo wants input in Bohr call calcthermo(mol%nat,mol%at,mol%xyz,freq,.true., & - & ithr,fscal,sthr,nt,temps,et,ht,gt,stot) !> THIS HAS IUNIT IN IT!!!! + & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,emodel=emodel) !> THIS HAS IUNIT IN IT!!!! !> printoutgeometr zpve = et(nrt)-ht(nrt) @@ -351,6 +354,7 @@ subroutine thermo_standalone(env) real(wp),allocatable :: freq(:) real(wp) :: etot real(wp) :: ithr,fscal,sthr + character(len=:),allocatable :: emodel integer :: nt,nfreq,nrt real(wp),allocatable :: temps(:),et(:),ht(:),stot(:),gt(:) real(wp) :: zpve @@ -400,8 +404,10 @@ subroutine thermo_standalone(env) ithr = env%thermo%ithr !> frequency scaling factor fscal = env%thermo%fscal - !> RR-HO interpolation + !> RR-HO interpolation (or cut-off) sthr = env%thermo%sthr + !> Svib model + emodel = env%thermo%emodel if (.not.allocated(env%thermo%temps)) then call env%thermo%get_temps() @@ -416,7 +422,7 @@ subroutine thermo_standalone(env) !> calcthermo wants input in Bohr call calcthermo(mol%nat,mol%at,mol%xyz,freq,.true., & - & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,iunit) + & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,iunit,emodel=emodel) !> printout zpve = et(nrt)-ht(nrt) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 51f89516..bb04569f 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -272,7 +272,7 @@ module calc_type integer,allocatable :: ONIOMmap(:) !> map ONIOM fragments to calculation_settings integer,allocatable :: ONIOMrevmap(:) !> map calculation settings to ONIOM frags (or zero) -!>--- Hessian Reconstructor +!>--- Hessian Reconstructor and Thermo data type(cashed_hessian),allocatable :: chess logical :: do_HR = .false. logical :: full_HR = .false. !> Keyword for HR with all opt steps @@ -281,6 +281,7 @@ module calc_type real(wp),allocatable :: temperatures(:) real(wp),allocatable :: et(:),ht(:),gt(:),stot(:) real(wp) :: ithr,fscal,sthr + character(len=:),allocatable :: emodel integer :: initialize_hr_type !> case defining initialization integer :: mh_type = 0 integer :: hr_hu_type = 0 diff --git a/src/classes.f90 b/src/classes.f90 index ab085f44..4fb6a3de 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -292,6 +292,7 @@ module crest_data logical :: avbhess = .false. !> use bhess in the msRRHO average calc. for all structures (expensive!) logical :: constrhess = .false. !> apply constraints in rrhoav? logical :: printpop = .false. !> print a file with populations at different T + character(len=:),allocatable :: emodel contains procedure :: get_temps => thermo_get_temps procedure :: read_temps => thermo_read_temps diff --git a/src/confparse.f90 b/src/confparse.f90 index 845c0eaf..7bf8de41 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -282,14 +282,15 @@ subroutine parseflags(env,arg,nra) !>--- options for principal component analysis (PCA) and clustering env%pcmeasure = 'dihedral' -!>--- thermo options +!>--- Standard THERMO options env%thermo%trange(1) = 278.15d0 !> T start env%thermo%trange(2) = 380.0d0 !> T stop (approx.) env%thermo%trange(3) = 10.0d0 !> T step - env%thermo%ptot = 0.9d0 !> for hessians take x% conformers - env%thermo%pcap = 50000 !> limit number of structures - env%thermo%sthr = 25.0d0 !> rotor cutoff - env%thermo%fscal = 1.0d0 !> frequency scaling factor + env%thermo%ptot = 0.9d0 !> for hessians take x% conformers + env%thermo%pcap = 50000 !> limit number of structures + env%thermo%sthr = 25.0d0 !> rotor cutoff + env%thermo%fscal = 1.0d0 !> frequency scaling factor + env%thermo%emodel = 'grimme' !> Svib treatment !>--- other things env%crest_ohess = .false. diff --git a/src/entropy/thermo.f90 b/src/entropy/thermo.f90 index 6ffc22de..acd625bd 100644 --- a/src/entropy/thermo.f90 +++ b/src/entropy/thermo.f90 @@ -21,23 +21,23 @@ ! Taken from the xtb code and modified for crest !========================================================================! module crest_thermo - use iso_fortran_env, only : wp => real64 - implicit none - - real(wp),private,parameter :: pi = 3.1415926535897932384626433832795029_wp - real(wp),private,parameter :: twopi = 2.0_wp * pi - real(wp),private,parameter :: kB = 3.166808578545117e-06_wp - - real(wp),private,parameter :: autoaa = 0.52917726_wp - real(wp),private,parameter :: aatoau = 1.0_wp/autoaa - real(wp),private,parameter :: amutokg = 1.660539040e-27_wp - real(wp),private,parameter :: autokj = 2625.49964038_wp - real(wp),private,parameter :: autokcal = 627.50947428_wp - real(wp),private,parameter :: kcaltoau = 1.0_wp/autokcal - real(wp),private,parameter :: autorcm = 219474.63067_wp - real(wp),private,parameter :: rcmtoau = 1.0_wp/autorcm - real(wp),private,parameter :: metokg = 9.10938356e-31_wp - real(wp),private,parameter :: kgtome = 1.0_wp/metokg + use iso_fortran_env,only:wp => real64 + implicit none + + real(wp),private,parameter :: pi = 3.1415926535897932384626433832795029_wp + real(wp),private,parameter :: twopi = 2.0_wp*pi + real(wp),private,parameter :: kB = 3.166808578545117e-06_wp + + real(wp),private,parameter :: autoaa = 0.52917726_wp + real(wp),private,parameter :: aatoau = 1.0_wp/autoaa + real(wp),private,parameter :: amutokg = 1.660539040e-27_wp + real(wp),private,parameter :: autokj = 2625.49964038_wp + real(wp),private,parameter :: autokcal = 627.50947428_wp + real(wp),private,parameter :: kcaltoau = 1.0_wp/autokcal + real(wp),private,parameter :: autorcm = 219474.63067_wp + real(wp),private,parameter :: rcmtoau = 1.0_wp/autorcm + real(wp),private,parameter :: metokg = 9.10938356e-31_wp + real(wp),private,parameter :: kgtome = 1.0_wp/metokg !========================================================================================! !========================================================================================! @@ -45,327 +45,395 @@ module crest_thermo !========================================================================================! !========================================================================================! -subroutine thermodyn(iunit,A_rcm,B_rcm,C_rcm,avmom_si,linear,atom,sym,molmass, & - & vibs,nvibs,T,sthr_rcm,et,ht,g,ts,zp,pr) - use iso_fortran_env, only : wp => real64 - implicit none - integer, intent(in) :: iunit !< output_unit - integer, intent(in) :: nvibs !< number of vibrational frequencies - real(wp),intent(in) :: A_rcm !< rotational constants in cm-1 - real(wp),intent(in) :: B_rcm !< rotational constants in cm-1 - real(wp),intent(in) :: C_rcm !< rotational constants in cm-1 - real(wp),intent(in) :: avmom_si !< average moment of inertia in whatever - real(wp),intent(in) :: sym !< symmetry number - real(wp),intent(in) :: molmass !< molecular mass in in amu - real(wp),intent(in) :: T !< temperature in K - real(wp),intent(in) :: sthr_rcm !< rotor cutoff in cm-1 - real(wp),intent(out) :: et !< enthalpy in Eh - real(wp),intent(out) :: ht !< enthalpy in Eh - real(wp),intent(out) :: g !< free energy in Eh - real(wp),intent(out) :: ts !< entropy in Eh - real(wp),intent(in) :: zp !< zero point vibrational energy in Eh - real(wp),intent(in) :: vibs(nvibs) !< vibrational frequencies in cm-1 - logical, intent(in) :: linear !< is linear - logical, intent(in) :: atom !< only one atom - logical, intent(in) :: pr !< clutter the screen with printout - real(wp),parameter :: R = 1.98726D0 ! GAS CONSTANT IN CALORIES/MOLE - real(wp),parameter :: H = 6.626176D-27 ! PLANCK'S CONSTANT IN ERG-SECONDS - real(wp),parameter :: AK = 1.3807D-16 ! BOLTZMANN CONSTANT IN ERG/DEGREE - real(wp),parameter :: conv3 = amutokg*1000 ! 1.6606d-24 - real(wp),parameter :: magic4 = 2.2868d0 ! unknown - real(wp),parameter :: magic5 = 2.3135d0 ! unknown - real(wp),parameter :: caltoj = autokj/autokcal - - integer :: i - real(wp) :: s_tr,s_rot,s_vib,s_int,s_tot - real(wp) :: h_tr,h_rot,h_vib,h_int,h_tot - real(wp) :: q_tr,q_rot,q_vib,q_int - real(wp) :: cptr,cprot,cpvib,cpint,cptot - real(wp) :: beta,sthr,avmom,A,B,C - real(wp) :: ewj,omega,mu - real(wp) :: wofrot - real(wp) :: cp_ho,cp_rr - real(wp) :: sv_ho,sv_rr - !******************************************************************* - - ! convert EVERYTHING to atomic units NOW and avoid horror and dispair later - beta=1.0_wp/kB/T ! beta in 1/Eh - !c1=h*ac/ak/T ! beta in cm - sthr = sthr_rcm * rcmtoau ! sthr in Eh - avmom = avmom_si*kgtome*aatoau**2*1.0e+20_wp ! in me·α² (au) - A = A_rcm * rcmtoau - B = B_rcm * rcmtoau - C = C_rcm * rcmtoau - - ! *** INITIALISE SOME VARIABLES *** - q_vib = 1.0_wp - h_vib = 0.0_wp - cpvib = 0.0_wp - s_vib = 0.0_wp - q_rot = 1.0_wp - h_rot = 0.0_wp - cprot = 0.0_wp - s_rot = 0.0_wp - ! free rotor heat capacity is constant 0.5*R - ! we use the below to work with Eh² units - ! conversion to cal/mol/K is done later - cp_rr = 0.5_wp/(beta**2) - - ! construct the frequency dependent parts of partition function - do i=1,nvibs - omega=vibs(i) + subroutine thermodyn(iunit,A_rcm,B_rcm,C_rcm,avmom_si,linear,atom,sym,molmass, & + & vibs,nvibs,T,sthr_rcm,et,ht,g,ts,zp,pr,emodel) + use iso_fortran_env,only:wp => real64 + implicit none + integer,intent(in) :: iunit !< output_unit + integer,intent(in) :: nvibs !< number of vibrational frequencies + real(wp),intent(in) :: A_rcm !< rotational constants in cm-1 + real(wp),intent(in) :: B_rcm !< rotational constants in cm-1 + real(wp),intent(in) :: C_rcm !< rotational constants in cm-1 + real(wp),intent(in) :: avmom_si !< average moment of inertia in whatever + real(wp),intent(in) :: sym !< symmetry number + real(wp),intent(in) :: molmass !< molecular mass in in amu + real(wp),intent(in) :: T !< temperature in K + real(wp),intent(in) :: sthr_rcm !< rotor cutoff in cm-1 + real(wp),intent(out) :: et !< enthalpy in Eh + real(wp),intent(out) :: ht !< enthalpy in Eh + real(wp),intent(out) :: g !< free energy in Eh + real(wp),intent(out) :: ts !< entropy in Eh + real(wp),intent(in) :: zp !< zero point vibrational energy in Eh + real(wp),intent(in) :: vibs(nvibs) !< vibrational frequencies in cm-1 + logical,intent(in) :: linear !< is linear + logical,intent(in) :: atom !< only one atom + logical,intent(in) :: pr !< clutter the screen with printout + integer,intent(in),optional :: emodel + real(wp),parameter :: R = 1.98726D0 ! GAS CONSTANT IN CALORIES/MOLE + real(wp),parameter :: H = 6.626176D-27 ! PLANCK'S CONSTANT IN ERG-SECONDS + real(wp),parameter :: AK = 1.3807D-16 ! BOLTZMANN CONSTANT IN ERG/DEGREE + real(wp),parameter :: conv3 = amutokg*1000 ! 1.6606d-24 + real(wp),parameter :: magic4 = 2.2868d0 ! unknown + real(wp),parameter :: magic5 = 2.3135d0 ! unknown + real(wp),parameter :: caltoj = autokj/autokcal + + integer :: i,model + real(wp) :: s_tr,s_rot,s_vib,s_int,s_tot + real(wp) :: h_tr,h_rot,h_vib,h_int,h_tot + real(wp) :: q_tr,q_rot,q_vib,q_int + real(wp) :: cptr,cprot,cpvib,cpint,cptot + real(wp) :: beta,sthr,avmom,A,B,C + real(wp) :: ewj,omega,mu + real(wp) :: wofrot + real(wp) :: cp_ho,cp_rr + real(wp) :: sv_ho,sv_rr + !******************************************************************* + + if (present(emodel)) then + !> selecting vib. entropy approximation: 1=Grimme (2012), 2=Truhlar (2011) + model = emodel + else + model = 1 + end if + + ! convert EVERYTHING to atomic units NOW and avoid horror and dispair later + beta = 1.0_wp/kB/T ! beta in 1/Eh + !c1=h*ac/ak/T ! beta in cm + sthr = sthr_rcm*rcmtoau ! sthr in Eh + avmom = avmom_si*kgtome*aatoau**2*1.0e+20_wp ! in me·α² (au) + A = A_rcm*rcmtoau + B = B_rcm*rcmtoau + C = C_rcm*rcmtoau + + ! *** INITIALISE SOME VARIABLES *** + q_vib = 1.0_wp + h_vib = 0.0_wp + cpvib = 0.0_wp + s_vib = 0.0_wp + q_rot = 1.0_wp + h_rot = 0.0_wp + cprot = 0.0_wp + s_rot = 0.0_wp + ! free rotor heat capacity is constant 0.5*R + ! we use the below to work with Eh² units + ! conversion to cal/mol/K is done later + cp_rr = 0.5_wp/(beta**2) + + ! construct the frequency dependent parts of partition function + do i = 1,nvibs + select case (model) + case (1) !> Grimme mod.RRHO (2012) + omega = vibs(i) + case (2) !> Truhlar cutoff (2011) + if (vibs(i) >= 0.0_wp) then + omega = max(sthr,vibs(i)) + else + omega = vibs(i) + end if + end select ! omega in Eh, beta in 1/Eh - ewj=exp(-omega*beta) - q_vib=q_vib/(1.0_wp-ewj) + ewj = exp(-omega*beta) + q_vib = q_vib/(1.0_wp-ewj) ! h_vib in Eh - h_vib=h_vib+omega*ewj/(1.0_wp-ewj) + h_vib = h_vib+omega*ewj/(1.0_wp-ewj) ! cp_ho in Eh² - cp_ho=omega**2 * ewj/(1.0_wp-ewj)/(1.0_wp-ewj) + cp_ho = omega**2*ewj/(1.0_wp-ewj)/(1.0_wp-ewj) ! replace low-lying vibs for S by rotor approx. - mu = 0.5_wp / (omega + 1.0e-14_wp) + mu = 0.5_wp/(omega+1.0e-14_wp) ! this reduced moment limits the rotational moment of inertia for ! this vibration to that of the total molecule rotation/3 ! avmom and xmom are in me·α² (au) mu = mu*avmom/(mu+avmom) - if(omega.gt.0)then - ! sv is S/R which is dimensionless - ! harm. osc. entropy - sv_ho = vibs(i)*beta*ewj/(1.0_wp-ewj) - log(1.0_wp-ewj) - ! free rotor entropy - ! Cramer, page 328 for one degree of freedom or - ! http://cccbdb.nist.gov/thermo.asp, eq. 35, sigma=1 - !sv_rr = (0.5_wp+log(sqrt(8.0_wp*pi**3*xmom*sik*t)/sih)) - sv_rr = 0.5_wp + log(sqrt(pi/beta*2.0_wp*mu)) + if (omega .gt. 0) then + ! sv is S/R which is dimensionless + ! harm. osc. entropy + sv_ho = omega*beta*ewj/(1.0_wp-ewj)-log(1.0_wp-ewj) + ! free rotor entropy + ! Cramer, page 328 for one degree of freedom or + ! http://cccbdb.nist.gov/thermo.asp, eq. 35, sigma=1 + sv_rr = 0.5_wp+log(sqrt(pi/beta*2.0_wp*mu)) else - sv_ho = 0.0_wp - sv_rr = 0.0_wp - endif - ! fermi weigthing - ! wofrot=1./(1.+exp( (omega-sthr)/20.0 ) ) - ! Head-Gordon weighting - wofrot=1.0_wp-chg_switching(omega,sthr) - ! heat capacity (cp_rr is a constant), all in Eh² - cpvib = cpvib + ((1.0_wp-wofrot)*cp_ho + wofrot*cp_rr) - ! entropy s_vib is converted to cal/mol/K... by multiplying with R - s_vib=s_vib+R*((1.0_wp-wofrot)*sv_ho + wofrot*sv_rr) - enddo - ! *** FINISH CALCULATION OF VIBRATIONAL PARTS *** - ! now unit conversion again... - ! h_vib in Eh, beta is in 1/Eh, T is in K, R is in cal/mol/K, - h_vib=h_vib*R*beta*T - ! same here - ! cpvib is in Eh², beta in 1/Eh, R in cal/mol/K - cpvib=cpvib*R*beta**2 - ! *** NOW CALCULATE THE ROTATIONAL PARTS (FIRST LINEAR MOLECULES) - if (.not.atom) then - if(linear) then - ! A is in Eh, beta is in 1/Eh, q_rot is dimensionless - q_rot=1/(beta*A*sym) - ! h_rot is in cal/mol - h_rot=R*T - ! cprot is in cal/mol/K - cprot=R - ! s_rot is in cal/mol/K - s_rot=R*((log(1.0_wp/(beta*A*sym)))+1.0_wp) + sv_ho = 0.0_wp + sv_rr = 0.0_wp + end if + select case (model) + case (1) !> Grimme mod.RRHO (2012) + ! Head-Gordon weighting + wofrot = 1.0_wp-chg_switching(omega,sthr) + ! heat capacity (cp_rr is a constant), all in Eh² + cpvib = cpvib+((1.0_wp-wofrot)*cp_ho+wofrot*cp_rr) + ! entropy s_vib is converted to cal/mol/K... by multiplying with R + s_vib = s_vib+R*((1.0_wp-wofrot)*sv_ho+wofrot*sv_rr) + case (2) !> Truhlar cutoff (2011) + ! heat capacity in Eh² + cpvib = cpvib+(cp_ho) + ! entropy s_vib is converted to cal/mol/K... by multiplying with R + s_vib = s_vib+R*(sv_ho) + end select + end do + ! *** FINISH CALCULATION OF VIBRATIONAL PARTS *** + ! now unit conversion again... + ! h_vib in Eh, beta is in 1/Eh, T is in K, R is in cal/mol/K, + h_vib = h_vib*R*beta*T + ! same here + ! cpvib is in Eh², beta in 1/Eh, R in cal/mol/K + cpvib = cpvib*R*beta**2 + ! *** NOW CALCULATE THE ROTATIONAL PARTS (FIRST LINEAR MOLECULES) + if (.not.atom) then + if (linear) then + ! A is in Eh, beta is in 1/Eh, q_rot is dimensionless + q_rot = 1/(beta*A*sym) + ! h_rot is in cal/mol + h_rot = R*T + ! cprot is in cal/mol/K + cprot = R + ! s_rot is in cal/mol/K + s_rot = R*((log(1.0_wp/(beta*A*sym)))+1.0_wp) else - ! see above - q_rot=sqrt(pi/(A*B*C*beta**3))/sym - h_rot=3.0_wp*R*T/2.0_wp - cprot=3.0_wp*R/2.0_wp - s_rot=0.5_wp*R*(-2.0_wp*log(sym)+log(pi/(A*B*C*beta**3))+3.0_wp) - endif - endif - ! *** CALCULATE INTERNAL CONTRIBUTIONS *** - q_int=q_vib*q_rot - h_int=h_vib+h_rot - cpint=cpvib+cprot - s_int=s_vib+s_rot - ! *** CONSTRUCT TRANSLATION CONTRIBUTIONS *** - q_tr=(sqrt(2.0_wp*pi*molmass*t*ak*conv3)/h)**3 - ! this is 3/2rt+pv=5/2rt - h_tr=5.0_wp*R*T/2.0_wp - cptr=5.0_wp*R/2.0_wp - s_tr=magic4*(5.0_wp*log10(t)+3.0_wp*log10(molmass))-magic5 - ! *** CONSTRUCT TOTALS *** - cptot=cptr+cpint - s_tot=s_tr+s_int - h_tot=h_tr+h_int - - if(pr)then - write(iunit,'(a)') - write(iunit,'(" temp. (K) partition function ", & + ! see above + q_rot = sqrt(pi/(A*B*C*beta**3))/sym + h_rot = 3.0_wp*R*T/2.0_wp + cprot = 3.0_wp*R/2.0_wp + s_rot = 0.5_wp*R*(-2.0_wp*log(sym)+log(pi/(A*B*C*beta**3))+3.0_wp) + end if + end if + ! *** CALCULATE INTERNAL CONTRIBUTIONS *** + q_int = q_vib*q_rot + h_int = h_vib+h_rot + cpint = cpvib+cprot + s_int = s_vib+s_rot + ! *** CONSTRUCT TRANSLATION CONTRIBUTIONS *** + q_tr = (sqrt(2.0_wp*pi*molmass*t*ak*conv3)/h)**3 + ! this is 3/2rt+pv=5/2rt + h_tr = 5.0_wp*R*T/2.0_wp + cptr = 5.0_wp*R/2.0_wp + s_tr = magic4*(5.0_wp*log10(t)+3.0_wp*log10(molmass))-magic5 + ! *** CONSTRUCT TOTALS *** + cptot = cptr+cpint + s_tot = s_tr+s_int + h_tot = h_tr+h_int + + if (pr) then + write (iunit,'(a)') + write (iunit,'(" temp. (K) partition function ", & & " enthalpy heat capacity entropy")') - write(iunit,'( " ", & + write (iunit,'( " ", & & "cal/mol cal/K/mol cal/K/mol J/K/mol")') - write(iunit,'( f7.2," VIB ",G10.3,10X,3F11.3)') & - & T,q_vib, h_vib, cpvib, s_vib - write(iunit,'(7X," ROT ",G10.3,10X,3F11.3)') & - & q_rot, h_rot, cprot, s_rot - write(iunit,'(7X," INT ",G10.3,10X,3F11.3)') & + write (iunit,'( f7.2," VIB ",G10.3,10X,3F11.3)') & + & T,q_vib,h_vib,cpvib,s_vib + write (iunit,'(7X," ROT ",G10.3,10X,3F11.3)') & + & q_rot,h_rot,cprot,s_rot + write (iunit,'(7X," INT ",G10.3,10X,3F11.3)') & & q_int,h_int,cpint,s_int - write(iunit,'(7X," TR ",G10.3,10X,3F11.3)') & - & q_tr, h_tr, cptr, s_tr - write(iunit,'(7X," TOT ",21X,F11.4,3F11.4)') & + write (iunit,'(7X," TR ",G10.3,10X,3F11.3)') & + & q_tr,h_tr,cptr,s_tr + write (iunit,'(7X," TOT ",21X,F11.4,3F11.4)') & & h_tot,cptot,s_tot,s_tot*caltoj - endif - - ht=h_tot/1000.0_wp*kcaltoau - et=ht+zp - ts=s_tot*t/1000.0_wp*kcaltoau - - g=et-ts - - return -end subroutine thermodyn - -pure elemental function lnqrot(temp,f,avmom) result(lnq_r) - implicit none - real(wp), parameter :: rcmtoj = rcmtoau*autokj*1000.0_wp - real(wp), parameter :: avogadro = 6.0221413e23_wp ! 1/mol - real(wp), parameter :: planck = 6.62606957e-34_wp ! J*s - real(wp), parameter :: hbar = planck/(2.0_wp*pi) - real(wp), parameter :: kb = 1.3806488e-23_wp ! J/K - real(wp), intent(in) :: temp !< temperature in K - real(wp), intent(in) :: f !< vibrational frequency in cm⁻¹ - real(wp), intent(in) :: avmom !< average moment of inertia in kg·m² - real(wp):: e - real(wp):: mu - real(wp):: lnq_r - real(wp):: t_rot - - ! moment of inertia corresponding to the rotor with frequency f(ifreq) - ! convert frequency first from cm⁻¹ to J, we add also a little offset to avoid Infinities - e = ((f*rcmtoJ)+1.0e-14_wp)/avogadro - mu = hbar**2/(2.0_wp*e) - ! the vibrational moment of inertia is now in SI - ! reduce the moment relative to the total rotational moment - mu = avmom*mu/(avmom+mu) - ! now we need a rotational temperature of mu, - ! since we are SI already no unit conversion needed - t_rot = hbar**2/(2.0_wp*mu*kb) - ! ln(q) of the free rotor partition function, we assume σ=1 - lnq_r = log(sqrt(pi*temp/t_rot)) - -end function lnqrot - -pure elemental function lnqvib(temp,f) result(lnq_v) - implicit none - real(wp), parameter :: planck = 6.62606957e-34_wp ! J*s - real(wp), parameter :: kb = 1.3806488e-23_wp ! J/K - real(wp), parameter :: speed_of_light = 299792458.0_wp ! m/s - real(wp), parameter :: factor = planck*100.0_wp*speed_of_light/kb - real(wp), intent(in) :: temp !< temperature in K - real(wp), intent(in) :: f !< vibrational frequency in cm⁻¹ - real(wp):: lnq_v - real(wp):: t_vib - ! get the vibrational temperature (which is in K, BTW) - t_vib = factor*f - ! modified oscillator, for sthr = 0 -> HO. - ! ln(q) of the harmonic oscillator partition function - lnq_v = - 0.5_wp*t_vib/temp - log(1.0_wp - exp(-t_vib/temp)) - -end function lnqvib - -pure elemental function lnqvibmod(temp,f,sthr,avmom) result(lnq) - implicit none - real(wp), intent(in) :: temp !< temperature in K - real(wp), intent(in) :: f !< vibrational frequency in cm⁻¹ - real(wp), intent(in) :: sthr !< rotor cutoff in cm⁻¹ - real(wp), intent(in) :: avmom !< average moment of inertia in kg·m² - real(wp):: fswitch - real(wp):: lnq_r,lnq_v,lnq - ! ln(q) of the harmonic oscillator partition function - lnq_v = lnqvib(temp,f) - ! ln(q) of the free rotor partition function, we assume σ=1 - lnq_r = lnqrot(temp,f,avmom) - - ! Chai--Head-Gordon weighting - fswitch = 1.0_wp - chg_switching(sthr,f) - - ! now final modified vibrational partiation function - lnq = (1.0_wp-fswitch) * lnq_v + fswitch * lnq_r - -end function lnqvibmod - -pure elemental function chg_switching(omega,sthr) result(f) - real(wp),intent(in) :: omega - real(wp),intent(in) :: sthr - real(wp) :: f - if(sthr.ge.0.0_wp) then + end if + + ht = h_tot/1000.0_wp*kcaltoau + et = ht+zp + ts = s_tot*t/1000.0_wp*kcaltoau + + g = et-ts + + return + end subroutine thermodyn + + pure elemental function lnqrot(temp,f,avmom) result(lnq_r) + implicit none + real(wp),parameter :: rcmtoj = rcmtoau*autokj*1000.0_wp + real(wp),parameter :: avogadro = 6.0221413e23_wp ! 1/mol + real(wp),parameter :: planck = 6.62606957e-34_wp ! J*s + real(wp),parameter :: hbar = planck/(2.0_wp*pi) + real(wp),parameter :: kb = 1.3806488e-23_wp ! J/K + real(wp),intent(in) :: temp !< temperature in K + real(wp),intent(in) :: f !< vibrational frequency in cm⁻¹ + real(wp),intent(in) :: avmom !< average moment of inertia in kg·m² + real(wp):: e + real(wp):: mu + real(wp):: lnq_r + real(wp):: t_rot + + ! moment of inertia corresponding to the rotor with frequency f(ifreq) + ! convert frequency first from cm⁻¹ to J, we add also a little offset to avoid Infinities + e = ((f*rcmtoJ)+1.0e-14_wp)/avogadro + mu = hbar**2/(2.0_wp*e) + ! the vibrational moment of inertia is now in SI + ! reduce the moment relative to the total rotational moment + mu = avmom*mu/(avmom+mu) + ! now we need a rotational temperature of mu, + ! since we are SI already no unit conversion needed + t_rot = hbar**2/(2.0_wp*mu*kb) + ! ln(q) of the free rotor partition function, we assume σ=1 + lnq_r = log(sqrt(pi*temp/t_rot)) + + end function lnqrot + + pure elemental function lnqvib(temp,f) result(lnq_v) + implicit none + real(wp),parameter :: planck = 6.62606957e-34_wp ! J*s + real(wp),parameter :: kb = 1.3806488e-23_wp ! J/K + real(wp),parameter :: speed_of_light = 299792458.0_wp ! m/s + real(wp),parameter :: factor = planck*100.0_wp*speed_of_light/kb + real(wp),intent(in) :: temp !< temperature in K + real(wp),intent(in) :: f !< vibrational frequency in cm⁻¹ + real(wp):: lnq_v + real(wp):: t_vib + ! get the vibrational temperature (which is in K, BTW) + t_vib = factor*f + ! modified oscillator, for sthr = 0 -> HO. + ! ln(q) of the harmonic oscillator partition function + lnq_v = -0.5_wp*t_vib/temp-log(1.0_wp-exp(-t_vib/temp)) + + end function lnqvib + + pure elemental function lnqvibmod(temp,f,sthr,avmom) result(lnq) + implicit none + real(wp),intent(in) :: temp !< temperature in K + real(wp),intent(in) :: f !< vibrational frequency in cm⁻¹ + real(wp),intent(in) :: sthr !< rotor cutoff in cm⁻¹ + real(wp),intent(in) :: avmom !< average moment of inertia in kg·m² + real(wp):: fswitch + real(wp):: lnq_r,lnq_v,lnq + ! ln(q) of the harmonic oscillator partition function + lnq_v = lnqvib(temp,f) + ! ln(q) of the free rotor partition function, we assume σ=1 + lnq_r = lnqrot(temp,f,avmom) + + ! Chai--Head-Gordon weighting + fswitch = 1.0_wp-chg_switching(sthr,f) + + ! now final modified vibrational partiation function + lnq = (1.0_wp-fswitch)*lnq_v+fswitch*lnq_r + + end function lnqvibmod + + pure elemental function chg_switching(omega,sthr) result(f) + real(wp),intent(in) :: omega + real(wp),intent(in) :: sthr + real(wp) :: f + if (sthr .ge. 0.0_wp) then f = 1.0_wp/(1.0_wp+(sthr/omega)**4) - else + else f = 1.0_wp - endif -end function chg_switching - -pure elemental function chg_inverted(f,sthr) result(omega) - real(wp),intent(in) :: f - real(wp),intent(in) :: sthr - real(wp) :: omega - omega = sthr/(1.0_wp/f - 1.0_wp)**0.25_wp - -end function chg_inverted - - -subroutine print_thermo_sthr_ts(iunit,nvib,vibs,avmom_si,sthr_rcm,temp) - implicit none - - integer, intent(in) :: iunit !< output unit, usually STDOUT - integer, intent(in) :: nvib !< number of frequencies - real(wp),intent(in) :: vibs(nvib) !< frequencies in Eh - real(wp),intent(in) :: avmom_si !< average moment - real(wp),intent(in) :: sthr_rcm !< rotor cutoff - real(wp),intent(in) :: temp !< temperature - - integer :: i - real(wp) :: maxfreq,omega,s_r,s_v,fswitch - real(wp) :: beta,ewj,mu,RT,sthr,avmom - beta = 1.0_wp/kB/temp ! beta in 1/Eh - sthr = sthr_rcm * rcmtoau ! sthr in Eh - RT = kb*temp*autokcal ! RT in kcal/mol for printout - avmom = avmom_si*kgtome*aatoau**2*1.0e+20_wp ! in me·α² - - write(iunit,'(a)') - maxfreq = max(300.0_wp,chg_inverted(0.99_wp,sthr_rcm)) - write(iunit,'(1x,a,f6.2,a,/)') 'Frequencies up to ',maxfreq,' cm⁻¹ treated with '// & - & 'the modified RRHO approximation:' - write(iunit,'(a8,a14,1x,a27,a27,a12)') & + end if + end function chg_switching + + pure elemental function chg_inverted(f,sthr) result(omega) + real(wp),intent(in) :: f + real(wp),intent(in) :: sthr + real(wp) :: omega + omega = sthr/(1.0_wp/f-1.0_wp)**0.25_wp + + end function chg_inverted + + subroutine print_thermo_sthr_ts(iunit,nvib,vibs,avmom_si,sthr_rcm,temp) + implicit none + + integer,intent(in) :: iunit !< output unit, usually STDOUT + integer,intent(in) :: nvib !< number of frequencies + real(wp),intent(in) :: vibs(nvib) !< frequencies in Eh + real(wp),intent(in) :: avmom_si !< average moment + real(wp),intent(in) :: sthr_rcm !< rotor cutoff + real(wp),intent(in) :: temp !< temperature + + integer :: i + real(wp) :: maxfreq,omega,s_r,s_v,fswitch + real(wp) :: beta,ewj,mu,RT,sthr,avmom + beta = 1.0_wp/kB/temp ! beta in 1/Eh + sthr = sthr_rcm*rcmtoau ! sthr in Eh + RT = kb*temp*autokcal ! RT in kcal/mol for printout + avmom = avmom_si*kgtome*aatoau**2*1.0e+20_wp ! in me·α² + + write (iunit,'(a)') + maxfreq = max(300.0_wp,chg_inverted(0.99_wp,sthr_rcm)) + write (iunit,'(1x,a,f6.2,a,/)') 'Frequencies up to ',maxfreq,' cm⁻¹ treated with '// & + & 'the modified RRHO approximation:' + write (iunit,'(a8,a14,1x,a27,a27,a12)') & "mode","ω/cm⁻¹","T·S(HO)/kcal·mol⁻¹","T·S(FR)/kcal·mol⁻¹","T·S(vib)" - write(iunit,'(3x,72("-"))') - do i = 1, nvib + write (iunit,'(3x,72("-"))') + do i = 1,nvib ! frequency is Eh - omega=vibs(i) + omega = vibs(i) ! omega in Eh, beta in 1/Eh - ewj=exp(-omega*beta) + ewj = exp(-omega*beta) ! moment of intertia corresponding to the rotor with frequency omega ! mu is in me·α² (au) - mu = 0.5_wp / (omega+1.0e-14_wp) + mu = 0.5_wp/(omega+1.0e-14_wp) ! this reduced moment limits the rotational moment of inertia for ! this vibration to that of the total molecule rotation/3 ! avmom and mu are in au - mu=mu*avmom/(mu+avmom) + mu = mu*avmom/(mu+avmom) ! free rotor entropy ! Cramer, page 328 for one degree of freedom or ! http://cccbdb.nist.gov/thermo.asp, eq. 35, sigma=1 ! harm. osc. entropy - if(omega.gt.0)then - ! this is S/R which is dimensionless - s_v = omega*beta*ewj/(1.0_wp-ewj) - log(1.0_wp-ewj) - s_r = 0.5_wp + log(sqrt(pi/beta*2.0_wp*mu)) + if (omega .gt. 0) then + ! this is S/R which is dimensionless + s_v = omega*beta*ewj/(1.0_wp-ewj)-log(1.0_wp-ewj) + s_r = 0.5_wp+log(sqrt(pi/beta*2.0_wp*mu)) else - s_v = 0.0_wp - s_r = 0.0_wp - endif + s_v = 0.0_wp + s_r = 0.0_wp + end if ! Head-Gordon weighting - fswitch=1.0_wp-chg_switching(omega,sthr) + fswitch = 1.0_wp-chg_switching(omega,sthr) + if (omega > maxfreq*rcmtoau) exit + write (iunit,'(i8,f10.2,2(f12.5,1x,"(",f6.2,"%)"),f12.5)') & + i,omega*autorcm,-RT*s_v, (1.0_wp-fswitch)*100, & + -RT*s_r,fswitch*100,-RT*((1.0_wp-fswitch)*s_v+fswitch*s_r) + end do + write (iunit,'(3x,72("-"))') + + end subroutine print_thermo_sthr_ts + + subroutine print_thermo_sthr_cut(iunit,nvib,vibs,sthr_rcm,temp) + implicit none + + integer,intent(in) :: iunit !< output unit, usually STDOUT + integer,intent(in) :: nvib !< number of frequencies + real(wp),intent(in) :: vibs(nvib) !< frequencies in Eh + real(wp),intent(in) :: sthr_rcm !< rotor cutoff + real(wp),intent(in) :: temp !< temperature + + integer :: i + real(wp) :: maxfreq,omega,s_r,s_v,omega_cut + real(wp) :: beta,ewj,mu,RT,sthr,avmom,ewj_cut + beta = 1.0_wp/kB/temp ! beta in 1/Eh + sthr = sthr_rcm*rcmtoau ! sthr in Eh + RT = kb*temp*autokcal ! RT in kcal/mol for printout + + write (iunit,'(a)') + maxfreq = sthr_rcm + write (iunit,'(1x,a,f6.2,a,/)') 'Frequencies up to ',maxfreq,' cm⁻¹ will '// & + & 'crudely be cut to exactly this value (Truhlar, 2011)' + write (iunit,'(a8,a14,1x,a27,a27,a13)') & + "mode","ω/cm⁻¹","T·S(HO)/kcal·mol⁻¹","T·S(cut)/kcal·mol⁻¹","ΔT·S" + write (iunit,'(3x,72("-"))') + do i = 1,nvib + ! frequency is Eh + omega = vibs(i) if (omega > maxfreq*rcmtoau) exit - write(iunit,'(i8,f10.2,2(f12.5,1x,"(",f6.2,"%)"),f12.5)') & - i,omega*autorcm,-RT*s_v,(1.0_wp-fswitch)*100, & - -RT*s_r,fswitch*100,-RT*((1.0_wp-fswitch) * s_v + fswitch * s_r) - enddo - write(iunit,'(3x,72("-"))') + omega_cut = maxfreq*rcmtoau + ! omega in Eh, beta in 1/Eh + ewj = exp(-omega*beta) + ewj_cut = exp(-omega_cut*beta) -end subroutine print_thermo_sthr_ts + if (omega .gt. 0) then + ! this is S/R which is dimensionless + s_v = omega*beta*ewj/(1.0_wp-ewj)-log(1.0_wp-ewj) + s_r = omega_cut*beta*ewj_cut/(1.0_wp-ewj_cut)-log(1.0_wp-ewj_cut) + else + s_v = 0.0_wp + s_r = 0.0_wp + end if + write (iunit,'(i8,f10.2,9x,f12.5,10x,f12.5,1x,f12.5)') & + i,omega*autorcm,-RT*s_v,-RT*s_r,-RT*(s_v-s_r) + end do + write (iunit,'(3x,72("-"))') + + end subroutine print_thermo_sthr_cut !========================================================================================! !========================================================================================! diff --git a/src/entropy/thermocalc.f90 b/src/entropy/thermocalc.f90 index 26136819..8a85529e 100644 --- a/src/entropy/thermocalc.f90 +++ b/src/entropy/thermocalc.f90 @@ -60,7 +60,7 @@ subroutine thermo_wrap_legacy(env,pr,nat,at,xyz,dirname, & integer :: nfreq real(wp),allocatable :: freq(:) real(wp) :: ithr,fscal,sthr - + type(coord) :: mol integer :: TID,OMP_GET_THREAD_NUM !!$OMP PARALLEL PRIVATE(TID) @@ -137,9 +137,10 @@ subroutine thermo_wrap_legacy(env,pr,nat,at,xyz,dirname, & end if !$omp critical - call rdxmol(trim(optpath)//'xtbopt.xyz',nat,at,xyz,atmp) + !call rdxmol(trim(optpath)//'xtbopt.xyz',nat,at,xyz,atmp) + call mol%open(trim(optpath)//'xtbopt.xyz') etot = grepenergy(atmp) - nfreq = 3*nat + nfreq = 3*mol%nat allocate (freq(nfreq)) call rdfreq(trim(optpath)//'vibspectrum',nfreq,freq) @@ -147,8 +148,8 @@ subroutine thermo_wrap_legacy(env,pr,nat,at,xyz,dirname, & ithr = env%thermo%ithr fscal = env%thermo%fscal sthr = env%thermo%sthr - call calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr, & - & nt,temps,et,ht,gt,stot,stdout) + call calcthermo(mol%nat,mol%at,mol%xyz,freq,pr,ithr,fscal,sthr, & + & nt,temps,et,ht,gt,stot,stdout,emodel=env%thermo%emodel) deallocate (freq) !$omp end critical call initsignal() @@ -316,8 +317,8 @@ subroutine thermo_wrap_new(env,pr,nat,at,xyz,dirname, & ithr = env%thermo%ithr fscal = env%thermo%fscal sthr = env%thermo%sthr - call calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr, & - & nt,temps,et,ht,gt,stot,stdout) + call calcthermo(mol%nat,mol%at,mol%xyz,freq,pr,ithr,fscal,sthr, & + & nt,temps,et,ht,gt,stot,stdout,emodel=env%thermo%emodel) deallocate (hess,freq) !$omp end critical call initsignal() diff --git a/src/entropy/thermochem_module.f90 b/src/entropy/thermochem_module.f90 index dc010e26..4dd85fc3 100644 --- a/src/entropy/thermochem_module.f90 +++ b/src/entropy/thermochem_module.f90 @@ -10,7 +10,9 @@ module thermochem_module public calcthermo,calc_thermo_from_hess -contains +!==============================================================================! +contains !> MODULE PROCEDURES STARTE HERE +!==============================================================================! subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar,iunit) !*********************************************************************** @@ -102,7 +104,7 @@ subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar,iunit) end subroutine prepthermo subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & - & et,ht,gt,stot,iunit_in) + & et,ht,gt,stot,iunit_in,emodel) !************************************************************** !* Calculate thermodynamic contributions for a given structure !* from it's frequencies (from second derivatives/the Hessian) @@ -124,6 +126,7 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & integer,intent(in) :: nt real(wp),intent(in) :: temps(nt) integer,intent(in),optional :: iunit_in + character(len=*),intent(in),optional :: emodel real(wp) :: et(nt) !< enthalpy in Eh real(wp) :: ht(nt) !< enthalpy in Eh real(wp) :: gt(nt) !< free energy in Eh @@ -143,7 +146,7 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & real(wp) :: vibthr real(wp),allocatable :: vibs(:) - integer :: i,j,iunit + integer :: i,j,iunit,emodelunit integer :: n3,rt real(wp) :: adum(nt) character(len=64) :: atmp @@ -151,17 +154,17 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & character(len=*),parameter :: outfmt = & & '(9x,"::",1x,a,f24.12,1x,a,1x,"::")' character(len=*),parameter :: dblfmt = & - & '(10x,":",2x,a,f24.7,1x,a,1x,":")' + & '(10x,":",2x,a,f24.7,1x,a,t63,":")' character(len=*),parameter :: intfmt = & - & '(10x,":",2x,a,i24, 6x,":")' + & '(10x,":",2x,a,i24, t63,":")' character(len=*),parameter :: chrfmt = & - & '(10x,":",2x,a,a24, 6x,":")' + & '(10x,":",2x,a,a24, t63,":")' real(wp),parameter :: autorcm = 219474.63067_wp real(wp),parameter :: rcmtoau = 1.0_wp/autorcm real(wp),parameter :: autocal = 627.50947428_wp*1000.0_wp - xyz = xyz*autoaa + xyz = xyz*autoaa !> NOTE: FROM HERE ON WE WORK IN ANGSTRÖM if (present(iunit_in)) then iunit = iunit_in @@ -169,6 +172,19 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & iunit = stdout end if + if (present(emodel)) then + select case (emodel) + case ('grimme') + emodelunit = 1 + case ('truhlar') + emodelunit = 2 + case default + emodelunit = 1 + end select + else + emodelunit = 1 + end if + call prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,sym,symchar,iunit) n3 = 3*nat @@ -213,9 +229,9 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & if (pr) then write (iunit,'(a)') - write (iunit,'(10x,51("."))') - write (iunit,'(10x,":",22x,a,22x,":")') "SETUP" - write (iunit,'(10x,":",49("."),":")') + write (iunit,'(10x,53("."))') + write (iunit,'(10x,":",23x,a,23x,":")') "SETUP" + write (iunit,'(10x,":",51("."),":")') write (iunit,intfmt) "# frequencies ",nvib write (iunit,intfmt) "# imaginary freq.",nimag write (atmp,*) linear @@ -223,9 +239,17 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & write (iunit,chrfmt) "symmetry ",adjustr(symchar) write (iunit,intfmt) "rotational number",nint(sym) write (iunit,dblfmt) "scaling factor ",fscal," " - write (iunit,dblfmt) "rotor cutoff ",sthr,"cm⁻¹" - write (iunit,dblfmt) "imag. cutoff ",ithr,"cm⁻¹" - write (iunit,'(10x,":",49("."),":")') + select case (emodelunit) + case (1) + write (iunit,chrfmt) "vib.entropy model ","Grimme (2012)" + write (iunit,dblfmt) "rotor cutoff ",sthr,"cm^-1" + case (2) + write (iunit,chrfmt) "vib.entropy model ","Truhlar (2011)" + write (iunit,dblfmt) "frequency cutoff ",sthr,"cm^-1" + end select + + write (iunit,dblfmt) "imag. cutoff ",ithr,"cm^-1" + write (iunit,'(10x,":",51("."),":")') end if vibs = vibs*rcmtoau ! thermodyn needs vibs and zp in Eh @@ -240,10 +264,15 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & pr2 = .false. end if if (pr2) then - call print_thermo_sthr_ts(iunit,nvib,vibs,avmom,sthr,temps(j)) + select case (emodelunit) + case (1) + call print_thermo_sthr_ts(iunit,nvib,vibs,avmom,sthr,temps(j)) + case (2) + call print_thermo_sthr_cut(iunit,nvib,vibs,sthr,temps(j)) + end select end if call thermodyn(iunit,a,b,c,avmom,linear,atom,sym,molmass,vibs,nvib, & - & temps(j),sthr,et(j),ht(j),gt(j),ts(j),zp,pr2) + & temps(j),sthr,et(j),ht(j),gt(j),ts(j),zp,pr2,emodel=emodelunit) stot(j) = (ts(j)/temps(j))*autocal end do @@ -271,14 +300,14 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & write (iunit,'(3x,72("-"))') end if - xyz = xyz*aatoau + xyz = xyz*aatoau !> NOTE: BACK TO BOHRS deallocate (vibs) return end subroutine calcthermo subroutine calc_thermo_from_hess(mol,hess,pr,nt,temps,ithr,& - & fscal,sthr,et,ht,gt,stot, etot) + & fscal,sthr,et,ht,gt,stot,etot) type(coord),intent(inout) :: mol integer :: nat3 integer :: io,iunit @@ -289,7 +318,7 @@ subroutine calc_thermo_from_hess(mol,hess,pr,nt,temps,ithr,& real(wp),allocatable,intent(out) :: et(:),ht(:),gt(:),stot(:) real(wp),intent(inout) :: hess(:,:) real(wp),allocatable :: freq(:) - real(wp), intent(in) :: etot + real(wp),intent(in) :: etot real(wp) :: zpve integer :: nrt real(wp),allocatable :: int_temps(:) @@ -316,20 +345,19 @@ subroutine calc_thermo_from_hess(mol,hess,pr,nt,temps,ithr,& zpve = et(nrt)-ht(nrt) if (pr) then - write (stdout,*) - write (stdout,'(10x,a)') repeat(':',50) - write (stdout,'(10x,"::",7x,a,f12.2,1x,a,8x,"::")') "THERMODYNAMICS at",temps(nrt),'K' - write (stdout,'(10x,a)') repeat(':',50) - write (stdout,outfmt) 'TOTAL FREE ENERGY',etot+gt(nrt),'Eh' - write (stdout,'(10x,a)') '::'//repeat('-',46)//'::' - write (stdout,outfmt) 'total energy ',etot,'Eh' - write (stdout,outfmt) 'ZPVE ',zpve,'Eh' - write (stdout,outfmt) 'G(RRHO) w/o ZPVE ',gt(nrt)-zpve,'Eh' - write (stdout,outfmt) 'G(RRHO) total ',gt(nrt),'Eh' - write (stdout,'(10x,a)') repeat(':',50) - endif + write (stdout,*) + write (stdout,'(10x,a)') repeat(':',50) + write (stdout,'(10x,"::",7x,a,f12.2,1x,a,8x,"::")') "THERMODYNAMICS at",temps(nrt),'K' + write (stdout,'(10x,a)') repeat(':',50) + write (stdout,outfmt) 'TOTAL FREE ENERGY',etot+gt(nrt),'Eh' + write (stdout,'(10x,a)') '::'//repeat('-',46)//'::' + write (stdout,outfmt) 'total energy ',etot,'Eh' + write (stdout,outfmt) 'ZPVE ',zpve,'Eh' + write (stdout,outfmt) 'G(RRHO) w/o ZPVE ',gt(nrt)-zpve,'Eh' + write (stdout,outfmt) 'G(RRHO) total ',gt(nrt),'Eh' + write (stdout,'(10x,a)') repeat(':',50) + end if end subroutine calc_thermo_from_hess - end module thermochem_module diff --git a/src/legacy_wrappers.f90 b/src/legacy_wrappers.f90 index 003306c7..ae25e43c 100644 --- a/src/legacy_wrappers.f90 +++ b/src/legacy_wrappers.f90 @@ -197,6 +197,21 @@ subroutine env2calc_modify(env) call env%calc%ONIOMexpand() end if +!>--- pass on thermo data to the calculator + if (.not.allocated(env%calc%temperatures)) then + if (.not.allocated(env%thermo%temps)) then + call env%thermo%get_temps() + end if + env%calc%nt = env%thermo%ntemps + allocate (env%calc%temperatures(env%calc%nt),source=0.0_wp) + + env%calc%temperatures = env%thermo%temps + env%calc%ithr = env%thermo%ithr + env%calc%sthr = env%thermo%sthr + env%calc%fscal = env%thermo%fscal + env%calc%emodel = env%thermo%emodel + end if + end subroutine env2calc_modify !================================================================================! diff --git a/src/parsing/confparse2.f90 b/src/parsing/confparse2.f90 index 96cfaeea..e4705bf1 100644 --- a/src/parsing/confparse2.f90 +++ b/src/parsing/confparse2.f90 @@ -223,18 +223,18 @@ subroutine env_calcdat_specialcases(env) end do end if - if (.not.allocated(env%calc%temperatures)) then - if (.not.allocated(env%thermo%temps)) then - call env%thermo%get_temps() - end if - env%calc%nt = env%thermo%ntemps - allocate (env%calc%temperatures(env%calc%nt),source=0.0_wp) - env%calc%temperatures = env%thermo%temps - env%calc%ithr = env%thermo%ithr - env%calc%sthr = env%thermo%sthr - env%calc%fscal = env%thermo%fscal - end if + + + + + + + + + + + end subroutine env_calcdat_specialcases diff --git a/src/parsing/parse_maindata.f90 b/src/parsing/parse_maindata.f90 index 34f5ae30..e3361d92 100644 --- a/src/parsing/parse_maindata.f90 +++ b/src/parsing/parse_maindata.f90 @@ -463,6 +463,19 @@ subroutine parse_thermo(env,blk,istat) case ('freq_input','vibs','hessian') env%thermo%vibfile = kv%value_c if (allocated(env%thermo%coords)) env%properties = p_thermo + + case ('entropy_model','svib_model') + select case (kv%value_c) + case ('grimme') + env%thermo%emodel = kv%value_c + case ('truhlar') + env%thermo%emodel = kv%value_c + env%thermo%sthr = 100.0_wp + case default + write (stdout,fmtura) trim(kv%rawvalue) + call creststop(status_config) + end select + case default !>--- unrecognized keyword istat = istat+1 diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index 237312b9..05d24524 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -1297,6 +1297,7 @@ subroutine ens_freq_calculator(env,fname,NTMP,TMPdir,opt) integer :: n3,io,ich real(wp) :: ithr,fscal,sthr + character(len=:),allocatable :: emodel integer :: nt,nfreq,nrt real(wp),allocatable :: temps(:),et(:),ht(:),stot(:),gt(:) real(wp) :: zpve @@ -1342,6 +1343,8 @@ subroutine ens_freq_calculator(env,fname,NTMP,TMPdir,opt) fscal = env%thermo%fscal !> RR-HO interpolation sthr = env%thermo%sthr + !> Svib model + emodel = env%thermo%emodel !> we just need one temperature nt = 1 @@ -1380,7 +1383,7 @@ subroutine ens_freq_calculator(env,fname,NTMP,TMPdir,opt) open (newunit=ich,file="xtb_freq.out") !> calcthermo wants input in Bohr call calcthermo(mol%nat,mol%at,mol%xyz,freq,.true., & - & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,ich) + & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,ich,emodel=emodel) close (ich) deallocate (freq,hess,tmpgrd) From 226f6a9ff7bef17d0eb574344ade964e27d5c93e Mon Sep 17 00:00:00 2001 From: LukasRindt Date: Thu, 19 Feb 2026 13:47:45 +0100 Subject: [PATCH 180/374] optimizers refixed --- src/calculator/calc_type.f90 | 2 +- src/optimize/ancopt.f90 | 18 ++++++- src/optimize/newton_raphson.f90 | 3 +- src/optimize/optutils.f90 | 87 --------------------------------- src/optimize/rfo.f90 | 3 +- 5 files changed, 22 insertions(+), 91 deletions(-) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index bb04569f..daa4824e 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -256,7 +256,7 @@ module calc_type integer :: iupdat = 0 !> 0=BFGS, 1=Powell, 2=SR1, 3=Bofill, 4=Schlegel integer :: opt_engine = 0 !> default: ANCOPT integer :: lbfgs_histsize = 20 !> L-BFGS history size - integer :: hess_init = 0 !> Initialization of the hessian, standard is scaled identity (with hguess) + integer :: hess_init = 5 !> Initialization of the hessian, standard modhess lindh95 !>--- GFN0* data, needed for special MECP application type(gfn0_data),allocatable :: g0calc diff --git a/src/optimize/ancopt.f90 b/src/optimize/ancopt.f90 index 6a65e9be..469bda75 100644 --- a/src/optimize/ancopt.f90 +++ b/src/optimize/ancopt.f90 @@ -476,7 +476,7 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & ! alp = 3.0d0 ! 3 !end if - alp = alp_generate(gnorm,calc%optlev,calc%opt_engine, calc%hess_init) + alp = alp_generate(gnorm) !write(stdout,*) alp !>------------------------------------------------------------------------ @@ -639,5 +639,21 @@ subroutine trfp2xyz(nvar,nat3,p,xyz0,h,dspl) end subroutine trfp2xyz !========================================================================================! + + function alp_generate(gnorm) result(alp) +!**************************************************** +!* Computes stepsize scaling factor +!**************************************************** + real(wp), intent(in) :: gnorm + real(wp) :: alp, shift, l, k + + l=2.0_wp + k=2000.0 + shift=0.0005 + + alp = L/(1+euler**(k*(gnorm-shift)))+1 + + end function alp_generate + !========================================================================================! end module ancopt_module diff --git a/src/optimize/newton_raphson.f90 b/src/optimize/newton_raphson.f90 index f2257a4b..1ea8f511 100644 --- a/src/optimize/newton_raphson.f90 +++ b/src/optimize/newton_raphson.f90 @@ -310,7 +310,8 @@ subroutine newton_raphson(mol,calc,etot,grd,pr,wr,iostatus) !end if - alp = alp_generate(gnorm, calc%optlev,calc%opt_engine, calc%hess_init) + !alp = alp_generate(gnorm, calc%optlev,calc%opt_engine, calc%hess_init) + alp = 1.0_wp !write(stdout,*) alp !>------------------------------------------------------------------------ diff --git a/src/optimize/optutils.f90 b/src/optimize/optutils.f90 index f935101f..e9195874 100644 --- a/src/optimize/optutils.f90 +++ b/src/optimize/optutils.f90 @@ -454,92 +454,5 @@ subroutine print_convd(econverged,gconverged) end subroutine print_convd !========================================================================================! - - function alp_generate(gnorm,optlev,optimizer, hessian_init) result(alp) -!**************************************************** -!* Computes stepsize scaling factor depending on optimizer -!* and optlev -!**************************************************** - real(wp), intent(in) :: gnorm - integer, intent(in) :: optlev, optimizer, hessian_init - real(wp) :: alp, shift, l, k - - alp = 1.0_wp - if (gnorm .lt. 0.002) then ! 0.002 - alp = 1.5_wp ! 1.5 - end if - if (gnorm .lt. 0.0006) then - alp = 2.0_wp ! 2 - end if - if (gnorm .lt. 0.0003) then - alp = 3.0_wp ! 3 - end if - - select case(optimizer) - case (0) !ancopt - select case(optlev) - case (-1) !loose - L=2.0_wp - k=4000_wp - shift=0.0005_wp - case(0) !normal - L=1.5_wp - k=8000_wp - shift=0.0007_wp - case(1) !tight - L=1.5_wp - k=6000_wp - shift=0.0007_wp - case(2) !vtight - L=1.5_wp - k=2000_wp - shift=0.0007_wp - end select - case (2) !rfo - select case(optlev) - case (-1) !loose - L=2.0_wp - k=2000_wp - shift=0.0005_wp - case(0) !normal - L=1.5_wp - k=8000_Wp - shift=0.0003_wp - case(1) !tight - L=0.05_wp - k=6000_wp - shift=0.0003_wp - case(2) !vtight, we do not scale here - L=0.0_wp - k=1.0_wp - shift=1.0_wp - end select - case (3) !Newton - select case(optlev) - case (-1) !loose - L=2.0_wp - k=4000_wp - shift=0.0005_wp - case(0) !normal - L=0.5_wp - k=4000_wp - shift=0.0001_wp - case(1) !tight, we do not scale here - L=0.0_wp - k=1.0_wp - shift=1.0_wp - case(2) !vtight - L=0.5_wp - k=8000_wp - shift=0.0003_wp - end select - end select - - alp = L/(1+euler**(k*(gnorm-shift)))+1 - - if (hessian_init .eq. 0) alp = 1.0_wp - - end function alp_generate - !========================================================================================! end module optimize_utils diff --git a/src/optimize/rfo.f90 b/src/optimize/rfo.f90 index 216080f3..a5ca3e11 100644 --- a/src/optimize/rfo.f90 +++ b/src/optimize/rfo.f90 @@ -328,8 +328,9 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !end if - alp = alp_generate(gnorm, calc%optlev,calc%opt_engine, calc%hess_init) + !alp = alp_generate(gnorm, calc%optlev,calc%opt_engine, calc%hess_init) !write(stdout,*) alp + alp = 1.0_wp !The whole thing should be removed before merging!! Same for NR! !>------------------------------------------------------------------------ From 813eec43f722c441cfaf2ba796731ab3e03da4bb Mon Sep 17 00:00:00 2001 From: LukasRindt Date: Thu, 19 Feb 2026 14:23:27 +0100 Subject: [PATCH 181/374] ancopt alp 1 --- src/optimize/ancopt.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/optimize/ancopt.f90 b/src/optimize/ancopt.f90 index 469bda75..cb40546b 100644 --- a/src/optimize/ancopt.f90 +++ b/src/optimize/ancopt.f90 @@ -465,7 +465,7 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & end if end if - !alp = 1.0d0 + alp = 1.0d0 !if (gnorm .lt. 0.002) then ! 0.002 ! alp = 1.5d0 ! 1.5 !end if @@ -476,7 +476,7 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & ! alp = 3.0d0 ! 3 !end if - alp = alp_generate(gnorm) + !alp = alp_generate(gnorm) !write(stdout,*) alp !>------------------------------------------------------------------------ From 1fbbef2460b7cfae875743e691ebc539b2b134fd Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 21 Feb 2026 16:06:09 +0100 Subject: [PATCH 182/374] Fix io error in cleanup --- src/cleanup.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cleanup.f90 b/src/cleanup.f90 index c3f43f06..8a6a0d0b 100644 --- a/src/cleanup.f90 +++ b/src/cleanup.f90 @@ -72,9 +72,9 @@ subroutine custom_cleanup(env) call rmrf('cregen_*.tmp') call rmrf('MDFILES') if(allocated(env%calc%calcs))then - if(.not.any(env%calc%calcs(:)%pr))then + !if(.not.any(env%calc%calcs(:)%pr))then call rmrfw('calculation.level.') - endif + !endif endif endif call rmrf('.CHRG .UHF') From b54e119d933337909c3ee72c908c0efcd40cb67d Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 25 Feb 2026 13:32:42 +0100 Subject: [PATCH 183/374] Moving some thermo/frequency routines around --- src/algos/CMakeLists.txt | 1 - src/algos/hessian_tools.f90 | 542 ------------------------------ src/algos/meson.build | 1 - src/algos/numhess.f90 | 2 +- src/calculator/calculator.F90 | 1 + src/crest_pars.f90 | 7 +- src/entropy/thermo.f90 | 10 +- src/entropy/thermocalc.f90 | 1 - src/entropy/thermochem_module.f90 | 467 ++++++++++++++++++++++++- src/optimize/optimize_module.f90 | 1 - src/qcg/qcg_misc.f90 | 1 - 11 files changed, 468 insertions(+), 566 deletions(-) delete mode 100644 src/algos/hessian_tools.f90 diff --git a/src/algos/CMakeLists.txt b/src/algos/CMakeLists.txt index 57dfc9e1..dc4f2dff 100644 --- a/src/algos/CMakeLists.txt +++ b/src/algos/CMakeLists.txt @@ -30,7 +30,6 @@ list(APPEND srcs "${dir}/setuptest.f90" "${dir}/sorting.f90" "${dir}/protonate.f90" - "${dir}/hessian_tools.f90" "${dir}/ConfSolv.F90" "${dir}/search_conformers.f90" "${dir}/search_entropy.f90" diff --git a/src/algos/hessian_tools.f90 b/src/algos/hessian_tools.f90 deleted file mode 100644 index 716db799..00000000 --- a/src/algos/hessian_tools.f90 +++ /dev/null @@ -1,542 +0,0 @@ -!================================================================================! -! This file is part of crest. -! -! Copyright (C) 2023 Gereon Feldmann -! -! crest is free software: you can redistribute it and/or modify it under -! the terms of the GNU Lesser General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! crest is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public License -! along with crest. If not, see . -! Routines were adapted from the xtb code (github.com/grimme-lab/xtb) -! under the Open-source software LGPL-3.0 Licencse. -!================================================================================! - -!========================================================================================! -!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>! -!> Routines for the computation of a projected mass-weighted Hessian -!> Routines for the computation of frequencies from the Hessian -!> Rotuines for the computation of the effective Hessian at an MECP based on: DOI:10.1039/A907723E -!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>! -!========================================================================================! - -module hessian_tools - use crest_parameters,only:wp,stdout - ! use crest_data - use crest_calculator - use strucrd - !use optimize_module - use optimize_maths - use iomod - - public :: frequencies - -!=========================================================================================! -!=========================================================================================! -contains !> MODULE PROCEDURES START HERE -!=========================================================================================! -!=========================================================================================! - - subroutine frequencies(nat,at,xyz,nat3,prj_mw_hess,freq,io) -!************************************************* -!* Returns the Frequencies from a Hessian in cm-1 -!************************************************* - implicit none - - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - real(wp),intent(in) :: xyz(3,nat) - real(wp) :: prj_mw_hess(nat3,nat3) - - integer :: io,nat3 - logical :: pr - real(wp) :: energy - real(wp) :: freq(nat3) - real(wp),allocatable :: pmode(:,:) - - integer,allocatable :: iwork(:) - real(wp),allocatable :: work(:) - - integer :: lwork,liwork,info,i - integer :: unit - !>LAPCK - external :: dsyevd - - nat3 = nat*3 - - !Parameters for diagonalization - lwork = 1+6*nat3+2*nat3**2 - liwork = 3+5*nat3 - - allocate (work(lwork),iwork(liwork)) - - !Diagonalization - call dsyevd('V','U',nat3,prj_mw_hess,nat3,freq,work,lwork,iwork,liwork,info) - - deallocate (work,iwork) - - !Convert eigenvalues to frequencies - do i = 1,nat3 - if (freq(i) .gt. 0.0_wp) then - freq(i) = sqrt(freq(i))*219474.63_wp - else - freq(i) = -sqrt(abs(freq(i)))*219474.63_wp - end if - end do - - open (newunit=unit,file="frequencies") - write (unit,*) "Frequencies:" - do i = 1,size(freq) - write (unit,*) freq(i) - end do - close (unit) - - return - - end subroutine frequencies - - subroutine mass_weight_hess(nat,at,nat3,hess) - use atmasses - implicit none - - !> Mass weighting the Hessian - integer,intent(in) :: nat !Number of atoms - integer,intent(in) :: at(nat) !atomic number of all atoms - - real(wp),intent(inout) :: hess(nat3,nat3) !Hessian matrix - real(wp) :: mass_in_au !Masses of all atoms of the periodic table - integer :: i,j,nat3,i3,i33,j3,j33 - - mass_in_au = (1.66054e-27_wp/9.1094e-31_wp)**2 - - !amv = ams(1:118) - - do i = 1,nat - do j = i,nat - - i3 = 3*(i-1)+1 - i33 = 3*(i-1)+3 - j3 = 3*(j-1)+1 - j33 = 3*(j-1)+3 - - hess(i3:i33,j3:j33) = 1/sqrt(ams(at(i))*ams(at(j))*mass_in_au)*hess(i3:i33,j3:j33) - !Hessian is symmetric hence upper triangular can be copied - hess(j3:j33,i3:i33) = hess(i3:i33,j3:j33) - - end do - end do - - return - end subroutine mass_weight_hess - -!=========================================================================================! - - subroutine prj_mw_hess(nat,at,nat3,xyz,hess) -!*************************************************************** -!* Projection of the translational and rotational DOF out of -!* the numerical Hessian plus the mass-weighting of the Hessian -!*************************************************************** - implicit none - - integer,intent(in) :: nat,nat3 - integer :: at(nat) - real(wp),intent(inout) :: hess(nat3,nat3) - real(wp) :: xyz(3,nat) - !real(wp) :: hess_ut(nat3*(nat3+1)/2),pmode(nat3,1) - real(wp),allocatable :: hess_ut(:),pmode(:,:) - integer :: i - - allocate (hess_ut(nat3*(nat3+1)/2),source=0.0_wp) - allocate (pmode(nat3,1),source=0.0_wp) - - !> Transforms matrix of the upper triangle vector - call dsqtoh(nat3,hess,hess_ut) - - !> Projection - call trproj(nat,nat3,xyz,hess_ut,.false.,0,pmode,1) - - !> Transforms vector of the upper triangle into matrix - call dhtosq(nat3,hess,hess_ut) - - !> Mass weighting - call mass_weight_hess(nat,at,nat3,hess) - - deallocate (pmode,hess_ut) - end subroutine prj_mw_hess - -!=========================================================================================! - - subroutine print_vib_spectrum(nat,at,nat3,xyz,freq,dir,fname) -!********************************************************************* -!* Prints the frequencies in Turbomoles "vibspectrum" format -!* The intensity is only artficially set to 1000 for every vibration!! -!********************************************************************** - integer,intent(in) :: nat,nat3 - integer :: at(nat),i - real(wp) :: xyz(3,nat) - real(wp) :: freq(nat3),thr - character(len=*) :: fname - character(len=*) :: dir - - thr = 0.01_wp - if (len_trim(dir) .eq. 0) then - open (newunit=ich,file=fname) - else - if (directory_exist(dir)) then - open (newunit=ich,file=dir//'/'//fname) - else - open (newunit=ich,file=fname) - end if - end if - - write (ich,'("$vibrational spectrum")') - write (ich,'("# mode symmetry wave number IR intensity selection rules")') - write (ich,'("# 1/cm km/mol IR RAMAN")') - - do i = 1,nat3 - if (abs(freq(i)) .lt. thr) then - write (ich,'(i6,9x, f18.2,f16.5,7x," - ",5x," - ")') & - i,freq(i),0.0_wp - else - write (ich,'(i6,8x,"a",f18.2,f16.5,7x,"YES",5x,"YES")') & - i,freq(i),1000.0_wp - end if - end do - - write (ich,'("$end")') - - close (ich) - - end subroutine print_vib_spectrum - -!=========================================================================================! - - subroutine print_g98_fake(nat,at,nat3,xyz,freq,hess,dir,fname) -!**************************************************************** -!* Prints the vibration spectrum of the a system as a g98.out. -!* Routine is adapted from the xtb code. -!**************************************************************** - integer,intent(in) :: nat,nat3 - integer :: at(nat) - integer :: gu,i,j,ka,kb,kc,la,lb,k - - real(wp) :: xyz(3,nat) - real(wp),intent(in) :: hess(nat3,nat3) - real(wp) :: freq(nat3),red_mass(nat3),force(nat3),ir_int(nat3),zero(1),f2(nat3),u(nat3,nat3) - - character(len=2) :: irrep - character(len=*) :: fname - character(len=*) :: dir - - irrep = 'a' - - red_mass = 99.0 - force = 99.0 - ir_int = 99.0 - zero = 0.0 - - k = 0 - - do i = 1,nat3 - if (abs(freq(i)) .gt. 1.d-1) then - k = k+1 - u(1:nat3,k) = hess(1:nat3,i) - f2(k) = freq(i) - end if - end do - - if (len_trim(dir) .eq. 0) then - open (newunit=gu,file=fname) - else - if (directory_exist(dir)) then - open (newunit=gu,file=dir//'/'//fname) - else - open (newunit=gu,file=fname) - end if - end if - - write (gu,'('' Entering Gaussian System'')') - write (gu,'('' *********************************************'')') - write (gu,'('' Gaussian 98:'')') - write (gu,'('' frequency output generated by the crest code'')') - write (gu,'('' *********************************************'')') - - write (gu,*) ' Standard orientation:' - write (gu,*) '---------------------------------------------', & - & '-----------------------' - write (gu,*) ' Center Atomic Atomic', & - & ' Coordinates (Angstroms)' - write (gu,*) ' Number Number Type ', & - & ' X Y Z' - write (gu,*) '-----------------------', & - & '---------------------------------------------' - j = 0 - do i = 1,nat - write (gu,111) i,at(i),j,xyz(1:3,i)*0.52917726 - end do - write (gu,*) '----------------------', & - & '----------------------------------------------' - write (gu,*) ' 1 basis functions 1 primitive gaussians' - write (gu,*) ' 1 alpha electrons 1 beta electrons' - write (gu,*) -111 format(i5,i11,i14,4x,3f12.6) - - write (gu,*) 'Harmonic frequencies (cm**-1), IR intensities',' (km*mol⁻¹),' - write (gu,*) 'Raman scattering activities (A**4/amu),', & - & ' Raman depolarization ratios,' - write (gu,*) 'reduced masses (AMU), force constants (mDyne/A)', & - & ' and normal coordinates:' - - ka = 1 - kc = 3 - -60 kb = min0(kc,k) - write (gu,100) (j,j=ka,kb) - write (gu,105) (irrep,j=ka,kb) - write (gu,110) ' Frequencies --', (f2(j),j=ka,kb) - write (gu,110) ' Red. masses --', (red_mass(j),j=ka,kb) - write (gu,110) ' Frc consts --', (force(j),j=ka,kb) - write (gu,110) ' IR Inten --', (ir_int(j),j=ka,kb) - write (gu,110) ' Raman Activ --', (zero,j=ka,kb) - write (gu,110) ' Depolar --', (zero,j=ka,kb) - write (gu,*) 'Atom AN X Y Z X Y', & - & ' Z X Y Z' - la = 1 -70 lb = nat - do i = la,lb - write (gu,130) i,at(i), (u(i*3-2,j),u(i*3-1,j),u(i*3,j),j=ka,kb) - end do - if (lb .eq. nat) go to 90 - go to 70 -90 if (kb .eq. k) then - goto 200 - end if - - ka = kc+1 - kc = kc+3 - go to 60 - -100 format(3(20x,i3)) -105 format(3x,3(18x,a5)) -110 format(a15,f11.4,12x,f11.4,12x,f11.4) -130 format(2i4,3(2x,3f7.2)) -200 continue - write (gu,'(''end of file'')') - close (gu) - - end subroutine print_g98_fake - -!=========================================================================================! - - subroutine print_hessian(hess,nat3,dir,fname) -!******************************* -!* Prints the numerical hessian -!******************************* - integer :: nat3,i,j,k - real(wp) :: hess(nat3,nat3) - character(len=*) :: fname - character(len=*) :: dir - - if (len_trim(dir) .eq. 0) then - open (newunit=ich,file=fname) - write (stdout,'(1x,a)',advance='no') 'Will be written to file "'//fname//'" ...' - else - if (directory_exist(dir)) then - open (newunit=ich,file=dir//'/'//fname) - write (stdout,'(1x,a)',advance='no') 'Will be written to file "'//dir//'/'//fname//'" ...' - else - open (newunit=ich,file=fname) - write (stdout,'(1x,a)',advance='no') 'Will be written to file "'//fname//'" ...' - end if - end if - flush (stdout) - - write (ich,'(1x,a)') '$hessian' - do i = 1,nat3 - k = 0 - do j = 1,nat3 - k = k+1 - if (k .le. 4) then - write (ich,'(f16.8)',advance='no') hess(i,j) - else - write (ich,'(f16.8)') hess(i,j) - k = 0 - end if - end do - if (k .ne. 0) then - write (ich,*) - end if - end do - write (ich,'(1x,a)') '$end' - close (ich) - - write (stdout,*) 'done.' - write (stdout,*) - - end subroutine print_hessian - -!=========================================================================================! - - subroutine effective_hessian(nat,nat3,grad1_i,grad2_i,hess1,hess2,heff) -!****************************************************************** -!* Effective Hessian at an MECP is computed via Eq. 27 and Eq. 28 -!* in https://doi.org/10.1002/qua.25124 -!****************************************************************** - implicit none - integer,intent(in) :: nat,nat3 - integer :: i,j,ii - real(wp),intent(in) :: grad1_i(3,nat3),grad2_i(3,nat3) - real(wp) :: grad1(nat3),grad2(nat3),dot - - real(wp),intent(in) :: hess1(nat3,nat3),hess2(nat3,nat3) - - real(wp) :: gnorm1,gnorm2,grad_diff_norm - real(wp) :: grad_diff(nat3),heff_temp(nat3,nat3) - - real(wp),intent(inout) :: heff(nat3,nat3) - real(wp),allocatable :: proj_vec(:,:) - - real(wp) :: freq(nat3) - - integer,allocatable :: iwork(:) - real(wp),allocatable :: work(:) - - integer :: lwork,liwork,info - - allocate (proj_vec(nat3,nat3),source=0.0_wp) - - grad1 = reshape(grad1_i, (/nat3/)) - grad2 = reshape(grad2_i, (/nat3/)) - - gnorm1 = norm2(grad1) - - gnorm2 = norm2(grad2) - - grad_diff = grad1-grad2 - - grad_diff_norm = norm2(grad_diff) - - dot = dot_product(grad1,grad2) - - if (dot .gt. 0.0_wp) then !sloped: dot > 0.0 --> - | peaked: dot <= 0.0 --> + - - write (stdout,*) 'MECI is considered as a sloped CI' - write (stdout,*) - - heff = (gnorm1*hess2-gnorm2*hess1)/grad_diff_norm - - else - - write (stdout,*) 'MECI is considered as a peaked CI' - write (stdout,*) - - heff = (gnorm1*hess2+gnorm2*hess1)/grad_diff_norm - - end if - - !Outer Product of grad_diff - - !Building projection matrix - - !proj_vec = 1 - (dg/|dg| o dg.T/|dg|) = 1 - (dg o dg.T)/|dg|**2 - - grad_diff_norm = grad_diff_norm**2 - - do i = 1,nat3 - proj_vec(i,:) = -grad_diff(i)*grad_diff/grad_diff_norm - proj_vec(i,i) = proj_vec(i,i)+1 - end do - - !Projection - heff = matmul(matmul(proj_vec,heff),proj_vec) - - !Check if hess1 and hess2 are assigned correctly, otherwise change - lwork = 1+6*nat3+2*nat3**2 - liwork = 3+5*nat3 - allocate (work(lwork),iwork(liwork)) - - heff_temp = heff - - call dsyevd('V','U',nat3,heff_temp,nat3,freq,work,lwork,iwork,liwork,info) - - deallocate (work,iwork) - - if (0 .gt. sum(freq)) then - heff = -heff - end if - - end subroutine effective_hessian - -!=========================================================================================! - - subroutine calculate_frequencies(calc,nat,at,xyz,freq,io,constraints) -!******************************************************* -!* Bundels several routines from this module to -!* calculate the vib. frequencies for a given structure -!* The output frequencies are in cm-1 -!******************************************************* - implicit none - !> INPUT - type(calcdata),intent(inout) :: calc - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - real(wp),intent(in) :: xyz(3,nat) - logical,intent(in),optional :: constraints - !> OUTPUT - integer,intent(out) :: io - real(wp),intent(out) :: freq(3*nat) - !> LOCAL - real(wp),allocatable :: hessian(:,:) - real(wp),allocatable :: chess(:,:) - type(calcdata) :: dummycalc - integer :: nat3,ncalc,i - - io = 0 - freq = 0.0_wp - nat3 = nat*3 - ncalc = calc%ncalculations - - allocate (hessian(nat3,nat3),source=0.0_wp) - - !>--- Hessian from combined energy and gradient - call numhess1(nat,at,xyz,calc,hessian,io) - if (io /= 0) return - - !>--- do we consider contributions from the constraints? - !> (yes, by default, they are in the hessian from numhess1, - !> if we DO NOT want them, we need to take them out again) - if (present(constraints)) then - if (.not.constraints) then - dummycalc = calc !> new dummy calculation - dummycalc%id = 0 !> set to zero so that ONLY constraints are considered - dummycalc%ncalculations = 0 - dummycalc%pr_energies = .false. - allocate (chess(nat3,nat3),source=0.0_wp) - call numhess1(nat,at,xyz,dummycalc,chess,io) - hessian(:,:) = hessian(:,:)-chess(:,:) - deallocate (chess) - end if - end if - - do i = 1,calc%ncalculations - - !>-- Projects and mass-weights the Hessian - call prj_mw_hess(nat,at,nat3,xyz,hessian(:,:)) - - !>-- Computes the Frequencies - call frequencies(nat,at,xyz,nat3,hessian(:,:),freq(:),io) - end do - - deallocate (hessian) - return - end subroutine calculate_frequencies - -!=========================================================================================! -end module hessian_tools diff --git a/src/algos/meson.build b/src/algos/meson.build index a4283a63..8f7e466c 100644 --- a/src/algos/meson.build +++ b/src/algos/meson.build @@ -28,7 +28,6 @@ srcs += files( 'setuptest.f90', 'sorting.f90', 'protonate.f90', - 'hessian_tools.f90', 'ConfSolv.F90', 'search_conformers.f90', 'search_entropy.f90', diff --git a/src/algos/numhess.f90 b/src/algos/numhess.f90 index 795d5366..d0d2c205 100644 --- a/src/algos/numhess.f90 +++ b/src/algos/numhess.f90 @@ -32,7 +32,7 @@ subroutine crest_numhess(env,tim) use crest_calculator use strucrd use optimize_module - use hessian_tools + use thermochem_module use gradreader_module use xtb_sc use oniom_hessian diff --git a/src/calculator/calculator.F90 b/src/calculator/calculator.F90 index 11cedde3..68b7f433 100644 --- a/src/calculator/calculator.F90 +++ b/src/calculator/calculator.F90 @@ -30,6 +30,7 @@ module crest_calculator use constraints use nonadiabatic_module use lwoniom_module + use thermochem_module !$ use omp_lib implicit none !=========================================================================================! diff --git a/src/crest_pars.f90 b/src/crest_pars.f90 index 2c8ef879..0bc28740 100644 --- a/src/crest_pars.f90 +++ b/src/crest_pars.f90 @@ -14,10 +14,10 @@ module crest_parameters real(wp),parameter,public :: autoaa = bohr real(wp),parameter,public :: aatoau = angstrom - real(wp),parameter,public :: pi = acos(0.0_wp)*2.0_wp - real(wp),parameter,public :: radtodeg = 180.0_wp / pi + real(wp),parameter,public :: pi = acos(0.0_wp)*2.0_wp + real(wp),parameter,public :: radtodeg = 180.0_wp/pi real(wp),parameter,public :: euler = 2.718281828459045_wp - real(wp),parameter,public :: degtorad = 1.0_wp / radtodeg + real(wp),parameter,public :: degtorad = 1.0_wp/radtodeg real(wp),parameter,public :: amutokg = 1.660539040e-27_wp real(wp),parameter,public :: autokj = 2625.49964038_wp @@ -31,6 +31,7 @@ module crest_parameters real(wp),parameter,public :: kgtome = 1.0_wp/metokg real(wp),parameter,public :: c_vacuum = 299792458e0_wp + real(wp),parameter,public :: mhztorcm = 1.0_wp/(c_vacuum*10e-05_wp) !> Coulomb to atomic charge units (electrons) real(wp),public,parameter :: autoc = 1.6021766208e-19_wp real(wp),parameter,public :: ctoau = 1.0_wp/autoc diff --git a/src/entropy/thermo.f90 b/src/entropy/thermo.f90 index acd625bd..ca31b5d4 100644 --- a/src/entropy/thermo.f90 +++ b/src/entropy/thermo.f90 @@ -379,7 +379,10 @@ subroutine print_thermo_sthr_ts(iunit,nvib,vibs,avmom_si,sthr_rcm,temp) end if ! Head-Gordon weighting fswitch = 1.0_wp-chg_switching(omega,sthr) - if (omega > maxfreq*rcmtoau) exit + if (omega > maxfreq*rcmtoau) then + if (i == 1) write (iunit,'(a8,4x,a,10x,a,21x,a,20x,a)') 'none','-','-','-','-' + exit + end if write (iunit,'(i8,f10.2,2(f12.5,1x,"(",f6.2,"%)"),f12.5)') & i,omega*autorcm,-RT*s_v, (1.0_wp-fswitch)*100, & -RT*s_r,fswitch*100,-RT*((1.0_wp-fswitch)*s_v+fswitch*s_r) @@ -414,7 +417,10 @@ subroutine print_thermo_sthr_cut(iunit,nvib,vibs,sthr_rcm,temp) do i = 1,nvib ! frequency is Eh omega = vibs(i) - if (omega > maxfreq*rcmtoau) exit + if (omega > maxfreq*rcmtoau) then + if (i == 1) write (iunit,'(a8,4x,a,10x,a,20x,a,25x,a)') 'none','-','-','-','-' + exit + end if omega_cut = maxfreq*rcmtoau ! omega in Eh, beta in 1/Eh ewj = exp(-omega*beta) diff --git a/src/entropy/thermocalc.f90 b/src/entropy/thermocalc.f90 index 8a85529e..0da43bf4 100644 --- a/src/entropy/thermocalc.f90 +++ b/src/entropy/thermocalc.f90 @@ -220,7 +220,6 @@ subroutine thermo_wrap_new(env,pr,nat,at,xyz,dirname, & use crest_calculator use iomod use strucrd - use hessian_tools use thermochem_module implicit none !> INPUT diff --git a/src/entropy/thermochem_module.f90 b/src/entropy/thermochem_module.f90 index 4dd85fc3..f62939ef 100644 --- a/src/entropy/thermochem_module.f90 +++ b/src/entropy/thermochem_module.f90 @@ -1,18 +1,152 @@ module thermochem_module use crest_parameters use getsymmetry - use hessian_tools + use optimize_maths use atmasses,only:molweight - use iomod,only:to_lower + use iomod,only:to_lower,directory_exist use axis_module + use strucrd implicit none private - public calcthermo,calc_thermo_from_hess + public :: frequencies + public :: effective_hessian + public :: prj_mw_hess,mass_weight_hess + public :: calcthermo,calc_thermo_from_hess + public :: print_vib_spectrum,print_hessian,print_g98_fake -!==============================================================================! +!=============================================================================! contains !> MODULE PROCEDURES STARTE HERE -!==============================================================================! +!=============================================================================! + + subroutine frequencies(nat,at,xyz,nat3,prj_mw_hess,freq,io) +!************************************************* +!* Returns the Frequencies from a Hessian in cm-1 +!************************************************* + implicit none + + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(in) :: xyz(3,nat) + real(wp) :: prj_mw_hess(nat3,nat3) + + integer :: io,nat3 + logical :: pr + real(wp) :: energy + real(wp) :: freq(nat3) + real(wp),allocatable :: pmode(:,:) + + integer,allocatable :: iwork(:) + real(wp),allocatable :: work(:) + + integer :: lwork,liwork,info,i + integer :: unit + !>LAPCK + external :: dsyevd + + nat3 = nat*3 + + !Parameters for diagonalization + lwork = 1+6*nat3+2*nat3**2 + liwork = 3+5*nat3 + + allocate (work(lwork),iwork(liwork)) + + !Diagonalization + call dsyevd('V','U',nat3,prj_mw_hess,nat3,freq,work,lwork,iwork,liwork,info) + + deallocate (work,iwork) + + !Convert eigenvalues to frequencies + do i = 1,nat3 + if (freq(i) .gt. 0.0_wp) then + freq(i) = sqrt(freq(i))*autorcm + else + freq(i) = -sqrt(abs(freq(i)))*autorcm + end if + end do + + !open (newunit=unit,file="frequencies") + !write (unit,*) "Frequencies:" + !do i = 1,size(freq) + ! write (unit,*) freq(i) + !end do + !close (unit) + + return + + end subroutine frequencies + + subroutine mass_weight_hess(nat,at,nat3,hess) + implicit none + + !> Mass weighting the Hessian + integer,intent(in) :: nat !Number of atoms + integer,intent(in) :: at(nat) !atomic number of all atoms + + real(wp),intent(inout) :: hess(nat3,nat3) !Hessian matrix + real(wp) :: mass_in_au !Masses of all atoms of the periodic table + integer :: i,j,nat3,i3,i33,j3,j33 + + !mass_in_au = (1.66054e-27_wp/9.1094e-31_wp)**2 + mass_in_au = (amutokg/metokg)**2 + + do i = 1,nat + do j = i,nat + + i3 = 3*(i-1)+1 + i33 = 3*(i-1)+3 + j3 = 3*(j-1)+1 + j33 = 3*(j-1)+3 + + hess(i3:i33,j3:j33) = 1/sqrt(ams(at(i))*ams(at(j))*mass_in_au)*hess(i3:i33,j3:j33) + !Hessian is symmetric hence upper triangular can be copied + hess(j3:j33,i3:i33) = hess(i3:i33,j3:j33) + + end do + end do + + return + end subroutine mass_weight_hess + +!=========================================================================================! + + subroutine prj_mw_hess(nat,at,nat3,xyz,hess) +!*************************************************************** +!* Projection of the translational and rotational DOF out of +!* the numerical Hessian plus the mass-weighting of the Hessian +!*************************************************************** + implicit none + + integer,intent(in) :: nat,nat3 + integer :: at(nat) + real(wp),intent(inout) :: hess(nat3,nat3) + real(wp) :: xyz(3,nat) + !real(wp) :: hess_ut(nat3*(nat3+1)/2),pmode(nat3,1) + real(wp),allocatable :: hess_ut(:),pmode(:,:) + integer :: i + + allocate (hess_ut(nat3*(nat3+1)/2),source=0.0_wp) + allocate (pmode(nat3,1),source=0.0_wp) + + !> Transforms matrix of the upper triangle vector + call dsqtoh(nat3,hess,hess_ut) + + !> Projection + call trproj(nat,nat3,xyz,hess_ut,.false.,0,pmode,1) + + !> Transforms vector of the upper triangle into matrix + call dhtosq(nat3,hess,hess_ut) + + !> Mass weighting + call mass_weight_hess(nat,at,nat3,hess) + + deallocate (pmode,hess_ut) + end subroutine prj_mw_hess + + !============================================================================! + !############################################################################! + !============================================================================! subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar,iunit) !*********************************************************************** @@ -54,7 +188,8 @@ subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar,iunit) if (pr) then write (iunit,'(1x,a,3f15.2)') 'Rot. const. /MHz : ',rabc(1:3) end if - rabc = rabc/2.99792458d+4 ! MHz to cm-1 + !rabc = rabc/2.99792458d+4 ! MHz to cm-1 + rabc = rabc*mhztorcm if (pr) then write (iunit,'(1x,a,3f15.2)') 'Rot. const. /cm-1 : ',rabc(1:3) end if @@ -110,10 +245,10 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & !* from it's frequencies (from second derivatives/the Hessian) !* Based on xtb's "print_thermo" routine !************************************************************** - use crest_parameters,only:wp,bohr,stdout + !use crest_parameters,only:wp,bohr,stdout use crest_thermo - use atmasses,only:molweight - use iomod,only:to_lower + !use atmasses,only:molweight + !use iomod,only:to_lower implicit none integer,intent(in) :: nat integer,intent(in) :: at(nat) @@ -160,9 +295,9 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & character(len=*),parameter :: chrfmt = & & '(10x,":",2x,a,a24, t63,":")' - real(wp),parameter :: autorcm = 219474.63067_wp - real(wp),parameter :: rcmtoau = 1.0_wp/autorcm - real(wp),parameter :: autocal = 627.50947428_wp*1000.0_wp + !real(wp),parameter :: autorcm = 219474.63067_wp + !real(wp),parameter :: rcmtoau = 1.0_wp/autorcm + real(wp),parameter :: autocal = autokcal*1000.0_wp xyz = xyz*autoaa !> NOTE: FROM HERE ON WE WORK IN ANGSTRÖM @@ -245,7 +380,7 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & write (iunit,dblfmt) "rotor cutoff ",sthr,"cm^-1" case (2) write (iunit,chrfmt) "vib.entropy model ","Truhlar (2011)" - write (iunit,dblfmt) "frequency cutoff ",sthr,"cm^-1" + write (iunit,dblfmt) "frequency cutoff ",sthr,"cm^-1" end select write (iunit,dblfmt) "imag. cutoff ",ithr,"cm^-1" @@ -360,4 +495,310 @@ subroutine calc_thermo_from_hess(mol,hess,pr,nt,temps,ithr,& end subroutine calc_thermo_from_hess + subroutine effective_hessian(nat,nat3,grad1_i,grad2_i,hess1,hess2,heff) +!****************************************************************** +!* Effective Hessian at an MECP is computed via Eq. 27 and Eq. 28 +!* in https://doi.org/10.1002/qua.25124 +!****************************************************************** + implicit none + integer,intent(in) :: nat,nat3 + integer :: i,j,ii + real(wp),intent(in) :: grad1_i(3,nat3),grad2_i(3,nat3) + real(wp) :: grad1(nat3),grad2(nat3),dot + + real(wp),intent(in) :: hess1(nat3,nat3),hess2(nat3,nat3) + + real(wp) :: gnorm1,gnorm2,grad_diff_norm + real(wp) :: grad_diff(nat3),heff_temp(nat3,nat3) + + real(wp),intent(inout) :: heff(nat3,nat3) + real(wp),allocatable :: proj_vec(:,:) + + real(wp) :: freq(nat3) + + integer,allocatable :: iwork(:) + real(wp),allocatable :: work(:) + + integer :: lwork,liwork,info + + allocate (proj_vec(nat3,nat3),source=0.0_wp) + + grad1 = reshape(grad1_i, (/nat3/)) + grad2 = reshape(grad2_i, (/nat3/)) + + gnorm1 = norm2(grad1) + + gnorm2 = norm2(grad2) + + grad_diff = grad1-grad2 + + grad_diff_norm = norm2(grad_diff) + + dot = dot_product(grad1,grad2) + + if (dot .gt. 0.0_wp) then !sloped: dot > 0.0 --> - | peaked: dot <= 0.0 --> + + + write (stdout,*) 'MECI is considered as a sloped CI' + write (stdout,*) + + heff = (gnorm1*hess2-gnorm2*hess1)/grad_diff_norm + + else + + write (stdout,*) 'MECI is considered as a peaked CI' + write (stdout,*) + + heff = (gnorm1*hess2+gnorm2*hess1)/grad_diff_norm + + end if + + !Outer Product of grad_diff + + !Building projection matrix + + !proj_vec = 1 - (dg/|dg| o dg.T/|dg|) = 1 - (dg o dg.T)/|dg|**2 + + grad_diff_norm = grad_diff_norm**2 + + do i = 1,nat3 + proj_vec(i,:) = -grad_diff(i)*grad_diff/grad_diff_norm + proj_vec(i,i) = proj_vec(i,i)+1 + end do + + !Projection + heff = matmul(matmul(proj_vec,heff),proj_vec) + + !Check if hess1 and hess2 are assigned correctly, otherwise change + lwork = 1+6*nat3+2*nat3**2 + liwork = 3+5*nat3 + allocate (work(lwork),iwork(liwork)) + + heff_temp = heff + + call dsyevd('V','U',nat3,heff_temp,nat3,freq,work,lwork,iwork,liwork,info) + + deallocate (work,iwork) + + if (0 .gt. sum(freq)) then + heff = -heff + end if + + end subroutine effective_hessian + +!============================================================================! +!############################################################################! +!============================================================================! +!> PRINTOUT ROUTINES + subroutine print_vib_spectrum(nat,at,nat3,xyz,freq,dir,fname) +!********************************************************************* +!* Prints the frequencies in Turbomoles "vibspectrum" format +!* The intensity is only artficially set to 1000 for every vibration!! +!********************************************************************** + integer,intent(in) :: nat,nat3 + integer :: at(nat),i,ich + real(wp) :: xyz(3,nat) + real(wp) :: freq(nat3),thr + character(len=*) :: fname + character(len=*) :: dir + + thr = 0.01_wp + if (len_trim(dir) .eq. 0) then + open (newunit=ich,file=fname) + else + if (directory_exist(dir)) then + open (newunit=ich,file=dir//'/'//fname) + else + open (newunit=ich,file=fname) + end if + end if + + write (ich,'("$vibrational spectrum")') + write (ich,'("# mode symmetry wave number IR intensity selection rules")') + write (ich,'("# 1/cm km/mol IR RAMAN")') + + do i = 1,nat3 + if (abs(freq(i)) .lt. thr) then + write (ich,'(i6,9x, f18.2,f16.5,7x," - ",5x," - ")') & + i,freq(i),0.0_wp + else + write (ich,'(i6,8x,"a",f18.2,f16.5,7x,"YES",5x,"YES")') & + i,freq(i),1000.0_wp + end if + end do + + write (ich,'("$end")') + + close (ich) + + end subroutine print_vib_spectrum + +!=========================================================================================! + + subroutine print_g98_fake(nat,at,nat3,xyz,freq,hess,dir,fname) +!**************************************************************** +!* Prints the vibration spectrum of the a system as a g98.out. +!* Routine is adapted from the xtb code. +!**************************************************************** + integer,intent(in) :: nat,nat3 + integer :: at(nat) + integer :: gu,i,j,ka,kb,kc,la,lb,k + + real(wp) :: xyz(3,nat) + real(wp),intent(in) :: hess(nat3,nat3) + real(wp) :: freq(nat3),red_mass(nat3),force(nat3),ir_int(nat3),zero(1),f2(nat3),u(nat3,nat3) + + character(len=2) :: irrep + character(len=*) :: fname + character(len=*) :: dir + + irrep = 'a' + + red_mass = 99.0 + force = 99.0 + ir_int = 99.0 + zero = 0.0 + + k = 0 + + do i = 1,nat3 + if (abs(freq(i)) .gt. 1.d-1) then + k = k+1 + u(1:nat3,k) = hess(1:nat3,i) + f2(k) = freq(i) + end if + end do + + if (len_trim(dir) .eq. 0) then + open (newunit=gu,file=fname) + else + if (directory_exist(dir)) then + open (newunit=gu,file=dir//'/'//fname) + else + open (newunit=gu,file=fname) + end if + end if + + write (gu,'('' Entering Gaussian System'')') + write (gu,'('' *********************************************'')') + write (gu,'('' Gaussian 98:'')') + write (gu,'('' frequency output generated by the crest code'')') + write (gu,'('' *********************************************'')') + + write (gu,*) ' Standard orientation:' + write (gu,*) '---------------------------------------------', & + & '-----------------------' + write (gu,*) ' Center Atomic Atomic', & + & ' Coordinates (Angstroms)' + write (gu,*) ' Number Number Type ', & + & ' X Y Z' + write (gu,*) '-----------------------', & + & '---------------------------------------------' + j = 0 + do i = 1,nat + write (gu,111) i,at(i),j,xyz(1:3,i)*0.52917726 + end do + write (gu,*) '----------------------', & + & '----------------------------------------------' + write (gu,*) ' 1 basis functions 1 primitive gaussians' + write (gu,*) ' 1 alpha electrons 1 beta electrons' + write (gu,*) +111 format(i5,i11,i14,4x,3f12.6) + + write (gu,*) 'Harmonic frequencies (cm**-1), IR intensities',' (km*mol⁻¹),' + write (gu,*) 'Raman scattering activities (A**4/amu),', & + & ' Raman depolarization ratios,' + write (gu,*) 'reduced masses (AMU), force constants (mDyne/A)', & + & ' and normal coordinates:' + + ka = 1 + kc = 3 + +60 kb = min0(kc,k) + write (gu,100) (j,j=ka,kb) + write (gu,105) (irrep,j=ka,kb) + write (gu,110) ' Frequencies --', (f2(j),j=ka,kb) + write (gu,110) ' Red. masses --', (red_mass(j),j=ka,kb) + write (gu,110) ' Frc consts --', (force(j),j=ka,kb) + write (gu,110) ' IR Inten --', (ir_int(j),j=ka,kb) + write (gu,110) ' Raman Activ --', (zero,j=ka,kb) + write (gu,110) ' Depolar --', (zero,j=ka,kb) + write (gu,*) 'Atom AN X Y Z X Y', & + & ' Z X Y Z' + la = 1 +70 lb = nat + do i = la,lb + write (gu,130) i,at(i), (u(i*3-2,j),u(i*3-1,j),u(i*3,j),j=ka,kb) + end do + if (lb .eq. nat) go to 90 + go to 70 +90 if (kb .eq. k) then + goto 200 + end if + + ka = kc+1 + kc = kc+3 + go to 60 + +100 format(3(20x,i3)) +105 format(3x,3(18x,a5)) +110 format(a15,f11.4,12x,f11.4,12x,f11.4) +130 format(2i4,3(2x,3f7.2)) +200 continue + write (gu,'(''end of file'')') + close (gu) + + end subroutine print_g98_fake + +!=========================================================================================! + + subroutine print_hessian(hess,nat3,dir,fname) +!******************************* +!* Prints the numerical hessian +!******************************* + integer :: nat3,i,j,k,ich + real(wp) :: hess(nat3,nat3) + character(len=*) :: fname + character(len=*) :: dir + + if (len_trim(dir) .eq. 0) then + open (newunit=ich,file=fname) + write (stdout,'(1x,a)',advance='no') 'Will be written to file "'//fname//'" ...' + else + if (directory_exist(dir)) then + open (newunit=ich,file=dir//'/'//fname) + write (stdout,'(1x,a)',advance='no') 'Will be written to file "'//dir//'/'//fname//'" ...' + else + open (newunit=ich,file=fname) + write (stdout,'(1x,a)',advance='no') 'Will be written to file "'//fname//'" ...' + end if + end if + flush (stdout) + + write (ich,'(1x,a)') '$hessian' + do i = 1,nat3 + k = 0 + do j = 1,nat3 + k = k+1 + if (k .le. 4) then + write (ich,'(f16.8)',advance='no') hess(i,j) + else + write (ich,'(f16.8)') hess(i,j) + k = 0 + end if + end do + if (k .ne. 0) then + write (ich,*) + end if + end do + write (ich,'(1x,a)') '$end' + close (ich) + + write (stdout,*) 'done.' + write (stdout,*) + + end subroutine print_hessian + +!============================================================================! +!############################################################################! +!============================================================================! end module thermochem_module diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index e1b82785..c5a8b7ae 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -37,7 +37,6 @@ module optimize_module use hessian_reconstruct use newton_raphson_module use hr_utils - !use hessian_tools implicit none private diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index 05d24524..5b80fda8 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -1270,7 +1270,6 @@ subroutine ens_freq_calculator(env,fname,NTMP,TMPdir,opt) use crest_data use strucrd use crest_calculator - use hessian_tools use thermochem_module use optimize_module implicit none From 428c4ad630f744723202b10254997f9206febc8d Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 25 Feb 2026 15:00:43 +0100 Subject: [PATCH 184/374] Start implementing "approxg" with modelhessian thermocontributions --- src/calculator/CMakeLists.txt | 2 + src/calculator/approxg.f90 | 75 + src/calculator/calc_type.f90 | 19 +- src/calculator/calculator.F90 | 1 - src/calculator/meson.build | 3 + src/calculator/modelhessians.f90 | 3145 ++++++++++++++++++++++++++++++ src/optimize/modelhessian.f90 | 3115 +---------------------------- 7 files changed, 3243 insertions(+), 3117 deletions(-) create mode 100644 src/calculator/approxg.f90 create mode 100644 src/calculator/modelhessians.f90 diff --git a/src/calculator/CMakeLists.txt b/src/calculator/CMakeLists.txt index f285fda5..e398c61d 100644 --- a/src/calculator/CMakeLists.txt +++ b/src/calculator/CMakeLists.txt @@ -41,6 +41,8 @@ list(APPEND srcs "${dir}/subprocess_engrad.f90" "${dir}/hessian_reconstruct.f90" "${dir}/hr_utils.f90" + "${dir}/modelhessians.f90" + "${dir}/approxg.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/calculator/approxg.f90 b/src/calculator/approxg.f90 new file mode 100644 index 00000000..85f8c3a7 --- /dev/null +++ b/src/calculator/approxg.f90 @@ -0,0 +1,75 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2026 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +!> a small module for getting a free energy as engrad call + +module approxg_module + use crest_parameters + use calc_type + use modelhessian_core + use thermochem_module + use strucrd + implicit none + private + + public :: modh_engrad + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + subroutine modh_engrad(mol,calc,dg,dggrad) + type(coord),intent(in) :: mol + type(calculation_settings),intent(inout) :: calc + real(wp),intent(out) :: dg + real(wp),intent(out) :: dggrad(:) + integer :: n3 + + type(mhparam) :: mhset + + dg = 0.0_wp + dggrad(:) = 0.0_wp + + !> setup + n3 = mol%nat*3 + if (calc%approxg_dim .ne. mol%nat) then + !$omp critical + if (allocated(calc%approxg_hess)) deallocate (calc%approxg_hess) + allocate (calc%approxg_hess(n3,n3),source=0.0_wp) + + if (allocated(calc%approxg_h)) deallocate (calc%approxg_h) + allocate (calc%approxg_h(n3*(n3+1)/2),source=0.0_wp) + + + calc%approxg_dim = mol%nat + !$omp end critical + else + calc%approxg_hess(:,:) = 0.0_wp + calc%approxg_h(:) = 0.0_wp + end if + + call ddvopt(mol%xyz,mol%nat,calc%approxg_h,mol%at,mhset) + + end subroutine modh_engrad + +!========================================================================================! +!========================================================================================! +end module approxg_module diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index daa4824e..d03039ff 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -50,10 +50,11 @@ module calc_type integer :: gfnff = 9 integer :: libpvol = 10 integer :: lj = 11 + integer :: approxg = 12 end type enum_jobtype type(enum_jobtype), parameter,public :: jobtype = enum_jobtype() - character(len=45),parameter,private :: jobdescription(12) = [ & + character(len=45),parameter,private :: jobdescription(13) = [ & & 'Unknown calculation type ', & & 'xTB calculation via external binary ', & & 'Generic script execution ', & @@ -65,7 +66,8 @@ module calc_type & 'GFN0*-xTB calculation via GFN0 lib ', & & 'GFN-FF calculation via GFNFF lib ', & & 'external pressure calculation via libpvol ', & - & 'Lennard-Jones potential calculation ' ] + & 'Lennard-Jones potential calculation ', & + & 'Approximate free energy computation ' ] !&> !=========================================================================================! @@ -172,6 +174,13 @@ module calc_type real(wp) :: pvradscal = 1.0_wp !> Scaling factor for SAS radii type(libpvol_calculator),allocatable :: libpvol +!>--- approxg data + integer :: approxg_dim = 0 + real(wp) :: approxg_T = 298.15_wp + real(wp),allocatable :: approxg_hess(:,:) + real(wp),allocatable :: approxg_h(:) + real(wp),allocatable :: approxg_freq(:) + !> ONIOM fragment IDs integer :: ONIOM_highlowroot = 0 integer :: ONIOM_id = 0 @@ -1090,6 +1099,12 @@ subroutine calculation_settings_copy(self,src) self%ONIOM_highlowroot = src%ONIOM_highlowroot self%ONIOM_id = src%ONIOM_id + + self%approxg_dim = src%approxg_dim + self%approxg_T = src%approxg_T + if(allocated(src%approxg_hess)) self%approxg_hess = src%approxg_hess + if(allocated(src%approxg_h)) self%approxg_h = src%approxg_h + if(allocated(src%approxg_freq)) self%approxg_freq = src%approxg_freq !&< return end subroutine calculation_settings_copy diff --git a/src/calculator/calculator.F90 b/src/calculator/calculator.F90 index 68b7f433..11cedde3 100644 --- a/src/calculator/calculator.F90 +++ b/src/calculator/calculator.F90 @@ -30,7 +30,6 @@ module crest_calculator use constraints use nonadiabatic_module use lwoniom_module - use thermochem_module !$ use omp_lib implicit none !=========================================================================================! diff --git a/src/calculator/meson.build b/src/calculator/meson.build index da3d2598..bf130092 100644 --- a/src/calculator/meson.build +++ b/src/calculator/meson.build @@ -36,4 +36,7 @@ srcs += files( 'generic_sc.f90', 'turbom_sc.f90', 'subprocess_engrad.f90', + 'hr_utils.f90', + 'modelhessians.f90', + 'approxg.f90', ) diff --git a/src/calculator/modelhessians.f90 b/src/calculator/modelhessians.f90 new file mode 100644 index 00000000..cd15ecb4 --- /dev/null +++ b/src/calculator/modelhessians.f90 @@ -0,0 +1,3145 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2021 - 2022 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +! +! Routines were adapted from the xtb code (github.com/grimme-lab/xtb) +! under the Open-source software LGPL-3.0 Licencse. +!================================================================================! +module modelhessian_core + use iso_fortran_env,only:wp => real64,stdout => output_unit + implicit none + +!> a modelhessian type to save settings + type :: mhparam + integer :: model = 0 !> model hessian selection + real(wp) :: s6 = 20.0_wp !> dispersion scaling + real(wp) :: rcut = 70.0_wp !> cutoff parameter + !> force constants + real(wp) :: kr = 0.4000_wp + real(wp) :: kf = 0.1300_wp + real(wp) :: kt = 0.0075_wp + real(wp) :: ko = 0.0000_wp + real(wp) :: kd = 0.0000_wp + real(wp) :: kq = 0.0000_wp + end type mhparam + +!> Parameters & constants + real(wp),parameter :: bohr = 0.52917726_wp + real(wp),parameter :: aatoau = 1.0/bohr + real(wp),parameter :: pi = 3.141592653589793_wp + real(wp),parameter :: Zero = 0.0_wp + real(wp),parameter :: One = 1.0_wp + real(wp),parameter :: Two = 2.0_wp + real(wp),parameter :: Three = 3.0_wp + real(wp),parameter :: Four = 4.0_wp + real(wp),parameter :: Five = 5.0_wp + real(wp),parameter :: Six = 6.0_wp + real(wp),parameter :: Seven = 7.0_wp + real(wp),parameter :: Eight = 8.0_wp + real(wp),parameter :: RNine = 9.0_wp + real(wp),parameter :: Ten = 10.0_wp + real(wp),parameter :: Half = 0.5_wp + real(wp),parameter :: SqrtP2 = 0.8862269254527579_wp + real(wp),parameter :: TwoP34 = 0.2519794355383808_wp + real(wp),parameter :: TwoP54 = 5.914967172795612_wp + real(wp),parameter :: One2C2 = 0.2662567690426443D-04 + + !> van-der-Waals radii used in the D2 model (NOTE: here not in a.u.) + real(wp),parameter :: vander(86) = (/ & + & 0.91_wp,0.92_wp, & ! H, He + & 0.75_wp,1.28_wp,1.35_wp,1.32_wp,1.27_wp,1.22_wp,1.17_wp,1.13_wp, & ! Li-Ne + & 1.04_wp,1.24_wp,1.49_wp,1.56_wp,1.55_wp,1.53_wp,1.49_wp,1.45_wp, & ! Na-Ar + & 1.35_wp,1.34_wp, & ! K, Ca + & 1.42_wp,1.42_wp,1.42_wp,1.42_wp,1.42_wp, & ! Sc-Zn + & 1.42_wp,1.42_wp,1.42_wp,1.42_wp,1.42_wp, & + & 1.50_wp,1.57_wp,1.60_wp,1.61_wp,1.59_wp,1.57_wp, & ! Ga-Kr + & 1.48_wp,1.46_wp, & ! Rb, Sr + & 1.49_wp,1.49_wp,1.49_wp,1.49_wp,1.49_wp, & ! Y-Cd + & 1.49_wp,1.49_wp,1.49_wp,1.49_wp,1.49_wp, & + & 1.52_wp,1.64_wp,1.71_wp,1.72_wp,1.72_wp,1.71_wp, & ! In-Xe + & 2.00_wp,2.00_wp, & + & 2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp, & ! La-Yb + & 2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp, & + & 2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp, & ! Lu-Hg + & 2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp, & + & 2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp/) ! Tl-Rn + !> C6 coefficients used in the D2 model + real(wp),parameter :: c6(86) = (/ & + & 0.14_wp,0.08_wp, & ! H,He + & 1.61_wp,1.61_wp,3.13_wp,1.75_wp,1.23_wp,0.70_wp,0.75_wp,0.63_wp, & + & 5.71_wp,5.71_wp,10.79_wp,9.23_wp,7.84_wp,5.57_wp,5.07_wp,4.61_wp, & + & 10.80_wp,10.80_wp, & ! K,Ca + & 10.80_wp,10.80_wp,10.80_wp,10.80_wp,10.80_wp, & ! Sc-Zn + & 10.80_wp,10.80_wp,10.80_wp,10.80_wp,10.80_wp, & + & 16.99_wp,17.10_wp,16.37_wp,12.64_wp,12.47_wp,12.01_wp, & ! Ga-Kr + & 24.67_wp,24.67_wp, & ! Rb,Sr + & 24.67_wp,24.67_wp,24.67_wp,24.67_wp,24.67_wp, & ! Y-Cd + & 24.67_wp,24.67_wp,24.67_wp,24.67_wp,24.67_wp, & + & 37.32_wp,38.71_wp,38.44_wp,31.74_wp,31.50_wp,29.99_wp, & ! In-Xe + & 50.00_wp,50.00_wp, & ! Cs,Ba + & 50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp, & ! La-Yb + & 50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp, & + & 50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp, & ! Lu-Hg + & 50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp, & + & 50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp/) ! Tl-Rn + +!&< + integer, private, parameter :: max_elem = 118 + !> covalent radii (taken from Pyykko and Atsumi, Chem. Eur. J. 15, 2009, + ! 188-197), values for metals decreased by 10 % + real(wp),parameter :: covrad_2009(max_elem) = aatoau * [ & + & 0.32_wp,0.46_wp, & ! H,He + & 1.20_wp,0.94_wp,0.77_wp,0.75_wp,0.71_wp,0.63_wp,0.64_wp,0.67_wp, & ! Li-Ne + & 1.40_wp,1.25_wp,1.13_wp,1.04_wp,1.10_wp,1.02_wp,0.99_wp,0.96_wp, & ! Na-Ar + & 1.76_wp,1.54_wp, & ! K,Ca + & 1.33_wp,1.22_wp,1.21_wp,1.10_wp,1.07_wp, & ! Sc- + & 1.04_wp,1.00_wp,0.99_wp,1.01_wp,1.09_wp, & ! -Zn + & 1.12_wp,1.09_wp,1.15_wp,1.10_wp,1.14_wp,1.17_wp, & ! Ga-Kr + & 1.89_wp,1.67_wp, & ! Rb,Sr + & 1.47_wp,1.39_wp,1.32_wp,1.24_wp,1.15_wp, & ! Y- + & 1.13_wp,1.13_wp,1.08_wp,1.15_wp,1.23_wp, & ! -Cd + & 1.28_wp,1.26_wp,1.26_wp,1.23_wp,1.32_wp,1.31_wp, & ! In-Xe + & 2.09_wp,1.76_wp, & ! Cs,Ba + & 1.62_wp,1.47_wp,1.58_wp,1.57_wp,1.56_wp,1.55_wp,1.51_wp, & ! La-Eu + & 1.52_wp,1.51_wp,1.50_wp,1.49_wp,1.49_wp,1.48_wp,1.53_wp, & ! Gd-Yb + & 1.46_wp,1.37_wp,1.31_wp,1.23_wp,1.18_wp, & ! Lu- + & 1.16_wp,1.11_wp,1.12_wp,1.13_wp,1.32_wp, & ! -Hg + & 1.30_wp,1.30_wp,1.36_wp,1.31_wp,1.38_wp,1.42_wp, & ! Tl-Rn + & 2.01_wp,1.81_wp, & ! Fr,Ra + & 1.67_wp,1.58_wp,1.52_wp,1.53_wp,1.54_wp,1.55_wp,1.49_wp, & ! Ac-Am + & 1.49_wp,1.51_wp,1.51_wp,1.48_wp,1.50_wp,1.56_wp,1.58_wp, & ! Cm-No + & 1.45_wp,1.41_wp,1.34_wp,1.29_wp,1.27_wp, & ! Lr- + & 1.21_wp,1.16_wp,1.15_wp,1.09_wp,1.22_wp, & ! -Cn + & 1.36_wp,1.43_wp,1.46_wp,1.58_wp,1.48_wp,1.57_wp ] ! Nh-Og +!&> + + public :: ddvopt,mh_lindh_d2,mh_lindh,mh_swart + +!==============================================================================! +contains !> MODULE PROCEDURES START HERE +!==============================================================================! + + subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) +!*********************************************************** +!* subroutine ddvopt +!* generates a Lindh Model Hessian +!* Chem. Phys. Let. 241(1995) 423-428 +!* +!* Input: +!* Cart - cartesian coordinates +!* nAtoms - number of atoms +!* iANr - atom types as integers +!* mhset - model Hessian parameters +!* +!* Output: +!* Hess - the (packed) model Hessian +!********************************************************** + Implicit Integer(i-n) + Implicit Real(wp) (a-h,o-z) + type(mhparam) :: mhset + + real(wp) :: s6 + real(wp) :: rcut + + Real(wp) :: Cart(3,nAtoms),rij(3),rjk(3),rkl(3), & + & Hess((3*nAtoms)*(3*nAtoms+1)/2),si(3),sj(3),sk(3), & + & sl(3),sm(3),x(2),y(2),z(2), & + & xyz(3,4),C(3,4),Dum(3,4,3,4) + Integer iANr(nAtoms) + +! include "common/ddvdt.inc" (molpro 2002.6) + Real(wp) :: rAV(3,3),aAV(3,3), & + & B_Str(6),A_Bend(2),A_Trsn(2),A_StrH(2), & + & rkr,rkf,A_Str,RF_Const, & + & wthr + + Data rAv/1.3500d+00,2.1000d+00,2.5300d+00, & + & 2.1000d+00,2.8700d+00,3.4000d+00, & + & 2.5300d+00,3.4000d+00,3.4000d+00/ + Data aAv/1.0000d+00,0.3949d+00,0.3949d+00, & + & 0.3949d+00,0.2800d+00,0.2800d+00, & + & 0.3949d+00,0.2800d+00,0.2800d+00/ +!org Data rkr,rkf,rkt/0.4500D+00,0.1500D+00,0.5000D-02/ + Data rkr,rkf,rkt/0.4000D+00,0.1300D+00,0.7500D-02/ + Data A_Str/1.734d0/ + Data B_Str/-.244d0,0.352d0,1.085d0,0.660d0,1.522d0,2.068d0/ + Data A_Bend/0.160d0,0.250d0/ + Data A_Trsn/0.0023d0,0.07d0/ + Data A_StrH/0.3601d0,1.944d0/ + Data RF_Const/1.0D-2/ + Data wthr/0.2/ + +!cc VDWx-Parameters (Grimme) used for vdw-correction of model hessian + real(wp) :: alphavdw,damp,c6k,c6l,c66,vdw(3,3),dr(3) + integer :: kxyz,lxyz +!cc End: VDWx ccccccccccccccccc + + !> BLAS + external :: dcopy + + s6 = mhset%s6 + rcut = mhset%rcut + +! +!------- Statement functions +! +! ixyz(i,iAtom) = (iAtom-1)*3 + i +! Jnd(i,j) = i*(i-1)/2 +j +! Ind(i,iAtom,j,jAtom)=Jnd(Max(ixyz(i,iAtom),ixyz(j,jAtom)), & +! & Min(ixyz(i,iAtom),ixyz(j,jAtom))) +!end + + Fact = One +!hjw threshold reduced + rZero = 1.0d-10 + n3 = 3*nAtoms + Hess = 0.0d0 + +! +! Hessian for tension +! + Do kAtom = 1,nAtoms + kr = iTabRow(iANr(kAtom)) +! If (kr.eq.0) Go To 5 + + Do lAtom = 1,kAtom-1 + lr = iTabRow(iANr(lAtom)) +! If (lr.eq.0) Go To 10 + xkl = Cart(1,kAtom)-Cart(1,lAtom) + ykl = Cart(2,kAtom)-Cart(2,lAtom) + zkl = Cart(3,kAtom)-Cart(3,lAtom) + rkl2 = xkl**2+ykl**2+zkl**2 + r0 = rAv(kr,lr) + alpha = aAv(kr,lr) + +!cccccc VDWx ccccccccccccccccccccccccccccccccc + c6k = c6(iANr(katom)) + c6l = c6(iANr(latom)) + c66 = sqrt(c6k*c6l) + Rv = (vander(iANr(katom))+vander(iANr(latom)))/bohr + + call getvdwxx(xkl,ykl,zkl,c66,s6,Rv,vdw(1,1)) + call getvdwxy(xkl,ykl,zkl,c66,s6,Rv,vdw(1,2)) + call getvdwxy(xkl,zkl,ykl,c66,s6,Rv,vdw(1,3)) + call getvdwxx(ykl,xkl,zkl,c66,s6,Rv,vdw(2,2)) + call getvdwxy(ykl,zkl,xkl,c66,s6,Rv,vdw(2,3)) + call getvdwxx(zkl,xkl,ykl,c66,s6,Rv,vdw(3,3)) +!cccccc Ende VDWx ccccccccccccccccccccccccccccccc + + gamma = rkr*Exp(alpha*r0**2) +! not better: *sqrt(abs(wb(kAtom,lAtom))) + gmm = gamma*Exp(-alpha*rkl2) + Hxx = gmm*xkl*xkl/rkl2-vdw(1,1) + Hxy = gmm*xkl*ykl/rkl2-vdw(1,2) + Hxz = gmm*xkl*zkl/rkl2-vdw(1,3) + Hyy = gmm*ykl*ykl/rkl2-vdw(2,2) + Hyz = gmm*ykl*zkl/rkl2-vdw(2,3) + Hzz = gmm*zkl*zkl/rkl2-vdw(3,3) + +! + Hess(Ind(1,kAtom,1,kAtom)) = Hess(Ind(1,kAtom,1,kAtom))+Hxx + Hess(Ind(2,kAtom,1,kAtom)) = Hess(Ind(2,kAtom,1,kAtom))+Hxy + Hess(Ind(2,kAtom,2,kAtom)) = Hess(Ind(2,kAtom,2,kAtom))+Hyy + Hess(Ind(3,kAtom,1,kAtom)) = Hess(Ind(3,kAtom,1,kAtom))+Hxz + Hess(Ind(3,kAtom,2,kAtom)) = Hess(Ind(3,kAtom,2,kAtom))+Hyz + Hess(Ind(3,kAtom,3,kAtom)) = Hess(Ind(3,kAtom,3,kAtom))+Hzz +! + Hess(Ind(1,kAtom,1,lAtom)) = Hess(Ind(1,kAtom,1,lAtom))-Hxx + Hess(Ind(1,kAtom,2,lAtom)) = Hess(Ind(1,kAtom,2,lAtom))-Hxy + Hess(Ind(1,kAtom,3,lAtom)) = Hess(Ind(1,kAtom,3,lAtom))-Hxz + Hess(Ind(2,kAtom,1,lAtom)) = Hess(Ind(2,kAtom,1,lAtom))-Hxy + Hess(Ind(2,kAtom,2,lAtom)) = Hess(Ind(2,kAtom,2,lAtom))-Hyy + Hess(Ind(2,kAtom,3,lAtom)) = Hess(Ind(2,kAtom,3,lAtom))-Hyz + Hess(Ind(3,kAtom,1,lAtom)) = Hess(Ind(3,kAtom,1,lAtom))-Hxz + Hess(Ind(3,kAtom,2,lAtom)) = Hess(Ind(3,kAtom,2,lAtom))-Hyz + Hess(Ind(3,kAtom,3,lAtom)) = Hess(Ind(3,kAtom,3,lAtom))-Hzz +! + Hess(Ind(1,lAtom,1,lAtom)) = Hess(Ind(1,lAtom,1,lAtom))+Hxx + Hess(Ind(2,lAtom,1,lAtom)) = Hess(Ind(2,lAtom,1,lAtom))+Hxy + Hess(Ind(2,lAtom,2,lAtom)) = Hess(Ind(2,lAtom,2,lAtom))+Hyy + Hess(Ind(3,lAtom,1,lAtom)) = Hess(Ind(3,lAtom,1,lAtom))+Hxz + Hess(Ind(3,lAtom,2,lAtom)) = Hess(Ind(3,lAtom,2,lAtom))+Hyz + Hess(Ind(3,lAtom,3,lAtom)) = Hess(Ind(3,lAtom,3,lAtom))+Hzz +! +10 Continue + End Do + +5 Continue + End Do + +! +! Hessian for bending +! + Do mAtom = 1,nAtoms + mr = iTabRow(iANr(mAtom)) +! If (mr.eq.0) Go To 20 + Do iAtom = 1,nAtoms + If (iAtom .eq. mAtom) Go To 30 + ir = iTabRow(iANr(iAtom)) +! If (ir.eq.0) Go To 30 + if (rcutoff(cart,iatom,matom,rcut)) cycle +! if(wb(iatom,matom).lt.wthr) cycle + Do jAtom = 1,iAtom-1 + If (jAtom .eq. mAtom) Go To 40 + jr = iTabRow(iANr(jAtom)) +! If (jr.eq.0) Go To 40 + if (rcutoff(cart,jatom,iatom,rcut)) cycle + if (rcutoff(cart,jatom,matom,rcut)) cycle +! if(wb(jatom,iatom).lt.wthr) cycle +! if(wb(jatom,matom).lt.wthr) cycle + + xmi = (Cart(1,iAtom)-Cart(1,mAtom)) + ymi = (Cart(2,iAtom)-Cart(2,mAtom)) + zmi = (Cart(3,iAtom)-Cart(3,mAtom)) + rmi2 = xmi**2+ymi**2+zmi**2 + rmi = sqrt(rmi2) + r0mi = rAv(mr,ir) + ami = aAv(mr,ir) +! + xmj = (Cart(1,jAtom)-Cart(1,mAtom)) + ymj = (Cart(2,jAtom)-Cart(2,mAtom)) + zmj = (Cart(3,jAtom)-Cart(3,mAtom)) + rmj2 = xmj**2+ymj**2+zmj**2 + rmj = sqrt(rmj2) + r0mj = rAv(mr,jr) + amj = aAv(mr,jr) +! +!---------- Test if zero angle +! + Test = xmi*xmj+ymi*ymj+zmi*zmj + Test = Test/(rmi*rmj) + If (Test .eq. One) Go To 40 +! + xij = (Cart(1,jAtom)-Cart(1,iAtom)) + yij = (Cart(2,jAtom)-Cart(2,iAtom)) + zij = (Cart(3,jAtom)-Cart(3,iAtom)) + rij2 = xij**2+yij**2+zij**2 + rrij = sqrt(rij2) +! + alpha = rkf*exp((ami*r0mi**2+amj*r0mj**2)) +! + r = sqrt(rmj2+rmi2) + gij = alpha*exp(-(ami*rmi2+amj*rmj2)) +! Write (*,*) ' gij=',gij + rL2 = (ymi*zmj-zmi*ymj)**2+(zmi*xmj-xmi*zmj)**2+ & + & (xmi*ymj-ymi*xmj)**2 +!hjw modified + if (rL2 .lt. 1.d-14) then + rL = 0 + else + rL = sqrt(rL2) + end if +! + if ((rmj .gt. rZero).and.(rmi .gt. rZero).and. & + & (rrij .gt. rZero)) Then + SinPhi = rL/(rmj*rmi) + rmidotrmj = xmi*xmj+ymi*ymj+zmi*zmj + CosPhi = rmidotrmj/(rmj*rmi) +! +!-------------None linear case +! + If (SinPhi .gt. rZero) Then +! Write (*,*) ' None linear case' + si(1) = (xmi/rmi*cosphi-xmj/rmj)/(rmi*sinphi) + si(2) = (ymi/rmi*cosphi-ymj/rmj)/(rmi*sinphi) + si(3) = (zmi/rmi*cosphi-zmj/rmj)/(rmi*sinphi) + sj(1) = (cosphi*xmj/rmj-xmi/rmi)/(rmj*sinphi) + sj(2) = (cosphi*ymj/rmj-ymi/rmi)/(rmj*sinphi) + sj(3) = (cosphi*zmj/rmj-zmi/rmi)/(rmj*sinphi) + sm(1) = -si(1)-sj(1) + sm(2) = -si(2)-sj(2) + sm(3) = -si(3)-sj(3) + Do icoor = 1,3 + Do jCoor = 1,3 + If (mAtom .gt. iAtom) Then + Hess(Ind(icoor,mAtom,jcoor,iAtom)) = & + & Hess(Ind(icoor,mAtom,jcoor,iAtom)) & + & +gij*sm(icoor)*si(jcoor) + else + Hess(Ind(icoor,iAtom,jcoor,mAtom)) = & + & Hess(Ind(icoor,iAtom,jcoor,mAtom)) & + & +gij*si(icoor)*sm(jcoor) + End If + If (mAtom .gt. jAtom) Then + Hess(Ind(icoor,mAtom,jcoor,jAtom)) = & + & Hess(Ind(icoor,mAtom,jcoor,jAtom)) & + & +gij*sm(icoor)*sj(jcoor) + else + Hess(Ind(icoor,jAtom,jcoor,mAtom)) = & + & Hess(Ind(icoor,jAtom,jcoor,mAtom)) & + & +gij*sj(icoor)*sm(jcoor) + End If + If (iAtom .gt. jAtom) Then + Hess(Ind(icoor,iAtom,jcoor,jAtom)) = & + & Hess(Ind(icoor,iAtom,jcoor,jAtom)) & + & +gij*si(icoor)*sj(jcoor) + else + Hess(Ind(icoor,jAtom,jcoor,iAtom)) = & + & Hess(Ind(icoor,jAtom,jcoor,iAtom)) & + & +gij*sj(icoor)*si(jcoor) + End If + End Do + End Do + Do icoor = 1,3 + Do jCoor = 1,icoor + Hess(Ind(icoor,iAtom,jcoor,iAtom)) = & + & Hess(Ind(icoor,iAtom,jcoor,iAtom)) & + & +gij*si(icoor)*si(jcoor) + Hess(Ind(icoor,mAtom,jcoor,mAtom)) = & + & Hess(Ind(icoor,mAtom,jcoor,mAtom)) & + & +gij*sm(icoor)*sm(jcoor) + Hess(Ind(icoor,jAtom,jcoor,jAtom)) = & + & Hess(Ind(icoor,jAtom,jcoor,jAtom)) & + & +gij*sj(icoor)*sj(jcoor) + +! + End Do + End Do + Else +! +!----------------Linear case +! + if ((abs(ymi) .gt. rZero).or. & +& (abs(xmi) .gt. rZero)) Then + x(1) = -ymi + y(1) = xmi + z(1) = Zero + x(2) = -xmi*zmi + y(2) = -ymi*zmi + z(2) = xmi*xmi+ymi*ymi + Else + x(1) = One + y(1) = Zero + z(1) = Zero + x(2) = Zero + y(2) = One + z(2) = Zero + End If + Do i = 1,2 + r1 = sqrt(x(i)**2+y(i)**2+z(i)**2) + cosThetax = x(i)/r1 + cosThetay = y(i)/r1 + cosThetaz = z(i)/r1 + si(1) = -cosThetax/rmi + si(2) = -cosThetay/rmi + si(3) = -cosThetaz/rmi + sj(1) = -cosThetax/rmj + sj(2) = -cosThetay/rmj + sj(3) = -cosThetaz/rmj + sm(1) = -(si(1)+sj(1)) + sm(2) = -(si(2)+sj(2)) + sm(3) = -(si(3)+sj(3)) +! + Do icoor = 1,3 + Do jCoor = 1,3 + If (mAtom .gt. iAtom) Then + Hess(Ind(icoor,mAtom,jcoor,iAtom)) = & + & Hess(Ind(icoor,mAtom,jcoor,iAtom)) & + & +gij*sm(icoor)*si(jcoor) + else + Hess(Ind(icoor,iAtom,jcoor,mAtom)) = & +& Hess(Ind(icoor,iAtom,jcoor,mAtom)) & +& +gij*si(icoor)*sm(jcoor) + End If + If (mAtom .gt. jAtom) Then + Hess(Ind(icoor,mAtom,jcoor,jAtom)) = & + & Hess(Ind(icoor,mAtom,jcoor,jAtom)) & + & +gij*sm(icoor)*sj(jcoor) + else + Hess(Ind(icoor,jAtom,jcoor,mAtom)) = & + & Hess(Ind(icoor,jAtom,jcoor,mAtom)) & + & +gij*sj(icoor)*sm(jcoor) + End If + If (iAtom .gt. jAtom) Then + Hess(Ind(icoor,iAtom,jcoor,jAtom)) = & +& Hess(Ind(icoor,iAtom,jcoor,jAtom)) & +& +gij*si(icoor)*sj(jcoor) + else + Hess(Ind(icoor,jAtom,jcoor,iAtom)) = & +& Hess(Ind(icoor,jAtom,jcoor,iAtom)) & +& +gij*sj(icoor)*si(jcoor) + End If + End Do + End Do + Do icoor = 1,3 + Do jCoor = 1,icoor + Hess(Ind(icoor,iAtom,jcoor,iAtom)) = & +& Hess(Ind(icoor,iAtom,jcoor,iAtom)) & +& +gij*si(icoor)*si(jcoor) + Hess(Ind(icoor,mAtom,jcoor,mAtom)) = & +& Hess(Ind(icoor,mAtom,jcoor,mAtom)) & +& +gij*sm(icoor)*sm(jcoor) + Hess(Ind(icoor,jAtom,jcoor,jAtom)) = & +& Hess(Ind(icoor,jAtom,jcoor,jAtom)) & +& +gij*sj(icoor)*sj(jcoor) + End Do + End Do + End Do + End If + End If +! +40 Continue + End Do +30 Continue + End Do +20 Continue + End Do +! +! Hessian for torsion +! + Do jAtom = 1,nAtoms + jr = iTabRow(iANr(jAtom)) +! If (jr.eq.0) Go To 444 +! + Call DCopy(3,Cart(1,jAtom),1,xyz(1,2),1) +! + Do kAtom = 1,nAtoms + If (kAtom .eq. jAtom) Go To 111 + kr = iTabRow(iANr(kAtom)) +! If (kr.eq.0) Go To 111 + + if (rcutoff(cart,katom,jatom,rcut)) cycle +! if(wb(katom,jatom).lt.wthr) cycle +! + Call DCopy(3,Cart(1,kAtom),1,xyz(1,3),1) +! + Do iAtom = 1,nAtoms + ij_ = nAtoms*(jAtom-1)+iAtom + If (iAtom .eq. jAtom) Go To 333 + If (iAtom .eq. kAtom) Go To 333 + ir = iTabRow(iANr(iAtom)) +! If (ir.eq.0) Go To 333 +! + if (rcutoff(cart,iatom,katom,rcut)) cycle + if (rcutoff(cart,iatom,jatom,rcut)) cycle +! if(wb(iatom,katom).lt.wthr) cycle +! if(wb(iatom,jatom).lt.wthr) cycle + + Call DCopy(3,Cart(1,iAtom),1,xyz(1,1),1) +! + Do lAtom = 1,nAtoms + lk_ = nAtoms*(kAtom-1)+lAtom + If (ij_ .le. lk_) Go To 222 + If (lAtom .eq. iAtom) Go To 222 + If (lAtom .eq. jAtom) Go To 222 + If (lAtom .eq. kAtom) Go To 222 + lr = iTabRow(iANr(lAtom)) +! If (lr.eq.0) Go To 222 +! + if (rcutoff(cart,latom,iatom,rcut)) cycle + if (rcutoff(cart,latom,katom,rcut)) cycle + if (rcutoff(cart,latom,jatom,rcut)) cycle +! if(wb(latom,iatom).lt.wthr) cycle +! if(wb(latom,katom).lt.wthr) cycle +! if(wb(latom,jatom).lt.wthr) cycle + + Call DCopy(3,Cart(1,lAtom),1,xyz(1,4),1) +! + rij(1) = Cart(1,iAtom)-Cart(1,jAtom) + rij(2) = Cart(2,iAtom)-Cart(2,jAtom) + rij(3) = Cart(3,iAtom)-Cart(3,jAtom) + rij0 = rAv(ir,jr)**2 + aij = aAv(ir,jr) +! + rjk(1) = Cart(1,jAtom)-Cart(1,kAtom) + rjk(2) = Cart(2,jAtom)-Cart(2,kAtom) + rjk(3) = Cart(3,jAtom)-Cart(3,kAtom) + rjk0 = rAv(jr,kr)**2 + ajk = aAv(jr,kr) +! + rkl(1) = Cart(1,kAtom)-Cart(1,lAtom) + rkl(2) = Cart(2,kAtom)-Cart(2,lAtom) + rkl(3) = Cart(3,kAtom)-Cart(3,lAtom) + rkl0 = rAv(kr,lr)**2 + akl = aAv(kr,lr) +! + rij2 = rij(1)**2+rij(2)**2+rij(3)**2 + rjk2 = rjk(1)**2+rjk(2)**2+rjk(3)**2 + rkl2 = rkl(1)**2+rkl(2)**2+rkl(3)**2 +! Allow only angles in the range of 35-145 + A35 = (35.0D0/180.D0)*Pi + CosFi_Max = Cos(A35) + CosFi2 = (rij(1)*rjk(1)+rij(2)*rjk(2)+rij(3)*rjk(3)) & + & /Sqrt(rij2*rjk2) + If (Abs(CosFi2) .gt. CosFi_Max) Go To 222 + CosFi3 = (rkl(1)*rjk(1)+rkl(2)*rjk(2)+rkl(3)*rjk(3)) & + & /Sqrt(rkl2*rjk2) + If (Abs(CosFi3) .gt. CosFi_Max) Go To 222 + + beta = rkt* & + & exp((aij*rij0+ajk*rjk0+akl*rkl0)) + tij = beta*exp(-(aij*rij2+ajk*rjk2+akl*rkl2)) + + Call Trsn(xyz,4,Tau,C,.False.,.False.,' ', & + & Dum,.False.) + Call DCopy(3,C(1,1),1,si,1) + Call DCopy(3,C(1,2),1,sj,1) + Call DCopy(3,C(1,3),1,sk,1) + Call DCopy(3,C(1,4),1,sl,1) +! +!-------------Off diagonal block +! + Do icoor = 1,3 + Do jCoor = 1,3 + Hess(Ind(icoor,iAtom,jcoor,jAtom)) = & + & Hess(Ind(icoor,iAtom,jcoor,jAtom)) & + & +tij*si(icoor)*sj(jcoor) + Hess(Ind(icoor,iAtom,jcoor,kAtom)) = & + & Hess(Ind(icoor,iAtom,jcoor,kAtom)) & + & +tij*si(icoor)*sk(jcoor) + Hess(Ind(icoor,iAtom,jcoor,lAtom)) = & + & Hess(Ind(icoor,iAtom,jcoor,lAtom)) & + & +tij*si(icoor)*sl(jcoor) + Hess(Ind(icoor,jAtom,jcoor,kAtom)) = & + & Hess(Ind(icoor,jAtom,jcoor,kAtom)) & + & +tij*sj(icoor)*sk(jcoor) + Hess(Ind(icoor,jAtom,jcoor,lAtom)) = & + & Hess(Ind(icoor,jAtom,jcoor,lAtom)) & + & +tij*sj(icoor)*sl(jcoor) + Hess(Ind(icoor,kAtom,jcoor,lAtom)) = & + & Hess(Ind(icoor,kAtom,jcoor,lAtom)) & + & +tij*sk(icoor)*sl(jcoor) + + End Do + End Do +! +!-------------Diagonal block +! + Do icoor = 1,3 + Do jCoor = 1,icoor + Hess(Ind(icoor,iAtom,jcoor,iAtom)) = & + & Hess(Ind(icoor,iAtom,jcoor,iAtom)) & + & +tij*si(icoor)*si(jcoor) + Hess(Ind(icoor,jAtom,jcoor,jAtom)) = & + & Hess(Ind(icoor,jAtom,jcoor,jAtom)) & + & +tij*sj(icoor)*sj(jcoor) + Hess(Ind(icoor,kAtom,jcoor,kAtom)) = & + & Hess(Ind(icoor,kAtom,jcoor,kAtom)) & + & +tij*sk(icoor)*sk(jcoor) + Hess(Ind(icoor,lAtom,jcoor,lAtom)) = & + & Hess(Ind(icoor,lAtom,jcoor,lAtom)) & + & +tij*sl(icoor)*sl(jcoor) + +! + End Do + End Do +222 Continue + End Do ! lAtom +333 Continue + End Do ! iAtom +111 Continue + End Do ! kAtom +444 Continue + End Do ! jAtom + Return + + contains + function ixyz(i,iatom) + integer :: ixyz + integer,intent(in) :: i,iatom + ixyz = (iatom-1)*3+i + end function ixyz + function jnd(i,j) + integer :: jnd + integer,intent(in) :: i,j + jnd = i*(i-1)/2+j + end function jnd + function ind(i,iatom,j,jatom) + integer :: ind + integer,intent(in) :: i,iatom,j,jatom + ind = jnd(max(ixyz(i,iatom),ixyz(j,jatom)),min(ixyz(i,iatom),ixyz(j,jatom))) + end function ind + end subroutine ddvopt + +!========================================================================================! +!########################################################################################! +!========================================================================================! + + subroutine mh_swart(xyz,n,hess,at,modh) +!**************************************************************************** +!* Swart's Model Hessian augmented with D2 +!* ------------------------------------------------------------------------ +!* Implemented after: +!* M. Swart, F. M. Bickelhaupt, Int. J. Quantum Chem., 2006, 106, 2536–2544. +!* DOI:10.1002/qua.21049 +!* +!* gij = exp[-(Rij/Cij-1)] +!* kij = rkr·gij +!* kijk = rkf·gij·gjk +!* kijkl = rkt·gij·gjk·gkl +!* +!* The proposed force constants by Swart are: +!* rkr = 0.35, rkf = 0.15, rkt = 0.005 +!* +!* This Hessian is additionally augmented with D2, please note that D2 +!* is not implemented in atomic units and requires some magical conversion +!* factor somewhere hidden in the implementation below. +!**************************************************************************** + implicit none + + integer,intent(in) :: n + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(out) :: hess((3*n)*(3*n+1)/2) + integer,intent(in) :: at(n) + type(mhparam),intent(in) :: modh + + integer :: n3 + real(wp),parameter :: rzero = 1.0e-10_wp + logical,allocatable :: lcutoff(:,:) + real(wp) :: kd + + allocate (lcutoff(n,n),source=.false.) + + n3 = 3*n + hess = 0.0d0 + +! the dispersion force constant is used relative to the stretch force constant + kd = modh%kd/modh%kr + + associate (rad => covrad_2009) + + call mh_swart_stretch(n,at,xyz,hess,modh%kr,kd,modh%s6,rad,rad,lcutoff,modh%rcut) + if (modh%kf .ne. 0.0_wp) & + call mh_swart_bend(n,at,xyz,hess,modh%kf,kd,rad,rad,lcutoff) + if (modh%kt .ne. 0.0_wp) & + call mh_swart_torsion(n,at,xyz,hess,modh%kt,kd,rad,rad,lcutoff) + if (modh%ko .ne. 0.0_wp) & + call mh_swart_outofp(n,at,xyz,hess,modh%ko,kd,rad,rad,lcutoff) + if (modh%kq .ne. 0.0_wp) then +! call new_charge_model_2019(chrgeq,n,at) + call mh_eeq(n,at,xyz,0.0_wp,modh%kq,hess) + end if + + end associate + + end subroutine mh_swart + + pure subroutine mh_swart_stretch(n,at,xyz,hess,kr,kd,s6,rcov,rvdw,lcutoff,rcut) + implicit none + + integer,intent(in) :: n + integer,intent(in) :: at(n) + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) + real(wp),intent(in) :: kr + real(wp),intent(in) :: kd + real(wp),intent(in) :: s6 + real(wp),intent(in) :: rcov(:) + real(wp),intent(in) :: rvdw(:) + logical,intent(out) :: lcutoff(n,n) + real(wp),intent(in) :: rcut + + integer :: i,j + real(wp) :: xij,yij,zij,rij2,r0,d0 + real(wp) :: gmm + real(wp) :: c6i,c6j,c6ij,rv + real(wp) :: hxx,hxy,hxz,hyy,hyz,hzz + real(wp) :: vdw(3,3) + +!! ------------------------------------------------------------------------ +! Hessian for stretch +!! ------------------------------------------------------------------------ + stretch_iAt: do i = 1,n + + stretch_jAt: do j = 1,i-1 + + ! save for later + lcutoff(i,j) = rcutoff(xyz,i,j,rcut) + lcutoff(j,i) = lcutoff(i,j) + + xij = xyz(1,i)-xyz(1,j) + yij = xyz(2,i)-xyz(2,j) + zij = xyz(3,i)-xyz(3,j) + rij2 = xij**2+yij**2+zij**2 + r0 = rcov(at(i))+rcov(at(j)) + d0 = rvdw(at(i))+rvdw(at(j)) + + !cccccc vdwx ccccccccccccccccccccccccccccccccc + c6i = c6(at(i)) + c6j = c6(at(j)) + c6ij = sqrt(c6i*c6j) + rv = (vander(at(i))+vander(at(j)))*aatoau + + call getvdwxx(xij,yij,zij,c6ij,s6,rv,vdw(1,1)) + call getvdwxy(xij,yij,zij,c6ij,s6,rv,vdw(1,2)) + call getvdwxy(xij,zij,yij,c6ij,s6,rv,vdw(1,3)) + call getvdwxx(yij,xij,zij,c6ij,s6,rv,vdw(2,2)) + call getvdwxy(yij,zij,xij,c6ij,s6,rv,vdw(2,3)) + call getvdwxx(zij,xij,yij,c6ij,s6,rv,vdw(3,3)) + !cccccc ende vdwx ccccccccccccccccccccccccccccccc + + gmm = kr*fk_swart(1.0_wp,r0,rij2) & + +kr*kd*fk_vdw(5.0_wp,d0,rij2) + + !gmm = max(gmm,min_fk) + + hxx = gmm*xij*xij/rij2-vdw(1,1) + hxy = gmm*xij*yij/rij2-vdw(1,2) + hxz = gmm*xij*zij/rij2-vdw(1,3) + hyy = gmm*yij*yij/rij2-vdw(2,2) + hyz = gmm*yij*zij/rij2-vdw(2,3) + hzz = gmm*zij*zij/rij2-vdw(3,3) + + ! save diagonal elements for atom i + hess(ind(1,i,1,i)) = hess(ind(1,i,1,i))+hxx + hess(ind(2,i,1,i)) = hess(ind(2,i,1,i))+hxy + hess(ind(2,i,2,i)) = hess(ind(2,i,2,i))+hyy + hess(ind(3,i,1,i)) = hess(ind(3,i,1,i))+hxz + hess(ind(3,i,2,i)) = hess(ind(3,i,2,i))+hyz + hess(ind(3,i,3,i)) = hess(ind(3,i,3,i))+hzz + ! save elements between atom i and atom j + hess(ind(1,i,1,j)) = hess(ind(1,i,1,j))-hxx + hess(ind(1,i,2,j)) = hess(ind(1,i,2,j))-hxy + hess(ind(1,i,3,j)) = hess(ind(1,i,3,j))-hxz + hess(ind(2,i,1,j)) = hess(ind(2,i,1,j))-hxy + hess(ind(2,i,2,j)) = hess(ind(2,i,2,j))-hyy + hess(ind(2,i,3,j)) = hess(ind(2,i,3,j))-hyz + hess(ind(3,i,1,j)) = hess(ind(3,i,1,j))-hxz + hess(ind(3,i,2,j)) = hess(ind(3,i,2,j))-hyz + hess(ind(3,i,3,j)) = hess(ind(3,i,3,j))-hzz + ! save diagonal elements for atom j + hess(ind(1,j,1,j)) = hess(ind(1,j,1,j))+hxx + hess(ind(2,j,1,j)) = hess(ind(2,j,1,j))+hxy + hess(ind(2,j,2,j)) = hess(ind(2,j,2,j))+hyy + hess(ind(3,j,1,j)) = hess(ind(3,j,1,j))+hxz + hess(ind(3,j,2,j)) = hess(ind(3,j,2,j))+hyz + hess(ind(3,j,3,j)) = hess(ind(3,j,3,j))+hzz + + end do stretch_jAt + end do stretch_iAt + + end subroutine mh_swart_stretch + + pure subroutine mh_swart_bend(n,at,xyz,hess,kf,kd,rcov,rvdw,lcutoff) + implicit none + + integer,intent(in) :: n + integer,intent(in) :: at(n) + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) + real(wp),intent(in) :: kf + real(wp),intent(in) :: kd + real(wp),intent(in) :: rcov(:) + real(wp),intent(in) :: rvdw(:) + logical,intent(in) :: lcutoff(n,n) + + integer :: i,j,m,ic,jc,ii + real(wp),parameter :: rzero = 1.0e-10_wp + real(wp) :: xij,yij,zij,rij2,rrij,r1 + real(wp) :: xmi,ymi,zmi,rmi2,rmi,r0mi,d0mj,gmi + real(wp) :: xmj,ymj,zmj,rmj2,rmj,r0mj,d0mi,gmj + real(wp) :: test,gij,rl2,rl,rmidotrmj + real(wp) :: sinphi,cosphi,costhetax,costhetay,costhetaz + real(wp) :: alpha + real(wp) :: si(3),sj(3),sm(3),x(2),y(2),z(2) + +!! ------------------------------------------------------------------------ +! Hessian for bending +!! ------------------------------------------------------------------------ + bend_mAt: do m = 1,n + bend_iAt: do i = 1,n + if (i .eq. m) cycle bend_iAt + if (lcutoff(i,m)) cycle bend_iAt + + xmi = (xyz(1,i)-xyz(1,m)) + ymi = (xyz(2,i)-xyz(2,m)) + zmi = (xyz(3,i)-xyz(3,m)) + rmi2 = xmi**2+ymi**2+zmi**2 + rmi = sqrt(rmi2) + r0mi = rcov(at(m))+rcov(at(i)) + d0mi = rvdw(at(m))+rvdw(at(i)) + + bend_jAt: do j = 1,i-1 + if (j .eq. m) cycle bend_jAt + if (lcutoff(j,i)) cycle bend_jAt + if (lcutoff(j,m)) cycle bend_jAt + + xmj = (xyz(1,j)-xyz(1,m)) + ymj = (xyz(2,j)-xyz(2,m)) + zmj = (xyz(3,j)-xyz(3,m)) + rmj2 = xmj**2+ymj**2+zmj**2 + rmj = sqrt(rmj2) + r0mj = rcov(at(m))+rcov(at(j)) + d0mj = rvdw(at(m))+rvdw(at(j)) + + ! test if zero angle + test = xmi*xmj+ymi*ymj+zmi*zmj + test = test/(rmi*rmj) + if (abs(test-1.0_wp) .lt. 1.0e-12_wp) cycle bend_jAt + + xij = (xyz(1,j)-xyz(1,i)) + yij = (xyz(2,j)-xyz(2,i)) + zij = (xyz(3,j)-xyz(3,i)) + rij2 = xij**2+yij**2+zij**2 + rrij = sqrt(rij2) + + gmi = fk_swart(1.0_wp,r0mi,rmi2) & + +0.5_wp*kd*fk_vdw(5.0_wp,d0mi,rmi2) + gmj = fk_swart(1.0_wp,r0mj,rmj2) & + +0.5_wp*kd*fk_vdw(5.0_wp,d0mj,rmj2) + + gij = kf*gmi*gmj + + rl2 = (ymi*zmj-zmi*ymj)**2+(zmi*xmj-xmi*zmj)**2+(xmi*ymj-ymi*xmj)**2 + + if (rl2 .lt. 1.e-14_wp) then + rl = 0.0_wp + else + rl = sqrt(rl2) + end if + + !gij = max(gij,min_fk) + + if ((rmj .gt. rzero).and.(rmi .gt. rzero).and.(rrij .gt. rzero)) then + sinphi = rl/(rmj*rmi) + rmidotrmj = xmi*xmj+ymi*ymj+zmi*zmj + cosphi = rmidotrmj/(rmj*rmi) + ! none linear case + if (sinphi .gt. rzero) then + si(1) = (xmi/rmi*cosphi-xmj/rmj)/(rmi*sinphi) + si(2) = (ymi/rmi*cosphi-ymj/rmj)/(rmi*sinphi) + si(3) = (zmi/rmi*cosphi-zmj/rmj)/(rmi*sinphi) + sj(1) = (cosphi*xmj/rmj-xmi/rmi)/(rmj*sinphi) + sj(2) = (cosphi*ymj/rmj-ymi/rmi)/(rmj*sinphi) + sj(3) = (cosphi*zmj/rmj-zmi/rmi)/(rmj*sinphi) + sm(1) = -si(1)-sj(1) + sm(2) = -si(2)-sj(2) + sm(3) = -si(3)-sj(3) + do ic = 1,3 + do jc = 1,3 + if (m .gt. i) then + hess(ind(ic,m,jc,i)) = hess(ind(ic,m,jc,i)) & + +gij*sm(ic)*si(jc) + else + hess(ind(ic,i,jc,m)) = hess(ind(ic,i,jc,m)) & + +gij*si(ic)*sm(jc) + end if + if (m .gt. j) then + hess(ind(ic,m,jc,j)) = hess(ind(ic,m,jc,j)) & + +gij*sm(ic)*sj(jc) + else + hess(ind(ic,j,jc,m)) = hess(ind(ic,j,jc,m)) & + +gij*sj(ic)*sm(jc) + end if + if (i .gt. j) then + hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j)) & + +gij*si(ic)*sj(jc) + else + hess(ind(ic,j,jc,i)) = hess(ind(ic,j,jc,i)) & + +gij*sj(ic)*si(jc) + end if + end do + end do + do ic = 1,3 + do jc = 1,ic + hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+gij*si(ic)*si(jc) + hess(ind(ic,m,jc,m)) = hess(ind(ic,m,jc,m))+gij*sm(ic)*sm(jc) + hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+gij*sj(ic)*sj(jc) + end do + end do + else + ! linear case + if ((abs(ymi) .gt. rzero).or.(abs(xmi) .gt. rzero)) then + x(1) = -ymi + y(1) = xmi + z(1) = 0.0_wp + x(2) = -xmi*zmi + y(2) = -ymi*zmi + z(2) = xmi*xmi+ymi*ymi + else + x(1) = 1.0_wp + y(1) = 0.0_wp + z(1) = 0.0_wp + x(2) = 0.0_wp + y(2) = 1.0_wp + z(2) = 0.0_wp + end if + do ii = 1,2 + r1 = sqrt(x(ii)**2+y(ii)**2+z(ii)**2) + costhetax = x(ii)/r1 + costhetay = y(ii)/r1 + costhetaz = z(ii)/r1 + si(1) = -costhetax/rmi + si(2) = -costhetay/rmi + si(3) = -costhetaz/rmi + sj(1) = -costhetax/rmj + sj(2) = -costhetay/rmj + sj(3) = -costhetaz/rmj + sm(1) = -(si(1)+sj(1)) + sm(2) = -(si(2)+sj(2)) + sm(3) = -(si(3)+sj(3)) + ! + do ic = 1,3 + do jc = 1,3 + if (m .gt. i) then + hess(ind(ic,m,jc,i)) = hess(ind(ic,m,jc,i)) & + +gij*sm(ic)*si(jc) + else + hess(ind(ic,i,jc,m)) = hess(ind(ic,i,jc,m)) & + +gij*si(ic)*sm(jc) + end if + if (m .gt. j) then + hess(ind(ic,m,jc,j)) = hess(ind(ic,m,jc,j)) & + +gij*sm(ic)*sj(jc) + else + hess(ind(ic,j,jc,m)) = hess(ind(ic,j,jc,m)) & + +gij*sj(ic)*sm(jc) + end if + if (i .gt. j) then + hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j)) & + +gij*si(ic)*sj(jc) + else + hess(ind(ic,j,jc,i)) = hess(ind(ic,j,jc,i)) & + +gij*sj(ic)*si(jc) + end if + end do + end do + do ic = 1,3 + do jc = 1,ic + hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i)) & + +gij*si(ic)*si(jc) + hess(ind(ic,m,jc,m)) = hess(ind(ic,m,jc,m)) & + +gij*sm(ic)*sm(jc) + hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j)) & + +gij*sj(ic)*sj(jc) + end do + end do + end do + + end if + end if + + end do bend_jAt + end do bend_iAt + end do bend_mAt + + end subroutine mh_swart_bend + + pure subroutine mh_swart_torsion(n,at,xyz,hess,kt,kd,rcov,rvdw,lcutoff) + implicit none + + integer,intent(in) :: n + integer,intent(in) :: at(n) + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) + real(wp),intent(in) :: kt + real(wp),intent(in) :: kd + real(wp),intent(in) :: rcov(:) + real(wp),intent(in) :: rvdw(:) + logical,intent(in) :: lcutoff(n,n) + + integer :: i,j,k,l,ic,jc,ij,kl +! allow only angles in the range of 35-145 + real(wp),parameter :: a35 = (35.0d0/180.d0)*pi + real(wp),parameter :: cosfi_max = cos(a35) + real(wp) :: txyz(3,4),c(3,4) + real(wp) :: rij(3),rij0,aij,rij2,d0ij,gij + real(wp) :: rjk(3),rjk0,ajk,rjk2,d0jk,gjk + real(wp) :: rkl(3),rkl0,akl,rkl2,d0kl,gkl + real(wp) :: cosfi2,cosfi3,cosfi4 + real(wp) :: beta,tij,tau + real(wp) :: si(3),sj(3),sk(3),sl(3) + +!! ------------------------------------------------------------------------ +! Hessian for torsion +!! ------------------------------------------------------------------------ + torsion_jAt: do j = 1,n + txyz(:,2) = xyz(:,j) + torsion_kAt: do k = 1,n + if (k .eq. j) cycle torsion_kAt + if (lcutoff(k,j)) cycle torsion_kAt + txyz(:,3) = xyz(:,k) + torsion_iAt: do i = 1,n + ij = n*(j-1)+i + if (i .eq. j) cycle torsion_iAt + if (i .eq. k) cycle torsion_iAt + if (lcutoff(i,k)) cycle torsion_iAt + if (lcutoff(i,j)) cycle torsion_iAt + + txyz(:,1) = xyz(:,i) + torsion_lAt: do l = 1,n + kl = n*(l-1)+k + if (ij .le. kl) cycle torsion_lAt + if (l .eq. i) cycle torsion_lAt + if (l .eq. j) cycle torsion_lAt + if (l .eq. k) cycle torsion_lAt +! + if (lcutoff(l,i)) cycle torsion_lAt + if (lcutoff(l,k)) cycle torsion_lAt + if (lcutoff(l,j)) cycle torsion_lAt + + txyz(:,4) = xyz(:,l) + + rij = xyz(:,i)-xyz(:,j) + d0ij = rvdw(at(i))+rvdw(at(j)) + rij0 = rcov(at(i))+rcov(at(j)) + + rjk = xyz(:,j)-xyz(:,k) + d0jk = rvdw(at(j))+rvdw(at(k)) + rjk0 = rcov(at(j))+rcov(at(k)) + + rkl = xyz(:,k)-xyz(:,l) + d0kl = rvdw(at(k))+rvdw(at(l)) + rkl0 = rcov(at(k))+rcov(at(l)) + + rij2 = sum(rij**2) + rjk2 = sum(rjk**2) + rkl2 = sum(rjk**2) + + cosfi2 = dot_product(rij,rjk)/sqrt(rij2*rjk2) + if (abs(cosfi2) .gt. cosfi_max) cycle + cosfi3 = dot_product(rkl,rjk)/sqrt(rkl2*rjk2) + if (abs(cosfi3) .gt. cosfi_max) cycle + + gij = fk_swart(1.0_wp,rij0,rij2) & + +0.5_wp*kd*fk_vdw(5.0_wp,d0ij,rij2) + gjk = fk_swart(1.0_wp,rjk0,rjk2) & + +0.5_wp*kd*fk_vdw(5.0_wp,d0jk,rjk2) + gkl = fk_swart(1.0_wp,rkl0,rkl2) & + +0.5_wp*kd*fk_vdw(5.0_wp,d0kl,rkl2) + + tij = kt*gij*gjk*gkl + + !tij = max(tij,10*min_fk) + + call trsn2(txyz,tau,c) + si = c(:,1) + sj = c(:,2) + sk = c(:,3) + sl = c(:,4) + + ! off diagonal block + do ic = 1,3 + do jc = 1,3 + hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j))+tij*si(ic)*sj(jc) + hess(ind(ic,i,jc,k)) = hess(ind(ic,i,jc,k))+tij*si(ic)*sk(jc) + hess(ind(ic,i,jc,l)) = hess(ind(ic,i,jc,l))+tij*si(ic)*sl(jc) + hess(ind(ic,j,jc,k)) = hess(ind(ic,j,jc,k))+tij*sj(ic)*sk(jc) + hess(ind(ic,j,jc,l)) = hess(ind(ic,j,jc,l))+tij*sj(ic)*sl(jc) + hess(ind(ic,k,jc,l)) = hess(ind(ic,k,jc,l))+tij*sk(ic)*sl(jc) + end do + end do + + ! diagonal block + do ic = 1,3 + do jc = 1,ic + hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+tij*si(ic)*si(jc) + hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+tij*sj(ic)*sj(jc) + hess(ind(ic,k,jc,k)) = hess(ind(ic,k,jc,k))+tij*sk(ic)*sk(jc) + hess(ind(ic,l,jc,l)) = hess(ind(ic,l,jc,l))+tij*sl(ic)*sl(jc) + end do + end do + + end do torsion_lAt + end do torsion_iAt + end do torsion_kAt + end do torsion_jAt + + end subroutine mh_swart_torsion + + pure subroutine mh_swart_outofp(n,at,xyz,hess,ko,kd,rcov,rvdw,lcutoff) + implicit none + + integer,intent(in) :: n + integer,intent(in) :: at(n) + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) + real(wp),intent(in) :: ko + real(wp),intent(in) :: kd + real(wp),intent(in) :: rcov(:) + real(wp),intent(in) :: rvdw(:) + logical,intent(in) :: lcutoff(n,n) + + integer :: i,ir,j,jr,k,kr,l,lr,ic,jc + real(wp) :: txyz(3,4),c(3,4) + real(wp) :: rij(3),rij0,d0ij,rij2,gij + real(wp) :: rik(3),rik0,d0ik,rik2,gik + real(wp) :: ril(3),ril0,d0il,ril2,gil + real(wp) :: cosfi2,cosfi3,cosfi4 + real(wp) :: beta,tij,tau + real(wp) :: si(3),sj(3),sk(3),sl(3) + +!! ------------------------------------------------------------------------ +! Hessian for out-of-plane +!! ------------------------------------------------------------------------ + outofplane_iAt: do i = 1,n + txyz(:,4) = xyz(:,i) + outofplane_jAt: do j = 1,n + if (j .eq. i) cycle outofplane_jAt + if (lcutoff(j,i)) cycle outofplane_jAt + txyz(:,1) = xyz(:,j) + outofplane_kAt: do k = 1,n + if (i .eq. k) cycle outofplane_kAt + if (j .eq. k) cycle outofplane_kat + if (lcutoff(k,i)) cycle outofplane_kAt + if (lcutoff(k,j)) cycle outofplane_kAt + txyz(:,2) = xyz(:,k) + outofplane_lAt: do l = 1,n + txyz(:,3) = xyz(:,l) + if (l .eq. i) cycle outofplane_lAt + if (l .eq. j) cycle outofplane_lAt + if (l .eq. k) cycle outofplane_lAt + if (lcutoff(l,i)) cycle outofplane_lAt + if (lcutoff(l,k)) cycle outofplane_lAt + if (lcutoff(l,j)) cycle outofplane_lAt + + rij = xyz(:,i)-xyz(:,j) + rij0 = rcov(at(i))+rcov(at(j)) + d0ij = rvdw(at(i))+rvdw(at(j)) + + rik = xyz(:,i)-xyz(:,k) + rik0 = rcov(at(i))+rcov(at(k)) + d0ik = rvdw(at(i))+rvdw(at(k)) + + ril = xyz(:,i)-xyz(:,l) + ril0 = rcov(at(i))+rcov(at(l)) + d0il = rvdw(at(i))+rvdw(at(l)) + + rij2 = sum(rij**2) + rik2 = sum(rik**2) + ril2 = sum(ril**2) + + cosfi2 = dot_product(rij,rik)/sqrt(rij2*rik2) + if (abs(abs(cosfi2)-1.0_wp) .lt. 1.0e-1_wp) cycle + cosfi3 = dot_product(rij,ril)/sqrt(rij2*ril2) + if (abs(abs(cosfi3)-1.0_wp) .lt. 1.0e-1_wp) cycle + cosfi4 = dot_product(rik,ril)/sqrt(rik2*ril2) + if (abs(abs(cosfi4)-1.0_wp) .lt. 1.0e-1_wp) cycle + + gij = fk_swart(1.0_wp,rij0,rij2) & + +0.5_wp*kd*fk_vdw(5.0_wp,d0ij,rij2) + gik = fk_swart(1.0_wp,rik0,rik2) & + +0.5_wp*kd*fk_vdw(5.0_wp,d0ik,rik2) + gil = fk_swart(1.0_wp,ril0,ril2) & + +0.5_wp*kd*fk_vdw(5.0_wp,d0il,ril2) + + tij = ko*gij*gik*gil + + !tij = max(tij,10*min_fk) + + call outofp2(xyz,tau,c) + If (abs(tau) .gt. 45.0d0*(pi/180.d0)) cycle + + si = c(:,4) + sj = c(:,1) + sk = c(:,2) + sl = c(:,3) + + ! off diagonal block + do ic = 1,3 + do jc = 1,3 + hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j))+tij*si(ic)*sj(jc) + hess(ind(ic,i,jc,k)) = hess(ind(ic,i,jc,k))+tij*si(ic)*sk(jc) + hess(ind(ic,i,jc,l)) = hess(ind(ic,i,jc,l))+tij*si(ic)*sl(jc) + hess(ind(ic,j,jc,k)) = hess(ind(ic,j,jc,k))+tij*sj(ic)*sk(jc) + hess(ind(ic,j,jc,l)) = hess(ind(ic,j,jc,l))+tij*sj(ic)*sl(jc) + hess(ind(ic,k,jc,l)) = hess(ind(ic,k,jc,l))+tij*sk(ic)*sl(jc) + end do + end do + + ! diagonal block + do ic = 1,3 + do jc = 1,ic + hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+tij*si(ic)*si(jc) + hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+tij*sj(ic)*sj(jc) + hess(ind(ic,k,jc,k)) = hess(ind(ic,k,jc,k))+tij*sk(ic)*sk(jc) + hess(ind(ic,l,jc,l)) = hess(ind(ic,l,jc,l))+tij*sl(ic)*sl(jc) + end do + end do + + end do outofplane_lAt + end do outofplane_kAt + end do outofplane_jAt + end do outofplane_iAt + + end subroutine mh_swart_outofp + +!========================================================================================! +!########################################################################################! +!========================================================================================! + + subroutine mh_lindh(xyz,n,hess,at,modh) +!************************************************************************** +!* Lindh's Model Hessian updated around 2007 +!* ------------------------------------------------------------------------ +!* R. Lindh, personal communication. +!* +!* gij = exp[αij(R²ref - R²ij)] +!* dij = exp[-4·(Rvdw - Rij)²] +!* kij = rkr·gij + rkd·dij +!* kijk = rkf·(gij+½·rkd/rkr·dij)·(gjk+½·rkd/rkr·djk) +!* kijkl = rkt·(gij+½·rkd/rkr·dij)·(gjk+½·rkd/rkr·djk)·(gkl+½·rkd/rkr·dkl) +!* +!* parameters tweaked by R. Lindh in 2007: +!* rkr = 0.45, rkf = 0.10, rkt = 0.0025, rko = 0.16, rkd = 0.05 +!* +!* the reference distances are divided by rows in the PSE: +!* rAv: 1 2 3 aAv: 1 2 3 +!* 1 1.3500 2.1000 2.5300 1 1.0000 0.3949 0.3949 +!* 2 2.1000 2.8700 3.8000 2 0.3949 0.2800 0.1200 +!* 3 2.5300 3.8000 4.5000 3 0.3949 0.1200 0.0600 +!* +!* dAv: 1 2 3 +!* 1 0.0000 3.6000 3.6000 +!* 2 3.6000 5.3000 5.3000 +!* 3 3.6000 5.3000 5.3000 +!* +!************************************************************************** + implicit none + + integer,intent(in) :: n + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(out) :: hess((3*n)*(3*n+1)/2) + integer,intent(in) :: at(n) + type(mhparam),intent(in) :: modh + + real(wp),parameter :: rAv(3,3) = reshape( & + (/1.3500_wp,2.1000_wp,2.5300_wp, & + 2.1000_wp,2.8700_wp,3.8000_wp, & + 2.5300_wp,3.8000_wp,4.5000_wp/),shape(rAv)) + real(wp),parameter :: aAv(3,3) = reshape( & + (/1.0000_wp,0.3949_wp,0.3949_wp, & + 0.3949_wp,0.2800_wp,0.1200_wp, & + 0.3949_wp,0.1200_wp,0.0600_wp/),shape(aAv)) + real(wp),parameter :: dAv(3,3) = reshape( & + (/0.0000_wp,3.6000_wp,3.6000_wp, & + 3.6000_wp,5.3000_wp,5.3000_wp, & + 3.6000_wp,5.3000_wp,5.3000_wp/),shape(aAv)) + + integer :: n3 + real(wp) :: kd + logical,allocatable :: lcutoff(:,:) + !type(chrg_parameter) :: chrgeq + + allocate (lcutoff(n,n),source=.false.) + + n3 = 3*n + hess = 0.0d0 + +! the dispersion force constant is used relative to the stretch force constant + kd = modh%kd/modh%kr + + call mh_lindh_stretch(n,at,xyz,hess,modh%kr,kd,modh%s6,aav,rav,dav,lcutoff,modh%rcut) + if (modh%kf .ne. 0.0_wp) & + call mh_lindh_bend(n,at,xyz,hess,modh%kf,kd,aav,rav,dav,lcutoff) + if (modh%kt .ne. 0.0_wp) & + call mh_lindh_torsion(n,at,xyz,hess,modh%kt,kd,aav,rav,dav,lcutoff) + if (modh%ko .ne. 0.0_wp) & + call mh_lindh_outofp(n,at,xyz,hess,modh%ko,0.0_wp,aav,rav,dav,lcutoff) + if (modh%kq .ne. 0.0_wp) then + !call new_charge_model_2019(chrgeq,n,at) + call mh_eeq(n,at,xyz,0.0_wp,modh%kq,hess) + end if + + end subroutine mh_lindh + + subroutine mh_lindh_d2(xyz,n,hess,at,modh) +!************************************************************************** +!* Lindh's Model Hessian augmented with D2 +!* ------------------------------------------------------------------------ +!* Implemented after: +!* Lindh, R., Bernhardsson, A., Karlström, G., & Malmqvist, P.-Å. (1995). +!* On the use of a Hessian model function in molecular geometry optimizations. +!* Chem. Phys. Lett., 241(4), 423–428. doi:10.1016/0009-2614(95)00646-l +!* +!* gij = exp[αij(R²ref - R²ij)] +!* kij = rkr·gij +!* kijk = rkf·gij·gjk +!* kijkl = rkt·gij·gjk·gkl +!* +!* Originally Lindh proposed (we tweaked those a little bit): +!* rkr = 0.45, rkf = 0.15, rkt = 0.005 +!* +!* the reference distances are divided by rows in the PSE: +!* rAv: 1 2 3 aAv: 1 2 3 +!* 1 1.3500 2.1000 2.5300 1 1.0000 0.3949 0.3949 +!* 2 2.1000 2.8700 3.4000 2 0.3949 0.2800 0.2800 +!* 3 2.5300 3.4000 3.4000 3 0.3949 0.2800 0.2800 +!* +!* This Hessian is additionally augmented with D2, please note that D2 +!* is not implemented in atomic units and requires some magical conversion +!* factor somewhere hidden in the implementation below. +!************************************************************************* + implicit none + + integer,intent(in) :: n + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(out) :: hess((3*n)*(3*n+1)/2) + integer,intent(in) :: at(n) + type(mhparam),intent(in) :: modh + + real(wp),parameter :: rAv(3,3) = reshape( & + (/1.3500_wp,2.1000_wp,2.5300_wp, & + 2.1000_wp,2.8700_wp,3.4000_wp, & + 2.5300_wp,3.4000_wp,3.4000_wp/),shape(rAv)) + real(wp),parameter :: aAv(3,3) = reshape( & + (/1.0000_wp,0.3949_wp,0.3949_wp, & + 0.3949_wp,0.2800_wp,0.2800_wp, & + 0.3949_wp,0.2800_wp,0.2800_wp/),shape(aAv)) + real(wp),parameter :: dAv(3,3) = reshape( & + (/0.0000_wp,0.0000_wp,0.0000_wp, & + 0.0000_wp,0.0000_wp,0.0000_wp, & + 0.0000_wp,0.0000_wp,0.0000_wp/),shape(aAv)) + + integer :: n3 + real(wp) :: kd + logical,allocatable :: lcutoff(:,:) + + allocate (lcutoff(n,n),source=.false.) + + n3 = 3*n + hess = 0.0d0 + +! the dispersion force constant is used relative to the stretch force constant + kd = modh%kd/modh%kr + + call mh_lindh_stretch(n,at,xyz,hess,modh%kr,kd,modh%s6,aav,rav,dav,lcutoff,modh%rcut) + if (modh%kf .ne. 0.0_wp) & + call mh_lindh_bend(n,at,xyz,hess,modh%kf,kd,aav,rav,dav,lcutoff) + if (modh%kt .ne. 0.0_wp) & + call mh_lindh_torsion(n,at,xyz,hess,modh%kt,kd,aav,rav,dav,lcutoff) + if (modh%ko .ne. 0.0_wp) & + call mh_lindh_outofp(n,at,xyz,hess,modh%ko,kd,aav,rav,dav,lcutoff) + if (modh%kq .ne. 0.0_wp) then + call mh_eeq(n,at,xyz,0.0_wp,modh%kq,hess) + end if + end subroutine mh_lindh_d2 + + pure subroutine mh_lindh_stretch(n,at,xyz,hess,kr,kd,s6,aav,rav,dav,lcutoff,rcut) + implicit none + + integer,intent(in) :: n + integer,intent(in) :: at(n) + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) + real(wp),intent(in) :: kr + real(wp),intent(in) :: kd + real(wp),intent(in) :: s6 + real(wp),intent(in) :: aav(3,3) + real(wp),intent(in) :: rav(3,3) + real(wp),intent(in) :: dav(3,3) + logical,intent(out) :: lcutoff(n,n) + real(wp),intent(in) :: rcut + + integer :: i,ir,j,jr + real(wp) :: xij,yij,zij,rij2,r0,d0 + real(wp) :: alpha,gmm + real(wp) :: c6i,c6j,c6ij,rv + real(wp) :: hxx,hxy,hxz,hyy,hyz,hzz + real(wp) :: vdw(3,3) + +!! ------------------------------------------------------------------------ +! Hessian for stretch +!! ------------------------------------------------------------------------ + stretch_iAt: do i = 1,n + ir = itabrow(at(i)) + + stretch_jAt: do j = 1,i-1 + jr = itabrow(at(j)) + + ! save for later + lcutoff(i,j) = rcutoff(xyz,i,j,rcut) + lcutoff(j,i) = lcutoff(i,j) + + xij = xyz(1,i)-xyz(1,j) + yij = xyz(2,i)-xyz(2,j) + zij = xyz(3,i)-xyz(3,j) + rij2 = xij**2+yij**2+zij**2 + r0 = rav(ir,jr) + d0 = dav(ir,jr) + alpha = aav(ir,jr) + + !cccccc vdwx ccccccccccccccccccccccccccccccccc + c6i = c6(at(i)) + c6j = c6(at(j)) + c6ij = sqrt(c6i*c6j) + rv = (vander(at(i))+vander(at(j)))*aatoau + + call getvdwxx(xij,yij,zij,c6ij,s6,rv,vdw(1,1)) + call getvdwxy(xij,yij,zij,c6ij,s6,rv,vdw(1,2)) + call getvdwxy(xij,zij,yij,c6ij,s6,rv,vdw(1,3)) + call getvdwxx(yij,xij,zij,c6ij,s6,rv,vdw(2,2)) + call getvdwxy(yij,zij,xij,c6ij,s6,rv,vdw(2,3)) + call getvdwxx(zij,xij,yij,c6ij,s6,rv,vdw(3,3)) + !cccccc ende vdwx ccccccccccccccccccccccccccccccc + + gmm = kr*fk_lindh(alpha,r0,rij2) & + +kr*kd*fk_vdw(4.0_wp,d0,rij2) + + !gmm = max(gmm,min_fk) + + hxx = gmm*xij*xij/rij2-vdw(1,1) + hxy = gmm*xij*yij/rij2-vdw(1,2) + hxz = gmm*xij*zij/rij2-vdw(1,3) + hyy = gmm*yij*yij/rij2-vdw(2,2) + hyz = gmm*yij*zij/rij2-vdw(2,3) + hzz = gmm*zij*zij/rij2-vdw(3,3) + + ! save diagonal elements for atom i + hess(ind(1,i,1,i)) = hess(ind(1,i,1,i))+hxx + hess(ind(2,i,1,i)) = hess(ind(2,i,1,i))+hxy + hess(ind(2,i,2,i)) = hess(ind(2,i,2,i))+hyy + hess(ind(3,i,1,i)) = hess(ind(3,i,1,i))+hxz + hess(ind(3,i,2,i)) = hess(ind(3,i,2,i))+hyz + hess(ind(3,i,3,i)) = hess(ind(3,i,3,i))+hzz + ! save elements between atom i and atom j + hess(ind(1,i,1,j)) = hess(ind(1,i,1,j))-hxx + hess(ind(1,i,2,j)) = hess(ind(1,i,2,j))-hxy + hess(ind(1,i,3,j)) = hess(ind(1,i,3,j))-hxz + hess(ind(2,i,1,j)) = hess(ind(2,i,1,j))-hxy + hess(ind(2,i,2,j)) = hess(ind(2,i,2,j))-hyy + hess(ind(2,i,3,j)) = hess(ind(2,i,3,j))-hyz + hess(ind(3,i,1,j)) = hess(ind(3,i,1,j))-hxz + hess(ind(3,i,2,j)) = hess(ind(3,i,2,j))-hyz + hess(ind(3,i,3,j)) = hess(ind(3,i,3,j))-hzz + ! save diagonal elements for atom j + hess(ind(1,j,1,j)) = hess(ind(1,j,1,j))+hxx + hess(ind(2,j,1,j)) = hess(ind(2,j,1,j))+hxy + hess(ind(2,j,2,j)) = hess(ind(2,j,2,j))+hyy + hess(ind(3,j,1,j)) = hess(ind(3,j,1,j))+hxz + hess(ind(3,j,2,j)) = hess(ind(3,j,2,j))+hyz + hess(ind(3,j,3,j)) = hess(ind(3,j,3,j))+hzz + + end do stretch_jAt + end do stretch_iAt + + end subroutine mh_lindh_stretch + + pure subroutine mh_lindh_bend(n,at,xyz,hess,kf,kd,aav,rav,dav,lcutoff) + implicit none + + integer,intent(in) :: n + integer,intent(in) :: at(n) + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) + real(wp),intent(in) :: kf + real(wp),intent(in) :: kd + real(wp),intent(in) :: aav(3,3) + real(wp),intent(in) :: rav(3,3) + real(wp),intent(in) :: dav(3,3) + logical,intent(in) :: lcutoff(n,n) + + integer :: i,ir,j,jr,m,mr,ic,jc,ii + real(wp),parameter :: rzero = 1.0e-10_wp + real(wp) :: xij,yij,zij,rij2,rrij,r1 + real(wp) :: xmi,ymi,zmi,rmi2,rmi,r0mi,ami,d0mj,gmi + real(wp) :: xmj,ymj,zmj,rmj2,rmj,r0mj,amj,d0mi,gmj + real(wp) :: test,gij,rl2,rl,rmidotrmj + real(wp) :: sinphi,cosphi,costhetax,costhetay,costhetaz + real(wp) :: alpha + real(wp) :: si(3),sj(3),sm(3),x(2),y(2),z(2) + +!! ------------------------------------------------------------------------ +! Hessian for bending +!! ------------------------------------------------------------------------ + bend_mAt: do m = 1,n + mr = itabrow(at(m)) + bend_iAt: do i = 1,n + if (i .eq. m) cycle bend_iAt + ir = itabrow(at(i)) + if (lcutoff(i,m)) cycle bend_iAt + + xmi = (xyz(1,i)-xyz(1,m)) + ymi = (xyz(2,i)-xyz(2,m)) + zmi = (xyz(3,i)-xyz(3,m)) + rmi2 = xmi**2+ymi**2+zmi**2 + rmi = sqrt(rmi2) + r0mi = rav(mr,ir) + d0mi = dav(mr,ir) + ami = aav(mr,ir) + + bend_jAt: do j = 1,i-1 + if (j .eq. m) cycle bend_jAt + jr = itabrow(at(j)) + if (lcutoff(j,i)) cycle bend_jAt + if (lcutoff(j,m)) cycle bend_jAt + + xmj = (xyz(1,j)-xyz(1,m)) + ymj = (xyz(2,j)-xyz(2,m)) + zmj = (xyz(3,j)-xyz(3,m)) + rmj2 = xmj**2+ymj**2+zmj**2 + rmj = sqrt(rmj2) + r0mj = rav(mr,jr) + d0mj = dav(mr,jr) + amj = aav(mr,jr) + + ! test if zero angle + test = xmi*xmj+ymi*ymj+zmi*zmj + test = test/(rmi*rmj) + if (abs(test-1.0_wp) .lt. 1.0e-12_wp) cycle bend_jAt + + xij = (xyz(1,j)-xyz(1,i)) + yij = (xyz(2,j)-xyz(2,i)) + zij = (xyz(3,j)-xyz(3,i)) + rij2 = xij**2+yij**2+zij**2 + rrij = sqrt(rij2) + + gmi = fk_lindh(ami,r0mi,rmi2) & + +0.5_wp*kd*fk_vdw(4.0_wp,d0mi,rmi2) + gmj = fk_lindh(amj,r0mj,rmj2) & + +0.5_wp*kd*fk_vdw(4.0_wp,d0mj,rmj2) + + gij = kf*gmi*gmj + + rl2 = (ymi*zmj-zmi*ymj)**2+(zmi*xmj-xmi*zmj)**2+(xmi*ymj-ymi*xmj)**2 + + if (rl2 .lt. 1.e-14_wp) then + rl = 0.0_wp + else + rl = sqrt(rl2) + end if + + !gij = max(gij,min_fk) + + if ((rmj .gt. rzero).and.(rmi .gt. rzero).and.(rrij .gt. rzero)) then + sinphi = rl/(rmj*rmi) + rmidotrmj = xmi*xmj+ymi*ymj+zmi*zmj + cosphi = rmidotrmj/(rmj*rmi) + ! none linear case + if (sinphi .gt. rzero) then + si(1) = (xmi/rmi*cosphi-xmj/rmj)/(rmi*sinphi) + si(2) = (ymi/rmi*cosphi-ymj/rmj)/(rmi*sinphi) + si(3) = (zmi/rmi*cosphi-zmj/rmj)/(rmi*sinphi) + sj(1) = (cosphi*xmj/rmj-xmi/rmi)/(rmj*sinphi) + sj(2) = (cosphi*ymj/rmj-ymi/rmi)/(rmj*sinphi) + sj(3) = (cosphi*zmj/rmj-zmi/rmi)/(rmj*sinphi) + sm(1) = -si(1)-sj(1) + sm(2) = -si(2)-sj(2) + sm(3) = -si(3)-sj(3) + do ic = 1,3 + do jc = 1,3 + if (m .gt. i) then + hess(ind(ic,m,jc,i)) = hess(ind(ic,m,jc,i)) & + +gij*sm(ic)*si(jc) + else + hess(ind(ic,i,jc,m)) = hess(ind(ic,i,jc,m)) & + +gij*si(ic)*sm(jc) + end if + if (m .gt. j) then + hess(ind(ic,m,jc,j)) = hess(ind(ic,m,jc,j)) & + +gij*sm(ic)*sj(jc) + else + hess(ind(ic,j,jc,m)) = hess(ind(ic,j,jc,m)) & + +gij*sj(ic)*sm(jc) + end if + if (i .gt. j) then + hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j)) & + +gij*si(ic)*sj(jc) + else + hess(ind(ic,j,jc,i)) = hess(ind(ic,j,jc,i)) & + +gij*sj(ic)*si(jc) + end if + end do + end do + do ic = 1,3 + do jc = 1,ic + hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+gij*si(ic)*si(jc) + hess(ind(ic,m,jc,m)) = hess(ind(ic,m,jc,m))+gij*sm(ic)*sm(jc) + hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+gij*sj(ic)*sj(jc) + end do + end do + else + ! linear case + if ((abs(ymi) .gt. rzero).or.(abs(xmi) .gt. rzero)) then + x(1) = -ymi + y(1) = xmi + z(1) = 0.0_wp + x(2) = -xmi*zmi + y(2) = -ymi*zmi + z(2) = xmi*xmi+ymi*ymi + else + x(1) = 1.0_wp + y(1) = 0.0_wp + z(1) = 0.0_wp + x(2) = 0.0_wp + y(2) = 1.0_wp + z(2) = 0.0_wp + end if + do ii = 1,2 + r1 = sqrt(x(ii)**2+y(ii)**2+z(ii)**2) + costhetax = x(ii)/r1 + costhetay = y(ii)/r1 + costhetaz = z(ii)/r1 + si(1) = -costhetax/rmi + si(2) = -costhetay/rmi + si(3) = -costhetaz/rmi + sj(1) = -costhetax/rmj + sj(2) = -costhetay/rmj + sj(3) = -costhetaz/rmj + sm(1) = -(si(1)+sj(1)) + sm(2) = -(si(2)+sj(2)) + sm(3) = -(si(3)+sj(3)) + ! + do ic = 1,3 + do jc = 1,3 + if (m .gt. i) then + hess(ind(ic,m,jc,i)) = hess(ind(ic,m,jc,i)) & + +gij*sm(ic)*si(jc) + else + hess(ind(ic,i,jc,m)) = hess(ind(ic,i,jc,m)) & + +gij*si(ic)*sm(jc) + end if + if (m .gt. j) then + hess(ind(ic,m,jc,j)) = hess(ind(ic,m,jc,j)) & + +gij*sm(ic)*sj(jc) + else + hess(ind(ic,j,jc,m)) = hess(ind(ic,j,jc,m)) & + +gij*sj(ic)*sm(jc) + end if + if (i .gt. j) then + hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j)) & + +gij*si(ic)*sj(jc) + else + hess(ind(ic,j,jc,i)) = hess(ind(ic,j,jc,i)) & + +gij*sj(ic)*si(jc) + end if + end do + end do + do ic = 1,3 + do jc = 1,ic + hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i)) & + +gij*si(ic)*si(jc) + hess(ind(ic,m,jc,m)) = hess(ind(ic,m,jc,m)) & + +gij*sm(ic)*sm(jc) + hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j)) & + +gij*sj(ic)*sj(jc) + end do + end do + end do + + end if + end if + + end do bend_jAt + end do bend_iAt + end do bend_mAt + + end subroutine mh_lindh_bend + + subroutine mh_lindh_torsion(n,at,xyz,hess,kt,kd,aav,rav,dav,lcutoff) + implicit none + + integer,intent(in) :: n + integer,intent(in) :: at(n) + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) + real(wp),intent(in) :: kt + real(wp),intent(in) :: kd + real(wp),intent(in) :: aav(3,3) + real(wp),intent(in) :: rav(3,3) + real(wp),intent(in) :: dav(3,3) + logical,intent(in) :: lcutoff(n,n) + + integer :: i,ir,j,jr,k,kr,l,lr,ic,jc,ij,kl +! allow only angles in the range of 35-145 + real(wp),parameter :: a35 = (35.0d0/180.d0)*pi + real(wp),parameter :: cosfi_max = cos(a35) + real(wp) :: txyz(3,4),c(3,4) + real(wp) :: rij(3),rij0,aij,rij2,d0ij,gij + real(wp) :: rjk(3),rjk0,ajk,rjk2,d0jk,gjk + real(wp) :: rkl(3),rkl0,akl,rkl2,d0kl,gkl + real(wp) :: cosfi2,cosfi3,cosfi4 + real(wp) :: beta,tij,tau,dum(3,4,3,4) + real(wp) :: si(3),sj(3),sk(3),sl(3) + +!! ------------------------------------------------------------------------ +! Hessian for torsion +!! ------------------------------------------------------------------------ + torsion_jAt: do j = 1,n + jr = itabrow(at(j)) + txyz(:,2) = xyz(:,j) + torsion_kAt: do k = 1,n + if (k .eq. j) cycle torsion_kAt + kr = itabrow(at(k)) + if (lcutoff(k,j)) cycle torsion_kAt + txyz(:,3) = xyz(:,k) + torsion_iAt: do i = 1,n + ij = n*(j-1)+i + if (i .eq. j) cycle torsion_iAt + if (i .eq. k) cycle torsion_iAt + ir = itabrow(at(i)) + if (lcutoff(i,k)) cycle torsion_iAt + if (lcutoff(i,j)) cycle torsion_iAt + + txyz(:,1) = xyz(:,i) + torsion_lAt: do l = 1,n + kl = n*(k-1)+l + if (ij .le. kl) cycle torsion_lAt + if (l .eq. i) cycle torsion_lAt + if (l .eq. j) cycle torsion_lAt + if (l .eq. k) cycle torsion_lAt + lr = itabrow(at(l)) +! + if (lcutoff(l,i)) cycle torsion_lAt + if (lcutoff(l,k)) cycle torsion_lAt + if (lcutoff(l,j)) cycle torsion_lAt + + txyz(:,4) = xyz(:,l) + + rij = xyz(:,i)-xyz(:,j) + d0ij = dav(ir,jr) + rij0 = rav(ir,jr) + aij = aav(ir,jr) + + rjk = xyz(:,j)-xyz(:,k) + d0jk = dav(jr,kr) + rjk0 = rav(jr,kr) + ajk = aav(jr,kr) + + rkl = xyz(:,k)-xyz(:,l) + d0kl = dav(kr,lr) + rkl0 = rav(kr,lr) + akl = aav(kr,lr) + + rij2 = sum(rij**2) + rjk2 = sum(rjk**2) + rkl2 = sum(rjk**2) + + cosfi2 = dot_product(rij,rjk)/sqrt(rij2*rjk2) + if (abs(cosfi2) .gt. cosfi_max) cycle + cosfi3 = dot_product(rkl,rjk)/sqrt(rkl2*rjk2) + if (abs(cosfi3) .gt. cosfi_max) cycle + + gij = fk_lindh(aij,rij0,rij2) & + +0.5_wp*kd*fk_vdw(4.0_wp,d0ij,rij2) + gjk = fk_lindh(ajk,rjk0,rjk2) & + +0.5_wp*kd*fk_vdw(4.0_wp,d0jk,rjk2) + gkl = fk_lindh(akl,rkl0,rkl2) & + +0.5_wp*kd*fk_vdw(4.0_wp,d0kl,rkl2) + + tij = kt*gij*gjk*gkl + + !tij = max(tij,10*min_fk) + + !call trsn2(txyz,tau,c) + Call Trsn(txyz,4,Tau,C,.False.,.False.,' ', & + & Dum,.False.) + si = c(:,1) + sj = c(:,2) + sk = c(:,3) + sl = c(:,4) + + ! off diagonal block + do ic = 1,3 + do jc = 1,3 + hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j))+tij*si(ic)*sj(jc) + hess(ind(ic,i,jc,k)) = hess(ind(ic,i,jc,k))+tij*si(ic)*sk(jc) + hess(ind(ic,i,jc,l)) = hess(ind(ic,i,jc,l))+tij*si(ic)*sl(jc) + hess(ind(ic,j,jc,k)) = hess(ind(ic,j,jc,k))+tij*sj(ic)*sk(jc) + hess(ind(ic,j,jc,l)) = hess(ind(ic,j,jc,l))+tij*sj(ic)*sl(jc) + hess(ind(ic,k,jc,l)) = hess(ind(ic,k,jc,l))+tij*sk(ic)*sl(jc) + end do + end do + + ! diagonal block + do ic = 1,3 + do jc = 1,ic + hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+tij*si(ic)*si(jc) + hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+tij*sj(ic)*sj(jc) + hess(ind(ic,k,jc,k)) = hess(ind(ic,k,jc,k))+tij*sk(ic)*sk(jc) + hess(ind(ic,l,jc,l)) = hess(ind(ic,l,jc,l))+tij*sl(ic)*sl(jc) + end do + end do + + end do torsion_lAt + end do torsion_iAt + end do torsion_kAt + end do torsion_jAt + + end subroutine mh_lindh_torsion + + pure subroutine mh_lindh_outofp(n,at,xyz,hess,ko,kd,aav,rav,dav,lcutoff) + implicit none + + integer,intent(in) :: n + integer,intent(in) :: at(n) + real(wp),intent(in) :: xyz(3,n) + real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) + real(wp),intent(in) :: ko + real(wp),intent(in) :: kd + real(wp),intent(in) :: aav(3,3) + real(wp),intent(in) :: rav(3,3) + real(wp),intent(in) :: dav(3,3) + logical,intent(in) :: lcutoff(n,n) + + integer :: i,ir,j,jr,k,kr,l,lr,ic,jc + real(wp) :: txyz(3,4),c(3,4) + real(wp) :: rij(3),rij0,aij,rij2,gij,d0ij + real(wp) :: rik(3),rik0,aik,rik2,gik,d0ik + real(wp) :: ril(3),ril0,ail,ril2,gil,d0il + real(wp) :: cosfi2,cosfi3,cosfi4 + real(wp) :: beta,tij,tau + real(wp) :: si(3),sj(3),sk(3),sl(3) + +!! ------------------------------------------------------------------------ +! Hessian for out-of-plane +!! ------------------------------------------------------------------------ + outofplane_iAt: do i = 1,n + ir = itabrow(at(i)) + txyz(:,4) = xyz(:,i) + outofplane_jAt: do j = 1,n + if (j .eq. i) cycle outofplane_jAt + if (lcutoff(j,i)) cycle outofplane_jAt + jr = itabrow(at(j)) + txyz(:,1) = xyz(:,j) + outofplane_kAt: do k = 1,n + if (i .eq. k) cycle outofplane_kAt + if (j .eq. k) cycle outofplane_kat + if (lcutoff(k,i)) cycle outofplane_kAt + if (lcutoff(k,j)) cycle outofplane_kAt + kr = itabrow(at(k)) + txyz(:,2) = xyz(:,k) + outofplane_lAt: do l = 1,n + lr = itabrow(at(l)) + txyz(:,3) = xyz(:,l) + if (l .eq. i) cycle outofplane_lAt + if (l .eq. j) cycle outofplane_lAt + if (l .eq. k) cycle outofplane_lAt + if (lcutoff(l,i)) cycle outofplane_lAt + if (lcutoff(l,k)) cycle outofplane_lAt + if (lcutoff(l,j)) cycle outofplane_lAt + + rij = xyz(:,i)-xyz(:,j) + d0ij = dav(ir,jr) + rij0 = rav(ir,jr) + aij = aav(ir,jr) + + rik = xyz(:,i)-xyz(:,k) + d0ik = dav(ir,kr) + rik0 = rav(ir,kr) + aik = aav(ir,kr) + + ril = xyz(:,i)-xyz(:,l) + d0il = dav(ir,lr) + ril0 = rav(ir,lr) + ail = aav(ir,lr) + + rij2 = sum(rij**2) + rik2 = sum(rik**2) + ril2 = sum(ril**2) + + cosfi2 = dot_product(rij,rik)/sqrt(rij2*rik2) + if (abs(abs(cosfi2)-1.0_wp) .lt. 1.0e-1_wp) cycle + cosfi3 = dot_product(rij,ril)/sqrt(rij2*ril2) + if (abs(abs(cosfi3)-1.0_wp) .lt. 1.0e-1_wp) cycle + cosfi4 = dot_product(rik,ril)/sqrt(rik2*ril2) + if (abs(abs(cosfi4)-1.0_wp) .lt. 1.0e-1_wp) cycle + + gij = fk_lindh(aij,rij0,rij2) & + +0.5_wp*kd*fk_vdw(4.0_wp,d0ij,rij2) + gik = fk_lindh(aik,rik0,rik2) & + +0.5_wp*kd*fk_vdw(4.0_wp,d0ik,rik2) + gil = fk_lindh(ail,ril0,ril2) & + +0.5_wp*kd*fk_vdw(4.0_wp,d0il,ril2) + + tij = ko*gij*gik*gil + + !tij = max(tij,10*min_fk) + + call outofp2(xyz,tau,c) + If (abs(tau) .gt. 45.0d0*(pi/180.d0)) cycle + + si = c(:,4) + sj = c(:,1) + sk = c(:,2) + sl = c(:,3) + + ! off diagonal block + do ic = 1,3 + do jc = 1,3 + hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j))+tij*si(ic)*sj(jc) + hess(ind(ic,i,jc,k)) = hess(ind(ic,i,jc,k))+tij*si(ic)*sk(jc) + hess(ind(ic,i,jc,l)) = hess(ind(ic,i,jc,l))+tij*si(ic)*sl(jc) + hess(ind(ic,j,jc,k)) = hess(ind(ic,j,jc,k))+tij*sj(ic)*sk(jc) + hess(ind(ic,j,jc,l)) = hess(ind(ic,j,jc,l))+tij*sj(ic)*sl(jc) + hess(ind(ic,k,jc,l)) = hess(ind(ic,k,jc,l))+tij*sk(ic)*sl(jc) + end do + end do + + ! diagonal block + do ic = 1,3 + do jc = 1,ic + hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+tij*si(ic)*si(jc) + hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+tij*sj(ic)*sj(jc) + hess(ind(ic,k,jc,k)) = hess(ind(ic,k,jc,k))+tij*sk(ic)*sk(jc) + hess(ind(ic,l,jc,l)) = hess(ind(ic,l,jc,l))+tij*sl(ic)*sl(jc) + end do + end do + + end do outofplane_lAt + end do outofplane_kAt + end do outofplane_jAt + end do outofplane_iAt + + end subroutine mh_lindh_outofp + +!========================================================================================! +!########################################################################################! +!========================================================================================! + + pure function rcutoff(xyz,katom,latom,rcut) + implicit none + logical :: rcutoff + real(wp),intent(in) :: xyz(3,*) + real(wp),intent(in) :: rcut + real(wp) :: rkl(3),rkl2 + integer,intent(in) :: katom,latom + rcutoff = .false. + rkl = xyz(:,kAtom)-xyz(:,lAtom) + rkl2 = sum(rkl**2) + if (rkl2 .gt. rcut) rcutoff = .true. + end function rcutoff + + pure elemental function itabrow(i) + integer :: itabrow + integer,intent(in) :: i + + itabrow = 0 + if (i .gt. 0.and.i .le. 2) then + itabrow = 1 + else if (i .gt. 2.and.i .le. 10) then + itabrow = 2 + else if (i .gt. 10.and.i .le. 18) then + itabrow = 3 + else if (i .gt. 18.and.i .le. 36) then + itabrow = 3 + else if (i .gt. 36.and.i .le. 54) then + itabrow = 3 + else if (i .gt. 54.and.i .le. 86) then + itabrow = 3 + else if (i .gt. 86) then + itabrow = 3 + end if + + return + end function itabrow + + pure subroutine getvdwxy(rx,ry,rz,c66,s6,r0,vdw) + !cc Ableitung nach rx und ry + implicit none + real(wp),intent(in) :: rx,ry,rz,c66,s6,r0 + real(wp),intent(out) :: vdw + real(wp) :: t1,t2,t3,t4,t5,t6,t7,t11,t12,t16,t17,t25,t26,t35 + real(wp) :: t40,t41,t43,t44,t56,avdw + + ! write(*,*) 's6:', s6 + avdw = 20.0 + t1 = s6*C66 + t2 = rx**2 + t3 = ry**2 + t4 = rz**2 + t5 = t2+t3+t4 + t6 = t5**2 + t7 = t6**2 + t11 = sqrt(t5) + t12 = 0.1D1/r0 + t16 = exp(-avdw*(t11*t12-0.1D1)) + t17 = 0.1D1+t16 + t25 = t17**2 + t26 = 0.1D1/t25 + t35 = 0.1D1/t7 + t40 = avdw**2 + t41 = r0**2 + t43 = t40/t41 + t44 = t16**2 + t56 = -0.48D2*t1/t7/t5/t17*rx*ry+0.13D2*t1/t11/& + & t7*t26*rx*avdw*t12*ry*t16-0.2D1*t1*t35/t25/& + &t17*t43*rx*t44*ry+t1*t35*t26*t43*rx*ry*t16 + vdw = t56 + return + end subroutine getvdwxy + + pure subroutine getvdwxx(rx,ry,rz,c66,s6,r0,vdw) + !cc Ableitung nach rx und rx + Implicit none + real(wp),intent(in) :: rx,ry,rz,c66,s6,r0 + real(wp),intent(out) :: vdw + real(wp) :: t1,t2,t3,t4,t5,t6,t7,t10,t11,t15,t16,t17,t24,t25,t29 + real(wp) :: t33,t41,t42,t44,t45,t62,avdw + avdw = 20.0 + ! write(*,*) 's6:', s6 + t1 = s6*C66 + t2 = rx**2 + t3 = ry**2 + t4 = rz**2 + t5 = t2+t3+t4 + t6 = t5**2 + t7 = t6**2 + t10 = sqrt(t5) + t11 = 0.1D1/r0 + t15 = exp(-avdw*(t10*t11-0.1D1)) + t16 = 0.1D1+t15 + t17 = 0.1D1/t16 + t24 = t16**2 + t25 = 0.1D1/t24 + t29 = t11*t15 + t33 = 0.1D1/t7 + t41 = avdw**2 + t42 = r0**2 + t44 = t41/t42 + t45 = t15**2 + t62 = -0.48D2*t1/t7/t5*t17*t2+0.13D2*t1/t10/t7*& + & t25*t2*avdw*t29+0.6D1*t1*t33*t17-0.2D1*t1*t33& + & /t24/t16*t44*t2*t45-t1/t10/t6/t5*t25*avdw*& + &t29+t1*t33*t25*t44*t2*t15 + vdw = t62 + end subroutine getvdwxx + + pure subroutine trsn2(xyz,tau,bt) + implicit none + real(wp),intent(out) :: bt(3,4) + real(wp),intent(out) :: tau + real(wp),intent(in) :: xyz(3,4) + real(wp) :: rij(3),rij1,brij(3,2) + real(wp) :: rjk(3),rjk1,brjk(3,2) + real(wp) :: rkl(3),rkl1,brkl(3,2) + real(wp) :: bf2(3,3),fi2,sinfi2,cosfi2 + real(wp) :: bf3(3,3),fi3,sinfi3,cosfi3 + real(wp) :: costau,sintau + integer :: ix,iy,iz + call strtch2(xyz(1,1),rij1,brij) + call strtch2(xyz(1,2),rjk1,brjk) + call strtch2(xyz(1,3),rkl1,brkl) + call bend2(xyz(1,1),fi2,bf2) + sinfi2 = sin(fi2) + cosfi2 = cos(fi2) + call bend2(xyz(1,2),fi3,bf3) + sinfi3 = sin(fi3) + cosfi3 = cos(fi3) + costau = ((brij(2,1)*brjk(3,2)-brij(3,1)*brjk(2,2))* & + (brjk(2,1)*brkl(3,2)-brjk(3,1)*brkl(2,2))+ & + (brij(3,1)*brjk(1,2)-brij(1,1)*brjk(3,2))* & + (brjk(3,1)*brkl(1,2)-brjk(1,1)*brkl(3,2))+ & + (brij(1,1)*brjk(2,2)-brij(2,1)*brjk(1,2))* & + (brjk(1,1)*brkl(2,2)-brjk(2,1)*brkl(1,2))) & + /(sinfi2*sinfi3) + sintau = (brij(1,2)*(brjk(2,1)*brkl(3,2)-brjk(3,1)*brkl(2,2)) & + +brij(2,2)*(brjk(3,1)*brkl(1,2)-brjk(1,1)*brkl(3,2)) & + +brij(3,2)*(brjk(1,1)*brkl(2,2)-brjk(2,1)*brkl(1,2))) & + /(sinfi2*sinfi3) + tau = atan2(sintau,costau) + if (abs(tau) .eq. pi) tau = pi + do ix = 1,3 + iy = ix+1 + if (iy .gt. 3) iy = iy-3 + iz = iy+1 + if (iz .gt. 3) iz = iz-3 + bt(ix,1) = (brij(iy,2)*brjk(iz,2)-brij(iz,2)*brjk(iy,2)) & + & /(rij1*sinfi2**2) + bt(ix,4) = (brkl(iy,1)*brjk(iz,1)-brkl(iz,1)*brjk(iy,1)) & + & /(rkl1*sinfi3**2) + bt(ix,2) = -((rjk1-rij1*cosfi2)*bt(ix,1) & + & +rkl1*cosfi3*bt(ix,4))/rjk1 + bt(ix,3) = -(bt(ix,1)+bt(ix,2)+bt(ix,4)) + end do + end subroutine trsn2 + pure subroutine strtch2(xyz,avst,b) + implicit none + real(wp),intent(out) :: b(3,2) + real(wp),intent(in) :: xyz(3,2) + real(wp) :: r(3) + real(wp) :: rr + real(wp),intent(out) :: avst + r = xyz(:,2)-xyz(:,1) + rr = norm2(r) + avst = rr + b(:,1) = -r/rr + b(:,2) = -b(:,1) + end subroutine strtch2 + pure subroutine bend2(xyz,fir,bf) + implicit none + real(wp),intent(out) :: bf(3,3) + real(wp),intent(in) :: xyz(3,3) + real(wp) :: brij(3,2) + real(wp) :: brjk(3,2) + real(wp) :: co,crap + real(wp),intent(out) :: fir + real(wp) :: si + real(wp) :: rij1,rjk1 + integer :: i + call strtch2(xyz(1,1),rij1,brij) + call strtch2(xyz(1,2),rjk1,brjk) + co = 0.0_wp + crap = 0.0_wp + do i = 1,3 + co = co+brij(i,1)*brjk(i,2) + crap = crap+(brjk(i,2)+brij(i,1))**2 + end do + if (sqrt(crap) .lt. 1.0d-6) then + fir = pi-asin(sqrt(crap)) + si = sqrt(crap) + else + fir = acos(co) + si = sqrt(1.0_wp-co**2) + end if + if (abs(fir-pi) .lt. 1.0d-13) then + fir = pi + return + end if + do i = 1,3 + bf(i,1) = (co*brij(i,1)-brjk(i,2))/(si*rij1) + bf(i,3) = (co*brjk(i,2)-brij(i,1))/(si*rjk1) + bf(i,2) = -(bf(i,1)+bf(i,3)) + end do + end subroutine bend2 + + pure subroutine outofp2(xyz,teta,bt) + implicit none + real(wp),intent(out) :: teta + real(wp),intent(out) :: bt(3,4) + real(wp),intent(in) :: xyz(3,4) + real(wp) :: r1(3),r2(3),r3(3) + real(wp) :: q41,q42,q43,e41(3),e42(3),e43(3) + real(wp) :: cosfi1,fi1,dfi1,cosfi2,fi2,dfi2,cosfi3,fi3,dfi3 + real(wp) :: c14(3,3),br14(3,3) + real(wp) :: r42(3),r43(3) + integer :: ix,iy,iz +! 4 -> 1 (bond) + r1 = xyz(:,1)-xyz(:,4) + q41 = norm2(r1) + e41 = r1/q41 +! 4 -> 2 (bond in plane) + r2 = xyz(:,2)-xyz(:,4) + q42 = norm2(r2) + e42 = r2/q42 +! 4 -> 3 (bond in plane) + r3 = xyz(:,3)-xyz(:,4) + q43 = norm2(r3) + e43 = r3/q43 +! +! get the angle between e43 and e42 +! + cosfi1 = dot_product(e43,e42) + + fi1 = acos(cosfi1) + dfi1 = 180.d0*fi1/pi +! +! dirty exit! this happens when an earlier structure is ill defined. +! + if (abs(fi1-pi) .lt. 1.0d-13) then + teta = 0.0_wp + bt = 0.0_wp + return + end if +! +! get the angle between e41 and e43 +! + cosfi2 = dot_product(e41,e43) + + fi2 = acos(cosfi2) + dfi2 = 180.d0*fi2/pi +! +! get the angle between e41 and e42 +! + cosfi3 = dot_product(e41,e42) + + fi3 = acos(cosfi3) + dfi3 = 180.d0*fi3/pi +! +! the first two centers are trivially +! + c14(:,1) = xyz(:,1) + c14(:,2) = xyz(:,4) +! +! the 3rd is +! + r42 = xyz(:,2)-xyz(:,4) + r43 = xyz(:,3)-xyz(:,4) + c14(1,3) = r42(2)*r43(3)-r42(3)*r43(2) + c14(2,3) = r42(3)*r43(1)-r42(1)*r43(3) + c14(3,3) = r42(1)*r43(2)-r42(2)*r43(1) +! +! exit if 2-3-4 are collinear +! (equivalent to the above check, but this is more concrete) +! + if ((c14(1,3)**2+c14(2,3)**2+c14(3,3)**2) .lt. 1.0d-10) then + teta = 0.0d0 + bt = 0.0_wp + return + end if + c14(1,3) = c14(1,3)+xyz(1,4) + c14(2,3) = c14(2,3)+xyz(2,4) + c14(3,3) = c14(3,3)+xyz(3,4) + + call bend2(c14,teta,br14) + + teta = teta-0.5_wp*pi +! +!--compute the wdc matrix +! + do ix = 1,3 + iy = mod(ix+1,4)+(ix+1)/4 + iz = mod(iy+1,4)+(iy+1)/4 + + bt(ix,1) = -br14(ix,1) + bt(ix,2) = r43(iz)*br14(iy,3)-r43(iy)*br14(iz,3) + bt(ix,3) = -r42(iz)*br14(iy,3)+r42(iy)*br14(iz,3) + + bt(ix,4) = -(bt(ix,1)+bt(ix,2)+bt(ix,3)) + + end do + + bt = -bt + end subroutine outofp2 + + Subroutine Trsn(xyz,nCent,Tau,Bt,lWrite,lWarn,Label,dBt,ldB) +!************************************************************************ +!* * +!* Reference: Molecular Vibrations, E. Bright Wilson, Jr, J. C. Decicius* +!* nd Paul C. Cross, Sec. 4-1, Eq. 20-24 * +!* * +!* R.Lindh May-June '96 * +!************************************************************************ + Implicit Real(wp) (a-h,o-z) + + integer :: nCent,mCent,i,j,ix,iy,iz,jx,jy,jz + Real(wp) Bt(3,nCent),xyz(3,nCent),Rij(3),Eij(3),Rjk(3),Ejk(3),& + & Rkl(3),Ekl(3),Rijk(3),Eijk(3),dBt(3,nCent,3,nCent),& + & BRij(3,2),dBRij(3,2,3,2),BRjk(3,2),dBRjk(3,2,3,2),& + & BRkl(3,2),dBRkl(3,2,3,2),Bf2(3,3),dum(3,4,3,4),& + & Bf3(3,3) + Logical :: lWrite,lWarn,ldB + Character(len=8) :: Label + ! + ! Call qEnter('Trsn') + mCent = 2 + Call Strtch(xyz(1,1),mCent,Rij1,BRij,.False.,Label,dBRij,ldB) + Call Strtch(xyz(1,2),mCent,Rjk1,BRjk,.False.,Label,dBRjk,ldB) + Call Strtch(xyz(1,3),mCent,Rkl1,BRkl,.False.,Label,dBRkl,ldB) + mCent = 3 + Call Bend(xyz(1,1),mCent,Fi2,Bf2,.False.,.False.,Label,Dum,& + & .False.) + SinFi2 = Sin(Fi2) + CosFi2 = Cos(Fi2) + Call Bend(xyz(1,2),mCent,Fi3,Bf3,.False.,.False.,Label,Dum,& + & .False.) + SinFi3 = Sin(Fi3) + CosFi3 = Cos(Fi3) + ! + ! Get the angle between the two planes, i.e. the + ! angle between the normal vectors. + ! + ! r123 * r234 = CosTau + ! + CosTau = ((BRij(2,1)*BRjk(3,2)-BRij(3,1)*BRjk(2,2))*& + & (BRjk(2,1)*BRkl(3,2)-BRjk(3,1)*BRkl(2,2))+& + & (BRij(3,1)*BRjk(1,2)-BRij(1,1)*BRjk(3,2))*& + & (BRjk(3,1)*BRkl(1,2)-BRjk(1,1)*BRkl(3,2))+& + & (BRij(1,1)*BRjk(2,2)-BRij(2,1)*BRjk(1,2))*& + & (BRjk(1,1)*BRkl(2,2)-BRjk(2,1)*BRkl(1,2)))& + & /(SinFi2*SinFi3) + ! + ! For the vector product of the two vectors. This + ! will give a vector parallell to e23. The direction + ! relative to e23 defines the sign. + ! + ! e123 X e234 = SinTau * e23 + ! + SinTau = (BRij(1,2)*(BRjk(2,1)*BRkl(3,2)-BRjk(3,1)*BRkl(2,2))& + & +BRij(2,2)*(BRjk(3,1)*BRkl(1,2)-BRjk(1,1)*BRkl(3,2))& + & +BRij(3,2)*(BRjk(1,1)*BRkl(2,2)-BRjk(2,1)*BRkl(1,2)))& + & /(SinFi2*SinFi3) + ! + ! (-Pi < Tau <= Pi) + ! + Tau = ATan2(SinTau,CosTau) + If (Abs(Tau) .eq. Pi) Tau = Pi + ! + dTau = 180.0D+00*Tau/Pi + dFi2 = 180.0D+00*Fi2/Pi + dFi3 = 180.0D+00*Fi3/Pi + If (lWarn) Then + If (dTau .gt. 177.5.or.dTau .lt. -177.5) Then + Write (*,*) ' Warning: dihedral angle close to'& + & //' end of range' + End If + If (dFi2 .gt. 177.5.or.dFi2 .lt. 2.5) Then + Write (*,*) ' Warning: bond angle close to'& + & //' end of range' + End If + If (dFi3 .gt. 177.5.or.dFi3 .lt. 2.5) Then + Write (*,*) ' Warning: bond angle close to'& + & //' end of range' + End If + End If + If (LWRITE) Write (*,1) Label,dTau,Tau +1 FORMAT(1X,A,' : Dihedral Angle=',F10.4,& + & '/degree,',F10.4,'/rad') + ! + !---- Compute the WDC matrix. + ! + Do ix = 1,3 + iy = ix+1 + If (iy .gt. 3) iy = iy-3 + iz = iy+1 + If (iz .gt. 3) iz = iz-3 + Bt(ix,1) = (BRij(iy,2)*BRjk(iz,2)-BRij(iz,2)*BRjk(iy,2))& + & /(Rij1*SinFi2**2) + Bt(ix,4) = (BRkl(iy,1)*BRjk(iz,1)-BRkl(iz,1)*BRjk(iy,1))& + & /(Rkl1*SinFi3**2) + Bt(ix,2) = -((Rjk1-Rij1*CosFi2)*Bt(ix,1)& + & +Rkl1*CosFi3*Bt(ix,4))/Rjk1 + Bt(ix,3) = -(Bt(ix,1)+Bt(ix,2)+Bt(ix,4)) + End Do + ! + If (ldB) Then + ! + !------- Compute the derivative of the WDC matrix. + ! + Do ix = 1,3 + iy = ix+1 + If (iy .gt. 3) iy = iy-3 + iz = iy+1 + If (iz .gt. 3) iz = iz-3 + Do jx = 1,ix + jy = jx+1 + If (jy .gt. 3) jy = jy-3 + jz = jy+1 + If (jz .gt. 3) jz = jz-3 + ! + dBt(ix,1,jx,1) = (dBRij(ix,1,jy,2)*BRjk(jz,2)& + & -dBRij(ix,1,jz,2)*BRjk(jy,2)& + & -Bt(jx,1)*(BRij(ix,1)*SinFi2**2& + & +Rij1*Two*SinFi2*CosFi2*Bf2(ix,1)))& + & /(Rij1*SinFi2**2) + dBt(ix,1,jx,2) = -((-BRij(ix,1)*CosFi2& + & +Rij1*SinFi2*Bf2(ix,1))*Bt(jx,1)& + & +(Rjk1-Rij1*CosFi2)*dBt(ix,1,jx,1))& + & /Rjk1 + dBt(jx,2,ix,1) = dBt(ix,1,jx,2) + dBt(ix,1,jx,4) = Zero + dBt(jx,4,ix,1) = dBt(ix,1,jx,4) + dBt(ix,1,jx,3) = -(dBt(ix,1,jx,1)+dBt(ix,1,jx,2)) + dBt(jx,3,ix,1) = dBt(ix,1,jx,3) + dBt(ix,4,jx,4) = (dBRkl(ix,2,jy,1)*BRjk(jz,1)& + & -dBRkl(ix,2,jz,1)*BRjk(jy,1)& + & -Bt(jx,4)*(BRkl(ix,2)*SinFi3**2& + & +Rkl1*Two*SinFi3*CosFi3*Bf3(ix,3)))& + & /(Rkl1*SinFi3**2) + dBt(ix,4,jx,3) = -((-BRkl(ix,2)*CosFi3& + & +Rkl1*SinFi3*Bf3(ix,3))*Bt(jx,4)& + & +(Rjk1-Rkl1*CosFi3)*dBt(ix,4,jx,4))& + & /Rjk1 + dBt(jx,3,ix,4) = dBt(ix,4,jx,3) + dBt(ix,4,jx,2) = -(dBt(ix,4,jx,4)+dBt(ix,4,jx,3)) + dBt(jx,2,ix,4) = dBt(ix,4,jx,2) + If (ix .ne. jx) Then + dBt(jx,1,ix,1) = dBt(ix,1,jx,1) + dBt(ix,4,jx,1) = Zero + dBt(jx,4,ix,4) = dBt(ix,4,jx,4) + dBt(jx,1,ix,4) = dBt(ix,4,jx,1) + dBt(jx,1,ix,2) = -((-BRij(jx,1)*CosFi2& + & +Rij1*SinFi2*Bf2(jx,1))*Bt(ix,1)& + & +(Rjk1-Rij1*CosFi2)*dBt(jx,1,ix,1))& + & /Rjk1 + dBt(ix,2,jx,1) = dBt(jx,1,ix,2) + dBt(ix,3,jx,1) = -(dBt(ix,1,jx,1)+dBt(ix,2,jx,1)& + & +dBt(ix,4,jx,1)) + dBt(jx,1,ix,3) = dBt(ix,3,jx,1) + dBt(jx,4,ix,3) = -((-BRkl(jx,2)*CosFi3& + & +Rkl1*SinFi3*Bf3(jx,3))*Bt(ix,4)& + & +(Rjk1-Rkl1*CosFi3)*dBt(jx,4,ix,4))& + & /Rjk1 + dBt(ix,3,jx,4) = dBt(jx,4,ix,3) + dBt(ix,2,jx,4) = -(dBt(ix,4,jx,4)+dBt(ix,3,jx,4)) + dBt(jx,4,ix,2) = dBt(ix,2,jx,4) + End If + dBt(ix,2,jx,3) = -((BRjk(ix,1)& + & +Rkl1*SinFi3*Bf3(ix,1))*Bt(jx,4)& + & +(Rjk1-Rkl1*CosFi3)*dBt(ix,2,jx,4)& + & +(BRij(ix,2)*CosFi2& + & -Rij1*SinFi2*Bf2(ix,2))*Bt(jx,1)& + & +Rij1*CosFi2*dBt(ix,2,jx,1)& + & +Bt(jx,3)*BRjk(ix,1))/Rjk1 + dBt(jx,3,ix,2) = dBt(ix,2,jx,3) + dBt(ix,2,jx,2) = -(dBt(ix,2,jx,1)+dBt(ix,2,jx,4)& + & +dBt(ix,2,jx,3)) + dBt(ix,3,jx,3) = -(dBt(ix,2,jx,3)+dBt(ix,1,jx,3)& + & +dBt(ix,4,jx,3)) + If (ix .ne. jx) Then + dBt(ix,3,jx,2) = -(dBt(ix,2,jx,2)+dBt(ix,1,jx,2)& + & +dBt(ix,4,jx,2)) + dBt(jx,2,ix,3) = dBt(ix,3,jx,2) + dBt(jx,2,ix,2) = dBt(ix,2,jx,2) + dBt(jx,3,ix,3) = dBt(ix,3,jx,3) + End If + ! + End Do + End Do + ! + End If + ! Call qExit('Trsn') + Return + contains + Subroutine Strtch(xyz,nCent,Avst,B,lWrite,Label,dB,ldB) + Implicit Real(wp) (a-h,o-z) + ! include "common/real.inc" + !comdeck real.inc $Revision: 2002.3 $ + Real(wp) :: Zero,One,Two,Three,Four,Five,Six,Seven,& + & Eight,RNine,Ten,Half,Pi,SqrtP2,TwoP34,& + & TwoP54,One2C2 + Parameter(Zero=0.0D0,One=1.0D0,Two=2.0D0,Three=3.0D0,& + & Four=4.0D0,Five=5.0D0,Six=6.0D0,Seven=7.0D0,& + & Eight=8.0D0,rNine=9.0D0,Ten=1.0D1,Half=0.5D0,& + & Pi=3.141592653589793D0,& + & SqrtP2=0.8862269254527579D0,& + & TwoP34=0.2519794355383808D0,& + & TwoP54=5.914967172795612D0,& + & One2C2=0.2662567690426443D-04) + + integer :: nCent + Real(wp) :: B(3,nCent),xyz(3,nCent),dB(3,nCent,3,nCent),R(3) + Logical :: lWrite,ldB + Character(len=8) :: Label + ! include "common/angstr.inc" + !comdeck angstr.inc $Revision: 2002.3 $ + ! + ! Conversion factor angstrom to bohr from the IUPAC + ! publication + ! .529177249(24) angstrom / bohr + ! "Quantities, Units and Symbols in Physical Chemistry" + ! I. Mills, T. Cvitas, K. Homann, N. Kallay and + ! K. Kuchitsu, Blackwell Scientific Publications, + ! Oxford, 1988. + ! + Data Angstr/0.529177249D+00/ + ! + R(1) = xyz(1,2)-xyz(1,1) + R(2) = xyz(2,2)-xyz(2,1) + R(3) = xyz(3,2)-xyz(3,1) + R2 = R(1)**2+R(2)**2+R(3)**2 + RR = Sqrt(R2) + Avst = RR + ! + aRR = RR*Angstr + If (lWrite) Write (*,'(1X,A,A,2(F10.6,A))') Label,& + & ' : Bond Length=',aRR,' / Angstrom',RR,' / bohr' + ! + !---- Compute the WDC B-matrix. + ! + B(1,1) = -R(1)/RR + B(2,1) = -R(2)/RR + B(3,1) = -R(3)/RR + !.... Utilize translational invariance. + B(1,2) = -B(1,1) + B(2,2) = -B(2,1) + B(3,2) = -B(3,1) + ! + !---- Compute the cartesian derivative of the B-matrix. + ! + If (ldB) Then + ! + Do i = 1,3 + Do j = 1,i + If (i .eq. j) Then + dB(i,1,j,1) = (One-B(j,1)*B(i,1))/RR + Else + dB(i,1,j,1) = (-B(j,1)*B(i,1))/RR + End If + dB(j,1,i,1) = dB(i,1,j,1) + ! + dB(i,2,j,1) = -dB(i,1,j,1) + dB(j,1,i,2) = dB(i,2,j,1) + ! + dB(i,1,j,2) = -dB(i,1,j,1) + dB(j,2,i,1) = dB(i,1,j,2) + ! + dB(i,2,j,2) = -dB(i,2,j,1) + dB(j,2,i,2) = dB(i,2,j,2) + End Do + End Do + ! + End If + ! Call qExit('Strtch') + ! Call GetMem('Exit Strtch','Chec','Real',ipMass,2*msAtom) + Return + End subroutine strtch + Subroutine Bend(xyz,nCent,Fir,Bf,lWrite,lWarn,Label,dBf,ldB) + Implicit Real(wp) (a-h,o-z) + + integer :: nCent + !Real(wp) :: Bf(3,nCent),xyz(3,nCent),dBf(3,nCent,3,nCent),& + Real(wp) :: Bf(3,3),xyz(3,nCent),dBf(3,nCent,3,nCent),& + & BRij(3,2),dBRij(3,2,3,2),& + & BRjk(3,2),dBRjk(3,2,3,2) + Logical lWrite,ldB,lWarn + Character(len=8) :: Label + ! + ! Call QEnter('Bend') + ! + mCent = 2 + Call Strtch(xyz(1,1),mCent,Rij1,BRij,.False.,Label,dBRij,ldB) + Call Strtch(xyz(1,2),mCent,Rjk1,BRjk,.False.,Label,dBRjk,ldB) + Co = Zero + Crap = Zero + Do i = 1,3 + Co = Co+BRij(i,1)*BRjk(i,2) + Crap = Crap+(BRjk(i,2)+BRij(i,1))**2 + End Do + ! + !.... Special care for cases close to linearity + ! + If (Sqrt(Crap) .lt. 1.0D-6) Then + Fir = Pi-ArSin(Sqrt(Crap)) + Si = Sqrt(Crap) + Else + Fir = ArCos(Co) + Si = Sqrt(One-Co**2) + End If + ! + If (Abs(Fir-Pi) .lt. 1.0d-13) Then + Fir = Pi + Return + End If + dFir = 180.0D0*Fir/Pi + If ((Abs(dFir) .gt. 177.5.or.Abs(dFir) .lt. 2.5).and.lWarn)& + & Write (*,*) ' Valence angle close to end in '//& + & 'range of definition' + If (lWrite) Write (*,'(1X,A,A,F10.4,A,F10.6,A)') Label,& + & ' : Angle=',dFir,'/degree, ',Fir,'/rad' + ! + !---- Compute the WDC B-matrix + ! + ! Bf=-11.1111 + Do i = 1,3 + Bf(i,1) = (Co*BRij(i,1)-BRjk(i,2))/(Si*Rij1) + Bf(i,3) = (Co*BRjk(i,2)-BRij(i,1))/(Si*Rjk1) + !....... Utilize translational invariance. + Bf(i,2) = -(Bf(i,1)+Bf(i,3)) + End Do + ! Call RecPrt('Bf',' ',Bf,9,1) + ! + !---- Compute the cartesian derivative of the B-Matrix. + ! + If (ldB) Then + ! + ! dBf=-11.11111 + Do i = 1,3 + Do j = 1,i + dBf(i,1,j,1) = (-Si*Bf(i,1)*BRij(j,1)& + & +Co*dBRij(i,1,j,1)& + & -Bf(j,1)*(Co*Bf(i,1)*Rij1& + & +Si*BRij(i,1)))/(Si*Rij1) + dBf(i,1,j,3) = (-Si*Bf(i,1)*BRjk(j,2)& + & +dBRij(i,1,j,2)& + & -Bf(j,3)*Co*Bf(i,1)*Rjk1)& + & /(Si*Rjk1) + ! Write (*,*) '13',dBf(i,1,j,3), i, j + dBf(i,3,j,1) = (-Si*Bf(i,3)*BRij(j,1)& + & +dBRjk(i,2,j,1)& + & -Bf(j,1)*Co*Bf(i,3)*Rij1)& + & /(Si*Rij1) + dBf(i,3,j,3) = (-Si*Bf(i,3)*BRjk(j,2)& + & +Co*dBRjk(i,2,j,2)& + & -Bf(j,3)*(Co*Bf(i,3)*Rjk1& + & +Si*BRjk(i,2)))/(Si*Rjk1) + ! + dBf(j,1,i,1) = dBf(i,1,j,1) + dBf(j,3,i,1) = dBf(i,1,j,3) + dBf(j,1,i,3) = dBf(i,3,j,1) + dBf(j,3,i,3) = dBf(i,3,j,3) + ! + dBf(i,1,j,2) = -(dBf(i,1,j,1)+dBf(i,1,j,3)) + dBf(j,2,i,1) = dBf(i,1,j,2) + dBf(j,1,i,2) = -(dBf(j,1,i,1)+dBf(j,1,i,3)) + dBf(i,2,j,1) = dBf(j,1,i,2) + dBf(i,3,j,2) = -(dBf(i,3,j,1)+dBf(i,3,j,3)) + dBf(j,2,i,3) = dBf(i,3,j,2) + dBf(j,3,i,2) = -(dBf(j,3,i,1)+dBf(j,3,i,3)) + dBf(i,2,j,3) = dBf(j,3,i,2) + ! + dBf(i,2,j,2) = -(dBf(i,2,j,1)+dBf(i,2,j,3)) + dBf(j,2,i,2) = dBf(i,2,j,2) + ! + End Do + End Do + ! Call RecPrt('dBf','(9F9.1)',dBf,9,9) + ! + End If + ! + ! Call QExit('Bend') + Return + End subroutine bend + Function arSin(Arg) + Implicit Real*8(a-h,o-z) + Real*8 ArSin + + A = Arg + IF (ABS(A) .GT. One) Then + PRINT 3,A +3 FORMAT(1X,'Warning argument of aSin= ',1F21.18) + A = Sign(One,A) + End If + ! + ArSin = ASin(A) + Return + End function arSin + Function arCos(Arg) + Implicit Real(wp) (a-h,o-z) + Real(wp) :: ArCos + A = Arg + IF (ABS(A) .GT. One) Then + A = Sign(One,A) + End If + ArCos = ACos(A) + Return + End function arCos + End subroutine trsn + + pure elemental function ixyz(i,iatom) + integer :: ixyz + integer,intent(in) :: i,iatom + ixyz = (iatom-1)*3+i + end function ixyz + pure elemental function jnd(i,j) + integer :: jnd + integer,intent(in) :: i,j + jnd = i*(i-1)/2+j + end function jnd + pure elemental function ind(i,iatom,j,jatom) + integer :: ind + integer,intent(in) :: i,iatom,j,jatom + ind = jnd(max(ixyz(i,iatom),ixyz(j,jatom)),min(ixyz(i,iatom),ixyz(j,jatom))) + end function ind + + pure elemental function fk_lindh(alpha,r0,r2) result(gmm) + implicit none + real(wp),intent(in) :: alpha,r0,r2 + real(wp) :: gmm + gmm = exp(alpha*(r0**2-r2)) + end function fk_lindh + + pure elemental function fk_swart(alpha,r0,r2) result(gmm) + implicit none + real(wp),intent(in) :: alpha,r0,r2 + real(wp) :: gmm + gmm = exp(-alpha*(sqrt(r2)/r0-1.0_wp)) + end function fk_swart + + pure elemental function fk_vdw(alpha,r0,r2) result(gmm) + implicit none + real(wp),intent(in) :: alpha,r0,r2 + real(wp) :: gmm + gmm = exp(-alpha*(r0-sqrt(r2))**2) + end function fk_vdw + +!========================================================================================! +!########################################################################################! +!========================================================================================! + + subroutine mh_eeq(n,at,xyz,chrg,kq,hess) + implicit none + +!! ------------------------------------------------------------------------ +! Input +!! ------------------------------------------------------------------------ + integer,intent(in) :: n ! number of atoms + integer,intent(in) :: at(n) ! ordinal numbers + real(wp),intent(in) :: xyz(3,n) ! geometry + real(wp),intent(in) :: chrg ! total charge + real(wp),intent(in) :: kq ! scaling parameter +! type(chrg_parameter),intent(in) :: chrgeq ! charge model +!! ------------------------------------------------------------------------ +! Output +!! ------------------------------------------------------------------------ + real(wp),intent(out) :: hess((3*n)*(3*n+1)/2) + real(wp),allocatable :: hessian(:,:,:,:) ! molecular hessian of IES + +! π itself + real(wp),parameter :: pi = 3.1415926535897932384626433832795029_wp +! √π + real(wp),parameter :: sqrtpi = sqrt(pi) +! √(2/π) + real(wp),parameter :: sqrt2pi = sqrt(2.0_wp/pi) +! +!! ------------------------------------------------------------------------ +! charge model +!! ------------------------------------------------------------------------ + integer :: m ! dimension of the Lagrangian + real(wp),allocatable :: Amat(:,:) + real(wp),allocatable :: Xvec(:) + real(wp),allocatable :: Ainv(:,:) + real(wp),allocatable :: dAmat(:,:,:) + real(wp),allocatable :: dqdr(:,:,:) + +!! ------------------------------------------------------------------------ +! local variables +!! ------------------------------------------------------------------------ + integer :: i,j,k,l + real(wp) :: r,rij(3),r2 + real(wp) :: gamij,gamij2 + real(wp) :: arg,arg2,tmp,dtmp + real(wp) :: lambda + real(wp) :: es,expterm,erfterm + real(wp) :: htmp,rxr(3,3) + real(wp) :: rcovij,rr + +!! ------------------------------------------------------------------------ +! scratch variables +!! ------------------------------------------------------------------------ + real(wp),allocatable :: alpha(:) + real(wp),allocatable :: xtmp(:) + real(wp),allocatable :: atmp(:,:) + +!! ------------------------------------------------------------------------ +! Lapack work variables +!! ------------------------------------------------------------------------ + integer,allocatable :: ipiv(:) + real(wp),allocatable :: temp(:) + real(wp),allocatable :: work(:) + integer :: lwork + integer :: info + real(wp) :: test(1) + +!! ------------------------------------------------------------------------ +! EEQ parameters +! PARAMETRISATION BY S. SPICHER (Fri, 14 Dec 2018 16:13:08 +0100) +!! ------------------------------------------------------------------------ + integer,parameter :: max_elem = 86 +!&< + real(wp),parameter :: enparam(max_elem) = (/ & + 1.23695041_wp, 1.26590957_wp, 0.54341808_wp, 0.99666991_wp, 1.26691604_wp, & + 1.40028282_wp, 1.55819364_wp, 1.56866440_wp, 1.57540015_wp, 1.15056627_wp, & + 0.55936220_wp, 0.72373742_wp, 1.12910844_wp, 1.12306840_wp, 1.52672442_wp, & + 1.40768172_wp, 1.48154584_wp, 1.31062963_wp, 0.40374140_wp, 0.75442607_wp, & + 0.76482096_wp, 0.98457281_wp, 0.96702598_wp, 1.05266584_wp, 0.93274875_wp, & + 1.04025281_wp, 0.92738624_wp, 1.07419210_wp, 1.07900668_wp, 1.04712861_wp, & + 1.15018618_wp, 1.15388455_wp, 1.36313743_wp, 1.36485106_wp, 1.39801837_wp, & + 1.18695346_wp, 0.36273870_wp, 0.58797255_wp, 0.71961946_wp, 0.96158233_wp, & + 0.89585296_wp, 0.81360499_wp, 1.00794665_wp, 0.92613682_wp, 1.09152285_wp, & + 1.14907070_wp, 1.13508911_wp, 1.08853785_wp, 1.11005982_wp, 1.12452195_wp, & + 1.21642129_wp, 1.36507125_wp, 1.40340000_wp, 1.16653482_wp, 0.34125098_wp, & + 0.58884173_wp, 0.68441115_wp, 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, & + 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, & + 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, & + 0.56999999_wp, 0.87936784_wp, 1.02761808_wp, 0.93297476_wp, 1.10172128_wp, & + 0.97350071_wp, 1.16695666_wp, 1.23997927_wp, 1.18464453_wp, 1.14191734_wp, & + 1.12334192_wp, 1.01485321_wp, 1.12950808_wp, 1.30804834_wp, 1.33689961_wp, & + 1.27465977_wp /) + real(wp),parameter :: gamparam(max_elem) = (/ & + -0.35015861_wp, 1.04121227_wp, 0.09281243_wp, 0.09412380_wp, 0.26629137_wp, & + 0.19408787_wp, 0.05317918_wp, 0.03151644_wp, 0.32275132_wp, 1.30996037_wp, & + 0.24206510_wp, 0.04147733_wp, 0.11634126_wp, 0.13155266_wp, 0.15350650_wp, & + 0.15250997_wp, 0.17523529_wp, 0.28774450_wp, 0.42937314_wp, 0.01896455_wp, & + 0.07179178_wp,-0.01121381_wp,-0.03093370_wp, 0.02716319_wp,-0.01843812_wp, & + -0.15270393_wp,-0.09192645_wp,-0.13418723_wp,-0.09861139_wp, 0.18338109_wp, & + 0.08299615_wp, 0.11370033_wp, 0.19005278_wp, 0.10980677_wp, 0.12327841_wp, & + 0.25345554_wp, 0.58615231_wp, 0.16093861_wp, 0.04548530_wp,-0.02478645_wp, & + 0.01909943_wp, 0.01402541_wp,-0.03595279_wp, 0.01137752_wp,-0.03697213_wp, & + 0.08009416_wp, 0.02274892_wp, 0.12801822_wp,-0.02078702_wp, 0.05284319_wp, & + 0.07581190_wp, 0.09663758_wp, 0.09547417_wp, 0.07803344_wp, 0.64913257_wp, & + 0.15348654_wp, 0.05054344_wp, 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, & + 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, & + 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, & + 0.11000000_wp,-0.02786741_wp, 0.01057858_wp,-0.03892226_wp,-0.04574364_wp, & + -0.03874080_wp,-0.03782372_wp,-0.07046855_wp, 0.09546597_wp, 0.21953269_wp, & + 0.02522348_wp, 0.15263050_wp, 0.08042611_wp, 0.01878626_wp, 0.08715453_wp, & + 0.10500484_wp /) + real(wp),parameter :: kappa(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, & + 0.07126660_wp, 0.13682750_wp, 0.14877121_wp,-0.10219289_wp,-0.08979338_wp, & + -0.08273597_wp,-0.01754829_wp,-0.02765460_wp,-0.02558926_wp,-0.08010286_wp, & + -0.04163215_wp,-0.09369631_wp,-0.03774117_wp,-0.05759708_wp, 0.02431998_wp, & + -0.01056270_wp,-0.02692862_wp, 0.07657769_wp, 0.06561608_wp, 0.08006749_wp, & + 0.14139200_wp,-0.05351029_wp,-0.06701705_wp,-0.07377246_wp,-0.02927768_wp, & + -0.03867291_wp,-0.06929825_wp,-0.04485293_wp,-0.04800824_wp,-0.01484022_wp, & + 0.07917502_wp, 0.06619243_wp, 0.02434095_wp,-0.01505548_wp,-0.03030768_wp, & + 0.01418235_wp, 0.08953411_wp, 0.08967527_wp, 0.07277771_wp,-0.02129476_wp, & + -0.06188828_wp,-0.06568203_wp,-0.11000000_wp,-0.11000000_wp,-0.11000000_wp, & + -0.11000000_wp,-0.11000000_wp,-0.11000000_wp,-0.11000000_wp,-0.11000000_wp, & + -0.11000000_wp,-0.11000000_wp,-0.11000000_wp,-0.11000000_wp,-0.11000000_wp, & + -0.11000000_wp,-0.03585873_wp,-0.03132400_wp,-0.05902379_wp,-0.02827592_wp, & + -0.07606260_wp,-0.02123839_wp, 0.03814822_wp, 0.02146834_wp, 0.01580538_wp, & + -0.00894298_wp,-0.05864876_wp,-0.01817842_wp, 0.07721851_wp, 0.07936083_wp, & + 0.05849285_wp /) + real(wp),parameter :: alphaparam(max_elem) = (/ & + 0.55159092_wp, 0.66205886_wp, 0.90529132_wp, 1.51710827_wp, 2.86070364_wp, & + 1.88862966_wp, 1.32250290_wp, 1.23166285_wp, 1.77503721_wp, 1.11955204_wp, & + 1.28263182_wp, 1.22344336_wp, 1.70936266_wp, 1.54075036_wp, 1.38200579_wp, & + 2.18849322_wp, 1.36779065_wp, 1.27039703_wp, 1.64466502_wp, 1.58859404_wp, & + 1.65357953_wp, 1.50021521_wp, 1.30104175_wp, 1.46301827_wp, 1.32928147_wp, & + 1.02766713_wp, 1.02291377_wp, 0.94343886_wp, 1.14881311_wp, 1.47080755_wp, & + 1.76901636_wp, 1.98724061_wp, 2.41244711_wp, 2.26739524_wp, 2.95378999_wp, & + 1.20807752_wp, 1.65941046_wp, 1.62733880_wp, 1.61344972_wp, 1.63220728_wp, & + 1.60899928_wp, 1.43501286_wp, 1.54559205_wp, 1.32663678_wp, 1.37644152_wp, & + 1.36051851_wp, 1.23395526_wp, 1.65734544_wp, 1.53895240_wp, 1.97542736_wp, & + 1.97636542_wp, 2.05432381_wp, 3.80138135_wp, 1.43893803_wp, 1.75505957_wp, & + 1.59815118_wp, 1.76401732_wp, 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, & + 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, & + 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, & + 1.63999999_wp, 1.47055223_wp, 1.81127084_wp, 1.40189963_wp, 1.54015481_wp, & + 1.33721475_wp, 1.57165422_wp, 1.04815857_wp, 1.78342098_wp, 2.79106396_wp, & + 1.78160840_wp, 2.47588882_wp, 2.37670734_wp, 1.76613217_wp, 2.66172302_wp, & + 2.82773085_wp /) +!&> + +!! ------------------------------------------------------------------------ +! initizialization +!! ------------------------------------------------------------------------ + m = n+1 + allocate (ipiv(m),source=0) + allocate (Amat(m,m),Xvec(m),alpha(n),dqdr(3,n,m),source=0.0_wp) + +!! ------------------------------------------------------------------------ +! set up the A matrix and X vector +!! ------------------------------------------------------------------------ +! αi -> alpha(i), ENi -> xi(i), κi -> kappa(i), Jii -> gam(i) +! γij = 1/√(αi+αj) +! Xi = -ENi + κi·√CNi +! Aii = Jii + 2/√π·γii +! Aij = erf(γij·Rij)/Rij = 2/√π·F0(γ²ij·R²ij) +!! ------------------------------------------------------------------------ +! prepare some arrays +!$omp parallel default(none) & +!!$omp shared(n,at,chrgeq) & +!$omp shared(n,at) & +!$omp private(i) & +!$omp shared(Xvec,alpha) +!$omp do schedule(dynamic) + do i = 1,n +! Xvec(i) = -chrgeq%en(i) +! alpha(i) = chrgeq%alpha(i)**2 + Xvec(i) = -enparam(at(i)) + alpha(i) = alphaparam(at(i))**2 + end do +!$omp enddo +!$omp endparallel + +!$omp parallel default(none) & +!!$omp shared(n,at,xyz,chrgeq,alpha) & +!$omp shared(n,at,xyz,alpha) & +!$omp private(i,j,r,gamij) & +!$omp shared(Amat) +!$omp do schedule(dynamic) + ! prepare A matrix + do i = 1,n + ! EN of atom i + do j = 1,i-1 + r = sqrt(sum((xyz(:,j)-xyz(:,i))**2)) + gamij = 1.0_wp/sqrt(alpha(i)+alpha(j)) + Amat(j,i) = erf(gamij*r)/r + Amat(i,j) = Amat(j,i) + end do +! Amat(i,i) = chrgeq%gam(i)+sqrt2pi/sqrt(alpha(i)) + Amat(i,i) = gamparam(at(i))+sqrt2pi/sqrt(alpha(i)) + end do +!$omp enddo +!$omp endparallel + +!! ------------------------------------------------------------------------ +! solve the linear equations to obtain partial charges +!! ------------------------------------------------------------------------ + Amat(m,1:m) = 1.0_wp + Amat(1:m,m) = 1.0_wp + Amat(m,m) = 0.0_wp + Xvec(m) = chrg + ! generate temporary copy + allocate (Atmp(m,m),source=Amat) + allocate (Xtmp(m),source=Xvec) + + ! assume work space query, set best value to test after first dsysv call + call dsysv('u',m,1,Atmp,m,ipiv,Xtmp,m,test,-1,info) + lwork = int(test(1)) + allocate (work(lwork),source=0.0_wp) + + call dsysv('u',m,1,Atmp,m,ipiv,Xtmp,m,work,lwork,info) + if (info > 0) error stop '** ERROR ** (goedecker_solve) DSYSV failed' + + if (abs(sum(Xtmp(:n))-chrg) > 1.e-6_wp) & + error stop '** ERROR ** (goedecker_solve) charge constrain error' + !print'(3f20.14)',Xtmp + +!! ------------------------------------------------------------------------ +! calculate isotropic electrostatic (IES) energy +!! ------------------------------------------------------------------------ +! E = ∑i (ENi - κi·√CNi)·qi + ∑i (Jii + 2/√π·γii)·q²i +! + ½ ∑i ∑j,j≠i qi·qj·2/√π·F0(γ²ij·R²ij) +! = q·(½A·q - X) +!! ------------------------------------------------------------------------ +! work(:m) = Xvec +! call dsymv('u',m,0.5_wp,Amat,m,Xtmp,1,-1.0_wp,work,1) +! es = dot_product(Xtmp,work(:m)) +! energy = es + energy + +!! ------------------------------------------------------------------------ +! calculate molecular gradient of the IES energy +!! ------------------------------------------------------------------------ +! dE/dRj -> g(:,j), ∂Xi/∂Rj -> -dcn(:,i,j), ½∂Aij/∂Rj -> dAmat(:,j,i) +! dE/dR = (½∂A/∂R·q - ∂X/∂R)·q +! ∂Aij/∂Rj = ∂Aij/∂Ri +!! ------------------------------------------------------------------------ + allocate (dAmat(3,n,m),source=0.0_wp) +!$omp parallel default(none) & +!$omp shared(n,xyz,alpha,Amat,Xtmp) & +!$omp private(i,j,rij,r2,gamij,arg,dtmp) & +!$omp reduction(+:dAmat) +!$omp do schedule(dynamic) + do i = 1,n + do j = 1,i-1 + rij = xyz(:,i)-xyz(:,j) + r2 = sum(rij**2) + gamij = 1.0_wp/sqrt(alpha(i)+alpha(j)) + arg = gamij**2*r2 + dtmp = 2.0_wp*gamij*exp(-arg)/(sqrtpi*r2)-Amat(j,i)/r2 + dAmat(:,i,i) = +dtmp*rij*Xtmp(j)+dAmat(:,i,i) + dAmat(:,j,j) = -dtmp*rij*Xtmp(i)+dAmat(:,j,j) + dAmat(:,i,j) = +dtmp*rij*Xtmp(i) + dAmat(:,j,i) = -dtmp*rij*Xtmp(j) + end do + end do +!$omp enddo +!$omp endparallel + +!! ------------------------------------------------------------------------ +! invert the A matrix using a Bunch-Kaufman factorization +! A⁻¹ = (L·D·L^T)⁻¹ = L^T·D⁻¹·L +!! ------------------------------------------------------------------------ + allocate (Ainv(m,m),source=Amat) + + ! assume work space query, set best value to test after first dsytrf call + call dsytrf('L',m,Ainv,m,ipiv,test,-1,info) + if (int(test(1)) > lwork) then + deallocate (work) + lwork = int(test(1)) + allocate (work(lwork),source=0.0_wp) + end if + + ! Bunch-Kaufman factorization A = L*D*L**T + call dsytrf('L',m,Ainv,m,ipiv,work,lwork,info) + if (info > 0) then + error stop '** ERROR ** (goedecker_inversion) DSYTRF failed' + + end if + + ! A⁻¹ from factorized L matrix, save lower part of A⁻¹ in Ainv matrix + ! Ainv matrix is overwritten with lower triangular part of A⁻¹ + call dsytri('L',m,Ainv,m,ipiv,work,info) + if (info > 0) then + error stop '** ERROR ** (goedecker_inversion) DSYTRI failed' + end if + + ! symmetrizes A⁻¹ matrix from lower triangular part of inverse matrix + do i = 1,m + do j = i+1,m + Ainv(i,j) = Ainv(j,i) + end do + end do + +!! ------------------------------------------------------------------------ +! calculate gradient of the partial charge w.r.t. the nuclear coordinates +!! ------------------------------------------------------------------------ + !call dsymm('r','l',3*n,m,-1.0_wp,Ainv,m,dAmat,3*n,1.0_wp,dqdr,3*n) + call dgemm('n','n',3*n,m,m,-1.0_wp,dAmat,3*n,Ainv,m,1.0_wp,dqdr,3*n) + !print'(/,"analytical gradient")' + !print'(3f20.14)',dqdr(:,:,:n) + +!! ------------------------------------------------------------------------ +! molecular Hessian calculation +!! ------------------------------------------------------------------------ + do i = 1,n + do j = 1,i-1 + rij = xyz(:,j)-xyz(:,i) + r2 = sum(rij**2) + r = sqrt(r2) + gamij = 1.0_wp/sqrt(alpha(i)+alpha(j)) + gamij2 = gamij**2 + arg2 = gamij2*r2 + arg = sqrt(arg2) + erfterm = Xtmp(i)*Xtmp(j)*erf(arg)/r + expterm = Xtmp(i)*Xtmp(j)*2*gamij*exp(-arg2)/sqrtpi + ! ∂²(qAq)/(∂Ri∂Rj): + ! ∂²(qAq)/(∂Xi∂Xi) = (1-3X²ij/R²ij-2γ²ijX²ij) 2γij/√π exp[-γ²ij·R²ij]/R²ij + ! - (R²ij-3X²ij) erf[γij·Rij]/R⁵ij + ! ∂²(qAq)/(∂Xi∂Xj) = (R²ij-3X²ij) erf[γij·Rij]/R⁵ij + ! - (1-3X²ij/R²ij-2γ²ijX²ij) 2γij/√π exp[-γ²ij·R²ij]/R²ij + ! ∂²(qAq)/(∂Xi∂Yi) = 3X²ij erf[γij·Rij]/R⁵ij + ! - (3X²ij/R²ij+2γ²ijX²ij) 2γij/√π exp[-γ²ij·R²ij]/R²ij + ! ∂²(qAq)/(∂Xi∂Yj) = (3X²ij/R²ij+2γ²ijX²ij) 2γij/√π exp[-γ²ij·R²ij]/R²ij + ! - 3X²ij erf[γij·Rij]/R⁵ij + rxr(1,1) = erfterm*(3*rij(1)**2/r2**2-1.0_wp/r2) & + -expterm*(3*rij(1)**2/r2**2+2*gamij2*rij(1)**2/r2-1/r2) + rxr(2,2) = erfterm*(3*rij(2)**2/r2**2-1.0_wp/r2) & + -expterm*(3*rij(2)**2/r2**2+2*gamij2*rij(2)**2/r2-1/r2) + rxr(3,3) = erfterm*(3*rij(3)**2/r2**2-1.0_wp/r2) & + -expterm*(3*rij(3)**2/r2**2+2*gamij2*rij(3)**2/r2-1/r2) + rxr(2,1) = erfterm*3*rij(2)*rij(1)/r2**2 & + -expterm*(3*rij(2)*rij(1)/r2**2+2*gamij2*rij(2)*rij(1)/r2) + rxr(3,1) = erfterm*3*rij(3)*rij(1)/r2**2 & + -expterm*(3*rij(3)*rij(1)/r2**2+2*gamij2*rij(3)*rij(1)/r2) + rxr(3,2) = erfterm*3*rij(3)*rij(2)/r2**2 & + -expterm*(3*rij(3)*rij(2)/r2**2+2*gamij2*rij(3)*rij(2)/r2) + + do k = 1,m + rxr(1,1) = rxr(1,1)+0.5_wp*dqdr(1,i,k)*dAmat(1,j,k) & + +0.5_wp*dqdr(1,j,k)*dAmat(1,i,k) + rxr(2,1) = rxr(2,1)+0.5_wp*dqdr(2,i,k)*dAmat(1,j,k) & + +0.5_wp*dqdr(2,j,k)*dAmat(1,i,k) + rxr(3,1) = rxr(3,1)+0.5_wp*dqdr(3,i,k)*dAmat(1,j,k) & + +0.5_wp*dqdr(3,j,k)*dAmat(1,i,k) + rxr(2,2) = rxr(2,2)+0.5_wp*dqdr(2,i,k)*dAmat(2,j,k) & + +0.5_wp*dqdr(2,j,k)*dAmat(2,i,k) + rxr(3,2) = rxr(3,2)+0.5_wp*dqdr(3,i,k)*dAmat(2,j,k) & + +0.5_wp*dqdr(3,j,k)*dAmat(2,i,k) + rxr(3,3) = rxr(3,3)+0.5_wp*dqdr(3,i,k)*dAmat(3,j,k) & + +0.5_wp*dqdr(3,j,k)*dAmat(3,i,k) + end do + ! symmetrize + rxr(1,2) = rxr(2,1) + rxr(1,3) = rxr(3,1) + rxr(2,3) = rxr(3,2) + + ! save diagonal elements for atom i + hess(ind(1,i,1,i)) = hess(ind(1,i,1,i))+kq*rxr(1,1) + hess(ind(2,i,1,i)) = hess(ind(2,i,1,i))+kq*rxr(2,1) + hess(ind(2,i,2,i)) = hess(ind(2,i,2,i))+kq*rxr(2,2) + hess(ind(3,i,1,i)) = hess(ind(3,i,1,i))+kq*rxr(3,1) + hess(ind(3,i,2,i)) = hess(ind(3,i,2,i))+kq*rxr(3,2) + hess(ind(3,i,3,i)) = hess(ind(3,i,3,i))+kq*rxr(3,3) + ! save elements between atom i and atom j + hess(ind(1,i,1,j)) = hess(ind(1,i,1,j))-kq*rxr(1,1) + hess(ind(1,i,2,j)) = hess(ind(1,i,2,j))-kq*rxr(2,1) + hess(ind(1,i,3,j)) = hess(ind(1,i,3,j))-kq*rxr(3,1) + hess(ind(2,i,1,j)) = hess(ind(2,i,1,j))-kq*rxr(2,1) + hess(ind(2,i,2,j)) = hess(ind(2,i,2,j))-kq*rxr(2,2) + hess(ind(2,i,3,j)) = hess(ind(2,i,3,j))-kq*rxr(3,2) + hess(ind(3,i,1,j)) = hess(ind(3,i,1,j))-kq*rxr(3,1) + hess(ind(3,i,2,j)) = hess(ind(3,i,2,j))-kq*rxr(3,2) + hess(ind(3,i,3,j)) = hess(ind(3,i,3,j))-kq*rxr(3,3) + ! save diagonal elements for atom j + hess(ind(1,j,1,j)) = hess(ind(1,j,1,j))+kq*rxr(1,1) + hess(ind(2,j,1,j)) = hess(ind(2,j,1,j))+kq*rxr(2,1) + hess(ind(2,j,2,j)) = hess(ind(2,j,2,j))+kq*rxr(2,2) + hess(ind(3,j,1,j)) = hess(ind(3,j,1,j))+kq*rxr(3,1) + hess(ind(3,j,2,j)) = hess(ind(3,j,2,j))+kq*rxr(3,2) + hess(ind(3,j,3,j)) = hess(ind(3,j,3,j))+kq*rxr(3,3) + end do + end do + + ! ∂²(qA)/(∂Ri∂q)·∂q/∂Rj + ! hessian = hessian + reshape(matmul(reshape(dqdr,(/3*n,m/)),& + ! transpose(reshape(dAmat,(/3*n,m/)))),(/3,n,3,n/)) + !call dgemm('n','t',3*n,m,3*n,+1.0_wp,dqdr,3*n,dAmat,3*n,1.0_wp,hessian,3*n) + !call dgemm('n','t',3*n,m,3*n,+1.0_wp,dAmat,3*n,dqdr,3*n,1.0_wp,hessian,3*n) + + end subroutine mh_eeq + +!========================================================================================! +!########################################################################################! +!========================================================================================! +end module modelhessian_core diff --git a/src/optimize/modelhessian.f90 b/src/optimize/modelhessian.f90 index bc89bccc..300e0ac9 100644 --- a/src/optimize/modelhessian.f90 +++ b/src/optimize/modelhessian.f90 @@ -22,112 +22,9 @@ module modelhessian_module use iso_fortran_env,only:wp => real64,stdout => output_unit use crest_calculator,only:calcdata,constrhess + use modelhessian_core implicit none -!> a modelhessian type to save settings - type :: mhparam - integer :: model = 0 !> model hessian selection - real(wp) :: s6 = 20.0_wp !> dispersion scaling - real(wp) :: rcut = 70.0_wp !> cutoff parameter - !> force constants - real(wp) :: kr = 0.4000_wp - real(wp) :: kf = 0.1300_wp - real(wp) :: kt = 0.0075_wp - real(wp) :: ko = 0.0000_wp - real(wp) :: kd = 0.0000_wp - real(wp) :: kq = 0.0000_wp - end type mhparam - -!> Parameters & constants - real(wp),parameter :: bohr = 0.52917726_wp - real(wp),parameter :: aatoau = 1.0/bohr - real(wp),parameter :: pi = 3.141592653589793_wp - real(wp),parameter :: Zero = 0.0_wp - real(wp),parameter :: One = 1.0_wp - real(wp),parameter :: Two = 2.0_wp - real(wp),parameter :: Three = 3.0_wp - real(wp),parameter :: Four = 4.0_wp - real(wp),parameter :: Five = 5.0_wp - real(wp),parameter :: Six = 6.0_wp - real(wp),parameter :: Seven = 7.0_wp - real(wp),parameter :: Eight = 8.0_wp - real(wp),parameter :: RNine = 9.0_wp - real(wp),parameter :: Ten = 10.0_wp - real(wp),parameter :: Half = 0.5_wp - real(wp),parameter :: SqrtP2 = 0.8862269254527579_wp - real(wp),parameter :: TwoP34 = 0.2519794355383808_wp - real(wp),parameter :: TwoP54 = 5.914967172795612_wp - real(wp),parameter :: One2C2 = 0.2662567690426443D-04 - - !> van-der-Waals radii used in the D2 model (NOTE: here not in a.u.) - real(wp),parameter :: vander(86) = (/ & - & 0.91_wp,0.92_wp, & ! H, He - & 0.75_wp,1.28_wp,1.35_wp,1.32_wp,1.27_wp,1.22_wp,1.17_wp,1.13_wp, & ! Li-Ne - & 1.04_wp,1.24_wp,1.49_wp,1.56_wp,1.55_wp,1.53_wp,1.49_wp,1.45_wp, & ! Na-Ar - & 1.35_wp,1.34_wp, & ! K, Ca - & 1.42_wp,1.42_wp,1.42_wp,1.42_wp,1.42_wp, & ! Sc-Zn - & 1.42_wp,1.42_wp,1.42_wp,1.42_wp,1.42_wp, & - & 1.50_wp,1.57_wp,1.60_wp,1.61_wp,1.59_wp,1.57_wp, & ! Ga-Kr - & 1.48_wp,1.46_wp, & ! Rb, Sr - & 1.49_wp,1.49_wp,1.49_wp,1.49_wp,1.49_wp, & ! Y-Cd - & 1.49_wp,1.49_wp,1.49_wp,1.49_wp,1.49_wp, & - & 1.52_wp,1.64_wp,1.71_wp,1.72_wp,1.72_wp,1.71_wp, & ! In-Xe - & 2.00_wp,2.00_wp, & - & 2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp, & ! La-Yb - & 2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp, & - & 2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp, & ! Lu-Hg - & 2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp, & - & 2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp,2.00_wp/) ! Tl-Rn - !> C6 coefficients used in the D2 model - real(wp),parameter :: c6(86) = (/ & - & 0.14_wp,0.08_wp, & ! H,He - & 1.61_wp,1.61_wp,3.13_wp,1.75_wp,1.23_wp,0.70_wp,0.75_wp,0.63_wp, & - & 5.71_wp,5.71_wp,10.79_wp,9.23_wp,7.84_wp,5.57_wp,5.07_wp,4.61_wp, & - & 10.80_wp,10.80_wp, & ! K,Ca - & 10.80_wp,10.80_wp,10.80_wp,10.80_wp,10.80_wp, & ! Sc-Zn - & 10.80_wp,10.80_wp,10.80_wp,10.80_wp,10.80_wp, & - & 16.99_wp,17.10_wp,16.37_wp,12.64_wp,12.47_wp,12.01_wp, & ! Ga-Kr - & 24.67_wp,24.67_wp, & ! Rb,Sr - & 24.67_wp,24.67_wp,24.67_wp,24.67_wp,24.67_wp, & ! Y-Cd - & 24.67_wp,24.67_wp,24.67_wp,24.67_wp,24.67_wp, & - & 37.32_wp,38.71_wp,38.44_wp,31.74_wp,31.50_wp,29.99_wp, & ! In-Xe - & 50.00_wp,50.00_wp, & ! Cs,Ba - & 50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp, & ! La-Yb - & 50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp, & - & 50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp, & ! Lu-Hg - & 50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp, & - & 50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp,50.00_wp/) ! Tl-Rn - -!&< - integer, private, parameter :: max_elem = 118 - !> covalent radii (taken from Pyykko and Atsumi, Chem. Eur. J. 15, 2009, - ! 188-197), values for metals decreased by 10 % - real(wp),parameter :: covrad_2009(max_elem) = aatoau * [ & - & 0.32_wp,0.46_wp, & ! H,He - & 1.20_wp,0.94_wp,0.77_wp,0.75_wp,0.71_wp,0.63_wp,0.64_wp,0.67_wp, & ! Li-Ne - & 1.40_wp,1.25_wp,1.13_wp,1.04_wp,1.10_wp,1.02_wp,0.99_wp,0.96_wp, & ! Na-Ar - & 1.76_wp,1.54_wp, & ! K,Ca - & 1.33_wp,1.22_wp,1.21_wp,1.10_wp,1.07_wp, & ! Sc- - & 1.04_wp,1.00_wp,0.99_wp,1.01_wp,1.09_wp, & ! -Zn - & 1.12_wp,1.09_wp,1.15_wp,1.10_wp,1.14_wp,1.17_wp, & ! Ga-Kr - & 1.89_wp,1.67_wp, & ! Rb,Sr - & 1.47_wp,1.39_wp,1.32_wp,1.24_wp,1.15_wp, & ! Y- - & 1.13_wp,1.13_wp,1.08_wp,1.15_wp,1.23_wp, & ! -Cd - & 1.28_wp,1.26_wp,1.26_wp,1.23_wp,1.32_wp,1.31_wp, & ! In-Xe - & 2.09_wp,1.76_wp, & ! Cs,Ba - & 1.62_wp,1.47_wp,1.58_wp,1.57_wp,1.56_wp,1.55_wp,1.51_wp, & ! La-Eu - & 1.52_wp,1.51_wp,1.50_wp,1.49_wp,1.49_wp,1.48_wp,1.53_wp, & ! Gd-Yb - & 1.46_wp,1.37_wp,1.31_wp,1.23_wp,1.18_wp, & ! Lu- - & 1.16_wp,1.11_wp,1.12_wp,1.13_wp,1.32_wp, & ! -Hg - & 1.30_wp,1.30_wp,1.36_wp,1.31_wp,1.38_wp,1.42_wp, & ! Tl-Rn - & 2.01_wp,1.81_wp, & ! Fr,Ra - & 1.67_wp,1.58_wp,1.52_wp,1.53_wp,1.54_wp,1.55_wp,1.49_wp, & ! Ac-Am - & 1.49_wp,1.51_wp,1.51_wp,1.48_wp,1.50_wp,1.56_wp,1.58_wp, & ! Cm-No - & 1.45_wp,1.41_wp,1.34_wp,1.29_wp,1.27_wp, & ! Lr- - & 1.21_wp,1.16_wp,1.15_wp,1.09_wp,1.22_wp, & ! -Cn - & 1.36_wp,1.43_wp,1.46_wp,1.58_wp,1.48_wp,1.57_wp ] ! Nh-Og -!&> - public :: modhes !==============================================================================! @@ -187,3016 +84,6 @@ subroutine modhes(calc,modh,natoms,xyz,at,Hess,pr) return end subroutine modhes -!========================================================================================! -!########################################################################################! -!========================================================================================! - - subroutine ddvopt(Cart,nAtoms,Hess,iANr,mhset) -!*********************************************************** -!* subroutine ddvopt -!* generates a Lindh Model Hessian -!* Chem. Phys. Let. 241(1995) 423-428 -!* -!* Input: -!* Cart - cartesian coordinates -!* nAtoms - number of atoms -!* iANr - atom types as integers -!* mhset - model Hessian parameters -!* -!* Output: -!* Hess - the (packed) model Hessian -!********************************************************** - Implicit Integer(i-n) - Implicit Real(wp) (a-h,o-z) - type(mhparam) :: mhset - - real(wp) :: s6 - real(wp) :: rcut - - Real(wp) :: Cart(3,nAtoms),rij(3),rjk(3),rkl(3), & - & Hess((3*nAtoms)*(3*nAtoms+1)/2),si(3),sj(3),sk(3), & - & sl(3),sm(3),x(2),y(2),z(2), & - & xyz(3,4),C(3,4),Dum(3,4,3,4) - Integer iANr(nAtoms) - -! include "common/ddvdt.inc" (molpro 2002.6) - Real(wp) :: rAV(3,3),aAV(3,3), & - & B_Str(6),A_Bend(2),A_Trsn(2),A_StrH(2), & - & rkr,rkf,A_Str,RF_Const, & - & wthr - - Data rAv/1.3500d+00,2.1000d+00,2.5300d+00, & - & 2.1000d+00,2.8700d+00,3.4000d+00, & - & 2.5300d+00,3.4000d+00,3.4000d+00/ - Data aAv/1.0000d+00,0.3949d+00,0.3949d+00, & - & 0.3949d+00,0.2800d+00,0.2800d+00, & - & 0.3949d+00,0.2800d+00,0.2800d+00/ -!org Data rkr,rkf,rkt/0.4500D+00,0.1500D+00,0.5000D-02/ - Data rkr,rkf,rkt/0.4000D+00,0.1300D+00,0.7500D-02/ - Data A_Str/1.734d0/ - Data B_Str/-.244d0,0.352d0,1.085d0,0.660d0,1.522d0,2.068d0/ - Data A_Bend/0.160d0,0.250d0/ - Data A_Trsn/0.0023d0,0.07d0/ - Data A_StrH/0.3601d0,1.944d0/ - Data RF_Const/1.0D-2/ - Data wthr/0.2/ - -!cc VDWx-Parameters (Grimme) used for vdw-correction of model hessian - real(wp) :: alphavdw,damp,c6k,c6l,c66,vdw(3,3),dr(3) - integer :: kxyz,lxyz -!cc End: VDWx ccccccccccccccccc - - !> BLAS - external :: dcopy - - s6 = mhset%s6 - rcut = mhset%rcut - -! -!------- Statement functions -! -! ixyz(i,iAtom) = (iAtom-1)*3 + i -! Jnd(i,j) = i*(i-1)/2 +j -! Ind(i,iAtom,j,jAtom)=Jnd(Max(ixyz(i,iAtom),ixyz(j,jAtom)), & -! & Min(ixyz(i,iAtom),ixyz(j,jAtom))) -!end - - Fact = One -!hjw threshold reduced - rZero = 1.0d-10 - n3 = 3*nAtoms - Hess = 0.0d0 - -! -! Hessian for tension -! - Do kAtom = 1,nAtoms - kr = iTabRow(iANr(kAtom)) -! If (kr.eq.0) Go To 5 - - Do lAtom = 1,kAtom-1 - lr = iTabRow(iANr(lAtom)) -! If (lr.eq.0) Go To 10 - xkl = Cart(1,kAtom)-Cart(1,lAtom) - ykl = Cart(2,kAtom)-Cart(2,lAtom) - zkl = Cart(3,kAtom)-Cart(3,lAtom) - rkl2 = xkl**2+ykl**2+zkl**2 - r0 = rAv(kr,lr) - alpha = aAv(kr,lr) - -!cccccc VDWx ccccccccccccccccccccccccccccccccc - c6k = c6(iANr(katom)) - c6l = c6(iANr(latom)) - c66 = sqrt(c6k*c6l) - Rv = (vander(iANr(katom))+vander(iANr(latom)))/bohr - - call getvdwxx(xkl,ykl,zkl,c66,s6,Rv,vdw(1,1)) - call getvdwxy(xkl,ykl,zkl,c66,s6,Rv,vdw(1,2)) - call getvdwxy(xkl,zkl,ykl,c66,s6,Rv,vdw(1,3)) - call getvdwxx(ykl,xkl,zkl,c66,s6,Rv,vdw(2,2)) - call getvdwxy(ykl,zkl,xkl,c66,s6,Rv,vdw(2,3)) - call getvdwxx(zkl,xkl,ykl,c66,s6,Rv,vdw(3,3)) -!cccccc Ende VDWx ccccccccccccccccccccccccccccccc - - gamma = rkr*Exp(alpha*r0**2) -! not better: *sqrt(abs(wb(kAtom,lAtom))) - gmm = gamma*Exp(-alpha*rkl2) - Hxx = gmm*xkl*xkl/rkl2-vdw(1,1) - Hxy = gmm*xkl*ykl/rkl2-vdw(1,2) - Hxz = gmm*xkl*zkl/rkl2-vdw(1,3) - Hyy = gmm*ykl*ykl/rkl2-vdw(2,2) - Hyz = gmm*ykl*zkl/rkl2-vdw(2,3) - Hzz = gmm*zkl*zkl/rkl2-vdw(3,3) - -! - Hess(Ind(1,kAtom,1,kAtom)) = Hess(Ind(1,kAtom,1,kAtom))+Hxx - Hess(Ind(2,kAtom,1,kAtom)) = Hess(Ind(2,kAtom,1,kAtom))+Hxy - Hess(Ind(2,kAtom,2,kAtom)) = Hess(Ind(2,kAtom,2,kAtom))+Hyy - Hess(Ind(3,kAtom,1,kAtom)) = Hess(Ind(3,kAtom,1,kAtom))+Hxz - Hess(Ind(3,kAtom,2,kAtom)) = Hess(Ind(3,kAtom,2,kAtom))+Hyz - Hess(Ind(3,kAtom,3,kAtom)) = Hess(Ind(3,kAtom,3,kAtom))+Hzz -! - Hess(Ind(1,kAtom,1,lAtom)) = Hess(Ind(1,kAtom,1,lAtom))-Hxx - Hess(Ind(1,kAtom,2,lAtom)) = Hess(Ind(1,kAtom,2,lAtom))-Hxy - Hess(Ind(1,kAtom,3,lAtom)) = Hess(Ind(1,kAtom,3,lAtom))-Hxz - Hess(Ind(2,kAtom,1,lAtom)) = Hess(Ind(2,kAtom,1,lAtom))-Hxy - Hess(Ind(2,kAtom,2,lAtom)) = Hess(Ind(2,kAtom,2,lAtom))-Hyy - Hess(Ind(2,kAtom,3,lAtom)) = Hess(Ind(2,kAtom,3,lAtom))-Hyz - Hess(Ind(3,kAtom,1,lAtom)) = Hess(Ind(3,kAtom,1,lAtom))-Hxz - Hess(Ind(3,kAtom,2,lAtom)) = Hess(Ind(3,kAtom,2,lAtom))-Hyz - Hess(Ind(3,kAtom,3,lAtom)) = Hess(Ind(3,kAtom,3,lAtom))-Hzz -! - Hess(Ind(1,lAtom,1,lAtom)) = Hess(Ind(1,lAtom,1,lAtom))+Hxx - Hess(Ind(2,lAtom,1,lAtom)) = Hess(Ind(2,lAtom,1,lAtom))+Hxy - Hess(Ind(2,lAtom,2,lAtom)) = Hess(Ind(2,lAtom,2,lAtom))+Hyy - Hess(Ind(3,lAtom,1,lAtom)) = Hess(Ind(3,lAtom,1,lAtom))+Hxz - Hess(Ind(3,lAtom,2,lAtom)) = Hess(Ind(3,lAtom,2,lAtom))+Hyz - Hess(Ind(3,lAtom,3,lAtom)) = Hess(Ind(3,lAtom,3,lAtom))+Hzz -! -10 Continue - End Do - -5 Continue - End Do - -! -! Hessian for bending -! - Do mAtom = 1,nAtoms - mr = iTabRow(iANr(mAtom)) -! If (mr.eq.0) Go To 20 - Do iAtom = 1,nAtoms - If (iAtom .eq. mAtom) Go To 30 - ir = iTabRow(iANr(iAtom)) -! If (ir.eq.0) Go To 30 - if (rcutoff(cart,iatom,matom,rcut)) cycle -! if(wb(iatom,matom).lt.wthr) cycle - Do jAtom = 1,iAtom-1 - If (jAtom .eq. mAtom) Go To 40 - jr = iTabRow(iANr(jAtom)) -! If (jr.eq.0) Go To 40 - if (rcutoff(cart,jatom,iatom,rcut)) cycle - if (rcutoff(cart,jatom,matom,rcut)) cycle -! if(wb(jatom,iatom).lt.wthr) cycle -! if(wb(jatom,matom).lt.wthr) cycle - - xmi = (Cart(1,iAtom)-Cart(1,mAtom)) - ymi = (Cart(2,iAtom)-Cart(2,mAtom)) - zmi = (Cart(3,iAtom)-Cart(3,mAtom)) - rmi2 = xmi**2+ymi**2+zmi**2 - rmi = sqrt(rmi2) - r0mi = rAv(mr,ir) - ami = aAv(mr,ir) -! - xmj = (Cart(1,jAtom)-Cart(1,mAtom)) - ymj = (Cart(2,jAtom)-Cart(2,mAtom)) - zmj = (Cart(3,jAtom)-Cart(3,mAtom)) - rmj2 = xmj**2+ymj**2+zmj**2 - rmj = sqrt(rmj2) - r0mj = rAv(mr,jr) - amj = aAv(mr,jr) -! -!---------- Test if zero angle -! - Test = xmi*xmj+ymi*ymj+zmi*zmj - Test = Test/(rmi*rmj) - If (Test .eq. One) Go To 40 -! - xij = (Cart(1,jAtom)-Cart(1,iAtom)) - yij = (Cart(2,jAtom)-Cart(2,iAtom)) - zij = (Cart(3,jAtom)-Cart(3,iAtom)) - rij2 = xij**2+yij**2+zij**2 - rrij = sqrt(rij2) -! - alpha = rkf*exp((ami*r0mi**2+amj*r0mj**2)) -! - r = sqrt(rmj2+rmi2) - gij = alpha*exp(-(ami*rmi2+amj*rmj2)) -! Write (*,*) ' gij=',gij - rL2 = (ymi*zmj-zmi*ymj)**2+(zmi*xmj-xmi*zmj)**2+ & - & (xmi*ymj-ymi*xmj)**2 -!hjw modified - if (rL2 .lt. 1.d-14) then - rL = 0 - else - rL = sqrt(rL2) - end if -! - if ((rmj .gt. rZero).and.(rmi .gt. rZero).and. & - & (rrij .gt. rZero)) Then - SinPhi = rL/(rmj*rmi) - rmidotrmj = xmi*xmj+ymi*ymj+zmi*zmj - CosPhi = rmidotrmj/(rmj*rmi) -! -!-------------None linear case -! - If (SinPhi .gt. rZero) Then -! Write (*,*) ' None linear case' - si(1) = (xmi/rmi*cosphi-xmj/rmj)/(rmi*sinphi) - si(2) = (ymi/rmi*cosphi-ymj/rmj)/(rmi*sinphi) - si(3) = (zmi/rmi*cosphi-zmj/rmj)/(rmi*sinphi) - sj(1) = (cosphi*xmj/rmj-xmi/rmi)/(rmj*sinphi) - sj(2) = (cosphi*ymj/rmj-ymi/rmi)/(rmj*sinphi) - sj(3) = (cosphi*zmj/rmj-zmi/rmi)/(rmj*sinphi) - sm(1) = -si(1)-sj(1) - sm(2) = -si(2)-sj(2) - sm(3) = -si(3)-sj(3) - Do icoor = 1,3 - Do jCoor = 1,3 - If (mAtom .gt. iAtom) Then - Hess(Ind(icoor,mAtom,jcoor,iAtom)) = & - & Hess(Ind(icoor,mAtom,jcoor,iAtom)) & - & +gij*sm(icoor)*si(jcoor) - else - Hess(Ind(icoor,iAtom,jcoor,mAtom)) = & - & Hess(Ind(icoor,iAtom,jcoor,mAtom)) & - & +gij*si(icoor)*sm(jcoor) - End If - If (mAtom .gt. jAtom) Then - Hess(Ind(icoor,mAtom,jcoor,jAtom)) = & - & Hess(Ind(icoor,mAtom,jcoor,jAtom)) & - & +gij*sm(icoor)*sj(jcoor) - else - Hess(Ind(icoor,jAtom,jcoor,mAtom)) = & - & Hess(Ind(icoor,jAtom,jcoor,mAtom)) & - & +gij*sj(icoor)*sm(jcoor) - End If - If (iAtom .gt. jAtom) Then - Hess(Ind(icoor,iAtom,jcoor,jAtom)) = & - & Hess(Ind(icoor,iAtom,jcoor,jAtom)) & - & +gij*si(icoor)*sj(jcoor) - else - Hess(Ind(icoor,jAtom,jcoor,iAtom)) = & - & Hess(Ind(icoor,jAtom,jcoor,iAtom)) & - & +gij*sj(icoor)*si(jcoor) - End If - End Do - End Do - Do icoor = 1,3 - Do jCoor = 1,icoor - Hess(Ind(icoor,iAtom,jcoor,iAtom)) = & - & Hess(Ind(icoor,iAtom,jcoor,iAtom)) & - & +gij*si(icoor)*si(jcoor) - Hess(Ind(icoor,mAtom,jcoor,mAtom)) = & - & Hess(Ind(icoor,mAtom,jcoor,mAtom)) & - & +gij*sm(icoor)*sm(jcoor) - Hess(Ind(icoor,jAtom,jcoor,jAtom)) = & - & Hess(Ind(icoor,jAtom,jcoor,jAtom)) & - & +gij*sj(icoor)*sj(jcoor) - -! - End Do - End Do - Else -! -!----------------Linear case -! - if ((abs(ymi) .gt. rZero).or. & -& (abs(xmi) .gt. rZero)) Then - x(1) = -ymi - y(1) = xmi - z(1) = Zero - x(2) = -xmi*zmi - y(2) = -ymi*zmi - z(2) = xmi*xmi+ymi*ymi - Else - x(1) = One - y(1) = Zero - z(1) = Zero - x(2) = Zero - y(2) = One - z(2) = Zero - End If - Do i = 1,2 - r1 = sqrt(x(i)**2+y(i)**2+z(i)**2) - cosThetax = x(i)/r1 - cosThetay = y(i)/r1 - cosThetaz = z(i)/r1 - si(1) = -cosThetax/rmi - si(2) = -cosThetay/rmi - si(3) = -cosThetaz/rmi - sj(1) = -cosThetax/rmj - sj(2) = -cosThetay/rmj - sj(3) = -cosThetaz/rmj - sm(1) = -(si(1)+sj(1)) - sm(2) = -(si(2)+sj(2)) - sm(3) = -(si(3)+sj(3)) -! - Do icoor = 1,3 - Do jCoor = 1,3 - If (mAtom .gt. iAtom) Then - Hess(Ind(icoor,mAtom,jcoor,iAtom)) = & - & Hess(Ind(icoor,mAtom,jcoor,iAtom)) & - & +gij*sm(icoor)*si(jcoor) - else - Hess(Ind(icoor,iAtom,jcoor,mAtom)) = & -& Hess(Ind(icoor,iAtom,jcoor,mAtom)) & -& +gij*si(icoor)*sm(jcoor) - End If - If (mAtom .gt. jAtom) Then - Hess(Ind(icoor,mAtom,jcoor,jAtom)) = & - & Hess(Ind(icoor,mAtom,jcoor,jAtom)) & - & +gij*sm(icoor)*sj(jcoor) - else - Hess(Ind(icoor,jAtom,jcoor,mAtom)) = & - & Hess(Ind(icoor,jAtom,jcoor,mAtom)) & - & +gij*sj(icoor)*sm(jcoor) - End If - If (iAtom .gt. jAtom) Then - Hess(Ind(icoor,iAtom,jcoor,jAtom)) = & -& Hess(Ind(icoor,iAtom,jcoor,jAtom)) & -& +gij*si(icoor)*sj(jcoor) - else - Hess(Ind(icoor,jAtom,jcoor,iAtom)) = & -& Hess(Ind(icoor,jAtom,jcoor,iAtom)) & -& +gij*sj(icoor)*si(jcoor) - End If - End Do - End Do - Do icoor = 1,3 - Do jCoor = 1,icoor - Hess(Ind(icoor,iAtom,jcoor,iAtom)) = & -& Hess(Ind(icoor,iAtom,jcoor,iAtom)) & -& +gij*si(icoor)*si(jcoor) - Hess(Ind(icoor,mAtom,jcoor,mAtom)) = & -& Hess(Ind(icoor,mAtom,jcoor,mAtom)) & -& +gij*sm(icoor)*sm(jcoor) - Hess(Ind(icoor,jAtom,jcoor,jAtom)) = & -& Hess(Ind(icoor,jAtom,jcoor,jAtom)) & -& +gij*sj(icoor)*sj(jcoor) - End Do - End Do - End Do - End If - End If -! -40 Continue - End Do -30 Continue - End Do -20 Continue - End Do -! -! Hessian for torsion -! - Do jAtom = 1,nAtoms - jr = iTabRow(iANr(jAtom)) -! If (jr.eq.0) Go To 444 -! - Call DCopy(3,Cart(1,jAtom),1,xyz(1,2),1) -! - Do kAtom = 1,nAtoms - If (kAtom .eq. jAtom) Go To 111 - kr = iTabRow(iANr(kAtom)) -! If (kr.eq.0) Go To 111 - - if (rcutoff(cart,katom,jatom,rcut)) cycle -! if(wb(katom,jatom).lt.wthr) cycle -! - Call DCopy(3,Cart(1,kAtom),1,xyz(1,3),1) -! - Do iAtom = 1,nAtoms - ij_ = nAtoms*(jAtom-1)+iAtom - If (iAtom .eq. jAtom) Go To 333 - If (iAtom .eq. kAtom) Go To 333 - ir = iTabRow(iANr(iAtom)) -! If (ir.eq.0) Go To 333 -! - if (rcutoff(cart,iatom,katom,rcut)) cycle - if (rcutoff(cart,iatom,jatom,rcut)) cycle -! if(wb(iatom,katom).lt.wthr) cycle -! if(wb(iatom,jatom).lt.wthr) cycle - - Call DCopy(3,Cart(1,iAtom),1,xyz(1,1),1) -! - Do lAtom = 1,nAtoms - lk_ = nAtoms*(kAtom-1)+lAtom - If (ij_ .le. lk_) Go To 222 - If (lAtom .eq. iAtom) Go To 222 - If (lAtom .eq. jAtom) Go To 222 - If (lAtom .eq. kAtom) Go To 222 - lr = iTabRow(iANr(lAtom)) -! If (lr.eq.0) Go To 222 -! - if (rcutoff(cart,latom,iatom,rcut)) cycle - if (rcutoff(cart,latom,katom,rcut)) cycle - if (rcutoff(cart,latom,jatom,rcut)) cycle -! if(wb(latom,iatom).lt.wthr) cycle -! if(wb(latom,katom).lt.wthr) cycle -! if(wb(latom,jatom).lt.wthr) cycle - - Call DCopy(3,Cart(1,lAtom),1,xyz(1,4),1) -! - rij(1) = Cart(1,iAtom)-Cart(1,jAtom) - rij(2) = Cart(2,iAtom)-Cart(2,jAtom) - rij(3) = Cart(3,iAtom)-Cart(3,jAtom) - rij0 = rAv(ir,jr)**2 - aij = aAv(ir,jr) -! - rjk(1) = Cart(1,jAtom)-Cart(1,kAtom) - rjk(2) = Cart(2,jAtom)-Cart(2,kAtom) - rjk(3) = Cart(3,jAtom)-Cart(3,kAtom) - rjk0 = rAv(jr,kr)**2 - ajk = aAv(jr,kr) -! - rkl(1) = Cart(1,kAtom)-Cart(1,lAtom) - rkl(2) = Cart(2,kAtom)-Cart(2,lAtom) - rkl(3) = Cart(3,kAtom)-Cart(3,lAtom) - rkl0 = rAv(kr,lr)**2 - akl = aAv(kr,lr) -! - rij2 = rij(1)**2+rij(2)**2+rij(3)**2 - rjk2 = rjk(1)**2+rjk(2)**2+rjk(3)**2 - rkl2 = rkl(1)**2+rkl(2)**2+rkl(3)**2 -! Allow only angles in the range of 35-145 - A35 = (35.0D0/180.D0)*Pi - CosFi_Max = Cos(A35) - CosFi2 = (rij(1)*rjk(1)+rij(2)*rjk(2)+rij(3)*rjk(3)) & - & /Sqrt(rij2*rjk2) - If (Abs(CosFi2) .gt. CosFi_Max) Go To 222 - CosFi3 = (rkl(1)*rjk(1)+rkl(2)*rjk(2)+rkl(3)*rjk(3)) & - & /Sqrt(rkl2*rjk2) - If (Abs(CosFi3) .gt. CosFi_Max) Go To 222 - - beta = rkt* & - & exp((aij*rij0+ajk*rjk0+akl*rkl0)) - tij = beta*exp(-(aij*rij2+ajk*rjk2+akl*rkl2)) - - Call Trsn(xyz,4,Tau,C,.False.,.False.,' ', & - & Dum,.False.) - Call DCopy(3,C(1,1),1,si,1) - Call DCopy(3,C(1,2),1,sj,1) - Call DCopy(3,C(1,3),1,sk,1) - Call DCopy(3,C(1,4),1,sl,1) -! -!-------------Off diagonal block -! - Do icoor = 1,3 - Do jCoor = 1,3 - Hess(Ind(icoor,iAtom,jcoor,jAtom)) = & - & Hess(Ind(icoor,iAtom,jcoor,jAtom)) & - & +tij*si(icoor)*sj(jcoor) - Hess(Ind(icoor,iAtom,jcoor,kAtom)) = & - & Hess(Ind(icoor,iAtom,jcoor,kAtom)) & - & +tij*si(icoor)*sk(jcoor) - Hess(Ind(icoor,iAtom,jcoor,lAtom)) = & - & Hess(Ind(icoor,iAtom,jcoor,lAtom)) & - & +tij*si(icoor)*sl(jcoor) - Hess(Ind(icoor,jAtom,jcoor,kAtom)) = & - & Hess(Ind(icoor,jAtom,jcoor,kAtom)) & - & +tij*sj(icoor)*sk(jcoor) - Hess(Ind(icoor,jAtom,jcoor,lAtom)) = & - & Hess(Ind(icoor,jAtom,jcoor,lAtom)) & - & +tij*sj(icoor)*sl(jcoor) - Hess(Ind(icoor,kAtom,jcoor,lAtom)) = & - & Hess(Ind(icoor,kAtom,jcoor,lAtom)) & - & +tij*sk(icoor)*sl(jcoor) - - End Do - End Do -! -!-------------Diagonal block -! - Do icoor = 1,3 - Do jCoor = 1,icoor - Hess(Ind(icoor,iAtom,jcoor,iAtom)) = & - & Hess(Ind(icoor,iAtom,jcoor,iAtom)) & - & +tij*si(icoor)*si(jcoor) - Hess(Ind(icoor,jAtom,jcoor,jAtom)) = & - & Hess(Ind(icoor,jAtom,jcoor,jAtom)) & - & +tij*sj(icoor)*sj(jcoor) - Hess(Ind(icoor,kAtom,jcoor,kAtom)) = & - & Hess(Ind(icoor,kAtom,jcoor,kAtom)) & - & +tij*sk(icoor)*sk(jcoor) - Hess(Ind(icoor,lAtom,jcoor,lAtom)) = & - & Hess(Ind(icoor,lAtom,jcoor,lAtom)) & - & +tij*sl(icoor)*sl(jcoor) - -! - End Do - End Do -222 Continue - End Do ! lAtom -333 Continue - End Do ! iAtom -111 Continue - End Do ! kAtom -444 Continue - End Do ! jAtom - Return - - contains - function ixyz(i,iatom) - integer :: ixyz - integer,intent(in) :: i,iatom - ixyz = (iatom-1)*3+i - end function ixyz - function jnd(i,j) - integer :: jnd - integer,intent(in) :: i,j - jnd = i*(i-1)/2+j - end function jnd - function ind(i,iatom,j,jatom) - integer :: ind - integer,intent(in) :: i,iatom,j,jatom - ind = jnd(max(ixyz(i,iatom),ixyz(j,jatom)),min(ixyz(i,iatom),ixyz(j,jatom))) - end function ind - end subroutine ddvopt - -!========================================================================================! -!########################################################################################! -!========================================================================================! - - subroutine mh_swart(xyz,n,hess,at,modh) -!**************************************************************************** -!* Swart's Model Hessian augmented with D2 -!* ------------------------------------------------------------------------ -!* Implemented after: -!* M. Swart, F. M. Bickelhaupt, Int. J. Quantum Chem., 2006, 106, 2536–2544. -!* DOI:10.1002/qua.21049 -!* -!* gij = exp[-(Rij/Cij-1)] -!* kij = rkr·gij -!* kijk = rkf·gij·gjk -!* kijkl = rkt·gij·gjk·gkl -!* -!* The proposed force constants by Swart are: -!* rkr = 0.35, rkf = 0.15, rkt = 0.005 -!* -!* This Hessian is additionally augmented with D2, please note that D2 -!* is not implemented in atomic units and requires some magical conversion -!* factor somewhere hidden in the implementation below. -!**************************************************************************** - implicit none - - integer,intent(in) :: n - real(wp),intent(in) :: xyz(3,n) - real(wp),intent(out) :: hess((3*n)*(3*n+1)/2) - integer,intent(in) :: at(n) - type(mhparam),intent(in) :: modh - - integer :: n3 - real(wp),parameter :: rzero = 1.0e-10_wp - logical,allocatable :: lcutoff(:,:) - real(wp) :: kd - - allocate (lcutoff(n,n),source=.false.) - - n3 = 3*n - hess = 0.0d0 - -! the dispersion force constant is used relative to the stretch force constant - kd = modh%kd/modh%kr - - associate (rad => covrad_2009) - - call mh_swart_stretch(n,at,xyz,hess,modh%kr,kd,modh%s6,rad,rad,lcutoff,modh%rcut) - if (modh%kf .ne. 0.0_wp) & - call mh_swart_bend(n,at,xyz,hess,modh%kf,kd,rad,rad,lcutoff) - if (modh%kt .ne. 0.0_wp) & - call mh_swart_torsion(n,at,xyz,hess,modh%kt,kd,rad,rad,lcutoff) - if (modh%ko .ne. 0.0_wp) & - call mh_swart_outofp(n,at,xyz,hess,modh%ko,kd,rad,rad,lcutoff) - if (modh%kq .ne. 0.0_wp) then -! call new_charge_model_2019(chrgeq,n,at) - call mh_eeq(n,at,xyz,0.0_wp,modh%kq,hess) - end if - - end associate - - end subroutine mh_swart - - pure subroutine mh_swart_stretch(n,at,xyz,hess,kr,kd,s6,rcov,rvdw,lcutoff,rcut) - implicit none - - integer,intent(in) :: n - integer,intent(in) :: at(n) - real(wp),intent(in) :: xyz(3,n) - real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) - real(wp),intent(in) :: kr - real(wp),intent(in) :: kd - real(wp),intent(in) :: s6 - real(wp),intent(in) :: rcov(:) - real(wp),intent(in) :: rvdw(:) - logical,intent(out) :: lcutoff(n,n) - real(wp),intent(in) :: rcut - - integer :: i,j - real(wp) :: xij,yij,zij,rij2,r0,d0 - real(wp) :: gmm - real(wp) :: c6i,c6j,c6ij,rv - real(wp) :: hxx,hxy,hxz,hyy,hyz,hzz - real(wp) :: vdw(3,3) - -!! ------------------------------------------------------------------------ -! Hessian for stretch -!! ------------------------------------------------------------------------ - stretch_iAt: do i = 1,n - - stretch_jAt: do j = 1,i-1 - - ! save for later - lcutoff(i,j) = rcutoff(xyz,i,j,rcut) - lcutoff(j,i) = lcutoff(i,j) - - xij = xyz(1,i)-xyz(1,j) - yij = xyz(2,i)-xyz(2,j) - zij = xyz(3,i)-xyz(3,j) - rij2 = xij**2+yij**2+zij**2 - r0 = rcov(at(i))+rcov(at(j)) - d0 = rvdw(at(i))+rvdw(at(j)) - - !cccccc vdwx ccccccccccccccccccccccccccccccccc - c6i = c6(at(i)) - c6j = c6(at(j)) - c6ij = sqrt(c6i*c6j) - rv = (vander(at(i))+vander(at(j)))*aatoau - - call getvdwxx(xij,yij,zij,c6ij,s6,rv,vdw(1,1)) - call getvdwxy(xij,yij,zij,c6ij,s6,rv,vdw(1,2)) - call getvdwxy(xij,zij,yij,c6ij,s6,rv,vdw(1,3)) - call getvdwxx(yij,xij,zij,c6ij,s6,rv,vdw(2,2)) - call getvdwxy(yij,zij,xij,c6ij,s6,rv,vdw(2,3)) - call getvdwxx(zij,xij,yij,c6ij,s6,rv,vdw(3,3)) - !cccccc ende vdwx ccccccccccccccccccccccccccccccc - - gmm = kr*fk_swart(1.0_wp,r0,rij2) & - +kr*kd*fk_vdw(5.0_wp,d0,rij2) - - !gmm = max(gmm,min_fk) - - hxx = gmm*xij*xij/rij2-vdw(1,1) - hxy = gmm*xij*yij/rij2-vdw(1,2) - hxz = gmm*xij*zij/rij2-vdw(1,3) - hyy = gmm*yij*yij/rij2-vdw(2,2) - hyz = gmm*yij*zij/rij2-vdw(2,3) - hzz = gmm*zij*zij/rij2-vdw(3,3) - - ! save diagonal elements for atom i - hess(ind(1,i,1,i)) = hess(ind(1,i,1,i))+hxx - hess(ind(2,i,1,i)) = hess(ind(2,i,1,i))+hxy - hess(ind(2,i,2,i)) = hess(ind(2,i,2,i))+hyy - hess(ind(3,i,1,i)) = hess(ind(3,i,1,i))+hxz - hess(ind(3,i,2,i)) = hess(ind(3,i,2,i))+hyz - hess(ind(3,i,3,i)) = hess(ind(3,i,3,i))+hzz - ! save elements between atom i and atom j - hess(ind(1,i,1,j)) = hess(ind(1,i,1,j))-hxx - hess(ind(1,i,2,j)) = hess(ind(1,i,2,j))-hxy - hess(ind(1,i,3,j)) = hess(ind(1,i,3,j))-hxz - hess(ind(2,i,1,j)) = hess(ind(2,i,1,j))-hxy - hess(ind(2,i,2,j)) = hess(ind(2,i,2,j))-hyy - hess(ind(2,i,3,j)) = hess(ind(2,i,3,j))-hyz - hess(ind(3,i,1,j)) = hess(ind(3,i,1,j))-hxz - hess(ind(3,i,2,j)) = hess(ind(3,i,2,j))-hyz - hess(ind(3,i,3,j)) = hess(ind(3,i,3,j))-hzz - ! save diagonal elements for atom j - hess(ind(1,j,1,j)) = hess(ind(1,j,1,j))+hxx - hess(ind(2,j,1,j)) = hess(ind(2,j,1,j))+hxy - hess(ind(2,j,2,j)) = hess(ind(2,j,2,j))+hyy - hess(ind(3,j,1,j)) = hess(ind(3,j,1,j))+hxz - hess(ind(3,j,2,j)) = hess(ind(3,j,2,j))+hyz - hess(ind(3,j,3,j)) = hess(ind(3,j,3,j))+hzz - - end do stretch_jAt - end do stretch_iAt - - end subroutine mh_swart_stretch - - pure subroutine mh_swart_bend(n,at,xyz,hess,kf,kd,rcov,rvdw,lcutoff) - implicit none - - integer,intent(in) :: n - integer,intent(in) :: at(n) - real(wp),intent(in) :: xyz(3,n) - real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) - real(wp),intent(in) :: kf - real(wp),intent(in) :: kd - real(wp),intent(in) :: rcov(:) - real(wp),intent(in) :: rvdw(:) - logical,intent(in) :: lcutoff(n,n) - - integer :: i,j,m,ic,jc,ii - real(wp),parameter :: rzero = 1.0e-10_wp - real(wp) :: xij,yij,zij,rij2,rrij,r1 - real(wp) :: xmi,ymi,zmi,rmi2,rmi,r0mi,d0mj,gmi - real(wp) :: xmj,ymj,zmj,rmj2,rmj,r0mj,d0mi,gmj - real(wp) :: test,gij,rl2,rl,rmidotrmj - real(wp) :: sinphi,cosphi,costhetax,costhetay,costhetaz - real(wp) :: alpha - real(wp) :: si(3),sj(3),sm(3),x(2),y(2),z(2) - -!! ------------------------------------------------------------------------ -! Hessian for bending -!! ------------------------------------------------------------------------ - bend_mAt: do m = 1,n - bend_iAt: do i = 1,n - if (i .eq. m) cycle bend_iAt - if (lcutoff(i,m)) cycle bend_iAt - - xmi = (xyz(1,i)-xyz(1,m)) - ymi = (xyz(2,i)-xyz(2,m)) - zmi = (xyz(3,i)-xyz(3,m)) - rmi2 = xmi**2+ymi**2+zmi**2 - rmi = sqrt(rmi2) - r0mi = rcov(at(m))+rcov(at(i)) - d0mi = rvdw(at(m))+rvdw(at(i)) - - bend_jAt: do j = 1,i-1 - if (j .eq. m) cycle bend_jAt - if (lcutoff(j,i)) cycle bend_jAt - if (lcutoff(j,m)) cycle bend_jAt - - xmj = (xyz(1,j)-xyz(1,m)) - ymj = (xyz(2,j)-xyz(2,m)) - zmj = (xyz(3,j)-xyz(3,m)) - rmj2 = xmj**2+ymj**2+zmj**2 - rmj = sqrt(rmj2) - r0mj = rcov(at(m))+rcov(at(j)) - d0mj = rvdw(at(m))+rvdw(at(j)) - - ! test if zero angle - test = xmi*xmj+ymi*ymj+zmi*zmj - test = test/(rmi*rmj) - if (abs(test-1.0_wp) .lt. 1.0e-12_wp) cycle bend_jAt - - xij = (xyz(1,j)-xyz(1,i)) - yij = (xyz(2,j)-xyz(2,i)) - zij = (xyz(3,j)-xyz(3,i)) - rij2 = xij**2+yij**2+zij**2 - rrij = sqrt(rij2) - - gmi = fk_swart(1.0_wp,r0mi,rmi2) & - +0.5_wp*kd*fk_vdw(5.0_wp,d0mi,rmi2) - gmj = fk_swart(1.0_wp,r0mj,rmj2) & - +0.5_wp*kd*fk_vdw(5.0_wp,d0mj,rmj2) - - gij = kf*gmi*gmj - - rl2 = (ymi*zmj-zmi*ymj)**2+(zmi*xmj-xmi*zmj)**2+(xmi*ymj-ymi*xmj)**2 - - if (rl2 .lt. 1.e-14_wp) then - rl = 0.0_wp - else - rl = sqrt(rl2) - end if - - !gij = max(gij,min_fk) - - if ((rmj .gt. rzero).and.(rmi .gt. rzero).and.(rrij .gt. rzero)) then - sinphi = rl/(rmj*rmi) - rmidotrmj = xmi*xmj+ymi*ymj+zmi*zmj - cosphi = rmidotrmj/(rmj*rmi) - ! none linear case - if (sinphi .gt. rzero) then - si(1) = (xmi/rmi*cosphi-xmj/rmj)/(rmi*sinphi) - si(2) = (ymi/rmi*cosphi-ymj/rmj)/(rmi*sinphi) - si(3) = (zmi/rmi*cosphi-zmj/rmj)/(rmi*sinphi) - sj(1) = (cosphi*xmj/rmj-xmi/rmi)/(rmj*sinphi) - sj(2) = (cosphi*ymj/rmj-ymi/rmi)/(rmj*sinphi) - sj(3) = (cosphi*zmj/rmj-zmi/rmi)/(rmj*sinphi) - sm(1) = -si(1)-sj(1) - sm(2) = -si(2)-sj(2) - sm(3) = -si(3)-sj(3) - do ic = 1,3 - do jc = 1,3 - if (m .gt. i) then - hess(ind(ic,m,jc,i)) = hess(ind(ic,m,jc,i)) & - +gij*sm(ic)*si(jc) - else - hess(ind(ic,i,jc,m)) = hess(ind(ic,i,jc,m)) & - +gij*si(ic)*sm(jc) - end if - if (m .gt. j) then - hess(ind(ic,m,jc,j)) = hess(ind(ic,m,jc,j)) & - +gij*sm(ic)*sj(jc) - else - hess(ind(ic,j,jc,m)) = hess(ind(ic,j,jc,m)) & - +gij*sj(ic)*sm(jc) - end if - if (i .gt. j) then - hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j)) & - +gij*si(ic)*sj(jc) - else - hess(ind(ic,j,jc,i)) = hess(ind(ic,j,jc,i)) & - +gij*sj(ic)*si(jc) - end if - end do - end do - do ic = 1,3 - do jc = 1,ic - hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+gij*si(ic)*si(jc) - hess(ind(ic,m,jc,m)) = hess(ind(ic,m,jc,m))+gij*sm(ic)*sm(jc) - hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+gij*sj(ic)*sj(jc) - end do - end do - else - ! linear case - if ((abs(ymi) .gt. rzero).or.(abs(xmi) .gt. rzero)) then - x(1) = -ymi - y(1) = xmi - z(1) = 0.0_wp - x(2) = -xmi*zmi - y(2) = -ymi*zmi - z(2) = xmi*xmi+ymi*ymi - else - x(1) = 1.0_wp - y(1) = 0.0_wp - z(1) = 0.0_wp - x(2) = 0.0_wp - y(2) = 1.0_wp - z(2) = 0.0_wp - end if - do ii = 1,2 - r1 = sqrt(x(ii)**2+y(ii)**2+z(ii)**2) - costhetax = x(ii)/r1 - costhetay = y(ii)/r1 - costhetaz = z(ii)/r1 - si(1) = -costhetax/rmi - si(2) = -costhetay/rmi - si(3) = -costhetaz/rmi - sj(1) = -costhetax/rmj - sj(2) = -costhetay/rmj - sj(3) = -costhetaz/rmj - sm(1) = -(si(1)+sj(1)) - sm(2) = -(si(2)+sj(2)) - sm(3) = -(si(3)+sj(3)) - ! - do ic = 1,3 - do jc = 1,3 - if (m .gt. i) then - hess(ind(ic,m,jc,i)) = hess(ind(ic,m,jc,i)) & - +gij*sm(ic)*si(jc) - else - hess(ind(ic,i,jc,m)) = hess(ind(ic,i,jc,m)) & - +gij*si(ic)*sm(jc) - end if - if (m .gt. j) then - hess(ind(ic,m,jc,j)) = hess(ind(ic,m,jc,j)) & - +gij*sm(ic)*sj(jc) - else - hess(ind(ic,j,jc,m)) = hess(ind(ic,j,jc,m)) & - +gij*sj(ic)*sm(jc) - end if - if (i .gt. j) then - hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j)) & - +gij*si(ic)*sj(jc) - else - hess(ind(ic,j,jc,i)) = hess(ind(ic,j,jc,i)) & - +gij*sj(ic)*si(jc) - end if - end do - end do - do ic = 1,3 - do jc = 1,ic - hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i)) & - +gij*si(ic)*si(jc) - hess(ind(ic,m,jc,m)) = hess(ind(ic,m,jc,m)) & - +gij*sm(ic)*sm(jc) - hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j)) & - +gij*sj(ic)*sj(jc) - end do - end do - end do - - end if - end if - - end do bend_jAt - end do bend_iAt - end do bend_mAt - - end subroutine mh_swart_bend - - pure subroutine mh_swart_torsion(n,at,xyz,hess,kt,kd,rcov,rvdw,lcutoff) - implicit none - - integer,intent(in) :: n - integer,intent(in) :: at(n) - real(wp),intent(in) :: xyz(3,n) - real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) - real(wp),intent(in) :: kt - real(wp),intent(in) :: kd - real(wp),intent(in) :: rcov(:) - real(wp),intent(in) :: rvdw(:) - logical,intent(in) :: lcutoff(n,n) - - integer :: i,j,k,l,ic,jc,ij,kl -! allow only angles in the range of 35-145 - real(wp),parameter :: a35 = (35.0d0/180.d0)*pi - real(wp),parameter :: cosfi_max = cos(a35) - real(wp) :: txyz(3,4),c(3,4) - real(wp) :: rij(3),rij0,aij,rij2,d0ij,gij - real(wp) :: rjk(3),rjk0,ajk,rjk2,d0jk,gjk - real(wp) :: rkl(3),rkl0,akl,rkl2,d0kl,gkl - real(wp) :: cosfi2,cosfi3,cosfi4 - real(wp) :: beta,tij,tau - real(wp) :: si(3),sj(3),sk(3),sl(3) - -!! ------------------------------------------------------------------------ -! Hessian for torsion -!! ------------------------------------------------------------------------ - torsion_jAt: do j = 1,n - txyz(:,2) = xyz(:,j) - torsion_kAt: do k = 1,n - if (k .eq. j) cycle torsion_kAt - if (lcutoff(k,j)) cycle torsion_kAt - txyz(:,3) = xyz(:,k) - torsion_iAt: do i = 1,n - ij = n*(j-1)+i - if (i .eq. j) cycle torsion_iAt - if (i .eq. k) cycle torsion_iAt - if (lcutoff(i,k)) cycle torsion_iAt - if (lcutoff(i,j)) cycle torsion_iAt - - txyz(:,1) = xyz(:,i) - torsion_lAt: do l = 1,n - kl = n*(l-1)+k - if (ij .le. kl) cycle torsion_lAt - if (l .eq. i) cycle torsion_lAt - if (l .eq. j) cycle torsion_lAt - if (l .eq. k) cycle torsion_lAt -! - if (lcutoff(l,i)) cycle torsion_lAt - if (lcutoff(l,k)) cycle torsion_lAt - if (lcutoff(l,j)) cycle torsion_lAt - - txyz(:,4) = xyz(:,l) - - rij = xyz(:,i)-xyz(:,j) - d0ij = rvdw(at(i))+rvdw(at(j)) - rij0 = rcov(at(i))+rcov(at(j)) - - rjk = xyz(:,j)-xyz(:,k) - d0jk = rvdw(at(j))+rvdw(at(k)) - rjk0 = rcov(at(j))+rcov(at(k)) - - rkl = xyz(:,k)-xyz(:,l) - d0kl = rvdw(at(k))+rvdw(at(l)) - rkl0 = rcov(at(k))+rcov(at(l)) - - rij2 = sum(rij**2) - rjk2 = sum(rjk**2) - rkl2 = sum(rjk**2) - - cosfi2 = dot_product(rij,rjk)/sqrt(rij2*rjk2) - if (abs(cosfi2) .gt. cosfi_max) cycle - cosfi3 = dot_product(rkl,rjk)/sqrt(rkl2*rjk2) - if (abs(cosfi3) .gt. cosfi_max) cycle - - gij = fk_swart(1.0_wp,rij0,rij2) & - +0.5_wp*kd*fk_vdw(5.0_wp,d0ij,rij2) - gjk = fk_swart(1.0_wp,rjk0,rjk2) & - +0.5_wp*kd*fk_vdw(5.0_wp,d0jk,rjk2) - gkl = fk_swart(1.0_wp,rkl0,rkl2) & - +0.5_wp*kd*fk_vdw(5.0_wp,d0kl,rkl2) - - tij = kt*gij*gjk*gkl - - !tij = max(tij,10*min_fk) - - call trsn2(txyz,tau,c) - si = c(:,1) - sj = c(:,2) - sk = c(:,3) - sl = c(:,4) - - ! off diagonal block - do ic = 1,3 - do jc = 1,3 - hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j))+tij*si(ic)*sj(jc) - hess(ind(ic,i,jc,k)) = hess(ind(ic,i,jc,k))+tij*si(ic)*sk(jc) - hess(ind(ic,i,jc,l)) = hess(ind(ic,i,jc,l))+tij*si(ic)*sl(jc) - hess(ind(ic,j,jc,k)) = hess(ind(ic,j,jc,k))+tij*sj(ic)*sk(jc) - hess(ind(ic,j,jc,l)) = hess(ind(ic,j,jc,l))+tij*sj(ic)*sl(jc) - hess(ind(ic,k,jc,l)) = hess(ind(ic,k,jc,l))+tij*sk(ic)*sl(jc) - end do - end do - - ! diagonal block - do ic = 1,3 - do jc = 1,ic - hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+tij*si(ic)*si(jc) - hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+tij*sj(ic)*sj(jc) - hess(ind(ic,k,jc,k)) = hess(ind(ic,k,jc,k))+tij*sk(ic)*sk(jc) - hess(ind(ic,l,jc,l)) = hess(ind(ic,l,jc,l))+tij*sl(ic)*sl(jc) - end do - end do - - end do torsion_lAt - end do torsion_iAt - end do torsion_kAt - end do torsion_jAt - - end subroutine mh_swart_torsion - - pure subroutine mh_swart_outofp(n,at,xyz,hess,ko,kd,rcov,rvdw,lcutoff) - implicit none - - integer,intent(in) :: n - integer,intent(in) :: at(n) - real(wp),intent(in) :: xyz(3,n) - real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) - real(wp),intent(in) :: ko - real(wp),intent(in) :: kd - real(wp),intent(in) :: rcov(:) - real(wp),intent(in) :: rvdw(:) - logical,intent(in) :: lcutoff(n,n) - - integer :: i,ir,j,jr,k,kr,l,lr,ic,jc - real(wp) :: txyz(3,4),c(3,4) - real(wp) :: rij(3),rij0,d0ij,rij2,gij - real(wp) :: rik(3),rik0,d0ik,rik2,gik - real(wp) :: ril(3),ril0,d0il,ril2,gil - real(wp) :: cosfi2,cosfi3,cosfi4 - real(wp) :: beta,tij,tau - real(wp) :: si(3),sj(3),sk(3),sl(3) - -!! ------------------------------------------------------------------------ -! Hessian for out-of-plane -!! ------------------------------------------------------------------------ - outofplane_iAt: do i = 1,n - txyz(:,4) = xyz(:,i) - outofplane_jAt: do j = 1,n - if (j .eq. i) cycle outofplane_jAt - if (lcutoff(j,i)) cycle outofplane_jAt - txyz(:,1) = xyz(:,j) - outofplane_kAt: do k = 1,n - if (i .eq. k) cycle outofplane_kAt - if (j .eq. k) cycle outofplane_kat - if (lcutoff(k,i)) cycle outofplane_kAt - if (lcutoff(k,j)) cycle outofplane_kAt - txyz(:,2) = xyz(:,k) - outofplane_lAt: do l = 1,n - txyz(:,3) = xyz(:,l) - if (l .eq. i) cycle outofplane_lAt - if (l .eq. j) cycle outofplane_lAt - if (l .eq. k) cycle outofplane_lAt - if (lcutoff(l,i)) cycle outofplane_lAt - if (lcutoff(l,k)) cycle outofplane_lAt - if (lcutoff(l,j)) cycle outofplane_lAt - - rij = xyz(:,i)-xyz(:,j) - rij0 = rcov(at(i))+rcov(at(j)) - d0ij = rvdw(at(i))+rvdw(at(j)) - - rik = xyz(:,i)-xyz(:,k) - rik0 = rcov(at(i))+rcov(at(k)) - d0ik = rvdw(at(i))+rvdw(at(k)) - - ril = xyz(:,i)-xyz(:,l) - ril0 = rcov(at(i))+rcov(at(l)) - d0il = rvdw(at(i))+rvdw(at(l)) - - rij2 = sum(rij**2) - rik2 = sum(rik**2) - ril2 = sum(ril**2) - - cosfi2 = dot_product(rij,rik)/sqrt(rij2*rik2) - if (abs(abs(cosfi2)-1.0_wp) .lt. 1.0e-1_wp) cycle - cosfi3 = dot_product(rij,ril)/sqrt(rij2*ril2) - if (abs(abs(cosfi3)-1.0_wp) .lt. 1.0e-1_wp) cycle - cosfi4 = dot_product(rik,ril)/sqrt(rik2*ril2) - if (abs(abs(cosfi4)-1.0_wp) .lt. 1.0e-1_wp) cycle - - gij = fk_swart(1.0_wp,rij0,rij2) & - +0.5_wp*kd*fk_vdw(5.0_wp,d0ij,rij2) - gik = fk_swart(1.0_wp,rik0,rik2) & - +0.5_wp*kd*fk_vdw(5.0_wp,d0ik,rik2) - gil = fk_swart(1.0_wp,ril0,ril2) & - +0.5_wp*kd*fk_vdw(5.0_wp,d0il,ril2) - - tij = ko*gij*gik*gil - - !tij = max(tij,10*min_fk) - - call outofp2(xyz,tau,c) - If (abs(tau) .gt. 45.0d0*(pi/180.d0)) cycle - - si = c(:,4) - sj = c(:,1) - sk = c(:,2) - sl = c(:,3) - - ! off diagonal block - do ic = 1,3 - do jc = 1,3 - hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j))+tij*si(ic)*sj(jc) - hess(ind(ic,i,jc,k)) = hess(ind(ic,i,jc,k))+tij*si(ic)*sk(jc) - hess(ind(ic,i,jc,l)) = hess(ind(ic,i,jc,l))+tij*si(ic)*sl(jc) - hess(ind(ic,j,jc,k)) = hess(ind(ic,j,jc,k))+tij*sj(ic)*sk(jc) - hess(ind(ic,j,jc,l)) = hess(ind(ic,j,jc,l))+tij*sj(ic)*sl(jc) - hess(ind(ic,k,jc,l)) = hess(ind(ic,k,jc,l))+tij*sk(ic)*sl(jc) - end do - end do - - ! diagonal block - do ic = 1,3 - do jc = 1,ic - hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+tij*si(ic)*si(jc) - hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+tij*sj(ic)*sj(jc) - hess(ind(ic,k,jc,k)) = hess(ind(ic,k,jc,k))+tij*sk(ic)*sk(jc) - hess(ind(ic,l,jc,l)) = hess(ind(ic,l,jc,l))+tij*sl(ic)*sl(jc) - end do - end do - - end do outofplane_lAt - end do outofplane_kAt - end do outofplane_jAt - end do outofplane_iAt - - end subroutine mh_swart_outofp - -!========================================================================================! -!########################################################################################! -!========================================================================================! - - subroutine mh_lindh(xyz,n,hess,at,modh) -!************************************************************************** -!* Lindh's Model Hessian updated around 2007 -!* ------------------------------------------------------------------------ -!* R. Lindh, personal communication. -!* -!* gij = exp[αij(R²ref - R²ij)] -!* dij = exp[-4·(Rvdw - Rij)²] -!* kij = rkr·gij + rkd·dij -!* kijk = rkf·(gij+½·rkd/rkr·dij)·(gjk+½·rkd/rkr·djk) -!* kijkl = rkt·(gij+½·rkd/rkr·dij)·(gjk+½·rkd/rkr·djk)·(gkl+½·rkd/rkr·dkl) -!* -!* parameters tweaked by R. Lindh in 2007: -!* rkr = 0.45, rkf = 0.10, rkt = 0.0025, rko = 0.16, rkd = 0.05 -!* -!* the reference distances are divided by rows in the PSE: -!* rAv: 1 2 3 aAv: 1 2 3 -!* 1 1.3500 2.1000 2.5300 1 1.0000 0.3949 0.3949 -!* 2 2.1000 2.8700 3.8000 2 0.3949 0.2800 0.1200 -!* 3 2.5300 3.8000 4.5000 3 0.3949 0.1200 0.0600 -!* -!* dAv: 1 2 3 -!* 1 0.0000 3.6000 3.6000 -!* 2 3.6000 5.3000 5.3000 -!* 3 3.6000 5.3000 5.3000 -!* -!************************************************************************** - implicit none - - integer,intent(in) :: n - real(wp),intent(in) :: xyz(3,n) - real(wp),intent(out) :: hess((3*n)*(3*n+1)/2) - integer,intent(in) :: at(n) - type(mhparam),intent(in) :: modh - - real(wp),parameter :: rAv(3,3) = reshape( & - (/1.3500_wp,2.1000_wp,2.5300_wp, & - 2.1000_wp,2.8700_wp,3.8000_wp, & - 2.5300_wp,3.8000_wp,4.5000_wp/),shape(rAv)) - real(wp),parameter :: aAv(3,3) = reshape( & - (/1.0000_wp,0.3949_wp,0.3949_wp, & - 0.3949_wp,0.2800_wp,0.1200_wp, & - 0.3949_wp,0.1200_wp,0.0600_wp/),shape(aAv)) - real(wp),parameter :: dAv(3,3) = reshape( & - (/0.0000_wp,3.6000_wp,3.6000_wp, & - 3.6000_wp,5.3000_wp,5.3000_wp, & - 3.6000_wp,5.3000_wp,5.3000_wp/),shape(aAv)) - - integer :: n3 - real(wp) :: kd - logical,allocatable :: lcutoff(:,:) - !type(chrg_parameter) :: chrgeq - - allocate (lcutoff(n,n),source=.false.) - - n3 = 3*n - hess = 0.0d0 - -! the dispersion force constant is used relative to the stretch force constant - kd = modh%kd/modh%kr - - call mh_lindh_stretch(n,at,xyz,hess,modh%kr,kd,modh%s6,aav,rav,dav,lcutoff,modh%rcut) - if (modh%kf .ne. 0.0_wp) & - call mh_lindh_bend(n,at,xyz,hess,modh%kf,kd,aav,rav,dav,lcutoff) - if (modh%kt .ne. 0.0_wp) & - call mh_lindh_torsion(n,at,xyz,hess,modh%kt,kd,aav,rav,dav,lcutoff) - if (modh%ko .ne. 0.0_wp) & - call mh_lindh_outofp(n,at,xyz,hess,modh%ko,0.0_wp,aav,rav,dav,lcutoff) - if (modh%kq .ne. 0.0_wp) then - !call new_charge_model_2019(chrgeq,n,at) - call mh_eeq(n,at,xyz,0.0_wp,modh%kq,hess) - end if - - end subroutine mh_lindh - - subroutine mh_lindh_d2(xyz,n,hess,at,modh) -!************************************************************************** -!* Lindh's Model Hessian augmented with D2 -!* ------------------------------------------------------------------------ -!* Implemented after: -!* Lindh, R., Bernhardsson, A., Karlström, G., & Malmqvist, P.-Å. (1995). -!* On the use of a Hessian model function in molecular geometry optimizations. -!* Chem. Phys. Lett., 241(4), 423–428. doi:10.1016/0009-2614(95)00646-l -!* -!* gij = exp[αij(R²ref - R²ij)] -!* kij = rkr·gij -!* kijk = rkf·gij·gjk -!* kijkl = rkt·gij·gjk·gkl -!* -!* Originally Lindh proposed (we tweaked those a little bit): -!* rkr = 0.45, rkf = 0.15, rkt = 0.005 -!* -!* the reference distances are divided by rows in the PSE: -!* rAv: 1 2 3 aAv: 1 2 3 -!* 1 1.3500 2.1000 2.5300 1 1.0000 0.3949 0.3949 -!* 2 2.1000 2.8700 3.4000 2 0.3949 0.2800 0.2800 -!* 3 2.5300 3.4000 3.4000 3 0.3949 0.2800 0.2800 -!* -!* This Hessian is additionally augmented with D2, please note that D2 -!* is not implemented in atomic units and requires some magical conversion -!* factor somewhere hidden in the implementation below. -!************************************************************************* - implicit none - - integer,intent(in) :: n - real(wp),intent(in) :: xyz(3,n) - real(wp),intent(out) :: hess((3*n)*(3*n+1)/2) - integer,intent(in) :: at(n) - type(mhparam),intent(in) :: modh - - real(wp),parameter :: rAv(3,3) = reshape( & - (/1.3500_wp,2.1000_wp,2.5300_wp, & - 2.1000_wp,2.8700_wp,3.4000_wp, & - 2.5300_wp,3.4000_wp,3.4000_wp/),shape(rAv)) - real(wp),parameter :: aAv(3,3) = reshape( & - (/1.0000_wp,0.3949_wp,0.3949_wp, & - 0.3949_wp,0.2800_wp,0.2800_wp, & - 0.3949_wp,0.2800_wp,0.2800_wp/),shape(aAv)) - real(wp),parameter :: dAv(3,3) = reshape( & - (/0.0000_wp,0.0000_wp,0.0000_wp, & - 0.0000_wp,0.0000_wp,0.0000_wp, & - 0.0000_wp,0.0000_wp,0.0000_wp/),shape(aAv)) - - integer :: n3 - real(wp) :: kd - logical,allocatable :: lcutoff(:,:) - - allocate (lcutoff(n,n),source=.false.) - - n3 = 3*n - hess = 0.0d0 - -! the dispersion force constant is used relative to the stretch force constant - kd = modh%kd/modh%kr - - call mh_lindh_stretch(n,at,xyz,hess,modh%kr,kd,modh%s6,aav,rav,dav,lcutoff,modh%rcut) - if (modh%kf .ne. 0.0_wp) & - call mh_lindh_bend(n,at,xyz,hess,modh%kf,kd,aav,rav,dav,lcutoff) - if (modh%kt .ne. 0.0_wp) & - call mh_lindh_torsion(n,at,xyz,hess,modh%kt,kd,aav,rav,dav,lcutoff) - if (modh%ko .ne. 0.0_wp) & - call mh_lindh_outofp(n,at,xyz,hess,modh%ko,kd,aav,rav,dav,lcutoff) - if (modh%kq .ne. 0.0_wp) then - call mh_eeq(n,at,xyz,0.0_wp,modh%kq,hess) - end if - end subroutine mh_lindh_d2 - - pure subroutine mh_lindh_stretch(n,at,xyz,hess,kr,kd,s6,aav,rav,dav,lcutoff,rcut) - implicit none - - integer,intent(in) :: n - integer,intent(in) :: at(n) - real(wp),intent(in) :: xyz(3,n) - real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) - real(wp),intent(in) :: kr - real(wp),intent(in) :: kd - real(wp),intent(in) :: s6 - real(wp),intent(in) :: aav(3,3) - real(wp),intent(in) :: rav(3,3) - real(wp),intent(in) :: dav(3,3) - logical,intent(out) :: lcutoff(n,n) - real(wp),intent(in) :: rcut - - integer :: i,ir,j,jr - real(wp) :: xij,yij,zij,rij2,r0,d0 - real(wp) :: alpha,gmm - real(wp) :: c6i,c6j,c6ij,rv - real(wp) :: hxx,hxy,hxz,hyy,hyz,hzz - real(wp) :: vdw(3,3) - -!! ------------------------------------------------------------------------ -! Hessian for stretch -!! ------------------------------------------------------------------------ - stretch_iAt: do i = 1,n - ir = itabrow(at(i)) - - stretch_jAt: do j = 1,i-1 - jr = itabrow(at(j)) - - ! save for later - lcutoff(i,j) = rcutoff(xyz,i,j,rcut) - lcutoff(j,i) = lcutoff(i,j) - - xij = xyz(1,i)-xyz(1,j) - yij = xyz(2,i)-xyz(2,j) - zij = xyz(3,i)-xyz(3,j) - rij2 = xij**2+yij**2+zij**2 - r0 = rav(ir,jr) - d0 = dav(ir,jr) - alpha = aav(ir,jr) - - !cccccc vdwx ccccccccccccccccccccccccccccccccc - c6i = c6(at(i)) - c6j = c6(at(j)) - c6ij = sqrt(c6i*c6j) - rv = (vander(at(i))+vander(at(j)))*aatoau - - call getvdwxx(xij,yij,zij,c6ij,s6,rv,vdw(1,1)) - call getvdwxy(xij,yij,zij,c6ij,s6,rv,vdw(1,2)) - call getvdwxy(xij,zij,yij,c6ij,s6,rv,vdw(1,3)) - call getvdwxx(yij,xij,zij,c6ij,s6,rv,vdw(2,2)) - call getvdwxy(yij,zij,xij,c6ij,s6,rv,vdw(2,3)) - call getvdwxx(zij,xij,yij,c6ij,s6,rv,vdw(3,3)) - !cccccc ende vdwx ccccccccccccccccccccccccccccccc - - gmm = kr*fk_lindh(alpha,r0,rij2) & - +kr*kd*fk_vdw(4.0_wp,d0,rij2) - - !gmm = max(gmm,min_fk) - - hxx = gmm*xij*xij/rij2-vdw(1,1) - hxy = gmm*xij*yij/rij2-vdw(1,2) - hxz = gmm*xij*zij/rij2-vdw(1,3) - hyy = gmm*yij*yij/rij2-vdw(2,2) - hyz = gmm*yij*zij/rij2-vdw(2,3) - hzz = gmm*zij*zij/rij2-vdw(3,3) - - ! save diagonal elements for atom i - hess(ind(1,i,1,i)) = hess(ind(1,i,1,i))+hxx - hess(ind(2,i,1,i)) = hess(ind(2,i,1,i))+hxy - hess(ind(2,i,2,i)) = hess(ind(2,i,2,i))+hyy - hess(ind(3,i,1,i)) = hess(ind(3,i,1,i))+hxz - hess(ind(3,i,2,i)) = hess(ind(3,i,2,i))+hyz - hess(ind(3,i,3,i)) = hess(ind(3,i,3,i))+hzz - ! save elements between atom i and atom j - hess(ind(1,i,1,j)) = hess(ind(1,i,1,j))-hxx - hess(ind(1,i,2,j)) = hess(ind(1,i,2,j))-hxy - hess(ind(1,i,3,j)) = hess(ind(1,i,3,j))-hxz - hess(ind(2,i,1,j)) = hess(ind(2,i,1,j))-hxy - hess(ind(2,i,2,j)) = hess(ind(2,i,2,j))-hyy - hess(ind(2,i,3,j)) = hess(ind(2,i,3,j))-hyz - hess(ind(3,i,1,j)) = hess(ind(3,i,1,j))-hxz - hess(ind(3,i,2,j)) = hess(ind(3,i,2,j))-hyz - hess(ind(3,i,3,j)) = hess(ind(3,i,3,j))-hzz - ! save diagonal elements for atom j - hess(ind(1,j,1,j)) = hess(ind(1,j,1,j))+hxx - hess(ind(2,j,1,j)) = hess(ind(2,j,1,j))+hxy - hess(ind(2,j,2,j)) = hess(ind(2,j,2,j))+hyy - hess(ind(3,j,1,j)) = hess(ind(3,j,1,j))+hxz - hess(ind(3,j,2,j)) = hess(ind(3,j,2,j))+hyz - hess(ind(3,j,3,j)) = hess(ind(3,j,3,j))+hzz - - end do stretch_jAt - end do stretch_iAt - - end subroutine mh_lindh_stretch - - pure subroutine mh_lindh_bend(n,at,xyz,hess,kf,kd,aav,rav,dav,lcutoff) - implicit none - - integer,intent(in) :: n - integer,intent(in) :: at(n) - real(wp),intent(in) :: xyz(3,n) - real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) - real(wp),intent(in) :: kf - real(wp),intent(in) :: kd - real(wp),intent(in) :: aav(3,3) - real(wp),intent(in) :: rav(3,3) - real(wp),intent(in) :: dav(3,3) - logical,intent(in) :: lcutoff(n,n) - - integer :: i,ir,j,jr,m,mr,ic,jc,ii - real(wp),parameter :: rzero = 1.0e-10_wp - real(wp) :: xij,yij,zij,rij2,rrij,r1 - real(wp) :: xmi,ymi,zmi,rmi2,rmi,r0mi,ami,d0mj,gmi - real(wp) :: xmj,ymj,zmj,rmj2,rmj,r0mj,amj,d0mi,gmj - real(wp) :: test,gij,rl2,rl,rmidotrmj - real(wp) :: sinphi,cosphi,costhetax,costhetay,costhetaz - real(wp) :: alpha - real(wp) :: si(3),sj(3),sm(3),x(2),y(2),z(2) - -!! ------------------------------------------------------------------------ -! Hessian for bending -!! ------------------------------------------------------------------------ - bend_mAt: do m = 1,n - mr = itabrow(at(m)) - bend_iAt: do i = 1,n - if (i .eq. m) cycle bend_iAt - ir = itabrow(at(i)) - if (lcutoff(i,m)) cycle bend_iAt - - xmi = (xyz(1,i)-xyz(1,m)) - ymi = (xyz(2,i)-xyz(2,m)) - zmi = (xyz(3,i)-xyz(3,m)) - rmi2 = xmi**2+ymi**2+zmi**2 - rmi = sqrt(rmi2) - r0mi = rav(mr,ir) - d0mi = dav(mr,ir) - ami = aav(mr,ir) - - bend_jAt: do j = 1,i-1 - if (j .eq. m) cycle bend_jAt - jr = itabrow(at(j)) - if (lcutoff(j,i)) cycle bend_jAt - if (lcutoff(j,m)) cycle bend_jAt - - xmj = (xyz(1,j)-xyz(1,m)) - ymj = (xyz(2,j)-xyz(2,m)) - zmj = (xyz(3,j)-xyz(3,m)) - rmj2 = xmj**2+ymj**2+zmj**2 - rmj = sqrt(rmj2) - r0mj = rav(mr,jr) - d0mj = dav(mr,jr) - amj = aav(mr,jr) - - ! test if zero angle - test = xmi*xmj+ymi*ymj+zmi*zmj - test = test/(rmi*rmj) - if (abs(test-1.0_wp) .lt. 1.0e-12_wp) cycle bend_jAt - - xij = (xyz(1,j)-xyz(1,i)) - yij = (xyz(2,j)-xyz(2,i)) - zij = (xyz(3,j)-xyz(3,i)) - rij2 = xij**2+yij**2+zij**2 - rrij = sqrt(rij2) - - gmi = fk_lindh(ami,r0mi,rmi2) & - +0.5_wp*kd*fk_vdw(4.0_wp,d0mi,rmi2) - gmj = fk_lindh(amj,r0mj,rmj2) & - +0.5_wp*kd*fk_vdw(4.0_wp,d0mj,rmj2) - - gij = kf*gmi*gmj - - rl2 = (ymi*zmj-zmi*ymj)**2+(zmi*xmj-xmi*zmj)**2+(xmi*ymj-ymi*xmj)**2 - - if (rl2 .lt. 1.e-14_wp) then - rl = 0.0_wp - else - rl = sqrt(rl2) - end if - - !gij = max(gij,min_fk) - - if ((rmj .gt. rzero).and.(rmi .gt. rzero).and.(rrij .gt. rzero)) then - sinphi = rl/(rmj*rmi) - rmidotrmj = xmi*xmj+ymi*ymj+zmi*zmj - cosphi = rmidotrmj/(rmj*rmi) - ! none linear case - if (sinphi .gt. rzero) then - si(1) = (xmi/rmi*cosphi-xmj/rmj)/(rmi*sinphi) - si(2) = (ymi/rmi*cosphi-ymj/rmj)/(rmi*sinphi) - si(3) = (zmi/rmi*cosphi-zmj/rmj)/(rmi*sinphi) - sj(1) = (cosphi*xmj/rmj-xmi/rmi)/(rmj*sinphi) - sj(2) = (cosphi*ymj/rmj-ymi/rmi)/(rmj*sinphi) - sj(3) = (cosphi*zmj/rmj-zmi/rmi)/(rmj*sinphi) - sm(1) = -si(1)-sj(1) - sm(2) = -si(2)-sj(2) - sm(3) = -si(3)-sj(3) - do ic = 1,3 - do jc = 1,3 - if (m .gt. i) then - hess(ind(ic,m,jc,i)) = hess(ind(ic,m,jc,i)) & - +gij*sm(ic)*si(jc) - else - hess(ind(ic,i,jc,m)) = hess(ind(ic,i,jc,m)) & - +gij*si(ic)*sm(jc) - end if - if (m .gt. j) then - hess(ind(ic,m,jc,j)) = hess(ind(ic,m,jc,j)) & - +gij*sm(ic)*sj(jc) - else - hess(ind(ic,j,jc,m)) = hess(ind(ic,j,jc,m)) & - +gij*sj(ic)*sm(jc) - end if - if (i .gt. j) then - hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j)) & - +gij*si(ic)*sj(jc) - else - hess(ind(ic,j,jc,i)) = hess(ind(ic,j,jc,i)) & - +gij*sj(ic)*si(jc) - end if - end do - end do - do ic = 1,3 - do jc = 1,ic - hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+gij*si(ic)*si(jc) - hess(ind(ic,m,jc,m)) = hess(ind(ic,m,jc,m))+gij*sm(ic)*sm(jc) - hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+gij*sj(ic)*sj(jc) - end do - end do - else - ! linear case - if ((abs(ymi) .gt. rzero).or.(abs(xmi) .gt. rzero)) then - x(1) = -ymi - y(1) = xmi - z(1) = 0.0_wp - x(2) = -xmi*zmi - y(2) = -ymi*zmi - z(2) = xmi*xmi+ymi*ymi - else - x(1) = 1.0_wp - y(1) = 0.0_wp - z(1) = 0.0_wp - x(2) = 0.0_wp - y(2) = 1.0_wp - z(2) = 0.0_wp - end if - do ii = 1,2 - r1 = sqrt(x(ii)**2+y(ii)**2+z(ii)**2) - costhetax = x(ii)/r1 - costhetay = y(ii)/r1 - costhetaz = z(ii)/r1 - si(1) = -costhetax/rmi - si(2) = -costhetay/rmi - si(3) = -costhetaz/rmi - sj(1) = -costhetax/rmj - sj(2) = -costhetay/rmj - sj(3) = -costhetaz/rmj - sm(1) = -(si(1)+sj(1)) - sm(2) = -(si(2)+sj(2)) - sm(3) = -(si(3)+sj(3)) - ! - do ic = 1,3 - do jc = 1,3 - if (m .gt. i) then - hess(ind(ic,m,jc,i)) = hess(ind(ic,m,jc,i)) & - +gij*sm(ic)*si(jc) - else - hess(ind(ic,i,jc,m)) = hess(ind(ic,i,jc,m)) & - +gij*si(ic)*sm(jc) - end if - if (m .gt. j) then - hess(ind(ic,m,jc,j)) = hess(ind(ic,m,jc,j)) & - +gij*sm(ic)*sj(jc) - else - hess(ind(ic,j,jc,m)) = hess(ind(ic,j,jc,m)) & - +gij*sj(ic)*sm(jc) - end if - if (i .gt. j) then - hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j)) & - +gij*si(ic)*sj(jc) - else - hess(ind(ic,j,jc,i)) = hess(ind(ic,j,jc,i)) & - +gij*sj(ic)*si(jc) - end if - end do - end do - do ic = 1,3 - do jc = 1,ic - hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i)) & - +gij*si(ic)*si(jc) - hess(ind(ic,m,jc,m)) = hess(ind(ic,m,jc,m)) & - +gij*sm(ic)*sm(jc) - hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j)) & - +gij*sj(ic)*sj(jc) - end do - end do - end do - - end if - end if - - end do bend_jAt - end do bend_iAt - end do bend_mAt - - end subroutine mh_lindh_bend - - subroutine mh_lindh_torsion(n,at,xyz,hess,kt,kd,aav,rav,dav,lcutoff) - implicit none - - integer,intent(in) :: n - integer,intent(in) :: at(n) - real(wp),intent(in) :: xyz(3,n) - real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) - real(wp),intent(in) :: kt - real(wp),intent(in) :: kd - real(wp),intent(in) :: aav(3,3) - real(wp),intent(in) :: rav(3,3) - real(wp),intent(in) :: dav(3,3) - logical,intent(in) :: lcutoff(n,n) - - integer :: i,ir,j,jr,k,kr,l,lr,ic,jc,ij,kl -! allow only angles in the range of 35-145 - real(wp),parameter :: a35 = (35.0d0/180.d0)*pi - real(wp),parameter :: cosfi_max = cos(a35) - real(wp) :: txyz(3,4),c(3,4) - real(wp) :: rij(3),rij0,aij,rij2,d0ij,gij - real(wp) :: rjk(3),rjk0,ajk,rjk2,d0jk,gjk - real(wp) :: rkl(3),rkl0,akl,rkl2,d0kl,gkl - real(wp) :: cosfi2,cosfi3,cosfi4 - real(wp) :: beta,tij,tau,dum(3,4,3,4) - real(wp) :: si(3),sj(3),sk(3),sl(3) - -!! ------------------------------------------------------------------------ -! Hessian for torsion -!! ------------------------------------------------------------------------ - torsion_jAt: do j = 1,n - jr = itabrow(at(j)) - txyz(:,2) = xyz(:,j) - torsion_kAt: do k = 1,n - if (k .eq. j) cycle torsion_kAt - kr = itabrow(at(k)) - if (lcutoff(k,j)) cycle torsion_kAt - txyz(:,3) = xyz(:,k) - torsion_iAt: do i = 1,n - ij = n*(j-1)+i - if (i .eq. j) cycle torsion_iAt - if (i .eq. k) cycle torsion_iAt - ir = itabrow(at(i)) - if (lcutoff(i,k)) cycle torsion_iAt - if (lcutoff(i,j)) cycle torsion_iAt - - txyz(:,1) = xyz(:,i) - torsion_lAt: do l = 1,n - kl = n*(k-1)+l - if (ij .le. kl) cycle torsion_lAt - if (l .eq. i) cycle torsion_lAt - if (l .eq. j) cycle torsion_lAt - if (l .eq. k) cycle torsion_lAt - lr = itabrow(at(l)) -! - if (lcutoff(l,i)) cycle torsion_lAt - if (lcutoff(l,k)) cycle torsion_lAt - if (lcutoff(l,j)) cycle torsion_lAt - - txyz(:,4) = xyz(:,l) - - rij = xyz(:,i)-xyz(:,j) - d0ij = dav(ir,jr) - rij0 = rav(ir,jr) - aij = aav(ir,jr) - - rjk = xyz(:,j)-xyz(:,k) - d0jk = dav(jr,kr) - rjk0 = rav(jr,kr) - ajk = aav(jr,kr) - - rkl = xyz(:,k)-xyz(:,l) - d0kl = dav(kr,lr) - rkl0 = rav(kr,lr) - akl = aav(kr,lr) - - rij2 = sum(rij**2) - rjk2 = sum(rjk**2) - rkl2 = sum(rjk**2) - - cosfi2 = dot_product(rij,rjk)/sqrt(rij2*rjk2) - if (abs(cosfi2) .gt. cosfi_max) cycle - cosfi3 = dot_product(rkl,rjk)/sqrt(rkl2*rjk2) - if (abs(cosfi3) .gt. cosfi_max) cycle - - gij = fk_lindh(aij,rij0,rij2) & - +0.5_wp*kd*fk_vdw(4.0_wp,d0ij,rij2) - gjk = fk_lindh(ajk,rjk0,rjk2) & - +0.5_wp*kd*fk_vdw(4.0_wp,d0jk,rjk2) - gkl = fk_lindh(akl,rkl0,rkl2) & - +0.5_wp*kd*fk_vdw(4.0_wp,d0kl,rkl2) - - tij = kt*gij*gjk*gkl - - !tij = max(tij,10*min_fk) - - !call trsn2(txyz,tau,c) - Call Trsn(txyz,4,Tau,C,.False.,.False.,' ', & - & Dum,.False.) - si = c(:,1) - sj = c(:,2) - sk = c(:,3) - sl = c(:,4) - - ! off diagonal block - do ic = 1,3 - do jc = 1,3 - hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j))+tij*si(ic)*sj(jc) - hess(ind(ic,i,jc,k)) = hess(ind(ic,i,jc,k))+tij*si(ic)*sk(jc) - hess(ind(ic,i,jc,l)) = hess(ind(ic,i,jc,l))+tij*si(ic)*sl(jc) - hess(ind(ic,j,jc,k)) = hess(ind(ic,j,jc,k))+tij*sj(ic)*sk(jc) - hess(ind(ic,j,jc,l)) = hess(ind(ic,j,jc,l))+tij*sj(ic)*sl(jc) - hess(ind(ic,k,jc,l)) = hess(ind(ic,k,jc,l))+tij*sk(ic)*sl(jc) - end do - end do - - ! diagonal block - do ic = 1,3 - do jc = 1,ic - hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+tij*si(ic)*si(jc) - hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+tij*sj(ic)*sj(jc) - hess(ind(ic,k,jc,k)) = hess(ind(ic,k,jc,k))+tij*sk(ic)*sk(jc) - hess(ind(ic,l,jc,l)) = hess(ind(ic,l,jc,l))+tij*sl(ic)*sl(jc) - end do - end do - - end do torsion_lAt - end do torsion_iAt - end do torsion_kAt - end do torsion_jAt - - end subroutine mh_lindh_torsion - - pure subroutine mh_lindh_outofp(n,at,xyz,hess,ko,kd,aav,rav,dav,lcutoff) - implicit none - - integer,intent(in) :: n - integer,intent(in) :: at(n) - real(wp),intent(in) :: xyz(3,n) - real(wp),intent(inout) :: hess((3*n)*(3*n+1)/2) - real(wp),intent(in) :: ko - real(wp),intent(in) :: kd - real(wp),intent(in) :: aav(3,3) - real(wp),intent(in) :: rav(3,3) - real(wp),intent(in) :: dav(3,3) - logical,intent(in) :: lcutoff(n,n) - - integer :: i,ir,j,jr,k,kr,l,lr,ic,jc - real(wp) :: txyz(3,4),c(3,4) - real(wp) :: rij(3),rij0,aij,rij2,gij,d0ij - real(wp) :: rik(3),rik0,aik,rik2,gik,d0ik - real(wp) :: ril(3),ril0,ail,ril2,gil,d0il - real(wp) :: cosfi2,cosfi3,cosfi4 - real(wp) :: beta,tij,tau - real(wp) :: si(3),sj(3),sk(3),sl(3) - -!! ------------------------------------------------------------------------ -! Hessian for out-of-plane -!! ------------------------------------------------------------------------ - outofplane_iAt: do i = 1,n - ir = itabrow(at(i)) - txyz(:,4) = xyz(:,i) - outofplane_jAt: do j = 1,n - if (j .eq. i) cycle outofplane_jAt - if (lcutoff(j,i)) cycle outofplane_jAt - jr = itabrow(at(j)) - txyz(:,1) = xyz(:,j) - outofplane_kAt: do k = 1,n - if (i .eq. k) cycle outofplane_kAt - if (j .eq. k) cycle outofplane_kat - if (lcutoff(k,i)) cycle outofplane_kAt - if (lcutoff(k,j)) cycle outofplane_kAt - kr = itabrow(at(k)) - txyz(:,2) = xyz(:,k) - outofplane_lAt: do l = 1,n - lr = itabrow(at(l)) - txyz(:,3) = xyz(:,l) - if (l .eq. i) cycle outofplane_lAt - if (l .eq. j) cycle outofplane_lAt - if (l .eq. k) cycle outofplane_lAt - if (lcutoff(l,i)) cycle outofplane_lAt - if (lcutoff(l,k)) cycle outofplane_lAt - if (lcutoff(l,j)) cycle outofplane_lAt - - rij = xyz(:,i)-xyz(:,j) - d0ij = dav(ir,jr) - rij0 = rav(ir,jr) - aij = aav(ir,jr) - - rik = xyz(:,i)-xyz(:,k) - d0ik = dav(ir,kr) - rik0 = rav(ir,kr) - aik = aav(ir,kr) - - ril = xyz(:,i)-xyz(:,l) - d0il = dav(ir,lr) - ril0 = rav(ir,lr) - ail = aav(ir,lr) - - rij2 = sum(rij**2) - rik2 = sum(rik**2) - ril2 = sum(ril**2) - - cosfi2 = dot_product(rij,rik)/sqrt(rij2*rik2) - if (abs(abs(cosfi2)-1.0_wp) .lt. 1.0e-1_wp) cycle - cosfi3 = dot_product(rij,ril)/sqrt(rij2*ril2) - if (abs(abs(cosfi3)-1.0_wp) .lt. 1.0e-1_wp) cycle - cosfi4 = dot_product(rik,ril)/sqrt(rik2*ril2) - if (abs(abs(cosfi4)-1.0_wp) .lt. 1.0e-1_wp) cycle - - gij = fk_lindh(aij,rij0,rij2) & - +0.5_wp*kd*fk_vdw(4.0_wp,d0ij,rij2) - gik = fk_lindh(aik,rik0,rik2) & - +0.5_wp*kd*fk_vdw(4.0_wp,d0ik,rik2) - gil = fk_lindh(ail,ril0,ril2) & - +0.5_wp*kd*fk_vdw(4.0_wp,d0il,ril2) - - tij = ko*gij*gik*gil - - !tij = max(tij,10*min_fk) - - call outofp2(xyz,tau,c) - If (abs(tau) .gt. 45.0d0*(pi/180.d0)) cycle - - si = c(:,4) - sj = c(:,1) - sk = c(:,2) - sl = c(:,3) - - ! off diagonal block - do ic = 1,3 - do jc = 1,3 - hess(ind(ic,i,jc,j)) = hess(ind(ic,i,jc,j))+tij*si(ic)*sj(jc) - hess(ind(ic,i,jc,k)) = hess(ind(ic,i,jc,k))+tij*si(ic)*sk(jc) - hess(ind(ic,i,jc,l)) = hess(ind(ic,i,jc,l))+tij*si(ic)*sl(jc) - hess(ind(ic,j,jc,k)) = hess(ind(ic,j,jc,k))+tij*sj(ic)*sk(jc) - hess(ind(ic,j,jc,l)) = hess(ind(ic,j,jc,l))+tij*sj(ic)*sl(jc) - hess(ind(ic,k,jc,l)) = hess(ind(ic,k,jc,l))+tij*sk(ic)*sl(jc) - end do - end do - - ! diagonal block - do ic = 1,3 - do jc = 1,ic - hess(ind(ic,i,jc,i)) = hess(ind(ic,i,jc,i))+tij*si(ic)*si(jc) - hess(ind(ic,j,jc,j)) = hess(ind(ic,j,jc,j))+tij*sj(ic)*sj(jc) - hess(ind(ic,k,jc,k)) = hess(ind(ic,k,jc,k))+tij*sk(ic)*sk(jc) - hess(ind(ic,l,jc,l)) = hess(ind(ic,l,jc,l))+tij*sl(ic)*sl(jc) - end do - end do - - end do outofplane_lAt - end do outofplane_kAt - end do outofplane_jAt - end do outofplane_iAt - - end subroutine mh_lindh_outofp - -!========================================================================================! -!########################################################################################! -!========================================================================================! - - pure function rcutoff(xyz,katom,latom,rcut) - implicit none - logical :: rcutoff - real(wp),intent(in) :: xyz(3,*) - real(wp),intent(in) :: rcut - real(wp) :: rkl(3),rkl2 - integer,intent(in) :: katom,latom - rcutoff = .false. - rkl = xyz(:,kAtom)-xyz(:,lAtom) - rkl2 = sum(rkl**2) - if (rkl2 .gt. rcut) rcutoff = .true. - end function rcutoff - - pure elemental function itabrow(i) - integer :: itabrow - integer,intent(in) :: i - - itabrow = 0 - if (i .gt. 0.and.i .le. 2) then - itabrow = 1 - else if (i .gt. 2.and.i .le. 10) then - itabrow = 2 - else if (i .gt. 10.and.i .le. 18) then - itabrow = 3 - else if (i .gt. 18.and.i .le. 36) then - itabrow = 3 - else if (i .gt. 36.and.i .le. 54) then - itabrow = 3 - else if (i .gt. 54.and.i .le. 86) then - itabrow = 3 - else if (i .gt. 86) then - itabrow = 3 - end if - - return - end function itabrow - - pure subroutine getvdwxy(rx,ry,rz,c66,s6,r0,vdw) - !cc Ableitung nach rx und ry - implicit none - real(wp),intent(in) :: rx,ry,rz,c66,s6,r0 - real(wp),intent(out) :: vdw - real(wp) :: t1,t2,t3,t4,t5,t6,t7,t11,t12,t16,t17,t25,t26,t35 - real(wp) :: t40,t41,t43,t44,t56,avdw - - ! write(*,*) 's6:', s6 - avdw = 20.0 - t1 = s6*C66 - t2 = rx**2 - t3 = ry**2 - t4 = rz**2 - t5 = t2+t3+t4 - t6 = t5**2 - t7 = t6**2 - t11 = sqrt(t5) - t12 = 0.1D1/r0 - t16 = exp(-avdw*(t11*t12-0.1D1)) - t17 = 0.1D1+t16 - t25 = t17**2 - t26 = 0.1D1/t25 - t35 = 0.1D1/t7 - t40 = avdw**2 - t41 = r0**2 - t43 = t40/t41 - t44 = t16**2 - t56 = -0.48D2*t1/t7/t5/t17*rx*ry+0.13D2*t1/t11/& - & t7*t26*rx*avdw*t12*ry*t16-0.2D1*t1*t35/t25/& - &t17*t43*rx*t44*ry+t1*t35*t26*t43*rx*ry*t16 - vdw = t56 - return - end subroutine getvdwxy - - pure subroutine getvdwxx(rx,ry,rz,c66,s6,r0,vdw) - !cc Ableitung nach rx und rx - Implicit none - real(wp),intent(in) :: rx,ry,rz,c66,s6,r0 - real(wp),intent(out) :: vdw - real(wp) :: t1,t2,t3,t4,t5,t6,t7,t10,t11,t15,t16,t17,t24,t25,t29 - real(wp) :: t33,t41,t42,t44,t45,t62,avdw - avdw = 20.0 - ! write(*,*) 's6:', s6 - t1 = s6*C66 - t2 = rx**2 - t3 = ry**2 - t4 = rz**2 - t5 = t2+t3+t4 - t6 = t5**2 - t7 = t6**2 - t10 = sqrt(t5) - t11 = 0.1D1/r0 - t15 = exp(-avdw*(t10*t11-0.1D1)) - t16 = 0.1D1+t15 - t17 = 0.1D1/t16 - t24 = t16**2 - t25 = 0.1D1/t24 - t29 = t11*t15 - t33 = 0.1D1/t7 - t41 = avdw**2 - t42 = r0**2 - t44 = t41/t42 - t45 = t15**2 - t62 = -0.48D2*t1/t7/t5*t17*t2+0.13D2*t1/t10/t7*& - & t25*t2*avdw*t29+0.6D1*t1*t33*t17-0.2D1*t1*t33& - & /t24/t16*t44*t2*t45-t1/t10/t6/t5*t25*avdw*& - &t29+t1*t33*t25*t44*t2*t15 - vdw = t62 - end subroutine getvdwxx - - pure subroutine trsn2(xyz,tau,bt) - implicit none - real(wp),intent(out) :: bt(3,4) - real(wp),intent(out) :: tau - real(wp),intent(in) :: xyz(3,4) - real(wp) :: rij(3),rij1,brij(3,2) - real(wp) :: rjk(3),rjk1,brjk(3,2) - real(wp) :: rkl(3),rkl1,brkl(3,2) - real(wp) :: bf2(3,3),fi2,sinfi2,cosfi2 - real(wp) :: bf3(3,3),fi3,sinfi3,cosfi3 - real(wp) :: costau,sintau - integer :: ix,iy,iz - call strtch2(xyz(1,1),rij1,brij) - call strtch2(xyz(1,2),rjk1,brjk) - call strtch2(xyz(1,3),rkl1,brkl) - call bend2(xyz(1,1),fi2,bf2) - sinfi2 = sin(fi2) - cosfi2 = cos(fi2) - call bend2(xyz(1,2),fi3,bf3) - sinfi3 = sin(fi3) - cosfi3 = cos(fi3) - costau = ((brij(2,1)*brjk(3,2)-brij(3,1)*brjk(2,2))* & - (brjk(2,1)*brkl(3,2)-brjk(3,1)*brkl(2,2))+ & - (brij(3,1)*brjk(1,2)-brij(1,1)*brjk(3,2))* & - (brjk(3,1)*brkl(1,2)-brjk(1,1)*brkl(3,2))+ & - (brij(1,1)*brjk(2,2)-brij(2,1)*brjk(1,2))* & - (brjk(1,1)*brkl(2,2)-brjk(2,1)*brkl(1,2))) & - /(sinfi2*sinfi3) - sintau = (brij(1,2)*(brjk(2,1)*brkl(3,2)-brjk(3,1)*brkl(2,2)) & - +brij(2,2)*(brjk(3,1)*brkl(1,2)-brjk(1,1)*brkl(3,2)) & - +brij(3,2)*(brjk(1,1)*brkl(2,2)-brjk(2,1)*brkl(1,2))) & - /(sinfi2*sinfi3) - tau = atan2(sintau,costau) - if (abs(tau) .eq. pi) tau = pi - do ix = 1,3 - iy = ix+1 - if (iy .gt. 3) iy = iy-3 - iz = iy+1 - if (iz .gt. 3) iz = iz-3 - bt(ix,1) = (brij(iy,2)*brjk(iz,2)-brij(iz,2)*brjk(iy,2)) & - & /(rij1*sinfi2**2) - bt(ix,4) = (brkl(iy,1)*brjk(iz,1)-brkl(iz,1)*brjk(iy,1)) & - & /(rkl1*sinfi3**2) - bt(ix,2) = -((rjk1-rij1*cosfi2)*bt(ix,1) & - & +rkl1*cosfi3*bt(ix,4))/rjk1 - bt(ix,3) = -(bt(ix,1)+bt(ix,2)+bt(ix,4)) - end do - end subroutine trsn2 - pure subroutine strtch2(xyz,avst,b) - implicit none - real(wp),intent(out) :: b(3,2) - real(wp),intent(in) :: xyz(3,2) - real(wp) :: r(3) - real(wp) :: rr - real(wp),intent(out) :: avst - r = xyz(:,2)-xyz(:,1) - rr = norm2(r) - avst = rr - b(:,1) = -r/rr - b(:,2) = -b(:,1) - end subroutine strtch2 - pure subroutine bend2(xyz,fir,bf) - implicit none - real(wp),intent(out) :: bf(3,3) - real(wp),intent(in) :: xyz(3,3) - real(wp) :: brij(3,2) - real(wp) :: brjk(3,2) - real(wp) :: co,crap - real(wp),intent(out) :: fir - real(wp) :: si - real(wp) :: rij1,rjk1 - integer :: i - call strtch2(xyz(1,1),rij1,brij) - call strtch2(xyz(1,2),rjk1,brjk) - co = 0.0_wp - crap = 0.0_wp - do i = 1,3 - co = co+brij(i,1)*brjk(i,2) - crap = crap+(brjk(i,2)+brij(i,1))**2 - end do - if (sqrt(crap) .lt. 1.0d-6) then - fir = pi-asin(sqrt(crap)) - si = sqrt(crap) - else - fir = acos(co) - si = sqrt(1.0_wp-co**2) - end if - if (abs(fir-pi) .lt. 1.0d-13) then - fir = pi - return - end if - do i = 1,3 - bf(i,1) = (co*brij(i,1)-brjk(i,2))/(si*rij1) - bf(i,3) = (co*brjk(i,2)-brij(i,1))/(si*rjk1) - bf(i,2) = -(bf(i,1)+bf(i,3)) - end do - end subroutine bend2 - - pure subroutine outofp2(xyz,teta,bt) - implicit none - real(wp),intent(out) :: teta - real(wp),intent(out) :: bt(3,4) - real(wp),intent(in) :: xyz(3,4) - real(wp) :: r1(3),r2(3),r3(3) - real(wp) :: q41,q42,q43,e41(3),e42(3),e43(3) - real(wp) :: cosfi1,fi1,dfi1,cosfi2,fi2,dfi2,cosfi3,fi3,dfi3 - real(wp) :: c14(3,3),br14(3,3) - real(wp) :: r42(3),r43(3) - integer :: ix,iy,iz -! 4 -> 1 (bond) - r1 = xyz(:,1)-xyz(:,4) - q41 = norm2(r1) - e41 = r1/q41 -! 4 -> 2 (bond in plane) - r2 = xyz(:,2)-xyz(:,4) - q42 = norm2(r2) - e42 = r2/q42 -! 4 -> 3 (bond in plane) - r3 = xyz(:,3)-xyz(:,4) - q43 = norm2(r3) - e43 = r3/q43 -! -! get the angle between e43 and e42 -! - cosfi1 = dot_product(e43,e42) - - fi1 = acos(cosfi1) - dfi1 = 180.d0*fi1/pi -! -! dirty exit! this happens when an earlier structure is ill defined. -! - if (abs(fi1-pi) .lt. 1.0d-13) then - teta = 0.0_wp - bt = 0.0_wp - return - end if -! -! get the angle between e41 and e43 -! - cosfi2 = dot_product(e41,e43) - - fi2 = acos(cosfi2) - dfi2 = 180.d0*fi2/pi -! -! get the angle between e41 and e42 -! - cosfi3 = dot_product(e41,e42) - - fi3 = acos(cosfi3) - dfi3 = 180.d0*fi3/pi -! -! the first two centers are trivially -! - c14(:,1) = xyz(:,1) - c14(:,2) = xyz(:,4) -! -! the 3rd is -! - r42 = xyz(:,2)-xyz(:,4) - r43 = xyz(:,3)-xyz(:,4) - c14(1,3) = r42(2)*r43(3)-r42(3)*r43(2) - c14(2,3) = r42(3)*r43(1)-r42(1)*r43(3) - c14(3,3) = r42(1)*r43(2)-r42(2)*r43(1) -! -! exit if 2-3-4 are collinear -! (equivalent to the above check, but this is more concrete) -! - if ((c14(1,3)**2+c14(2,3)**2+c14(3,3)**2) .lt. 1.0d-10) then - teta = 0.0d0 - bt = 0.0_wp - return - end if - c14(1,3) = c14(1,3)+xyz(1,4) - c14(2,3) = c14(2,3)+xyz(2,4) - c14(3,3) = c14(3,3)+xyz(3,4) - - call bend2(c14,teta,br14) - - teta = teta-0.5_wp*pi -! -!--compute the wdc matrix -! - do ix = 1,3 - iy = mod(ix+1,4)+(ix+1)/4 - iz = mod(iy+1,4)+(iy+1)/4 - - bt(ix,1) = -br14(ix,1) - bt(ix,2) = r43(iz)*br14(iy,3)-r43(iy)*br14(iz,3) - bt(ix,3) = -r42(iz)*br14(iy,3)+r42(iy)*br14(iz,3) - - bt(ix,4) = -(bt(ix,1)+bt(ix,2)+bt(ix,3)) - - end do - - bt = -bt - end subroutine outofp2 - - Subroutine Trsn(xyz,nCent,Tau,Bt,lWrite,lWarn,Label,dBt,ldB) -!************************************************************************ -!* * -!* Reference: Molecular Vibrations, E. Bright Wilson, Jr, J. C. Decicius* -!* nd Paul C. Cross, Sec. 4-1, Eq. 20-24 * -!* * -!* R.Lindh May-June '96 * -!************************************************************************ - Implicit Real(wp) (a-h,o-z) - - integer :: nCent,mCent,i,j,ix,iy,iz,jx,jy,jz - Real(wp) Bt(3,nCent),xyz(3,nCent),Rij(3),Eij(3),Rjk(3),Ejk(3),& - & Rkl(3),Ekl(3),Rijk(3),Eijk(3),dBt(3,nCent,3,nCent),& - & BRij(3,2),dBRij(3,2,3,2),BRjk(3,2),dBRjk(3,2,3,2),& - & BRkl(3,2),dBRkl(3,2,3,2),Bf2(3,3),dum(3,4,3,4),& - & Bf3(3,3) - Logical :: lWrite,lWarn,ldB - Character(len=8) :: Label - ! - ! Call qEnter('Trsn') - mCent = 2 - Call Strtch(xyz(1,1),mCent,Rij1,BRij,.False.,Label,dBRij,ldB) - Call Strtch(xyz(1,2),mCent,Rjk1,BRjk,.False.,Label,dBRjk,ldB) - Call Strtch(xyz(1,3),mCent,Rkl1,BRkl,.False.,Label,dBRkl,ldB) - mCent = 3 - Call Bend(xyz(1,1),mCent,Fi2,Bf2,.False.,.False.,Label,Dum,& - & .False.) - SinFi2 = Sin(Fi2) - CosFi2 = Cos(Fi2) - Call Bend(xyz(1,2),mCent,Fi3,Bf3,.False.,.False.,Label,Dum,& - & .False.) - SinFi3 = Sin(Fi3) - CosFi3 = Cos(Fi3) - ! - ! Get the angle between the two planes, i.e. the - ! angle between the normal vectors. - ! - ! r123 * r234 = CosTau - ! - CosTau = ((BRij(2,1)*BRjk(3,2)-BRij(3,1)*BRjk(2,2))*& - & (BRjk(2,1)*BRkl(3,2)-BRjk(3,1)*BRkl(2,2))+& - & (BRij(3,1)*BRjk(1,2)-BRij(1,1)*BRjk(3,2))*& - & (BRjk(3,1)*BRkl(1,2)-BRjk(1,1)*BRkl(3,2))+& - & (BRij(1,1)*BRjk(2,2)-BRij(2,1)*BRjk(1,2))*& - & (BRjk(1,1)*BRkl(2,2)-BRjk(2,1)*BRkl(1,2)))& - & /(SinFi2*SinFi3) - ! - ! For the vector product of the two vectors. This - ! will give a vector parallell to e23. The direction - ! relative to e23 defines the sign. - ! - ! e123 X e234 = SinTau * e23 - ! - SinTau = (BRij(1,2)*(BRjk(2,1)*BRkl(3,2)-BRjk(3,1)*BRkl(2,2))& - & +BRij(2,2)*(BRjk(3,1)*BRkl(1,2)-BRjk(1,1)*BRkl(3,2))& - & +BRij(3,2)*(BRjk(1,1)*BRkl(2,2)-BRjk(2,1)*BRkl(1,2)))& - & /(SinFi2*SinFi3) - ! - ! (-Pi < Tau <= Pi) - ! - Tau = ATan2(SinTau,CosTau) - If (Abs(Tau) .eq. Pi) Tau = Pi - ! - dTau = 180.0D+00*Tau/Pi - dFi2 = 180.0D+00*Fi2/Pi - dFi3 = 180.0D+00*Fi3/Pi - If (lWarn) Then - If (dTau .gt. 177.5.or.dTau .lt. -177.5) Then - Write (*,*) ' Warning: dihedral angle close to'& - & //' end of range' - End If - If (dFi2 .gt. 177.5.or.dFi2 .lt. 2.5) Then - Write (*,*) ' Warning: bond angle close to'& - & //' end of range' - End If - If (dFi3 .gt. 177.5.or.dFi3 .lt. 2.5) Then - Write (*,*) ' Warning: bond angle close to'& - & //' end of range' - End If - End If - If (LWRITE) Write (*,1) Label,dTau,Tau -1 FORMAT(1X,A,' : Dihedral Angle=',F10.4,& - & '/degree,',F10.4,'/rad') - ! - !---- Compute the WDC matrix. - ! - Do ix = 1,3 - iy = ix+1 - If (iy .gt. 3) iy = iy-3 - iz = iy+1 - If (iz .gt. 3) iz = iz-3 - Bt(ix,1) = (BRij(iy,2)*BRjk(iz,2)-BRij(iz,2)*BRjk(iy,2))& - & /(Rij1*SinFi2**2) - Bt(ix,4) = (BRkl(iy,1)*BRjk(iz,1)-BRkl(iz,1)*BRjk(iy,1))& - & /(Rkl1*SinFi3**2) - Bt(ix,2) = -((Rjk1-Rij1*CosFi2)*Bt(ix,1)& - & +Rkl1*CosFi3*Bt(ix,4))/Rjk1 - Bt(ix,3) = -(Bt(ix,1)+Bt(ix,2)+Bt(ix,4)) - End Do - ! - If (ldB) Then - ! - !------- Compute the derivative of the WDC matrix. - ! - Do ix = 1,3 - iy = ix+1 - If (iy .gt. 3) iy = iy-3 - iz = iy+1 - If (iz .gt. 3) iz = iz-3 - Do jx = 1,ix - jy = jx+1 - If (jy .gt. 3) jy = jy-3 - jz = jy+1 - If (jz .gt. 3) jz = jz-3 - ! - dBt(ix,1,jx,1) = (dBRij(ix,1,jy,2)*BRjk(jz,2)& - & -dBRij(ix,1,jz,2)*BRjk(jy,2)& - & -Bt(jx,1)*(BRij(ix,1)*SinFi2**2& - & +Rij1*Two*SinFi2*CosFi2*Bf2(ix,1)))& - & /(Rij1*SinFi2**2) - dBt(ix,1,jx,2) = -((-BRij(ix,1)*CosFi2& - & +Rij1*SinFi2*Bf2(ix,1))*Bt(jx,1)& - & +(Rjk1-Rij1*CosFi2)*dBt(ix,1,jx,1))& - & /Rjk1 - dBt(jx,2,ix,1) = dBt(ix,1,jx,2) - dBt(ix,1,jx,4) = Zero - dBt(jx,4,ix,1) = dBt(ix,1,jx,4) - dBt(ix,1,jx,3) = -(dBt(ix,1,jx,1)+dBt(ix,1,jx,2)) - dBt(jx,3,ix,1) = dBt(ix,1,jx,3) - dBt(ix,4,jx,4) = (dBRkl(ix,2,jy,1)*BRjk(jz,1)& - & -dBRkl(ix,2,jz,1)*BRjk(jy,1)& - & -Bt(jx,4)*(BRkl(ix,2)*SinFi3**2& - & +Rkl1*Two*SinFi3*CosFi3*Bf3(ix,3)))& - & /(Rkl1*SinFi3**2) - dBt(ix,4,jx,3) = -((-BRkl(ix,2)*CosFi3& - & +Rkl1*SinFi3*Bf3(ix,3))*Bt(jx,4)& - & +(Rjk1-Rkl1*CosFi3)*dBt(ix,4,jx,4))& - & /Rjk1 - dBt(jx,3,ix,4) = dBt(ix,4,jx,3) - dBt(ix,4,jx,2) = -(dBt(ix,4,jx,4)+dBt(ix,4,jx,3)) - dBt(jx,2,ix,4) = dBt(ix,4,jx,2) - If (ix .ne. jx) Then - dBt(jx,1,ix,1) = dBt(ix,1,jx,1) - dBt(ix,4,jx,1) = Zero - dBt(jx,4,ix,4) = dBt(ix,4,jx,4) - dBt(jx,1,ix,4) = dBt(ix,4,jx,1) - dBt(jx,1,ix,2) = -((-BRij(jx,1)*CosFi2& - & +Rij1*SinFi2*Bf2(jx,1))*Bt(ix,1)& - & +(Rjk1-Rij1*CosFi2)*dBt(jx,1,ix,1))& - & /Rjk1 - dBt(ix,2,jx,1) = dBt(jx,1,ix,2) - dBt(ix,3,jx,1) = -(dBt(ix,1,jx,1)+dBt(ix,2,jx,1)& - & +dBt(ix,4,jx,1)) - dBt(jx,1,ix,3) = dBt(ix,3,jx,1) - dBt(jx,4,ix,3) = -((-BRkl(jx,2)*CosFi3& - & +Rkl1*SinFi3*Bf3(jx,3))*Bt(ix,4)& - & +(Rjk1-Rkl1*CosFi3)*dBt(jx,4,ix,4))& - & /Rjk1 - dBt(ix,3,jx,4) = dBt(jx,4,ix,3) - dBt(ix,2,jx,4) = -(dBt(ix,4,jx,4)+dBt(ix,3,jx,4)) - dBt(jx,4,ix,2) = dBt(ix,2,jx,4) - End If - dBt(ix,2,jx,3) = -((BRjk(ix,1)& - & +Rkl1*SinFi3*Bf3(ix,1))*Bt(jx,4)& - & +(Rjk1-Rkl1*CosFi3)*dBt(ix,2,jx,4)& - & +(BRij(ix,2)*CosFi2& - & -Rij1*SinFi2*Bf2(ix,2))*Bt(jx,1)& - & +Rij1*CosFi2*dBt(ix,2,jx,1)& - & +Bt(jx,3)*BRjk(ix,1))/Rjk1 - dBt(jx,3,ix,2) = dBt(ix,2,jx,3) - dBt(ix,2,jx,2) = -(dBt(ix,2,jx,1)+dBt(ix,2,jx,4)& - & +dBt(ix,2,jx,3)) - dBt(ix,3,jx,3) = -(dBt(ix,2,jx,3)+dBt(ix,1,jx,3)& - & +dBt(ix,4,jx,3)) - If (ix .ne. jx) Then - dBt(ix,3,jx,2) = -(dBt(ix,2,jx,2)+dBt(ix,1,jx,2)& - & +dBt(ix,4,jx,2)) - dBt(jx,2,ix,3) = dBt(ix,3,jx,2) - dBt(jx,2,ix,2) = dBt(ix,2,jx,2) - dBt(jx,3,ix,3) = dBt(ix,3,jx,3) - End If - ! - End Do - End Do - ! - End If - ! Call qExit('Trsn') - Return - contains - Subroutine Strtch(xyz,nCent,Avst,B,lWrite,Label,dB,ldB) - Implicit Real(wp) (a-h,o-z) - ! include "common/real.inc" - !comdeck real.inc $Revision: 2002.3 $ - Real(wp) :: Zero,One,Two,Three,Four,Five,Six,Seven,& - & Eight,RNine,Ten,Half,Pi,SqrtP2,TwoP34,& - & TwoP54,One2C2 - Parameter(Zero=0.0D0,One=1.0D0,Two=2.0D0,Three=3.0D0,& - & Four=4.0D0,Five=5.0D0,Six=6.0D0,Seven=7.0D0,& - & Eight=8.0D0,rNine=9.0D0,Ten=1.0D1,Half=0.5D0,& - & Pi=3.141592653589793D0,& - & SqrtP2=0.8862269254527579D0,& - & TwoP34=0.2519794355383808D0,& - & TwoP54=5.914967172795612D0,& - & One2C2=0.2662567690426443D-04) - - integer :: nCent - Real(wp) :: B(3,nCent),xyz(3,nCent),dB(3,nCent,3,nCent),R(3) - Logical :: lWrite,ldB - Character(len=8) :: Label - ! include "common/angstr.inc" - !comdeck angstr.inc $Revision: 2002.3 $ - ! - ! Conversion factor angstrom to bohr from the IUPAC - ! publication - ! .529177249(24) angstrom / bohr - ! "Quantities, Units and Symbols in Physical Chemistry" - ! I. Mills, T. Cvitas, K. Homann, N. Kallay and - ! K. Kuchitsu, Blackwell Scientific Publications, - ! Oxford, 1988. - ! - Data Angstr/0.529177249D+00/ - ! - R(1) = xyz(1,2)-xyz(1,1) - R(2) = xyz(2,2)-xyz(2,1) - R(3) = xyz(3,2)-xyz(3,1) - R2 = R(1)**2+R(2)**2+R(3)**2 - RR = Sqrt(R2) - Avst = RR - ! - aRR = RR*Angstr - If (lWrite) Write (*,'(1X,A,A,2(F10.6,A))') Label,& - & ' : Bond Length=',aRR,' / Angstrom',RR,' / bohr' - ! - !---- Compute the WDC B-matrix. - ! - B(1,1) = -R(1)/RR - B(2,1) = -R(2)/RR - B(3,1) = -R(3)/RR - !.... Utilize translational invariance. - B(1,2) = -B(1,1) - B(2,2) = -B(2,1) - B(3,2) = -B(3,1) - ! - !---- Compute the cartesian derivative of the B-matrix. - ! - If (ldB) Then - ! - Do i = 1,3 - Do j = 1,i - If (i .eq. j) Then - dB(i,1,j,1) = (One-B(j,1)*B(i,1))/RR - Else - dB(i,1,j,1) = (-B(j,1)*B(i,1))/RR - End If - dB(j,1,i,1) = dB(i,1,j,1) - ! - dB(i,2,j,1) = -dB(i,1,j,1) - dB(j,1,i,2) = dB(i,2,j,1) - ! - dB(i,1,j,2) = -dB(i,1,j,1) - dB(j,2,i,1) = dB(i,1,j,2) - ! - dB(i,2,j,2) = -dB(i,2,j,1) - dB(j,2,i,2) = dB(i,2,j,2) - End Do - End Do - ! - End If - ! Call qExit('Strtch') - ! Call GetMem('Exit Strtch','Chec','Real',ipMass,2*msAtom) - Return - End subroutine strtch - Subroutine Bend(xyz,nCent,Fir,Bf,lWrite,lWarn,Label,dBf,ldB) - Implicit Real(wp) (a-h,o-z) - - integer :: nCent - !Real(wp) :: Bf(3,nCent),xyz(3,nCent),dBf(3,nCent,3,nCent),& - Real(wp) :: Bf(3,3),xyz(3,nCent),dBf(3,nCent,3,nCent),& - & BRij(3,2),dBRij(3,2,3,2),& - & BRjk(3,2),dBRjk(3,2,3,2) - Logical lWrite,ldB,lWarn - Character(len=8) :: Label - ! - ! Call QEnter('Bend') - ! - mCent = 2 - Call Strtch(xyz(1,1),mCent,Rij1,BRij,.False.,Label,dBRij,ldB) - Call Strtch(xyz(1,2),mCent,Rjk1,BRjk,.False.,Label,dBRjk,ldB) - Co = Zero - Crap = Zero - Do i = 1,3 - Co = Co+BRij(i,1)*BRjk(i,2) - Crap = Crap+(BRjk(i,2)+BRij(i,1))**2 - End Do - ! - !.... Special care for cases close to linearity - ! - If (Sqrt(Crap) .lt. 1.0D-6) Then - Fir = Pi-ArSin(Sqrt(Crap)) - Si = Sqrt(Crap) - Else - Fir = ArCos(Co) - Si = Sqrt(One-Co**2) - End If - ! - If (Abs(Fir-Pi) .lt. 1.0d-13) Then - Fir = Pi - Return - End If - dFir = 180.0D0*Fir/Pi - If ((Abs(dFir) .gt. 177.5.or.Abs(dFir) .lt. 2.5).and.lWarn)& - & Write (*,*) ' Valence angle close to end in '//& - & 'range of definition' - If (lWrite) Write (*,'(1X,A,A,F10.4,A,F10.6,A)') Label,& - & ' : Angle=',dFir,'/degree, ',Fir,'/rad' - ! - !---- Compute the WDC B-matrix - ! - ! Bf=-11.1111 - Do i = 1,3 - Bf(i,1) = (Co*BRij(i,1)-BRjk(i,2))/(Si*Rij1) - Bf(i,3) = (Co*BRjk(i,2)-BRij(i,1))/(Si*Rjk1) - !....... Utilize translational invariance. - Bf(i,2) = -(Bf(i,1)+Bf(i,3)) - End Do - ! Call RecPrt('Bf',' ',Bf,9,1) - ! - !---- Compute the cartesian derivative of the B-Matrix. - ! - If (ldB) Then - ! - ! dBf=-11.11111 - Do i = 1,3 - Do j = 1,i - dBf(i,1,j,1) = (-Si*Bf(i,1)*BRij(j,1)& - & +Co*dBRij(i,1,j,1)& - & -Bf(j,1)*(Co*Bf(i,1)*Rij1& - & +Si*BRij(i,1)))/(Si*Rij1) - dBf(i,1,j,3) = (-Si*Bf(i,1)*BRjk(j,2)& - & +dBRij(i,1,j,2)& - & -Bf(j,3)*Co*Bf(i,1)*Rjk1)& - & /(Si*Rjk1) - ! Write (*,*) '13',dBf(i,1,j,3), i, j - dBf(i,3,j,1) = (-Si*Bf(i,3)*BRij(j,1)& - & +dBRjk(i,2,j,1)& - & -Bf(j,1)*Co*Bf(i,3)*Rij1)& - & /(Si*Rij1) - dBf(i,3,j,3) = (-Si*Bf(i,3)*BRjk(j,2)& - & +Co*dBRjk(i,2,j,2)& - & -Bf(j,3)*(Co*Bf(i,3)*Rjk1& - & +Si*BRjk(i,2)))/(Si*Rjk1) - ! - dBf(j,1,i,1) = dBf(i,1,j,1) - dBf(j,3,i,1) = dBf(i,1,j,3) - dBf(j,1,i,3) = dBf(i,3,j,1) - dBf(j,3,i,3) = dBf(i,3,j,3) - ! - dBf(i,1,j,2) = -(dBf(i,1,j,1)+dBf(i,1,j,3)) - dBf(j,2,i,1) = dBf(i,1,j,2) - dBf(j,1,i,2) = -(dBf(j,1,i,1)+dBf(j,1,i,3)) - dBf(i,2,j,1) = dBf(j,1,i,2) - dBf(i,3,j,2) = -(dBf(i,3,j,1)+dBf(i,3,j,3)) - dBf(j,2,i,3) = dBf(i,3,j,2) - dBf(j,3,i,2) = -(dBf(j,3,i,1)+dBf(j,3,i,3)) - dBf(i,2,j,3) = dBf(j,3,i,2) - ! - dBf(i,2,j,2) = -(dBf(i,2,j,1)+dBf(i,2,j,3)) - dBf(j,2,i,2) = dBf(i,2,j,2) - ! - End Do - End Do - ! Call RecPrt('dBf','(9F9.1)',dBf,9,9) - ! - End If - ! - ! Call QExit('Bend') - Return - End subroutine bend - Function arSin(Arg) - Implicit Real*8(a-h,o-z) - Real*8 ArSin - - A = Arg - IF (ABS(A) .GT. One) Then - PRINT 3,A -3 FORMAT(1X,'Warning argument of aSin= ',1F21.18) - A = Sign(One,A) - End If - ! - ArSin = ASin(A) - Return - End function arSin - Function arCos(Arg) - Implicit Real(wp) (a-h,o-z) - Real(wp) :: ArCos - A = Arg - IF (ABS(A) .GT. One) Then - A = Sign(One,A) - End If - ArCos = ACos(A) - Return - End function arCos - End subroutine trsn - - pure elemental function ixyz(i,iatom) - integer :: ixyz - integer,intent(in) :: i,iatom - ixyz = (iatom-1)*3+i - end function ixyz - pure elemental function jnd(i,j) - integer :: jnd - integer,intent(in) :: i,j - jnd = i*(i-1)/2+j - end function jnd - pure elemental function ind(i,iatom,j,jatom) - integer :: ind - integer,intent(in) :: i,iatom,j,jatom - ind = jnd(max(ixyz(i,iatom),ixyz(j,jatom)),min(ixyz(i,iatom),ixyz(j,jatom))) - end function ind - - pure elemental function fk_lindh(alpha,r0,r2) result(gmm) - implicit none - real(wp),intent(in) :: alpha,r0,r2 - real(wp) :: gmm - gmm = exp(alpha*(r0**2-r2)) - end function fk_lindh - - pure elemental function fk_swart(alpha,r0,r2) result(gmm) - implicit none - real(wp),intent(in) :: alpha,r0,r2 - real(wp) :: gmm - gmm = exp(-alpha*(sqrt(r2)/r0-1.0_wp)) - end function fk_swart - - pure elemental function fk_vdw(alpha,r0,r2) result(gmm) - implicit none - real(wp),intent(in) :: alpha,r0,r2 - real(wp) :: gmm - gmm = exp(-alpha*(r0-sqrt(r2))**2) - end function fk_vdw - -!========================================================================================! -!########################################################################################! -!========================================================================================! - - subroutine mh_eeq(n,at,xyz,chrg,kq,hess) - implicit none - -!! ------------------------------------------------------------------------ -! Input -!! ------------------------------------------------------------------------ - integer,intent(in) :: n ! number of atoms - integer,intent(in) :: at(n) ! ordinal numbers - real(wp),intent(in) :: xyz(3,n) ! geometry - real(wp),intent(in) :: chrg ! total charge - real(wp),intent(in) :: kq ! scaling parameter -! type(chrg_parameter),intent(in) :: chrgeq ! charge model -!! ------------------------------------------------------------------------ -! Output -!! ------------------------------------------------------------------------ - real(wp),intent(out) :: hess((3*n)*(3*n+1)/2) - real(wp),allocatable :: hessian(:,:,:,:) ! molecular hessian of IES - -! π itself - real(wp),parameter :: pi = 3.1415926535897932384626433832795029_wp -! √π - real(wp),parameter :: sqrtpi = sqrt(pi) -! √(2/π) - real(wp),parameter :: sqrt2pi = sqrt(2.0_wp/pi) -! -!! ------------------------------------------------------------------------ -! charge model -!! ------------------------------------------------------------------------ - integer :: m ! dimension of the Lagrangian - real(wp),allocatable :: Amat(:,:) - real(wp),allocatable :: Xvec(:) - real(wp),allocatable :: Ainv(:,:) - real(wp),allocatable :: dAmat(:,:,:) - real(wp),allocatable :: dqdr(:,:,:) - -!! ------------------------------------------------------------------------ -! local variables -!! ------------------------------------------------------------------------ - integer :: i,j,k,l - real(wp) :: r,rij(3),r2 - real(wp) :: gamij,gamij2 - real(wp) :: arg,arg2,tmp,dtmp - real(wp) :: lambda - real(wp) :: es,expterm,erfterm - real(wp) :: htmp,rxr(3,3) - real(wp) :: rcovij,rr - -!! ------------------------------------------------------------------------ -! scratch variables -!! ------------------------------------------------------------------------ - real(wp),allocatable :: alpha(:) - real(wp),allocatable :: xtmp(:) - real(wp),allocatable :: atmp(:,:) - -!! ------------------------------------------------------------------------ -! Lapack work variables -!! ------------------------------------------------------------------------ - integer,allocatable :: ipiv(:) - real(wp),allocatable :: temp(:) - real(wp),allocatable :: work(:) - integer :: lwork - integer :: info - real(wp) :: test(1) - -!! ------------------------------------------------------------------------ -! EEQ parameters -! PARAMETRISATION BY S. SPICHER (Fri, 14 Dec 2018 16:13:08 +0100) -!! ------------------------------------------------------------------------ - integer,parameter :: max_elem = 86 -!&< - real(wp),parameter :: enparam(max_elem) = (/ & - 1.23695041_wp, 1.26590957_wp, 0.54341808_wp, 0.99666991_wp, 1.26691604_wp, & - 1.40028282_wp, 1.55819364_wp, 1.56866440_wp, 1.57540015_wp, 1.15056627_wp, & - 0.55936220_wp, 0.72373742_wp, 1.12910844_wp, 1.12306840_wp, 1.52672442_wp, & - 1.40768172_wp, 1.48154584_wp, 1.31062963_wp, 0.40374140_wp, 0.75442607_wp, & - 0.76482096_wp, 0.98457281_wp, 0.96702598_wp, 1.05266584_wp, 0.93274875_wp, & - 1.04025281_wp, 0.92738624_wp, 1.07419210_wp, 1.07900668_wp, 1.04712861_wp, & - 1.15018618_wp, 1.15388455_wp, 1.36313743_wp, 1.36485106_wp, 1.39801837_wp, & - 1.18695346_wp, 0.36273870_wp, 0.58797255_wp, 0.71961946_wp, 0.96158233_wp, & - 0.89585296_wp, 0.81360499_wp, 1.00794665_wp, 0.92613682_wp, 1.09152285_wp, & - 1.14907070_wp, 1.13508911_wp, 1.08853785_wp, 1.11005982_wp, 1.12452195_wp, & - 1.21642129_wp, 1.36507125_wp, 1.40340000_wp, 1.16653482_wp, 0.34125098_wp, & - 0.58884173_wp, 0.68441115_wp, 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, & - 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, & - 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, 0.56999999_wp, & - 0.56999999_wp, 0.87936784_wp, 1.02761808_wp, 0.93297476_wp, 1.10172128_wp, & - 0.97350071_wp, 1.16695666_wp, 1.23997927_wp, 1.18464453_wp, 1.14191734_wp, & - 1.12334192_wp, 1.01485321_wp, 1.12950808_wp, 1.30804834_wp, 1.33689961_wp, & - 1.27465977_wp /) - real(wp),parameter :: gamparam(max_elem) = (/ & - -0.35015861_wp, 1.04121227_wp, 0.09281243_wp, 0.09412380_wp, 0.26629137_wp, & - 0.19408787_wp, 0.05317918_wp, 0.03151644_wp, 0.32275132_wp, 1.30996037_wp, & - 0.24206510_wp, 0.04147733_wp, 0.11634126_wp, 0.13155266_wp, 0.15350650_wp, & - 0.15250997_wp, 0.17523529_wp, 0.28774450_wp, 0.42937314_wp, 0.01896455_wp, & - 0.07179178_wp,-0.01121381_wp,-0.03093370_wp, 0.02716319_wp,-0.01843812_wp, & - -0.15270393_wp,-0.09192645_wp,-0.13418723_wp,-0.09861139_wp, 0.18338109_wp, & - 0.08299615_wp, 0.11370033_wp, 0.19005278_wp, 0.10980677_wp, 0.12327841_wp, & - 0.25345554_wp, 0.58615231_wp, 0.16093861_wp, 0.04548530_wp,-0.02478645_wp, & - 0.01909943_wp, 0.01402541_wp,-0.03595279_wp, 0.01137752_wp,-0.03697213_wp, & - 0.08009416_wp, 0.02274892_wp, 0.12801822_wp,-0.02078702_wp, 0.05284319_wp, & - 0.07581190_wp, 0.09663758_wp, 0.09547417_wp, 0.07803344_wp, 0.64913257_wp, & - 0.15348654_wp, 0.05054344_wp, 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, & - 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, & - 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, 0.11000000_wp, & - 0.11000000_wp,-0.02786741_wp, 0.01057858_wp,-0.03892226_wp,-0.04574364_wp, & - -0.03874080_wp,-0.03782372_wp,-0.07046855_wp, 0.09546597_wp, 0.21953269_wp, & - 0.02522348_wp, 0.15263050_wp, 0.08042611_wp, 0.01878626_wp, 0.08715453_wp, & - 0.10500484_wp /) - real(wp),parameter :: kappa(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, & - 0.07126660_wp, 0.13682750_wp, 0.14877121_wp,-0.10219289_wp,-0.08979338_wp, & - -0.08273597_wp,-0.01754829_wp,-0.02765460_wp,-0.02558926_wp,-0.08010286_wp, & - -0.04163215_wp,-0.09369631_wp,-0.03774117_wp,-0.05759708_wp, 0.02431998_wp, & - -0.01056270_wp,-0.02692862_wp, 0.07657769_wp, 0.06561608_wp, 0.08006749_wp, & - 0.14139200_wp,-0.05351029_wp,-0.06701705_wp,-0.07377246_wp,-0.02927768_wp, & - -0.03867291_wp,-0.06929825_wp,-0.04485293_wp,-0.04800824_wp,-0.01484022_wp, & - 0.07917502_wp, 0.06619243_wp, 0.02434095_wp,-0.01505548_wp,-0.03030768_wp, & - 0.01418235_wp, 0.08953411_wp, 0.08967527_wp, 0.07277771_wp,-0.02129476_wp, & - -0.06188828_wp,-0.06568203_wp,-0.11000000_wp,-0.11000000_wp,-0.11000000_wp, & - -0.11000000_wp,-0.11000000_wp,-0.11000000_wp,-0.11000000_wp,-0.11000000_wp, & - -0.11000000_wp,-0.11000000_wp,-0.11000000_wp,-0.11000000_wp,-0.11000000_wp, & - -0.11000000_wp,-0.03585873_wp,-0.03132400_wp,-0.05902379_wp,-0.02827592_wp, & - -0.07606260_wp,-0.02123839_wp, 0.03814822_wp, 0.02146834_wp, 0.01580538_wp, & - -0.00894298_wp,-0.05864876_wp,-0.01817842_wp, 0.07721851_wp, 0.07936083_wp, & - 0.05849285_wp /) - real(wp),parameter :: alphaparam(max_elem) = (/ & - 0.55159092_wp, 0.66205886_wp, 0.90529132_wp, 1.51710827_wp, 2.86070364_wp, & - 1.88862966_wp, 1.32250290_wp, 1.23166285_wp, 1.77503721_wp, 1.11955204_wp, & - 1.28263182_wp, 1.22344336_wp, 1.70936266_wp, 1.54075036_wp, 1.38200579_wp, & - 2.18849322_wp, 1.36779065_wp, 1.27039703_wp, 1.64466502_wp, 1.58859404_wp, & - 1.65357953_wp, 1.50021521_wp, 1.30104175_wp, 1.46301827_wp, 1.32928147_wp, & - 1.02766713_wp, 1.02291377_wp, 0.94343886_wp, 1.14881311_wp, 1.47080755_wp, & - 1.76901636_wp, 1.98724061_wp, 2.41244711_wp, 2.26739524_wp, 2.95378999_wp, & - 1.20807752_wp, 1.65941046_wp, 1.62733880_wp, 1.61344972_wp, 1.63220728_wp, & - 1.60899928_wp, 1.43501286_wp, 1.54559205_wp, 1.32663678_wp, 1.37644152_wp, & - 1.36051851_wp, 1.23395526_wp, 1.65734544_wp, 1.53895240_wp, 1.97542736_wp, & - 1.97636542_wp, 2.05432381_wp, 3.80138135_wp, 1.43893803_wp, 1.75505957_wp, & - 1.59815118_wp, 1.76401732_wp, 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, & - 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, & - 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, 1.63999999_wp, & - 1.63999999_wp, 1.47055223_wp, 1.81127084_wp, 1.40189963_wp, 1.54015481_wp, & - 1.33721475_wp, 1.57165422_wp, 1.04815857_wp, 1.78342098_wp, 2.79106396_wp, & - 1.78160840_wp, 2.47588882_wp, 2.37670734_wp, 1.76613217_wp, 2.66172302_wp, & - 2.82773085_wp /) -!&> - -!! ------------------------------------------------------------------------ -! initizialization -!! ------------------------------------------------------------------------ - m = n+1 - allocate (ipiv(m),source=0) - allocate (Amat(m,m),Xvec(m),alpha(n),dqdr(3,n,m),source=0.0_wp) - -!! ------------------------------------------------------------------------ -! set up the A matrix and X vector -!! ------------------------------------------------------------------------ -! αi -> alpha(i), ENi -> xi(i), κi -> kappa(i), Jii -> gam(i) -! γij = 1/√(αi+αj) -! Xi = -ENi + κi·√CNi -! Aii = Jii + 2/√π·γii -! Aij = erf(γij·Rij)/Rij = 2/√π·F0(γ²ij·R²ij) -!! ------------------------------------------------------------------------ -! prepare some arrays -!$omp parallel default(none) & -!!$omp shared(n,at,chrgeq) & -!$omp shared(n,at) & -!$omp private(i) & -!$omp shared(Xvec,alpha) -!$omp do schedule(dynamic) - do i = 1,n -! Xvec(i) = -chrgeq%en(i) -! alpha(i) = chrgeq%alpha(i)**2 - Xvec(i) = -enparam(at(i)) - alpha(i) = alphaparam(at(i))**2 - end do -!$omp enddo -!$omp endparallel - -!$omp parallel default(none) & -!!$omp shared(n,at,xyz,chrgeq,alpha) & -!$omp shared(n,at,xyz,alpha) & -!$omp private(i,j,r,gamij) & -!$omp shared(Amat) -!$omp do schedule(dynamic) - ! prepare A matrix - do i = 1,n - ! EN of atom i - do j = 1,i-1 - r = sqrt(sum((xyz(:,j)-xyz(:,i))**2)) - gamij = 1.0_wp/sqrt(alpha(i)+alpha(j)) - Amat(j,i) = erf(gamij*r)/r - Amat(i,j) = Amat(j,i) - end do -! Amat(i,i) = chrgeq%gam(i)+sqrt2pi/sqrt(alpha(i)) - Amat(i,i) = gamparam(at(i))+sqrt2pi/sqrt(alpha(i)) - end do -!$omp enddo -!$omp endparallel - -!! ------------------------------------------------------------------------ -! solve the linear equations to obtain partial charges -!! ------------------------------------------------------------------------ - Amat(m,1:m) = 1.0_wp - Amat(1:m,m) = 1.0_wp - Amat(m,m) = 0.0_wp - Xvec(m) = chrg - ! generate temporary copy - allocate (Atmp(m,m),source=Amat) - allocate (Xtmp(m),source=Xvec) - - ! assume work space query, set best value to test after first dsysv call - call dsysv('u',m,1,Atmp,m,ipiv,Xtmp,m,test,-1,info) - lwork = int(test(1)) - allocate (work(lwork),source=0.0_wp) - - call dsysv('u',m,1,Atmp,m,ipiv,Xtmp,m,work,lwork,info) - if (info > 0) error stop '** ERROR ** (goedecker_solve) DSYSV failed' - - if (abs(sum(Xtmp(:n))-chrg) > 1.e-6_wp) & - error stop '** ERROR ** (goedecker_solve) charge constrain error' - !print'(3f20.14)',Xtmp - -!! ------------------------------------------------------------------------ -! calculate isotropic electrostatic (IES) energy -!! ------------------------------------------------------------------------ -! E = ∑i (ENi - κi·√CNi)·qi + ∑i (Jii + 2/√π·γii)·q²i -! + ½ ∑i ∑j,j≠i qi·qj·2/√π·F0(γ²ij·R²ij) -! = q·(½A·q - X) -!! ------------------------------------------------------------------------ -! work(:m) = Xvec -! call dsymv('u',m,0.5_wp,Amat,m,Xtmp,1,-1.0_wp,work,1) -! es = dot_product(Xtmp,work(:m)) -! energy = es + energy - -!! ------------------------------------------------------------------------ -! calculate molecular gradient of the IES energy -!! ------------------------------------------------------------------------ -! dE/dRj -> g(:,j), ∂Xi/∂Rj -> -dcn(:,i,j), ½∂Aij/∂Rj -> dAmat(:,j,i) -! dE/dR = (½∂A/∂R·q - ∂X/∂R)·q -! ∂Aij/∂Rj = ∂Aij/∂Ri -!! ------------------------------------------------------------------------ - allocate (dAmat(3,n,m),source=0.0_wp) -!$omp parallel default(none) & -!$omp shared(n,xyz,alpha,Amat,Xtmp) & -!$omp private(i,j,rij,r2,gamij,arg,dtmp) & -!$omp reduction(+:dAmat) -!$omp do schedule(dynamic) - do i = 1,n - do j = 1,i-1 - rij = xyz(:,i)-xyz(:,j) - r2 = sum(rij**2) - gamij = 1.0_wp/sqrt(alpha(i)+alpha(j)) - arg = gamij**2*r2 - dtmp = 2.0_wp*gamij*exp(-arg)/(sqrtpi*r2)-Amat(j,i)/r2 - dAmat(:,i,i) = +dtmp*rij*Xtmp(j)+dAmat(:,i,i) - dAmat(:,j,j) = -dtmp*rij*Xtmp(i)+dAmat(:,j,j) - dAmat(:,i,j) = +dtmp*rij*Xtmp(i) - dAmat(:,j,i) = -dtmp*rij*Xtmp(j) - end do - end do -!$omp enddo -!$omp endparallel - -!! ------------------------------------------------------------------------ -! invert the A matrix using a Bunch-Kaufman factorization -! A⁻¹ = (L·D·L^T)⁻¹ = L^T·D⁻¹·L -!! ------------------------------------------------------------------------ - allocate (Ainv(m,m),source=Amat) - - ! assume work space query, set best value to test after first dsytrf call - call dsytrf('L',m,Ainv,m,ipiv,test,-1,info) - if (int(test(1)) > lwork) then - deallocate (work) - lwork = int(test(1)) - allocate (work(lwork),source=0.0_wp) - end if - - ! Bunch-Kaufman factorization A = L*D*L**T - call dsytrf('L',m,Ainv,m,ipiv,work,lwork,info) - if (info > 0) then - error stop '** ERROR ** (goedecker_inversion) DSYTRF failed' - - end if - - ! A⁻¹ from factorized L matrix, save lower part of A⁻¹ in Ainv matrix - ! Ainv matrix is overwritten with lower triangular part of A⁻¹ - call dsytri('L',m,Ainv,m,ipiv,work,info) - if (info > 0) then - error stop '** ERROR ** (goedecker_inversion) DSYTRI failed' - end if - - ! symmetrizes A⁻¹ matrix from lower triangular part of inverse matrix - do i = 1,m - do j = i+1,m - Ainv(i,j) = Ainv(j,i) - end do - end do - -!! ------------------------------------------------------------------------ -! calculate gradient of the partial charge w.r.t. the nuclear coordinates -!! ------------------------------------------------------------------------ - !call dsymm('r','l',3*n,m,-1.0_wp,Ainv,m,dAmat,3*n,1.0_wp,dqdr,3*n) - call dgemm('n','n',3*n,m,m,-1.0_wp,dAmat,3*n,Ainv,m,1.0_wp,dqdr,3*n) - !print'(/,"analytical gradient")' - !print'(3f20.14)',dqdr(:,:,:n) - -!! ------------------------------------------------------------------------ -! molecular Hessian calculation -!! ------------------------------------------------------------------------ - do i = 1,n - do j = 1,i-1 - rij = xyz(:,j)-xyz(:,i) - r2 = sum(rij**2) - r = sqrt(r2) - gamij = 1.0_wp/sqrt(alpha(i)+alpha(j)) - gamij2 = gamij**2 - arg2 = gamij2*r2 - arg = sqrt(arg2) - erfterm = Xtmp(i)*Xtmp(j)*erf(arg)/r - expterm = Xtmp(i)*Xtmp(j)*2*gamij*exp(-arg2)/sqrtpi - ! ∂²(qAq)/(∂Ri∂Rj): - ! ∂²(qAq)/(∂Xi∂Xi) = (1-3X²ij/R²ij-2γ²ijX²ij) 2γij/√π exp[-γ²ij·R²ij]/R²ij - ! - (R²ij-3X²ij) erf[γij·Rij]/R⁵ij - ! ∂²(qAq)/(∂Xi∂Xj) = (R²ij-3X²ij) erf[γij·Rij]/R⁵ij - ! - (1-3X²ij/R²ij-2γ²ijX²ij) 2γij/√π exp[-γ²ij·R²ij]/R²ij - ! ∂²(qAq)/(∂Xi∂Yi) = 3X²ij erf[γij·Rij]/R⁵ij - ! - (3X²ij/R²ij+2γ²ijX²ij) 2γij/√π exp[-γ²ij·R²ij]/R²ij - ! ∂²(qAq)/(∂Xi∂Yj) = (3X²ij/R²ij+2γ²ijX²ij) 2γij/√π exp[-γ²ij·R²ij]/R²ij - ! - 3X²ij erf[γij·Rij]/R⁵ij - rxr(1,1) = erfterm*(3*rij(1)**2/r2**2-1.0_wp/r2) & - -expterm*(3*rij(1)**2/r2**2+2*gamij2*rij(1)**2/r2-1/r2) - rxr(2,2) = erfterm*(3*rij(2)**2/r2**2-1.0_wp/r2) & - -expterm*(3*rij(2)**2/r2**2+2*gamij2*rij(2)**2/r2-1/r2) - rxr(3,3) = erfterm*(3*rij(3)**2/r2**2-1.0_wp/r2) & - -expterm*(3*rij(3)**2/r2**2+2*gamij2*rij(3)**2/r2-1/r2) - rxr(2,1) = erfterm*3*rij(2)*rij(1)/r2**2 & - -expterm*(3*rij(2)*rij(1)/r2**2+2*gamij2*rij(2)*rij(1)/r2) - rxr(3,1) = erfterm*3*rij(3)*rij(1)/r2**2 & - -expterm*(3*rij(3)*rij(1)/r2**2+2*gamij2*rij(3)*rij(1)/r2) - rxr(3,2) = erfterm*3*rij(3)*rij(2)/r2**2 & - -expterm*(3*rij(3)*rij(2)/r2**2+2*gamij2*rij(3)*rij(2)/r2) - - do k = 1,m - rxr(1,1) = rxr(1,1)+0.5_wp*dqdr(1,i,k)*dAmat(1,j,k) & - +0.5_wp*dqdr(1,j,k)*dAmat(1,i,k) - rxr(2,1) = rxr(2,1)+0.5_wp*dqdr(2,i,k)*dAmat(1,j,k) & - +0.5_wp*dqdr(2,j,k)*dAmat(1,i,k) - rxr(3,1) = rxr(3,1)+0.5_wp*dqdr(3,i,k)*dAmat(1,j,k) & - +0.5_wp*dqdr(3,j,k)*dAmat(1,i,k) - rxr(2,2) = rxr(2,2)+0.5_wp*dqdr(2,i,k)*dAmat(2,j,k) & - +0.5_wp*dqdr(2,j,k)*dAmat(2,i,k) - rxr(3,2) = rxr(3,2)+0.5_wp*dqdr(3,i,k)*dAmat(2,j,k) & - +0.5_wp*dqdr(3,j,k)*dAmat(2,i,k) - rxr(3,3) = rxr(3,3)+0.5_wp*dqdr(3,i,k)*dAmat(3,j,k) & - +0.5_wp*dqdr(3,j,k)*dAmat(3,i,k) - end do - ! symmetrize - rxr(1,2) = rxr(2,1) - rxr(1,3) = rxr(3,1) - rxr(2,3) = rxr(3,2) - - ! save diagonal elements for atom i - hess(ind(1,i,1,i)) = hess(ind(1,i,1,i))+kq*rxr(1,1) - hess(ind(2,i,1,i)) = hess(ind(2,i,1,i))+kq*rxr(2,1) - hess(ind(2,i,2,i)) = hess(ind(2,i,2,i))+kq*rxr(2,2) - hess(ind(3,i,1,i)) = hess(ind(3,i,1,i))+kq*rxr(3,1) - hess(ind(3,i,2,i)) = hess(ind(3,i,2,i))+kq*rxr(3,2) - hess(ind(3,i,3,i)) = hess(ind(3,i,3,i))+kq*rxr(3,3) - ! save elements between atom i and atom j - hess(ind(1,i,1,j)) = hess(ind(1,i,1,j))-kq*rxr(1,1) - hess(ind(1,i,2,j)) = hess(ind(1,i,2,j))-kq*rxr(2,1) - hess(ind(1,i,3,j)) = hess(ind(1,i,3,j))-kq*rxr(3,1) - hess(ind(2,i,1,j)) = hess(ind(2,i,1,j))-kq*rxr(2,1) - hess(ind(2,i,2,j)) = hess(ind(2,i,2,j))-kq*rxr(2,2) - hess(ind(2,i,3,j)) = hess(ind(2,i,3,j))-kq*rxr(3,2) - hess(ind(3,i,1,j)) = hess(ind(3,i,1,j))-kq*rxr(3,1) - hess(ind(3,i,2,j)) = hess(ind(3,i,2,j))-kq*rxr(3,2) - hess(ind(3,i,3,j)) = hess(ind(3,i,3,j))-kq*rxr(3,3) - ! save diagonal elements for atom j - hess(ind(1,j,1,j)) = hess(ind(1,j,1,j))+kq*rxr(1,1) - hess(ind(2,j,1,j)) = hess(ind(2,j,1,j))+kq*rxr(2,1) - hess(ind(2,j,2,j)) = hess(ind(2,j,2,j))+kq*rxr(2,2) - hess(ind(3,j,1,j)) = hess(ind(3,j,1,j))+kq*rxr(3,1) - hess(ind(3,j,2,j)) = hess(ind(3,j,2,j))+kq*rxr(3,2) - hess(ind(3,j,3,j)) = hess(ind(3,j,3,j))+kq*rxr(3,3) - end do - end do - - ! ∂²(qA)/(∂Ri∂q)·∂q/∂Rj - ! hessian = hessian + reshape(matmul(reshape(dqdr,(/3*n,m/)),& - ! transpose(reshape(dAmat,(/3*n,m/)))),(/3,n,3,n/)) - !call dgemm('n','t',3*n,m,3*n,+1.0_wp,dqdr,3*n,dAmat,3*n,1.0_wp,hessian,3*n) - !call dgemm('n','t',3*n,m,3*n,+1.0_wp,dAmat,3*n,dqdr,3*n,1.0_wp,hessian,3*n) - - end subroutine mh_eeq - !========================================================================================! !########################################################################################! !========================================================================================! From 55c62cb558bb9ea1c065d6a3405ed571b578919e Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 25 Feb 2026 21:57:07 +0100 Subject: [PATCH 185/374] changes to approxg, callable via calculator now. why though? --- src/calculator/api_engrad.f90 | 76 +++++++++++++++++++++++++++++-- src/calculator/approxg.f90 | 56 +++++++++++++++-------- src/calculator/calc_type.f90 | 19 ++++---- src/calculator/calculator.F90 | 11 +++-- src/entropy/thermochem_module.f90 | 34 ++++++++------ src/parsing/parse_calcdata.f90 | 2 + 6 files changed, 148 insertions(+), 50 deletions(-) diff --git a/src/calculator/api_engrad.f90 b/src/calculator/api_engrad.f90 index ddcf60e3..08192ebf 100644 --- a/src/calculator/api_engrad.f90 +++ b/src/calculator/api_engrad.f90 @@ -35,6 +35,7 @@ module api_engrad use gfnff_api use libpvol_api use lj + use approxg_module implicit none !>--- private module variables and parameters private @@ -43,7 +44,8 @@ module api_engrad public :: gfn0_engrad,gfn0occ_engrad public :: gfnff_engrad public :: libpvol_engrad - public :: lj_engrad !> RE-EXPORT + public :: lj_engrad !> RE-EXPORT + public :: modelhessian_engrad !=========================================================================================! !=========================================================================================! @@ -258,9 +260,9 @@ subroutine gfnff_engrad(mol,calc,energy,grad,iostatus) !>--- populate parameters and neighbourlists if (loadnew) then if (calc%ceh_guess) then - if(pr)then - write(calc%prch,'(/,a)') 'Initializing (fragement) charges from CEH model' - endif + if (pr) then + write (calc%prch,'(/,a)') 'Initializing (fragement) charges from CEH model' + end if !> A bit hacky and additional I/O, but would need adjusting submodule code otherwise call tblite_quick_ceh_q(mol,q,calc%chrg,pr=pr,prch=calc%prch) tmpchrgs = dump_array_to_tmp(q) @@ -348,5 +350,71 @@ subroutine libpvol_engrad(mol,calc,energy,grad,iostatus) end subroutine libpvol_engrad !========================================================================================! + + subroutine modelhessian_engrad(mol,calc,energy,grad,iostatus) +!*************************************************************** +!* Interface singlepoint call between CREST and XHC force field +!*************************************************************** + implicit none + type(coord) :: mol + type(calculation_settings) :: calc + + real(wp),intent(inout) :: energy + real(wp),intent(inout) :: grad(3,mol%nat) + integer,intent(out) :: iostatus + + logical :: loadnew,pr + integer :: i,j,k,l,ich,och,io,n3 + logical :: ex + iostatus = 0 + pr = .false. +!>--- setup system call information + !$omp critical +!>--- printout handling + call api_handle_output(calc,'modh.out',mol,pr) +!>--- populate parameters + n3 = mol%nat*3 + if (calc%ag%dim .ne. mol%nat) then + calc%ag%pr = calc%prstdout .and. .not.calc%numgrad + + if (allocated(calc%ag%hess)) deallocate (calc%ag%hess) + allocate (calc%ag%hess(n3,n3),source=0.0_wp) + + if (allocated(calc%ag%h)) deallocate (calc%ag%h) + allocate (calc%ag%h(n3*(n3+1)/2),source=0.0_wp) + + if (allocated(calc%ag%freq)) deallocate (calc%ag%freq) + allocate (calc%ag%freq(n3),source=0.0_wp) + + if (allocated(calc%ag%xyz)) deallocate (calc%ag%xyz) + allocate (calc%ag%xyz(3,mol%nat),source=0.0_wp) + + calc%ag%dim = mol%nat + else + calc%ag%hess(:,:) = 0.0_wp + calc%ag%h(:) = 0.0_wp + end if + !$omp end critical + if (iostatus /= 0) return + +!>--- do the engrad call + call initsignal() + call modh_engrad(mol,calc%ag,energy,grad,iostatus) + if (iostatus /= 0) return + +!>--- printout + if (pr) then + !> the libpvol_sp call includes the printout within libpvol-lib + if (.not.calc%prstdout) & + & call api_print_e_grd(pr,calc%prch,mol,energy,grad) + end if + +!>--- postprocessing, getting other data + + return + end subroutine modelhessian_engrad + +!========================================================================================! +!########################################################################################! !========================================================================================! end module api_engrad diff --git a/src/calculator/approxg.f90 b/src/calculator/approxg.f90 index 85f8c3a7..61342048 100644 --- a/src/calculator/approxg.f90 +++ b/src/calculator/approxg.f90 @@ -21,13 +21,27 @@ module approxg_module use crest_parameters - use calc_type use modelhessian_core use thermochem_module use strucrd + use optimize_maths,only:dhtosq implicit none private + public :: approxg_params + type :: approxg_params + integer :: dim = 0 + logical :: pr = .false. + real(wp) :: T = 298.15_wp + real(wp),allocatable :: hess(:,:) + real(wp),allocatable :: h(:) + real(wp),allocatable :: freq(:) + real(wp),allocatable :: xyz(:,:) + real(wp) :: fscal = 1.0_wp + real(wp) :: ithr = -50.0_wp + real(wp) :: sthr = 50.0_wp + end type approxg_params + public :: modh_engrad !========================================================================================! @@ -36,38 +50,42 @@ module approxg_module !========================================================================================! !========================================================================================! - subroutine modh_engrad(mol,calc,dg,dggrad) + subroutine modh_engrad(mol,ag,dg,dggrad,iostatus) type(coord),intent(in) :: mol - type(calculation_settings),intent(inout) :: calc + type(approxg_params),intent(inout) :: ag real(wp),intent(out) :: dg - real(wp),intent(out) :: dggrad(:) - integer :: n3 + real(wp),intent(out) :: dggrad(:,:) + integer,intent(out) :: iostatus + integer :: n3,io + integer,parameter :: nt = 1 + real(wp) :: temps(nt),et(nt),ht(nt),gt(nt),stot(nt) type(mhparam) :: mhset + iostatus = 0 dg = 0.0_wp - dggrad(:) = 0.0_wp + dggrad(:,:) = 0.0_wp + temps(1) = ag%T !> setup n3 = mol%nat*3 - if (calc%approxg_dim .ne. mol%nat) then - !$omp critical - if (allocated(calc%approxg_hess)) deallocate (calc%approxg_hess) - allocate (calc%approxg_hess(n3,n3),source=0.0_wp) + call ddvopt(mol%xyz,mol%nat,ag%h,mol%at,mhset) - if (allocated(calc%approxg_h)) deallocate (calc%approxg_h) - allocate (calc%approxg_h(n3*(n3+1)/2),source=0.0_wp) + call dhtosq(n3,ag%hess,ag%h) + ag%h(:) = 0.0_wp + call prj_mw_hess(mol%nat,mol%at,n3,mol%xyz, & + & ag%hess,ag%h) - calc%approxg_dim = mol%nat - !$omp end critical - else - calc%approxg_hess(:,:) = 0.0_wp - calc%approxg_h(:) = 0.0_wp - end if + call frequencies(mol%nat,mol%at,mol%xyz,n3,ag%hess,ag%freq,io) + iostatus = io + if (iostatus .ne. 0) return - call ddvopt(mol%xyz,mol%nat,calc%approxg_h,mol%at,mhset) + ag%xyz(:,:) = mol%xyz(:,:) + call calcthermo(mol%nat,mol%at,ag%xyz,ag%freq,ag%pr, & + ag%ithr,ag%fscal,ag%sthr,nt,temps,et,ht,gt,stot) + dg = gt(1) end subroutine modh_engrad !========================================================================================! diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index d03039ff..0b85e11b 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -30,6 +30,7 @@ module calc_type use orca_type use lwoniom_module use hessian_reconstruct + use approxg_module, only: approxg_params implicit none character(len=*),public,parameter :: sep = '/' @@ -175,11 +176,13 @@ module calc_type type(libpvol_calculator),allocatable :: libpvol !>--- approxg data - integer :: approxg_dim = 0 - real(wp) :: approxg_T = 298.15_wp - real(wp),allocatable :: approxg_hess(:,:) - real(wp),allocatable :: approxg_h(:) - real(wp),allocatable :: approxg_freq(:) +! integer :: approxg_dim = 0 +! real(wp) :: approxg_T = 298.15_wp +! real(wp),allocatable :: approxg_hess(:,:) +! real(wp),allocatable :: approxg_h(:) +! real(wp),allocatable :: approxg_freq(:) +! real(wp),allocatable :: approxg_xyz(:,:) + type(approxg_params) :: ag !> ONIOM fragment IDs integer :: ONIOM_highlowroot = 0 @@ -1100,11 +1103,7 @@ subroutine calculation_settings_copy(self,src) self%ONIOM_highlowroot = src%ONIOM_highlowroot self%ONIOM_id = src%ONIOM_id - self%approxg_dim = src%approxg_dim - self%approxg_T = src%approxg_T - if(allocated(src%approxg_hess)) self%approxg_hess = src%approxg_hess - if(allocated(src%approxg_h)) self%approxg_h = src%approxg_h - if(allocated(src%approxg_freq)) self%approxg_freq = src%approxg_freq + self%ag = src%ag !&< return end subroutine calculation_settings_copy diff --git a/src/calculator/calculator.F90 b/src/calculator/calculator.F90 index 11cedde3..b99673af 100644 --- a/src/calculator/calculator.F90 +++ b/src/calculator/calculator.F90 @@ -301,9 +301,11 @@ subroutine engrad_mol(mol,calc,energy,gradient,iostatus) !>--- Hessian Reconstruct !********************************************** - if ((calc%do_HR .or. calc%deform_opt_hess) .and. allocated(calc%chess) .and. calc%chess%track_step) then - call calc%chess%update(gradient,energy,mol%xyz) - !write(stdout,*) "HESSIAN CASH UPDATED" + if ((calc%do_HR.or.calc%deform_opt_hess).and.allocated(calc%chess)) then + if (calc%chess%track_step) then + call calc%chess%update(gradient,energy,mol%xyz) + !write(stdout,*) "HESSIAN CASH UPDATED" + end if end if return @@ -387,6 +389,9 @@ subroutine potential_core(molptr,calc,id,iostatus) & calc%etmp(id),calc%grdtmp(:,1:pnat,id)) calc%grdtmp(:,:,id) = calc%grdtmp(:,:,id)*autoaa + case (jobtype%approxg) + call modelhessian_engrad(molptr,calc%calcs(id),calc%etmp(id),calc%grdtmp(:,1:pnat,id),iostatus) + case default calc%etmp(id) = 0.0_wp calc%grdtmp(:,:,id) = 0.0_wp diff --git a/src/entropy/thermochem_module.f90 b/src/entropy/thermochem_module.f90 index f62939ef..48cdf221 100644 --- a/src/entropy/thermochem_module.f90 +++ b/src/entropy/thermochem_module.f90 @@ -6,6 +6,7 @@ module thermochem_module use iomod,only:to_lower,directory_exist use axis_module use strucrd + use crest_thermo implicit none private @@ -44,6 +45,7 @@ subroutine frequencies(nat,at,xyz,nat3,prj_mw_hess,freq,io) !>LAPCK external :: dsyevd + io = 0 nat3 = nat*3 !Parameters for diagonalization @@ -54,7 +56,7 @@ subroutine frequencies(nat,at,xyz,nat3,prj_mw_hess,freq,io) !Diagonalization call dsyevd('V','U',nat3,prj_mw_hess,nat3,freq,work,lwork,iwork,liwork,info) - + io = info deallocate (work,iwork) !Convert eigenvalues to frequencies @@ -111,7 +113,7 @@ end subroutine mass_weight_hess !=========================================================================================! - subroutine prj_mw_hess(nat,at,nat3,xyz,hess) + subroutine prj_mw_hess(nat,at,nat3,xyz,hess,phess_ut) !*************************************************************** !* Projection of the translational and rotational DOF out of !* the numerical Hessian plus the mass-weighting of the Hessian @@ -119,29 +121,36 @@ subroutine prj_mw_hess(nat,at,nat3,xyz,hess) implicit none integer,intent(in) :: nat,nat3 - integer :: at(nat) + integer,intent(in) :: at(nat) real(wp),intent(inout) :: hess(nat3,nat3) - real(wp) :: xyz(3,nat) + real(wp),intent(in) :: xyz(3,nat) + real(wp),intent(in),optional,target :: phess_ut(:) !real(wp) :: hess_ut(nat3*(nat3+1)/2),pmode(nat3,1) - real(wp),allocatable :: hess_ut(:),pmode(:,:) + real(wp),allocatable,target :: hess_ut(:) + real(wp),allocatable :: pmode(:,:) + real(wp),pointer :: phess(:) integer :: i - allocate (hess_ut(nat3*(nat3+1)/2),source=0.0_wp) + if (present(phess_ut)) then + phess => phess_ut + else + allocate (hess_ut(nat3*(nat3+1)/2),source=0.0_wp) + phess => hess_ut + end if allocate (pmode(nat3,1),source=0.0_wp) !> Transforms matrix of the upper triangle vector - call dsqtoh(nat3,hess,hess_ut) + call dsqtoh(nat3,hess,phess) !> Projection - call trproj(nat,nat3,xyz,hess_ut,.false.,0,pmode,1) + call trproj(nat,nat3,xyz,phess,.false.,0,pmode,1) !> Transforms vector of the upper triangle into matrix - call dhtosq(nat3,hess,hess_ut) + call dhtosq(nat3,hess,phess) !> Mass weighting call mass_weight_hess(nat,at,nat3,hess) - deallocate (pmode,hess_ut) end subroutine prj_mw_hess !============================================================================! @@ -245,10 +254,7 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & !* from it's frequencies (from second derivatives/the Hessian) !* Based on xtb's "print_thermo" routine !************************************************************** - !use crest_parameters,only:wp,bohr,stdout - use crest_thermo - !use atmasses,only:molweight - !use iomod,only:to_lower + implicit none integer,intent(in) :: nat integer,intent(in) :: at(nat) diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 24d942d1..7bb3ede9 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -262,6 +262,8 @@ subroutine parse_setting_auto(env,job,kv,rd) job%id = jobtype%unknown case ('lj','lennard-jones') job%id = jobtype%lj + case ('modh') + job%id = jobtype%approxg case default job%id = jobtype%unknown !>--- keyword was recognized, but invalid argument supplied From 88b76ffd011d1ecc7518d143463fc9ae64b27501 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 2 Mar 2026 10:52:59 +0100 Subject: [PATCH 186/374] Start implementing RMSD penalty as calculator object --- src/calculator/CMakeLists.txt | 1 + src/calculator/meson.build | 1 + src/calculator/penalty.f90 | 77 +++++++++++++++++++++++++++++++++++ 3 files changed, 79 insertions(+) create mode 100644 src/calculator/penalty.f90 diff --git a/src/calculator/CMakeLists.txt b/src/calculator/CMakeLists.txt index e398c61d..5a81bf9e 100644 --- a/src/calculator/CMakeLists.txt +++ b/src/calculator/CMakeLists.txt @@ -43,6 +43,7 @@ list(APPEND srcs "${dir}/hr_utils.f90" "${dir}/modelhessians.f90" "${dir}/approxg.f90" + "${dir}/penalty.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/calculator/meson.build b/src/calculator/meson.build index bf130092..c659c3fb 100644 --- a/src/calculator/meson.build +++ b/src/calculator/meson.build @@ -39,4 +39,5 @@ srcs += files( 'hr_utils.f90', 'modelhessians.f90', 'approxg.f90', + 'penalty.f90', ) diff --git a/src/calculator/penalty.f90 b/src/calculator/penalty.f90 new file mode 100644 index 00000000..3e2a6713 --- /dev/null +++ b/src/calculator/penalty.f90 @@ -0,0 +1,77 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2026 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +!> a small module for getting a penalty contribution, e.g. from the RMSD potential used in metadynamics + +module penalty_module + use crest_parameters + use strucrd + use irmsd_module + implicit none + private + + public :: penalty_params + type :: penalty_params + type(coord),pointer :: biaslist(:) + real(wp) :: alpha = 1.0_wp + real(wp) :: kpush = 0.01_wp + real(wp),allocatable :: ramp(:) + real(wp),allocatable :: gradtmp(:,:) + type(rmsd_core_cache) :: ccache + end type penalty_params + + public :: rmsd_engrad + +!========================================================================================! +!========================================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================================! +!========================================================================================! + + subroutine rmsd_engrad(mol,ppars,energy,grad,iostatus) + type(coord),intent(in) :: mol + type(penalty_params),intent(inout) :: ppars + real(wp),intent(out) :: energy + real(wp),intent(out) :: grad(:,:) + integer,intent(out) :: iostatus + integer :: nall,io,ii + real(wp) :: etmp,rmsdval,dEdr + + iostatus = 0 + energy = 0.0_wp + grad(:,:) = 0.0_wp + rmsdval = 0.0_wp + nall = size(ppars%biaslist,1) + + do ii = 1,nall + + rmsdval = rmsd(mol,ppars%biaslist(ii),gradient=ppars%gradtmp,ccache=ppars%ccache) + + etmp = ppars%kpush*(-ppars%alpha*rmsdval**2) + dEdr = -2.0_wp*ppars%alpha*etmp*rmsdval + + energy = energy+etmp + grad(:,:) = grad(:,:)+dEdr*ppars%gradtmp(:,:) + end do + + end subroutine rmsd_engrad + +!========================================================================================! +!========================================================================================! +end module penalty_module From bf5904a72447c9603f355b58dae721d7c837c154 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 2 Mar 2026 11:30:28 +0100 Subject: [PATCH 187/374] pass refine_lvl in calculation copy --- src/calculator/calc_type.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 0b85e11b..ed87eabe 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -1082,6 +1082,7 @@ subroutine calculation_settings_copy(self,src) self%prch = src%prch self%chrg = src%chrg self%uhf = src%uhf + self%refine_lvl = src%refine_lvl self%rdwbo = src%rdwbo self%rddip = src%rddip From 9cbfdb8853256c7210e0edd61042f53cde519e71 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 3 Mar 2026 10:46:36 +0100 Subject: [PATCH 188/374] CREGEN printout fix --- src/sorting/cregen.f90 | 69 ++++++++++++++++++++++++++++++------------ 1 file changed, 50 insertions(+), 19 deletions(-) diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 9d607491..8c5ba698 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -972,7 +972,7 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & integer,intent(in),optional :: ch !> LOCAL - integer :: i,ii,jj,kk,T,cc,nat,io + integer :: i,ii,jj,kk,T,cc,nat,io,gg integer :: gcount,ggcount,nallnew integer :: prlvl,prch type(rmsd_cache),allocatable :: rcaches(:) @@ -1168,21 +1168,21 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & workmols(cc)%nat = structures(jj)%nat workmols(cc)%at(:) = structures(jj)%at(:) workmols(cc)%xyz(:,:) = structures(jj)%xyz(:,:) - if (heavy.or.substruc) then - rmsdval = rmsd(structures(ii),workmols(cc),mask=mask,& - & scratch=rcaches(cc)%xyzscratch,ccache=rcaches(cc)%ccache) - else - rmsdval = rmsd(structures(ii),workmols(cc), & - & scratch=rcaches(cc)%xyzscratch,ccache=rcaches(cc)%ccache) - end if - if (rmsdval < RTHR) then - !> only "true" duplicates will have tiny RMSD, assign negative gcount for pruning - groups(jj) = -gcount - else - l1 = equalrotaniso(ii,jj,nall,rot,BTHR,bthrmax,bthrshift) - l2 = (2.0_wp*abs(enuc(ii)-enuc(jj))/(enuc(ii)+enuc(jj))) .lt. enuc_thr - if (l1.and.l2) groups(jj) = gcount - end if + !if (heavy.or.substruc) then + ! rmsdval = rmsd(structures(ii),workmols(cc),mask=mask,& + ! & scratch=rcaches(cc)%xyzscratch,ccache=rcaches(cc)%ccache) + !else + ! rmsdval = rmsd(structures(ii),workmols(cc), & + ! & scratch=rcaches(cc)%xyzscratch,ccache=rcaches(cc)%ccache) + !end if + !if (rmsdval < RTHR) then + !> only "true" duplicates will have tiny RMSD, assign negative gcount for pruning + ! groups(jj) = -gcount + !else + l1 = equalrotaniso(ii,jj,nall,rot,BTHR,bthrmax,bthrshift) + l2 = (2.0_wp*abs(enuc(ii)-enuc(jj))/(enuc(ii)+enuc(jj))) .lt. enuc_thr + if (l1.and.l2) groups(jj) = gcount + !end if end do if (prlvl > 1) then ! call progress_update(ps,ii,nall) @@ -1190,8 +1190,37 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & ! !$omp end do ! !$omp end parallel end do + +!> for all groups run RMSD checks + gcount = maxval(groups(1:nall)) + do gg = 1,gcount + do ii = 1,nall + if (groups(ii) .ne. gg) cycle + do jj = ii+1,nall + kk = groups(jj) + if (kk .ne. gg .or. kk < 0) cycle + + workmols(cc)%nat = structures(jj)%nat + workmols(cc)%at(:) = structures(jj)%at(:) + workmols(cc)%xyz(:,:) = structures(jj)%xyz(:,:) + if (heavy.or.substruc) then + rmsdval = rmsd(structures(ii),workmols(cc),mask=mask,& + & scratch=rcaches(cc)%xyzscratch,ccache=rcaches(cc)%ccache) + else + rmsdval = rmsd(structures(ii),workmols(cc), & + & scratch=rcaches(cc)%xyzscratch,ccache=rcaches(cc)%ccache) + end if + if (rmsdval < RTHR) then + !> only "true" duplicates will have tiny RMSD, assign negative gcount for pruning + groups(jj) = -gg + end if + end do + end do + end do + if (prlvl > 0) then - if (prlvl > 1.and.prch == stdout) then + !if (prlvl > 1 .and.prch == stdout) then + if (prlvl > 1) then ! call progress_update(ps,nall,nall) ! call progress_finish(ps) write (prch,'(a)') 'done.' @@ -2433,7 +2462,8 @@ subroutine cregen_pr2(ch,env,nall,ng,degen,er) & 'id ','kcal/mol','hartree','p(i)','p(group)','group','degen','origin' write (och,'(4x,4("-"),1x,8("-"),3(1x,12("-")),1x,9("-"),1x,5("-"),1x,6("-"))') if (abbrev) then - open (newunit=och2,file='cregen.full') + call remove('cregen.full') + open (newunit=och2,file='cregen.full',status='replace') write (och2,'(1x,a8,1x,a8,3(1x,a12),1x,a9,1x,a5)') & & ' ','ΔE','Etot','weight','conf.weight','conformer','' write (och2,'(a8,1x,a8,3(1x,a12),1x,a9,1x,a5,1x,a6)') & @@ -2460,7 +2490,6 @@ subroutine cregen_pr2(ch,env,nall,ng,degen,er) write (och2,'(i8,1x,f8.4,1x,f12.6,2(1x,f12.5),1x,i9,1x,i5,a)') & & a,erel(a),er(a),p(a),pg(i),i,degen(1,i),trim(origin(a)) end if -! if (.not. env%entropic) then do j = a+1,b k = k+1 if (k <= printlimit.or.k > nall-10) then @@ -2477,6 +2506,8 @@ subroutine cregen_pr2(ch,env,nall,ng,degen,er) end do end do + if(abbrev) close(och2) + !>-- file for the '-compare' mode if (env%compareens) then open (newunit=ich,file='.cretrack') From 167f02fdb07633a3a00b0fd3d8378759b85d33ec Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 3 Mar 2026 15:45:01 +0100 Subject: [PATCH 189/374] RMSD penalty function via calculation.level TOML object --- src/calculator/api_engrad.f90 | 65 ++++++++++++++++++- src/calculator/calc_type.f90 | 17 ++--- src/calculator/calculator.F90 | 3 + src/calculator/penalty.f90 | 33 +++++++--- src/parsing/parse_calcdata.f90 | 112 +++++++++++++++++++-------------- src/sorting/irmsd_module.f90 | 6 +- 6 files changed, 169 insertions(+), 67 deletions(-) diff --git a/src/calculator/api_engrad.f90 b/src/calculator/api_engrad.f90 index 08192ebf..0e9d6d83 100644 --- a/src/calculator/api_engrad.f90 +++ b/src/calculator/api_engrad.f90 @@ -36,6 +36,7 @@ module api_engrad use libpvol_api use lj use approxg_module + use penalty_module implicit none !>--- private module variables and parameters private @@ -46,6 +47,7 @@ module api_engrad public :: libpvol_engrad public :: lj_engrad !> RE-EXPORT public :: modelhessian_engrad + public :: rmsd_engrad !=========================================================================================! !=========================================================================================! @@ -375,7 +377,7 @@ subroutine modelhessian_engrad(mol,calc,energy,grad,iostatus) !>--- populate parameters n3 = mol%nat*3 if (calc%ag%dim .ne. mol%nat) then - calc%ag%pr = calc%prstdout .and. .not.calc%numgrad + calc%ag%pr = calc%prstdout.and..not.calc%numgrad if (allocated(calc%ag%hess)) deallocate (calc%ag%hess) allocate (calc%ag%hess(n3,n3),source=0.0_wp) @@ -414,6 +416,67 @@ subroutine modelhessian_engrad(mol,calc,energy,grad,iostatus) return end subroutine modelhessian_engrad +!========================================================================================! + + subroutine rmsd_engrad(mol,calc,energy,grad,iostatus) +!************************************************************************** +!* Interface singlepoint to add RMSD penalty function (as in metadynamics) +!************************************************************************** + implicit none + type(coord) :: mol + type(calculation_settings),target :: calc + + real(wp),intent(inout) :: energy + real(wp),intent(inout) :: grad(3,mol%nat) + integer,intent(out) :: iostatus + + logical :: loadnew,pr + integer :: i,j,k,l,ich,och,io,nall + logical :: ex + iostatus = 0 + pr = .false. +!>--- setup system call information + + if (.not.associated(calc%penalty%biaslist))then + if(allocated(calc%penalty%biasfile))then + !$omp critical + call rdensemble(calc%penalty%biasfile,nall,calc%penalty%biastmp) + calc%penalty%biaslist => calc%penalty%biastmp + !$omp end critical + else + return + endif + endif + !$omp critical +!>--- printout handling + call api_handle_output(calc,'rmsd_penalty.out',mol,pr) +!>--- populate parameters + if (.not.allocated(calc%penalty%gradtmp)) then + allocate(calc%penalty%gradtmp(3,mol%nat), source=0.0_wp) + call calc%penalty%ccache%allocate(mol%nat) + else + calc%penalty%gradtmp(:,:) = 0.0_wp + end if + !$omp end critical + if (iostatus /= 0) return + +!>--- do the engrad call + call initsignal() + call rmsd_penalty_engrad(mol,calc%penalty,energy,grad,iostatus) + if (iostatus /= 0) return + +!>--- printout + if (pr) then + !> the libpvol_sp call includes the printout within libpvol-lib + if (.not.calc%prstdout) & + & call api_print_e_grd(pr,calc%prch,mol,energy,grad) + end if + +!>--- postprocessing, getting other data + + return + end subroutine rmsd_engrad + !========================================================================================! !########################################################################################! !========================================================================================! diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index ed87eabe..d1e0d258 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -31,6 +31,7 @@ module calc_type use lwoniom_module use hessian_reconstruct use approxg_module, only: approxg_params + use penalty_module, only: penalty_params implicit none character(len=*),public,parameter :: sep = '/' @@ -52,10 +53,11 @@ module calc_type integer :: libpvol = 10 integer :: lj = 11 integer :: approxg = 12 + integer :: penalty = 13 end type enum_jobtype type(enum_jobtype), parameter,public :: jobtype = enum_jobtype() - character(len=45),parameter,private :: jobdescription(13) = [ & + character(len=45),parameter,private :: jobdescription(14) = [ & & 'Unknown calculation type ', & & 'xTB calculation via external binary ', & & 'Generic script execution ', & @@ -68,7 +70,8 @@ module calc_type & 'GFN-FF calculation via GFNFF lib ', & & 'external pressure calculation via libpvol ', & & 'Lennard-Jones potential calculation ', & - & 'Approximate free energy computation ' ] + & 'Approximate free energy computation ', & + & 'Empirical penalty function ' ] !&> !=========================================================================================! @@ -176,14 +179,11 @@ module calc_type type(libpvol_calculator),allocatable :: libpvol !>--- approxg data -! integer :: approxg_dim = 0 -! real(wp) :: approxg_T = 298.15_wp -! real(wp),allocatable :: approxg_hess(:,:) -! real(wp),allocatable :: approxg_h(:) -! real(wp),allocatable :: approxg_freq(:) -! real(wp),allocatable :: approxg_xyz(:,:) type(approxg_params) :: ag +!>--- penalty params + type(penalty_params) :: penalty + !> ONIOM fragment IDs integer :: ONIOM_highlowroot = 0 integer :: ONIOM_id = 0 @@ -1105,6 +1105,7 @@ subroutine calculation_settings_copy(self,src) self%ONIOM_id = src%ONIOM_id self%ag = src%ag + self%penalty = src%penalty !&< return end subroutine calculation_settings_copy diff --git a/src/calculator/calculator.F90 b/src/calculator/calculator.F90 index b99673af..376b8b4f 100644 --- a/src/calculator/calculator.F90 +++ b/src/calculator/calculator.F90 @@ -392,6 +392,9 @@ subroutine potential_core(molptr,calc,id,iostatus) case (jobtype%approxg) call modelhessian_engrad(molptr,calc%calcs(id),calc%etmp(id),calc%grdtmp(:,1:pnat,id),iostatus) + case (jobtype%penalty) + call rmsd_engrad(molptr,calc%calcs(id),calc%etmp(id),calc%grdtmp(:,1:pnat,id),iostatus) + case default calc%etmp(id) = 0.0_wp calc%grdtmp(:,:,id) = 0.0_wp diff --git a/src/calculator/penalty.f90 b/src/calculator/penalty.f90 index 3e2a6713..efa7e2ee 100644 --- a/src/calculator/penalty.f90 +++ b/src/calculator/penalty.f90 @@ -29,14 +29,18 @@ module penalty_module public :: penalty_params type :: penalty_params type(coord),pointer :: biaslist(:) + real(wp) :: alpha = 1.0_wp - real(wp) :: kpush = 0.01_wp + real(wp) :: kpush = 0.002_wp real(wp),allocatable :: ramp(:) real(wp),allocatable :: gradtmp(:,:) type(rmsd_core_cache) :: ccache + + character(len=:),allocatable :: biasfile + type(coord),allocatable :: biastmp(:) end type penalty_params - public :: rmsd_engrad + public :: rmsd_penalty_engrad !========================================================================================! !========================================================================================! @@ -44,33 +48,46 @@ module penalty_module !========================================================================================! !========================================================================================! - subroutine rmsd_engrad(mol,ppars,energy,grad,iostatus) + subroutine rmsd_penalty_engrad(mol,ppars,energy,grad,iostatus) type(coord),intent(in) :: mol type(penalty_params),intent(inout) :: ppars real(wp),intent(out) :: energy real(wp),intent(out) :: grad(:,:) integer,intent(out) :: iostatus integer :: nall,io,ii - real(wp) :: etmp,rmsdval,dEdr + real(wp) :: etmp,rmsdval,dEdr,knat + real(wp),parameter :: thr = sqrt(epsilon(thr)) iostatus = 0 energy = 0.0_wp grad(:,:) = 0.0_wp rmsdval = 0.0_wp nall = size(ppars%biaslist,1) + knat = ppars%kpush*mol%nat do ii = 1,nall rmsdval = rmsd(mol,ppars%biaslist(ii),gradient=ppars%gradtmp,ccache=ppars%ccache) - etmp = ppars%kpush*(-ppars%alpha*rmsdval**2) - dEdr = -2.0_wp*ppars%alpha*etmp*rmsdval - + !> energy contribution + call penalty_potential_gauss(knat,ppars%alpha,rmsdval,etmp,dEdr) energy = energy+etmp + !> fallback: exactly matching structures will produce NaN gradients! + if (rmsdval < thr) cycle + !> gradient contribution grad(:,:) = grad(:,:)+dEdr*ppars%gradtmp(:,:) end do - end subroutine rmsd_engrad + end subroutine rmsd_penalty_engrad + +!========================================================================================! + + subroutine penalty_potential_gauss(k,a,r,etmp,dEdr) + real(wp),intent(in) :: k,a,r + real(wp),intent(out) :: etmp,dEdr + etmp = k*exp(-a*r**2) + dEdr = -2.0_wp*a*etmp*r + end subroutine penalty_potential_gauss !========================================================================================! !========================================================================================! diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 7bb3ede9..566d9d3d 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -264,6 +264,9 @@ subroutine parse_setting_auto(env,job,kv,rd) job%id = jobtype%lj case ('modh') job%id = jobtype%approxg + case ('rmsdbias','penalty') + job%id = jobtype%penalty + nullify(job%penalty%biaslist) case default job%id = jobtype%unknown !>--- keyword was recognized, but invalid argument supplied @@ -389,6 +392,21 @@ subroutine parse_setting_auto(env,job,kv,rd) call creststop(status_input) end if + case ('biasfile') + inquire (file=kv%value_c,exist=ex) + if (ex) then + job%penalty%biasfile = kv%value_c + else + write (stderr,'(a,a,a)') 'specified bias file ',kv%value_c,' does not exist' + call creststop(status_input) + end if + + case ('penalty_kpush') + job%penalty%kpush = kv%value_f + + case ('penalty_alpha') + job%penalty%alpha = kv%value_f + case ('parametrisation') inquire (file=kv%value_c,exist=ex) if (ex) then @@ -525,23 +543,23 @@ subroutine parse_calc_auto(env,calc,kv,rd) case ('hguess') calc%hguess = kv%value_f !> guess for the initial hessian - + case ('opt_lval') calc%L = kv%value_f !> Parameters for smooth function for stepsize control within optimizer - - case('opt_k') + + case ('opt_k') calc%k = kv%value_f - - case('opt_shift') + + case ('opt_shift') calc%shift = kv%value_f - case('scaling') + case ('scaling') calc%scaling = kv%value_f - case('doh_stepsize') + case ('doh_stepsize') calc%doh_stepsize = kv%value_f - case('chess_id_guess') + case ('chess_id_guess') calc%chess_id_guess = kv%value_f !>--- integers @@ -596,7 +614,7 @@ subroutine parse_calc_auto(env,calc,kv,rd) calc%opt_engine = 1 case ('rfo','rfo-cart') calc%opt_engine = 2 - case('newton','nr') + case ('newton','nr') calc%opt_engine = 3 case ('gd','gradient descent') calc%opt_engine = -1 @@ -608,18 +626,18 @@ subroutine parse_calc_auto(env,calc,kv,rd) case ('hr_init','hr_initialization') !> here we set how the matrix for hessian reconstruction is initialized select case (kv%value_c) - case('identity') + case ('identity') calc%initialize_hr_type = 0 - case('gfnff', 'gfn-ff') + case ('gfnff','gfn-ff') calc%initialize_hr_type = 1 - case('gfn0') - calc%initialize_hr_type = 2 - case('gfn1') - calc%initialize_hr_type = 3 - case('gfn2') - calc%initialize_hr_type = 4 - case('modhess') - calc%initialize_hr_type = 5 + case ('gfn0') + calc%initialize_hr_type = 2 + case ('gfn1') + calc%initialize_hr_type = 3 + case ('gfn2') + calc%initialize_hr_type = 4 + case ('modhess') + calc%initialize_hr_type = 5 case default !>--- keyword was recognized, but invalid argument supplied write (stdout,fmtura) kv%value_c @@ -628,41 +646,41 @@ subroutine parse_calc_auto(env,calc,kv,rd) case ('modhess_type','mh_type') !> here we set how the matrix for hessian reconstruction is initialized select case (kv%value_c) !>maybe need to add another keywort for crosstesting hr and geopt -> No, - case('lindh95') + case ('lindh95') calc%mh_type = 0 - case('lindh') + case ('lindh') calc%mh_type = 1 - case('lindh07') - calc%mh_type = 2 - case('swart') - calc%mh_type = 3 + case ('lindh07') + calc%mh_type = 2 + case ('swart') + calc%mh_type = 3 case default !>--- keyword was recognized, but invalid argument supplied write (stdout,fmtura) kv%value_c call creststop(status_config) end select - case ('hess_init','hess_initialization') !> here we set how the hessian for optimization - select case (kv%value_c) - case('identity') - calc%hess_init = 0 - case('gfnff', 'gfn-ff') - calc%hess_init = 1 - case('gfn0') - calc%hess_init = 2 - case('gfn1') - calc%hess_init = 3 - case('gfn2') - calc%hess_init = 4 - case('modhess') - calc%hess_init = 5 - case default - !>--- keyword was recognized, but invalid argument supplied - write (stdout,fmtura) kv%value_c - call creststop(status_config) - end select + case ('hess_init','hess_initialization') !> here we set how the hessian for optimization + select case (kv%value_c) + case ('identity') + calc%hess_init = 0 + case ('gfnff','gfn-ff') + calc%hess_init = 1 + case ('gfn0') + calc%hess_init = 2 + case ('gfn1') + calc%hess_init = 3 + case ('gfn2') + calc%hess_init = 4 + case ('modhess') + calc%hess_init = 5 + case default + !>--- keyword was recognized, but invalid argument supplied + write (stdout,fmtura) kv%value_c + call creststop(status_config) + end select - case ('hr_hess_update','hr_hu_update') + case ('hr_hess_update','hr_hu_update') select case (kv%value_c) !> Hessian updates in hessian reconstruction case ('bfgs') calc%hr_hu_type = 0 @@ -697,11 +715,11 @@ subroutine parse_calc_auto(env,calc,kv,rd) case ('full_chess') !> Do Hessian Reconstruct with all optimization steps calc%full_HR = kv%value_b - + case ('deform_opt_hess') calc%deform_opt_hess = kv%value_b - case("g_sampling") !> Do sampling on free energy surface as approximated by lindh95 hessian + case ("g_sampling") !> Do sampling on free energy surface as approximated by lindh95 hessian calc%g_sampling = kv%value_b case default diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index 5c73daba..61dad8c7 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -282,7 +282,7 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient,ccache) result(rmsdval) !> calculate call rmsd_core(nat,scratchptr(1:3,1:nat,1),scratchptr(1:3,1:nat,2), & - & calc_u,Udum,rmsdval,getgrad,grdptr,ccptr) + & calc_u,Udum,rmsdval,getgrad,grdptr(1:3,:),ccptr) !> go backwards through gradient (if necessary) to restore atom order if (getgrad) then @@ -302,7 +302,7 @@ function rmsd(ref,mol,mask,scratch,rotmat,gradient,ccache) result(rmsdval) else !>--- standard calculation (quaternion algorithm, no mask) call rmsd_core(ref%nat,mol%xyz,ref%xyz, & - & calc_u,Udum,rmsdval,getgrad,grdptr,ccptr) + & calc_u,Udum,rmsdval,getgrad,grdptr(1:3,:),ccptr) end if !> pass on rotation matrix if asked for @@ -402,7 +402,7 @@ subroutine rmsd_core(nat,xyz1,xyz2,calc_u,U,error,calc_g,grad,ccache) return end if - if (calc_u) then + if (calc_u.or.calc_g) then !> reset U(:,:) = Imat(:,:) !> convert quaternion q to rotation matrix U From 880396486d0df8896531297056a1178916190126 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 4 Mar 2026 14:54:26 +0100 Subject: [PATCH 190/374] ORCA .hess reader for thermo --- src/algos/numhess.f90 | 26 ++--- src/confparse.f90 | 119 +++++++++++++++++++-- src/entropy/thermocalc.f90 | 188 +++++++++++++++++++++++++++++++-- src/parsing/parse_maindata.f90 | 5 + 4 files changed, 307 insertions(+), 31 deletions(-) diff --git a/src/algos/numhess.f90 b/src/algos/numhess.f90 index d0d2c205..6c4fcea2 100644 --- a/src/algos/numhess.f90 +++ b/src/algos/numhess.f90 @@ -363,12 +363,12 @@ subroutine thermo_standalone(env) & '(10x,"::",1x,a,f24.12,1x,a,1x,"::")' !> header - write (stdout,*) " _ _ " - write (stdout,*) "| |_| |__ ___ _ __ _ __ ___ ___ " - write (stdout,*) "| __| '_ \ / _ \ '__| '_ ` _ \ / _ \ " - write (stdout,*) "| |_| | | | __/ | | | | | | | (_) |" - write (stdout,*) " \__|_| |_|\___|_| |_| |_| |_|\___/ " - write (stdout,*) " " + write (stdout,'(t10,a)') " _ _ " + write (stdout,'(t10,a)') "| |_| |__ ___ _ __ _ __ ___ ___ " + write (stdout,'(t10,a)') "| __| '_ \ / _ \ '__| '_ ` _ \ / _ \ " + write (stdout,'(t10,a)') "| |_| | | | __/ | | | | | | | (_) |" + write (stdout,'(t10,a)') " \__|_| |_|\___|_| |_| |_| |_|\___/ " + write (stdout,'(t10,a)') " " write (stdout,*) "Molecular thermodynamics from the modified and scaled" write (stdout,*) "rigid-rotor harmonic-oscillator approximation (msRRHO)" write (stdout,*) "See:" @@ -377,21 +377,21 @@ subroutine thermo_standalone(env) write (stdout,*) !> input coords - write (stdout,'(1x,a)',advance='no') 'Reading input coords: ' + write (stdout,'(1x,a,t30)',advance='no') 'Reading input coords:' if (allocated(env%thermo%coords)) then call mol%open(env%thermo%coords) - write (stdout,'(1x,a)') trim(env%thermo%coords) + write (stdout,'(a)') trim(env%thermo%coords) else call mol%open(env%inputcoords) - write (stdout,'(1x,a)') trim(env%inputcoords) + write (stdout,'(a)') trim(env%inputcoords) end if nat3 = mol%nat*3 - allocate (hess(nat3,nat3),freq(nat3),source=0.0_wp) + allocate (freq(nat3),source=0.0_wp) !> input frequencies or hessian if (allocated(env%thermo%vibfile)) then - write (stdout,'(1x,a,a)') 'Reading frequencies from: ',trim(env%thermo%vibfile) - call rdfreq(env%thermo%vibfile,nat3,freq) + write (stdout,'(1x,a,t30,a)') 'Reading frequencies from:',trim(env%thermo%vibfile) + call rdfreq(mol,env%thermo%vibfile,nat3,freq) else write (stdout,'(1x,a)') 'No Hessian or vibspectrum file allocated for thermo routine!' call creststop(status_input) @@ -422,7 +422,7 @@ subroutine thermo_standalone(env) !> calcthermo wants input in Bohr call calcthermo(mol%nat,mol%at,mol%xyz,freq,.true., & - & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,iunit,emodel=emodel) + & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,stdout,emodel=emodel) !> printout zpve = et(nrt)-ht(nrt) diff --git a/src/confparse.f90 b/src/confparse.f90 index 7bf8de41..925a1ca7 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -61,10 +61,13 @@ subroutine parseflags(env,arg,nra) integer :: ctype logical :: ex,bondconst character(len=:),allocatable :: argument + logical,allocatable :: processedarg(:) allocate (xx(10),floats(3),strings(3)) ctmp = '' dtmp = '' + + allocate (processedarg(nra),source=.false.) !========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>! !> Set the defaults @@ -93,6 +96,7 @@ subroutine parseflags(env,arg,nra) !=========================================================================================! !>--- check if help is requested or citations shall be diplayed do i = 1,nra + if (processedarg(i)) cycle if (any((/character(6)::'-h','-H','--h','--H','--help'/) == trim(arg(i)))) then if (nra > i) then ctmp = trim(arg(i+1)) @@ -107,12 +111,15 @@ subroutine parseflags(env,arg,nra) end if if (index(arg(i),'-newversion') .ne. 0) then !> as in CREST version >= 3.0 env%legacy = .false. + processedarg(i) = .true. end if if (index(arg(i),'-legacy') .ne. 0) then !> as in CREST version <3.0 env%legacy = .true. + processedarg(i) = .true. end if if (index(arg(i),'-dry') .ne. 0) then !> "dry" run to print settings env%dryrun = .true. + processedarg(i) = .true. end if end do @@ -335,10 +342,12 @@ subroutine parseflags(env,arg,nra) call find_input_file(arg,nra,idum) if (idum .ne. 0) then call parseinputfile(env,trim(arg(idum))) + processedarg(idum) = .true. end if !>--- first arg loop do i = 1,nra + if (processedarg(i)) cycle argument = trim(arg(i)) if (argument(1:2) == '--') then argument = argument(2:) @@ -347,6 +356,7 @@ subroutine parseflags(env,arg,nra) select case (argument) !> RUNTYPES case ('-v1') !> confscript version 1 (MF-MD-GC) + processedarg(i) = .true. env%crestver = crest_mfmdgc write (*,'(2x,a,'' : MF-MD-GC'')') trim(arg(i)) env%mdtime = 40.0d0 !> simulation length of the MD, 40ps total (2*20ps)(default for QMDFF would be 500) @@ -357,6 +367,7 @@ subroutine parseflags(env,arg,nra) exit case ('-v2') !> confscript version 2 (MTD-GC) + processedarg(i) = .true. env%crestver = crest_imtd write (*,'(2x,a,'' : MTD-GC'')') trim(arg(i)) env%iterativeV2 = .false. !> iterative crest V2 version @@ -364,12 +375,14 @@ subroutine parseflags(env,arg,nra) exit case ('-v3','-v2i') !> confscript version 2 but iterativ (iMTD-GC) + processedarg(i) = .true. env%crestver = crest_imtd env%iterativeV2 = .true. write (*,'(2x,a,'' : iMTD-GC'')') trim(arg(i)) exit case ('-v4') !> sMTD-iMTD (same as entropy mode) + processedarg(i) = .true. env%crestver = crest_imtd2 env%iterativeV2 = .true. env%entropymd = .true. @@ -380,28 +393,32 @@ subroutine parseflags(env,arg,nra) exit case ('-mdopt','-purge') !> MDOPT + processedarg(i) = .true. env%crestver = crest_mdopt atmp = '' env%preopt = .false. env%ensemblename = 'none selected' if (nra .ge. (i+1)) atmp = adjustl(arg(i+1)) if ((atmp(1:1) /= '-').and.(len_trim(atmp) .ge. 1)) then + processedarg(i+1) = .true. env%ensemblename = trim(atmp) + call xyz2coord(env%ensemblename,'coord') !> write coord from lowest structure + env%inputcoords = env%ensemblename !> just for a printout end if - call xyz2coord(env%ensemblename,'coord') !> write coord from lowest structure - env%inputcoords = env%ensemblename !> just for a printout exit case ('-screen') !> SCREEN + processedarg(i) = .true. env%crestver = crest_screen atmp = '' env%ensemblename = 'none selected' if (nra .ge. (i+1)) atmp = adjustl(arg(i+1)) if ((atmp(1:1) /= '-').and.(len_trim(atmp) .ge. 1)) then + processedarg(i+1) = .true. env%ensemblename = trim(atmp) + call xyz2coord(env%ensemblename,'coord') !write coord from lowest structure + env%inputcoords = env%ensemblename !just for a printout end if - call xyz2coord(env%ensemblename,'coord') !write coord from lowest structure - env%inputcoords = env%ensemblename !just for a printout exit case ('-mdsp','-ensemblesp') !> Singlepoints along ensemble @@ -411,13 +428,15 @@ subroutine parseflags(env,arg,nra) env%ensemblename = 'none selected' if (nra .ge. (i+1)) atmp = adjustl(arg(i+1)) if ((atmp(1:1) /= '-').and.(len_trim(atmp) .ge. 1)) then + processedarg(i+1) = .true. env%ensemblename = trim(atmp) + call xyz2coord(env%ensemblename,'coord') !> write coord from lowest structure + env%inputcoords = env%ensemblename !> just for a printout end if - call xyz2coord(env%ensemblename,'coord') !> write coord from lowest structure - env%inputcoords = env%ensemblename !> just for a printout exit case ('-pka','-pKa') !> pKa calculation script + processedarg(i) = .true. env%crestver = crest_pka env%runver = 33 !env%relax=.true. @@ -432,6 +451,7 @@ subroutine parseflags(env,arg,nra) if (env%protb%h_acidic == -2) env%protb%pka_baseinp = trim(arg(i+1)) case ('-compare') !> flag for comparing two ensembles, analysis tool + processedarg(i) = .true. env%compareens = .true. env%crestver = 5 env%properties = p_compare @@ -449,11 +469,14 @@ subroutine parseflags(env,arg,nra) & (btmp(1:1) /= '-').and.(len_trim(btmp) .ge. 1)) then env%ensemblename = trim(atmp) env%ensemblename2 = trim(btmp) + processedarg(i+1) = .true. + processedarg(i+2) = .true. end if write (*,'(1x,a,1x,a,1x,a)') trim(arg(i)),trim(env%ensemblename),trim(env%ensemblename2) exit case ('-protonate') !> protonation tool + processedarg(i) = .true. env%properties = p_protonate env%crestver = crest_protonate env%legacy = .true. !> TODO, set active at later version @@ -461,6 +484,7 @@ subroutine parseflags(env,arg,nra) exit case ('-deprotonate') !> deprotonation tool + processedarg(i) = .true. env%properties = p_deprotonate env%crestver = crest_deprotonate env%legacy = .true. !> TODO, set active at later version @@ -468,6 +492,7 @@ subroutine parseflags(env,arg,nra) exit case ('-tautomerize') !> tautomerization tool + processedarg(i) = .true. env%properties = p_tautomerize env%crestver = crest_tautomerize env%legacy = .true. !> TODO, set active at later version @@ -475,18 +500,21 @@ subroutine parseflags(env,arg,nra) exit case ('-isomerize','-stereomers') !> isomerization tool + processedarg(i) = .true. env%properties = p_isomerize write (*,'(2x,a,'' : automated stereoisomerization script'')') trim(arg(i)) write (*,'(2x,''Note: Use of GFN-FF required for stereoisomer generation.'')') exit case ('-forall','-for') !> property mode with ensemble as input + processedarg(i) = .true. env%properties = p_propcalc atmp = '' env%ensemblename = 'none selected' if (nra .ge. (i+1)) atmp = adjustl(arg(i+1)) if ((atmp(1:1) /= '-').and.(len_trim(atmp) .ge. 1)) then env%ensemblename = trim(atmp) + processedarg(i+1) = .true. end if inquire (file=env%ensemblename,exist=ex) if (.not.ex) then @@ -501,12 +529,14 @@ subroutine parseflags(env,arg,nra) exit case ('-rrhoav') !> Hessians along given ensemble and average + processedarg(i) = .true. env%properties = p_rrhoaverage atmp = '' env%ensemblename = 'none selected' if (nra .ge. (i+1)) atmp = adjustl(arg(i+1)) if ((atmp(1:1) /= '-').and.(len_trim(atmp) .ge. 1)) then env%ensemblename = trim(atmp) + processedarg(i+1) = .true. end if inquire (file=env%ensemblename,exist=ex) if (.not.ex) then @@ -516,16 +546,30 @@ subroutine parseflags(env,arg,nra) exit case ('-reactor') !> xtb nanoreactor workarounds + processedarg(i) = .true. env%preopt = .false. env%crestver = crest_nano exit case ('-solvtool','-qcg') + processedarg(i) = .true. !> Set solute file if present - if (i == 2) env%solu_file = trim(arg(i-1)) + if (i == 2) then + env%solu_file = trim(arg(i-1)) + inquire (file=env%solu_file,exist=ex) + if (ex) then + processedarg(i-1) = .true. + end if + end if !> Set solvent file if prensent !> If it is another argument, it doesent matter as solvent file is checke in solvtool - if (nra >= i+1) env%solv_file = trim(arg(i+1)) + if (nra >= i+1) then + env%solv_file = trim(arg(i+1)) + inquire (file=env%solv_file,exist=ex) + if (ex) then + processedarg(i+1) = .true. + end if + end if !> Set QCG defaults env%preopt = .false. env%crestver = crest_solv @@ -541,6 +585,7 @@ subroutine parseflags(env,arg,nra) env%legacy = .true. !> force legacy routines for now case ('-compress') + processedarg(i) = .true. env%crestver = crest_compr env%runver = 77 env%mdstep = 2.5d0 @@ -549,87 +594,109 @@ subroutine parseflags(env,arg,nra) exit case ('-msreact') + processedarg(i) = .true. env%crestver = crest_msreac env%preopt = .false. env%presp = .true. env%ewin = 200.0d0 !> 200 kcal for msreact case ('-splitfile') + processedarg(i) = .true. ctmp = trim(arg(i+1)) + processedarg(i+1) = .true. k = huge(j) l = 1 if (nra >= i+2) then read (arg(i+2),*,iostat=io) j if (io == 0) then k = j + processedarg(i+2) = .true. end if end if if (nra >= i+3) then read (arg(i+3),*,iostat=io) j if (io == 0) then l = j + processedarg(i+3) = .true. end if end if call splitfile(ctmp,k,l) stop case ('-printaniso') + processedarg(i) = .true. ctmp = trim(arg(i+1)) inquire (file=ctmp,exist=ex) if (ex) then + processedarg(i+1) = .true. call printaniso(ctmp,0.01_wp,0.025_wp,0.5_wp) end if stop case ('-rotalign') + processedarg(i) = .true. ctmp = trim(arg(i+1)) inquire (file=ctmp,exist=ex) if (ex) then + processedarg(i+1) = .true. call rotalign_tool(ctmp) end if stop case ('-printboltz') + processedarg(i) = .true. if (nra >= i+2) then ctmp = trim(arg(i+1)) dtmp = trim(arg(i+2)) call prbweight(ctmp,dtmp) + processedarg(i+1) = .true. + processedarg(i+2) = .true. else ctmp = trim(arg(i+1)) call prbweight(ctmp,'') + processedarg(i+1) = .true. end if case ('-wbotopo','-usewbo') !> try to use a WBO file in topology analysis + processedarg(i) = .true. ctmp = trim(arg(i+1)) if (ctmp(1:1) .ne. '-'.and.(nra >= i+1)) then env%wbofile = trim(ctmp) + processedarg(i+1) = .true. else env%wbofile = 'wbo' end if env%wbotopo = .true. case ('-testtopo') + processedarg(i) = .true. ctmp = trim(arg(i+1)) inquire (file=ctmp,exist=ex) if (i+2 .le. nra) then dtmp = trim(arg(i+2)) if (dtmp(1:1) == '-') then dtmp = 'default' + else + processedarg(i+2) = .true. end if end if if (ex) then + processedarg(i+1) = .true. call testtopo(ctmp,env,dtmp) end if case ('-resortensemble') + processedarg(i) = .true. ctmp = trim(arg(i+1)) inquire (file=ctmp,exist=ex) if (ex) then + processedarg(i+1) = .true. call resort_ensemble(ctmp) end if stop case ('-thermo','-thermotool') + processedarg(i) = .true. env%properties = p_thermo ctmp = trim(arg(1)) ! first argument to read the structure if (ctmp(1:1) .ne. '-') then @@ -638,10 +705,12 @@ subroutine parseflags(env,arg,nra) end if ctmp = trim(arg(i+1)) ! second argument to read the vibspectrum if (ctmp(1:1) .ne. '-') then + processedarg(i+1) = .true. env%thermo%vibfile = trim(ctmp) end if case ('-rmsd','-rmsdheavy','-hrmsd') + processedarg(i) = .true. if ((argument == '-rmsdheavy').or.(argument == '-hrmsd')) then env%sortmode = 'hrmsd' else @@ -655,13 +724,16 @@ subroutine parseflags(env,arg,nra) if (ex) then env%inputcoords = ctmp env%ensemblename = ctmp + processedarg(i+1) = .true. end if inquire (file=dtmp,exist=ex) if (ex) then env%ensemblename2 = dtmp + processedarg(i+2) = .true. end if case ('-irmsd','-irmsd_noinv') + processedarg(i) = .true. ctmp = trim(arg(i+1)) dtmp = trim(arg(i+2)) env%preopt = .false. @@ -671,16 +743,19 @@ subroutine parseflags(env,arg,nra) if (ex) then env%inputcoords = ctmp env%ensemblename = ctmp + processedarg(i+1) = .true. end if inquire (file=dtmp,exist=ex) if (ex) then env%ensemblename2 = dtmp + processedarg(i+2) = .true. end if if (index(argument,'_noinv') .ne. 0) then env%iinversion = 2 end if case ('-hungarian','-hungarianheavy','-hhungarian','-lsap','-hlsap','-lsapheavy') + processedarg(i:i+2) = .true. ctmp = trim(arg(i+1)) dtmp = trim(arg(i+2)) if ((argument == '-hungarianheavy').or.(argument == '-hhungarian').or. & @@ -692,29 +767,36 @@ subroutine parseflags(env,arg,nra) stop case ('-symmetries') + processedarg(i) = .true. ctmp = trim(arg(i+1)) inquire (file=ctmp,exist=ex) if (ex) then + processedarg(i+1) = .true. call ensemble_analsym(trim(ctmp),.true.) end if stop case ('-exlig','-exligand','-exchligand') + processedarg(i) = .true. env%properties = p_ligand env%protb%infile = trim(arg(1)) ctmp = trim(arg(i+1)) + processedarg(i+1) = .true. env%protb%newligand = trim(ctmp) read (arg(i+2),*,iostat=io) j if (io == 0) then env%protb%centeratom = j + processedarg(i+2) = .true. end if read (arg(i+3),*,iostat=io) j if (io == 0) then env%protb%ligand = j + processedarg(i+3) = .true. end if exit case ("-acidbase","-ab",'-abprep','-pkaprep','-gdissprep') !-- acid base correction + processedarg(i) = .true. !> crest --ab --chrg env%properties = p_acidbase if (index(arg(i),'prep') .ne. 0) then @@ -723,12 +805,14 @@ subroutine parseflags(env,arg,nra) ctmp = trim(arg(i+1)) inquire (file=ctmp,exist=ex) if (ex) then + processedarg(i+1) = .true. env%protb%pka_acidensemble = trim(ctmp) write (*,'(1x,a,a)') 'File used for the acid: ',trim(ctmp) end if ctmp = trim(arg(i+2)) inquire (file=ctmp,exist=ex) if (ex) then + processedarg(i+2) = .true. env%protb%pka_baseensemble = trim(ctmp) write (*,'(1x,a,a)') 'File used for the base: ',trim(ctmp) end if @@ -737,9 +821,12 @@ subroutine parseflags(env,arg,nra) env%gfnver = '--gfn2' case ('-redoextrapol') + processedarg(i) = .true. ctmp = trim(arg(i+1)) + processedarg(i+1) = .true. read (arg(i+2),*,iostat=io) j if (io == 0) then + processedarg(i+2) = .true. call redo_extrapol(ctmp,j) else call redo_extrapol(ctmp,0) @@ -747,12 +834,14 @@ subroutine parseflags(env,arg,nra) stop case ('-sp') !> singlepoint calculation (uses new calculator routines) + processedarg(i) = .true. env%crestver = crest_sp env%preopt = .false. env%legacy = .false. exit case ('-opt','-optimize','-ancopt','-ohess') !> ANCOPT structure optimization (uses new calculator routines) + processedarg(i) = .true. env%preopt = .false. env%crestver = crest_optimize env%legacy = .false. @@ -760,45 +849,56 @@ subroutine parseflags(env,arg,nra) exit case ('-hess','-numhess') !> Numerical hessian + processedarg(i) = .true. env%preopt = .false. env%crestver = crest_numhessian env%legacy = .false. exit case ('-trialopt') !> test optimization with topocheck + processedarg(i) = .true. env%preopt = .false. env%crestver = crest_trialopt exit case ('-dynamics','-dyn') !> molecular dynamics (uses new calculator routines) + processedarg(i) = .true. env%preopt = .false. env%crestver = crest_moldyn env%legacy = .false. exit case ('-sort') + processedarg(i) = .true. env%preopt = .false. env%crestver = crest_sorting ctmp = trim(arg(i+1)) inquire (file=ctmp,exist=ex) if (ex) then + processedarg(i+1) = .true. env%inputcoords = ctmp env%ensemblename = ctmp end if if (nra >= i+2) then ctmp = trim(arg(i+2)) - if (ctmp(1:1) .ne. '-') env%sortmode = trim(ctmp) + if (ctmp(1:1) .ne. '-')then + processedarg(i+2) = .true. + env%sortmode = trim(ctmp) + endif end if case ('-bh','-GMIN') + processedarg(i) = .true. env%crestver = crest_bh exit case ('-SANDBOX') + processedarg(i) = .true. !>--- IMPLEMENT HERE WHATEVER YOU LIKE, FOR TESTING !>----- stop case ('-PLAYGROUND','-TEST') + processedarg(i) = .true. env%preopt = .false. env%crestver = crest_test exit @@ -847,6 +947,7 @@ subroutine parseflags(env,arg,nra) call inputcoords(env,env%inputcoords) else call inputcoords(env,trim(arg(1))) + processedarg(1) = .true. end if !========================================================================================! diff --git a/src/entropy/thermocalc.f90 b/src/entropy/thermocalc.f90 index 0da43bf4..dabb67b0 100644 --- a/src/entropy/thermocalc.f90 +++ b/src/entropy/thermocalc.f90 @@ -143,7 +143,7 @@ subroutine thermo_wrap_legacy(env,pr,nat,at,xyz,dirname, & nfreq = 3*mol%nat allocate (freq(nfreq)) - call rdfreq(trim(optpath)//'vibspectrum',nfreq,freq) + call rdfreq(mol,trim(optpath)//'vibspectrum',nfreq,freq) ithr = env%thermo%ithr fscal = env%thermo%fscal @@ -157,7 +157,49 @@ subroutine thermo_wrap_legacy(env,pr,nat,at,xyz,dirname, & end subroutine thermo_wrap_legacy !=========================================================================================! -subroutine rdfreq(fname,nmodes,freq) + +subroutine rdfreq(mol,fname,nmodes,freq) +!************************************** +!* read vibspectrum file in TM format +!************************************** + use crest_parameters,only:wp + use crest_data + use iomod + use strucrd + implicit none + type(coord),intent(in) :: mol + character(len=*),intent(in) :: fname + integer,intent(in) :: nmodes + real(wp),intent(out) :: freq(nmodes) !frequencies + + logical :: ex,ex2,ex3 + type(coord) :: moltmp + freq(:) = 0.0_wp + + inquire (file=fname,exist=ex) + if (.not.ex) return + + call minigrep(fname,'$vibrational spectrum',ex) + if (ex) then + !> TURBOMOLE "vibspectrum"-style file + call rdfreq_vibspectrum_file(fname,nmodes,freq) + end if + call minigrep(fname,'$orca_hessian_file',ex) + call minigrep(fname,'$hessian',ex2) + call minigrep(fname,'$ir_spectrum',ex3) + !if (ex.and.ex3) then + ! !> ORCA ".hess" file --> frequencies directly + ! call rdfreq_orca_ir_spectrum(fname,nmodes,freq) + !else if (ex.and.ex2) then + if(ex.and.ex2)then + !> ORCA ".hess" file --> from Hessian + moltmp = mol + call rdfreq_orca_hess(moltmp,fname,nmodes,freq) + end if + +end subroutine rdfreq + +subroutine rdfreq_vibspectrum_file(fname,nmodes,freq) !************************************** !* read vibspectrum file in TM format !************************************** @@ -174,12 +216,6 @@ subroutine rdfreq(fname,nmodes,freq) logical :: ex integer :: TID,OMP_GET_THREAD_NUM -!!$OMP PARALLEL PRIVATE(TID) - TID = OMP_GET_THREAD_NUM() -! write(*,*) '---->',TID -!!$OMP END PARALLEL - ich = (TID+1)*1000 ! generate CPU dependent file channel number - freq = 0.0_wp inquire (file=fname,exist=ex) if (.not.ex) return @@ -202,7 +238,141 @@ subroutine rdfreq(fname,nmodes,freq) end do rdfile close (ich) return -end subroutine rdfreq +end subroutine rdfreq_vibspectrum_file + +subroutine rdfreq_orca_ir_spectrum(fname,nmodes,freq) +!************************************** +!* read vibspectrum file in TM format +!************************************** + use crest_parameters,only:wp,stdout + use crest_data + use iomod + implicit none + character(len=*),intent(in) :: fname + integer,intent(in) :: nmodes + real(wp),intent(out) :: freq(nmodes) !frequencies + integer :: k,ich,io,n,nref + character(len=256) :: atmp + real(wp) :: floats(10) + logical :: ex + + freq = 0.0_wp + k = 1 !modes + open (file=fname,unit=ich) + rdfile: do + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + if (index(atmp,'$ir_spectrum') .ne. 0) then + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit rdfile + read (atmp,*,iostat=io) nref + if (io .ne. 0) exit rdfile + if (nref .ne. nmodes) exit rdfile + rdblock: do + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit rdfile + if (index(atmp,'$end') .ne. 0) exit rdfile + if (index(atmp,'#') .ne. 0) cycle rdblock !skip comment lines + call readl(atmp,floats,n) + freq(k) = floats(1) + if (k == nref) exit rdfile + k = k+1 + end do rdblock + end if + end do rdfile + if (k .ne. nmodes) then + write (stdout,*) '** WARNING ** error while reading '//trim(fname) + end if + close (ich) + return +end subroutine rdfreq_orca_ir_spectrum + +subroutine rdfreq_orca_hess(mol,fname,nmodes,freq) +!************************************** +!* read vibspectrum file in TM format +!************************************** + use crest_parameters,only:wp,stdout + use crest_data + use iomod + use strucrd + use thermochem_module + implicit none + type(coord),intent(inout) :: mol + character(len=*),intent(in) :: fname + integer,intent(in) :: nmodes + real(wp),intent(out) :: freq(nmodes) !frequencies + integer :: k,ich,io,n,nref + integer :: ii,jj,kk,iblocks,jblocks,ll + character(len=256) :: atmp + real(wp) :: floats(10) + logical :: ex + real(wp),allocatable :: hess(:,:) + + freq = 0.0_wp + allocate (hess(nmodes,nmodes),source=0.0_wp) + k = 1 !modes + open (file=fname,unit=ich) + rdfile: do + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + if (index(atmp,'$hessian') .ne. 0) then + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit rdfile + read (atmp,*,iostat=io) nref + if (io .ne. 0) exit rdfile + if (nref .ne. nmodes) exit rdfile + iblocks = (floor(real(nref,wp)/5.0_wp)) + jblocks = nref-(iblocks*5) + rdblock1: do ii = 1,iblocks + do jj = 0,nref + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit rdfile + if (index(atmp,'$end') .ne. 0) exit rdfile + if (index(atmp,'#') .ne. 0) cycle rdblock1 !skip comment lines + call readl(atmp,floats,n) + if (jj > 0) then + kk = (ii-1)*5 + do ll = 1,5 + hess(kk+ll,jj) = floats(1+ll) + end do + end if + end do + end do rdblock1 + if (jblocks > 0) then + do jj = 0,nref + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit rdfile + if (index(atmp,'$end') .ne. 0) exit rdfile + if (index(atmp,'#') .ne. 0) cycle + call readl(atmp,floats,n) + if (jj > 0) then + kk = (ii-1)*5 + do ll = 1,jblocks + hess(kk+ll,jj) = floats(1+ll) + end do + end if + end do + end if + end if + end do rdfile + if (nref .ne. nmodes) then + write (stdout,*) '** WARNING ** error while reading '//trim(fname) + end if + close (ich) + + write(stdout,'(a)',advance='no') ' Processing (raw) Hessian read from ORCA '//trim(fname)//' ... ' + flush(stdout) + !$omp critical + !>-- Projects and mass-weights the Hessian + call prj_mw_hess(mol%nat,mol%at,nmodes,mol%xyz,hess) + !>-- Computes the Frequencies + call frequencies(mol%nat,mol%at,mol%xyz,nmodes,hess,freq,io) + !$omp end critical + write(stdout,'(a)') 'done.' + + deallocate (hess) + return +end subroutine rdfreq_orca_hess !=========================================================================================! diff --git a/src/parsing/parse_maindata.f90 b/src/parsing/parse_maindata.f90 index e3361d92..962138f7 100644 --- a/src/parsing/parse_maindata.f90 +++ b/src/parsing/parse_maindata.f90 @@ -257,6 +257,11 @@ subroutine parse_main_c(env,key,val,rd) env%properties = p_tautomerize env%crestver = crest_tautomerize + case ('thermo') + env%properties = p_thermo + env%crestver = crest_none + env%preopt = .false. + case default !>--- keyword was recognized, but invalid argument supplied write (stdout,fmtura) val From a3426b4029b8a0f634be76ba827b7dd46fa8f2a6 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 5 Mar 2026 11:15:49 +0100 Subject: [PATCH 191/374] =?UTF-8?q?allow=20coord=20files=20to=20be=20speci?= =?UTF-8?q?fied=20in=20Angstr=C3=B6m?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/strucreader.f90 | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/strucreader.f90 b/src/strucreader.f90 index ee0de176..48e1f21a 100644 --- a/src/strucreader.f90 +++ b/src/strucreader.f90 @@ -1005,7 +1005,7 @@ subroutine rdcoord(fname,nat,at,xyz,energy) call checkcoordtype(fname,ftype) select case (ftype) - case (tmcoord) !-- TM coord file, is already in Bohr + case (tmcoord) !-- TM coord file, always retruns coords in Bohr call rdtmcoord(fname,nat,at,xyz) case (xmol) !-- XYZ file, is Angström, needs conversion if (present(energy)) then @@ -1051,6 +1051,7 @@ subroutine rdtmcoord(fname,nat,at,xyz) real(wp),intent(inout) :: xyz(3,nat) character(len=6) :: sym integer :: ich,io,i + real(wp) :: convert character(len=256) :: atmp open (newunit=ich,file=fname) do @@ -1059,6 +1060,12 @@ subroutine rdtmcoord(fname,nat,at,xyz) atmp = adjustl(atmp) if (index(atmp,"$coord") .eq. 1) exit end do + if(index(atmp,'ang').ne.0)then + !> coord files allow explicit specification in Angström + convert = aatoau + else + convert = 1.0_wp + endif do i = 1,nat read (ich,'(a)',iostat=io) atmp if (io < 0) exit @@ -1072,6 +1079,7 @@ subroutine rdtmcoord(fname,nat,at,xyz) at(i) = e2i(sym) end do close (ich) + xyz = xyz*convert return end subroutine rdtmcoord From 885b29e79511ce0baf9083b8886e84edae16233d Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 5 Mar 2026 14:57:54 +0100 Subject: [PATCH 192/374] Clean up CLI arguments --> map usage, terminate for invalid configs --- src/algos/setuptest.f90 | 2 +- src/classes.f90 | 40 +- src/confparse.f90 | 1398 ++++++++++++++++++++++++++++++--------- src/legacy_wrappers.f90 | 3 +- src/readl.f90 | 9 + 5 files changed, 1109 insertions(+), 343 deletions(-) diff --git a/src/algos/setuptest.f90 b/src/algos/setuptest.f90 index 460a0983..c53e2bc3 100644 --- a/src/algos/setuptest.f90 +++ b/src/algos/setuptest.f90 @@ -316,7 +316,7 @@ subroutine trialOPT_calculator(env) tmpcalc%optlev = -1 !> set loose convergence thresholds !>--- perform geometry optimization - pr = .false. !> stdout printout + pr = env%crestver == crest_trialopt wr = .true. !> write crestopt.log.xyz if (wr) then call remove('crestopt.log.xyz') diff --git a/src/classes.f90 b/src/classes.f90 index 4fb6a3de..897a047a 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -969,27 +969,31 @@ function optlevflag(optlev) result(flag) return end function optlevflag - function optlevnum(flag) result(optlev) + function optlevnum(flag,iostat) result(optlev) implicit none real(wp) :: optlev - character(len=*):: flag + character(len=*),intent(in) :: flag + integer,intent(out),optional :: iostat + if(present(iostat)) iostat = 0 optlev = 0.0_wp - if (index(flag,'crude') .ne. 0) optlev = -3.0d0 - if (index(flag,'loose') .ne. 0) optlev = -1.0d0 - if (index(flag,'vloose') .ne. 0) optlev = -2.0d0 - if (index(flag,'sloppy') .ne. 0) optlev = -2.0d0 - if (index(flag,'normal') .ne. 0) optlev = 0.0d0 - if (index(flag,'tight') .ne. 0) optlev = 1.0d0 - if (index(flag,'verytight') .ne. 0) optlev = 2.0d0 - if (index(flag,'vtight') .ne. 0) optlev = 2.0d0 - if (index(flag,'extreme') .ne. 0) optlev = 3.0d0 - if (index(flag,'3') .ne. 0) optlev = 3.0d0 - if (index(flag,'2') .ne. 0) optlev = 2.0d0 - if (index(flag,'1') .ne. 0) optlev = 1.0d0 - if (index(flag,'0') .ne. 0) optlev = 0.0d0 - if (index(flag,'-3') .ne. 0) optlev = -3.0d0 - if (index(flag,'-2') .ne. 0) optlev = -2.0d0 - if (index(flag,'-1') .ne. 0) optlev = -1.0d0 + select case (trim(adjustl(flag))) + case ('crude','-3') + optlev = -3.0_wp + case ('vloose','sloppy','-2') + optlev = -2.0_wp + case ('loose','-1') + optlev = -1.0_wp + case ('normal','0') + optlev = 0.0_wp + case ('tight','1') + optlev = 1.0_wp + case ('verytight','vtight','2') + optlev = 2.0_wp + case ('extreme','3') + optlev = 3.0_wp + case default + if(present(iostat)) iostat = 1 + end select return end function optlevnum diff --git a/src/confparse.f90 b/src/confparse.f90 index 925a1ca7..5512c93e 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -62,6 +62,7 @@ subroutine parseflags(env,arg,nra) logical :: ex,bondconst character(len=:),allocatable :: argument logical,allocatable :: processedarg(:) + character(len=:),allocatable :: arg1,arg2,arg3 allocate (xx(10),floats(3),strings(3)) ctmp = '' @@ -88,8 +89,8 @@ subroutine parseflags(env,arg,nra) if (.not.gui) then call confscript_head(.false.) - write (*,'(/,1x,a)') 'Command line input:' - write (*,'(1x,a,a,/)') '$ ',trim(cmd) + write (stdout,'(/,1x,a)') 'Command line input:' + write (stdout,'(1x,a,a,/)') '$ ',trim(cmd) end if env%cmd = trim(cmd) @@ -349,6 +350,12 @@ subroutine parseflags(env,arg,nra) do i = 1,nra if (processedarg(i)) cycle argument = trim(arg(i)) + arg1 = '' + if (i+1 .le. nra) arg1 = trim(arg(i+1)) + arg2 = '' + if (i+2 .le. nra) arg2 = trim(arg(i+2)) + arg3 = '' + if (i+3 .le. nra) arg3 = trim(arg(i+3)) if (argument(1:2) == '--') then argument = argument(2:) end if @@ -358,18 +365,20 @@ subroutine parseflags(env,arg,nra) case ('-v1') !> confscript version 1 (MF-MD-GC) processedarg(i) = .true. env%crestver = crest_mfmdgc - write (*,'(2x,a,'' : MF-MD-GC'')') trim(arg(i)) + write (stdout,'(2x,a,'' : MF-MD-GC'')') trim(arg(i)) env%mdtime = 40.0d0 !> simulation length of the MD, 40ps total (2*20ps)(default for QMDFF would be 500) env%temps = 1 !> number of default MD cycles env%Maxrestart = 15 env%performModef = .true. !> do the MF in V1 env%trackorigin = .false. !> for v1 there is not much insight from this + call parseflags_deprecated(argument) + call creststop(status_safety) exit case ('-v2') !> confscript version 2 (MTD-GC) processedarg(i) = .true. env%crestver = crest_imtd - write (*,'(2x,a,'' : MTD-GC'')') trim(arg(i)) + write (stdout,'(2x,a,'' : MTD-GC'')') trim(arg(i)) env%iterativeV2 = .false. !> iterative crest V2 version env%Maxrestart = 1 !> for non-iterative MTD-GC only exit @@ -378,7 +387,7 @@ subroutine parseflags(env,arg,nra) processedarg(i) = .true. env%crestver = crest_imtd env%iterativeV2 = .true. - write (*,'(2x,a,'' : iMTD-GC'')') trim(arg(i)) + write (stdout,'(2x,a,'' : iMTD-GC'')') trim(arg(i)) exit case ('-v4') !> sMTD-iMTD (same as entropy mode) @@ -389,7 +398,7 @@ subroutine parseflags(env,arg,nra) env%rotamermds = .false. env%performCross = .false. env%emtd%maxfallback = 1 - write (*,'(2x,a,'' : iMTD-sMTD'')') trim(arg(i)) + write (stdout,'(2x,a,'' : iMTD-sMTD'')') trim(arg(i)) exit case ('-mdopt','-purge') !> MDOPT @@ -448,7 +457,7 @@ subroutine parseflags(env,arg,nra) env%solv = '--alpb h2o' env%protb%h_acidic = 0 call pka_argparse(arg(i+1),env%protb%h_acidic) - if (env%protb%h_acidic == -2) env%protb%pka_baseinp = trim(arg(i+1)) + if (env%protb%h_acidic == -2) env%protb%pka_baseinp = arg1 case ('-compare') !> flag for comparing two ensembles, analysis tool processedarg(i) = .true. @@ -461,8 +470,8 @@ subroutine parseflags(env,arg,nra) atmp = adjustl(arg(i+1)) btmp = adjustl(arg(i+2)) else - write (*,'(a,a)') trim(arg(i)),' requires two arguments:' - write (*,'(2x,a,a)') trim(arg(i)),' [ensemble1] [ensemble2]' + write (stdout,'(a,a)') trim(arg(i)),' requires two arguments:' + write (stdout,'(2x,a,a)') trim(arg(i)),' [ensemble1] [ensemble2]' error stop end if if ((atmp(1:1) /= '-').and.(len_trim(atmp) .ge. 1).and. & @@ -472,7 +481,7 @@ subroutine parseflags(env,arg,nra) processedarg(i+1) = .true. processedarg(i+2) = .true. end if - write (*,'(1x,a,1x,a,1x,a)') trim(arg(i)),trim(env%ensemblename),trim(env%ensemblename2) + write (stdout,'(1x,a,1x,a,1x,a)') trim(arg(i)),trim(env%ensemblename),trim(env%ensemblename2) exit case ('-protonate') !> protonation tool @@ -480,7 +489,7 @@ subroutine parseflags(env,arg,nra) env%properties = p_protonate env%crestver = crest_protonate env%legacy = .true. !> TODO, set active at later version - write (*,'(2x,a,'' : automated protonation script'')') trim(arg(i)) + write (stdout,'(2x,a,'' : automated protonation script'')') trim(arg(i)) exit case ('-deprotonate') !> deprotonation tool @@ -488,7 +497,7 @@ subroutine parseflags(env,arg,nra) env%properties = p_deprotonate env%crestver = crest_deprotonate env%legacy = .true. !> TODO, set active at later version - write (*,'(2x,a,'' : automated deprotonation script'')') trim(arg(i)) + write (stdout,'(2x,a,'' : automated deprotonation script'')') trim(arg(i)) exit case ('-tautomerize') !> tautomerization tool @@ -496,14 +505,14 @@ subroutine parseflags(env,arg,nra) env%properties = p_tautomerize env%crestver = crest_tautomerize env%legacy = .true. !> TODO, set active at later version - write (*,'(2x,a,'' : automated tautomerization script'')') trim(arg(i)) + write (stdout,'(2x,a,'' : automated tautomerization script'')') trim(arg(i)) exit case ('-isomerize','-stereomers') !> isomerization tool processedarg(i) = .true. env%properties = p_isomerize - write (*,'(2x,a,'' : automated stereoisomerization script'')') trim(arg(i)) - write (*,'(2x,''Note: Use of GFN-FF required for stereoisomer generation.'')') + write (stdout,'(2x,a,'' : automated stereoisomerization script'')') trim(arg(i)) + write (stdout,'(2x,''Note: Use of GFN-FF required for stereoisomer generation.'')') exit case ('-forall','-for') !> property mode with ensemble as input @@ -518,7 +527,7 @@ subroutine parseflags(env,arg,nra) end if inquire (file=env%ensemblename,exist=ex) if (.not.ex) then - write (*,'(1x,a,a,a)') 'invalid ensemble file <',trim(env%ensemblename),'>. exit.' + write (stdout,'(1x,a,a,a)') 'invalid ensemble file <',trim(env%ensemblename),'>. exit.' error stop end if call xyz2coord(env%ensemblename,'coord') !> write coord from lowest structure @@ -540,7 +549,7 @@ subroutine parseflags(env,arg,nra) end if inquire (file=env%ensemblename,exist=ex) if (.not.ex) then - write (*,'(1x,a,a,a)') 'invalid ensemble file <',trim(env%ensemblename),'>. exit.' + write (stdout,'(1x,a,a,a)') 'invalid ensemble file <',trim(env%ensemblename),'>. exit.' error stop end if exit @@ -564,7 +573,7 @@ subroutine parseflags(env,arg,nra) !> Set solvent file if prensent !> If it is another argument, it doesent matter as solvent file is checke in solvtool if (nra >= i+1) then - env%solv_file = trim(arg(i+1)) + env%solv_file = arg1 inquire (file=env%solv_file,exist=ex) if (ex) then processedarg(i+1) = .true. @@ -582,7 +591,7 @@ subroutine parseflags(env,arg,nra) env%doOHflip = .false. !> Switch off OH-flip if (env%iterativeV2) env%iterativeV2 = .false. exit - env%legacy = .true. !> force legacy routines for now + !env%legacy = .true. !> force legacy routines for now case ('-compress') processedarg(i) = .true. @@ -602,7 +611,7 @@ subroutine parseflags(env,arg,nra) case ('-splitfile') processedarg(i) = .true. - ctmp = trim(arg(i+1)) + ctmp = arg1 processedarg(i+1) = .true. k = huge(j) l = 1 @@ -621,11 +630,11 @@ subroutine parseflags(env,arg,nra) end if end if call splitfile(ctmp,k,l) - stop + call creststop(status_normal) case ('-printaniso') processedarg(i) = .true. - ctmp = trim(arg(i+1)) + ctmp = arg1 inquire (file=ctmp,exist=ex) if (ex) then processedarg(i+1) = .true. @@ -635,7 +644,7 @@ subroutine parseflags(env,arg,nra) case ('-rotalign') processedarg(i) = .true. - ctmp = trim(arg(i+1)) + ctmp = arg1 inquire (file=ctmp,exist=ex) if (ex) then processedarg(i+1) = .true. @@ -646,20 +655,20 @@ subroutine parseflags(env,arg,nra) case ('-printboltz') processedarg(i) = .true. if (nra >= i+2) then - ctmp = trim(arg(i+1)) - dtmp = trim(arg(i+2)) + ctmp = arg1 + dtmp = arg2 call prbweight(ctmp,dtmp) processedarg(i+1) = .true. processedarg(i+2) = .true. else - ctmp = trim(arg(i+1)) + ctmp = arg1 call prbweight(ctmp,'') processedarg(i+1) = .true. end if case ('-wbotopo','-usewbo') !> try to use a WBO file in topology analysis processedarg(i) = .true. - ctmp = trim(arg(i+1)) + ctmp = arg1 if (ctmp(1:1) .ne. '-'.and.(nra >= i+1)) then env%wbofile = trim(ctmp) processedarg(i+1) = .true. @@ -670,10 +679,10 @@ subroutine parseflags(env,arg,nra) case ('-testtopo') processedarg(i) = .true. - ctmp = trim(arg(i+1)) + ctmp = arg1 inquire (file=ctmp,exist=ex) if (i+2 .le. nra) then - dtmp = trim(arg(i+2)) + dtmp = arg2 if (dtmp(1:1) == '-') then dtmp = 'default' else @@ -687,7 +696,7 @@ subroutine parseflags(env,arg,nra) case ('-resortensemble') processedarg(i) = .true. - ctmp = trim(arg(i+1)) + ctmp = arg1 inquire (file=ctmp,exist=ex) if (ex) then processedarg(i+1) = .true. @@ -703,7 +712,7 @@ subroutine parseflags(env,arg,nra) env%inputcoords = trim(ctmp) env%thermo%coords = trim(ctmp) end if - ctmp = trim(arg(i+1)) ! second argument to read the vibspectrum + ctmp = arg1 ! second argument to read the vibspectrum if (ctmp(1:1) .ne. '-') then processedarg(i+1) = .true. env%thermo%vibfile = trim(ctmp) @@ -716,8 +725,8 @@ subroutine parseflags(env,arg,nra) else env%sortmode = 'rmsd' end if - ctmp = trim(arg(i+1)) - dtmp = trim(arg(i+2)) + ctmp = arg1 + dtmp = arg2 env%preopt = .false. env%crestver = crest_sorting inquire (file=ctmp,exist=ex) @@ -734,8 +743,8 @@ subroutine parseflags(env,arg,nra) case ('-irmsd','-irmsd_noinv') processedarg(i) = .true. - ctmp = trim(arg(i+1)) - dtmp = trim(arg(i+2)) + ctmp = arg1 + dtmp = arg2 env%preopt = .false. env%crestver = crest_sorting env%sortmode = 'irmsd' @@ -756,8 +765,8 @@ subroutine parseflags(env,arg,nra) case ('-hungarian','-hungarianheavy','-hhungarian','-lsap','-hlsap','-lsapheavy') processedarg(i:i+2) = .true. - ctmp = trim(arg(i+1)) - dtmp = trim(arg(i+2)) + ctmp = arg1 + dtmp = arg2 if ((argument == '-hungarianheavy').or.(argument == '-hhungarian').or. & &(argument == '-lsapheavy').or.(argument == '-hlsap')) then call quick_hungarian_match(ctmp,dtmp,.true.) @@ -768,7 +777,7 @@ subroutine parseflags(env,arg,nra) case ('-symmetries') processedarg(i) = .true. - ctmp = trim(arg(i+1)) + ctmp = arg1 inquire (file=ctmp,exist=ex) if (ex) then processedarg(i+1) = .true. @@ -780,7 +789,7 @@ subroutine parseflags(env,arg,nra) processedarg(i) = .true. env%properties = p_ligand env%protb%infile = trim(arg(1)) - ctmp = trim(arg(i+1)) + ctmp = arg1 processedarg(i+1) = .true. env%protb%newligand = trim(ctmp) read (arg(i+2),*,iostat=io) j @@ -802,19 +811,19 @@ subroutine parseflags(env,arg,nra) if (index(arg(i),'prep') .ne. 0) then call pka_argparse2(env,arg(i+1),arg(i+2),env%protb%pka_mode) else - ctmp = trim(arg(i+1)) + ctmp = arg1 inquire (file=ctmp,exist=ex) if (ex) then processedarg(i+1) = .true. env%protb%pka_acidensemble = trim(ctmp) - write (*,'(1x,a,a)') 'File used for the acid: ',trim(ctmp) + write (stdout,'(1x,a,a)') 'File used for the acid: ',trim(ctmp) end if - ctmp = trim(arg(i+2)) + ctmp = arg2 inquire (file=ctmp,exist=ex) if (ex) then processedarg(i+2) = .true. env%protb%pka_baseensemble = trim(ctmp) - write (*,'(1x,a,a)') 'File used for the base: ',trim(ctmp) + write (stdout,'(1x,a,a)') 'File used for the base: ',trim(ctmp) end if end if env%solv = '--alpb h2o' @@ -822,7 +831,7 @@ subroutine parseflags(env,arg,nra) case ('-redoextrapol') processedarg(i) = .true. - ctmp = trim(arg(i+1)) + ctmp = arg1 processedarg(i+1) = .true. read (arg(i+2),*,iostat=io) j if (io == 0) then @@ -838,6 +847,7 @@ subroutine parseflags(env,arg,nra) env%crestver = crest_sp env%preopt = .false. env%legacy = .false. + write (stdout,'(2x,a,t15,a)') argument//':','Singlepoint energy calculation runtype' exit case ('-opt','-optimize','-ancopt','-ohess') !> ANCOPT structure optimization (uses new calculator routines) @@ -845,7 +855,17 @@ subroutine parseflags(env,arg,nra) env%preopt = .false. env%crestver = crest_optimize env%legacy = .false. - if (argument .eq. '-ohess') env%crest_ohess = .true. + if (argument .eq. '-ohess') then + env%crest_ohess = .true. + write (stdout,'(2x,a,t15,a)') argument//':','Geometry optimization + frequency calculation runtype' + else + write (stdout,'(2x,a,t15,a)') argument//':','Geometry optimization runtype' + end if + !if (i+1 .le. nra) then + env%optlev = optlevnum(arg(i+1),iostat=io) + if (io == 0) processedarg(i+1) = .true. + !end if + exit case ('-hess','-numhess') !> Numerical hessian @@ -853,12 +873,14 @@ subroutine parseflags(env,arg,nra) env%preopt = .false. env%crestver = crest_numhessian env%legacy = .false. + write (stdout,'(2x,a,t15,a)') argument//':','Frequency calculation runtype' exit case ('-trialopt') !> test optimization with topocheck processedarg(i) = .true. env%preopt = .false. env%crestver = crest_trialopt + write (stdout,'(2x,a,t15,a)') argument//':','Trial geometry optimization' exit case ('-dynamics','-dyn') !> molecular dynamics (uses new calculator routines) @@ -866,13 +888,14 @@ subroutine parseflags(env,arg,nra) env%preopt = .false. env%crestver = crest_moldyn env%legacy = .false. + write (stdout,'(2x,a,t15,a)') argument//':','Molecular dynamics simulation' exit case ('-sort') processedarg(i) = .true. env%preopt = .false. env%crestver = crest_sorting - ctmp = trim(arg(i+1)) + ctmp = arg1 inquire (file=ctmp,exist=ex) if (ex) then processedarg(i+1) = .true. @@ -880,16 +903,17 @@ subroutine parseflags(env,arg,nra) env%ensemblename = ctmp end if if (nra >= i+2) then - ctmp = trim(arg(i+2)) - if (ctmp(1:1) .ne. '-')then + ctmp = arg2 + if (ctmp(1:1) .ne. '-') then processedarg(i+2) = .true. env%sortmode = trim(ctmp) - endif + end if end if case ('-bh','-GMIN') processedarg(i) = .true. env%crestver = crest_bh + write (stdout,'(2x,a,t15,a)') argument//':','Basin-hopping global optimization' exit case ('-SANDBOX') @@ -956,7 +980,14 @@ subroutine parseflags(env,arg,nra) !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>! !========================================================================================! do i = 1,nra + if (processedarg(i)) cycle argument = trim(arg(i)) + arg1 = '' + if (i+1 .le. nra) arg1 = trim(arg(i+1)) + arg2 = '' + if (i+2 .le. nra) arg2 = trim(arg(i+2)) + arg3 = '' + if (i+3 .le. nra) arg3 = trim(arg(i+3)) if (argument(1:2) == '--') then argument = argument(2:) end if @@ -966,8 +997,10 @@ subroutine parseflags(env,arg,nra) !========================================================================================! select case (argument) case ('-legacy') !> switch to old xtb-call version where possible + processedarg(i) = .true. env%legacy = .true. case ('-newversion') !> switch to newer implementations (CREST >3.0) + processedarg(i) = .true. env%legacy = .false. end select !========================================================================================! @@ -975,61 +1008,70 @@ subroutine parseflags(env,arg,nra) !========================================================================================! if (any((/crest_imtd,crest_imtd2,11/) == env%crestver)) then select case (argument) !> V2 - case ('-mdtemp') !> set MTD temperature (V2 version) - call readl(arg(i+1),xx,j) - env%mdtemp = xx(1) - env%user_temp = .true. + case ('-quick') !> performing quick conformational search + processedarg(i) = .true. env%quick = .true. env%runver = 2 env%ewin = 5.0d0 if (env%optlev > 1.0d0) env%optlev = 1.0d0 !> optlev tight for quick run - case ('-shake') !> set shake - call readl(arg(i+1),xx,j) - env%shake = nint(xx(1)) - case ('-tstep') !> set MD timestep in fs - call readl(arg(i+1),xx,j) - env%mdstep = xx(1) - env%user_mdstep = .true. - case ('-vbdump') !> Vbias dump in ps - call readl(arg(i+1),xx,j) - xx(2) = xx(1)*1000 - env%mddump = nint(xx(2)) + case ('-mdskip') !> set skipping structures in -mdopt - call readl(arg(i+1),xx,j) - env%mdskip = nint(xx(1)) - case ('-mddump') !> set dumpstep for writing structures from MD - call readl(arg(i+1),xx,j) - env%mddumpxyz = nint(xx(1)) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + env%mdskip = nint(xx(1)) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + case ('-nomtd') !> Don't do the MTD in V2 + processedarg(i) = .true. env%performMTD = .false. + case ('-restartopt') !> go to step 2 of multilevel optimization immideatly + processedarg(i) = .true. env%restartopt = .true. env%autozsort = .false. + case ('-norotmd') !> don't do the regular mds after step 2 in multilevel optimization of V2 + processedarg(i) = .true. env%rotamermds = .false. + case ('-rotmd') + processedarg(i) = .true. env%rotamermds = .true. - case ('-tnmd') !> temperature for additional normal MDs - call readl(arg(i+1),xx,j) - env%nmdtemp = xx(1) + case ('-gcmopt') !> GC multilevel optimization activate in V2 + processedarg(i) = .true. env%gcmultiopt = .true. + case ('-gcsopt') !> GC single level optimization in V2 + processedarg(i) = .true. env%gcmultiopt = .false. + case ('-nogcmopt') !> GC single level optimization in V2 + processedarg(i) = .true. env%gcmultiopt = .false. + case ('-qmdff') !> use QMDFF for the MDs in V2? + processedarg(i) = .true. env%useqmdff = .true. + call parseflags_deprecated(argument) + case ('-nci') !> NCI special mode - write (*,'(2x,a,1x,a)') trim(arg(i)),' : Special NCI mode for non-covalently bound complexes or clusters.' + processedarg(i) = .true. + write (stdout,'(2x,a,1x,a)') trim(arg(i)),' : Special NCI mode for non-covalently bound complexes or clusters.' env%NCI = .true. env%runver = 4 env%autozsort = .false. env%performCross = .false. env%rotamermds = .false. + case ('-squick','-superquick') !> extremely crude quick mode - write (*,'(2x,a,1x,a)') trim(arg(i)),' : very crude quick-mode (no NORMMD, no GC, crude opt.)' + processedarg(i) = .true. + write (stdout,'(2x,a,1x,a)') trim(arg(i)),' : very crude quick-mode (no NORMMD, no GC, crude opt.)' env%rotamermds = .false. !> no NORMMD env%performCross = .false. !> no GC env%quick = .true. !> MTD settings from the quick-mode @@ -1039,7 +1081,8 @@ subroutine parseflags(env,arg,nra) env%ewin = 5.0d0 !> smaller energy window case ('-mquick','-megaquick') !> extremely crude quick mode pt.2 - write (*,'(2x,a,1x,a)') trim(arg(i)),' : very crude quick-mode (no NORMMD, no GC, crude opt.)' + processedarg(i) = .true. + write (stdout,'(2x,a,1x,a)') trim(arg(i)),' : very crude quick-mode (no NORMMD, no GC, crude opt.)' env%rotamermds = .false. !> no NORMMD env%performCross = .false. !> no GC env%quick = .true. !> MTD settings from the quick-mode @@ -1050,14 +1093,18 @@ subroutine parseflags(env,arg,nra) env%ewin = 2.5d0 !> smaller energy window case ('-extensive') !> counterpart to quick mode + processedarg(i) = .true. env%slow = .true. env%quick = .false. env%superquick = .false. env%optlev = 0.0d0 env%ewin = 8.0d0 env%runver = 8 + case ('-static','-staticmtd') + processedarg(i) = .true. env%staticmtd = .true. + case default continue end select !> V2 @@ -1065,17 +1112,26 @@ subroutine parseflags(env,arg,nra) if (env%iterativeV2) then select case (argument) !> V2i case ('-mrest') !> set max number of restarts - call readl(arg(i+1),xx,j) - env%Maxrestart = nint(xx(1)) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + env%Maxrestart = nint(xx(1)) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + case ('-iru') !> re-use previously found conformers as bias in iterative approach + processedarg(i) = .true. env%iru = .true. - case ('-keepdir','-keeptmp') !> Do not delete METADYN and NORMMD directories - env%keepModef = .true. + case ('-singlerun') !> QCG special mode - write (*,'(2x,a,1x,a)') trim(arg(i)),' : run mode with only a single MTD and no iterations (for testing)' + processedarg(i) = .true. + write (stdout,'(2x,a,1x,a)') trim(arg(i)),' : run mode with only a single MTD and no iterations (for testing)' env%runver = 45 env%Maxrestart = 1 env%rotamermds = .false. + case default continue end select !> V2i @@ -1088,10 +1144,17 @@ subroutine parseflags(env,arg,nra) if (env%crestver == crest_mdopt.or.env%crestver == crest_screen) then select case (argument) !> SCREEN case ('-purge') !> Purge special application + processedarg(i) = .true. env%optpurge = .true. + case ('-ethrpurge','-ethrp') + processedarg(i) = .true. read (arg(i+1),*,iostat=io) rdum - if (io == 0) env%ethrpurge = rdum + if (io == 0) then + env%ethrpurge = rdum + processedarg(i+1) = .true. + end if + case default continue end select !> SCREEN @@ -1102,23 +1165,28 @@ subroutine parseflags(env,arg,nra) if (env%crestver == crest_nano) then select case (argument) !> RCTR case ('-genpot') + processedarg(i) = .true. if (i+1 .le. nra) then - atmp = trim(arg(i+1)) + atmp = arg1 if (atmp(1:1) .ne. '-') then - call readl(arg(i+1),xx,j) + call readl(arg1,xx,j) env%rdens = xx(1) + processedarg(i+1) = .true. end if end if env%properties = p_reactorset env%preactorpot = .true. + case ('-genmtd') + processedarg(i) = .true. env%properties = p_reactorset env%mdtime = 20.0d0 if (i+1 .le. nra) then - atmp = trim(arg(i+1)) + atmp = arg1 if (atmp(1:1) .ne. '-') then - call readl(arg(i+1),xx,j) + call readl(arg1,xx,j) env%mdtime = xx(1) + processedarg(i+1) = .true. end if end if env%nmetadyn = 1 @@ -1131,10 +1199,15 @@ subroutine parseflags(env,arg,nra) env%metadexp(1) = 1.00_wp env%metadfac(1) = 0.04_wp env%preactormtd = .true. + case ('-fragopt') + processedarg(i) = .true. env%restartopt = .true. + case ('-iso') + processedarg(i) = .true. env%riso = .true. + case default continue end select !> RCTR @@ -1144,48 +1217,31 @@ subroutine parseflags(env,arg,nra) !========================================================================================! if (env%QCG) then select case (argument) !> QCG - case ('-keepdir','-keeptmp') + case ('-keeptmp') + processedarg(i) = .true. env%keepModef = .true. - case ('-tstep') !> set MD timestep in fs - call readl(arg(i+1),xx,j) - env%mdstep = xx(1) - env%user_mdstep = .true. - case ('-vbdump') !> Vbias dump in ps - call readl(arg(i+1),xx,j) - xx(2) = xx(1)*1000 - env%mddump = nint(xx(2)) - case ('-mdskip') !> set skipping structures in -mdopt - call readl(arg(i+1),xx,j) - env%mdskip = nint(xx(1)) - case ('-mddump') !> set dumpstep for writing structures out of the md - env%user_dumxyz = .true. - call readl(arg(i+1),xx,j) - env%mddumpxyz = nint(xx(1)) + case ('-nomtd') !> Don't do the MTD in V2 + processedarg(i) = .true. env%performMTD = .false. - case ('-wscal') !> scale size of wall potential - call readl(arg(i+1),xx,j) - env%potscal = xx(1) - env%user_wscal = .true. + case ('-fixsolute') !> Fix the solute after CMA trafo + processedarg(i) = .true. env%constrain_solu = .true. + case ('-nofix') !> No fixing of the solute after CMA trafo + processedarg(i) = .true. env%noconst = .true. + case ('-restartopt') !> go to step 2 of multilevel optimization immideatly + processedarg(i) = .true. env%restartopt = .true. env%autozsort = .false. + case ('-norotmd') !> don't do the regular mds after step 2 in multilevel optimization of V2 + processedarg(i) = .true. env%rotamermds = .false. - case ('-mdtemp') !> set MTD temperature (V2 version) - call readl(arg(i+1),xx,j) - env%mdtemp = xx(1) - env%user_temp = .true. - case ('-tnmd') !> temperature for additional normal MDs - call readl(arg(i+1),xx,j) - env%nmdtemp = xx(1) - case ('-shake') !> set shake - call readl(arg(i+1),xx,j) - env%shake = nint(xx(1)) + end select !> QCG end if @@ -1195,38 +1251,86 @@ subroutine parseflags(env,arg,nra) if (env%crestver == crest_msreac) then select case (argument) !> msreact case ('-msei') + processedarg(i) = .true. env%msei = .true. + case ('-mscid') + processedarg(i) = .true. env%mscid = .true. env%msei = .false. + case ('-msnoiso') !> filter out non fragmentated structures in msreact + processedarg(i) = .true. env%msnoiso = .true. + case ('-msiso') !> filter out fragmentated structures in msreact + processedarg(i) = .true. env%msiso = .true. + case ('-msnbonds') ! give number of bonds up to which bias potential is added between atoms default 3 - call readl(arg(i+1),xx,j) - env%msnbonds = xx(1) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + env%msnbonds = xx(1) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + case ('-msnshifts') ! give number of times atoms are randomly shifted before optimization - call readl(arg(i+1),xx,j) - env%msnshifts = xx(1) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + env%msnshifts = xx(1) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + case ('-msnshifts2') ! give number of times atoms are randomly shifted before applying the constrained optimization default 0 - call readl(arg(i+1),xx,j) - env%msnshifts2 = xx(1) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + env%msnshifts2 = xx(1) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + case ('-msnfrag') ! give number of structures that should be generated - call readl(arg(i+1),xx,j) - env%msnfrag = xx(1) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + env%msnfrag = xx(1) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + case ('-msmolbar') !> filter out structures with same molbar code in msreact + processedarg(i) = .true. env%msmolbar = .true. + case ('-msinchi') !> filter out structures with same inchi code in msreact + processedarg(i) = .true. env%msinchi = .true. + case ('-msnoattrh') !> add attractive potential for H-atoms + processedarg(i) = .true. env%msattrh = .false. + case ('-mslargeprint') !> additional printouts and keep MSDIR + processedarg(i) = .true. env%mslargeprint = .true. - case ('-msinput') ! give number of times atoms are randomly shifted before applying the constrained optimization default 0 - ctmp = trim(arg(i+1)) + + case ('-msinput') ! msreact input file + processedarg(i) = .true. + ctmp = arg1 if (ctmp(1:1) .ne. '-') then env%msinput = trim(ctmp) + processedarg(i+1) = .true. + else + end if end select !> msreact end if @@ -1235,28 +1339,45 @@ subroutine parseflags(env,arg,nra) !========================================================================================! select case (argument) !> ARGPARSER1 case ('-dry') !> "dry" run to print settings + processedarg(i) = .true. env%dryrun = .true. + case ('-nozs') + processedarg(i) = .true. env%autozsort = .false. !> turn off automatic zsort (default) + case ('-zs') + processedarg(i) = .true. env%autozsort = .true. !> turn on automatic zsort + case ('-nocross') + processedarg(i) = .true. env%performCross = .false. !> skip the genetic crossing - write (*,'(2x,a,1x,a)') trim(arg(i)),' : skipping GC part.' + write (stdout,'(2x,a,1x,a)') trim(arg(i)),' : skipping GC part.' + case ('-cross') + processedarg(i) = .true. env%performCross = .true. !> do the genetic crossing env%autozsort = .true. + case ('-keepdir','-keeptmp') !> Do not delete temporary directories at the end + processedarg(i) = .true. env%keepModef = .true. + case ('-opt','-optlev') !> settings for optimization level of GFN-xTB - if (nra >= i+1) then - env%optlev = optlevnum(arg(i+1)) + processedarg(i) = .true. + if (i+1 .le. nra) then + env%optlev = optlevnum(arg(i+1),iostat=io) + if (io == 0) processedarg(i+1) = .true. end if - write (*,'(2x,a,1x,a)') trim(arg(i)),optlevflag(env%optlev) + write (stdout,'(2x,a,1x,a)') trim(arg(i)),optlevflag(env%optlev) + case ('-gfn','-gfn1','-gfn2','-gfn0','-gff','-gfnff') + processedarg(i) = .true. ctmp = argument if (argument == '-gfn') then - dtmp = trim(arg(i+1)) + processedarg(i+1) = .true. + dtmp = arg1 ctmp = ctmp//dtmp end if if (env%properties == p_isomerize) then @@ -1265,16 +1386,16 @@ subroutine parseflags(env,arg,nra) select case (ctmp) !> GFN case ('-gfn1') env%gfnver = '--gfn1' - write (*,'(2x,a,'' : Use of GFN1-xTB requested.'')') env%gfnver + write (stdout,'(2x,a,'' : Use of GFN1-xTB requested.'')') env%gfnver case ('-gfn2') env%gfnver = '--gfn2' - write (*,'(2x,a,'' : Use of GFN2-xTB requested.'')') env%gfnver + write (stdout,'(2x,a,'' : Use of GFN2-xTB requested.'')') env%gfnver case ('-gfn0') env%gfnver = '--gfn0' - write (*,'(2x,a,'' : Use of GFN0-xTB requested.'')') env%gfnver + write (stdout,'(2x,a,'' : Use of GFN0-xTB requested.'')') env%gfnver case ('-gff','-gfnff') env%gfnver = '--gff' - write (*,'(2x,a,'' : Use of GFN-FF requested.'')') '--gfnff' + write (stdout,'(2x,a,'' : Use of GFN-FF requested.'')') '--gfnff' env%mdstep = 1.5d0 env%hmass = 5.0d0 ctype = 5 !> bond constraint activated @@ -1290,13 +1411,17 @@ subroutine parseflags(env,arg,nra) end select !> GFN case ('-gxtb') + processedarg(i) = .true. call gxtb_dev_warning() + case ('-gxtb_dev') + processedarg(i+1) = .true. env%gfnver = 'gxtb_dev' case ('-gfn2@gfn0','-gfn2@gfn1','-gfn2@gff','-gfn2@ff','-gfn2@gfnff') + processedarg(i) = .true. if (.not.env%legacy) then !TODO - write (*,'("> ",a,1x,a)') argument,'option not yet available with new calculator' + write (stdout,'("> ",a,1x,a)') argument,'option not yet available with new calculator' error stop end if select case (argument) !> GFN2ON @@ -1314,9 +1439,12 @@ subroutine parseflags(env,arg,nra) call env%addjob(51) call env%checkhy() env%reweight = .false. + case ('-gfn2//gfnff') + processedarg(i) = .true. if (.not.env%legacy) then !TODO - write (*,'("> ",a,1x,a)') argument,'option not yet available with new calculator' + write (stdout,'("> ",a,1x,a)') argument,'option only available with TOML setup in new calculator'// & + & " or the --refine flag" error stop end if env%gfnver = '--gff' @@ -1329,74 +1457,108 @@ subroutine parseflags(env,arg,nra) bondconst = .true. env%cts%cbonds_md = .true. env%checkiso = .true. - if (index(arg(i+1),'opt') .ne. 0) then + if (i+1 .le. nra) then + ctmp = arg1 + else + ctmp = '' + end if + if (ctmp(1:1) .ne. '-'.and.index(ctmp,'opt') .ne. 0) then + processedarg(i+1) = .true. env%altopt = .true. - write (*,'(2x,a,a)') argument,' : GFN-FF MDs + GFN2 opt.' + write (stdout,'(2x,a,a)') argument,' : GFN-FF MDs + GFN2 opt.' else - write (*,'(2x,a,a)') argument,' : energy reweighting' + write (stdout,'(2x,a,a)') argument,' : energy reweighting' end if case ('-refine','-rsp','-ropt') !> add one refinement step (via cmd only one is possible) + processedarg(i) = .true. env%legacy = .false. !> new calculators only! - if (nra >= i+1) then - env%gfnver2 = trim(arg(i+1)) - write (*,'(2x,a,1x,a,a)') argument,trim(env%gfnver2), & + if (i+1 .le. nra) then + env%gfnver2 = arg1 + write (stdout,'(2x,a,1x,a,a)') argument,trim(env%gfnver2), & & ' : adding refinement step (singlepoint on optimized structures)' + processedarg(i+1) = .true. end if case ('-charges') !> read charges from file for GFN-FF calcs. - ctmp = trim(arg(i+1)) + processedarg(i) = .true. + ctmp = arg1 if ((len_trim(ctmp) < 1).or.(ctmp(1:1) == '-')) then ctmp = 'charges' + else + processedarg(i+1) = .true. end if inquire (file=ctmp,exist=ex) if (ex) then env%chargesfilename = ctmp env%chargesfile = .true. - write (*,'(2x,a,a,a)') '-charges: file <',trim(ctmp),'> used for atomic charges' + write (stdout,'(2x,a,a,a)') '-charges: file <',trim(ctmp),'> used for atomic charges' call env%ref%rdcharges(env%chargesfilename,idum) if (idum .ne. env%chrg) then - write (*,'(12x,a,i0)') 'with total summed up molecular charge: ',idum + write (stdout,'(12x,a,i0)') 'with total summed up molecular charge: ',idum env%chrg = idum env%ref%ichrg = idum end if end if case ('-efield') !> electric field in V/Ang, only compatibe with tblite + processedarg(i) = .true. if (.not.allocated(env%ref%efield)) allocate (env%ref%efield(3),source=0.0_wp) - if (nra >= i+3) then - ctmp = trim(arg(i+1)) + if (i+3 .le. nra) then + ctmp = arg1 read (ctmp,*,iostat=io) env%ref%efield(1) - ctmp = trim(arg(i+2)) + if (io == 0) processedarg(i+1) = .true. + ctmp = arg2 read (ctmp,*,iostat=io) env%ref%efield(2) - ctmp = trim(arg(i+3)) + if (io == 0) processedarg(i+2) = .true. + ctmp = arg3 read (ctmp,*,iostat=io) env%ref%efield(3) + if (io == 0) processedarg(i+3) = .true. write (stdout,'(" --efield: ",3(1x,es10.3)," V/Å")') env%ref%efield(1:3) else - write (stdout,'(a)') + call parseflags_missing(argument) end if case ('-ceh_guess') + processedarg(i) = .true. env%ceh_guess = .true. case ('-dscal','-dispscal','-dscal_global','-dispscal_global') + processedarg(i) = .true. env%cts%dispscal_md = .true. if (index(argument,'_global') .ne. 0) then env%cts%dispscal_global = .true. end if if (nra .ge. i+1) then - ctmp = trim(arg(i+1)) + ctmp = arg1 read (ctmp,*,iostat=io) rdum - if (io .eq. 0) env%cts%dscal = rdum + if (io .eq. 0) then + env%cts%dscal = rdum + processedarg(i+1) = .true. + end if end if + if (.not.env%legacy) call parseflags_deprecated(argument) + case ('-mtd_kscal','-mtdkscal') - call readl(arg(i+1),xx,j) - env%mtd_kscal = xx(1) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + env%mtd_kscal = xx(1) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + case ('-norestart') + processedarg(i) = .true. env%allowrestart = .false. + case ('-readbias') + processedarg(i) = .true. env%readbias = .true. + case ('-useonly') + processedarg(i) = .true. env%properties = p_useonly env%autozsort = .false. env%dummypercent = 1.0_wp @@ -1404,46 +1566,67 @@ subroutine parseflags(env,arg,nra) atmp = adjustl(arg(i+1)) if (atmp(1:1) .ne. '-') then read (atmp,*) env%dummypercent + processedarg(i+1) = .true. end if end if case ('-gbsa','-g','-alpb') !> use GBSA or ALPB implicit solvation + processedarg(i) = .true. env%gbsa = .true. atmp = adjustl(arg(i+1)) if (atmp(1:1) .ne. '-'.and.atmp(1:1) .ne. ' ') then env%solvent = arg(i+1) + processedarg(i+1) = .true. if (trim(argument) == '-alpb') then env%solv = '--alpb '//trim(env%solvent) else env%solv = '--gbsa '//trim(env%solvent) end if + else + call parseflags_missing(argument) end if - write (*,'(2x,a,a)') trim(env%solv),' : implicit solvation' + write (stdout,'(2x,a,a)') trim(env%solv),' : implicit solvation' case ('-chrg') !> create a .CHRG file - call readl(arg(i+1),xx,j) - open (newunit=ich,file='.CHRG') - env%chrg = nint(xx(1)) - env%ref%ichrg = env%chrg - write (ich,'(i0)') nint(xx(1)) - close (ich) - write (*,'(2x,a,1x,a)') trim(arg(i)),trim(arg(i+1)) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + processedarg(i+1) = .true. + open (newunit=ich,file='.CHRG') + env%chrg = nint(xx(1)) + env%ref%ichrg = env%chrg + write (ich,'(i0)') nint(xx(1)) + close (ich) + write (stdout,'(2x,a,1x,a)') trim(arg(i)),arg1 + else + call parseflags_missing(argument) + end if case ('-uhf') !> create a .UHF file - call readl(arg(i+1),xx,j) - open (newunit=ich,file='.UHF') - env%uhf = nint(xx(1)) - env%ref%uhf = env%uhf - write (ich,'(i0)') nint(xx(1)) - close (ich) - write (*,'(2x,a,1x,a)') trim(arg(i)),trim(arg(i+1)) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + processedarg(i+1) = .true. + open (newunit=ich,file='.uhf') + env%uhf = nint(xx(1)) + env%ref%uhf = env%uhf + write (ich,'(i0)') nint(xx(1)) + close (ich) + write (stdout,'(2x,a,1x,a)') trim(arg(i)),arg1 + else + call parseflags_missing(argument) + end if case ('-grad') + processedarg(i) = .true. env%gradsp = .true. + case ('-nograd') + processedarg(i) = .true. env%gradsp = .false. case ('-len','-mdlen','-mdtime') !> set md length in ps + processedarg(i) = .true. atmp = arg(i+1) call to_lower(atmp) j = index(atmp,'x') @@ -1452,48 +1635,170 @@ subroutine parseflags(env,arg,nra) btmp = atmp(j+1:) env%scallen = .true. call readl(btmp,xx,j) - env%mdlenfac = xx(1) + if (j > 0) then + env%mdlenfac = xx(1) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if else !> direct setting of the md length - call readl(arg(i+1),xx,j) - env%mdtime = xx(1) - write (*,'(2x,a,1x,a,1x,a)') trim(arg(i)),trim(arg(i+1)), & - & '(MD length in ps)' + call readl(arg1,xx,j) + if (j > 0) then + processedarg(i+1) = .true. + env%mdtime = xx(1) + write (stdout,'(2x,a,1x,a,1x,a)') trim(arg(i)),arg1, & + & '(MD length in ps)' + else + call parseflags_missing(argument) + end if + end if + + case ('-shake') !> set shake + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + env%shake = nint(xx(1)) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + + case ('-tstep') !> set MD timestep in fs + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + env%mdstep = xx(1) + env%user_mdstep = .true. + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + + case ('-vbdump') !> Vbias dump in ps + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + xx(2) = xx(1)*1000 + env%mddump = nint(xx(2)) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + + case ('-tnmd') !> temperature for additional normal MDs + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + env%nmdtemp = xx(1) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + + case ('-mdskip') !> set skipping structures in -mdopt + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + env%mdskip = nint(xx(1)) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + + case ('-mddump') !> set dumpstep for writing structures from MD + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + env%user_dumxyz = .true. + env%mddumpxyz = nint(xx(1)) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) end if + case ('-mdscal','-lenscal') !> scale md length + processedarg(i) = .true. env%scallen = .true. - call readl(arg(i+1),xx,j) - env%mdlenfac = xx(1) + call readl(arg1,xx,j) + if (j > 0) then + env%mdlenfac = xx(1) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + + case ('-mdtemp') !> set MTD temperature (V2 version) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + env%mdtemp = xx(1) + env%user_temp = .true. + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + case ('-nmtd') !> set number of MTDs + processedarg(i) = .true. env%runver = 787878 - call readl(arg(i+1),xx,j) - env%nmetadyn = nint(xx(1)) + call readl(arg1,xx,j) + if (j > 0) then + processedarg(i+1) = .true. + env%nmetadyn = nint(xx(1)) + else + call parseflags_missing(argument) + end if + case ('-gcmax','-setgcmax') !> set maximum number of structures for GC + processedarg(i) = .true. env%setgcmax = .true. - call readl(arg(i+1),xx,j) - env%gcmax = xx(1) + call readl(arg1,xx,j) + if (j > 0) then + env%gcmax = xx(1) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + case ('-xnam') !> select a name for the xTB executeable - env%ProgName = trim(arg(i+1)) - write (*,'(2x,''-xnam :'')',advance='no') - write (*,'(1x,''xtb executable was set to: "'',a,''"'')') trim(env%ProgName) + processedarg(i) = .true. + env%ProgName = arg1 + write (stdout,'(2x,''-xnam :'')',advance='no') + write (stdout,'(1x,''xtb executable was set to: "'',a,''"'')') trim(env%ProgName) + processedarg(i+1) = .true. + case ('-niceprint') !> progres bar printout + processedarg(i) = .true. env%niceprint = .true. + case ('-origin') !> track the origin (i.e. the generation step) of each conformer + processedarg(i) = .true. env%trackorigin = .true. - write (*,'(2x,a,1x,a)') trim(arg(i)),': tracking conformer origins.' + write (stdout,'(2x,a,1x,a)') trim(arg(i)),': tracking conformer origins.' + case ('-constrain') !> provide a list of atoms to write a .xcontrol.sample - ctmp = trim(arg(i+1)) + processedarg(i) = .true. + ctmp = arg1 call quick_constrain_file('coord',env%nat,env%ref%at,ctmp) + processedarg(i+1) = .true. + case ('-nocbonds') + processedarg(i) = .true. bondconst = .false. env%cts%cbonds_global = .false. env%cts%cbonds_md = .false. inquire (file='bondlengths',exist=ex) if (ex) call remove('bondlengths') + case ('-cbonds','-cbonds_md','-cbonds_ez') !> constrain all bonds - ctmp = trim(arg(i+1)) + processedarg(i) = .true. + ctmp = arg1 if (ctmp(1:1) .ne. '-') then read (ctmp,*,iostat=io) rdum - if (io .eq. 0) env%forceconst = rdum + if (io .eq. 0) then + env%forceconst = rdum + processedarg(i+1) = .true. + end if end if ctype = 1 bondconst = .true. @@ -1505,11 +1810,16 @@ subroutine parseflags(env,arg,nra) if (index(argument,'_ez') .ne. 0) then !> if the only E/Z shall be constrained ctype = 5 end if + case ('-cmetal','-cmetal_md') !> constrain transition metal coordination sites - ctmp = trim(arg(i+1)) + processedarg(i) = .true. + ctmp = arg1 if (ctmp(1:1) .ne. '-') then read (ctmp,*,iostat=io) rdum - if (io .eq. 0) env%forceconst = rdum + if (io .eq. 0) then + env%forceconst = rdum + processedarg(i+1) = .true. + end if end if ctype = 2 bondconst = .true. @@ -1518,11 +1828,16 @@ subroutine parseflags(env,arg,nra) env%cts%cbonds_md = .true. env%cts%cbonds_global = .false. end if + case ('-cheavy','-fixheavy','-cheavy_md') !> constrain all heavy atom bonds - ctmp = trim(arg(i+1)) + processedarg(i) = .true. + ctmp = arg1 if (ctmp(1:1) .ne. '-') then read (ctmp,*,iostat=io) rdum - if (io .eq. 0) env%forceconst = rdum + if (io .eq. 0) then + env%forceconst = rdum + processedarg(i+1) = .true. + end if end if ctype = 3 bondconst = .true. @@ -1531,11 +1846,16 @@ subroutine parseflags(env,arg,nra) env%cts%cbonds_md = .true. env%cts%cbonds_global = .false. end if + case ('-clight','-fixhyd','-clight_md') !> constraint all X-H bonds - ctmp = trim(arg(i+1)) + processedarg(i) = .true. + ctmp = arg1 if (ctmp(1:1) .ne. '-') then read (ctmp,*,iostat=io) rdum - if (io .eq. 0) env%forceconst = rdum + if (io .eq. 0) then + env%forceconst = rdum + processedarg(i+1) = .true. + end if end if ctype = 4 bondconst = .true. @@ -1544,130 +1864,226 @@ subroutine parseflags(env,arg,nra) env%cts%cbonds_md = .true. env%cts%cbonds_global = .false. end if + case ('-cfile','-cinp','-C','-c') !> specify the constrain file - ctmp = trim(arg(i+1)) + processedarg(i) = .true. + ctmp = arg1 if (ctmp(1:1) .ne. '-') then env%constraints = trim(ctmp) - write (*,'(2x,a,1x,a)') argument//' :',trim(ctmp) + processedarg(i+1) = .true. + write (stdout,'(2x,a,1x,a)') argument//' :',trim(ctmp) end if + case ('-fc','-forceconstant') - ctmp = trim(arg(i+1)) - if (i+1 >= nra) then - call readl(arg(i+1),xx,j) - env%forceconst = xx(1) + processedarg(i) = .true. + ctmp = arg1 + if (i+1 .le. nra) then + call readl(arg1,xx,j) + if (j > 0) then + env%forceconst = xx(1) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if end if - write (*,'(2x,a,f6.4,a)') '-fc ',env%forceconst,': selected force constant in Eh' + write (stdout,'(2x,a,f6.4,a)') '-fc ',env%forceconst,': selected force constant in Eh' + case ('-nomlo','-no-multilevel') !> turn off multilevel optimization + processedarg(i) = .true. env%multilevelopt = .false. + case ('-normmd') !> set number of normMDs + processedarg(i) = .true. env%rotamermds = .true. if (i+1 .le. nra) then - call readl(arg(i+1),xx,j) - env%nrotammds = nint(xx(1)) !> how many lowest conformers? + call readl(arg1,xx,j) + if (j > 0) then + env%nrotammds = nint(xx(1)) !> how many lowest conformers? + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if end if if (i+2 .le. nra) then - call readl(arg(i+2),xx,j) - env%temps = nint(xx(1)) !> how many different temperatures + call readl(arg2,xx,j) + if (j > 0) then + env%temps = nint(xx(1)) !> how many different temperatures + processedarg(i+2) = .true. + end if end if + case ('-rmsdpot','-gesc') - ctmp = trim(arg(i+1)) + processedarg(i) = .true. + ctmp = arg1 inquire (file=ctmp,exist=ex) if (ex) then env%cts%usermsdpot = .true. call getcwd(atmp) env%cts%rmsdpotfile = trim(atmp)//'/'//ctmp - write (*,'(2x,a,a,a,a)') argument,': using <',ctmp,'> as bias' + write (stdout,'(2x,a,a,a,a)') argument,': using <',ctmp,'> as bias' + processedarg(i+1) = .true. else - write (*,'(a,a)') argument,': Warning! File could not be found!' + write (stdout,'(a,a)') argument,': Warning! File could not be found!' end if + call parseflags_deprecated(argument) + case ('-mergebias','-mergebias+','-gesc+') + processedarg(i) = .true. env%properties = -9224 if (index(argument,'+') > 0) env%properties = p_gesc2 - ctmp = trim(arg(i+1)) + ctmp = arg1 inquire (file=ctmp,exist=ex) if (ex) then env%biasfile = ctmp + processedarg(i+1) = .true. end if env%autozsort = .false. + call parseflags_deprecated(argument) + case ('-gescopt') - env%gescoptlev = optlevnum(arg(i+1)) + processedarg(i) = .true. + env%gescoptlev = optlevnum(arg(i+1),iostat=io) + if (io == 0) processedarg(i+1) = .true. + case ('-gescheavy','-heavygesc','-gesc_heavy') + processedarg(i) = .true. env%cts%gesc_heavy = .true. + case ('-rthr2') !> bias rmsd threshold + processedarg(i) = .true. read (arg(i+1),*,iostat=io) rdum - if (io == 0) env%rthr2 = rdum + if (io == 0) then + env%rthr2 = rdum + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + call parseflags_deprecated(argument) + case ('-kshift') + processedarg(i) = .true. read (arg(i+1),*,iostat=io) rdum - if (io == 0) env%kshift = rdum + if (io == 0) then + env%kshift = rdum + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if env%kshiftnum = 1 + call parseflags_deprecated(argument) + case ('-hflip') + processedarg(i) = .true. env%doOHflip = .true. + case ('-noflip') + processedarg(i) = .true. env%doOHflip = .false. + case ('-maxflip') + processedarg(i) = .true. read (arg(i+1),*,iostat=io) rdum if (io == 0.and.(index(arg(i+1),'-') .eq. 0)) then env%maxflip = nint(rdum) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) end if + case ('-osdf') + processedarg(i) = .true. env%outputsdf = .true. - write (*,'(2x,a," :",1x,a)') trim(arg(i)), & + write (stdout,'(2x,a," :",1x,a)') trim(arg(i)), & & "output ensemble requested in sdf format" case ('-wscal') !> scale size of wall potential - call readl(arg(i+1),xx,j) - env%potscal = xx(1) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + env%potscal = xx(1) + env%user_wscal = .true. + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + case ('-wpad') !> scale size of wall potential - call readl(arg(i+1),xx,j) - env%potpad = xx(1) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + env%potpad = xx(1) + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if + case ('-watoms','-wat') + processedarg(i) = .true. ctmp = arg(i+1) if (ctmp(1:1) .ne. '-') then env%potatlist = trim(ctmp) - write (*,*) env%potatlist + write (stdout,*) env%potatlist + processedarg(i+1) = .true. end if + case ('-wall') + processedarg(i) = .true. env%wallsetup = .true. - write (*,'(2x,a,1x,a)') '--wall:','requesting setup of wall potential' + write (stdout,'(2x,a,1x,a)') '--wall:','requesting setup of wall potential' + case ('-wallxl','-wall-xl') + processedarg(i) = .true. env%wallsetup = .true. env%potscal = 1.5_wp - write (*,'(2x,a,1x,a)') '--wall-xl:','requesting setup of wall potential (x1.5 size)' + write (stdout,'(2x,a,1x,a)') '--wall-xl:','requesting setup of wall potential (x1.5 size)' + case ('-wallxxl','-wall-xxl') + processedarg(i) = .true. env%wallsetup = .true. env%potscal = 2.0_wp - write (*,'(2x,a,1x,a)') '--wall-xxl:','requesting setup of wall potential (x2.0 size)' + write (stdout,'(2x,a,1x,a)') '--wall-xxl:','requesting setup of wall potential (x2.0 size)' case ('-alkylize') - write (*,'(2x,a,1x)',advance='no') '--alkylize' + processedarg(i) = .true. + write (stdout,'(2x,a,1x)',advance='no') '--alkylize' env%alkylize = .true. if (nra >= i+1) then - ctmp = trim(arg(i+1)) + ctmp = arg1 select case (ctmp) case ('full','sample') env%alkylizeskip = .false. - write (*,'(a,1x)',advance='no') ctmp + write (stdout,'(a,1x)',advance='no') ctmp + processedarg(i+1) = .true. end select end if - write (*,'(a)') ': automatic alkyl group dispatch' + write (stdout,'(a)') ': automatic alkyl group dispatch' !========================================================================================! !------ flags for parallelization / disk space !========================================================================================! case ('-T','-P','-parallel') !> set total number of OMP threads, this replaces -P and -O entirely - call readl(arg(i+1),xx,j) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + processedarg(i+1) = .true. + else + call parseflags_missing(argument) + end if if (index(arg(i+1),'-') .ne. 0) xx = 0d0 env%Threads = nint(xx(1)) env%autothreads = .true. env%threadssetmanual = .true. - write (*,'(2x,a,1x,i0,1x,a)') trim(arg(i)),nint(xx(1)), & + write (stdout,'(2x,a,1x,i0,1x,a)') trim(arg(i)),nint(xx(1)), & & '(CPUs/Threads selected)' + case ('-inplace') !> activate "in-place" mode for optimizations (ON by default) + processedarg(i) = .true. env%inplaceMode = .true. !========================================================================================! !------- CREGEN related flags !========================================================================================! case ('-cregen','-oldcregen') !> CREGEN standalone use + processedarg(i) = .true. env%confgo = .true. env%properties = p_cregen env%autozsort = .false. @@ -1676,121 +2092,225 @@ subroutine parseflags(env,arg,nra) if (nra .ge. (i+1)) atmp = adjustl(arg(i+1)) if ((atmp(1:1) /= '-').and.(len_trim(atmp) .ge. 1)) then env%ensemblename = trim(atmp) + processedarg(i+1) = .true. end if if (index(env%ensemblename,'none selected') .ne. 0) then - write (*,'(2x,a,1x,a)') trim(arg(i)),': CREGEN standalone usage.' + write (stdout,'(2x,a,1x,a)') trim(arg(i)),': CREGEN standalone usage.' else - write (*,'(2x,a,1x,a,a,a)') trim(arg(i)),': CREGEN standalone usage. Sorting file <', & + write (stdout,'(2x,a,1x,a,a,a)') trim(arg(i)),': CREGEN standalone usage. Sorting file <', & & trim(env%ensemblename),'>' end if if (trim(arg(i)) .eq. '-oldcregen') then - write (*,'(3x,a)') 'Using the old version of the CREGEN subroutine.' + write (stdout,'(3x,a)') 'Using the old version of the CREGEN subroutine.' env%newcregen = .false. end if + case ('-oldcr') - write (*,'(3x,a)') 'Using the old version of the CREGEN subroutine.' + processedarg(i) = .true. + write (stdout,'(3x,a)') 'Using the old version of the CREGEN subroutine.' env%newcregen = .false. env%ethr = 0.1d0 !> ETHR old value + case ('-enso') !> compare two given ensembles + processedarg(i) = .true. env%ENSO = .true. + case ('-compare') !> compare two given ensembles + processedarg(i) = .true. env%compareens = .true. + case ('-maxcomp') !> maximum number of lowest conformers to compare with "-compare" - call readl(arg(i+1),xx,j) - env%maxcompare = nint(xx(1)) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + processedarg(i+1) = .true. + env%maxcompare = nint(xx(1)) + else + call parseflags_missing(argument) + end if + case ('-ewin') !> set energy threshold in kcal/mol - call readl(arg(i+1),xx,j) - env%ewin = abs(xx(1)) - if (any((/p_protonate,p_deprotonate,p_tautomerize/) == env%properties)) then - env%protb%ewin = abs(xx(1)) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + processedarg(i+1) = .true. + env%ewin = abs(xx(1)) + if (any((/p_protonate,p_deprotonate,p_tautomerize/) == env%properties)) then + env%protb%ewin = abs(xx(1)) + end if + write (stdout,'(2x,a,1x,a)') trim(arg(i)),arg1 + else + call parseflags_missing(argument) end if - write (*,'(2x,a,1x,a)') trim(arg(i)),trim(arg(i+1)) + case ('-rthr') !> set RMSD thr - call readl(arg(i+1),xx,j) - env%rthr = xx(1) - write (*,'(2x,a,1x,a)') trim(arg(i)),trim(arg(i+1)) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + processedarg(i+1) = .true. + env%rthr = xx(1) + write (stdout,'(2x,a,1x,a)') trim(arg(i)),arg1 + else + call parseflags_missing(argument) + end if + case ('-ethr') !> set E thr - call readl(arg(i+1),xx,j) - env%ethr = xx(1) - write (*,'(2x,a,1x,a)') trim(arg(i)),trim(arg(i+1)) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + processedarg(i+1) = .true. + env%ethr = xx(1) + write (stdout,'(2x,a,1x,a)') trim(arg(i)),arg1 + else + call parseflags_missing(argument) + end if + case ('-bthr') !> set rot const thr - call readl(arg(i+1),xx,j) - env%thresholds(4) = xx(1) !> legacy - env%bthr2 = xx(1) - write (*,'(2x,a,1x,a)') trim(arg(i)),trim(arg(i+1)) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + processedarg(i+1) = .true. + env%thresholds(4) = xx(1) !> legacy + env%bthr2 = xx(1) + write (stdout,'(2x,a,1x,a)') trim(arg(i)),arg1 + else + call parseflags_missing(argument) + end if + case ('-allrot') !> use all rotational constants for comparison, instead of mean + processedarg(i) = .true. env%allrot = .true. + case ('-athr') !> set int. rotation. equal atoms for NMR thr - call readl(arg(i+1),xx,j) - env%athr = xx(1) - write (*,'(2x,a,1x,a)') trim(arg(i)),trim(arg(i+1)) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + processedarg(i+1) = .true. + env%athr = xx(1) + write (stdout,'(2x,a,1x,a)') trim(arg(i)),arg1 + else + call parseflags_missing(argument) + end if + case ('-pthr') !> set population thr - call readl(arg(i+1),xx,j) - rdum = min(1.0_wp,xx(1)) !--> pthr <= 1 - rdum = max(0.0_wp,rdum) !--> pthr >= 0 - env%pthr = rdum - write (*,'(2x,a,1x,f6.4)') trim(arg(i)),rdum !trim(arg(i+1)) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + processedarg(i+1) = .true. + rdum = min(1.0_wp,xx(1)) !--> pthr <= 1 + rdum = max(0.0_wp,rdum) !--> pthr >= 0 + env%pthr = rdum + write (stdout,'(2x,a,1x,f6.4)') trim(arg(i)),rdum !arg1 + else + call parseflags_missing(argument) + end if + case ('-eqv') + processedarg(i) = .true. env%doNMR = .true. !> option for the very last confg call + case ('-zsort') + processedarg(i) = .true. env%onlyZsort = .true. !perform only the zsort subroutine env%autozsort = .true. ! CB: needs to be set to run zsort - write (*,'(2x,a,1x,a)') trim(arg(i)),' : only using the ZSORT subroutine.' + write (stdout,'(2x,a,1x,a)') trim(arg(i)),' : only using the ZSORT subroutine.' + case ('-metac') !automatic complete of mag. and chem. methyl equivalencies + processedarg(i) = .true. env%methautocorr = .true. + case ('-esort') !> cregen legacy option + processedarg(i) = .true. env%esort = .true. + case ('-debug') + processedarg(i) = .true. env%cgf(1) = .true. !> debug option for confg + case ('-nowr') + processedarg(i) = .true. env%cgf(2) = .false. !> newfile option for confg + case ('-eqan') + processedarg(i) = .true. env%cgf(3) = .true. !> equivalence analysis on (for NMR) + case ('-noeqan') + processedarg(i) = .true. env%cgf(3) = .false. !> equivalence analysis off (for nmr) + case ('-rot') + processedarg(i) = .true. env%cgf(5) = .false. !> just rotamer check + case ('-nmr') !> NMR mode for confscript + processedarg(i) = .true. env%doNMR = .true. env%optlev = 2.0d0 + case ('-fullcre') + processedarg(i) = .true. env%doNMR = .true. env%fullcre = .true. + case ('-heavy') + processedarg(i) = .true. env%cgf(4) = .true. !> perform just the heavy atom RMSD env%heavyrmsd = .true. + case ('-temp') - ctmp = trim(arg(i+1)) + processedarg(i) = .true. + ctmp = arg1 if (index(ctmp,'-') .eq. 0) then - call readl(arg(i+1),xx,j) + call readl(arg1,xx,j) env%tboltz = xx(1) + processedarg(i+1) = .true. end if + case ('-prsc') !> write scoord files + processedarg(i) = .true. env%printscoords = .true. + case ('-noprsc') !> don't write scoord files + processedarg(i) = .true. env%printscoords = .false. + case ('-subrmsd') !> use only the RMSD for atoms that are included in the MTD + processedarg(i) = .true. env%subRMSD = .true. + case ('-noopt') !> skip the pre-optimization with GFNn-xTB before the confsearch + processedarg(i) = .true. env%preopt = .false. + case ('-topo','-topocheck') + processedarg(i) = .true. env%checktopo = .true. + case ('-notopo','-notopocheck','-noreftopo') + processedarg(i) = .true. env%checktopo = .false. - ctmp = trim(arg(i+1)) + ctmp = arg1 if (ctmp(1:1) .ne. '-') then + processedarg(i+1) = .true. call parse_topo_excl(env,ctmp) if (allocated(env%excludeTOPO)) then env%checktopo = .true. end if end if env%reftopo = .false. + case ('-ezcheck','-checkez') + processedarg(i) = .true. env%checkiso = .true. + case ('-noezcheck','-nocheckez') + processedarg(i) = .true. env%checkiso = .false. + case ('-inversion') - ctmp = lowercase(trim(arg(i+1))) + processedarg(i) = .true. + ctmp = lowercase(arg1) select case (ctmp) case ('auto') env%iinversion = 0 @@ -1802,36 +2322,49 @@ subroutine parseflags(env,arg,nra) write (stdout,'(a,a,a,a)') 'invalid argument for ',argument,': ',trim(ctmp) stop end select + processedarg(i+1) = .true. !========================================================================================! !-------- PROPERTY CALCULATION related flags !========================================================================================! case ('-protonate') !> protonation tool + processedarg(i) = .true. env%properties = p_protonate env%autozsort = .false. env%protb%threshsort = .true. - ctmp = trim(arg(i+1)) + ctmp = arg1 if (ctmp(1:1) .ne. '-') then + processedarg(i+1) = .true. read (ctmp,*,iostat=io) idum if (io .eq. 0) env%protb%amount = idum end if + case ('-swel') !> switch out H+ to something else in protonation script + processedarg(i) = .true. if (env%properties .eq. -3) then call swparse(arg(i+1),env%protb) + processedarg(i+1) = .true. end if + case ('-deprotonate') !> deprotonation tool + processedarg(i) = .true. env%properties = p_deprotonate env%autozsort = .false. env%protb%threshsort = .true. - ctmp = trim(arg(i+1)) + ctmp = arg1 if (ctmp(1:1) .ne. '-') then + processedarg(i+1) = .true. read (ctmp,*,iostat=io) idum if (io .eq. 0) env%protb%amount = idum end if + case ('-tautomerize') !> tautomerization tool + processedarg(i) = .true. env%properties = p_tautomerize env%autozsort = .false. env%protb%threshsort = .true. + case ('-tautomerize2','-exttautomerize') + processedarg(i) = .true. if (env%properties == p_propcalc) then env%properties = p_tautomerize2 else @@ -1844,48 +2377,77 @@ subroutine parseflags(env,arg,nra) env%performCross = .false. !> skip the genetic crossing env%trackorigin = .false. env%Maxrestart = 1 + case ('-relax') + processedarg(i) = .true. env%runver = 33 env%relax = .true. env%performCross = .false. !> skip the genetic crossing env%trackorigin = .false. env%Maxrestart = 1 + case ('-trev','-tdp') + processedarg(i) = .true. env%protb%deprotprot = .true. !> switch to deprotonation-first mode in tautomerization + case ('-iter') !> number of Protonation/Deprotonation cycles in Tautomerization - call readl(arg(i+1),xx,j) - env%protb%iter = nint(xx(1)) + processedarg(i) = .true. + call readl(arg1,xx,j) + if (j > 0) then + processedarg(i+1) = .true. + env%protb%iter = nint(xx(1)) + end if + case ('-texcl','-blacklist') - ctmp = trim(arg(i+1)) + processedarg(i) = .true. + ctmp = arg1 + processedarg(i+1) = .true. + case ('-strict') + processedarg(i) = .true. env%protb%strictPDT = .true. + case ('-verystrict','-vstrict') + processedarg(i) = .true. env%protb%strictPDT = .false. env%protb%fixPDT = .true. + case ('-fstrict') + processedarg(i) = .true. env%protb%strictPDT = .true. env%protb%fixPDT = .true. + case ('-corr','-abcorr') + processedarg(i) = .true. env%protb%strictPDT = .true. env%protb%fixPDT = .true. env%protb%ABcorrection = .true. + case ('-pkaensemble') + processedarg(i) = .true. env%preopt = .false. env%presp = .false. call pka_argparse2(env,arg(i+1),arg(i+2),env%protb%pka_mode) + processedarg(i+1) = .true. + processedarg(i+2) = .true. + case ('-pkaparam') + processedarg(i) = .true. env%protb%rdcfer = .true. if (i+1 .le. nra) then - ctmp = trim(arg(i+1)) + ctmp = arg1 if (ctmp(1:1) .ne. '-') then + processedarg(i+1) = .true. env%protb%cferfile = ctmp end if end if + !========================================================================================! !--------- ENTROPY related settings !========================================================================================! case ('-entropy','-entropic') !> new, specialized calculation of molecular entropies - write (*,'(2x,a,'' : enhanced ensemble entropy calculation'')') trim(arg(i)) + processedarg(i) = .true. + write (stdout,'(2x,a,'' : enhanced ensemble entropy calculation'')') argument if (env%properties == p_propcalc) then !>--- for standalone use env%properties = p_CREentropy @@ -1909,207 +2471,325 @@ subroutine parseflags(env,arg,nra) env%runver = 111 !> version for selection of MTD bias settings env%doNMR = .true. !> we need equivalencies if (i+1 .le. nra) then - ctmp = trim(arg(i+1)) !> second argument can be the temperature + ctmp = arg1 !> second argument can be the temperature if (index(ctmp,'-') .eq. 0) then - call readl(arg(i+1),xx,j) + processedarg(i+1) = .true. + call readl(arg1,xx,j) env%tboltz = xx(1) end if end if call env%addjob(env%properties) case ('-scthr','-entropy_cthr') + processedarg(i) = .true. read (arg(i+1),*,iostat=io) rdum - if (io == 0) env%emtd%confthr = rdum + if (io == 0) then + processedarg(i+1) = .true. + env%emtd%confthr = rdum + else + call parseflags_missing(argument) + end if + case ('-ssthr','-entropy_sthr') + processedarg(i) = .true. read (arg(i+1),*,iostat=io) rdum - if (io == 0) env%emtd%sconvthr = rdum + if (io == 0) then + processedarg(i+1) = .true. + env%emtd%sconvthr = rdum + else + call parseflags_missing(argument) + end if + case ('-rrhoav') !> see above in the first specification of -rrhoav + processedarg(i) = .true. env%properties = p_rrhoaverage call read_bhess_ref(env,'coord') + case ('-avbhess') + processedarg(i) = .true. env%thermo%avbhess = .true. !> use bhess in rrhoav for all structures (expensive) + case ('-avchess') + processedarg(i) = .true. env%thermo%constrhess = .true. !> apply constraints during rrhoav routine + case ('-printpop') + processedarg(i) = .true. env%thermo%printpop = .true. !> print a file with free energy pop. at different T + case ('-noref') !> dont use a bhess reference + processedarg(i) = .true. env%emtd%bhess = .false. + case ('-ref') + processedarg(i) = .true. env%emtd%bhess = .true. - inquire (file=trim(arg(i+1)),exist=ex) + inquire (file=arg1,exist=ex) if (ex) then - call read_bhess_ref(env,trim(arg(i+1))) + processedarg(i+1) = .true. + call read_bhess_ref(env,arg1) end if + case ('-pcap') + processedarg(i) = .true. read (arg(i+1),*,iostat=io) j if (io == 0.and.(index(arg(i+1),'-') .eq. 0)) then + processedarg(i+1) = .true. env%thermo%pcap = j end if + case ('-ptot') + processedarg(i) = .true. read (arg(i+1),*,iostat=io) rdum if (io == 0.and.(index(arg(i+1),'-') .eq. 0)) then + processedarg(i+1) = .true. if (rdum > 1.0d0) rdum = 1.0d0 env%thermo%ptot = rdum end if + case ('-ithr') + processedarg(i) = .true. read (arg(i+1),*,iostat=io) rdum if (io == 0) then + processedarg(i+1) = .true. if (rdum > 0.0d0) rdum = 0.0 env%thermo%ithr = rdum end if + case ('-rotorcut','-sthr') + processedarg(i) = .true. read (arg(i+1),*,iostat=io) rdum if (io == 0.and.(index(arg(i+1),'-') .eq. 0)) then + processedarg(i+1) = .true. if (rdum < 0.0d0) rdum = 0.0d0 env%thermo%sthr = rdum end if + case ('-fscal') + processedarg(i) = .true. read (arg(i+1),*,iostat=io) rdum if (io == 0.and.(index(arg(i+1),'-') .eq. 0)) then + processedarg(i+1) = .true. env%thermo%fscal = rdum end if + case ('-trange') !> provide a range of temperatures (min max step) for entropy evaluation + processedarg(i) = .true. read (arg(i+1),*,iostat=io) rdum if (io == 0.and.(index(arg(i+1),'-') .eq. 0)) then + processedarg(i+1) = .true. env%thermo%trange(1) = rdum !> T start end if read (arg(i+2),*,iostat=io) rdum if (io == 0.and.(index(arg(i+2),'-') .eq. 0)) then + processedarg(i+2) = .true. env%thermo%trange(2) = rdum !> T stop (approx.) end if read (arg(i+3),*,iostat=io) rdum if (io == 0.and.(index(arg(i+3),'-') .eq. 0)) then + processedarg(i+3) = .true. env%thermo%trange(3) = rdum !> T step end if + case ('-tread') !> read a file with temperatures (one per line) for entropy evaluation - ctmp = trim(arg(i+1)) + processedarg(i) = .true. + ctmp = arg1 inquire (file=ctmp,exist=ex) if (ex) then + processedarg(i+1) = .true. call env%thermo%read_temps(ctmp) end if !=========================================================================================! !-------- QCG-Related flags !=========================================================================================! case ('-nopreopt') + processedarg(i) = .true. env%nopreopt = .true. env%qcg_flag = .true. + case ('-xtbiff') + processedarg(i) = .true. env%use_xtbiff = .true. + case ('-grow') + processedarg(i) = .true. env%qcg_runtype = 0 env%qcg_flag = .true. + case ('-ensemble') + processedarg(i) = .true. env%qcg_runtype = 1 env%qcg_flag = .true. + case ('-esolv') + processedarg(i) = .true. env%qcg_runtype = 2 env%qcg_flag = .true. + case ('-gsolv') + processedarg(i) = .true. env%qcg_runtype = 3 env%qcg_flag = .true. + case ('-nsolv') + processedarg(i) = .true. env%qcg_flag = .true. - call readl(arg(i+1),xx,j) - env%nsolv = NINT(xx(1)) + call readl(arg1,xx,j) + if (j > 0) then + processedarg(i+1) = .true. + env%nsolv = NINT(xx(1)) + else + call parseflags_missing(argument) + end if + case ('-maxsolv') + processedarg(i) = .true. env%qcg_flag = .true. - call readl(arg(i+1),xx,j) - env%max_solv = NINT(xx(1)) + call readl(arg1,xx,j) + if (j > 0) then + processedarg(i+1) = .true. + env%max_solv = NINT(xx(1)) + else + call parseflags_missing(argument) + end if + case ('-normdock') + processedarg(i) = .true. env%docking_qcg_flag = '' + case ('-fin_opt_gfn2') + processedarg(i) = .true. env%final_gfn2_opt = .true. + case ('-no_fin_opt_gfn2') + processedarg(i) = .true. env%final_gfn2_opt = .false. + case ('-directed') !> specify the directed list + processedarg(i) = .true. env%qcg_flag = .true. - ctmp = trim(arg(i+1)) + ctmp = arg1 if (ctmp(1:1) .ne. '-') then + processedarg(i+1) = .true. env%directed_file = trim(ctmp) - write (*,'(2x,a,1x,a)') trim(argument)//' :',trim(ctmp) + write (stdout,'(2x,a,1x,a)') trim(argument)//' :',trim(ctmp) end if + case ('-nclus') + processedarg(i) = .true. env%qcg_flag = .true. - call readl(arg(i+1),xx,j) - env%nqcgclust = NINT(xx(1)) - env%user_nclust = .true. + call readl(arg1,xx,j) + if (j > 0) then + processedarg(i+1) = .true. + env%nqcgclust = NINT(xx(1)) + env%user_nclust = .true. + else + call parseflags_missing(argument) + end if + case ('-freqscal') + processedarg(i) = .true. env%qcg_flag = .true. - call readl(arg(i+1),xx,j) - env%freq_scal = (xx(1)) + call readl(arg1,xx,j) + if (j > 0) then + processedarg(i+1) = .true. + env%freq_scal = (xx(1)) + else + call parseflags_missing(argument) + end if + case ('-qcgmtd') + processedarg(i) = .true. env%ensemble_method = -1 env%qcg_flag = .true. + case ('-ncimtd') + processedarg(i) = .true. env%ensemble_method = 0 env%qcg_flag = .true. + case ('-md') + processedarg(i) = .true. env%ensemble_method = 1 env%qcg_flag = .true. if (.not.env%user_enslvl) then env%ensemble_opt = '--gfn2' end if + case ('-mtd') + processedarg(i) = .true. env%ensemble_method = 2 env%qcg_flag = .true. if (.not.env%user_enslvl) then env%ensemble_opt = '--gfn2' end if + case ('-samerand') + processedarg(i) = .true. env%sameRandomNumber = .true. env%qcg_flag = .true. + case ('-nocff') + processedarg(i) = .true. env%cff = .false. env%qcg_flag = .true. + case ('-enslvl') + processedarg(i) = .true. ctmp = arg(i+1) + processedarg(i+1) = .true. env%user_enslvl = .true. env%qcg_flag = .true. if (arg(i+1) == '-gfn') then - dtmp = trim(arg(i+2)) + processedarg(i+2) = .true. + dtmp = arg2 ctmp = trim(ctmp)//dtmp end if select case (ctmp) case ('gfn1') env%ensemble_opt = '--gfn1' - write (*,'(2x, a)') 'Use of GFN1-xTB for ensemble search requested.' + write (stdout,'(2x, a)') 'Use of GFN1-xTB for ensemble search requested.' case ('gfn2') env%ensemble_opt = '--gfn2' - write (*,'(2x, a)') 'Use of GFN2-xTB for ensemble search requested.' + write (stdout,'(2x, a)') 'Use of GFN2-xTB for ensemble search requested.' case ('gfn0') env%ensemble_opt = '--gfn0' - write (*,'(2x, a)') 'Use of GFN0-xTB for ensemble search requested.' + write (stdout,'(2x, a)') 'Use of GFN0-xTB for ensemble search requested.' case ('gff','gfnff') env%ensemble_opt = '--gff' - write (*,'(2x, a)') 'Use of GFN-FF for ensemble search requested.' + write (stdout,'(2x, a)') 'Use of GFN-FF for ensemble search requested.' end select case ('-freqlvl') + processedarg(i) = .true. ctmp = arg(i+1) + processedarg(i+1) = .true. env%qcg_flag = .true. if (arg(i+1) == '-gfn') then - dtmp = trim(arg(i+2)) + processedarg(i+2) = .true. + dtmp = arg2 ctmp = trim(ctmp)//dtmp end if select case (ctmp) case ('gfn1') env%freqver = '--gfn1' - write (*,'(2x, a)') 'Use of GFN1-xTB for frequency computation requested.' + write (stdout,'(2x, a)') 'Use of GFN1-xTB for frequency computation requested.' case ('gfn2') env%freqver = '--gfn2' - write (*,'(2x, a)') 'Use of GFN2-xTB for frequency computation requested.' + write (stdout,'(2x, a)') 'Use of GFN2-xTB for frequency computation requested.' case ('gfn0') env%freqver = '--gfn0' - write (*,'(2x, a)') 'Use of GFN0-xTB for frequency computation requested.' + write (stdout,'(2x, a)') 'Use of GFN0-xTB for frequency computation requested.' case ('gff','gfnff') env%freqver = '--gff' - write (*,'(2x, a)') 'Use of GFN-FF for frequency computation requested.' + write (stdout,'(2x, a)') 'Use of GFN-FF for frequency computation requested.' end select !========================================================================================! !-------- PRINCIPAL COMPONENT analysis and CLUSTERING flags !========================================================================================! case ('-cluster') - write (*,'(2x,a,'' : ensemble clustering'')') trim(arg(i)) + processedarg(i) = .true. + write (stdout,'(2x,a,'' : ensemble clustering'')') trim(arg(i)) if (env%properties == p_propcalc) then !>--- for standalone use env%properties = p_cluster @@ -2127,59 +2807,72 @@ subroutine parseflags(env,arg,nra) if (i+1 .le. nra) then !second argument a distinct number of clusters read (arg(i+1),*,iostat=io) j if (io == 0.and.(index(arg(i+1),'-') .eq. 0)) then + processedarg(i+1) = .true. env%nclust = j else env%nclust = 0 if ((index(arg(i+1),'-') .eq. 0)) then - ctmp = trim(arg(i+1)) + processedarg(i+1) = .true. + ctmp = arg1 select case (ctmp) case ('loose') env%clustlev = -1 - write (*,'(2x,a,'' loose : using loose clustering setting'')') trim(arg(i)) + write (stdout,'(2x,a,'' loose : using loose clustering setting'')') trim(arg(i)) case ('normal') env%clustlev = 0 - write (*,'(2x,a,'' normal : using normal clustering setting'')') trim(arg(i)) + write (stdout,'(2x,a,'' normal : using normal clustering setting'')') trim(arg(i)) case ('tight') env%clustlev = 1 - write (*,'(2x,a,'' tight : using tight clustering setting'')') trim(arg(i)) + write (stdout,'(2x,a,'' tight : using tight clustering setting'')') trim(arg(i)) case ('vtight','verytight') env%clustlev = 2 - write (*,'(2x,a,'' vtight : using very tight clustering setting'')') trim(arg(i)) + write (stdout,'(2x,a,'' vtight : using very tight clustering setting'')') trim(arg(i)) case ('incremental','incr') env%clustlev = 10 - write (*,'(2x,a,'' incremental : using incremental clustering settings'')') trim(arg(i)) + write (stdout,'(2x,a,'' incremental : using incremental clustering settings'')') trim(arg(i)) case ('tightincremental','tightincr') env%clustlev = 11 - write (*,'(2x,a,'' tightincremental : using incremental clustering settings'')') & + write (stdout,'(2x,a,'' tightincremental : using incremental clustering settings'')') & & trim(arg(i)) case ('vtightincremental','vtightincr') env%clustlev = 12 - write (*,'(2x,a,'' vtightincremental : using incremental clustering settings'')') & + write (stdout,'(2x,a,'' vtightincremental : using incremental clustering settings'')') & & trim(arg(i)) end select end if end if end if + case ('-pccap') + processedarg(i) = .true. if (i+1 .le. nra) then !> second argument is the max. number of PCs read (arg(i+1),*,iostat=io) j if (io == 0.and.(index(arg(i+1),'-') .eq. 0)) then + processedarg(i+1) = .true. env%pccap = j end if end if + case ('-nopcmin') + processedarg(i) = .true. env%pcmin = 0.0d0 + case ('-pctype','-pctyp') + processedarg(i) = .true. if (i+1 .le. nra) then - ctmp = trim(arg(i+1)) + ctmp = arg1 if (ctmp(1:1) .ne. '-') then + processedarg(i+1) = .true. env%pcmeasure = ctmp end if end if + case ('-pcaex','-pcaexclude') + processedarg(i) = .true. if (i+1 .le. nra) then - ctmp = trim(arg(i+1)) + ctmp = arg1 if (ctmp(1:1) .ne. '-') then + processedarg(i+1) = .true. env%atlist = ctmp env%pcaexclude = .true. end if @@ -2188,12 +2881,14 @@ subroutine parseflags(env,arg,nra) !---------- PROPERTY MODE !========================================================================================! case ('-prop') + processedarg(i) = .true. !>---------------------------------------------------------------- !> NOTE: These flags are outdated and using them is discouraged! !>---------------------------------------------------------------- if ((env%properties == p_none.or. & & env%properties == p_propcalc)) then !property selection - ctmp = trim(arg(i+1)) + ctmp = arg1 + processedarg(i+1) = .true. PROPARG:select case(ctmp) case ('hess') !hessian calculation to free energies for all conformers env%properties2 = 1 @@ -2233,26 +2928,40 @@ subroutine parseflags(env,arg,nra) call env%addjob(env%properties2) end if end if + call parseflags_deprecated(argument) + case ('-dftrc') !provide dft-rc file (including path) + processedarg(i) = .true. atmp = '' if (nra .ge. (i+1)) atmp = adjustl(arg(i+1)) if ((atmp(1:1) /= '-').and.(len_trim(atmp) .ge. 1)) then + processedarg(i+1) = .true. env%dftrcfile = trim(atmp) end if + call parseflags_deprecated(argument) + case ('-hardcut') !cut DFT populations hard + processedarg(i) = .true. env%hardcutDFT = .true. + call parseflags_deprecated(argument) + case ('-pclean') !cleanup option for property mode, i.e., remove PROP/ + processedarg(i) = .true. env%pclean = .true. !========================================================================================! case ('-scratch') + processedarg(i) = .true. !use a scratch directory to perform the calculation in env%scratch = .true. atmp = '' if (nra .ge. (i+1)) atmp = adjustl(arg(i+1)) if ((atmp(1:1) /= '-').and.(len_trim(atmp) .ge. 1)) then + processedarg(i+1) = .true. env%scratchdir = trim(atmp) end if + case ('-keepscratch') + processedarg(i) = .true. env%keepScratch = .true. case default continue @@ -2267,6 +2976,8 @@ subroutine parseflags(env,arg,nra) !========================================================================================! deallocate (strings,floats,xx) + call parseflags_cli_summary(nra,arg,processedarg) + !>----- additional checks and settings if (env%crestver .eq. crest_solv) bondconst = .false. @@ -2285,12 +2996,12 @@ subroutine parseflags(env,arg,nra) if ((env%NCI.or.env%wallsetup).and.env%legacy) then call wallpot(env) if (env%wallsetup) then - write (*,'(2x,a)') 'Automatically generated ellipsoide potential:' + write (stdout,'(2x,a)') 'Automatically generated ellipsoide potential:' else - write (*,'(2x,a)') 'Automatically generated ellipsoide potential for NCI mode:' + write (stdout,'(2x,a)') 'Automatically generated ellipsoide potential for NCI mode:' end if call write_cts_NCI_pr(stdout,env%cts) - write (*,*) + write (stdout,*) end if !>--- automatic bond constraint setup @@ -2443,6 +3154,47 @@ subroutine parseflags(env,arg,nra) return end subroutine parseflags +subroutine parseflags_missing(arg) + use crest_parameters + implicit none + character(len=*),intent(in) :: arg + write (stdout,'(a)') trim(arg)//' requires a valid argument' +end subroutine parseflags_missing + +subroutine parseflags_deprecated(arg) + use crest_parameters + implicit none + character(len=*),intent(in) :: arg + write (stdout,'(a)') '** WARNING ** '//trim(arg)//' is deprecated!' +end subroutine parseflags_deprecated + +subroutine parseflags_cli_summary(nra,args,processedarg) + use crest_parameters + use crest_data + implicit none + integer,intent(in) :: nra + character(len=*),intent(in) :: args(nra) + logical,intent(in) :: processedarg(nra) + integer :: ii,nprocessed + nprocessed = count(processedarg,1) + if (nprocessed == nra) then + write (stdout,'(/,a)') '> All CLI arguments successfully processed.' + else + write (stdout,'(70("-"))') + write (stdout,'(a,/)') '** WARNING ** Some CLI arguments were not correctly processed:' + do ii = 1,nra + if (processedarg(ii)) cycle + write (stdout,'(1x,a,i4,a,t20,a)') 'Argument',ii,': ',trim(args(ii)) + end do + + write (stdout,'(/,a)') 'Please check your command line input for sanity.' + write (stdout,'(70("-"))') + write (stdout,*) + call creststop(status_safety) + end if + +end subroutine parseflags_cli_summary + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc! !=========================================================================================! !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC! @@ -2491,7 +3243,7 @@ subroutine parseRC2(env,bondconst) end if if (ex1) then - write (*,'(/,1x,a,a,a)') '<',trim(env%constraints),'> file present.' + write (stdout,'(/,1x,a,a,a)') '<',trim(env%constraints),'> file present.' env%cts%used = .true. else env%cts%used = .false. @@ -2501,13 +3253,13 @@ subroutine parseRC2(env,bondconst) !>--- read the data call read_constrainbuffer(env%constraints,env%cts) call sort_constraints(env%cts) - write (*,*) 'content of the constraining file (sorted):' + write (stdout,*) 'content of the constraining file (sorted):' if (env%cts%ndim .gt. 20) then - write (*,'(1x,a)') '' + write (stdout,'(1x,a)') '' else do i = 1,env%cts%ndim if (trim(env%cts%sett(i)) .ne. '') then - write (*,'(''>'',1x,a)') trim(env%cts%sett(i)) + write (stdout,'(''>'',1x,a)') trim(env%cts%sett(i)) end if end do end if @@ -2532,8 +3284,8 @@ subroutine parseRC2(env,bondconst) dg = atmp call split_set_args(dg,argument) call parse_atlist_new(trim(argument),env%rednat,env%nat,env%ref%at,atlist) - write (*,'(2x,a)') trim(adjustl(btmp)) - write (*,'(5x,a,i0)') '# of atoms considered for RMSDs:',env%rednat + write (stdout,'(2x,a)') trim(adjustl(btmp)) + write (stdout,'(5x,a,i0)') '# of atoms considered for RMSDs:',env%rednat env%includeRMSD = atlist !includeRMSD contains only the atoms that are included in RMSD end if if (index(atmp,'atomlist-') .ne. 0) then @@ -2543,8 +3295,8 @@ subroutine parseRC2(env,bondconst) call split_set_args(dg,argument) call parse_atlist_new(trim(argument),j,env%nat,env%ref%at,atlist) env%rednat = env%nat-j - write (*,'(2x,a)') trim(adjustl(btmp)) - write (*,'(3x,a,i0)') '# of atoms considered for RMSDs:',env%rednat + write (stdout,'(2x,a)') trim(adjustl(btmp)) + write (stdout,'(3x,a,i0)') '# of atoms considered for RMSDs:',env%rednat env%includeRMSD = atlist !includeRMSD contains the atoms that are NOT included in RMSD do k = 1,env%nat if (env%includeRMSD(k) .lt. 1) then !therefore the values have to be "inverted" @@ -2564,15 +3316,15 @@ subroutine parseRC2(env,bondconst) dg = btmp call split_set_args(dg,argument) call parse_atlist_new(trim(argument),env%rednat,env%nat,env%ref%at,atlist) - write (*,'(2x,a)') trim(adjustl(btmp)) - write (*,'(5x,a,i0)') '# of atoms considered for RMSDs:',env%rednat + write (stdout,'(2x,a)') trim(adjustl(btmp)) + write (stdout,'(5x,a,i0)') '# of atoms considered for RMSDs:',env%rednat env%includeRMSD = atlist !includeRMSD contains only the atoms that are included in RMSD end if end do end if if (index(btmp,'reference=') .ne. 0) then call rdarg(btmp,'reference=',env%fixfile) - write (*,'(1x,a,1x,a)') 'fix file:',trim(env%fixfile) + write (stdout,'(1x,a,1x,a)') 'fix file:',trim(env%fixfile) end if if ((index(atmp,'$wall') .ne. 0)) then if (env%NCI) then @@ -2588,9 +3340,9 @@ subroutine parseRC2(env,bondconst) k = k+1 end do - write (*,'(/,2x,a)') 'Automatically generated ellipsoide potential overwritten by:' + write (stdout,'(/,2x,a)') 'Automatically generated ellipsoide potential overwritten by:' call write_cts_NCI(6,env%cts) - write (*,*) + write (stdout,*) end if end if diff --git a/src/legacy_wrappers.f90 b/src/legacy_wrappers.f90 index ae25e43c..26433937 100644 --- a/src/legacy_wrappers.f90 +++ b/src/legacy_wrappers.f90 @@ -425,7 +425,8 @@ subroutine trialOPT(env) !>-- if we reach this point in the standalone trialopt the geometry is ok! write (stdout,*) write (stdout,*) 'Geometry ok!' - stop + write (stdout,*) + call creststop(status_normal) end if end subroutine trialOPT diff --git a/src/readl.f90 b/src/readl.f90 index 82d0c633..97c77f4a 100644 --- a/src/readl.f90 +++ b/src/readl.f90 @@ -22,7 +22,16 @@ subroutine readl(a1,x,n) use iso_fortran_env,only:wp => real64 implicit real(wp) (a-h,o-z) character(*) a1 + integer :: la1,io dimension x(*) + la1=len(a1) + if(la1 == 0)then + return + else if(la1==1)then + read(la1,*,iostat=io) x(1) + n = 1 + return + endif i = 0 is = 1 10 i = i+1 From 513ff947642ac77197b8e0a974afc47c901aada8 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 9 Mar 2026 19:21:23 +0100 Subject: [PATCH 193/374] Proper final printout for basin-hopping --- src/basinhopping/algo.f90 | 17 +++++++++--- src/basinhopping/mc.f90 | 27 ++++++++++--------- src/printouts.f90 | 57 ++++++++++++++++++++++----------------- src/sorting/cregen.f90 | 28 ++++++++++--------- src/sorting/unionize.f90 | 2 +- 5 files changed, 76 insertions(+), 55 deletions(-) diff --git a/src/basinhopping/algo.f90 b/src/basinhopping/algo.f90 index 96edf67b..4d00f446 100644 --- a/src/basinhopping/algo.f90 +++ b/src/basinhopping/algo.f90 @@ -53,7 +53,7 @@ subroutine crest_basinhopping(env,tim) use crest_data use crest_calculator use strucrd - use cregen_interface,only:unionizeEnsembles + use cregen_interface,only:unionizeEnsembles,cregen_irmsd_sort use optimize_module use bh_module use bh_algo_interface @@ -70,6 +70,7 @@ subroutine crest_basinhopping(env,tim) real(wp),allocatable :: grad(:,:) integer :: nall type(coord),allocatable :: structuredump(:) + integer,allocatable :: groups(:) logical :: parallel character(len=80) :: atmp character(len=*),parameter :: trjf = 'crest_quenched.xyz' @@ -131,9 +132,15 @@ subroutine crest_basinhopping(env,tim) write (stdout,*) 'WARNING: BH run terminated ABNORMALLY' env%iostatus_meta = status_failed end if - call tim%stop(14) + write(stdout,*) + call smallhead('Final Ensemble Sorting (iRMSD)') + allocate(groups(nall),source=0) + env%confgo=.true. + call cregen_irmsd_sort(env,nall,structuredump,groups,allcanon=.false.,printlvl=2) + + if (allocated(groups)) deallocate(groups) if (allocated(structuredump)) deallocate (structuredump) return end subroutine crest_basinhopping @@ -170,7 +177,7 @@ subroutine single_basinhopping_core(env,mol,calc,structuredump) nall = 0 do mciter = 1,bh%maxiter - if (bh%maxiter > 1) call printiter2(mciter) + if (bh%maxiter > 1) call printiter3('Basin-Hopping Epoch',mciter) call bh%newiter() call mc(calc,mol,bh,verbosity=2) @@ -210,6 +217,7 @@ subroutine parallel_basinhopping_core(env,mol,calc,structuredump) type(coord),allocatable :: mols(:) real(wp) :: energy integer :: nall + character(len=128) :: tag type(mollist),allocatable :: dumplist(:) call new_ompautoset(env,'auto',0,T,Tn) @@ -240,7 +248,8 @@ subroutine parallel_basinhopping_core(env,mol,calc,structuredump) do K = 1,T do mciter = 1,bhp(K)%maxiter !$omp critical - if (bhp(K)%maxiter > 1) call printiter2(mciter) + write(tag,'(a,i0,a)') 'Runner [',K,']: Basin-Hopping Epoch' + if (bhp(K)%maxiter > 1) call printiter3(trim(tag),mciter) !$omp end critical call bhp(K)%newiter() call mc(calcp(K),mols(K),bhp(K),verbosity=2) diff --git a/src/basinhopping/mc.f90 b/src/basinhopping/mc.f90 index 7ce36642..311f7c8e 100644 --- a/src/basinhopping/mc.f90 +++ b/src/basinhopping/mc.f90 @@ -119,7 +119,7 @@ subroutine mc(calc,mol,bh,verbosity) !$omp critical write (stdout,'(a,1x,a,es17.8,a,es17.8,a)') trim(tag),'Quench E=',etot, & & ' Eh, Markov E=',bh%emin,' Eh' - !$omp end critical + !$omp end critical end if accept = mcaccept(optmol,bh) @@ -128,13 +128,14 @@ subroutine mc(calc,mol,bh,verbosity) call axis(optmol%nat,optmol%at,optmol%xyz) + !> check duplicates here + call mcduplicate(mol,bh,dupe,broken) + if (printlvl > 1) then write (stdout,'(a)',advance='no') repeat(' ',len_trim(tag)+1)// & & "Quench "//colorify('ACCEPTED','green') end if - !> check duplicates here - call mcduplicate(mol,bh,dupe,broken) if (broken) then broke = broke+1 if (printlvl > 1) write (stdout,'(a)',advance='no') & @@ -143,6 +144,9 @@ subroutine mc(calc,mol,bh,verbosity) discarded = discarded+1 if (printlvl > 1) write (stdout,'(a)',advance='no') & & ', but '//colorify('NOT SAVED','yellow')//' due to duplicate detection!' + else if (printlvl == 1) then + write(stdout,'(a,1x,a,a,es17.8,a)') trim(tag),"Quench "//colorify('ACCEPTED','green'), & + & ', NEW Markov E=',bh%emin,' Eh' end if if (printlvl > 1) write (stdout,'(/)') @@ -219,7 +223,6 @@ subroutine mcheader(bh) write (stdout,'("|")') end if - write (stdout,'(a,1x)',advance='no') '|' write (stdout,'(a,a,2x)',advance='no') 'step type: ',steptypestr(bh%steptype) write (stdout,'(a,3f9.5)',advance='no') 'step size:',bh%stepsize(1:3) @@ -379,23 +382,21 @@ subroutine mcduplicate(mol,bh,dupe,broken) !$omp end critical end subroutine mcduplicate - !========================================================================================! - - subroutine mcquench(calc,bh,tmpmol,optmol,iostat) + !========================================================================================! + + subroutine mcquench(calc,bh,tmpmol,optmol,iostat) implicit none !> Input - type(calcdata),intent(inout) :: calc !> potential settings - type(bh_class),intent(inout) :: bh !> BH settings - type(coord),intent(in) :: tmpmol !> molecular system + type(calcdata),intent(inout) :: calc !> potential settings + type(bh_class),intent(inout) :: bh !> BH settings + type(coord),intent(in) :: tmpmol !> molecular system !> Output type(coord),intent(out) :: optmol !> molecular system output integer,intent(out) :: iostat iostat = 1 - - end subroutine mcquench - + end subroutine mcquench !=========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<--- handle optional arguments if (present(allcanon)) then - individual_IDs = allcanon + individual_IDs = .not.allcanon else individual_IDs = .false. end if @@ -1529,22 +1529,24 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) !>--- set up parameters (note we are working with BOHR internally) RTHR = env%rthr*aatoau + ETHR = env%ethr/autokcal !>--- print some sorting data if (prlvl > 0) then write (stdout,'(a)') 'CREGEN> Info for iRMSD sorting:' - write (stdout,'(2x,a,i9)') 'number of structures :',nall - write (stdout,'(2x,a,f9.5,a)') 'RTHR (RMSD threshold) :',RTHR*autoaa,' Å' - write (stdout,'(2x,a,i9)') 'OpenMP threads :',T - write (stdout,'(2x,a,a9)') 'Individual atom IDs? :',to_str(individual_IDs) - write (stdout,'(2x,a)',advance='no') 'False rotamer check? :' + write (stdout,'(2x,a,t32,a,i10)') 'number of structures',':',nall + write (stdout,'(2x,a,t32,a,f10.5,a)') 'RTHR (RMSD threshold)',':',RTHR*autoaa,' Å' + write (stdout,'(2x,a,t32,a,es10.2,a)') 'ETHR (energy threshold)',':',ETHR,' Ha' + write (stdout,'(2x,a,t32,a,i10)') 'OpenMP threads',':',T + write (stdout,'(2x,a,t32,a,a10)') 'Individual atom IDs?',':',to_str(individual_IDs) + write (stdout,'(2x,a,t32,a)',advance='no') 'False rotamer check?',':' select case (env%iinversion) case (0) - write (stdout,'(a9)') 'auto' + write (stdout,'(a10)') 'auto' case (1) - write (stdout,'(a9)') 'on' + write (stdout,'(a10)') 'on' case (2) - write (stdout,'(a9)') 'off' + write (stdout,'(a10)') 'off' end select write (stdout,*) end if @@ -1646,12 +1648,14 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) !>--- Then, cross-check all other unassigned conformers !$omp parallel & !$omp shared(nall, nat, groups, individual_IDs, sorters, rcaches) & - !$omp shared(workmols, structures, ii) & - !$omp private(jj,rmsdval,cc) + !$omp shared(workmols, structures, ii, ETHR) & + !$omp private(jj,rmsdval,cc,ediff) !$omp do schedule(dynamic) do jj = ii+1,nall cc = omp_get_thread_num()+1 if (groups(jj) .ne. 0) cycle + ediff = abs(structures(ii)%energy-structures(jj)%energy) + if(ediff > ETHR) cycle if (individual_IDs) then rcaches(cc)%rank(1:nat,1) = sorters(ii)%rank(1:nat) rcaches(cc)%rank(1:nat,2) = sorters(jj)%rank(1:nat) diff --git a/src/sorting/unionize.f90 b/src/sorting/unionize.f90 index 453fdada..87b88c1f 100644 --- a/src/sorting/unionize.f90 +++ b/src/sorting/unionize.f90 @@ -85,7 +85,7 @@ subroutine unionizeEnsembles(nin,inputs,nmerge,newmols,rthr,ethr) !>--- allocate mapping allocate (similarto(nmerge),source=0) -!>--- we can skip the soring is "inputs" is empty + !>--- we can skip the sorting if "inputs" is empty if (nin .ne. 0) then !>--- Prepare comparison data storage if (debug) write (*,*) From bd2135a62853be228c60ba51c8650e6d612d3262 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 10 Mar 2026 16:37:51 +0100 Subject: [PATCH 194/374] Basinhopping on dihedral angles --- src/basinhopping/algo.f90 | 39 +++++-- src/basinhopping/class.f90 | 7 +- src/basinhopping/mc.f90 | 49 +++++---- src/basinhopping/takestep.f90 | 45 +++++++- src/internals2.f90 | 179 ++++++++++++++++--------------- src/molbuilder/analyze.f90 | 1 + src/molbuilder/classify_type.f90 | 97 +++++++++++++++-- src/printouts.f90 | 35 +++++- 8 files changed, 324 insertions(+), 128 deletions(-) diff --git a/src/basinhopping/algo.f90 b/src/basinhopping/algo.f90 index 4d00f446..c98dbebc 100644 --- a/src/basinhopping/algo.f90 +++ b/src/basinhopping/algo.f90 @@ -134,13 +134,13 @@ subroutine crest_basinhopping(env,tim) end if call tim%stop(14) - write(stdout,*) + write (stdout,*) call smallhead('Final Ensemble Sorting (iRMSD)') - allocate(groups(nall),source=0) - env%confgo=.true. + allocate (groups(nall),source=0) + env%confgo = .true. call cregen_irmsd_sort(env,nall,structuredump,groups,allcanon=.false.,printlvl=2) - if (allocated(groups)) deallocate(groups) + if (allocated(groups)) deallocate (groups) if (allocated(structuredump)) deallocate (structuredump) return end subroutine crest_basinhopping @@ -152,6 +152,7 @@ subroutine single_basinhopping_core(env,mol,calc,structuredump) use strucrd use cregen_interface,only:unionizeEnsembles use optimize_module + use molbuilder_classify use bh_module implicit none type(systemdata),intent(inout) :: env @@ -174,6 +175,16 @@ subroutine single_basinhopping_core(env,mol,calc,structuredump) call bh%init(300.0_wp,200,20) bh%stepsize(1) = 1.0_wp end if + select case (bh%steptype) + case (1,2) !> internals, dihedral only + write (stdout,'(a)') '> Setting up internal coordinates for input molecule:' + call setup_classify(mol,bh%molc) + call functional_group_classify(bh%molc) + call bh%molc%get_zmat(.true.) + call bh%molc%print_zmat(stdout) + write (stdout,*) + call bh%molc%check_dihedrals() + end select nall = 0 do mciter = 1,bh%maxiter @@ -202,6 +213,8 @@ subroutine parallel_basinhopping_core(env,mol,calc,structuredump) use cregen_interface,only:unionizeEnsembles use optimize_module use bh_module + use iomod,only:is_terminal + use molbuilder_classify implicit none !> INPUT/OUTPUT type(systemdata),intent(inout) :: env @@ -216,7 +229,7 @@ subroutine parallel_basinhopping_core(env,mol,calc,structuredump) type(bh_class),allocatable :: bhp(:) type(coord),allocatable :: mols(:) real(wp) :: energy - integer :: nall + integer :: nall,verbose character(len=128) :: tag type(mollist),allocatable :: dumplist(:) @@ -242,17 +255,29 @@ subroutine parallel_basinhopping_core(env,mol,calc,structuredump) end if do K = 1,T bhp(K)%id = K-1 + !$omp critical + select case (bhp(K)%steptype) + case (1,2) !> internals, dihedral only + if (K == 1) write (stdout,'(a)') '> Setting up internal coordinates for input molecule:' + call setup_classify(mol,bhp(K)%molc) + call functional_group_classify(bhp(K)%molc) + call bhp(K)%molc%get_zmat(.true.) + if (K == 1) call bhp(K)%molc%print_zmat(stdout) + if (K == 1) write (stdout,*) + call bhp(K)%molc%check_dihedrals() + end select + !$omp end critical end do !$omp parallel do default(shared) private(K, mciter) schedule(dynamic) do K = 1,T do mciter = 1,bhp(K)%maxiter !$omp critical - write(tag,'(a,i0,a)') 'Runner [',K,']: Basin-Hopping Epoch' + write (tag,'(a,i0,a)') 'Runner [',K-1,']: Basin-Hopping Epoch' if (bhp(K)%maxiter > 1) call printiter3(trim(tag),mciter) !$omp end critical call bhp(K)%newiter() - call mc(calcp(K),mols(K),bhp(K),verbosity=2) + call mc(calcp(K),mols(K),bhp(K),verbosity=1) write (stdout,'(a)') 'New structures will be appended to memory ...' call unionizeEnsembles(dumplist(K)%nall,dumplist(K)%structure, & diff --git a/src/basinhopping/class.f90 b/src/basinhopping/class.f90 index 58deff5e..1e0587e4 100644 --- a/src/basinhopping/class.f90 +++ b/src/basinhopping/class.f90 @@ -22,6 +22,7 @@ module bh_class_module use strucrd,only:coord use canonical_mod use irmsd_module + use molbuilder_classify implicit none !=========================================================================================! @@ -65,13 +66,16 @@ module bh_class_module !>--- temporary storage integer,allocatable :: amat(:,:) !> adjacency matrix - real(wp),allocatable :: zmat(:,:) !> internal coordinates (to cache the memory) type(rmsd_cache),allocatable :: rcache !> similarity check cache (iRMSD) logical :: stereocheck = .false. !> check for false-rotamers? type(canonical_sorter),allocatable :: sorters(:) !> canonical atom ID storage logical :: topocheck = .true. !> check for correct connectivity type(canonical_sorter),allocatable :: refsort !> use same reference connectivity for all +!> internal coordinates (stored via coord_classify) + type(coord_classify) :: molc + + !>--- Type procedures contains procedure :: init => bh_class_allocate @@ -128,7 +132,6 @@ subroutine bh_class_deallocate(self) class(bh_class) :: self if (allocated(self%structures)) deallocate (self%structures) if (allocated(self%amat)) deallocate (self%amat) - if (allocated(self%zmat)) deallocate (self%zmat) if (allocated(self%sorters)) deallocate (self%sorters) if (allocated(self%rcache)) deallocate (self%rcache) if (allocated(self%refsort)) deallocate (self%refsort) diff --git a/src/basinhopping/mc.f90 b/src/basinhopping/mc.f90 index 311f7c8e..633f9445 100644 --- a/src/basinhopping/mc.f90 +++ b/src/basinhopping/mc.f90 @@ -106,8 +106,10 @@ subroutine mc(calc,mol,bh,verbosity) dupe = .false. !>--- Take the step (mol --> tmpmol) + !!$omp critical call takestep(mol,calc,bh,tmpmol) - + !!$omp end critical + !>--- Quench it (tmpmol --> optmol) call optimize_geometry(tmpmol,optmol,calc,etot,grd, & & .false.,.false.,iostatus) @@ -198,42 +200,43 @@ subroutine mcheader(bh) character(len=80) :: atmp integer :: n - write (stdout,'(a)') '+'//repeat('-',63)//'+' - write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(t8,a)') '┌'//repeat('─',63)//'┐' + write (stdout,'(t8,a,1x)',advance='no') '│' write (stdout,'(a,3x)',advance='no') 'Starting Basin-Hopping Global Optimization' write (stdout,'(a,i3,a)',advance='no') '[Thread/ID ',bh%id,']' - write (stdout,'(2x,"|")') + write (stdout,'(2x,"│")') + write (stdout,'(t8,a)') '╞'//repeat('═',63)//'╡' - write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(t8,a,1x)',advance='no') '│' write (stdout,'(a,f20.10,a)',advance='no') 'Initial energy:',bh%emin,' Eh' - write (stdout,'(24x,"|")') + write (stdout,'(24x,"│")') - write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(t8,a,1x)',advance='no') '│' write (stdout,'(a,es9.3,3x)',advance='no') 'T/K: ',bh%temp write (stdout,'(a,i5,3x)',advance='no') 'steps: ',bh%maxsteps write (stdout,'(a,i5,3x)',advance='no') 'max save: ',bh%maxsave - write (stdout,'(12x,"|")') + write (stdout,'(12x,"│")') if (allocated(bh%seed)) then - write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(t8,a,1x)',advance='no') '│' write (atmp,'(a,i0)') 'Random number generation (reference) seed: ',bh%seed write (stdout,'(a,1x)',advance='no') trim(atmp) n = 61-len_trim(atmp) write (stdout,'(a)',advance='no') repeat(' ',n) - write (stdout,'("|")') + write (stdout,'("│")') end if - write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(t8,a,1x)',advance='no') '│' write (stdout,'(a,a,2x)',advance='no') 'step type: ',steptypestr(bh%steptype) write (stdout,'(a,3f9.5)',advance='no') 'step size:',bh%stepsize(1:3) - write (stdout,'(3x,"|")') + write (stdout,'(3x,"│")') - write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(t8,a,1x)',advance='no') '│' write (stdout,'(a,f9.5,a)',advance='no') 'Thresholds ΔRMSD:',bh%rthr,' Å, ' write (stdout,'(a,es10.4,a)',advance='no') 'ΔE: ',bh%ethr,' kcal/mol' - write (stdout,'(6x,"|")') + write (stdout,'(6x,"│")') - write (stdout,'(a)') '+'//repeat('-',63)//'+' + write (stdout,'(t8,a)') '└'//repeat('─',63)//'┘' end subroutine mcheader subroutine mcstats(bh,accepted,discarded,broke) @@ -242,26 +245,26 @@ subroutine mcstats(bh,accepted,discarded,broke) integer,intent(in) :: accepted,discarded,broke real(wp) :: ratio - write (stdout,'(a)') '+'//repeat('~',63)//'+' - write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(t8,a)') colorify('┌'//repeat('─',63)//'┐','green') + write (stdout,'(t8,a,1x)',advance='no') colorify("│","green") write (stdout,'(a,21x)',advance='no') 'Basin-Hopping Statistics' write (stdout,'(a,i3,a)',advance='no') '[Thread/ID ',bh%id,']' - write (stdout,'(2x,"|")') + write (stdout,'(2x,a)') colorify("│","green") - write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(t8,a,1x)',advance='no') colorify("│","green") ratio = real(accepted,wp)/real(bh%maxsteps,wp) write (stdout,'(a,f6.2,a)',advance='no') 'MC acceptance ratio ',ratio*100.0_wp,' %, ' ratio = real(discarded,wp)/real(accepted,wp) write (stdout,'(a,f6.2,a)',advance='no') 'similarity rejection ',ratio*100.0_wp,' %' - write (stdout,'(2x,"|")') + write (stdout,'(2x,a)') colorify("│","green") - write (stdout,'(a,1x)',advance='no') '|' + write (stdout,'(t8,a,1x)',advance='no') colorify("│","green") ratio = real(broke,wp)/real(accepted,wp) write (stdout,'(a,f6.2,a)',advance='no') 'topology rejection ',ratio*100.0_wp,' %, ' ratio = real(accepted-discarded-broke,wp)/real(bh%maxsteps,wp) write (stdout,'(a,f6.2,a)',advance='no') 'TOTAL ACCEPT ratio ',ratio*100.0_wp,' %' - write (stdout,'(2x,"|")') - write (stdout,'(a)') '+'//repeat('~',63)//'+' + write (stdout,'(2x,a)') colorify("│","green") + write (stdout,'(t8,a)') colorify('└'//repeat('─',63)//'┘',"green" ) end subroutine mcstats !=========================================================================================! diff --git a/src/basinhopping/takestep.f90 b/src/basinhopping/takestep.f90 index 0cad7527..fa705d23 100644 --- a/src/basinhopping/takestep.f90 +++ b/src/basinhopping/takestep.f90 @@ -52,6 +52,7 @@ function steptypestr(steptype) result(str) end select end function steptypestr +!=========================================================================================! !=========================================================================================! subroutine takestep(mol,calc,bh,newmol) @@ -64,15 +65,19 @@ subroutine takestep(mol,calc,bh,newmol) !> LOCAL select case (bh%steptype) - case(0) !> Cartesian + case (0) !> Cartesian newmol = mol call takestep_cart(newmol,bh%stepsize(1),calc) + case (2) !> dihedral only + newmol = mol + call takestep_dihedral(newmol,bh%molc,bh%stepsize(3),calc) case default error stop 'Steptype not implemented yet' end select end subroutine takestep +!=========================================================================================! !=========================================================================================! subroutine takestep_cart(newmol,stepsize,calc) @@ -105,11 +110,47 @@ subroutine take_fixed_stepsize_cart(newmol,stepsize,calc) end if call random_number(r) r(:) = (r(:)-0.5_wp)*2.0_wp - length=norm2(r) + length = norm2(r) newmol%xyz(:,i) = newmol%xyz(:,i)+r(:)*stepsize/length end do end subroutine take_fixed_stepsize_cart +!=========================================================================================! + + subroutine takestep_dihedral(newmol,molc,stepsize,calc) + use molbuilder_classify_type, only: dtypes + implicit none + type(coord),intent(inout) :: newmol + type(coord_classify),intent(inout) :: molc + real(wp),intent(in) :: stepsize + type(calcdata),intent(inout) :: calc + real(wp) :: r(1) + integer :: i,k + logical :: smartstep + call molc%update_zmat(newmol) + smartstep = allocated(molc%dtype) + if (smartstep) then + !> fallback: we need at least one valid dihdral if smartstep is true + !> otherwise we should turn it off again + k = count(molc%dtype(:) == dtypes%single) + if (k == 0) smartstep = .false. + end if + + do i = 1,newmol%nat + if (molc%zmap(i,3) .ne. 0) then + if (smartstep) then + if (molc%dtype(i) .ne. dtypes%single) cycle + end if + call random_number(r) + r(:) = (r(:)-0.5_wp)*2.0_wp + + molc%zmat(3,i) = molc%zmat(3,i)+r(1)*stepsize + end if + end do + !call molc%print_zmat(stdout) + call molc%from_zmat(newmol) + end subroutine takestep_dihedral + !=========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< first atom at zero GEO(1:3,1) = 0.0_wp !> select second atom - do i = 2,nat + do i = 1,nat j = NA(i) k = NB(i) l = NC(i) - GEO(1,i) = sqrt((xyz(1,i)-xyz(1,j))**2+ & - & (xyz(2,i)-xyz(2,j))**2+ & - & (xyz(3,i)-xyz(3,j))**2) - if (k /= 0) then - call BANGLE2(xyz,i,j,k,geo(2,i)) - geo(2,i) = geo(2,i)*DEGREE - if (l /= 0) then - call DIHED2(xyz,i,j,k,l,geo(3,i)) - geo(3,i) = geo(3,i)*DEGREE + if (j /= 0) then + GEO(1,i) = sqrt((xyz(1,i)-xyz(1,j))**2+ & + & (xyz(2,i)-xyz(2,j))**2+ & + & (xyz(3,i)-xyz(3,j))**2) + if (k /= 0) then + call BANGLE2(xyz,i,j,k,geo(2,i)) + geo(2,i) = geo(2,i)*DEGREE + if (l /= 0) then + call DIHED2(xyz,i,j,k,l,geo(3,i)) + geo(3,i) = geo(3,i)*DEGREE + end if end if end if end do @@ -347,11 +347,15 @@ SUBROUTINE GMETRY2(nat,geo,coord,na,nb,nc) !taken(:) = .false. !>--- first atom at origin - COORD(1:3,1) = 0.0_wp + do i = 1,nat + if (na(i) == 0) then + COORD(1:3,i) = 0.0_wp + end if + end do !taken(1) = .true. !>--- second atom - do i = 2,nat - if (na(i) == 1.and.nb(i) == 0.and.nc(i) == 0) then + do i = 1,nat + if (na(i) /= 0.and.nb(i) == 0.and.nc(i) == 0) then COORD(1,i) = GEO(1,i) COORD(2,i) = 0.0_wp COORD(3,i) = 0.0_wp @@ -361,7 +365,7 @@ SUBROUTINE GMETRY2(nat,geo,coord,na,nb,nc) end if end do !>--- third atom - do i = 2,nat + do i = 1,nat if (na(i) /= 0.and.nb(i) /= 0.and.nc(i) == 0) then COSC = COS(GEO(2,i)) j = na(i) @@ -378,17 +382,17 @@ SUBROUTINE GMETRY2(nat,geo,coord,na,nb,nc) end if end do - ! TAKELOOP: do while (any(.not.taken(:))) - TAKELOOP : do while ( any(COORD(:,:) > verylarge)) - DO I = 2,nat + ! TAKELOOP: do while (any(.not.taken(:))) + TAKELOOP: do while (any(COORD(:,:) > verylarge)) + DO I = 1,nat !>--- CYCLE the atom if already generated !if (taken(i)) cycle - if (COORD(1,i) < verylarge ) cycle + if (COORD(1,i) < verylarge) cycle !>--- CYCLE if any of the depending atoms have not been generated - ! if ((.not.taken(NA(i))).or.(.not.taken(NB(i))) & - !& .or.(.not.taken(NC(i)))) cycle - if ( coord(1,NA(i)) > verylarge .or. & - & coord(1,NB(i)) > verylarge .or. & + ! if ((.not.taken(NA(i))).or.(.not.taken(NB(i))) & + !& .or.(.not.taken(NC(i)))) cycle + if (coord(1,NA(i)) > verylarge.or. & + & coord(1,NB(i)) > verylarge.or. & & coord(1,NC(i)) > verylarge) cycle COSA = COS(GEO(2,I)) @@ -501,35 +505,36 @@ subroutine print_zmat(ch,nat,at,geo,na,nb,nc,nice) character(len=120) :: atmp integer :: i - if(nice)then - write (ch,'(1x,a5,1x,a12,1x,a12,1x,a12,a5,a5,a5)') 'A','d(AB)','θ(ABC)','ϕ(ABCD)','B','C','D' - do i = 1,nat - if (na(i) .ne. 0) then - if (nb(i) .ne. 0) then - if (nc(i) .ne. 0) then - write (atmp,'(1x,i5,1x,3f12.4,3i5)') i,geo(1:3,i),na(i),nb(i),nc(i) + if (nice) then + write (ch,'(1x,a2,1x,a5,1x,a12,1x,a12,1x,a12,a5,a5,a5)') & + & 'at','A','d(AB)','θ(ABC)','ϕ(ABCD)','B','C','D' + do i = 1,Nat + if (na(i) .ne. 0) then + if (nb(i) .ne. 0) then + if (nc(i) .ne. 0) then + write (atmp,'(1x,a2,1x,i5,1x,3f12.4,3i5)') i2e(at(i)),i,geo(1:3,i),na(i),nb(i),nc(i) + else + write (atmp,'(1x,a2,1x,i5,1x,2f12.4,a12,2i5)') i2e(at(i)),i,geo(1:2,i),'-',na(i),nb(i) + atmp = trim(atmp)//' -' + end if else - write (atmp,'(1x,i5,1x,2f12.4,a12,2i5)') i,geo(1:2,i),'-',na(i),nb(i) - atmp = trim(atmp)//' -' + write (atmp,'(1x,a2,1x,i5,1x,f12.4,a12,a12,i5)') i2e(at(i)),i,geo(1,i),'-','-',na(i) + atmp = trim(atmp)//' - -' end if else - write (atmp,'(1x,i5,1x,f12.4,a12,a12,i5)') i,geo(1,i),'-','-',na(i) - atmp = trim(atmp)//' - -' + write (atmp,'(1x,a2,1x,i5,1x,a12,a12,a12)') i2e(at(i)),i,'-','-','-' + atmp = trim(atmp)//' - - -' end if - else - write (atmp,'(1x,i5,1x,a12,a12,a12)') i,'-','-','-' - atmp = trim(atmp)//' - - -' - end if - write (ch,'(a)') trim(atmp) - end do + write (ch,'(a)') trim(atmp) + end do else - write(ch,*) nat - do i = 1,nat - write (atmp,'(1x,a,1x,3f12.4,3i5)') i2e(at(i),'nc'),geo(1:3,i),na(i),nb(i),nc(i) - write (ch,'(a)') trim(atmp) - end do + write (ch,*) nat + do i = 1,nat + write (atmp,'(1x,a,1x,3f12.4,3i5)') i2e(at(i),'nc'),geo(1:3,i),na(i),nb(i),nc(i) + write (ch,'(a)') trim(atmp) + end do - endif + end if end subroutine print_zmat @@ -549,46 +554,46 @@ subroutine rd_zmat(fname,nat,at,zmat,na,nb,nc) character(len=300) line at(:) = 0 - na(:) = 0 + na(:) = 0 nb(:) = 0 nc(:) = 0 zmat(:,:) = 0.0_wp - open(newunit=ich,file=trim(fname)) - read(ich,*) j - if(j /= nat) error stop 'Nat mismatch in rd_zmat()' - do i=1,nat - read(ich,'(a)') line + open (newunit=ich,file=trim(fname)) + read (ich,*) j + if (j /= nat) error stop 'Nat mismatch in rd_zmat()' + do i = 1,nat + read (ich,'(a)') line call zmatline(line,sym,zmat(:,i),na(i),nb(i),nc(i),io) - if(io /= 0) error stop 'error while reading zmat' - at(i) = e2i(sym) - enddo - close(ich) - contains + if (io /= 0) error stop 'error while reading zmat' + at(i) = e2i(sym) + end do + close (ich) + contains subroutine zmatline(line,sym,xyz,a,b,c,io) - implicit none - character(len=*) :: line - character(len=*) :: sym - real(wp) :: xyz(3) - integer :: a,b,c - integer,intent(out) :: io - - io = 0 - xyz(1:3) = 0 - a = 0 - b = 0 - c = 0 - read (line,*,iostat=io) sym,xyz(1:3),a,b,c - if (io .ne. 0) then - read (line,*,iostat=io) sym,xyz(1:2),a,b - if(io.ne.0)then - read (line,*,iostat=io) sym,xyz(1),a - if(io.ne.0)then - read (line,*,iostat=io) sym - endif - endif - end if + implicit none + character(len=*) :: line + character(len=*) :: sym + real(wp) :: xyz(3) + integer :: a,b,c + integer,intent(out) :: io + + io = 0 + xyz(1:3) = 0 + a = 0 + b = 0 + c = 0 + read (line,*,iostat=io) sym,xyz(1:3),a,b,c + if (io .ne. 0) then + read (line,*,iostat=io) sym,xyz(1:2),a,b + if (io .ne. 0) then + read (line,*,iostat=io) sym,xyz(1),a + if (io .ne. 0) then + read (line,*,iostat=io) sym + end if + end if + end if - return + return end subroutine zmatline end subroutine rd_zmat diff --git a/src/molbuilder/analyze.f90 b/src/molbuilder/analyze.f90 index 83b022e2..bf8cf78c 100644 --- a/src/molbuilder/analyze.f90 +++ b/src/molbuilder/analyze.f90 @@ -181,6 +181,7 @@ subroutine prune_zmat_dihedrals(mol,zmat,na,nb,nc,ztod,hpyrad,bond) end if do j = 1,nat if (j == refi) cycle + if (j == nc(refi)) cycle if (ztod(j) == i) then nc(j) = refi call DIHED2(xyz,j,na(j),nb(j),nc(j),zmat(3,j)) diff --git a/src/molbuilder/classify_type.f90 b/src/molbuilder/classify_type.f90 index 0eeb54c4..2ef6c882 100644 --- a/src/molbuilder/classify_type.f90 +++ b/src/molbuilder/classify_type.f90 @@ -38,6 +38,15 @@ module molbuilder_classify_type procedure :: copy => copy_func_group end type functional_group + type,private:: dihedral_types + integer :: unknown = 0 + integer :: single = 1 + integer :: improper = 2 + integer :: stiff = 3 + integer :: macrocycle = 4 + end type dihedral_types + type(dihedral_types),parameter,public :: dtypes = dihedral_types() + type,extends(coord) :: coord_classify !> new components that are added to the coord type: !integer,allocatable :: A(:,:) !> molecular graph/adjacency matrix @@ -62,6 +71,7 @@ module molbuilder_classify_type integer,allocatable :: zmap(:,:) !> na,nb,nc integer,allocatable :: ztod(:) integer,allocatable :: hatsort(:,:) + integer,allocatable :: dtype(:) !> utility storage logical,allocatable :: lwork(:) @@ -74,6 +84,8 @@ module molbuilder_classify_type procedure,private :: coord_classify_add_fg procedure :: get_zmat => coord_classify_calculate_zmat procedure :: from_zmat => coord_classify_reconstruct_from_zmat + procedure :: update_zmat => coord_classify_update_zmat + procedure :: check_dihedrals => coord_classify_check_dihedrals procedure :: print_funcgroups => coord_classify_print_functional procedure :: print_zmat => coord_classify_print_zmat end type coord_classify @@ -317,7 +329,7 @@ subroutine coord_classify_calculate_zmat(molc,natural) if (present(natural)) then if (natural) then - write (stdout,'(/,a)') 'NOTE: atom order will temporarily be changed!' + !write (stdout,'(/,a)') 'NOTE: atom order will temporarily be changed!' call coord_classify_hatsort(molc) end if end if @@ -335,7 +347,7 @@ subroutine coord_classify_calculate_zmat(molc,natural) if (natural) then call prune_zmat_dihedrals(molc,molc%zmat, & & molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3),molc%ztod, & - hpyrad=.true., bond=molc%bond) + hpyrad=.true.,bond=molc%bond) !call molc%print_zmat(stdout) call coord_classify_hatsort_restore(molc) deallocate (molc%hatsort) @@ -357,15 +369,88 @@ subroutine coord_classify_reconstruct_from_zmat(molc,mol) & molc%xyz, & & molc%zmap(:,1),molc%zmap(:,2),molc%zmap(:,3)) - !if (allocated(molc%hatsort)) then - ! call coord_classify_hatsort_restore(molc) - ! deallocate (molc%hatsort) - !end if if (present(mol)) then mol = molc%as_coord() end if end subroutine coord_classify_reconstruct_from_zmat + subroutine coord_classify_update_zmat(molc,mol) + !************************************************************ + !* Update the Z-matrix with fresh coords from Cartesian ones + !* (The mapping must exist at this point) + !************************************************************ + implicit none + class(coord_classify),intent(inout) :: molc + type(coord),intent(in),optional :: mol + integer :: ii,jj,a,b,c,d + + if (.not.allocated(molc%zmat)) then + write (stdout,*) '** ERROR ** in coord_classify_update_zmat(): zmat not allocated!' + return + end if + if (.not.allocated(molc%zmap)) then + write (stdout,*) '** ERROR ** in coord_classify_update_zmat(): zmapping not allocated!' + return + end if + if (present(mol)) then + if (.not.all(mol%at .eq. molc%at)) then + write (stdout,*) '** ERROR ** in coord_classify_update_zmat(): mismatch in atom order' + return + end if + molc%xyz = mol%xyz + end if + do a = 1,molc%nat + b = molc%zmap(a,1) + if (b == 0) cycle + molc%zmat(1,a) = molc%dist(a,b) + c = molc%zmap(a,2) + if (c == 0) cycle + molc%zmat(2,a) = molc%angle(a,b,c) + d = molc%zmap(a,3) + if (d == 0) cycle + molc%zmat(3,a) = molc%dihedral(a,b,c,d) + end do + end subroutine coord_classify_update_zmat + + subroutine coord_classify_check_dihedrals(molc) + !************************************************************ + !* Attempt to assign dihedral angles to a type of dihedral + !************************************************************ + implicit none + class(coord_classify),intent(inout) :: molc + integer :: ii,jj,a,b,c,d + + if (.not.allocated(molc%zmap)) then + write (stdout,*) '** ERROR ** in coord_classify_update_zmat(): zmapping not allocated!' + return + end if + + if (allocated(molc%dtype)) deallocate (molc%dtype) + allocate (molc%dtype(molc%nat),source=dtypes%unknown) + + do ii = 1,molc%nat + if (molc%zmap(3,ii) .eq. 0) cycle + a = ii + b = molc%zmap(ii,1) + c = molc%zmap(ii,2) + d = molc%zmap(ii,3) + + if (molc%bond(a,b) > 0.and. & + & molc%bond(b,c) > 0.and. & + & molc%bond(c,d) > 0) then + molc%dtype(ii) = dtypes%single + else if(molc%bond(a,b) > 0.and. & + & molc%bond(b,c) > 0.and. & + & molc%bond(b,d) > 0) then + molc%dtype(ii) = dtypes%improper + end if + !write(*,*) ii, molc%dtype(ii) + end do + + end subroutine coord_classify_check_dihedrals + +!=============================================================================! + subroutine coord_classify_hatsort(molc) !************************************************************** !* a routine that resorts the atomorder in molc so that diff --git a/src/printouts.f90 b/src/printouts.f90 index 41bfc41a..34462d17 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -665,7 +665,8 @@ subroutine printiter3(text,i) integer,intent(in) :: i character(len=128) :: atmp write (atmp,'(a,1x,i0)') trim(text),i - call largehead(trim(atmp)) + !call largehead(trim(atmp)) + call construct_boxed_headline(trim(atmp),80,.true.) end subroutine printiter3 !========================================================================================! @@ -715,6 +716,38 @@ subroutine construct_large_headline(symb,str) write (*,'(a)') trim(str2) return end subroutine construct_large_headline +subroutine construct_boxed_headline(str,width,bold) + use crest_parameters,only:stdout + implicit none + character(len=*),intent(in) :: str + integer,intent(in) :: width + logical,intent(in) :: bold + integer :: strlen,strlen2 + integer :: k,i,j,jj + integer :: wid + wid = max(width,len_trim(str)+4)-2 + wid = width-2 + strlen = len_trim(str) + if (strlen > wid) wid = strlen + write (stdout,*) + if (bold) then + write (stdout,'(a)') "┏"//repeat("━",wid)//"┓" + else + write (stdout,'(a)') "┌"//repeat("─",wid)//"┐" + end if + strlen2 = wid+2 + k = strlen2-strlen + j = k/2 + jj = k-j-2 + if (bold) then + write (stdout,'(a)') "┃"//repeat(" ",j)//trim(str)//repeat(" ",jj)//"┃" + write (stdout,'(a)') "┗"//repeat("━",wid)//"┛" + else + write (stdout,'(a)') "│"//repeat(" ",j)//trim(str)//repeat(" ",jj)//"│" + write (stdout,'(a)') "└"//repeat("─",wid)//"┘" + end if + return +end subroutine construct_boxed_headline !========================================================================================! From 738e57559285621cf4dfa7fda2be0bf159e1f58f Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 10 Mar 2026 16:39:10 +0100 Subject: [PATCH 195/374] Fix optimization tester (sp -> wp) --- test/test_optimization.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/test_optimization.F90 b/test/test_optimization.F90 index 6f01e39b..187cfd31 100644 --- a/test/test_optimization.F90 +++ b/test/test_optimization.F90 @@ -59,7 +59,7 @@ subroutine test_ancopt(error) integer :: io logical :: wr,pr !&< - real(wp),parameter :: e_ref = -4.677663337455959_wp + real(wp),parameter :: e_ref = -4.677661756_wp !&> !> setup From 71d73fd8b45eb0721090b75c058ebd12d5381eb7 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 10 Mar 2026 21:10:44 +0100 Subject: [PATCH 196/374] fix 1 character readl --- src/readl.f90 | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/src/readl.f90 b/src/readl.f90 index 97c77f4a..7d6ecf01 100644 --- a/src/readl.f90 +++ b/src/readl.f90 @@ -22,16 +22,20 @@ subroutine readl(a1,x,n) use iso_fortran_env,only:wp => real64 implicit real(wp) (a-h,o-z) character(*) a1 - integer :: la1,io + integer :: la1,io,tmpi dimension x(*) - la1=len(a1) - if(la1 == 0)then + la1 = len(a1) + if (la1 == 0) then + n = 0 return - else if(la1==1)then - read(la1,*,iostat=io) x(1) - n = 1 + else if (la1 == 1) then + read (a1,*,iostat=io) tmpi + if (io == 0) then + x(1) = real(tmpi,wp) + n = 1 + end if return - endif + end if i = 0 is = 1 10 i = i+1 From b73a1bb3acfa09210b90e804afc8a4e6df311baf Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 10 Mar 2026 22:23:53 +0100 Subject: [PATCH 197/374] Change asynchronous BH execution --- src/basinhopping/algo.f90 | 23 ++++++++++++++--------- src/basinhopping/mc.f90 | 24 +++++++++++++++--------- 2 files changed, 29 insertions(+), 18 deletions(-) diff --git a/src/basinhopping/algo.f90 b/src/basinhopping/algo.f90 index c98dbebc..83ff8d68 100644 --- a/src/basinhopping/algo.f90 +++ b/src/basinhopping/algo.f90 @@ -264,18 +264,21 @@ subroutine parallel_basinhopping_core(env,mol,calc,structuredump) call bhp(K)%molc%get_zmat(.true.) if (K == 1) call bhp(K)%molc%print_zmat(stdout) if (K == 1) write (stdout,*) - call bhp(K)%molc%check_dihedrals() + call bhp(K)%molc%check_dihedrals() end select !$omp end critical end do - !$omp parallel do default(shared) private(K, mciter) schedule(dynamic) - do K = 1,T - do mciter = 1,bhp(K)%maxiter - !$omp critical - write (tag,'(a,i0,a)') 'Runner [',K-1,']: Basin-Hopping Epoch' - if (bhp(K)%maxiter > 1) call printiter3(trim(tag),mciter) - !$omp end critical + write (stdout,'(a)') '> Starting parallel Basin-Hopping execution' + write (stdout,*) + + do mciter = 1,bhp(1)%maxiter + !$omp critical + write (tag,'(a,i0,a)') 'Basin-Hopping Epoch' + if (bhp(1)%maxiter > 1) call printiter3(trim(tag),mciter) + !$omp end critical + !$omp parallel do default(shared) private(K, mciter) schedule(dynamic) + do K = 1,T call bhp(K)%newiter() call mc(calcp(K),mols(K),bhp(K),verbosity=1) @@ -286,8 +289,10 @@ subroutine parallel_basinhopping_core(env,mol,calc,structuredump) write (stdout,'(a,i0,a,i0,a)') 'Currently ',dumplist(K)%nall, & & ' structures saved (BH[',bhp(K)%id,'])!' end do + !$omp end parallel do + + !> Do things here (?) end do - !$omp end parallel do write (stdout,*) write (stdout,'(a)') 'Parallel BH runs done!' diff --git a/src/basinhopping/mc.f90 b/src/basinhopping/mc.f90 index 633f9445..c582202f 100644 --- a/src/basinhopping/mc.f90 +++ b/src/basinhopping/mc.f90 @@ -106,13 +106,10 @@ subroutine mc(calc,mol,bh,verbosity) dupe = .false. !>--- Take the step (mol --> tmpmol) - !!$omp critical call takestep(mol,calc,bh,tmpmol) - !!$omp end critical - + !>--- Quench it (tmpmol --> optmol) - call optimize_geometry(tmpmol,optmol,calc,etot,grd, & - & .false.,.false.,iostatus) + call mcquench(calc,bh,tmpmol,optmol,etot,grd,iostatus) !>--- Accept/reject if (iostatus == 0) then !> successfull optimization @@ -147,7 +144,7 @@ subroutine mc(calc,mol,bh,verbosity) if (printlvl > 1) write (stdout,'(a)',advance='no') & & ', but '//colorify('NOT SAVED','yellow')//' due to duplicate detection!' else if (printlvl == 1) then - write(stdout,'(a,1x,a,a,es17.8,a)') trim(tag),"Quench "//colorify('ACCEPTED','green'), & + write (stdout,'(a,1x,a,a,es17.8,a)') trim(tag),"Quench "//colorify('ACCEPTED','green'), & & ', NEW Markov E=',bh%emin,' Eh' end if @@ -205,7 +202,7 @@ subroutine mcheader(bh) write (stdout,'(a,3x)',advance='no') 'Starting Basin-Hopping Global Optimization' write (stdout,'(a,i3,a)',advance='no') '[Thread/ID ',bh%id,']' write (stdout,'(2x,"│")') - write (stdout,'(t8,a)') '╞'//repeat('═',63)//'╡' + write (stdout,'(t8,a)') '╞'//repeat('═',63)//'╡' write (stdout,'(t8,a,1x)',advance='no') '│' write (stdout,'(a,f20.10,a)',advance='no') 'Initial energy:',bh%emin,' Eh' @@ -251,6 +248,10 @@ subroutine mcstats(bh,accepted,discarded,broke) write (stdout,'(a,i3,a)',advance='no') '[Thread/ID ',bh%id,']' write (stdout,'(2x,a)') colorify("│","green") + write (stdout,'(t8,a,1x)',advance='no') colorify("│","green") + write (stdout,'(a,12x,f17.8,a)',advance='no') 'Latest Markov chain energy: ',bh%emin,' Eh' + write (stdout,'(2x,a)') colorify("│","green") + write (stdout,'(t8,a,1x)',advance='no') colorify("│","green") ratio = real(accepted,wp)/real(bh%maxsteps,wp) write (stdout,'(a,f6.2,a)',advance='no') 'MC acceptance ratio ',ratio*100.0_wp,' %, ' @@ -264,7 +265,7 @@ subroutine mcstats(bh,accepted,discarded,broke) ratio = real(accepted-discarded-broke,wp)/real(bh%maxsteps,wp) write (stdout,'(a,f6.2,a)',advance='no') 'TOTAL ACCEPT ratio ',ratio*100.0_wp,' %' write (stdout,'(2x,a)') colorify("│","green") - write (stdout,'(t8,a)') colorify('└'//repeat('─',63)//'┘',"green" ) + write (stdout,'(t8,a)') colorify('└'//repeat('─',63)//'┘',"green") end subroutine mcstats !=========================================================================================! @@ -387,18 +388,23 @@ end subroutine mcduplicate !========================================================================================! - subroutine mcquench(calc,bh,tmpmol,optmol,iostat) + subroutine mcquench(calc,bh,tmpmol,optmol,etot,grd,iostat) implicit none !> Input type(calcdata),intent(inout) :: calc !> potential settings type(bh_class),intent(inout) :: bh !> BH settings type(coord),intent(in) :: tmpmol !> molecular system + real(wp),intent(inout) :: etot + real(wp),intent(inout) :: grd(:,:) !> Output type(coord),intent(out) :: optmol !> molecular system output integer,intent(out) :: iostat iostat = 1 + call optimize_geometry(tmpmol,optmol,calc,etot,grd, & + & .false.,.false.,iostat) + end subroutine mcquench !=========================================================================================! From 66ab386e0ca7600d637f8530be3c769dad6611d6 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 11 Mar 2026 00:09:13 +0100 Subject: [PATCH 198/374] drawbox function in iomod --- src/iomod.F90 | 110 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 110 insertions(+) diff --git a/src/iomod.F90 b/src/iomod.F90 index 31d1c4d8..9c8a4034 100644 --- a/src/iomod.F90 +++ b/src/iomod.F90 @@ -864,6 +864,116 @@ function colorify(text,color) result(colored_text) end function colorify +!=========================================================================================! + + subroutine drawbox(prch,str,width,charset,padl,padr,ltab,procedual,color) + implicit none + integer,intent(in) :: prch + character(len=*),intent(in) :: str + integer,intent(in),optional :: charset + integer,intent(in),optional :: width,padl,padr,ltab + integer,intent(in),optional :: procedual + character(len=*),intent(in),optional :: color + + integer :: strlen,padd,wid,ltabb,procc,paddl,paddr + character(len=*),parameter :: set1 = '******' + character(len=*),parameter :: set2 = '+-+|++' + character(len=*),parameter :: set3 = '=== ==' + character(len=*),parameter :: set4 = '┌─┐│└┘' + character(len=*),parameter :: set5 = '┏━┓┃┗┛' + character(len=*),parameter :: set6 = '╔═╗║╚╝' + character(len=*),parameter :: set7 = '┍━┑│┕┙' + + integer :: ul,ho,ur,ve,ll,lr,d + character(len=:),allocatable :: boxchars + + ul = 1; ho = 2; ur = 3; ve = 4; ll = 5; lr = 6; d = 0 + if (present(charset)) then + if (charset >= 4) then + !> technically, utf-8 chars are wider ... + ul = 1; ho = 4; ur = 7; ve = 10; ll = 13; lr = 16; d = 2 + end if + select case (charset) + case (2) + boxchars = set2 + case (3) + boxchars = set3 + case (4) + boxchars = set4 + case (5) + boxchars = set5 + case (6) + boxchars = set6 + case (7) + boxchars = set7 + case default + boxchars = set1 + end select + else + boxchars = set1 + end if + + strlen = len(str) + if (present(padl)) then + paddl = max(padl,0) + else + paddl = 1 + end if + if (present(padr)) then + paddr = max(padr,0) + else + paddr = 1 + end if + if (present(width)) then + wid = width-2 + if (.not.present(padl)) then + paddl = (wid-strlen)/2 + end if + paddr = wid-strlen-paddl + else + wid = (strlen+paddl+paddr) + end if + + if (present(ltab)) then + ltabb = ltab + else + ltabb = 0 + end if + + procc = -1 + if (present(procedual)) procc = procedual + + if (procc == -1.or.procc == 0) then + write (prch,'(a)',advance='no') repeat(' ',ltabb) + if (present(color)) then + write (prch,'(a)') colorify(boxchars(ul:ul+d)//repeat(boxchars(ho:ho+d),wid)//boxchars(ur:ur+d),color) + else + write (prch,'(a)') boxchars(ul:ul+d)//repeat(boxchars(ho:ho+d),wid)//boxchars(ur:ur+d) + end if + end if + + if (procc == -1.or.procc == 1) then + write (prch,'(a)',advance="no") repeat(' ',ltabb) + if (present(color)) then + write (prch,'(a)') colorify(boxchars(ve:ve+d),color)// & + & repeat(' ',paddl)//str//repeat(' ',paddr)// & + & colorify(boxchars(ve:ve+d),color) + else + write (prch,'(a)') boxchars(ve:ve+d)//repeat(' ',paddl)//str//repeat(' ',paddr)//boxchars(ve:ve+d) + end if + end if + + if (procc == -1.or.procc == 2) then + write (prch,'(a)',advance='no') repeat(' ',ltabb) + if (present(color)) then + write (prch,'(a)') colorify(boxchars(ll:ll+d)//repeat(boxchars(ho:ho+d),wid)//boxchars(lr:lr+d),color) + else + write (prch,'(a)') boxchars(ll:ll+d)//repeat(boxchars(ho:ho+d),wid)//boxchars(lr:lr+d) + end if + end if + + end subroutine drawbox + !=========================================================================================! !=========================================================================================! !=========================================================================================! From 0319fda6f9ad13aca84413cde3bb1ed0777cdee0 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 11 Mar 2026 21:57:37 +0100 Subject: [PATCH 199/374] Allow "refine" settings for mc quenches --- src/basinhopping/algo.f90 | 9 ++++- src/basinhopping/class.f90 | 1 + src/basinhopping/mc.f90 | 75 +++++++++++++++++++++++++++++++------- 3 files changed, 71 insertions(+), 14 deletions(-) diff --git a/src/basinhopping/algo.f90 b/src/basinhopping/algo.f90 index 83ff8d68..a1338a70 100644 --- a/src/basinhopping/algo.f90 +++ b/src/basinhopping/algo.f90 @@ -185,6 +185,10 @@ subroutine single_basinhopping_core(env,mol,calc,structuredump) write (stdout,*) call bh%molc%check_dihedrals() end select + bh%id = 0 + if (allocated(env%refine_queue)) then + bh%refine_queue = env%refine_queue + end if nall = 0 do mciter = 1,bh%maxiter @@ -266,6 +270,9 @@ subroutine parallel_basinhopping_core(env,mol,calc,structuredump) if (K == 1) write (stdout,*) call bhp(K)%molc%check_dihedrals() end select + if (allocated(env%refine_queue)) then + bhp(K)%refine_queue = env%refine_queue + end if !$omp end critical end do @@ -290,7 +297,7 @@ subroutine parallel_basinhopping_core(env,mol,calc,structuredump) & ' structures saved (BH[',bhp(K)%id,'])!' end do !$omp end parallel do - + !> Do things here (?) end do diff --git a/src/basinhopping/class.f90 b/src/basinhopping/class.f90 index 1e0587e4..7d900b76 100644 --- a/src/basinhopping/class.f90 +++ b/src/basinhopping/class.f90 @@ -56,6 +56,7 @@ module bh_class_module integer :: maxsave = 100 !> maximum number of quenches saved real(wp),allocatable :: etarget !> target energy to be hit (useful in benchmarks) + integer,allocatable :: refine_queue(:) !>--- results/properties real(wp) :: emin = 0.0_wp !> current ref energy of markov chain diff --git a/src/basinhopping/mc.f90 b/src/basinhopping/mc.f90 index c582202f..5c33856f 100644 --- a/src/basinhopping/mc.f90 +++ b/src/basinhopping/mc.f90 @@ -62,9 +62,9 @@ subroutine mc(calc,mol,bh,verbosity) real(wp),allocatable :: grd(:,:) logical :: accept,dupe,broken integer :: printlvl,first,last,dynamicseed - character(len=10) :: tag + character(len=20) :: tag - write (tag,'("BH[",i0,"]>")') bh%id + write (tag,'("BH[Runner ",i0,"]>")') bh%id if (present(verbosity)) then printlvl = verbosity @@ -72,7 +72,23 @@ subroutine mc(calc,mol,bh,verbosity) printlvl = 0 end if -!>--- Add input energy to Markov chain +!>--- Add input energy to Markov chain after an initial quench + !$omp critical + allocate (grd(3,mol%nat),source=0.0_wp) + !$omp end critical + + if (printlvl > 0) then + write (stdout,'(a,1x,a)') trim(tag),'Performing '//colorify('initial quench','gold')//"." + end if + + tmpmol = mol + call mcquench(calc,bh,tmpmol,optmol,etot,grd,iostatus) + if(iostatus .ne. 0)then + write(stdout,'(a,1x,a)') trim(tag),colorify('** WARNING **','red')// & + & ' initial quench failed. Returning.' + return + endif + mol = optmol bh%emin = mol%energy call bh%add(mol) @@ -93,9 +109,6 @@ subroutine mc(calc,mol,bh,verbosity) call RNG_seed(bh%seed) end if - !$omp critical - allocate (grd(3,mol%nat),source=0.0_wp) - !$omp end critical !=======================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Input - type(calcdata),intent(inout) :: calc !> potential settings - type(bh_class),intent(inout) :: bh !> BH settings - type(coord),intent(in) :: tmpmol !> molecular system - real(wp),intent(inout) :: etot - real(wp),intent(inout) :: grd(:,:) + type(calcdata),intent(inout) :: calc !> potential settings + type(bh_class),intent(inout) :: bh !> BH settings + type(coord),intent(inout) :: tmpmol !> molecular system + real(wp),intent(inout) :: etot !> quenechd energy + real(wp),intent(inout) :: grd(:,:) !> gradient (temp storage) !> Output - type(coord),intent(out) :: optmol !> molecular system output - integer,intent(out) :: iostat + type(coord),intent(out) :: optmol !> molecular system output + integer,intent(out) :: iostat !> return status + integer :: nrefine,ii + real(wp) :: etmp iostat = 1 + !> initial proper quench (refine_lvl = 0) call optimize_geometry(tmpmol,optmol,calc,etot,grd, & & .false.,.false.,iostat) + !> Special Post-processing via refinement queue + if (allocated(bh%refine_queue).and.iostat == 0) then + + nrefine = size(bh%refine_queue,1) + + do ii = 1,nrefine + if (iostat .ne. 0) exit + calc%refine_stage = bh%refine_queue(ii) + select case (calc%refine_stage) + case (1) !> singlepoint (rerank) + call engrad(optmol,calc,etot,grd,iostat) + + case (2) !> singlepoint (add) + call engrad(optmol,calc,etmp,grd,iostat) + etot = etot+etmp + + case (3) !> geometry opt (requench) + tmpmol = optmol + call optimize_geometry(tmpmol,optmol,calc,etot,grd, & + & .false.,.false.,iostat) + + case default + continue + end select + end do + + !> RESET refine level for next quench + calc%refine_stage = 0 + + !> Important: last energy must be stored in the optmol + optmol%energy = etot + end if + end subroutine mcquench !=========================================================================================! From 3c26d41b3c5e70942820ae21546245ab60ce2458 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 12 Mar 2026 15:57:43 +0100 Subject: [PATCH 200/374] Test fortbridge subproject --- .gitmodules | 3 +++ subprojects/fortbridge | 1 + 2 files changed, 4 insertions(+) create mode 160000 subprojects/fortbridge diff --git a/.gitmodules b/.gitmodules index ed86f56b..ef954c7a 100644 --- a/.gitmodules +++ b/.gitmodules @@ -24,3 +24,6 @@ [submodule "subprojects/pvol"] path = subprojects/pvol url = https://github.com/neudecker-group/libpvol.git +[submodule "subprojects/fortbridge"] + path = subprojects/fortbridge + url = git@github.com:pprcht/fortbridge.git diff --git a/subprojects/fortbridge b/subprojects/fortbridge new file mode 160000 index 00000000..ff136169 --- /dev/null +++ b/subprojects/fortbridge @@ -0,0 +1 @@ +Subproject commit ff136169aa553677475dfb345dd5b6e299fd7686 From f31b550d413ab617c9c1c434a9605523c59527e0 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 12 Mar 2026 16:50:49 +0100 Subject: [PATCH 201/374] Preliminary work on mlip interfacing --- CMakeLists.txt | 8 ++++ config/CMakeLists.txt | 1 + config/modules/Findfortbridge.cmake | 25 ++++++++++++ src/calculator/CMakeLists.txt | 1 + src/calculator/meson.build | 1 + src/calculator/mlip_sc.F90 | 59 +++++++++++++++++++++++++++++ subprojects/fortbridge | 2 +- 7 files changed, 96 insertions(+), 1 deletion(-) create mode 100644 config/modules/Findfortbridge.cmake create mode 100644 src/calculator/mlip_sc.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index 199254e7..d4c2f3ad 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -119,6 +119,11 @@ if(NOT TARGET "lwoniom::lwoniom" AND WITH_LWONIOM) add_compile_definitions(WITH_LWONIOM) endif() +if(NOT TARGET "fortbridge:fortbridge" AND WITH_FORTBRIDGE) + find_package("fortbridge" REQUIRED) + add_compile_definitions(WITH_FORTBRIDGE) +endif() + # Sources: initialize program sources (prog) and library sources (srcs) empty set(prog) set(srcs) @@ -158,6 +163,7 @@ if(WITH_OBJECT AND NOT STATICBUILD) $<$:pvol::pvol> $<$:toml-f::toml-f> $<$:lwoniom::lwoniom> + $<$:fortbridge::fortbridge> $<$:OpenMP::OpenMP_Fortran> ) @@ -209,6 +215,7 @@ target_link_libraries( $<$:pvol::pvol> $<$:toml-f::toml-f> $<$:lwoniom::lwoniom> + $<$:fortbridge::fortbridge> $<$:-static> ) @@ -254,6 +261,7 @@ if (WITH_OBJECT AND NOT STATICBUILD) $<$:pvol::pvol> $<$:toml-f::toml-f> $<$:lwoniom::lwoniom> + $<$:fortbridge::fortbridge> ) set_target_properties( diff --git a/config/CMakeLists.txt b/config/CMakeLists.txt index 7800906a..87d85ddf 100644 --- a/config/CMakeLists.txt +++ b/config/CMakeLists.txt @@ -36,6 +36,7 @@ option(WITH_GFN0 "Enable support for GFN0-xTB" TRUE) option(WITH_GFNFF "Enable support for GFN-FF" TRUE) option(WITH_LIBPVOL "Enable support for LIBPVOL" TRUE) option(WITH_LWONIOM "Enable support for lwONIOM" TRUE) +option(WITH_FORTBRIDGE "Enable fortbridge interface" TRUE) option(WITH_TESTS "Enable unit tests" TRUE) option(STATICBUILD "Attempt to link everything statically" FALSE) diff --git a/config/modules/Findfortbridge.cmake b/config/modules/Findfortbridge.cmake new file mode 100644 index 00000000..d2a89d60 --- /dev/null +++ b/config/modules/Findfortbridge.cmake @@ -0,0 +1,25 @@ +set(_lib "fortbridge") +set(_pkg "FORTBRIDGE") +set(_url "https://github.com/pprcht/fortbridge") + +# Discovery method order can be overridden by the parent project, e.g.: +# set(FORTBRIDGE_FIND_METHOD "subproject" "cmake") +if(NOT DEFINED "${_pkg}_FIND_METHOD") + set("${_pkg}_FIND_METHOD" "cmake" "subproject" "fetch" "pkgconf") +endif() + +# Reuse whichever utils macro your main project already provides. +# Replace "crest-utils" with the actual name if yours differs. +include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") + +crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}") + +set(found FALSE) +if(TARGET "fortbridge::fortbridge") + set(found TRUE) +endif() +message(STATUS "Found fortbridge: ${found}") + +unset(_lib) +unset(_pkg) +unset(_url) diff --git a/src/calculator/CMakeLists.txt b/src/calculator/CMakeLists.txt index 5a81bf9e..730cf71e 100644 --- a/src/calculator/CMakeLists.txt +++ b/src/calculator/CMakeLists.txt @@ -44,6 +44,7 @@ list(APPEND srcs "${dir}/modelhessians.f90" "${dir}/approxg.f90" "${dir}/penalty.f90" + "${dir}/mlip_sc.F90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/calculator/meson.build b/src/calculator/meson.build index c659c3fb..ffd39a79 100644 --- a/src/calculator/meson.build +++ b/src/calculator/meson.build @@ -40,4 +40,5 @@ srcs += files( 'modelhessians.f90', 'approxg.f90', 'penalty.f90', + 'mlip_sc.F90', ) diff --git a/src/calculator/mlip_sc.F90 b/src/calculator/mlip_sc.F90 new file mode 100644 index 00000000..d497e7fa --- /dev/null +++ b/src/calculator/mlip_sc.F90 @@ -0,0 +1,59 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2026 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +!> module mlip_sc +!> A module containing routines for calling MLIPs though persistent python instances +!> enabled through the fortbridge submodule + +!=========================================================================================! +module mlip_sc + use iso_fortran_env,only:wp => real64 + use strucrd + use calc_type + use iomod,only:makedir,directory_exist,remove,command +#ifdef WITH_FORTBRIDGE + use fortbridge_client +#endif + implicit none + !>--- private module variables and parameters + private + + + public :: mlip_engrad + +!========================================================================================! +!========================================================================================! +contains !>--- Module routines start here +!========================================================================================! +!========================================================================================! + + subroutine mlip_engrad(mol,energy,gradient,iostatus) + type(coord),intent(in) :: mol + real(wp),intent(out) :: energy + real(wp),intent(out) :: gradient(3,mol%nat) + integer,intent(out) :: iostatus + + energy = 0.0_wp + gradient(:,:) = 0.0_wp + iostatus = 1 + + end subroutine mlip_engrad + +!========================================================================================! +end module mlip_sc diff --git a/subprojects/fortbridge b/subprojects/fortbridge index ff136169..97f1474a 160000 --- a/subprojects/fortbridge +++ b/subprojects/fortbridge @@ -1 +1 @@ -Subproject commit ff136169aa553677475dfb345dd5b6e299fd7686 +Subproject commit 97f1474a77a5b5fcedf3fc40e12bfa93eb6e25c3 From 051fbbb5979725ab0f41e4e6720ed3e7d2b141f2 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 12 Mar 2026 20:42:55 +0100 Subject: [PATCH 202/374] flesh out mlip_sc.f90 a bit --- src/calculator/mlip_sc.F90 | 115 +++++++++++++++++++++++++++++++++++-- src/sigterm.f90 | 12 ++++ 2 files changed, 122 insertions(+), 5 deletions(-) diff --git a/src/calculator/mlip_sc.F90 b/src/calculator/mlip_sc.F90 index d497e7fa..705cb7c4 100644 --- a/src/calculator/mlip_sc.F90 +++ b/src/calculator/mlip_sc.F90 @@ -23,10 +23,10 @@ !=========================================================================================! module mlip_sc - use iso_fortran_env,only:wp => real64 + use crest_parameters use strucrd use calc_type - use iomod,only:makedir,directory_exist,remove,command + use iomod #ifdef WITH_FORTBRIDGE use fortbridge_client #endif @@ -34,8 +34,26 @@ module mlip_sc !>--- private module variables and parameters private + character(len=*),parameter :: basebin = 'fortbridge-server' - public :: mlip_engrad + public :: mlip_settings + type :: mlip_settings + integer :: BASE_PORT = 54320 + integer :: TIMEOUT_SEC = 120 + character(len=:),allocatable :: backend + character(len=:),allocatable :: modelpath + character(len=:),allocatable :: modelsize + integer :: iid = 0 + end type mlip_settings + + public :: mlip_engrad_core,fortbridge_init,mlips_shutdown + + integer,parameter :: nopbc(3) = (/0,0,0/) + integer,parameter :: allpbc(3) = (/1,1,1/) + real(wp),parameter :: bigcell(3,3) = reshape( & + & (/10000.0_wp,0.0_wp,0.0_wp, & + & 0.0_wp,10000.0_wp,0.0_wp, & + & 0.0_wp,0.0_wp,10000.0_wp/), [3,3]) !========================================================================================! !========================================================================================! @@ -43,17 +61,104 @@ module mlip_sc !========================================================================================! !========================================================================================! - subroutine mlip_engrad(mol,energy,gradient,iostatus) + subroutine fortbridge_init(MSET,iid) + type(mlip_settings),intent(inout) :: MSET + integer,intent(in) :: iid + integer :: io,tmpport + character(len=256) :: cmd,cmd_0 +#ifdef WITH_FORTBRIDGE + if (.not.allocated(MSET%backend)) then + write (stdout,*) '** ERROR ** No model backend selected for MLIP' + write (stdout,*) + error stop + end if + if (allocated(MSET%modelpath)) then + if (.not.file_exists(MSET%modelpath)) then + write (stdout,*) '** ERROR ** model path allocated but can not find '//trim(MSET%modelpath) + write (stdout,*) + error stop + end if + end if + + call checkprog_silent(basebin,verbose=.false.,iostat=io) + if (io .ne. 0) then + write (stdout,*) '** ERROR ** can not find socket server for MLIPs '//basebin + write (stdout,*) ' Make sure you install it from the fortbridge subproject via pip' + write (stdout,*) + error stop + end if + + !> check for already running instances that may need reinitialization + !> or rather, shutdown first + if (MSET%iid .ne. 0) then + call mlip_finalize(MSET%iid,io) + end if + + tmpport = MSET%BASE_PORT+iid + select case (MSET%backend) + case default + write (cmd,'(a,1x,a,1x,i0,2(1x,a,1x,a))') basebin,'--port',tmpport,'--backend', & + & trim(MSET%backend),'--model',trim(MSET%modelpath) + end select + + call mlip_init(iid,tmpport,trim(cmd),MSET%TIMEOUT_SEC,io) + if (io /= MLIP_OK) then + write (stdout,*) '** ERROR ** failed to initialize MLIP server' + write (stdout,*) + error stop + end if + !> Test it + call mlip_ping(iid,io) + if (io /= MLIP_OK) then + write (stdout,*) '** ERROR ** failed to ping MLIP server' + write (stdout,*) + error stop + end if + + MSET%iid = iid + +#else /* WITH_FORTBRIDGE */ + write (stdout,*) 'Error: Compiled without fortbridge support!' + write (stdout,*) 'Use -DWITH_FORTBRIDGE=true in the setup to enable this function' + error stop +#endif + end subroutine fortbridge_init + + subroutine mlip_engrad_core(mol,MSET,energy,gradient,iostatus) type(coord),intent(in) :: mol + type(mlip_settings) :: MSET real(wp),intent(out) :: energy real(wp),intent(out) :: gradient(3,mol%nat) integer,intent(out) :: iostatus + real(wp) :: stress(3,3) + energy = 0.0_wp gradient(:,:) = 0.0_wp iostatus = 1 - end subroutine mlip_engrad + if (allocated(mol%lat)) then + call mlip_compute(MSET%iid,mol%nat,mol%at,mol%xyz*autoaa,mol%lat,allpbc,0, & + & energy,gradient,stress,iostatus) + else + call mlip_compute(MSET%iid,mol%nat,mol%at,mol%xyz*autoaa,bigcell,nopbc,0, & + & energy,gradient,stress,iostatus) + end if + + !> CREST always works with atomic units, convert from eV and Angstroem: + energy = energy/autoev + gradient(:,:) = gradient(:,:)*(1.0_wp/(autoev*aatoau)) + + end subroutine mlip_engrad_core + +!========================================================================================! + + subroutine mlips_shutdown() + integer :: io +#ifdef WITH_FORTBRIDGE + call mlip_finalize_all(io) +#endif + end subroutine mlips_shutdown !========================================================================================! end module mlip_sc diff --git a/src/sigterm.f90 b/src/sigterm.f90 index e1d3a794..95ca5f2d 100644 --- a/src/sigterm.f90 +++ b/src/sigterm.f90 @@ -23,6 +23,9 @@ subroutine creststop(io) implicit none integer,intent(in) :: io + + call graceful_shutdowns() + select case(io) case (status_normal) write (stdout,*) 'CREST terminated normally.' @@ -114,3 +117,12 @@ subroutine initsignal() call signal(69,wSIGINT) end subroutine initsignal + +!=============================================================! +subroutine graceful_shutdowns() + use mlip_sc + implicit none + call mlips_shutdown() +end subroutine graceful_shutdowns + + From 6d2468b15609a4fe649fd7db2fedfd43b328b777 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 12 Mar 2026 22:05:29 +0100 Subject: [PATCH 203/374] First working call of CREST to MACE-OFF (singlepoint and optimization working) --- src/calculator/api_engrad.f90 | 65 +++++++++++++++++++--- src/calculator/calc_type.f90 | 14 +++-- src/calculator/calculator.F90 | 2 + src/calculator/mlip_sc.F90 | 99 ++++++++++++++++++++++------------ src/parsing/parse_calcdata.f90 | 13 ++++- 5 files changed, 147 insertions(+), 46 deletions(-) diff --git a/src/calculator/api_engrad.f90 b/src/calculator/api_engrad.f90 index 0e9d6d83..d0f54d3f 100644 --- a/src/calculator/api_engrad.f90 +++ b/src/calculator/api_engrad.f90 @@ -28,6 +28,7 @@ module api_engrad use strucrd use calc_type use iomod,only:makedir,directory_exist,remove,dump_array_to_tmp + use omp_lib !> API modules use api_helpers use tblite_api @@ -37,6 +38,7 @@ module api_engrad use lj use approxg_module use penalty_module + use mlip_sc implicit none !>--- private module variables and parameters private @@ -48,6 +50,7 @@ module api_engrad public :: lj_engrad !> RE-EXPORT public :: modelhessian_engrad public :: rmsd_engrad + public :: mlip_engrad !=========================================================================================! !=========================================================================================! @@ -436,23 +439,23 @@ subroutine rmsd_engrad(mol,calc,energy,grad,iostatus) iostatus = 0 pr = .false. !>--- setup system call information - - if (.not.associated(calc%penalty%biaslist))then - if(allocated(calc%penalty%biasfile))then + + if (.not.associated(calc%penalty%biaslist)) then + if (allocated(calc%penalty%biasfile)) then !$omp critical call rdensemble(calc%penalty%biasfile,nall,calc%penalty%biastmp) calc%penalty%biaslist => calc%penalty%biastmp !$omp end critical else return - endif - endif - !$omp critical + end if + end if + !$omp critical !>--- printout handling call api_handle_output(calc,'rmsd_penalty.out',mol,pr) !>--- populate parameters if (.not.allocated(calc%penalty%gradtmp)) then - allocate(calc%penalty%gradtmp(3,mol%nat), source=0.0_wp) + allocate (calc%penalty%gradtmp(3,mol%nat),source=0.0_wp) call calc%penalty%ccache%allocate(mol%nat) else calc%penalty%gradtmp(:,:) = 0.0_wp @@ -477,6 +480,54 @@ subroutine rmsd_engrad(mol,calc,energy,grad,iostatus) return end subroutine rmsd_engrad +!========================================================================================! + + subroutine mlip_engrad(mol,calc,energy,grad,iostatus) +!************************************************************************** +!* MLIP singlepoint through persistent python socket +!************************************************************************** + implicit none + type(coord) :: mol + type(calculation_settings),target :: calc + + real(wp),intent(inout) :: energy + real(wp),intent(inout) :: grad(3,mol%nat) + integer,intent(out) :: iostatus + + logical :: loadnew,pr + integer :: i,j,k,l,ich,och,io,iid + logical :: ex + iostatus = 0 + pr = .false. + !$omp critical +!>--- setup system call information + if (calc%MPAR%iid == 0) then + iid = OMP_GET_THREAD_NUM()+1 + call fortbridge_init(calc%MPAR,iid) + end if +!>--- printout handling + call api_handle_output(calc,'mlip.out',mol,pr) +!>--- populate parameters + !$omp end critical + if (iostatus /= 0) return + +!>--- do the engrad call + call initsignal() + call mlip_engrad_core(mol,calc%MPAR,energy,grad,iostatus) + if (iostatus /= 0) return + +!>--- printout + if (pr) then + !> the libpvol_sp call includes the printout within libpvol-lib + if (.not.calc%prstdout) & + & call api_print_e_grd(pr,calc%prch,mol,energy,grad) + end if + +!>--- postprocessing, getting other data + + return + end subroutine mlip_engrad + !========================================================================================! !########################################################################################! !========================================================================================! diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index d1e0d258..bd02e031 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -32,6 +32,7 @@ module calc_type use hessian_reconstruct use approxg_module, only: approxg_params use penalty_module, only: penalty_params + use mlip_sc, only: mlip_params implicit none character(len=*),public,parameter :: sep = '/' @@ -54,10 +55,11 @@ module calc_type integer :: lj = 11 integer :: approxg = 12 integer :: penalty = 13 + integer :: mlip = 14 end type enum_jobtype type(enum_jobtype), parameter,public :: jobtype = enum_jobtype() - character(len=45),parameter,private :: jobdescription(14) = [ & + character(len=45),parameter,private :: jobdescription(15) = [ & & 'Unknown calculation type ', & & 'xTB calculation via external binary ', & & 'Generic script execution ', & @@ -71,7 +73,8 @@ module calc_type & 'external pressure calculation via libpvol ', & & 'Lennard-Jones potential calculation ', & & 'Approximate free energy computation ', & - & 'Empirical penalty function ' ] + & 'Empirical penalty function ', & + & 'MLIP via persistent python socket '] !&> !=========================================================================================! @@ -188,9 +191,12 @@ module calc_type integer :: ONIOM_highlowroot = 0 integer :: ONIOM_id = 0 - !> ORCA job template +!>--- ORCA job template type(orca_input) :: ORCA +!>--- MLIP settings + type(mlip_params) :: MPAR + !>--- Type procedures contains procedure :: deallocate => calculation_settings_deallocate @@ -1106,6 +1112,8 @@ subroutine calculation_settings_copy(self,src) self%ag = src%ag self%penalty = src%penalty + + self%MPAR = src%MPAR !&< return end subroutine calculation_settings_copy diff --git a/src/calculator/calculator.F90 b/src/calculator/calculator.F90 index 376b8b4f..498f8293 100644 --- a/src/calculator/calculator.F90 +++ b/src/calculator/calculator.F90 @@ -395,6 +395,8 @@ subroutine potential_core(molptr,calc,id,iostatus) case (jobtype%penalty) call rmsd_engrad(molptr,calc%calcs(id),calc%etmp(id),calc%grdtmp(:,1:pnat,id),iostatus) + case (jobtype%mlip) + call mlip_engrad(molptr,calc%calcs(id),calc%etmp(id),calc%grdtmp(:,1:pnat,id),iostatus) case default calc%etmp(id) = 0.0_wp calc%grdtmp(:,:,id) = 0.0_wp diff --git a/src/calculator/mlip_sc.F90 b/src/calculator/mlip_sc.F90 index 705cb7c4..da54d26a 100644 --- a/src/calculator/mlip_sc.F90 +++ b/src/calculator/mlip_sc.F90 @@ -25,7 +25,6 @@ module mlip_sc use crest_parameters use strucrd - use calc_type use iomod #ifdef WITH_FORTBRIDGE use fortbridge_client @@ -36,15 +35,15 @@ module mlip_sc character(len=*),parameter :: basebin = 'fortbridge-server' - public :: mlip_settings - type :: mlip_settings + public :: mlip_params + type :: mlip_params integer :: BASE_PORT = 54320 integer :: TIMEOUT_SEC = 120 character(len=:),allocatable :: backend character(len=:),allocatable :: modelpath character(len=:),allocatable :: modelsize integer :: iid = 0 - end type mlip_settings + end type mlip_params public :: mlip_engrad_core,fortbridge_init,mlips_shutdown @@ -55,78 +54,107 @@ module mlip_sc & 0.0_wp,10000.0_wp,0.0_wp, & & 0.0_wp,0.0_wp,10000.0_wp/), [3,3]) + external creststop !========================================================================================! !========================================================================================! contains !>--- Module routines start here !========================================================================================! !========================================================================================! - subroutine fortbridge_init(MSET,iid) - type(mlip_settings),intent(inout) :: MSET + subroutine fortbridge_init(MPAR,iid) + type(mlip_params),intent(inout) :: MPAR integer,intent(in) :: iid integer :: io,tmpport - character(len=256) :: cmd,cmd_0 + character(len=256) :: cmd,cmd_0,cmd_1 #ifdef WITH_FORTBRIDGE - if (.not.allocated(MSET%backend)) then + if (.not.allocated(MPAR%backend)) then + write (stdout,*) write (stdout,*) '** ERROR ** No model backend selected for MLIP' write (stdout,*) - error stop - end if - if (allocated(MSET%modelpath)) then - if (.not.file_exists(MSET%modelpath)) then - write (stdout,*) '** ERROR ** model path allocated but can not find '//trim(MSET%modelpath) - write (stdout,*) - error stop - end if + call creststop(20) end if call checkprog_silent(basebin,verbose=.false.,iostat=io) if (io .ne. 0) then + write (stdout,*) write (stdout,*) '** ERROR ** can not find socket server for MLIPs '//basebin write (stdout,*) ' Make sure you install it from the fortbridge subproject via pip' write (stdout,*) - error stop + call creststop(20) end if !> check for already running instances that may need reinitialization !> or rather, shutdown first - if (MSET%iid .ne. 0) then - call mlip_finalize(MSET%iid,io) + if (MPAR%iid .ne. 0) then + call mlip_finalize(MPAR%iid,io) end if - tmpport = MSET%BASE_PORT+iid - select case (MSET%backend) + !> options prepping + tmpport = MPAR%BASE_PORT+iid + write(cmd_1,'("--dtype float64")') + + select case (MPAR%backend) + case ('mace_off','mace_mp') + + if (allocated(MPAR%modelpath)) then + if (.not.file_exists(MPAR%modelpath)) then + write (stdout,*) + write (stdout,*) '** ERROR ** model path allocated but can not find '//trim(MPAR%modelpath) + write (stdout,*) + call creststop(20) + end if + write (cmd,'(a,1x,a,1x,i0,2(1x,a,1x,a),1x,a)') basebin,'--port',tmpport,'--backend', & + & 'mace','--model',trim(MPAR%modelpath),trim(cmd_1) + else + cmd_0 = '' + if (allocated(MPAR%modelsize)) write (cmd_0,'(a,1x,a)') '--mace_model',trim(MPAR%modelsize) + write (cmd,'(a,1x,a,1x,i0,2(1x,a,1x,a),1x,a)') basebin,'--port',tmpport,'--backend', & + & trim(MPAR%backend),trim(cmd_0),'',trim(cmd_1) + end if + case default - write (cmd,'(a,1x,a,1x,i0,2(1x,a,1x,a))') basebin,'--port',tmpport,'--backend', & - & trim(MSET%backend),'--model',trim(MSET%modelpath) + + if (allocated(MPAR%modelpath)) then + if (.not.file_exists(MPAR%modelpath)) then + write (stdout,*) + write (stdout,*) '** ERROR ** model path allocated but can not find '//trim(MPAR%modelpath) + write (stdout,*) + call creststop(20) + end if + end if + + write (cmd,'(a,1x,a,1x,i0,2(1x,a,1x,a),1x,a)') basebin,'--port',tmpport,'--backend', & + & trim(MPAR%backend),'--model',trim(MPAR%modelpath),trim(cmd_1) end select - call mlip_init(iid,tmpport,trim(cmd),MSET%TIMEOUT_SEC,io) + call mlip_init(iid,tmpport,trim(cmd)//' 2>/dev/null',MPAR%TIMEOUT_SEC,io) if (io /= MLIP_OK) then + write (stdout,*) write (stdout,*) '** ERROR ** failed to initialize MLIP server' write (stdout,*) - error stop + call creststop(1) end if !> Test it call mlip_ping(iid,io) if (io /= MLIP_OK) then - write (stdout,*) '** ERROR ** failed to ping MLIP server' write (stdout,*) - error stop + write (stdout,*) '** ERROR ** failed to ping MLIP server' + call creststop(1) end if - MSET%iid = iid + MPAR%iid = iid #else /* WITH_FORTBRIDGE */ write (stdout,*) 'Error: Compiled without fortbridge support!' write (stdout,*) 'Use -DWITH_FORTBRIDGE=true in the setup to enable this function' - error stop + write (stdout,*) + call creststop(20) #endif end subroutine fortbridge_init - subroutine mlip_engrad_core(mol,MSET,energy,gradient,iostatus) + subroutine mlip_engrad_core(mol,MPAR,energy,gradient,iostatus) type(coord),intent(in) :: mol - type(mlip_settings) :: MSET + type(mlip_params) :: MPAR real(wp),intent(out) :: energy real(wp),intent(out) :: gradient(3,mol%nat) integer,intent(out) :: iostatus @@ -137,18 +165,19 @@ subroutine mlip_engrad_core(mol,MSET,energy,gradient,iostatus) gradient(:,:) = 0.0_wp iostatus = 1 +#ifdef WITH_FORTBRIDGE if (allocated(mol%lat)) then - call mlip_compute(MSET%iid,mol%nat,mol%at,mol%xyz*autoaa,mol%lat,allpbc,0, & + call mlip_compute(MPAR%iid,mol%nat,mol%at,mol%xyz*autoaa,mol%lat,allpbc,0, & & energy,gradient,stress,iostatus) else - call mlip_compute(MSET%iid,mol%nat,mol%at,mol%xyz*autoaa,bigcell,nopbc,0, & + call mlip_compute(MPAR%iid,mol%nat,mol%at,mol%xyz*autoaa,bigcell,nopbc,0, & & energy,gradient,stress,iostatus) end if !> CREST always works with atomic units, convert from eV and Angstroem: energy = energy/autoev - gradient(:,:) = gradient(:,:)*(1.0_wp/(autoev*aatoau)) - + gradient(:,:) = -gradient(:,:)*(1.0_wp/(autoev*aatoau)) +#endif end subroutine mlip_engrad_core !========================================================================================! diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 566d9d3d..eba352cf 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -267,6 +267,8 @@ subroutine parse_setting_auto(env,job,kv,rd) case ('rmsdbias','penalty') job%id = jobtype%penalty nullify(job%penalty%biaslist) + case ('mlip','fortbridge') + job%id = jobtype%mlip case default job%id = jobtype%unknown !>--- keyword was recognized, but invalid argument supplied @@ -339,12 +341,21 @@ subroutine parse_setting_auto(env,job,kv,rd) !>--- keyword was recognized, but invalid argument supplied write (stdout,fmtura) kv%value_c call creststop(status_config) - end select + case ('tblite_param') job%tbliteparam = kv%value_c job%tblitelvl = xtblvl%param + case ('mlip_backend') + job%MPAR%backend = kv%value_c + + case ('mlip_modelpath') + job%MPAR%modelpath = kv%value_c + + case ('mlip_modelsize') + job%MPAR%modelsize = kv%value_c + case ('orca_cmd') job%id = jobtype%orca job%ORCA%cmd = kv%value_c From a83550db733951669acfb33eedbc2ce18e6c05d9 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 13 Mar 2026 09:37:14 +0100 Subject: [PATCH 204/374] rename fortbridge -> fmlip_relay --- .gitmodules | 6 ++-- CMakeLists.txt | 12 ++++---- config/CMakeLists.txt | 2 +- ...fortbridge.cmake => Findfmlip_relay.cmake} | 14 +++++----- src/calculator/api_engrad.f90 | 2 +- src/calculator/mlip_sc.F90 | 28 +++++++++---------- src/parsing/parse_calcdata.f90 | 2 +- subprojects/.gitignore | 1 + subprojects/fmlip-relay | 1 + subprojects/fortbridge | 1 - 10 files changed, 35 insertions(+), 34 deletions(-) rename config/modules/{Findfortbridge.cmake => Findfmlip_relay.cmake} (60%) create mode 160000 subprojects/fmlip-relay delete mode 160000 subprojects/fortbridge diff --git a/.gitmodules b/.gitmodules index ef954c7a..1a8c92d3 100644 --- a/.gitmodules +++ b/.gitmodules @@ -24,6 +24,6 @@ [submodule "subprojects/pvol"] path = subprojects/pvol url = https://github.com/neudecker-group/libpvol.git -[submodule "subprojects/fortbridge"] - path = subprojects/fortbridge - url = git@github.com:pprcht/fortbridge.git +[submodule "subprojects/fmlip-relay"] + path = subprojects/fmlip-relay + url = git@github.com:pprcht/fmlip-relay.git diff --git a/CMakeLists.txt b/CMakeLists.txt index d4c2f3ad..e191339e 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -119,9 +119,9 @@ if(NOT TARGET "lwoniom::lwoniom" AND WITH_LWONIOM) add_compile_definitions(WITH_LWONIOM) endif() -if(NOT TARGET "fortbridge:fortbridge" AND WITH_FORTBRIDGE) - find_package("fortbridge" REQUIRED) - add_compile_definitions(WITH_FORTBRIDGE) +if(NOT TARGET "fmlip_relay:fmlip_relay" AND WITH_FMLIP_RELAY) + find_package("fmlip_relay" REQUIRED) + add_compile_definitions(WITH_FMLIP_RELAY) endif() # Sources: initialize program sources (prog) and library sources (srcs) empty @@ -163,7 +163,7 @@ if(WITH_OBJECT AND NOT STATICBUILD) $<$:pvol::pvol> $<$:toml-f::toml-f> $<$:lwoniom::lwoniom> - $<$:fortbridge::fortbridge> + $<$:fmlip_relay::fmlip_relay> $<$:OpenMP::OpenMP_Fortran> ) @@ -215,7 +215,7 @@ target_link_libraries( $<$:pvol::pvol> $<$:toml-f::toml-f> $<$:lwoniom::lwoniom> - $<$:fortbridge::fortbridge> + $<$:fmlip_relay::fmlip_relay> $<$:-static> ) @@ -261,7 +261,7 @@ if (WITH_OBJECT AND NOT STATICBUILD) $<$:pvol::pvol> $<$:toml-f::toml-f> $<$:lwoniom::lwoniom> - $<$:fortbridge::fortbridge> + $<$:fmlip_relay::fmlip_relay> ) set_target_properties( diff --git a/config/CMakeLists.txt b/config/CMakeLists.txt index 87d85ddf..f66566a4 100644 --- a/config/CMakeLists.txt +++ b/config/CMakeLists.txt @@ -36,7 +36,7 @@ option(WITH_GFN0 "Enable support for GFN0-xTB" TRUE) option(WITH_GFNFF "Enable support for GFN-FF" TRUE) option(WITH_LIBPVOL "Enable support for LIBPVOL" TRUE) option(WITH_LWONIOM "Enable support for lwONIOM" TRUE) -option(WITH_FORTBRIDGE "Enable fortbridge interface" TRUE) +option(WITH_FMLIP_RELAY "Enable fmlip-relay interface" TRUE) option(WITH_TESTS "Enable unit tests" TRUE) option(STATICBUILD "Attempt to link everything statically" FALSE) diff --git a/config/modules/Findfortbridge.cmake b/config/modules/Findfmlip_relay.cmake similarity index 60% rename from config/modules/Findfortbridge.cmake rename to config/modules/Findfmlip_relay.cmake index d2a89d60..84d781ec 100644 --- a/config/modules/Findfortbridge.cmake +++ b/config/modules/Findfmlip_relay.cmake @@ -1,11 +1,11 @@ -set(_lib "fortbridge") -set(_pkg "FORTBRIDGE") -set(_url "https://github.com/pprcht/fortbridge") +set(_lib "fmlip_relay") +set(_pkg "FMLIP_RELAY") +set(_url "https://github.com/pprcht/fmlip-relay") # Discovery method order can be overridden by the parent project, e.g.: -# set(FORTBRIDGE_FIND_METHOD "subproject" "cmake") +# set(FMLIP_RELAY_FIND_METHOD "subproject" "cmake") if(NOT DEFINED "${_pkg}_FIND_METHOD") - set("${_pkg}_FIND_METHOD" "cmake" "subproject" "fetch" "pkgconf") + set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") endif() # Reuse whichever utils macro your main project already provides. @@ -15,10 +15,10 @@ include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}") set(found FALSE) -if(TARGET "fortbridge::fortbridge") +if(TARGET "fmlip_relay::fmlip_relay") set(found TRUE) endif() -message(STATUS "Found fortbridge: ${found}") +message(STATUS "Found fmlip-relay: ${found}") unset(_lib) unset(_pkg) diff --git a/src/calculator/api_engrad.f90 b/src/calculator/api_engrad.f90 index d0f54d3f..1137db53 100644 --- a/src/calculator/api_engrad.f90 +++ b/src/calculator/api_engrad.f90 @@ -503,7 +503,7 @@ subroutine mlip_engrad(mol,calc,energy,grad,iostatus) !>--- setup system call information if (calc%MPAR%iid == 0) then iid = OMP_GET_THREAD_NUM()+1 - call fortbridge_init(calc%MPAR,iid) + call fmlip_relay_init(calc%MPAR,iid) end if !>--- printout handling call api_handle_output(calc,'mlip.out',mol,pr) diff --git a/src/calculator/mlip_sc.F90 b/src/calculator/mlip_sc.F90 index da54d26a..65ee0ddf 100644 --- a/src/calculator/mlip_sc.F90 +++ b/src/calculator/mlip_sc.F90 @@ -19,21 +19,21 @@ !> module mlip_sc !> A module containing routines for calling MLIPs though persistent python instances -!> enabled through the fortbridge submodule +!> enabled through the fmlip_relay submodule !=========================================================================================! module mlip_sc use crest_parameters use strucrd use iomod -#ifdef WITH_FORTBRIDGE - use fortbridge_client +#ifdef WITH_FMLIP_RELAY + use fmlip_relay_client #endif implicit none !>--- private module variables and parameters private - character(len=*),parameter :: basebin = 'fortbridge-server' + character(len=*),parameter :: basebin = 'fmlip-relay-server' public :: mlip_params type :: mlip_params @@ -45,7 +45,7 @@ module mlip_sc integer :: iid = 0 end type mlip_params - public :: mlip_engrad_core,fortbridge_init,mlips_shutdown + public :: mlip_engrad_core,fmlip_relay_init,mlips_shutdown integer,parameter :: nopbc(3) = (/0,0,0/) integer,parameter :: allpbc(3) = (/1,1,1/) @@ -61,12 +61,12 @@ module mlip_sc !========================================================================================! !========================================================================================! - subroutine fortbridge_init(MPAR,iid) + subroutine fmlip_relay_init(MPAR,iid) type(mlip_params),intent(inout) :: MPAR integer,intent(in) :: iid integer :: io,tmpport character(len=256) :: cmd,cmd_0,cmd_1 -#ifdef WITH_FORTBRIDGE +#ifdef WITH_FMLIP_RELAY if (.not.allocated(MPAR%backend)) then write (stdout,*) write (stdout,*) '** ERROR ** No model backend selected for MLIP' @@ -78,7 +78,7 @@ subroutine fortbridge_init(MPAR,iid) if (io .ne. 0) then write (stdout,*) write (stdout,*) '** ERROR ** can not find socket server for MLIPs '//basebin - write (stdout,*) ' Make sure you install it from the fortbridge subproject via pip' + write (stdout,*) ' Make sure you install it from the fmlip_relay subproject via pip' write (stdout,*) call creststop(20) end if @@ -144,13 +144,13 @@ subroutine fortbridge_init(MPAR,iid) MPAR%iid = iid -#else /* WITH_FORTBRIDGE */ - write (stdout,*) 'Error: Compiled without fortbridge support!' - write (stdout,*) 'Use -DWITH_FORTBRIDGE=true in the setup to enable this function' +#else /* WITH_FMLIP_RELAY */ + write (stdout,*) 'Error: Compiled without fmlip-relay support!' + write (stdout,*) 'Use -DWITH_FMLIP_RELAY=true in the setup to enable this function' write (stdout,*) call creststop(20) #endif - end subroutine fortbridge_init + end subroutine fmlip_relay_init subroutine mlip_engrad_core(mol,MPAR,energy,gradient,iostatus) type(coord),intent(in) :: mol @@ -165,7 +165,7 @@ subroutine mlip_engrad_core(mol,MPAR,energy,gradient,iostatus) gradient(:,:) = 0.0_wp iostatus = 1 -#ifdef WITH_FORTBRIDGE +#ifdef WITH_FMLIP_RELAY if (allocated(mol%lat)) then call mlip_compute(MPAR%iid,mol%nat,mol%at,mol%xyz*autoaa,mol%lat,allpbc,0, & & energy,gradient,stress,iostatus) @@ -184,7 +184,7 @@ end subroutine mlip_engrad_core subroutine mlips_shutdown() integer :: io -#ifdef WITH_FORTBRIDGE +#ifdef WITH_FMLIP_RELAY call mlip_finalize_all(io) #endif end subroutine mlips_shutdown diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index eba352cf..c5c4bfd3 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -267,7 +267,7 @@ subroutine parse_setting_auto(env,job,kv,rd) case ('rmsdbias','penalty') job%id = jobtype%penalty nullify(job%penalty%biaslist) - case ('mlip','fortbridge') + case ('mlip','fmlip_relay') job%id = jobtype%mlip case default job%id = jobtype%unknown diff --git a/subprojects/.gitignore b/subprojects/.gitignore index d9498d5d..8e86ddce 100644 --- a/subprojects/.gitignore +++ b/subprojects/.gitignore @@ -15,6 +15,7 @@ lammps* !tblite !test-drive !pvol +!fmlip-relay !packagefiles !packagefiles/tblite diff --git a/subprojects/fmlip-relay b/subprojects/fmlip-relay new file mode 160000 index 00000000..ed8f60f0 --- /dev/null +++ b/subprojects/fmlip-relay @@ -0,0 +1 @@ +Subproject commit ed8f60f06d2ec92adcda5c3cdf5e97a5a54523da diff --git a/subprojects/fortbridge b/subprojects/fortbridge deleted file mode 160000 index 97f1474a..00000000 --- a/subprojects/fortbridge +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 97f1474a77a5b5fcedf3fc40e12bfa93eb6e25c3 From 1c0a9633b7443545ca3425e4633b9d7009077378 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 13 Mar 2026 10:25:51 +0100 Subject: [PATCH 205/374] second try at renaming subproject --- .gitmodules | 4 ++-- config/modules/Findfmlip_relay.cmake | 2 +- src/calculator/mlip_sc.F90 | 4 ++-- subprojects/.gitignore | 2 +- subprojects/fmlip-relay | 1 - subprojects/fmlip_relay | 1 + 6 files changed, 7 insertions(+), 7 deletions(-) delete mode 160000 subprojects/fmlip-relay create mode 160000 subprojects/fmlip_relay diff --git a/.gitmodules b/.gitmodules index 1a8c92d3..737349d7 100644 --- a/.gitmodules +++ b/.gitmodules @@ -24,6 +24,6 @@ [submodule "subprojects/pvol"] path = subprojects/pvol url = https://github.com/neudecker-group/libpvol.git -[submodule "subprojects/fmlip-relay"] - path = subprojects/fmlip-relay +[submodule "subprojects/fmlip_relay"] + path = subprojects/fmlip_relay url = git@github.com:pprcht/fmlip-relay.git diff --git a/config/modules/Findfmlip_relay.cmake b/config/modules/Findfmlip_relay.cmake index 84d781ec..7a223640 100644 --- a/config/modules/Findfmlip_relay.cmake +++ b/config/modules/Findfmlip_relay.cmake @@ -18,7 +18,7 @@ set(found FALSE) if(TARGET "fmlip_relay::fmlip_relay") set(found TRUE) endif() -message(STATUS "Found fmlip-relay: ${found}") +message(STATUS "Found fmlip_relay: ${found}") unset(_lib) unset(_pkg) diff --git a/src/calculator/mlip_sc.F90 b/src/calculator/mlip_sc.F90 index 65ee0ddf..71d60292 100644 --- a/src/calculator/mlip_sc.F90 +++ b/src/calculator/mlip_sc.F90 @@ -51,8 +51,8 @@ module mlip_sc integer,parameter :: allpbc(3) = (/1,1,1/) real(wp),parameter :: bigcell(3,3) = reshape( & & (/10000.0_wp,0.0_wp,0.0_wp, & - & 0.0_wp,10000.0_wp,0.0_wp, & - & 0.0_wp,0.0_wp,10000.0_wp/), [3,3]) + & 0.0_wp,10000.0_wp,0.0_wp, & + & 0.0_wp,0.0_wp,10000.0_wp/), [3,3]) external creststop !========================================================================================! diff --git a/subprojects/.gitignore b/subprojects/.gitignore index 8e86ddce..5bf42fcb 100644 --- a/subprojects/.gitignore +++ b/subprojects/.gitignore @@ -15,7 +15,7 @@ lammps* !tblite !test-drive !pvol -!fmlip-relay +!fmlip_relay !packagefiles !packagefiles/tblite diff --git a/subprojects/fmlip-relay b/subprojects/fmlip-relay deleted file mode 160000 index ed8f60f0..00000000 --- a/subprojects/fmlip-relay +++ /dev/null @@ -1 +0,0 @@ -Subproject commit ed8f60f06d2ec92adcda5c3cdf5e97a5a54523da diff --git a/subprojects/fmlip_relay b/subprojects/fmlip_relay new file mode 160000 index 00000000..f0e5976a --- /dev/null +++ b/subprojects/fmlip_relay @@ -0,0 +1 @@ +Subproject commit f0e5976aea77f69a7705dfa10466edb15d6fa251 From ecf12df0ce91d294289869ab1045a74d48101361 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 13 Mar 2026 11:21:59 +0100 Subject: [PATCH 206/374] Add dftd4 as git submodule (tblite requirement) --- .gitmodules | 3 +++ CMakeLists.txt | 1 + config/modules/Finddftd4.cmake | 43 +++++++++++++++++++++++++++++++++ config/modules/Findtblite.cmake | 2 +- subprojects/.gitignore | 3 ++- subprojects/dftd4 | 1 + subprojects/dftd4.wrap | 4 +++ 7 files changed, 55 insertions(+), 2 deletions(-) create mode 100644 config/modules/Finddftd4.cmake create mode 160000 subprojects/dftd4 create mode 100644 subprojects/dftd4.wrap diff --git a/.gitmodules b/.gitmodules index 737349d7..31aff439 100644 --- a/.gitmodules +++ b/.gitmodules @@ -27,3 +27,6 @@ [submodule "subprojects/fmlip_relay"] path = subprojects/fmlip_relay url = git@github.com:pprcht/fmlip-relay.git +[submodule "subprojects/dftd4"] + path = subprojects/dftd4 + url = https://github.com/dftd4/dftd4 diff --git a/CMakeLists.txt b/CMakeLists.txt index e191339e..f61b9b13 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -91,6 +91,7 @@ endif() # tblite if(NOT TARGET "tblite::tblite" AND WITH_TBLITE) + find_package("dftd4" REQUIRED) find_package("tblite" REQUIRED) add_compile_definitions(WITH_TBLITE) endif() diff --git a/config/modules/Finddftd4.cmake b/config/modules/Finddftd4.cmake new file mode 100644 index 00000000..5d5edc91 --- /dev/null +++ b/config/modules/Finddftd4.cmake @@ -0,0 +1,43 @@ +# This file is part of crest. +# SPDX-Identifier: LGPL-3.0-or-later +# +# crest is free software: you can redistribute it and/or modify it under +# the terms of the GNU Lesser General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# crest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public License +# along with crest. If not, see . + +set(_lib "dftd4") +set(_pkg "DFTD4") +set(_url "https://github.com/dftd4/dftd4") +set(_branch "v3.7.0") + +if(NOT DEFINED "${_pkg}_FIND_METHOD") + set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") +endif() + +include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") + +set(temp_with_tests ${WITH_TESTS}) # Save the current value of WITH_TESTS +set(WITH_TESTS FALSE CACHE BOOL "Temporarily disable tests for the dftd4 subproject" FORCE) +set(WITH_API FALSE) +crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}" "${_branch}") + +set(found FALSE) +if(TARGET "dftd4::dftd4") + set (found TRUE) +endif() +message(STATUS "Found dftd4: ${found}") + +set(WITH_TESTS ${temp_with_tests} CACHE BOOL "Enable tests for the main project" FORCE) + +unset(_lib) +unset(_pkg) +unset(_url) diff --git a/config/modules/Findtblite.cmake b/config/modules/Findtblite.cmake index 6789f3d1..782e266f 100644 --- a/config/modules/Findtblite.cmake +++ b/config/modules/Findtblite.cmake @@ -17,7 +17,7 @@ set(_lib "tblite") set(_pkg "TBLITE") set(_url "https://github.com/tblite/tblite") -set(_branch "xtb_solvation") +set(_branch "HEAD") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") diff --git a/subprojects/.gitignore b/subprojects/.gitignore index 5bf42fcb..1be6b7f6 100644 --- a/subprojects/.gitignore +++ b/subprojects/.gitignore @@ -1,6 +1,6 @@ /*/ json-fortran-8.2.5.wrap -dftd4.wrap +!dftd4.wrap mstore.wrap multicharge.wrap s-dftd3.wrap @@ -16,6 +16,7 @@ lammps* !test-drive !pvol !fmlip_relay +!dftd4 !packagefiles !packagefiles/tblite diff --git a/subprojects/dftd4 b/subprojects/dftd4 new file mode 160000 index 00000000..7b2ff85a --- /dev/null +++ b/subprojects/dftd4 @@ -0,0 +1 @@ +Subproject commit 7b2ff85a71a3630808fd8a2d972933f75b743f3c diff --git a/subprojects/dftd4.wrap b/subprojects/dftd4.wrap new file mode 100644 index 00000000..6bd81c01 --- /dev/null +++ b/subprojects/dftd4.wrap @@ -0,0 +1,4 @@ +[wrap-git] +directory = dftd4 +url = https://github.com/dftd4/dftd4 +revision = v3.7.0 From 47bb33b71ea7570ef3fbf401b501b79a2ddbda46 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 13 Mar 2026 11:41:55 +0100 Subject: [PATCH 207/374] Add mctc-lib as git submodule (tblite dependency) --- .gitmodules | 3 +++ CMakeLists.txt | 1 + config/modules/Findmctc-lib.cmake | 38 +++++++------------------------ subprojects/.gitignore | 3 ++- subprojects/mctc-lib | 1 + subprojects/mctc-lib.wrap | 3 +++ 6 files changed, 18 insertions(+), 31 deletions(-) create mode 160000 subprojects/mctc-lib create mode 100644 subprojects/mctc-lib.wrap diff --git a/.gitmodules b/.gitmodules index 31aff439..2134defe 100644 --- a/.gitmodules +++ b/.gitmodules @@ -30,3 +30,6 @@ [submodule "subprojects/dftd4"] path = subprojects/dftd4 url = https://github.com/dftd4/dftd4 +[submodule "subprojects/mctc-lib"] + path = subprojects/mctc-lib + url = https://github.com/grimme-lab/mctc-lib.git diff --git a/CMakeLists.txt b/CMakeLists.txt index f61b9b13..af758a01 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -91,6 +91,7 @@ endif() # tblite if(NOT TARGET "tblite::tblite" AND WITH_TBLITE) + find_package("mctc-lib" REQUIRED) find_package("dftd4" REQUIRED) find_package("tblite" REQUIRED) add_compile_definitions(WITH_TBLITE) diff --git a/config/modules/Findmctc-lib.cmake b/config/modules/Findmctc-lib.cmake index 1ba16d81..5e9b3d1a 100644 --- a/config/modules/Findmctc-lib.cmake +++ b/config/modules/Findmctc-lib.cmake @@ -1,47 +1,25 @@ -# This file is part of crest. -# SPDX-Identifier: LGPL-3.0-or-later -# -# crest is free software: you can redistribute it and/or modify it under -# the terms of the GNU Lesser General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. -# -# crest is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public License -# along with crest. If not, see . - set(_lib "mctc-lib") set(_pkg "MCTCLIB") set(_url "https://github.com/grimme-lab/mctc-lib") +# Discovery method order can be overridden by the parent project, e.g.: +# set(mctc-lib_FIND_METHOD "subproject" "cmake") if(NOT DEFINED "${_pkg}_FIND_METHOD") - if(DEFINED "${PROJECT_NAME}-dependency-method") - set("${_pkg}_FIND_METHOD" "${${PROJECT_NAME}-dependency-method}") - else() - set("${_pkg}_FIND_METHOD" "cmake" "pkgconf" "subproject" "fetch") - endif() - set("_${_pkg}_FIND_METHOD") + set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") endif() +# Reuse whichever utils macro your main project already provides. +# Replace "crest-utils" with the actual name if yours differs. include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}") +set(found FALSE) if(TARGET "mctc-lib::mctc-lib") - set (found TRUE) -else() - set (found FALSE) + set(found TRUE) endif() -message("-- Found mctc-lib: ${found}") +message(STATUS "Found mctc-lib: ${found}") -if(DEFINED "_${_pkg}_FIND_METHOD") - unset("${_pkg}_FIND_METHOD") - unset("_${_pkg}_FIND_METHOD") -endif() unset(_lib) unset(_pkg) unset(_url) diff --git a/subprojects/.gitignore b/subprojects/.gitignore index 1be6b7f6..8f8fda32 100644 --- a/subprojects/.gitignore +++ b/subprojects/.gitignore @@ -4,7 +4,7 @@ json-fortran-8.2.5.wrap mstore.wrap multicharge.wrap s-dftd3.wrap -mctc-lib.wrap +!mctc-lib.wrap xhcff lammps* @@ -17,6 +17,7 @@ lammps* !pvol !fmlip_relay !dftd4 +!mctc-lib !packagefiles !packagefiles/tblite diff --git a/subprojects/mctc-lib b/subprojects/mctc-lib new file mode 160000 index 00000000..8cd0cb44 --- /dev/null +++ b/subprojects/mctc-lib @@ -0,0 +1 @@ +Subproject commit 8cd0cb4489537fd28bfb2e8094f1647f3e0da284 diff --git a/subprojects/mctc-lib.wrap b/subprojects/mctc-lib.wrap new file mode 100644 index 00000000..9f7635f9 --- /dev/null +++ b/subprojects/mctc-lib.wrap @@ -0,0 +1,3 @@ +[wrap-git] +directory = mctc-lib +url = https://github.com/grimme-lab/mctc-lib From baeace470ae375b9abfc001715017c767e254fde Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 13 Mar 2026 12:30:07 +0100 Subject: [PATCH 208/374] Update fmlip_relay update logic --- src/calculator/mlip_sc.F90 | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/src/calculator/mlip_sc.F90 b/src/calculator/mlip_sc.F90 index 71d60292..8c9bbc5e 100644 --- a/src/calculator/mlip_sc.F90 +++ b/src/calculator/mlip_sc.F90 @@ -91,7 +91,7 @@ subroutine fmlip_relay_init(MPAR,iid) !> options prepping tmpport = MPAR%BASE_PORT+iid - write(cmd_1,'("--dtype float64")') + write (cmd_1,'("--dtype float64")') select case (MPAR%backend) case ('mace_off','mace_mp') @@ -100,7 +100,7 @@ subroutine fmlip_relay_init(MPAR,iid) if (.not.file_exists(MPAR%modelpath)) then write (stdout,*) write (stdout,*) '** ERROR ** model path allocated but can not find '//trim(MPAR%modelpath) - write (stdout,*) + write (stdout,*) call creststop(20) end if write (cmd,'(a,1x,a,1x,i0,2(1x,a,1x,a),1x,a)') basebin,'--port',tmpport,'--backend', & @@ -127,12 +127,16 @@ subroutine fmlip_relay_init(MPAR,iid) & trim(MPAR%backend),'--model',trim(MPAR%modelpath),trim(cmd_1) end select - call mlip_init(iid,tmpport,trim(cmd)//' 2>/dev/null',MPAR%TIMEOUT_SEC,io) + !> check if this particular server is already running by pinging it + call mlip_ping(iid,io) if (io /= MLIP_OK) then - write (stdout,*) - write (stdout,*) '** ERROR ** failed to initialize MLIP server' - write (stdout,*) - call creststop(1) + call mlip_init(iid,tmpport,trim(cmd)//' 2>/dev/null',MPAR%TIMEOUT_SEC,io) + if (io /= MLIP_OK) then + write (stdout,*) + write (stdout,*) '** ERROR ** failed to initialize MLIP server' + write (stdout,*) + call creststop(1) + end if end if !> Test it call mlip_ping(iid,io) From 996b42d30b08f6cdcf11fa909df73c03469a64b4 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 13 Mar 2026 12:51:19 +0100 Subject: [PATCH 209/374] parallel execution of fmlip-relay --- src/basinhopping/algo.f90 | 1 + src/calculator/calc_type.f90 | 1 + 2 files changed, 2 insertions(+) diff --git a/src/basinhopping/algo.f90 b/src/basinhopping/algo.f90 index a1338a70..084e0058 100644 --- a/src/basinhopping/algo.f90 +++ b/src/basinhopping/algo.f90 @@ -258,6 +258,7 @@ subroutine parallel_basinhopping_core(env,mol,calc,structuredump) end do end if do K = 1,T + call calcp(K)%copy(calc) bhp(K)%id = K-1 !$omp critical select case (bhp(K)%steptype) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index bd02e031..ad355e27 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -1114,6 +1114,7 @@ subroutine calculation_settings_copy(self,src) self%penalty = src%penalty self%MPAR = src%MPAR + self%MPAR%iid = 0 !> important for parallelization !&< return end subroutine calculation_settings_copy From 251fc0d8cdc7343d757f18bd58217cd78aa8cb8c Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 13 Mar 2026 12:57:33 +0100 Subject: [PATCH 210/374] thread limitation for parallel MLIPs --- src/calculator/mlip_sc.F90 | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/calculator/mlip_sc.F90 b/src/calculator/mlip_sc.F90 index 8c9bbc5e..6a1d41ab 100644 --- a/src/calculator/mlip_sc.F90 +++ b/src/calculator/mlip_sc.F90 @@ -89,6 +89,15 @@ subroutine fmlip_relay_init(MPAR,iid) call mlip_finalize(MPAR%iid,io) end if + !> check if we have limitations for parallelity + if (iid > MLIP_MAX_INSTANCES) then + write (stdout,*) + write (stdout,*) '** ERROR ** exeeding the max number of parallel socket servers for MLIPs ' + write (stdout,*) ' Please request fewer than '//to_str(MLIP_MAX_INSTANCES) + write (stdout,*) + call creststop(20) + end if + !> options prepping tmpport = MPAR%BASE_PORT+iid write (cmd_1,'("--dtype float64")') From c19d5a0c086e36e3acce47a43b2d00d92a169bc0 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 13 Mar 2026 13:43:40 +0100 Subject: [PATCH 211/374] Add charge&spin update from fmlip-relay --- src/calculator/api_engrad.f90 | 3 ++- src/calculator/calc_type.f90 | 1 + src/calculator/mlip_sc.F90 | 17 +++++++++++++---- subprojects/fmlip_relay | 2 +- 4 files changed, 17 insertions(+), 6 deletions(-) diff --git a/src/calculator/api_engrad.f90 b/src/calculator/api_engrad.f90 index 1137db53..1cb9e37d 100644 --- a/src/calculator/api_engrad.f90 +++ b/src/calculator/api_engrad.f90 @@ -513,7 +513,8 @@ subroutine mlip_engrad(mol,calc,energy,grad,iostatus) !>--- do the engrad call call initsignal() - call mlip_engrad_core(mol,calc%MPAR,energy,grad,iostatus) + call mlip_engrad_core(mol,calc%MPAR,energy,grad,iostatus, & + & charge=calc%chrg,spin=calc%uhf) if (iostatus /= 0) return !>--- printout diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index ad355e27..1a82d922 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -638,6 +638,7 @@ subroutine calculation_copy(self,src,ignore_constraints) self%pr_energies = src%pr_energies self%eout_unit = src%eout_unit self%elog = src%elog + !&< return end subroutine calculation_copy diff --git a/src/calculator/mlip_sc.F90 b/src/calculator/mlip_sc.F90 index 6a1d41ab..314a7ad5 100644 --- a/src/calculator/mlip_sc.F90 +++ b/src/calculator/mlip_sc.F90 @@ -165,25 +165,34 @@ subroutine fmlip_relay_init(MPAR,iid) #endif end subroutine fmlip_relay_init - subroutine mlip_engrad_core(mol,MPAR,energy,gradient,iostatus) + subroutine mlip_engrad_core(mol,MPAR,energy,gradient,iostatus, & + & charge,spin) type(coord),intent(in) :: mol - type(mlip_params) :: MPAR + type(mlip_params),intent(in) :: MPAR + integer,intent(in),optional :: charge + integer,intent(in),optional :: spin real(wp),intent(out) :: energy real(wp),intent(out) :: gradient(3,mol%nat) integer,intent(out) :: iostatus + integer :: chrg,spn real(wp) :: stress(3,3) energy = 0.0_wp gradient(:,:) = 0.0_wp iostatus = 1 + chrg = 0 + spn = 1 + if (present(charge)) chrg = chrg + if (present(spin)) spn = spin + #ifdef WITH_FMLIP_RELAY if (allocated(mol%lat)) then - call mlip_compute(MPAR%iid,mol%nat,mol%at,mol%xyz*autoaa,mol%lat,allpbc,0, & + call mlip_compute(MPAR%iid,mol%nat,mol%at,mol%xyz*autoaa,mol%lat,allpbc,0,chrg,spn, & & energy,gradient,stress,iostatus) else - call mlip_compute(MPAR%iid,mol%nat,mol%at,mol%xyz*autoaa,bigcell,nopbc,0, & + call mlip_compute(MPAR%iid,mol%nat,mol%at,mol%xyz*autoaa,bigcell,nopbc,0,chrg,spn, & & energy,gradient,stress,iostatus) end if diff --git a/subprojects/fmlip_relay b/subprojects/fmlip_relay index f0e5976a..b171981b 160000 --- a/subprojects/fmlip_relay +++ b/subprojects/fmlip_relay @@ -1 +1 @@ -Subproject commit f0e5976aea77f69a7705dfa10466edb15d6fa251 +Subproject commit b171981b6f3399de1af5d01040af6d60aee29956 From 79071672cc9924d7225c47524442996baed5c6eb Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 13 Mar 2026 13:53:39 +0100 Subject: [PATCH 212/374] Update git submodule link --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index 2134defe..bc57262b 100644 --- a/.gitmodules +++ b/.gitmodules @@ -26,7 +26,7 @@ url = https://github.com/neudecker-group/libpvol.git [submodule "subprojects/fmlip_relay"] path = subprojects/fmlip_relay - url = git@github.com:pprcht/fmlip-relay.git + url = https://github.com/pprcht/fmlip-relay.git [submodule "subprojects/dftd4"] path = subprojects/dftd4 url = https://github.com/dftd4/dftd4 From 2df287f32fc3ae7e5faa509bd73f88121f6659ea Mon Sep 17 00:00:00 2001 From: Lukasrindt Date: Fri, 13 Mar 2026 13:57:28 +0100 Subject: [PATCH 213/374] g_sampling fully integrated --- src/calculator/calc_type.f90 | 14 + src/calculator/hr_utils.f90 | 4 +- src/optimize/optimize_module.f90 | 7 +- src/parsing/parse_calcdata.f90 | 2556 +++++++++++++++--------------- subprojects/tblite | 2 +- 5 files changed, 1310 insertions(+), 1273 deletions(-) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index daa4824e..c5c842c0 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -289,6 +289,7 @@ module calc_type real(wp) :: doh_stepsize = 0.10_wp !>stepsize for the deformation/reoptimization hessian generation real(wp) :: chess_id_guess = 0.1_wp logical :: g_sampling = .false. !>Do sampling on free energy surface as approximated using the lindh95 hessian + integer :: gs_hess_type = 5 !>--- Parameters for smooth function within optimizer real(wp) :: L = 1.50_wp @@ -620,6 +621,18 @@ subroutine calculation_copy(self,src,ignore_constraints) self%pr_energies = src%pr_energies self%eout_unit = src%eout_unit self%elog = src%elog + self%g_sampling = src%g_sampling + self%gs_hess_type = src%gs_hess_type + self%nt = src%nt + self%temperatures = src%temperatures + !self%et = src%et + !self%ht = src%ht + !self%gt = src%gt + !self%stot = src%stot + self%ithr = src%ithr + self%fscal = src%fscal + self%sthr = src%sthr + self%emodel = src%emodel !&< return end subroutine calculation_copy @@ -1044,6 +1057,7 @@ subroutine calculation_settings_deallocate(self) self%ONIOM_highlowroot = 0 self%ONIOM_id = 0 + return end subroutine calculation_settings_deallocate diff --git a/src/calculator/hr_utils.f90 b/src/calculator/hr_utils.f90 index 13df966e..ebfe5307 100644 --- a/src/calculator/hr_utils.f90 +++ b/src/calculator/hr_utils.f90 @@ -63,7 +63,7 @@ subroutine initialize_hessian(calc,type,xyz,nat,at,hess,hguess,pr) !>Matrix is f end if case (1) !$omp critical - write(stdout,*) calc%calcs(1)%chrg + !write(stdout,*) calc%calcs(1)%chrg call clevel%create('gfnff',chrg=calc%calcs(1)%chrg,uhf=calc%calcs(1)%uhf) !> Different levels?? and what happens to solvent?? call newcalc%add(clevel) !$omp end critical @@ -152,4 +152,4 @@ subroutine force_positive_definiteness(hess,nat3) end subroutine force_positive_definiteness -end module hr_utils \ No newline at end of file +end module hr_utils diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index e1b82785..1482770a 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -67,6 +67,8 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) real(wp),allocatable :: hess(:),g_hess(:), g_hess_full(:,:), int_temps(:) logical :: pr2 + + !write(stdout,*) "RUNNING AN OPT" iostatus = -1 !> do NOT overwrite original geometry @@ -158,11 +160,14 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) deallocate (calc%chess) end if + !write(stdout,*) calc%g_sampling + if (calc%g_sampling) then pr2 = .false. + !write(stdout,*) "Running gs" !write(stdout,*) "Energy pre correction", etot allocate(g_hess(nat3*(nat3+1)/2),g_hess_full(nat3,nat3)) - call initialize_hessian(calc,5,molnew%xyz,molnew%nat,molnew%at,g_hess,calc%chess%hguess,pr2) + call initialize_hessian(calc,calc%gs_hess_type,molnew%xyz,molnew%nat,molnew%at,g_hess,calc%chess%hguess,pr2) call dhtosq(nat3,g_hess_full,g_hess) call calc_thermo_from_hess(molnew,g_hess_full,pr2, & & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 24d942d1..f3f900da 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -24,51 +24,51 @@ !> This concerns mainly [calculation]/[calculation. ...] and [dynamics] blocks module parse_calcdata - use crest_parameters - use crest_data - use crest_calculator,only:calcdata,calculation_settings,jobtype,constraint,scantype - use dynamics_module - use bh_module - use gradreader_module,only:gradtype,conv2gradfmt - use tblite_api,only:xtblvl - use strucrd,only:get_atlist,coord - use axis_module - - use parse_block,only:datablock - use parse_keyvalue,only:keyvalue,valuetypes - use parse_datastruct,only:root_object - - implicit none - private + use crest_parameters + use crest_data + use crest_calculator, only: calcdata, calculation_settings, jobtype, constraint, scantype + use dynamics_module + use bh_module + use gradreader_module, only: gradtype, conv2gradfmt + use tblite_api, only: xtblvl + use strucrd, only: get_atlist, coord + use axis_module + + use parse_block, only: datablock + use parse_keyvalue, only: keyvalue, valuetypes + use parse_datastruct, only: root_object + + implicit none + private !>-- routines for parsing a calculation_settings object - interface parse_setting - module procedure :: parse_setting_auto - end interface parse_setting + interface parse_setting + module procedure :: parse_setting_auto + end interface parse_setting !>-- routines for parsing a calcdata object - interface parse_calc - module procedure :: parse_calc_auto - end interface parse_calc + interface parse_calc + module procedure :: parse_calc_auto + end interface parse_calc !>-- routines for parsing a mddata object - interface parse_md - module procedure :: parse_md_auto - end interface parse_md + interface parse_md + module procedure :: parse_md_auto + end interface parse_md !>-- routines for parsing a mtdpot object - interface parse_mtd - module procedure :: parse_metadyn_auto - end interface parse_mtd + interface parse_mtd + module procedure :: parse_metadyn_auto + end interface parse_mtd - public :: parse_calculation_data - public :: parse_dynamics_data - public :: parse_basinhopping_data + public :: parse_calculation_data + public :: parse_dynamics_data + public :: parse_basinhopping_data - character(len=*),parameter,private :: fmturk = '("unrecognized KEYWORD in ",a," : ",a)' - character(len=*),parameter,private :: fmtura = '("unrecognized ARGUMENT : ",a)' + character(len=*), parameter, private :: fmturk = '("unrecognized KEYWORD in ",a," : ",a)' + character(len=*), parameter, private :: fmtura = '("unrecognized ARGUMENT : ",a)' - external creststop + external creststop !========================================================================================! !========================================================================================! @@ -76,1355 +76,1373 @@ module parse_calcdata !========================================================================================! !========================================================================================! - subroutine parse_calculation_data(env,calc,dict,included,istat) - implicit none - type(systemdata) :: env - type(calcdata) :: calc - type(root_object) :: dict - type(datablock) :: blk - type(calculation_settings) :: newjob,newjob2 - type(constraint) :: newcstr - integer :: i,j,k,l - logical,intent(out) :: included - integer,intent(inout) :: istat - type(coord) :: moltmp - - included = .false. - call calc%reset() - call env%ref%to(moltmp) - call axis(moltmp%nat,moltmp%at,moltmp%xyz) - - do i = 1,dict%nblk - call blk%deallocate() - blk = dict%blk_list(i) - if (blk%header == 'calculation') then - included = .true. - call parse_calcdat(env,blk,calc,istat) - - else if (blk%header == 'calculation.level') then - call parse_leveldata(env,blk,newjob,istat) - call newjob%autocomplete(calc%ncalculations+1) - call calc%add(newjob) - included = .true. - - else if (blk%header == 'calculation.mecp') then - !>-- setup - if (allocated(calc%calcs)) deallocate (calc%calcs) - calc%ncalculations = 0 - calc%id = -1 - call parse_leveldata(env,blk,newjob,istat) - !>-- S0 setup - call parse_leveldata(env,blk,newjob,istat) - newjob%uhf = 0 - newjob%calcspace = 's0' - call calc%add(newjob) - !>-- S1 setup - newjob%uhf = 2 - newjob%calcspace = 's1' - call calc%add(newjob) - included = .true. - - else if (index(blk%header,'calculation.constraint') .ne. 0) then - call parse_constraintdat(env,moltmp,blk,calc,istat) - included = .true. - - else if (blk%header == 'calculation.scans') then - call parse_scandat(blk,calc,istat) - included = .true. - + subroutine parse_calculation_data(env, calc, dict, included, istat) + implicit none + type(systemdata) :: env + type(calcdata) :: calc + type(root_object) :: dict + type(datablock) :: blk + type(calculation_settings) :: newjob, newjob2 + type(constraint) :: newcstr + integer :: i, j, k, l + logical, intent(out) :: included + integer, intent(inout) :: istat + type(coord) :: moltmp + + included = .false. + call calc%reset() + call env%ref%to(moltmp) + call axis(moltmp%nat, moltmp%at, moltmp%xyz) + + do i = 1, dict%nblk + call blk%deallocate() + blk = dict%blk_list(i) + if (blk%header == 'calculation') then + included = .true. + call parse_calcdat(env, blk, calc, istat) + + else if (blk%header == 'calculation.level') then + call parse_leveldata(env, blk, newjob, istat) + call newjob%autocomplete(calc%ncalculations + 1) + call calc%add(newjob) + included = .true. + + else if (blk%header == 'calculation.mecp') then + !>-- setup + if (allocated(calc%calcs)) deallocate (calc%calcs) + calc%ncalculations = 0 + calc%id = -1 + call parse_leveldata(env, blk, newjob, istat) + !>-- S0 setup + call parse_leveldata(env, blk, newjob, istat) + newjob%uhf = 0 + newjob%calcspace = 's0' + call calc%add(newjob) + !>-- S1 setup + newjob%uhf = 2 + newjob%calcspace = 's1' + call calc%add(newjob) + included = .true. + + else if (index(blk%header, 'calculation.constraint') .ne. 0) then + call parse_constraintdat(env, moltmp, blk, calc, istat) + included = .true. + + else if (blk%header == 'calculation.scans') then + call parse_scandat(blk, calc, istat) + included = .true. + + end if + end do + if (included) then + call calc%init() end if - end do - if (included) then - call calc%init() - end if - return - end subroutine parse_calculation_data + return + end subroutine parse_calculation_data !========================================================================================! - subroutine parse_leveldata(env,blk,job,istat) + subroutine parse_leveldata(env, blk, job, istat) !********************************************************** !* The following routines are used to !* read information into the "calculation_settings" object !********************************************************** - implicit none - type(systemdata),intent(inout) :: env - type(datablock),intent(in) :: blk - type(calculation_settings),intent(out) :: job - integer,intent(inout) :: istat - logical :: rd - integer :: i - call job%deallocate() - if ((blk%header .ne. 'calculation.level').and. & - & (blk%header .ne. 'calculation.mecp')) then - return - end if - do i = 1,blk%nkv - call parse_setting_auto(env,job,blk%kv_list(i),rd) - if (.not.rd) then - istat = istat+1 - write (stdout,fmturk) '[['//blk%header//']]-block',blk%kv_list(i)%key + implicit none + type(systemdata), intent(inout) :: env + type(datablock), intent(in) :: blk + type(calculation_settings), intent(out) :: job + integer, intent(inout) :: istat + logical :: rd + integer :: i + call job%deallocate() + if ((blk%header .ne. 'calculation.level') .and. & + & (blk%header .ne. 'calculation.mecp')) then + return end if - end do - return - end subroutine parse_leveldata - subroutine parse_setting_auto(env,job,kv,rd) - implicit none - type(systemdata),intent(inout) :: env - type(calculation_settings) :: job - type(keyvalue) :: kv - logical,intent(out) :: rd - logical :: ex - integer :: n - rd = .true. - select case (kv%key) + do i = 1, blk%nkv + call parse_setting_auto(env, job, blk%kv_list(i), rd) + if (.not. rd) then + istat = istat + 1 + write (stdout, fmturk) '[['//blk%header//']]-block', blk%kv_list(i)%key + end if + end do + return + end subroutine parse_leveldata + subroutine parse_setting_auto(env, job, kv, rd) + implicit none + type(systemdata), intent(inout) :: env + type(calculation_settings) :: job + type(keyvalue) :: kv + logical, intent(out) :: rd + logical :: ex + integer :: n + rd = .true. + select case (kv%key) !>--- floats - case ('etemp') - job%etemp = kv%value_f - case ('accuracy') - job%accuracy = kv%value_f - case ('weight') - job%weight = kv%value_f - case ('pressure') - job%extpressure = kv%value_f - case ('proberad','pvol_proberad') - job%proberad = kv%value_f - case ('radscal','pvol_radscal') - job%pvradscal = kv%value_f - case ('efield') - n = size(kv%value_fa,1) - if (n .ne. 3) then - !>--- keyword was recognized, but invalid argument supplied - write (stdout,fmtura) trim(kv%rawvalue) - call creststop(status_config) - end if - allocate (job%efield(3),source=0.0_wp) - job%efield(:) = kv%value_fa(:) + case ('etemp') + job%etemp = kv%value_f + case ('accuracy') + job%accuracy = kv%value_f + case ('weight') + job%weight = kv%value_f + case ('pressure') + job%extpressure = kv%value_f + case ('proberad', 'pvol_proberad') + job%proberad = kv%value_f + case ('radscal', 'pvol_radscal') + job%pvradscal = kv%value_f + case ('efield') + n = size(kv%value_fa, 1) + if (n .ne. 3) then + !>--- keyword was recognized, but invalid argument supplied + write (stdout, fmtura) trim(kv%rawvalue) + call creststop(status_config) + end if + allocate (job%efield(3), source=0.0_wp) + job%efield(:) = kv%value_fa(:) !>--- integers - case ('uhf','multiplicity') - job%uhf = kv%value_i - case ('chrg','charge') - job%chrg = kv%value_i - case ('id') - job%id = kv%value_i - case ('maxscc') - job%maxscc = kv%value_i - case ('lebedev','pvol_ngrid') - job%ngrid = kv%value_i - case ('vdwset','pvol_vdwset') - job%vdwset = kv%value_i - case ('config') - call job%addconfig(kv%value_ia) + case ('uhf', 'multiplicity') + job%uhf = kv%value_i + case ('chrg', 'charge') + job%chrg = kv%value_i + case ('id') + job%id = kv%value_i + case ('maxscc') + job%maxscc = kv%value_i + case ('lebedev', 'pvol_ngrid') + job%ngrid = kv%value_i + case ('vdwset', 'pvol_vdwset') + job%vdwset = kv%value_i + case ('config') + call job%addconfig(kv%value_ia) !>--- strings - case ('method') - select case (kv%value_c) - case ('gfn-xtb','gfn','xtb') - job%id = jobtype%xtbsys - case ('generic') - job%id = jobtype%generic - case ('orca') - job%id = jobtype%orca - case ('turbomole','tm') - job%id = jobtype%turbomole - case ('terachem') - job%id = jobtype%terachem - case ('tblite') - job%id = jobtype%tblite - case ('gfn2','gfn2-xtb') - job%id = jobtype%tblite - job%tblitelvl = xtblvl%gfn2 - case ('gfn1','gfn1-xtb') - job%id = jobtype%tblite - job%tblitelvl = xtblvl%gfn1 - case ('ceh') - job%id = jobtype%tblite - job%tblitelvl = xtblvl%ceh - job%rdgrad = .false. - job%rdqat = .true. - job%rddip = .true. - case ('gfn0','gfn0-xtb') - job%id = jobtype%gfn0 - case ('gfn0*','gfn0*-xtb') - job%id = jobtype%gfn0occ - case ('gfnff','gff','gfn-ff') - job%id = jobtype%gfnff - case ('pvol','libpvol','pv') - job%id = jobtype%libpvol - case ('gxtb_dev') - job%id = jobtype%turbomole - job%rdgrad = .true. - job%binary = 'gxtb' - job%other = '-grad' - case ('none') - job%id = jobtype%unknown - case ('lj','lennard-jones') - job%id = jobtype%lj - case default - job%id = jobtype%unknown - !>--- keyword was recognized, but invalid argument supplied - write (stdout,fmtura) kv%value_c - call creststop(status_config) - end select - - case ('bin','binary','script') - job%binary = kv%value_c - - case ('flags') - job%other = kv%value_c - - !> don't. - !case ('sys','syscall','systemcall') - ! job%systemcall = val - - case ('calcspace','dir') - job%calcspace = kv%value_c - - case ('gradfile') - job%gradfile = kv%value_c - - case ('gradtype') - select case (kv%value_c) - case ('engrad','xtb','orca') - job%gradtype = gradtype%engrad - case ('turbomole','tm') - job%gradtype = gradtype%turbomole - case ('generic') - job%gradtype = gradtype%unknown - case default - job%gradtype = gradtype%unknown - !>--- keyword was recognized, but invalid argument supplied - write (stdout,fmtura) kv%value_c - call creststop(status_config) - - end select - - case ('gradkey') - job%gradkey = kv%value_c - - case ('gradmt') - job%gradfmt = conv2gradfmt(kv%value_c) - - case ('numgrad') - job%numgrad = kv%value_b - case ('gradstep') - job%gradstep = kv%value_f - - case ('efile') - job%efile = kv%value_c - - case ('tblite_level','tblite_hamiltonian') - select case (kv%value_c) - case ('gfn2','gfn2-xtb') - job%tblitelvl = xtblvl%gfn2 - case ('gfn1','gfn1-xtb') - job%tblitelvl = xtblvl%gfn1 - case ('ipea1') - job%tblitelvl = xtblvl%ipea1 - case ('ceh') - job%tblitelvl = xtblvl%ceh - job%rdgrad = .false. - case ('eeq','d4eeq') - job%tblitelvl = xtblvl%eeq - job%rdgrad = .false. - case default - job%tblitelvl = xtblvl%unknown - !>--- keyword was recognized, but invalid argument supplied - write (stdout,fmtura) kv%value_c - call creststop(status_config) + case ('method') + select case (kv%value_c) + case ('gfn-xtb', 'gfn', 'xtb') + job%id = jobtype%xtbsys + case ('generic') + job%id = jobtype%generic + case ('orca') + job%id = jobtype%orca + case ('turbomole', 'tm') + job%id = jobtype%turbomole + case ('terachem') + job%id = jobtype%terachem + case ('tblite') + job%id = jobtype%tblite + case ('gfn2', 'gfn2-xtb') + job%id = jobtype%tblite + job%tblitelvl = xtblvl%gfn2 + case ('gfn1', 'gfn1-xtb') + job%id = jobtype%tblite + job%tblitelvl = xtblvl%gfn1 + case ('ceh') + job%id = jobtype%tblite + job%tblitelvl = xtblvl%ceh + job%rdgrad = .false. + job%rdqat = .true. + job%rddip = .true. + case ('gfn0', 'gfn0-xtb') + job%id = jobtype%gfn0 + case ('gfn0*', 'gfn0*-xtb') + job%id = jobtype%gfn0occ + case ('gfnff', 'gff', 'gfn-ff') + job%id = jobtype%gfnff + case ('pvol', 'libpvol', 'pv') + job%id = jobtype%libpvol + case ('gxtb_dev') + job%id = jobtype%turbomole + job%rdgrad = .true. + job%binary = 'gxtb' + job%other = '-grad' + case ('none') + job%id = jobtype%unknown + case ('lj', 'lennard-jones') + job%id = jobtype%lj + case default + job%id = jobtype%unknown + !>--- keyword was recognized, but invalid argument supplied + write (stdout, fmtura) kv%value_c + call creststop(status_config) + end select + + case ('bin', 'binary', 'script') + job%binary = kv%value_c + + case ('flags') + job%other = kv%value_c + + !> don't. + !case ('sys','syscall','systemcall') + ! job%systemcall = val + + case ('calcspace', 'dir') + job%calcspace = kv%value_c + + case ('gradfile') + job%gradfile = kv%value_c + + case ('gradtype') + select case (kv%value_c) + case ('engrad', 'xtb', 'orca') + job%gradtype = gradtype%engrad + case ('turbomole', 'tm') + job%gradtype = gradtype%turbomole + case ('generic') + job%gradtype = gradtype%unknown + case default + job%gradtype = gradtype%unknown + !>--- keyword was recognized, but invalid argument supplied + write (stdout, fmtura) kv%value_c + call creststop(status_config) + + end select + + case ('gradkey') + job%gradkey = kv%value_c + + case ('gradmt') + job%gradfmt = conv2gradfmt(kv%value_c) + + case ('numgrad') + job%numgrad = kv%value_b + case ('gradstep') + job%gradstep = kv%value_f + + case ('efile') + job%efile = kv%value_c + + case ('tblite_level', 'tblite_hamiltonian') + select case (kv%value_c) + case ('gfn2', 'gfn2-xtb') + job%tblitelvl = xtblvl%gfn2 + case ('gfn1', 'gfn1-xtb') + job%tblitelvl = xtblvl%gfn1 + case ('ipea1') + job%tblitelvl = xtblvl%ipea1 + case ('ceh') + job%tblitelvl = xtblvl%ceh + job%rdgrad = .false. + case ('eeq', 'd4eeq') + job%tblitelvl = xtblvl%eeq + job%rdgrad = .false. + case default + job%tblitelvl = xtblvl%unknown + !>--- keyword was recognized, but invalid argument supplied + write (stdout, fmtura) kv%value_c + call creststop(status_config) + + end select + case ('tblite_param') + job%tbliteparam = kv%value_c + job%tblitelvl = xtblvl%param + + case ('orca_cmd') + job%id = jobtype%orca + job%ORCA%cmd = kv%value_c + job%binary = kv%value_c + case ('orca_template') + job%id = jobtype%orca + call job%ORCA%read(kv%value_c) + + case ('gbsa', 'alpb', 'cpcm') + job%solvmodel = kv%key + job%solvent = kv%value_c + + case ('refine', 'refinement') + select case (kv%value_c) + case ('sp', 'singlepoint') + job%refine_lvl = refine%singlepoint + case ('add', 'correction') + job%refine_lvl = refine%correction + case ('opt', 'optimization') + job%refine_lvl = refine%geoopt + case default + job%refine_lvl = refine%non + !>--- keyword was recognized, but invalid argument supplied + write (stdout, fmtura) kv%value_c + call creststop(status_config) + + end select + + case ('restartfile', 'topo', 'reftopo') + inquire (file=kv%value_c, exist=ex) + if (ex) then + job%restart = .true. + job%restartfile = kv%value_c + else + write (stderr, '(a,a,a)') 'specified restart file ', kv%value_c, ' does not exist' + call creststop(status_input) + end if + + case ('refgeo', 'refxyz') + inquire (file=kv%value_c, exist=ex) + if (ex) then + job%refgeo = kv%value_c + else + write (stderr, '(a,a,a)') 'specified reference geometry file ', kv%value_c, ' does not exist' + call creststop(status_input) + end if + + case ('parametrisation') + inquire (file=kv%value_c, exist=ex) + if (ex) then + job%parametrisation = kv%value_c + else + write (stderr, '(a,a,a)') 'specified parametrisation file ', kv%value_c, ' does not exist' + call creststop(status_input) + end if + + case ('refchrg', 'refcharges') + inquire (file=kv%value_c, exist=ex) + if (ex) then + job%refcharges = kv%value_c + else + write (stderr, '(a,a,a)') 'specified reference charge file ', kv%value_c, ' does not exist' + call creststop(status_config) + end if + + case ('print') + select case (kv%id) + case (2) + select case (kv%value_c) + case ('true', 'yes') + job%pr = .true. + case ('false', 'no') + job%pr = .false. + case ('append', 'cont', 'continuous') + job%pr = .true. + job%prappend = .true. + end select + case (3) + job%pr = kv%value_b + end select + if (job%pr) job%prch = 999 !> the actual ID will be generated automatically + + case ('getsasa') + call get_atlist(env%ref%nat, job%getsasa, kv%value_c, env%ref%at) + + case ('pvol_model', 'pgrad', 'pvgrad') + select case (kv%id) + case (valuetypes%int) + job%pvmodel = kv%value_i + case (valuetypes%string) + select case (kv%value_c) + case ('xhcff') + job%pvmodel = 0 + case ('analytic') + job%pvmodel = 1 + case default + write (stdout, fmtura) kv%value_c + call creststop(status_config) + end select + case default + write (stdout, fmtura) trim(kv%rawvalue) + call creststop(status_config) + end select - end select - case ('tblite_param') - job%tbliteparam = kv%value_c - job%tblitelvl = xtblvl%param - - case ('orca_cmd') - job%id = jobtype%orca - job%ORCA%cmd = kv%value_c - job%binary = kv%value_c - case ('orca_template') - job%id = jobtype%orca - call job%ORCA%read(kv%value_c) - - case ('gbsa','alpb','cpcm') - job%solvmodel = kv%key - job%solvent = kv%value_c - - case ('refine','refinement') - select case (kv%value_c) - case ('sp','singlepoint') - job%refine_lvl = refine%singlepoint - case ('add','correction') - job%refine_lvl = refine%correction - case ('opt','optimization') - job%refine_lvl = refine%geoopt - case default - job%refine_lvl = refine%non - !>--- keyword was recognized, but invalid argument supplied - write (stdout,fmtura) kv%value_c - call creststop(status_config) - - end select - - case ('restartfile','topo','reftopo') - inquire (file=kv%value_c,exist=ex) - if (ex) then - job%restart = .true. - job%restartfile = kv%value_c - else - write (stderr,'(a,a,a)') 'specified restart file ',kv%value_c,' does not exist' - call creststop(status_input) - end if - - case ('refgeo','refxyz') - inquire (file=kv%value_c,exist=ex) - if (ex) then - job%refgeo = kv%value_c - else - write (stderr,'(a,a,a)') 'specified reference geometry file ',kv%value_c,' does not exist' - call creststop(status_input) - end if - - case ('parametrisation') - inquire (file=kv%value_c,exist=ex) - if (ex) then - job%parametrisation = kv%value_c - else - write (stderr,'(a,a,a)') 'specified parametrisation file ',kv%value_c,' does not exist' - call creststop(status_input) - end if - - case ('refchrg','refcharges') - inquire (file=kv%value_c,exist=ex) - if (ex) then - job%refcharges = kv%value_c - else - write (stderr,'(a,a,a)') 'specified reference charge file ',kv%value_c,' does not exist' - call creststop(status_config) - end if +!>--- booleans + case ('rdwbo') + job%rdwbo = kv%value_b + case ('rddip', 'rddipole') + job%rddip = kv%value_b + case ('rdqat', 'rdchrg') + job%rdqat = kv%value_b + case ('dumpq', 'dumpchrg') + job%rdqat = kv%value_b + job%dumpq = kv%value_b + case ('dipgrad') + job%rddipgrad = kv%value_b + case ('rdgrad') + job%rdgrad = kv%value_b + case ('refresh') + job%apiclean = kv%value_b + case ('lmo', 'lmocent') + job%getlmocent = kv%value_b + case ('ceh_guess') + job%ceh_guess = kv%value_b - case ('print') - select case (kv%id) - case (2) - select case (kv%value_c) - case ('true','yes') - job%pr = .true. - case ('false','no') - job%pr = .false. - case ('append','cont','continuous') - job%pr = .true. - job%prappend = .true. - end select - case (3) - job%pr = kv%value_b - end select - if (job%pr) job%prch = 999 !> the actual ID will be generated automatically - - case ('getsasa') - call get_atlist(env%ref%nat,job%getsasa,kv%value_c,env%ref%at) - - case ('pvol_model','pgrad','pvgrad') - select case (kv%id) - case (valuetypes%int) - job%pvmodel = kv%value_i - case (valuetypes%string) - select case (kv%value_c) - case ('xhcff') - job%pvmodel = 0 - case ('analytic') - job%pvmodel = 1 - case default - write (stdout,fmtura) kv%value_c - call creststop(status_config) - end select case default - write (stdout,fmtura) trim(kv%rawvalue) - call creststop(status_config) + !>--- keyword not correctly read/found + rd = .false. + continue end select - -!>--- booleans - case ('rdwbo') - job%rdwbo = kv%value_b - case ('rddip','rddipole') - job%rddip = kv%value_b - case ('rdqat','rdchrg') - job%rdqat = kv%value_b - case ('dumpq','dumpchrg') - job%rdqat = kv%value_b - job%dumpq = kv%value_b - case ('dipgrad') - job%rddipgrad = kv%value_b - case ('rdgrad') - job%rdgrad = kv%value_b - case ('refresh') - job%apiclean = kv%value_b - case ('lmo','lmocent') - job%getlmocent = kv%value_b - case ('ceh_guess') - job%ceh_guess = kv%value_b - - case default - !>--- keyword not correctly read/found - rd = .false. - continue - end select - end subroutine parse_setting_auto + end subroutine parse_setting_auto !========================================================================================! - subroutine parse_calcdat(env,blk,calc,istat) + subroutine parse_calcdat(env, blk, calc, istat) !*********************************************** !* The following routines are used to !* read information into the "calcdata" object !*********************************************** - implicit none - type(systemdata),intent(inout) :: env - type(datablock),intent(in) :: blk - type(calcdata),intent(inout) :: calc - integer,intent(inout) :: istat - integer :: i - logical :: rd - if (blk%header .ne. 'calculation') return - do i = 1,blk%nkv - call parse_calc_auto(env,calc,blk%kv_list(i),rd) - if (.not.rd) then - istat = istat+1 - write (stdout,fmturk) '[calculation]-block',blk%kv_list(i)%key - end if - end do - return - end subroutine parse_calcdat - subroutine parse_calc_auto(env,calc,kv,rd) - implicit none - type(systemdata),intent(inout) :: env - type(calcdata) :: calc - type(keyvalue) :: kv - logical,intent(out) :: rd - logical,allocatable :: atlist(:) - rd = .true. - select case (kv%key) - case ('optlev','ancopt_level') - env%optlev = optlevnum(kv%rawvalue) + implicit none + type(systemdata), intent(inout) :: env + type(datablock), intent(in) :: blk + type(calcdata), intent(inout) :: calc + integer, intent(inout) :: istat + integer :: i + logical :: rd + if (blk%header .ne. 'calculation') return + do i = 1, blk%nkv + call parse_calc_auto(env, calc, blk%kv_list(i), rd) + if (.not. rd) then + istat = istat + 1 + write (stdout, fmturk) '[calculation]-block', blk%kv_list(i)%key + end if + end do + return + end subroutine parse_calcdat + subroutine parse_calc_auto(env, calc, kv, rd) + implicit none + type(systemdata), intent(inout) :: env + type(calcdata) :: calc + type(keyvalue) :: kv + logical, intent(out) :: rd + logical, allocatable :: atlist(:) + rd = .true. + select case (kv%key) + case ('optlev', 'ancopt_level') + env%optlev = optlevnum(kv%rawvalue) !>--- floats - case ('converge_e','ethr_opt') - calc%ethr_opt = kv%value_f !> optimization ΔE convergenve threshold (Ha) + case ('converge_e', 'ethr_opt') + calc%ethr_opt = kv%value_f !> optimization ΔE convergenve threshold (Ha) - case ('converge_g','gthr_opt','rmsforce') - calc%gthr_opt = kv%value_f !> optimization RMS convergence threshold (Ha/a0) + case ('converge_g', 'gthr_opt', 'rmsforce') + calc%gthr_opt = kv%value_f !> optimization RMS convergence threshold (Ha/a0) - case ('maxerise') - calc%maxerise = kv%value_f !> optimization max E rise (Ha) + case ('maxerise') + calc%maxerise = kv%value_f !> optimization max E rise (Ha) - case ('displ_opt','maxdispl') - calc%maxdispl_opt = kv%value_f !> optimization step size/scaling + case ('displ_opt', 'maxdispl') + calc%maxdispl_opt = kv%value_f !> optimization step size/scaling - case ('hguess') - calc%hguess = kv%value_f !> guess for the initial hessian - - case ('opt_lval') - calc%L = kv%value_f !> Parameters for smooth function for stepsize control within optimizer - - case('opt_k') - calc%k = kv%value_f - - case('opt_shift') - calc%shift = kv%value_f + case ('hguess') + calc%hguess = kv%value_f !> guess for the initial hessian - case('scaling') - calc%scaling = kv%value_f + case ('opt_lval') + calc%L = kv%value_f !> Parameters for smooth function for stepsize control within optimizer - case('doh_stepsize') - calc%doh_stepsize = kv%value_f + case ('opt_k') + calc%k = kv%value_f - case('chess_id_guess') - calc%chess_id_guess = kv%value_f + case ('opt_shift') + calc%shift = kv%value_f -!>--- integers - case ('maxcycle') - calc%maxcycle = kv%value_i !> optimization max cycles - - case ('chess_steps') - calc%hu_steps = kv%value_i + case ('scaling') + calc%scaling = kv%value_f -!>--- strings - case ('id','type') - !> (OLD setting) calculation type - select case (kv%id) - case (2) - calc%id = kv%value_i - case (4) - select case (kv%value_c) - case ('mecp') - calc%id = -1 - case default - calc%id = 0 - end select - end select + case ('doh_stepsize') + calc%doh_stepsize = kv%value_f - case ('elog') - calc%elog = kv%value_c - calc%pr_energies = .true. - - case ('hess_update','hupdate') - select case (kv%value_c) !> Hessian updates in geom. Opt. - case ('bfgs') - calc%iupdat = 0 - case ('powell') - calc%iupdat = 1 - case ('sr1') - calc%iupdat = 2 - case ('bofill') - calc%iupdat = 3 - case ('schlegel') - calc%iupdat = 4 - case default - !>--- keyword was recognized, but invalid argument supplied - write (stdout,fmtura) kv%value_c - call creststop(status_config) - end select - - case ('opt','opt_engine','opt_algo') - select case (kv%value_c) - case ('ancopt','rfo-anc') - calc%opt_engine = 0 - case ('lbfgs','l-bfgs') - calc%opt_engine = 1 - case ('rfo','rfo-cart') - calc%opt_engine = 2 - case('newton','nr') - calc%opt_engine = 3 - case ('gd','gradient descent') - calc%opt_engine = -1 - case default - !>--- keyword was recognized, but invalid argument supplied - write (stdout,fmtura) kv%value_c - call creststop(status_config) - end select - - case ('hr_init','hr_initialization') !> here we set how the matrix for hessian reconstruction is initialized - select case (kv%value_c) - case('identity') - calc%initialize_hr_type = 0 - case('gfnff', 'gfn-ff') - calc%initialize_hr_type = 1 - case('gfn0') - calc%initialize_hr_type = 2 - case('gfn1') - calc%initialize_hr_type = 3 - case('gfn2') - calc%initialize_hr_type = 4 - case('modhess') - calc%initialize_hr_type = 5 - case default - !>--- keyword was recognized, but invalid argument supplied - write (stdout,fmtura) kv%value_c - call creststop(status_config) - end select + case ('chess_id_guess') + calc%chess_id_guess = kv%value_f - case ('modhess_type','mh_type') !> here we set how the matrix for hessian reconstruction is initialized - select case (kv%value_c) !>maybe need to add another keywort for crosstesting hr and geopt -> No, - case('lindh95') - calc%mh_type = 0 - case('lindh') - calc%mh_type = 1 - case('lindh07') - calc%mh_type = 2 - case('swart') - calc%mh_type = 3 - case default - !>--- keyword was recognized, but invalid argument supplied - write (stdout,fmtura) kv%value_c - call creststop(status_config) - end select +!>--- integers + case ('maxcycle') + calc%maxcycle = kv%value_i !> optimization max cycles - case ('hess_init','hess_initialization') !> here we set how the hessian for optimization - select case (kv%value_c) - case('identity') - calc%hess_init = 0 - case('gfnff', 'gfn-ff') - calc%hess_init = 1 - case('gfn0') - calc%hess_init = 2 - case('gfn1') - calc%hess_init = 3 - case('gfn2') - calc%hess_init = 4 - case('modhess') - calc%hess_init = 5 - case default - !>--- keyword was recognized, but invalid argument supplied - write (stdout,fmtura) kv%value_c - call creststop(status_config) - end select - - case ('hr_hess_update','hr_hu_update') - select case (kv%value_c) !> Hessian updates in hessian reconstruction - case ('bfgs') - calc%hr_hu_type = 0 - case ('powell') - calc%hr_hu_type = 1 - case ('sr1') - calc%hr_hu_type = 2 - case ('bofill') - calc%hr_hu_type = 3 - case ('schlegel') - calc%hr_hu_type = 4 - case default - !>--- keyword was recognized, but invalid argument supplied - write (stdout,fmtura) kv%value_c - call creststop(status_config) - end select + case ('chess_steps') + calc%hu_steps = kv%value_i - case ('freeze') - call get_atlist(env%ref%nat,atlist,kv%value_c,env%ref%at) - calc%nfreeze = count(atlist) - call move_alloc(atlist,calc%freezelist) +!>--- strings + case ('id', 'type') + !> (OLD setting) calculation type + select case (kv%id) + case (2) + calc%id = kv%value_i + case (4) + select case (kv%value_c) + case ('mecp') + calc%id = -1 + case default + calc%id = 0 + end select + end select + + case ('elog') + calc%elog = kv%value_c + calc%pr_energies = .true. + + case ('hess_update', 'hupdate') + select case (kv%value_c) !> Hessian updates in geom. Opt. + case ('bfgs') + calc%iupdat = 0 + case ('powell') + calc%iupdat = 1 + case ('sr1') + calc%iupdat = 2 + case ('bofill') + calc%iupdat = 3 + case ('schlegel') + calc%iupdat = 4 + case default + !>--- keyword was recognized, but invalid argument supplied + write (stdout, fmtura) kv%value_c + call creststop(status_config) + end select + + case ('opt', 'opt_engine', 'opt_algo') + select case (kv%value_c) + case ('ancopt', 'rfo-anc') + calc%opt_engine = 0 + case ('lbfgs', 'l-bfgs') + calc%opt_engine = 1 + case ('rfo', 'rfo-cart') + calc%opt_engine = 2 + case ('newton', 'nr') + calc%opt_engine = 3 + case ('gd', 'gradient descent') + calc%opt_engine = -1 + case default + !>--- keyword was recognized, but invalid argument supplied + write (stdout, fmtura) kv%value_c + call creststop(status_config) + end select + + case ('hr_init', 'hr_initialization') !> here we set how the matrix for hessian reconstruction is initialized + select case (kv%value_c) + case ('identity') + calc%initialize_hr_type = 0 + case ('gfnff', 'gfn-ff') + calc%initialize_hr_type = 1 + case ('gfn0') + calc%initialize_hr_type = 2 + case ('gfn1') + calc%initialize_hr_type = 3 + case ('gfn2') + calc%initialize_hr_type = 4 + case ('modhess') + calc%initialize_hr_type = 5 + case default + !>--- keyword was recognized, but invalid argument supplied + write (stdout, fmtura) kv%value_c + call creststop(status_config) + end select + + case ('gs_hess_type') + select case (kv%value_c) + case ('gfnff', 'gfn-ff') + calc%gs_hess_type = 1 + case ('gfn0') + calc%gs_hess_type = 2 + case ('gfn1') + calc%gs_hess_type = 3 + case ('gfn2') + calc%gs_hess_type = 4 + case ('modhess') + calc%gs_hess_type = 5 + case default + !>--- keyword was recognized, but + write (stdout, fmtura) kv%value_c + call creststop(status_config) + end select + + case ('modhess_type', 'mh_type') !> here we set how the matrix for hessian reconstruction is initialized + select case (kv%value_c) !>maybe need to add another keywort for crosstesting hr and geopt -> No, + case ('lindh95') + calc%mh_type = 0 + case ('lindh') + calc%mh_type = 1 + case ('lindh07') + calc%mh_type = 2 + case ('swart') + calc%mh_type = 3 + case default + !>--- keyword was recognized, but invalid argument supplied + write (stdout, fmtura) kv%value_c + call creststop(status_config) + end select + + case ('hess_init', 'hess_initialization') !> here we set how the hessian for optimization + select case (kv%value_c) + case ('identity') + calc%hess_init = 0 + case ('gfnff', 'gfn-ff') + calc%hess_init = 1 + case ('gfn0') + calc%hess_init = 2 + case ('gfn1') + calc%hess_init = 3 + case ('gfn2') + calc%hess_init = 4 + case ('modhess') + calc%hess_init = 5 + case default + !>--- keyword was recognized, but invalid argument supplied + write (stdout, fmtura) kv%value_c + call creststop(status_config) + end select + + case ('hr_hess_update', 'hr_hu_update') + select case (kv%value_c) !> Hessian updates in hessian reconstruction + case ('bfgs') + calc%hr_hu_type = 0 + case ('powell') + calc%hr_hu_type = 1 + case ('sr1') + calc%hr_hu_type = 2 + case ('bofill') + calc%hr_hu_type = 3 + case ('schlegel') + calc%hr_hu_type = 4 + case default + !>--- keyword was recognized, but invalid argument supplied + write (stdout, fmtura) kv%value_c + call creststop(status_config) + end select + + case ('freeze') + call get_atlist(env%ref%nat, atlist, kv%value_c, env%ref%at) + calc%nfreeze = count(atlist) + call move_alloc(atlist, calc%freezelist) !>--- booleans - case ('eprint') - calc%pr_energies = kv%value_b + case ('eprint') + calc%pr_energies = kv%value_b - case ('exact_rf') - calc%exact_rf = kv%value_b + case ('exact_rf') + calc%exact_rf = kv%value_b - case ('chess') - calc%do_HR = kv%value_b + case ('chess') + calc%do_HR = kv%value_b - case ('full_chess') !> Do Hessian Reconstruct with all optimization steps - calc%full_HR = kv%value_b - - case ('deform_opt_hess') - calc%deform_opt_hess = kv%value_b + case ('full_chess') !> Do Hessian Reconstruct with all optimization steps + calc%full_HR = kv%value_b - case("g_sampling") !> Do sampling on free energy surface as approximated by lindh95 hessian - calc%g_sampling = kv%value_b + case ('deform_opt_hess') + calc%deform_opt_hess = kv%value_b - case default - rd = .false. - end select - end subroutine parse_calc_auto + case ("g_sampling") !> Do sampling on free energy surface as approximated by lindh95 hessian + calc%g_sampling = kv%value_b + + case default + rd = .false. + end select + end subroutine parse_calc_auto !========================================================================================! - subroutine parse_constraintdat(env,mol,blk,calc,istat) + subroutine parse_constraintdat(env, mol, blk, calc, istat) !************************************************* !* The following routines are used to !* read information into the "constraint" object !* and add it to a calculation data object !************************************************* - implicit none - type(systemdata),intent(inout) :: env - type(coord),intent(inout) :: mol - type(datablock),intent(in) :: blk - type(calcdata),intent(inout) :: calc - integer,intent(inout) :: istat - logical :: success - type(constraint) :: constr - integer :: i - logical :: rd - if (blk%header .ne. 'calculation.constraints'.and. & - & blk%header .ne. 'calculation.constraint') return - success = .false. - call constr%deallocate() - do i = 1,blk%nkv - call parse_constraint_auto(env,calc,constr,blk%kv_list(i),success,rd) - if (.not.rd) then - istat = istat+1 - write (stdout,fmturk) '[['//blk%header//']]-block',blk%kv_list(i)%key - end if - end do - if (success) then - call constr%complete(mol) - call calc%add(constr) - end if - return - end subroutine parse_constraintdat - subroutine parse_constraint_auto(env,calc,constr,kv,success,rd) - implicit none - type(systemdata) :: env - type(keyvalue) :: kv - type(constraint) :: constr - logical,intent(inout) :: success - type(calcdata),intent(inout) :: calc - real(wp) :: dum1,dum2,dum3,dum4 - real(wp) :: rabc(3) - integer :: atm1,atm2,atm3,atm4,n,k,j - logical,allocatable :: atlist(:) - logical,intent(out) :: rd - rd = .true. - select case (kv%key) - - case ('freeze') - call get_atlist(env%ref%nat,atlist,kv%rawvalue,env%ref%at) - calc%nfreeze = count(atlist) - call move_alloc(atlist,calc%freezelist) - - case ('type') !> the type of constraint - select case (kv%value_c) - case ('bond','bonds'); constr%type = 1 - case ('angle'); constr%type = 2 - case ('dihedral'); constr%type = 3 - case ('wall'); constr%type = 4 - case ('wall_logfermi','ellipsoid'); constr%type = 5 - case ('box'); constr%type = 6 - case ('bondrange'); constr%type = 8 - case ('gapdiff'); constr%type = -1 - case ('gapdiff2','mecp'); constr%type = -2 - case default - !>--- keyword was recognized, but invalid argument supplied - write (stdout,fmtura) kv%value_c - call creststop(status_config) - end select - if (constr%type /= 0) success = .true. - - case ('fc','k','forceconstant','params') !> force constants or parameters - if (allocated(constr%fc)) deallocate (constr%fc) - select case (kv%id) - case (valuetypes%int) - allocate (constr%fc(1),source=0.0_wp) - constr%fc(1) = kv%value_i - case (valuetypes%float) - allocate (constr%fc(1),source=0.0_wp) - constr%fc(1) = kv%value_f - case (valuetypes%int_array) - n = size(kv%value_ia,1) - allocate (constr%fc(n),source=0.0_wp) - constr%fc(:) = real(kv%value_ia(:)) - case (valuetypes%float_array) - n = size(kv%value_fa,1) - allocate (constr%fc(n),source=0.0_wp) - constr%fc(:) = real(kv%value_fa(:)) - end select - - case ('atoms') - if (allocated(constr%atms)) deallocate (constr%atms) - if (kv%id == valuetypes%int_array) then - n = size(kv%value_ia,1) - allocate (constr%atms(n),source=0) - constr%atms = kv%value_ia - else - allocate (atlist(env%ref%nat),source=.false.) - call get_atlist(env%ref%nat,atlist,kv%rawvalue,env%ref%at) - n = count(atlist) - allocate (constr%atms(n),source=0) - k = 0 - do j = 1,env%ref%nat - if (atlist(j)) then - k = k+1 - constr%atms(k) = j - end if - end do - deallocate (atlist) - end if - constr%n = n - - case ('ref','val') !> constrained value - if (allocated(constr%ref)) deallocate (constr%ref) - select case (kv%id) - case (valuetypes%int) - allocate (constr%ref(1),source=0.0_wp) - constr%ref(1) = kv%value_i - case (valuetypes%float) - allocate (constr%ref(1),source=0.0_wp) - constr%ref(1) = kv%value_f - case (valuetypes%int_array) - n = size(kv%value_ia,1) - allocate (constr%ref(n),source=0.0_wp) - constr%ref(:) = real(kv%value_ia(:)) - case (valuetypes%float_array) - n = size(kv%value_fa,1) - allocate (constr%ref(n),source=0.0_wp) - constr%ref(:) = real(kv%value_fa(:)) - end select - - case ('wscal') !> scaling factor if the wall potential is automatically set up - if (kv%id == valuetypes%int) then - constr%wscal = max(0.0_wp,real(kv%value_i)) - elseif (kv%id == valuetypes%float) then - constr%wscal = max(0.0_wp,kv%value_f) + implicit none + type(systemdata), intent(inout) :: env + type(coord), intent(inout) :: mol + type(datablock), intent(in) :: blk + type(calcdata), intent(inout) :: calc + integer, intent(inout) :: istat + logical :: success + type(constraint) :: constr + integer :: i + logical :: rd + if (blk%header .ne. 'calculation.constraints' .and. & + & blk%header .ne. 'calculation.constraint') return + success = .false. + call constr%deallocate() + do i = 1, blk%nkv + call parse_constraint_auto(env, calc, constr, blk%kv_list(i), success, rd) + if (.not. rd) then + istat = istat + 1 + write (stdout, fmturk) '[['//blk%header//']]-block', blk%kv_list(i)%key + end if + end do + if (success) then + call constr%complete(mol) + call calc%add(constr) end if + return + end subroutine parse_constraintdat + subroutine parse_constraint_auto(env, calc, constr, kv, success, rd) + implicit none + type(systemdata) :: env + type(keyvalue) :: kv + type(constraint) :: constr + logical, intent(inout) :: success + type(calcdata), intent(inout) :: calc + real(wp) :: dum1, dum2, dum3, dum4 + real(wp) :: rabc(3) + integer :: atm1, atm2, atm3, atm4, n, k, j + logical, allocatable :: atlist(:) + logical, intent(out) :: rd + rd = .true. + select case (kv%key) + + case ('freeze') + call get_atlist(env%ref%nat, atlist, kv%rawvalue, env%ref%at) + calc%nfreeze = count(atlist) + call move_alloc(atlist, calc%freezelist) + + case ('type') !> the type of constraint + select case (kv%value_c) + case ('bond', 'bonds'); constr%type = 1 + case ('angle'); constr%type = 2 + case ('dihedral'); constr%type = 3 + case ('wall'); constr%type = 4 + case ('wall_logfermi', 'ellipsoid'); constr%type = 5 + case ('box'); constr%type = 6 + case ('bondrange'); constr%type = 8 + case ('gapdiff'); constr%type = -1 + case ('gapdiff2', 'mecp'); constr%type = -2 + case default + !>--- keyword was recognized, but invalid argument supplied + write (stdout, fmtura) kv%value_c + call creststop(status_config) + end select + if (constr%type /= 0) success = .true. + + case ('fc', 'k', 'forceconstant', 'params') !> force constants or parameters + if (allocated(constr%fc)) deallocate (constr%fc) + select case (kv%id) + case (valuetypes%int) + allocate (constr%fc(1), source=0.0_wp) + constr%fc(1) = kv%value_i + case (valuetypes%float) + allocate (constr%fc(1), source=0.0_wp) + constr%fc(1) = kv%value_f + case (valuetypes%int_array) + n = size(kv%value_ia, 1) + allocate (constr%fc(n), source=0.0_wp) + constr%fc(:) = real(kv%value_ia(:)) + case (valuetypes%float_array) + n = size(kv%value_fa, 1) + allocate (constr%fc(n), source=0.0_wp) + constr%fc(:) = real(kv%value_fa(:)) + end select + + case ('atoms') + if (allocated(constr%atms)) deallocate (constr%atms) + if (kv%id == valuetypes%int_array) then + n = size(kv%value_ia, 1) + allocate (constr%atms(n), source=0) + constr%atms = kv%value_ia + else + allocate (atlist(env%ref%nat), source=.false.) + call get_atlist(env%ref%nat, atlist, kv%rawvalue, env%ref%at) + n = count(atlist) + allocate (constr%atms(n), source=0) + k = 0 + do j = 1, env%ref%nat + if (atlist(j)) then + k = k + 1 + constr%atms(k) = j + end if + end do + deallocate (atlist) + end if + constr%n = n + + case ('ref', 'val') !> constrained value + if (allocated(constr%ref)) deallocate (constr%ref) + select case (kv%id) + case (valuetypes%int) + allocate (constr%ref(1), source=0.0_wp) + constr%ref(1) = kv%value_i + case (valuetypes%float) + allocate (constr%ref(1), source=0.0_wp) + constr%ref(1) = kv%value_f + case (valuetypes%int_array) + n = size(kv%value_ia, 1) + allocate (constr%ref(n), source=0.0_wp) + constr%ref(:) = real(kv%value_ia(:)) + case (valuetypes%float_array) + n = size(kv%value_fa, 1) + allocate (constr%ref(n), source=0.0_wp) + constr%ref(:) = real(kv%value_fa(:)) + end select + + case ('wscal') !> scaling factor if the wall potential is automatically set up + if (kv%id == valuetypes%int) then + constr%wscal = max(0.0_wp, real(kv%value_i)) + elseif (kv%id == valuetypes%float) then + constr%wscal = max(0.0_wp, kv%value_f) + end if !>--- the following are for specifiying keywords in a single line !>--- I don't know it was wise to code them like this because it's hacky, !>--- but i'll leave them so I don't get confused. - case ('bond','bonds') - select case (kv%id) - case (4) !> string - select case (kv%value_c) - case ('all','allauto') - call constr%dummyconstraint(11) - success = .true. - end select - case (5) !> regular array - call constr%rdbondconstraint(kv%na,kv%value_fa) - success = .true. - case (9) !> unspecified array - call constr%analyzedummy(11,kv%na,kv%value_rawa) - success = .true. - case default - success = .false. - end select + case ('bond', 'bonds') + select case (kv%id) + case (4) !> string + select case (kv%value_c) + case ('all', 'allauto') + call constr%dummyconstraint(11) + success = .true. + end select + case (5) !> regular array + call constr%rdbondconstraint(kv%na, kv%value_fa) + success = .true. + case (9) !> unspecified array + call constr%analyzedummy(11, kv%na, kv%value_rawa) + success = .true. + case default + success = .false. + end select - case ('dihedral') - read (kv%value_rawa(1),*) atm1 - read (kv%value_rawa(2),*) atm2 - read (kv%value_rawa(3),*) atm3 - read (kv%value_rawa(4),*) atm4 - read (kv%value_rawa(5),*) dum1 - if (kv%na > 5) then - read (kv%value_rawa(6),*) dum2 - call constr%dihedralconstraint(atm1,atm2,atm3,atm4,dum1,dum2) - else - call constr%dihedralconstraint(atm1,atm2,atm3,atm4,dum1) - end if - success = .true. - - case ('sphere') - dum1 = kv%value_fa(3) !> sphere radius - dum2 = kv%value_fa(1) !> prefactor - dum3 = kv%value_fa(2) !> exponent - call constr%sphereconstraint(0,dum1,dum2,dum3,.false.) - success = .true. - - case ('sphere_logfermi') - dum1 = kv%value_fa(3) !> sphere radius - dum2 = kv%value_fa(1) !> fermi temperature - dum3 = kv%value_fa(2) !> exponent factor - call constr%sphereconstraint(0,dum1,dum2,dum3,.true.) - success = .true. - - case ('ellipsoid','ellipsoid_logfermi') - rabc(1:3) = kv%value_fa(1:3) - if (index(kv%key,'logfermi') .ne. 0) then - dum1 = 300.0_wp - dum2 = 6.0_wp - if (kv%na > 3) dum1 = kv%value_fa(4) - if (kv%na > 4) dum2 = kv%value_fa(5) - call constr%ellipsoid(0,atlist,rabc,dum1,dum2,.true.) - else - dum1 = 1.0_wp - dum2 = 30.0_wp - if (kv%na > 3) dum1 = kv%value_fa(4) - if (kv%na > 4) dum2 = kv%value_fa(5) - call constr%ellipsoid(0,atlist,rabc,dum1,dum2,.false.) - end if - success = .true. - - case ('gapdiff') - dum1 = kv%value_fa(1) - dum2 = kv%value_fa(2) - call constr%gapdiffconstraint(dum1,dum2) - success = .true. - - case ('gapdiff2','mecp') - success = .true. - if (kv%id == 3) then - if (kv%value_b) then - dum1 = 10.0_wp - dum2 = 0.005_wp - dum3 = 0.20_wp - else - success = .false. - end if - else - dum1 = kv%value_fa(1) - dum2 = kv%value_fa(2) - dum3 = kv%value_fa(3) - end if - call constr%gapdiffconstraint2(dum1,dum2,dum3) - - case ('bondrange') - atm1 = nint(kv%value_fa(1)) - atm2 = nint(kv%value_fa(2)) - dum1 = kv%value_fa(3)*aatoau - dum1 = max(0.0_wp,dum1) !> can't be negative - select case (kv%na) - case (3) - dum2 = huge(dum2)/3.0_wp !> some huge value - call constr%bondrangeconstraint(atm1,atm2,dum1,dum2) - case (4) - dum2 = kv%value_fa(4)*aatoau - call constr%bondrangeconstraint(atm1,atm2,dum1,dum2) - case (5) - dum3 = kv%value_fa(5) - call constr%bondrangeconstraint(atm1,atm2,dum1,dum2,beta=dum3) - case (6) - dum4 = kv%value_fa(6) - call constr%bondrangeconstraint(atm1,atm2,dum1,dum2,beta=dum3,T=dum4) - case default - write (stdout,'(a)') '**ERROR** wrong number of arguments in bondrange constraint' - call creststop(status_config) - end select - success = .true. + case ('dihedral') + read (kv%value_rawa(1), *) atm1 + read (kv%value_rawa(2), *) atm2 + read (kv%value_rawa(3), *) atm3 + read (kv%value_rawa(4), *) atm4 + read (kv%value_rawa(5), *) dum1 + if (kv%na > 5) then + read (kv%value_rawa(6), *) dum2 + call constr%dihedralconstraint(atm1, atm2, atm3, atm4, dum1, dum2) + else + call constr%dihedralconstraint(atm1, atm2, atm3, atm4, dum1) + end if + success = .true. + + case ('sphere') + dum1 = kv%value_fa(3) !> sphere radius + dum2 = kv%value_fa(1) !> prefactor + dum3 = kv%value_fa(2) !> exponent + call constr%sphereconstraint(0, dum1, dum2, dum3, .false.) + success = .true. + + case ('sphere_logfermi') + dum1 = kv%value_fa(3) !> sphere radius + dum2 = kv%value_fa(1) !> fermi temperature + dum3 = kv%value_fa(2) !> exponent factor + call constr%sphereconstraint(0, dum1, dum2, dum3, .true.) + success = .true. + + case ('ellipsoid', 'ellipsoid_logfermi') + rabc(1:3) = kv%value_fa(1:3) + if (index(kv%key, 'logfermi') .ne. 0) then + dum1 = 300.0_wp + dum2 = 6.0_wp + if (kv%na > 3) dum1 = kv%value_fa(4) + if (kv%na > 4) dum2 = kv%value_fa(5) + call constr%ellipsoid(0, atlist, rabc, dum1, dum2, .true.) + else + dum1 = 1.0_wp + dum2 = 30.0_wp + if (kv%na > 3) dum1 = kv%value_fa(4) + if (kv%na > 4) dum2 = kv%value_fa(5) + call constr%ellipsoid(0, atlist, rabc, dum1, dum2, .false.) + end if + success = .true. + + case ('gapdiff') + dum1 = kv%value_fa(1) + dum2 = kv%value_fa(2) + call constr%gapdiffconstraint(dum1, dum2) + success = .true. + + case ('gapdiff2', 'mecp') + success = .true. + if (kv%id == 3) then + if (kv%value_b) then + dum1 = 10.0_wp + dum2 = 0.005_wp + dum3 = 0.20_wp + else + success = .false. + end if + else + dum1 = kv%value_fa(1) + dum2 = kv%value_fa(2) + dum3 = kv%value_fa(3) + end if + call constr%gapdiffconstraint2(dum1, dum2, dum3) + + case ('bondrange') + atm1 = nint(kv%value_fa(1)) + atm2 = nint(kv%value_fa(2)) + dum1 = kv%value_fa(3)*aatoau + dum1 = max(0.0_wp, dum1) !> can't be negative + select case (kv%na) + case (3) + dum2 = huge(dum2)/3.0_wp !> some huge value + call constr%bondrangeconstraint(atm1, atm2, dum1, dum2) + case (4) + dum2 = kv%value_fa(4)*aatoau + call constr%bondrangeconstraint(atm1, atm2, dum1, dum2) + case (5) + dum3 = kv%value_fa(5) + call constr%bondrangeconstraint(atm1, atm2, dum1, dum2, beta=dum3) + case (6) + dum4 = kv%value_fa(6) + call constr%bondrangeconstraint(atm1, atm2, dum1, dum2, beta=dum3, T=dum4) + case default + write (stdout, '(a)') '**ERROR** wrong number of arguments in bondrange constraint' + call creststop(status_config) + end select + success = .true. !>-------------- !>-------------- !>-------------- - case default - rd = .false. - return - end select + case default + rd = .false. + return + end select - return - end subroutine parse_constraint_auto + return + end subroutine parse_constraint_auto !========================================================================================! - subroutine parse_scandat(blk,calc,istat) + subroutine parse_scandat(blk, calc, istat) !******************************************* !* The following routines are used to !* read information into the "scan" object !* and add it to a calculation data object !******************************************* - implicit none - type(datablock),intent(in) :: blk - type(calcdata),intent(inout) :: calc - integer,intent(inout) :: istat - logical :: success - type(scantype) :: scn - integer :: i - logical :: rd - if (blk%header .ne. 'calculation.scans') return - do i = 1,blk%nkv - call parse_scan_auto(scn,blk%kv_list(i),success,rd) - if (.not.rd) then - istat = istat+1 - write (stdout,fmturk) '[['//blk%header//']]-block',blk%kv_list(i)%key - end if - if (success) then - call calc%add(scn) - end if - end do - return - end subroutine parse_scandat - subroutine parse_scan_auto(scn,kv,success,rd) - implicit none - type(keyvalue) :: kv - type(scantype) :: scn - logical,intent(out) :: success,rd - real(wp) :: dum1,dum2,dum3 - integer :: atm1,atm2,atm3,atm4 - integer :: nsteps - success = .false. - rd = .true. - call scn%deallocate() - select case (kv%key) - case ('bond','distance') - scn%type = 1 - scn%n = 2 - allocate (scn%atms(2)) - if (kv%id == valuetypes%float_array) then - scn%atms(1) = nint(kv%value_fa(1)) - scn%atms(2) = nint(kv%value_fa(2)) - scn%minval = kv%value_fa(3) - scn%maxval = kv%value_fa(4) - if (kv%na > 4) then - scn%steps = nint(kv%value_fa(5)) - end if - success = .true. - else if (kv%id == valuetypes%int_array) then - scn%atms(1) = kv%value_ia(1) - scn%atms(2) = kv%value_ia(2) - scn%minval = real(kv%value_ia(3)) - scn%maxval = real(kv%value_ia(4)) - if (kv%na > 4) then - scn%steps = kv%value_ia(5) - end if - success = .true. - end if + implicit none + type(datablock), intent(in) :: blk + type(calcdata), intent(inout) :: calc + integer, intent(inout) :: istat + logical :: success + type(scantype) :: scn + integer :: i + logical :: rd + if (blk%header .ne. 'calculation.scans') return + do i = 1, blk%nkv + call parse_scan_auto(scn, blk%kv_list(i), success, rd) + if (.not. rd) then + istat = istat + 1 + write (stdout, fmturk) '[['//blk%header//']]-block', blk%kv_list(i)%key + end if + if (success) then + call calc%add(scn) + end if + end do + return + end subroutine parse_scandat + subroutine parse_scan_auto(scn, kv, success, rd) + implicit none + type(keyvalue) :: kv + type(scantype) :: scn + logical, intent(out) :: success, rd + real(wp) :: dum1, dum2, dum3 + integer :: atm1, atm2, atm3, atm4 + integer :: nsteps + success = .false. + rd = .true. + call scn%deallocate() + select case (kv%key) + case ('bond', 'distance') + scn%type = 1 + scn%n = 2 + allocate (scn%atms(2)) + if (kv%id == valuetypes%float_array) then + scn%atms(1) = nint(kv%value_fa(1)) + scn%atms(2) = nint(kv%value_fa(2)) + scn%minval = kv%value_fa(3) + scn%maxval = kv%value_fa(4) + if (kv%na > 4) then + scn%steps = nint(kv%value_fa(5)) + end if + success = .true. + else if (kv%id == valuetypes%int_array) then + scn%atms(1) = kv%value_ia(1) + scn%atms(2) = kv%value_ia(2) + scn%minval = real(kv%value_ia(3)) + scn%maxval = real(kv%value_ia(4)) + if (kv%na > 4) then + scn%steps = kv%value_ia(5) + end if + success = .true. + end if - case ('dihedral') - scn%type = 3 - scn%n = 2 - write (*,*) kv%value_rawa(:) - write (*,*) kv%value_ia(:) - write (*,*) kv%value_fa(:) - allocate (scn%atms(4)) - - if (kv%id == valuetypes%float_array) then - scn%atms(1) = nint(kv%value_fa(1)) - scn%atms(2) = nint(kv%value_fa(2)) - scn%atms(3) = nint(kv%value_fa(3)) - scn%atms(4) = nint(kv%value_fa(4)) - if (kv%na > 4) then - scn%steps = nint(kv%value_fa(5)) - end if - if (kv%na > 6) then - scn%minval = kv%value_fa(6) - scn%maxval = kv%value_fa(7) - end if - success = .true. - else if (kv%id == valuetypes%int_array) then - scn%atms(1) = kv%value_ia(1) - scn%atms(2) = kv%value_ia(2) - scn%atms(3) = kv%value_ia(3) - scn%atms(4) = kv%value_ia(4) - if (kv%na > 4) then - scn%steps = kv%value_ia(5) - end if - if (kv%na > 6) then - scn%minval = real(kv%value_ia(6)) - scn%maxval = real(kv%value_ia(7)) - end if - success = .true. - end if + case ('dihedral') + scn%type = 3 + scn%n = 2 + write (*, *) kv%value_rawa(:) + write (*, *) kv%value_ia(:) + write (*, *) kv%value_fa(:) + allocate (scn%atms(4)) + + if (kv%id == valuetypes%float_array) then + scn%atms(1) = nint(kv%value_fa(1)) + scn%atms(2) = nint(kv%value_fa(2)) + scn%atms(3) = nint(kv%value_fa(3)) + scn%atms(4) = nint(kv%value_fa(4)) + if (kv%na > 4) then + scn%steps = nint(kv%value_fa(5)) + end if + if (kv%na > 6) then + scn%minval = kv%value_fa(6) + scn%maxval = kv%value_fa(7) + end if + success = .true. + else if (kv%id == valuetypes%int_array) then + scn%atms(1) = kv%value_ia(1) + scn%atms(2) = kv%value_ia(2) + scn%atms(3) = kv%value_ia(3) + scn%atms(4) = kv%value_ia(4) + if (kv%na > 4) then + scn%steps = kv%value_ia(5) + end if + if (kv%na > 6) then + scn%minval = real(kv%value_ia(6)) + scn%maxval = real(kv%value_ia(7)) + end if + success = .true. + end if - case default - rd = .false. - return - end select + case default + rd = .false. + return + end select - return - end subroutine parse_scan_auto + return + end subroutine parse_scan_auto !========================================================================================! - subroutine parse_dynamics_data(env,mddat,dict,included,istat) + subroutine parse_dynamics_data(env, mddat, dict, included, istat) !********************************************* !* The following routines are used to !* read information into the "mddata" object !********************************************* - implicit none - type(systemdata) :: env - type(mddata) :: mddat - type(root_object) :: dict - type(datablock) :: blk - type(calculation_settings) :: newjob - type(constraint) :: newcstr - integer :: i,j,k,l - logical,intent(out) :: included - integer,intent(inout) :: istat - - included = .false. - - do i = 1,dict%nblk - call blk%deallocate() - blk = dict%blk_list(i) - if (blk%header == 'dynamics') then - included = .true. - call parse_mddat(env,blk,mddat,istat) - else if (blk%header == 'dynamics.meta') then - call parse_metadyn(env,blk,mddat,istat) - included = .true. - end if - end do - if (included) then - mddat%requested = .true. - end if - return - end subroutine parse_dynamics_data - subroutine parse_mddat(env,blk,mddat,istat) - implicit none - type(systemdata),intent(inout) :: env - type(datablock),intent(in) :: blk - type(mddata),intent(inout) :: mddat - integer,intent(inout) :: istat - logical,allocatable :: atlist(:) - integer :: i,j,nat - logical :: rd - if (blk%header .ne. 'dynamics') return - nat = env%ref%nat - allocate (atlist(nat),source=.false.) - - do i = 1,blk%nkv - call parse_md(env,mddat,blk%kv_list(i),rd) - if (.not.rd) then - istat = istat+1 - write (stdout,fmturk) '['//blk%header//']-block',blk%kv_list(i)%key - end if - end do - deallocate (atlist) - return - end subroutine parse_mddat - subroutine parse_md_auto(env,mddat,kv,rd) - implicit none - type(systemdata),intent(inout) :: env - type(mddata) :: mddat - type(keyvalue) :: kv - logical,intent(out) :: rd - logical,allocatable :: atlist(:) - integer :: nat,j - logical :: ex - rd = .true. - - select case (kv%key) - case ('active','active_levels') - mddat%active_potentials = kv%value_ia - - case ('includermsd','atlist+') - nat = env%ref%nat - call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) - if (.not.allocated(env%includeRMSD)) allocate (env%includeRMSD(nat),source=0) - do j = 1,nat - if (atlist(j)) env%includeRMSD(j) = 1 + implicit none + type(systemdata) :: env + type(mddata) :: mddat + type(root_object) :: dict + type(datablock) :: blk + type(calculation_settings) :: newjob + type(constraint) :: newcstr + integer :: i, j, k, l + logical, intent(out) :: included + integer, intent(inout) :: istat + + included = .false. + + do i = 1, dict%nblk + call blk%deallocate() + blk = dict%blk_list(i) + if (blk%header == 'dynamics') then + included = .true. + call parse_mddat(env, blk, mddat, istat) + else if (blk%header == 'dynamics.meta') then + call parse_metadyn(env, blk, mddat, istat) + included = .true. + end if end do - - case ('excludermsd','atlist-') + if (included) then + mddat%requested = .true. + end if + return + end subroutine parse_dynamics_data + subroutine parse_mddat(env, blk, mddat, istat) + implicit none + type(systemdata), intent(inout) :: env + type(datablock), intent(in) :: blk + type(mddata), intent(inout) :: mddat + integer, intent(inout) :: istat + logical, allocatable :: atlist(:) + integer :: i, j, nat + logical :: rd + if (blk%header .ne. 'dynamics') return nat = env%ref%nat - call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) - if (.not.allocated(env%includeRMSD)) allocate (env%includeRMSD(nat),source=1) - do j = 1,nat - if (atlist(j)) env%includeRMSD(j) = 0 + allocate (atlist(nat), source=.false.) + + do i = 1, blk%nkv + call parse_md(env, mddat, blk%kv_list(i), rd) + if (.not. rd) then + istat = istat + 1 + write (stdout, fmturk) '['//blk%header//']-block', blk%kv_list(i)%key + end if end do + deallocate (atlist) + return + end subroutine parse_mddat + subroutine parse_md_auto(env, mddat, kv, rd) + implicit none + type(systemdata), intent(inout) :: env + type(mddata) :: mddat + type(keyvalue) :: kv + logical, intent(out) :: rd + logical, allocatable :: atlist(:) + integer :: nat, j + logical :: ex + rd = .true. + + select case (kv%key) + case ('active', 'active_levels') + mddat%active_potentials = kv%value_ia + + case ('includermsd', 'atlist+') + nat = env%ref%nat + call get_atlist(nat, atlist, kv%rawvalue, env%ref%at) + if (.not. allocated(env%includeRMSD)) allocate (env%includeRMSD(nat), source=0) + do j = 1, nat + if (atlist(j)) env%includeRMSD(j) = 1 + end do + + case ('excludermsd', 'atlist-') + nat = env%ref%nat + call get_atlist(nat, atlist, kv%rawvalue, env%ref%at) + if (.not. allocated(env%includeRMSD)) allocate (env%includeRMSD(nat), source=1) + do j = 1, nat + if (atlist(j)) env%includeRMSD(j) = 0 + end do + + case ('length', 'length_ps') + mddat%length_ps = kv%value_f + env%user_mdtime = .true. + case ('dump') + mddat%dumpstep = kv%value_f + case ('hmass') + mddat%md_hmass = kv%value_f + case ('tstep') + mddat%tstep = kv%value_f + case ('t', 'temp', 'temperature') + mddat%tsoll = kv%value_f + mddat%thermostat = .true. + + case ('shake') + select case (kv%id) + case (valuetypes%int) + if (kv%value_i <= 0) then + mddat%shake = .false. + else + mddat%shake = .true. + mddat%shk%shake_mode = min(kv%value_i, 2) + end if + case (valuetypes%bool) + mddat%shake = kv%value_b + if (kv%value_b) mddat%shk%shake_mode = 1 + end select + case ('printstep') + mddat%printstep = kv%value_i + case ('blocklength', 'blockl') + mddat%blockl = kv%value_i + + case ('restart') + inquire (file=trim(kv%value_c), exist=ex) + if (ex) then + mddat%restart = .true. + mddat%restartfile = trim(kv%value_c) + end if - case ('length','length_ps') - mddat%length_ps = kv%value_f - env%user_mdtime = .true. - case ('dump') - mddat%dumpstep = kv%value_f - case ('hmass') - mddat%md_hmass = kv%value_f - case ('tstep') - mddat%tstep = kv%value_f - case ('t','temp','temperature') - mddat%tsoll = kv%value_f - mddat%thermostat = .true. - - case ('shake') - select case (kv%id) - case (valuetypes%int) - if (kv%value_i <= 0) then - mddat%shake = .false. - else - mddat%shake = .true. - mddat%shk%shake_mode = min(kv%value_i,2) - end if - case (valuetypes%bool) - mddat%shake = kv%value_b - if (kv%value_b) mddat%shk%shake_mode = 1 + case default + rd = .false. + return end select - case ('printstep') - mddat%printstep = kv%value_i - case ('blocklength','blockl') - mddat%blockl = kv%value_i - - case ('restart') - inquire (file=trim(kv%value_c),exist=ex) - if (ex) then - mddat%restart = .true. - mddat%restartfile = trim(kv%value_c) - end if - case default - rd = .false. - return - end select - - end subroutine parse_md_auto + end subroutine parse_md_auto !========================================================================================! - subroutine parse_metadyn(env,blk,mddat,istat) + subroutine parse_metadyn(env, blk, mddat, istat) !************************************************** !* The following routines are used to !* read information into the "metadynamics" object !* and add it to a mol.dynamics data object !*************************************************** - implicit none - type(systemdata),intent(inout) :: env - type(datablock),intent(in) :: blk - type(mddata),intent(inout) :: mddat - integer,intent(inout) :: istat - logical :: success - type(mtdpot) :: mtd - integer :: i,k - logical :: rd - call mtd%deallocate() - success = .false. - if (blk%header .ne. 'dynamics.meta') return - do i = 1,blk%nkv - call parse_metadyn_auto(env,mtd,blk%kv_list(i),success,rd) - if (.not.rd) then - istat = istat+1 - write (stdout,fmturk) '[['//blk%header//']]-block',blk%kv_list(i)%key - end if - end do - if (success) call mddat%add(mtd) - return - end subroutine parse_metadyn - subroutine parse_metadyn_auto(env,mtd,kv,success,rd) - implicit none - type(systemdata),intent(inout) :: env - type(keyvalue) :: kv - type(mtdpot) :: mtd - logical,intent(inout) :: success - logical,intent(out) :: rd - integer :: j,nat - logical,allocatable :: atlist(:) - rd = .true. - - select case (kv%key) + implicit none + type(systemdata), intent(inout) :: env + type(datablock), intent(in) :: blk + type(mddata), intent(inout) :: mddat + integer, intent(inout) :: istat + logical :: success + type(mtdpot) :: mtd + integer :: i, k + logical :: rd + call mtd%deallocate() + success = .false. + if (blk%header .ne. 'dynamics.meta') return + do i = 1, blk%nkv + call parse_metadyn_auto(env, mtd, blk%kv_list(i), success, rd) + if (.not. rd) then + istat = istat + 1 + write (stdout, fmturk) '[['//blk%header//']]-block', blk%kv_list(i)%key + end if + end do + if (success) call mddat%add(mtd) + return + end subroutine parse_metadyn + subroutine parse_metadyn_auto(env, mtd, kv, success, rd) + implicit none + type(systemdata), intent(inout) :: env + type(keyvalue) :: kv + type(mtdpot) :: mtd + logical, intent(inout) :: success + logical, intent(out) :: rd + integer :: j, nat + logical, allocatable :: atlist(:) + rd = .true. + + select case (kv%key) !>--- floats - case ('alpha') - mtd%alpha = kv%value_f - case ('kpush') - mtd%kpush = kv%value_f - case ('dump','dump_fs') - mtd%cvdump_fs = kv%value_f - case ('dump_ps') - mtd%cvdump_fs = kv%value_f*1000.0_wp - case ('ramp') - mtd%ramp = kv%value_f + case ('alpha') + mtd%alpha = kv%value_f + case ('kpush') + mtd%kpush = kv%value_f + case ('dump', 'dump_fs') + mtd%cvdump_fs = kv%value_f + case ('dump_ps') + mtd%cvdump_fs = kv%value_f*1000.0_wp + case ('ramp') + mtd%ramp = kv%value_f !>--- strings - case ('type') - success = .true. - select case (kv%id) - case (valuetypes%int) - mtd%mtdtype = kv%value_i - case (valuetypes%string) - select case (kv%value_c) - case ('rmsd') - mtd%mtdtype = cv_rmsd - case default - mtd%mtdtype = 0 - end select - end select - case ('biasfile') - mtd%mtdtype = cv_rmsd_static - mtd%biasfile = kv%value_c - - case ('includermsd','atlist+') - nat = env%ref%nat - call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) - if (.not.allocated(mtd%atinclude)) allocate (mtd%atinclude(nat),source=.false.) - do j = 1,nat - if (atlist(j)) mtd%atinclude(j) = .true. - end do + case ('type') + success = .true. + select case (kv%id) + case (valuetypes%int) + mtd%mtdtype = kv%value_i + case (valuetypes%string) + select case (kv%value_c) + case ('rmsd') + mtd%mtdtype = cv_rmsd + case default + mtd%mtdtype = 0 + end select + end select + case ('biasfile') + mtd%mtdtype = cv_rmsd_static + mtd%biasfile = kv%value_c + + case ('includermsd', 'atlist+') + nat = env%ref%nat + call get_atlist(nat, atlist, kv%rawvalue, env%ref%at) + if (.not. allocated(mtd%atinclude)) allocate (mtd%atinclude(nat), source=.false.) + do j = 1, nat + if (atlist(j)) mtd%atinclude(j) = .true. + end do + + case ('excludermsd', 'atlist-') + nat = env%ref%nat + call get_atlist(nat, atlist, kv%rawvalue, env%ref%at) + if (.not. allocated(mtd%atinclude)) allocate (mtd%atinclude(nat), source=.true.) + do j = 1, nat + if (atlist(j)) mtd%atinclude(j) = .false. + end do - case ('excludermsd','atlist-') - nat = env%ref%nat - call get_atlist(nat,atlist,kv%rawvalue,env%ref%at) - if (.not.allocated(mtd%atinclude)) allocate (mtd%atinclude(nat),source=.true.) - do j = 1,nat - if (atlist(j)) mtd%atinclude(j) = .false. - end do - - case default - rd = .false. - return - end select + case default + rd = .false. + return + end select - end subroutine parse_metadyn_auto + end subroutine parse_metadyn_auto !========================================================================================! - subroutine parse_basinhopping_data(env,bh,dict,included,istat) + subroutine parse_basinhopping_data(env, bh, dict, included, istat) !********************************************** !* The following routines are used to !* read information into the "bh_class" object !********************************************** - implicit none - type(systemdata) :: env - type(bh_class) :: bh - type(root_object) :: dict - type(datablock) :: blk - type(calculation_settings) :: newjob - type(constraint) :: newcstr - integer :: i,j,k,l - logical,intent(out) :: included - integer,intent(inout) :: istat - - included = .false. - - do i = 1,dict%nblk - call blk%deallocate() - blk = dict%blk_list(i) - if (blk%header == 'basinhopping') then - included = .true. - call parse_bh_class(env,blk,bh,istat) - end if - end do - return - end subroutine parse_basinhopping_data - subroutine parse_bh_class(env,blk,bh,istat) - implicit none - type(systemdata),intent(inout) :: env - type(datablock),intent(in) :: blk - type(bh_class),intent(inout) :: bh - integer,intent(inout) :: istat - integer :: i,j,nat - logical :: rd - if (blk%header .ne. 'basinhopping') return - - do i = 1,blk%nkv - call parse_bh_auto(env,bh,blk%kv_list(i),rd) - if (.not.rd) then - istat = istat+1 - write (stdout,fmturk) '['//blk%header//']-block',blk%kv_list(i)%key - end if - end do - return - end subroutine parse_bh_class - subroutine parse_bh_auto(env,bh,kv,rd) - implicit none - type(systemdata),intent(inout) :: env - type(bh_class) :: bh - type(keyvalue) :: kv - logical,intent(out) :: rd - logical,allocatable :: atlist(:) - integer :: n,j - logical :: ex - rd = .true. - - select case (kv%key) - case ('maxiter') !> these are NOT the BH steps! - bh%maxiter = max(1,kv%value_i) - - case ('maxsave') - bh%maxsave = kv%value_i - - case ('seed') - if (.not.allocated(bh%seed)) allocate (bh%seed) - bh%seed = kv%value_i - - case ('step','stepsize') - select case (kv%id) - case (valuetypes%int) - bh%stepsize(1) = real(kv%value_i) - case (valuetypes%float) - bh%stepsize(1) = kv%value_f - case (valuetypes%float_array) - n = min(size(kv%value_fa,1),3) - bh%stepsize(1:n) = kv%value_fa(1:n) - case default - !>--- keyword was recognized, but invalid argument supplied - write (stdout,fmtura) kv%rawvalue - call creststop(status_config) - end select - - case ('steps','maxsteps') !> these are the BH steps - bh%maxsteps = kv%value_i + implicit none + type(systemdata) :: env + type(bh_class) :: bh + type(root_object) :: dict + type(datablock) :: blk + type(calculation_settings) :: newjob + type(constraint) :: newcstr + integer :: i, j, k, l + logical, intent(out) :: included + integer, intent(inout) :: istat + + included = .false. + + do i = 1, dict%nblk + call blk%deallocate() + blk = dict%blk_list(i) + if (blk%header == 'basinhopping') then + included = .true. + call parse_bh_class(env, blk, bh, istat) + end if + end do + return + end subroutine parse_basinhopping_data + subroutine parse_bh_class(env, blk, bh, istat) + implicit none + type(systemdata), intent(inout) :: env + type(datablock), intent(in) :: blk + type(bh_class), intent(inout) :: bh + integer, intent(inout) :: istat + integer :: i, j, nat + logical :: rd + if (blk%header .ne. 'basinhopping') return + + do i = 1, blk%nkv + call parse_bh_auto(env, bh, blk%kv_list(i), rd) + if (.not. rd) then + istat = istat + 1 + write (stdout, fmturk) '['//blk%header//']-block', blk%kv_list(i)%key + end if + end do + return + end subroutine parse_bh_class + subroutine parse_bh_auto(env, bh, kv, rd) + implicit none + type(systemdata), intent(inout) :: env + type(bh_class) :: bh + type(keyvalue) :: kv + logical, intent(out) :: rd + logical, allocatable :: atlist(:) + integer :: n, j + logical :: ex + rd = .true. + + select case (kv%key) + case ('maxiter') !> these are NOT the BH steps! + bh%maxiter = max(1, kv%value_i) + + case ('maxsave') + bh%maxsave = kv%value_i + + case ('seed') + if (.not. allocated(bh%seed)) allocate (bh%seed) + bh%seed = kv%value_i + + case ('step', 'stepsize') + select case (kv%id) + case (valuetypes%int) + bh%stepsize(1) = real(kv%value_i) + case (valuetypes%float) + bh%stepsize(1) = kv%value_f + case (valuetypes%float_array) + n = min(size(kv%value_fa, 1), 3) + bh%stepsize(1:n) = kv%value_fa(1:n) + case default + !>--- keyword was recognized, but invalid argument supplied + write (stdout, fmtura) kv%rawvalue + call creststop(status_config) + end select + + case ('steps', 'maxsteps') !> these are the BH steps + bh%maxsteps = kv%value_i + + case ('steptype') + select case (kv%value_c) + case ('cartesian') + bh%steptype = 0 + case ('internal') + bh%steptype = 1 + case ('dihedral') + bh%steptype = 2 + case ('intermol') + bh%steptype = 3 + case default + write (stdout, fmtura) trim(kv%value_c) + call creststop(status_config) + end select + + case ('temp', 'T') + bh%temp = kv%value_f + + case ('parallel') + bh%parallel = kv%value_b - case ('steptype') - select case (kv%value_c) - case ('cartesian') - bh%steptype = 0 - case ('internal') - bh%steptype = 1 - case ('dihedral') - bh%steptype = 2 - case ('intermol') - bh%steptype = 3 case default - write (stdout,fmtura) trim(kv%value_c) - call creststop(status_config) + rd = .false. + return end select - case ('temp','T') - bh%temp = kv%value_f - - case ('parallel') - bh%parallel = kv%value_b - - case default - rd = .false. - return - end select - - end subroutine parse_bh_auto + end subroutine parse_bh_auto !========================================================================================! !========================================================================================! diff --git a/subprojects/tblite b/subprojects/tblite index 6f6cd7d2..660d1678 160000 --- a/subprojects/tblite +++ b/subprojects/tblite @@ -1 +1 @@ -Subproject commit 6f6cd7d20d97b22ef00d420904343c7bb8e2afdf +Subproject commit 660d1678d6f36999d7ffda6e710d5ff00ff2f8ff From 231b456662fb4489576ef3dd5b1f1ac8ecbca52d Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 13 Mar 2026 22:06:49 +0100 Subject: [PATCH 214/374] alternate mlip keyword --- src/parsing/parse_calcdata.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index c5c4bfd3..0460fa58 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -353,7 +353,7 @@ subroutine parse_setting_auto(env,job,kv,rd) case ('mlip_modelpath') job%MPAR%modelpath = kv%value_c - case ('mlip_modelsize') + case ('mlip_modelsize','mlip_modelname') job%MPAR%modelsize = kv%value_c case ('orca_cmd') From 9dc0ea42da36439e39b4bfb72584ab978962ba9b Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 13 Mar 2026 22:20:51 +0100 Subject: [PATCH 215/374] Add mstore as submodule (tblite dependency) --- .gitmodules | 3 +++ CMakeLists.txt | 1 + config/modules/Findmstore.cmake | 25 +++++++++++++++++++++++++ subprojects/.gitignore | 4 +--- subprojects/mstore | 1 + subprojects/mstore.wrap | 3 +++ 6 files changed, 34 insertions(+), 3 deletions(-) create mode 100644 config/modules/Findmstore.cmake create mode 160000 subprojects/mstore create mode 100644 subprojects/mstore.wrap diff --git a/.gitmodules b/.gitmodules index bc57262b..30f22858 100644 --- a/.gitmodules +++ b/.gitmodules @@ -33,3 +33,6 @@ [submodule "subprojects/mctc-lib"] path = subprojects/mctc-lib url = https://github.com/grimme-lab/mctc-lib.git +[submodule "subprojects/mstore"] + path = subprojects/mstore + url = https://github.com/grimme-lab/mstore diff --git a/CMakeLists.txt b/CMakeLists.txt index af758a01..352588a8 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -92,6 +92,7 @@ endif() # tblite if(NOT TARGET "tblite::tblite" AND WITH_TBLITE) find_package("mctc-lib" REQUIRED) + find_package("mstore" REQUIRED) find_package("dftd4" REQUIRED) find_package("tblite" REQUIRED) add_compile_definitions(WITH_TBLITE) diff --git a/config/modules/Findmstore.cmake b/config/modules/Findmstore.cmake new file mode 100644 index 00000000..104e3ff8 --- /dev/null +++ b/config/modules/Findmstore.cmake @@ -0,0 +1,25 @@ +set(_lib "mstore") +set(_pkg "MSTORE") +set(_url "https://github.com/grimme-lab/mstore") + +# Discovery method order can be overridden by the parent project, e.g.: +# set(mstore_FIND_METHOD "subproject" "cmake") +if(NOT DEFINED "${_pkg}_FIND_METHOD") + set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") +endif() + +# Reuse whichever utils macro your main project already provides. +# Replace "crest-utils" with the actual name if yours differs. +include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") + +crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}") + +set(found FALSE) +if(TARGET "mstore::mstore") + set(found TRUE) +endif() +message(STATUS "Found mstore: ${found}") + +unset(_lib) +unset(_pkg) +unset(_url) diff --git a/subprojects/.gitignore b/subprojects/.gitignore index 8f8fda32..7e678e56 100644 --- a/subprojects/.gitignore +++ b/subprojects/.gitignore @@ -1,10 +1,7 @@ /*/ json-fortran-8.2.5.wrap -!dftd4.wrap -mstore.wrap multicharge.wrap s-dftd3.wrap -!mctc-lib.wrap xhcff lammps* @@ -18,6 +15,7 @@ lammps* !fmlip_relay !dftd4 !mctc-lib +!mstore !packagefiles !packagefiles/tblite diff --git a/subprojects/mstore b/subprojects/mstore new file mode 160000 index 00000000..10a3437b --- /dev/null +++ b/subprojects/mstore @@ -0,0 +1 @@ +Subproject commit 10a3437b3634dd4464557580ae36c1ed72535f6c diff --git a/subprojects/mstore.wrap b/subprojects/mstore.wrap new file mode 100644 index 00000000..0b2aa233 --- /dev/null +++ b/subprojects/mstore.wrap @@ -0,0 +1,3 @@ +[wrap-git] +directory = mstore +url = https://github.com/grimme-lab/mstore From ce898c9c842d3fb056626a6a82d9d6a7beebb7cf Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 13 Mar 2026 22:26:40 +0100 Subject: [PATCH 216/374] Add multicharge as submodule (tblite dependency) --- .gitmodules | 3 +++ CMakeLists.txt | 10 ++++++---- config/modules/Findmulticharge.cmake | 25 +++++++++++++++++++++++++ subprojects/.gitignore | 2 +- subprojects/multicharge | 1 + 5 files changed, 36 insertions(+), 5 deletions(-) create mode 100644 config/modules/Findmulticharge.cmake create mode 160000 subprojects/multicharge diff --git a/.gitmodules b/.gitmodules index 30f22858..c7fa657c 100644 --- a/.gitmodules +++ b/.gitmodules @@ -36,3 +36,6 @@ [submodule "subprojects/mstore"] path = subprojects/mstore url = https://github.com/grimme-lab/mstore +[submodule "subprojects/multicharge"] + path = subprojects/multicharge + url = https://github.com/grimme-lab/multicharge diff --git a/CMakeLists.txt b/CMakeLists.txt index 352588a8..a19a0080 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -91,10 +91,12 @@ endif() # tblite if(NOT TARGET "tblite::tblite" AND WITH_TBLITE) - find_package("mctc-lib" REQUIRED) - find_package("mstore" REQUIRED) - find_package("dftd4" REQUIRED) - find_package("tblite" REQUIRED) + find_package("mctc-lib" REQUIRED) + find_package("mstore" REQUIRED) + find_package("multicharge" REQUIRED) + find_package("dftd4" REQUIRED) + + find_package("tblite" REQUIRED) add_compile_definitions(WITH_TBLITE) endif() diff --git a/config/modules/Findmulticharge.cmake b/config/modules/Findmulticharge.cmake new file mode 100644 index 00000000..c67ba0fa --- /dev/null +++ b/config/modules/Findmulticharge.cmake @@ -0,0 +1,25 @@ +set(_lib "multicharge") +set(_pkg "MULTICHARGE") +set(_url "https://github.com/grimme-lab/multicharge") + +# Discovery method order can be overridden by the parent project, e.g.: +# set(multicharge_FIND_METHOD "subproject" "cmake") +if(NOT DEFINED "${_pkg}_FIND_METHOD") + set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") +endif() + +# Reuse whichever utils macro your main project already provides. +# Replace "crest-utils" with the actual name if yours differs. +include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") + +crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}") + +set(found FALSE) +if(TARGET "multicharge::multicharge") + set(found TRUE) +endif() +message(STATUS "Found multicharge: ${found}") + +unset(_lib) +unset(_pkg) +unset(_url) diff --git a/subprojects/.gitignore b/subprojects/.gitignore index 7e678e56..14cbb0ac 100644 --- a/subprojects/.gitignore +++ b/subprojects/.gitignore @@ -1,6 +1,5 @@ /*/ json-fortran-8.2.5.wrap -multicharge.wrap s-dftd3.wrap xhcff lammps* @@ -16,6 +15,7 @@ lammps* !dftd4 !mctc-lib !mstore +!multicharge !packagefiles !packagefiles/tblite diff --git a/subprojects/multicharge b/subprojects/multicharge new file mode 160000 index 00000000..6a5d63f9 --- /dev/null +++ b/subprojects/multicharge @@ -0,0 +1 @@ +Subproject commit 6a5d63f9e9e29dcf13cc47cc27f33bf9015681bf From 820e3ad04aa30a2a8b4cb0f5e0472ac06080d8f6 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 13 Mar 2026 22:36:45 +0100 Subject: [PATCH 217/374] change multicharge version to something dftd4 compliant --- config/modules/Findmulticharge.cmake | 3 ++- subprojects/multicharge | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/config/modules/Findmulticharge.cmake b/config/modules/Findmulticharge.cmake index c67ba0fa..5f23d6a9 100644 --- a/config/modules/Findmulticharge.cmake +++ b/config/modules/Findmulticharge.cmake @@ -1,6 +1,7 @@ set(_lib "multicharge") set(_pkg "MULTICHARGE") set(_url "https://github.com/grimme-lab/multicharge") +set(_branch "v0.3.0") # Discovery method order can be overridden by the parent project, e.g.: # set(multicharge_FIND_METHOD "subproject" "cmake") @@ -12,7 +13,7 @@ endif() # Replace "crest-utils" with the actual name if yours differs. include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") -crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}") +crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}" "${_branch}") set(found FALSE) if(TARGET "multicharge::multicharge") diff --git a/subprojects/multicharge b/subprojects/multicharge index 6a5d63f9..282626e6 160000 --- a/subprojects/multicharge +++ b/subprojects/multicharge @@ -1 +1 @@ -Subproject commit 6a5d63f9e9e29dcf13cc47cc27f33bf9015681bf +Subproject commit 282626e690aa7db2aec448d9032636a5cd75f25c From 87c8d9e938f505f766e18d4c596958df60de3af3 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 13 Mar 2026 22:47:18 +0100 Subject: [PATCH 218/374] add s-dftd3 submodule (tblite dependency) --- .gitmodules | 3 +++ CMakeLists.txt | 2 +- config/modules/Finds-dftd3.cmake | 43 ++++++++++++++++++++++++++++++++ subprojects/.gitignore | 2 +- subprojects/s-dftd3 | 1 + subprojects/s-dftd3.wrap | 2 ++ 6 files changed, 51 insertions(+), 2 deletions(-) create mode 100644 config/modules/Finds-dftd3.cmake create mode 160000 subprojects/s-dftd3 create mode 100644 subprojects/s-dftd3.wrap diff --git a/.gitmodules b/.gitmodules index c7fa657c..9f61565e 100644 --- a/.gitmodules +++ b/.gitmodules @@ -39,3 +39,6 @@ [submodule "subprojects/multicharge"] path = subprojects/multicharge url = https://github.com/grimme-lab/multicharge +[submodule "subprojects/s-dftd3"] + path = subprojects/s-dftd3 + url = https://github.com/dftd3/simple-dftd3 diff --git a/CMakeLists.txt b/CMakeLists.txt index a19a0080..19f1d780 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -95,7 +95,7 @@ if(NOT TARGET "tblite::tblite" AND WITH_TBLITE) find_package("mstore" REQUIRED) find_package("multicharge" REQUIRED) find_package("dftd4" REQUIRED) - + find_package("s-dftd3" REQUIRED) find_package("tblite" REQUIRED) add_compile_definitions(WITH_TBLITE) endif() diff --git a/config/modules/Finds-dftd3.cmake b/config/modules/Finds-dftd3.cmake new file mode 100644 index 00000000..2ea1fff5 --- /dev/null +++ b/config/modules/Finds-dftd3.cmake @@ -0,0 +1,43 @@ +# This file is part of crest. +# SPDX-Identifier: LGPL-3.0-or-later +# +# crest is free software: you can redistribute it and/or modify it under +# the terms of the GNU Lesser General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# crest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public License +# along with crest. If not, see . + +set(_lib "s-dftd3") +set(_pkg "SDFTD3") +set(_url "https://github.com/dftd3/simple-dftd3") +set(_branch "v1.2.1") + +if(NOT DEFINED "${_pkg}_FIND_METHOD") + set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") +endif() + +include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") + +set(temp_with_tests ${WITH_TESTS}) # Save the current value of WITH_TESTS +set(WITH_TESTS FALSE CACHE BOOL "Temporarily disable tests for the s-dftd3 subproject" FORCE) +set(WITH_API FALSE) +crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}" "${_branch}") + +set(found FALSE) +if(TARGET "s-dftd3::s-dftd3") + set (found TRUE) +endif() +message(STATUS "Found s-dftd3: ${found}") + +set(WITH_TESTS ${temp_with_tests} CACHE BOOL "Enable tests for the main project" FORCE) + +unset(_lib) +unset(_pkg) +unset(_url) diff --git a/subprojects/.gitignore b/subprojects/.gitignore index 14cbb0ac..9ac048cd 100644 --- a/subprojects/.gitignore +++ b/subprojects/.gitignore @@ -1,6 +1,5 @@ /*/ json-fortran-8.2.5.wrap -s-dftd3.wrap xhcff lammps* @@ -16,6 +15,7 @@ lammps* !mctc-lib !mstore !multicharge +!s-dftd3 !packagefiles !packagefiles/tblite diff --git a/subprojects/s-dftd3 b/subprojects/s-dftd3 new file mode 160000 index 00000000..87efc010 --- /dev/null +++ b/subprojects/s-dftd3 @@ -0,0 +1 @@ +Subproject commit 87efc010cd74f84d273909ce1470eb63ddb07305 diff --git a/subprojects/s-dftd3.wrap b/subprojects/s-dftd3.wrap new file mode 100644 index 00000000..938c0a11 --- /dev/null +++ b/subprojects/s-dftd3.wrap @@ -0,0 +1,2 @@ +[wrap-redirect] +filename = tblite/subprojects/s-dftd3.wrap From 48632b38e4dc6b42166fcfb0093951c48307a8db Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 14 Mar 2026 22:08:37 +0100 Subject: [PATCH 219/374] Start another attempt at redoing the meson build system --- .gitignore | 3 +- BUILD.md | 292 ++++++++++++++++++++++ config/gnu.ini | 16 ++ config/intel-classic.ini | 18 ++ config/intel-fortran-gnu-c.ini | 25 ++ config/intel-llvm.ini | 15 ++ config/meson.build | 439 ++++++++++++++------------------- meson.build | 352 ++++++++++++++++++++++---- meson_options.txt | 135 +++++----- subprojects/dftd4.wrap | 7 +- subprojects/fmlip_relay.wrap | 10 + subprojects/gfn0.wrap | 7 +- subprojects/gfnff.wrap | 7 +- subprojects/libpvol.wrap | 5 +- subprojects/lwoniom.wrap | 7 +- subprojects/mctc-lib.wrap | 6 +- subprojects/mstore.wrap | 6 +- subprojects/multicharge.wrap | 7 + subprojects/s-dftd3.wrap | 9 +- subprojects/tblite.wrap | 9 +- subprojects/test-drive.wrap | 7 + subprojects/toml-f.wrap | 5 +- test/meson.build | 39 +++ 23 files changed, 1040 insertions(+), 386 deletions(-) create mode 100644 BUILD.md create mode 100644 config/gnu.ini create mode 100644 config/intel-classic.ini create mode 100644 config/intel-fortran-gnu-c.ini create mode 100644 config/intel-llvm.ini create mode 100644 subprojects/fmlip_relay.wrap create mode 100644 subprojects/multicharge.wrap create mode 100644 subprojects/test-drive.wrap create mode 100644 test/meson.build diff --git a/.gitignore b/.gitignore index cfeeb127..a1f0bcd0 100644 --- a/.gitignore +++ b/.gitignore @@ -12,4 +12,5 @@ _dist* src/crest bin/ subprojects/.wraplock -subprojects/test-drive.wrap +meson_build/ +meson_build_* diff --git a/BUILD.md b/BUILD.md new file mode 100644 index 00000000..ca5bab10 --- /dev/null +++ b/BUILD.md @@ -0,0 +1,292 @@ +# Building crest with Meson + +## Prerequisites + +| Tool | Minimum version | Notes | +|------|----------------|-------| +| [Meson](https://mesonbuild.com) | 0.57.0 | `pip install meson` or distro package | +| [Ninja](https://ninja-build.org) | 1.10 | usually installed alongside meson | +| Fortran compiler | — | gfortran ≥ 10, ifort ≥ 2021, or ifx ≥ 2023 | +| C compiler | — | gcc or the matching Intel C compiler | +| LAPACK + BLAS | — | OpenBLAS, Intel MKL, or netlib | +| OpenMP | — | libgomp (GNU) or libomp/libiomp5 (Intel) | + +Optional (auto-detected or pulled from `subprojects/`): + +- tblite, toml-f, GFN-FF, GFN0-xTB, libpvol, lwONIOM, fmlip-relay +- test-drive (only for `--tests`) + +--- + +## Quick start + +```sh +# Configure (defaults: release build, OpenBLAS/auto LAPACK, OpenMP on, all +# optional libs auto-detected, unit tests enabled) +meson setup build + +# Compile +ninja -C build + +# Run tests +ninja -C build test + +# Install to /usr/local +ninja -C build install +``` + +--- + +## Compiler selection + +The build system auto-detects whatever Fortran/C compilers are first on +`$PATH`. Use the native-file templates in `config/` to pin a specific +toolchain: + +```sh +# Pure GNU (gfortran + gcc) +meson setup build --native-file config/gnu.ini + +# Intel LLVM (ifx + icx) — oneAPI 2023+ +source /opt/intel/oneapi/setvars.sh +meson setup build --native-file config/intel-llvm.ini + +# Intel classic (ifort + icc) — oneAPI 2022 or earlier +meson setup build --native-file config/intel-classic.ini + +# Mixed: Intel Fortran (ifx) + GNU C (gcc) +meson setup build --native-file config/intel-fortran-gnu-c.ini +``` + +Or set compilers directly via environment variables (older style): + +```sh +FC=gfortran CC=gcc meson setup build +FC=ifort CC=icc meson setup build +FC=ifx CC=icx meson setup build +``` + +--- + +## Build options + +Pass options with `-D` at configure time, or modify with `meson configure`: + +| Option | Default | Description | +|--------|---------|-------------| +| `openmp` | `true` | Enable OpenMP parallelisation | +| `lapack` | `auto` | LAPACK/BLAS provider: `auto`, `openblas`, `mkl`, `netlib`, `custom` | +| `lapack_libs` | `[]` | Library names for `lapack=custom` | +| `blas_libs` | `[]` | Library names for `lapack=custom` | +| `static` | `false` | Link a fully static binary | +| `tblite` | `auto` | tblite semiempirical library | +| `toml-f` | `auto` | TOML-Fortran (file-based input) | +| `gfn0` | `auto` | GFN0-xTB library | +| `gfnff` | `auto` | GFN-FF library | +| `libpvol` | `auto` | libpvol (volume computation) | +| `lwoniom` | `auto` | lwONIOM | +| `fmlip-relay` | `auto` | fmlip-relay ML/IP interface | +| `tests` | `true` | Build unit tests | + +Feature options (`auto` / `enabled` / `disabled`): + +- `auto` — use it if found, silently skip if not +- `enabled` — require it; fail the build if not found +- `disabled` — never use it even if installed + +Examples: + +```sh +# Disable all optional libraries (minimal build) +meson setup build -Dtblite=disabled -Dtoml-f=disabled \ + -Dgfn0=disabled -Dgfnff=disabled \ + -Dlibpvol=disabled -Dlwoniom=disabled \ + -Dfmlip-relay=disabled + +# Require tblite (fail if not found) +meson setup build -Dtblite=enabled + +# Debug build with bounds checking +meson setup build --buildtype=debug + +# Change an option after configuration +meson configure build -Dopenmp=false +``` + +--- + +## LAPACK / BLAS selection + +### Auto (default) + +- For Intel compilers: tries MKL first, then OpenBLAS, then netlib +- For GNU: tries OpenBLAS first, then MKL (with `mkl_gnu_thread`), then netlib + +```sh +meson setup build -Dlapack=auto # (this is the default) +``` + +### OpenBLAS + +```sh +meson setup build -Dlapack=openblas +``` + +OpenBLAS bundles both BLAS and LAPACK. Make sure `libopenblas-dev` (Debian/Ubuntu) +or `openblas-devel` (RHEL/Fedora) is installed, or that `pkg-config --exists openblas` +succeeds. + +### Intel MKL + +```sh +source /opt/intel/oneapi/setvars.sh +meson setup build -Dlapack=mkl +``` + +The build system selects the correct threading layer automatically: + +| Fortran compiler | MKL threading layer | OpenMP runtime | +|-----------------|---------------------|----------------| +| gfortran | `mkl_gnu_thread` | libgomp | +| ifort / ifx | `mkl_intel_thread` | libiomp5 / libomp | + +**Do not mix** `mkl_gnu_thread` with Intel OpenMP or vice versa — this causes +silent wrong results or crashes. + +If `pkg-config` can see `mkl-sdl`, that single-dynamic-library interface is +used instead and no threading-layer selection is needed. + +### Custom libraries + +For non-standard LAPACK installations (e.g. a vendor-tuned LAPACK on a +cluster module): + +```sh +meson setup build -Dlapack=custom \ + -Dlapack_libs=lapack,blas \ + -Dblas_libs=blas +# or with full paths via pkg-config / LIBRARY_PATH +``` + +--- + +## Fully static binary + +A static binary embeds all libraries including the OpenMP runtime and LAPACK. +This is the most portable output for distribution on HPC clusters. + +### GNU static + +Requires: `libgfortran.a`, `libgomp.a`, `libopenblas.a` (or `liblapack.a` + +`libblas.a`) to be available as static `.a` archives. On Debian/Ubuntu +install `gfortran-static`, `libgomp1` (usually comes with `libgomp-staticdev`), +and `libopenblas-dev`. + +```sh +meson setup build_static \ + --buildtype=release \ + --native-file config/gnu.ini \ + -Dstatic=true \ + -Dlapack=openblas +ninja -C build_static +# Result: build_static/crest — fully self-contained ELF +ldd build_static/crest # should print "not a dynamic executable" +``` + +### Intel classic static + +```sh +source /opt/intel/oneapi/setvars.sh +meson setup build_static \ + --native-file config/intel-classic.ini \ + -Dstatic=true \ + -Dlapack=mkl +ninja -C build_static +``` + +Intel's `-static-intel -qopenmp-link=static` flags are applied automatically. +The Intel static libraries (`libifcore.a`, `libimf.a`, `libsvml.a`, +`libiomp5.a`) must be present — they are typically in +`$ONEAPI_ROOT/compiler/latest/linux/compiler/lib/intel64_lin/`. + +### Intel LLVM (ifx) static + +```sh +source /opt/intel/oneapi/setvars.sh +meson setup build_static \ + --native-file config/intel-llvm.ini \ + -Dstatic=true \ + -Dlapack=mkl +ninja -C build_static +``` + +`-static-intel -static-openmp` are applied automatically for ifx. + +--- + +## Subprojects + +Optional chemistry libraries are resolved in this order: + +1. **System-installed** — found via `pkg-config` or in standard library paths +2. **Git submodule** — if `subprojects//` exists and contains a + `meson.build` (populate with `git submodule update --init --recursive`) +3. **Wrap file** — `subprojects/.wrap` tells Meson to clone the repo on + first use with `meson subprojects download` + +To pre-fetch all wrap-defined subprojects: + +```sh +meson subprojects download +``` + +To update existing subproject clones: + +```sh +meson subprojects update +``` + +--- + +## Metadata generation + +At configure time Meson fills `assets/template/metadata.f90` and writes the +result to `/crest_metadata.fh`. The placeholders populated are: + +| Placeholder | Value | +|-------------|-------| +| `@version@` | project version from `meson.build` | +| `@commit@` | short git hash (or `unknown-commit`) | +| `@date@` | configure timestamp | +| `@author@` | `$USER` / `$USERNAME` | +| `@origin@` | hostname | +| `@fcid@` | Fortran compiler name | +| `@fcver@` | Fortran compiler version | +| `@ccid@` | C compiler name | +| `@ccver@` | C compiler version | +| `@bsystem@` | `meson ` | +| `@tomlfvar@` | `true` / `false` | +| `@gfn0var@` | `true` / `false` | +| `@gfnffvar@` | `true` / `false` | +| `@tblitevar@` | `true` / `false` | +| `@libpvolvar@` | `true` / `false` | +| `@lwoniomvar@` | `true` / `false` | + +--- + +## Compiler / LAPACK cross-compatibility reference + +``` +Fortran compiler │ C compiler │ Recommended LAPACK │ OpenMP runtime +─────────────────┼────────────┼────────────────────┼─────────────── +gfortran │ gcc │ OpenBLAS (default) │ libgomp +gfortran │ gcc │ MKL │ libgomp + mkl_gnu_thread +ifort / ifx │ icc / icx │ MKL ← best match │ libiomp5 / libomp +ifort / ifx │ gcc │ MKL │ libiomp5 (Intel wins link) +ifort / ifx │ icc / icx │ OpenBLAS (seq.) │ libiomp5 +``` + +**Rule of thumb:** the compiler that drives the *final link step* owns the +OpenMP runtime. With mixed toolchains, the Fortran compiler always drives the +link step here (crest is a Fortran-primary project), so use the LAPACK +threading layer that matches the *Fortran* compiler. diff --git a/config/gnu.ini b/config/gnu.ini new file mode 100644 index 00000000..f003b492 --- /dev/null +++ b/config/gnu.ini @@ -0,0 +1,16 @@ +# machine file: gnu.ini +# Usage: meson setup build --native-file cross/gnu.ini +# +# Selects the GNU toolchain explicitly. Useful when both GCC and Intel +# compilers are installed and the environment default is not what you want. + +[binaries] +c = 'gcc' +fortran = 'gfortran' +ar = 'ar' +strip = 'strip' + +[built-in options] +# Fortran standard — free-form F2018 is safe for crest +# (gfortran accepts it without an explicit flag, but being explicit helps) +fortran_args = ['-std=f2018'] diff --git a/config/intel-classic.ini b/config/intel-classic.ini new file mode 100644 index 00000000..5a613685 --- /dev/null +++ b/config/intel-classic.ini @@ -0,0 +1,18 @@ +# machine file: intel-classic.ini +# Usage: meson setup build --native-file cross/intel-classic.ini +# +# Uses the classic Intel compilers (ifort, icc). +# Note: icc was deprecated in oneAPI 2023 in favour of icx. +# For new installations prefer intel-llvm.ini instead. +# Source the Intel environment first: +# source /opt/intel/oneapi/setvars.sh + +[binaries] +c = 'icc' +fortran = 'ifort' +ar = 'ar' +strip = 'strip' + +[built-in options] +# -warn all is ifort's equivalent of -Wall +fortran_args = ['-warn', 'all'] diff --git a/config/intel-fortran-gnu-c.ini b/config/intel-fortran-gnu-c.ini new file mode 100644 index 00000000..2f79e2c4 --- /dev/null +++ b/config/intel-fortran-gnu-c.ini @@ -0,0 +1,25 @@ +# machine file: intel-fortran-gnu-c.ini +# Usage: meson setup build --native-file cross/intel-fortran-gnu-c.ini +# +# Mixes Intel Fortran (ifx) with GNU C (gcc). +# This is a common HPC pattern where only the Fortran compiler is licensed +# as Intel but C utilities default to GCC. +# +# IMPORTANT — OpenMP runtime compatibility: +# ifx links against Intel's libomp (libiomp5). +# gcc links against GNU's libgomp. +# The two runtimes must NOT both be loaded in the same process. +# Resolution: let ifx drive the final link step so it picks up libomp. +# Do NOT pass -fopenmp to gcc translation units; instead use +# -Dopenmp=true which the build system applies only to Fortran sources. +# +# IMPORTANT — MKL threading layer: +# With this mixed toolchain, use mkl_intel_thread (not mkl_gnu_thread) +# because the Fortran driver (ifx/ifort) owns the OpenMP runtime. +# Set: -Dlapack=mkl + +[binaries] +c = 'gcc' +fortran = 'ifx' +ar = 'ar' +strip = 'strip' diff --git a/config/intel-llvm.ini b/config/intel-llvm.ini new file mode 100644 index 00000000..20929f00 --- /dev/null +++ b/config/intel-llvm.ini @@ -0,0 +1,15 @@ +# machine file: intel-llvm.ini +# Usage: meson setup build --native-file cross/intel-llvm.ini +# +# Uses the Intel LLVM-based compilers (ifx, icx) from oneAPI 2023+. +# Source the Intel environment first: +# source /opt/intel/oneapi/setvars.sh + +[binaries] +c = 'icx' +fortran = 'ifx' +ar = 'ar' +strip = 'strip' + +[built-in options] +fortran_args = ['-warn', 'all'] diff --git a/config/meson.build b/config/meson.build index 99616924..04f6812b 100644 --- a/config/meson.build +++ b/config/meson.build @@ -1,299 +1,220 @@ # This file is part of crest. # SPDX-Identifier: LGPL-3.0-or-later # -# crest is free software: you can redistribute it and/or modify it under -# the terms of the GNU Lesser General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. +# Included from the root meson.build via subdir('config'). +# Runs in the same variable scope as the root — all variables set here +# are visible in the root after this file returns. # -# crest is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public License -# along with crest. If not, see . - +# Responsibilities: +# - Compiler identification and friendly display names +# - Per-compiler build flags (release and debug) +# - Static-binary link arguments +# - Metadata header generation (crest_metadata.fh) +# - inc_dirs (build include path carrying the generated header) + +# ═══════════════════════════════════════════════════════════════════════════════ +# Compiler identification +# ═══════════════════════════════════════════════════════════════════════════════ fc = meson.get_compiler('fortran') cc = meson.get_compiler('c') -fc_id = fc.get_id() + +fc_id = fc.get_id() # 'gcc' | 'intel' | 'intel-llvm' | ... cc_id = cc.get_id() -if fc.get_id() != cc.get_id() - warning('FC and CC are not from the same vendor') +_fc_name_map = { + 'gcc' : 'GNU Fortran', + 'intel' : 'Intel Fortran (Classic)', + 'intel-llvm' : 'Intel Fortran (LLVM/ifx)', + 'flang' : 'Flang', + 'flang-new' : 'Flang-new', +} +_cc_name_map = { + 'gcc' : 'GNU C', + 'intel' : 'Intel C (Classic)', + 'intel-llvm' : 'Intel C (LLVM/icx)', + 'clang' : 'Clang', +} + +fcid_str = _fc_name_map.get(fc_id, fc_id) +ccid_str = _cc_name_map.get(cc_id, cc_id) + +if fc_id not in ['gcc', 'intel', 'intel-llvm'] + warning( + 'Unsupported Fortran compiler "@0@". Proceeding, but results may be wrong.' + .format(fc_id), + ) endif -## ========================================= ## -## Compiler specific default arguments -## ========================================= ## +# ═══════════════════════════════════════════════════════════════════════════════ +# Compiler flags +# ═══════════════════════════════════════════════════════════════════════════════ +_is_debug = get_option('buildtype') in ['debug', 'debugoptimized'] + +# --- GNU (gfortran / gcc) ----------------------------------------------------- if fc_id == 'gcc' add_project_arguments( '-ffree-line-length-none', '-fbacktrace', - '-Wno-maybe-uninitialized', - '-Wno-uninitialized', - '-Wno-unused-variable', - '-Wno-unused-dummy-argument', - '-Wno-unused-function', - language: 'fortran', - ) -elif fc_id == 'intel' - add_project_link_arguments( - '-Wl,--allow-multiple-definition', - language: 'fortran', - ) - add_global_link_arguments( - '-Wl,--allow-multiple-definition', - language: 'fortran', + language : 'fortran', ) + if _is_debug + add_project_arguments( + '-fcheck=all', + '-ffpe-trap=invalid,zero,overflow', + '-fbounds-check', + '-finit-real=snan', + '-finit-integer=-999', + '-Wall', + '-Wextra', + language : 'fortran', + ) + endif +endif + +# --- Intel classic (ifort / icc) ----------------------------------------------- +if fc_id == 'intel' add_project_arguments( + '-r8', # treat all REAL as REAL(8) + '-align', 'array64byte', '-traceback', - language: 'fortran', + language : 'fortran', ) + if _is_debug + add_project_arguments( + '-check', 'all', + '-fpe0', + language : 'fortran', + ) + endif +endif + +# --- Intel LLVM (ifx / icx) ---------------------------------------------------- +if fc_id == 'intel-llvm' add_project_arguments( - '-DLINUX', - language: 'c', - ) -elif fc_id == 'pgi' or fc_id == 'nvidia_hpc' - add_project_arguments( - '-Mbackslash', - '-Mallocatable=03', + '-r8', + '-align', 'array64byte', '-traceback', - language: 'fortran', - ) -elif fc_id == 'flang' - add_project_arguments( - '-Mbackslash', - '-Mallocatable=03', - language: 'fortran', + language : 'fortran', ) -endif - -add_project_arguments('-D_Float128=__float128', language: 'c') - - -## ========================================= ## -## build type option arguments -## ========================================= ## -if ( get_option('default_library') == 'static') - message('Static linking selected') - add_project_link_arguments('-static', language: 'fortran') - add_project_link_arguments('-static', language: 'c') # icc will do linking -endif - - -## ========================================= ## -## OpenMP -## ========================================= ## -if get_option('openmp') - omp_dep = dependency('openmp', required: fc.get_id() != 'intel') - if not omp_dep.found() - omp_dep = declare_dependency( - compile_args: '-qopenmp', - link_args: '-fopenmp', + if _is_debug + add_project_arguments( + '-check', 'all', + '-fpe0', + language : 'fortran', ) endif - exe_deps += omp_dep endif -## ======================================== ## -## Linear Algebra Libraries -## ======================================== ## -la_backend = get_option('la_backend') -message('Linear algebra backend: '+get_option('la_backend')) -if la_backend == 'mkl' or la_backend == 'mkl-static' - add_project_arguments('-DWITH_MKL', language: 'fortran') - if la_backend == 'mkl-static' - add_project_link_arguments('-static', language: 'fortran') - add_project_link_arguments('-static', language: 'c') # icc will do linking - endif +# ═══════════════════════════════════════════════════════════════════════════════ +# Static-binary link arguments +# ═══════════════════════════════════════════════════════════════════════════════ +# Injected globally so they propagate to every link step (library + executable). +# See BUILD.md for notes on required system .a archives. +static_build = get_option('static') + +if static_build + if fc_id == 'gcc' + # Full static: bundles glibc, libgfortran, libgomp, libopenblas/lapack. + # Requires libgfortran-static and glibc-static system packages. + add_project_link_arguments('-static', language : 'fortran') + add_project_link_arguments('-static', language : 'c') + + elif fc_id == 'intel' + # -static-intel : statically links Intel runtime (ifcore, imf, svml) + # -qopenmp-link=static : statically links Intel OpenMP (libiomp5) + # Add -static on top if a fully self-contained binary is needed and + # glibc-static is available on the build host. + add_project_link_arguments( + '-static-intel', + '-qopenmp-link=static', + language : 'fortran', + ) - if get_option('default_library') == 'shared' - mkl_rt_dep = cc.find_library('mkl_rt', required: true) - exe_deps += mkl_rt_dep - else - if fc.get_id() == 'gcc' - libmkl_exe = [cc.find_library('mkl_gf_lp64')] - if get_option('openmp') - libmkl_exe += cc.find_library('mkl_gnu_thread') - endif - elif fc.get_id() == 'intel' or fc.get_id() == 'intel-cl' - libmkl_exe = [cc.find_library('mkl_intel_lp64')] - if get_option('openmp') - libmkl_exe += cc.find_library('mkl_intel_thread') - endif - elif fc.get_id() == 'pgi' or fc.get_id() == 'nvidia_hpc' - libmkl_exe = [cc.find_library('mkl_intel_lp64')] - if get_option('openmp') - libmkl_exe += cc.find_library('mkl_pgi_thread') - endif - endif - if not get_option('openmp') - libmkl_exe += cc.find_library('mkl_sequential') - endif - libmkl_exe += cc.find_library('mkl_core') - exe_deps += libmkl_exe + elif fc_id == 'intel-llvm' + # ifx uses -static-openmp instead of -qopenmp-link=static + add_project_link_arguments( + '-static-intel', + '-static-openmp', + language : 'fortran', + ) endif +endif -elif la_backend == 'mkl-rt' - add_project_arguments('-DWITH_MKL', language: 'fortran') - - mkl_rt_dep = fc.find_library('mkl_rt', required: true) - if fc.get_id() == 'intel' - exe_deps += fc.find_library('ifcore') +# ═══════════════════════════════════════════════════════════════════════════════ +# Metadata: fill assets/template/metadata.f90 → /crest_metadata.fh +# ═══════════════════════════════════════════════════════════════════════════════ +_git = find_program('git', required : false) +_commit = 'unknown-commit' +if _git.found() + _r = run_command(_git, 'show', '-s', '--format=%h', check : false) + if _r.returncode() == 0 + _commit = _r.stdout().strip() endif +endif - exe_deps += mkl_rt_dep - -elif la_backend == 'openblas' - # search for OpenBLAS - blas_dep = dependency('openblas', required: false) - if not blas_dep.found() - blas_dep = fc.find_library('openblas', required: true) - endif - exe_deps += blas_dep - # some OpenBLAS versions can provide lapack, check if we can find dsygvd - openblas_provides_lapack = fc.links( - 'external dsygvd; call dsygvd(); end', - dependencies: blas_dep, +_py = find_program('python3', 'python', required : false) +_date = 'unknown-date' +if _py.found() + _r = run_command( + _py, '-c', + 'import datetime; print(datetime.datetime.now().strftime("%a, %d %B %H:%M:%S, %m/%d/%Y"))', + check : false, ) - # otherwise we fall back to LAPACK - if not openblas_provides_lapack - lapack_dep = dependency('lapack', required: false) - if not lapack_dep.found() - lapack_dep = fc.find_library('lapack', required: true) - endif - exe_deps += lapack_dep - endif - -elif la_backend == 'custom' - foreach lib: get_option('custom_libraries') - exe_deps += fc.find_library(lib) - endforeach - -else - # Find BLAS (usually netlib, but in conda also OpenBLAS/MKL) - blas_dep = dependency('blas', required: false) - if not blas_dep.found() - blas_dep = fc.find_library('blas', required: true) - endif - exe_deps += blas_dep - # Find LAPACK (usually netlib, but in conda also MKL) - lapack_dep = dependency('lapack', required: false) - if not lapack_dep.found() - lapack_dep = fc.find_library('lapack', required: true) + if _r.returncode() == 0 + _date = _r.stdout().strip() endif - exe_deps += lapack_dep -endif - - -## ========================================= ## -## External subprojects -## ========================================= ## - -# GFN1-xTB and GFN2-xTB via TBLITE -if get_option('WITH_TBLITE') - add_project_arguments('-DWITH_TBLITE', language: 'fortran') - tblite_dep = dependency( - 'tblite', - version: '>=0.2', - fallback: ['tblite', 'tblite_dep'], - default_options: ['default_library=static', 'api=false'], - ) - exe_deps += tblite_dep -endif - -# TOML-F -if get_option('WITH_TOMLF') - add_project_arguments('-DWITH_TOMLF', language: 'fortran') - tomlf_dep = dependency( - 'toml-f', - version: '>=0.2.0', - fallback: ['toml-f', 'tomlf_dep'], - default_options: ['default_library=static'], - ) - exe_deps += tomlf_dep -endif - -# GFN0-xTB -if get_option('WITH_GFN0') - add_project_arguments('-DWITH_GFN0', language: 'fortran') - gfn0_dep = dependency( - 'gfn0', -# version: '>=0.2', - fallback: ['gfn0', 'gfn0_dep'], - default_options: ['default_library=static','with_gbsa=true'], - ) - exe_deps += gfn0_dep -endif - -# GFN-FF -if get_option('WITH_GFNFF') - add_project_arguments('-DWITH_GFNFF', language: 'fortran') - gfnff_dep = dependency( - 'gfnff', - fallback: ['gfnff', 'gfnff_dep'], - default_options: ['default_library=static','with_gbsa=true'], - ) - exe_deps += gfnff_dep -endif - - -# LIBPVOL -if get_option('WITH_LIBPVOL') - add_project_arguments('-DWITH_LIBPVOL', language: 'fortran') - libpvol_dep = dependency( - 'libpvol', - fallback: ['libpvol', 'libpvol_dep'], - default_options: ['default_library=static'], - ) - exe_deps += libpvol_dep endif - -# lwONIOM -if get_option('WITH_LWONIOM') - add_project_arguments('-DWITH_LWONIOM', language: 'fortran') - lwoniom_dep = dependency( - 'lwoniom', - fallback: ['lwoniom', 'lwoniom_dep'], - default_options: ['default_library=static'], - ) - exe_deps += lwoniom_dep +_hostname = 'unknown-host' +_hostname_prog = find_program('hostname', required : false) +if _hostname_prog.found() + _r = run_command(_hostname_prog, check : false) + if _r.returncode() == 0 + _hostname = _r.stdout().strip() + endif endif - -## ========================================= ## -## populate the data for crest_metadata.fh -## ========================================= ## -commit = 'unknown commit' -git = find_program('git', required: false) -if git.found() - git_commit = run_command(git, 'show', '-s', '--format=%h',check:true) - if git_commit.returncode() == 0 - commit = git_commit.stdout().strip() +_sh = find_program('sh', required : false) +_user = 'unknown' +if _sh.found() + _r = run_command( + _sh, '-c', 'printf "%s" "${USER:-${USERNAME:-unknown}}"', + check : false, + ) + if _r.returncode() == 0 and _r.stdout().strip() != '' + _user = _r.stdout().strip() endif endif -# create configuration data -config = configuration_data({ - 'name': meson.project_name(), - 'version': meson.project_version(), - 'description': 'Conformer Rotamer Ensemble Sampling Tool', - 'commit': commit, - 'date': run_command('date',check:true).stdout(). strip(), - 'author': run_command('id','-u','-n', check:true).stdout().strip(), - 'origin': run_command('hostname', check:true).stdout().strip(), - 'fcid': fc.get_id(), - 'fcver': fc.version(), - 'ccid': cc.get_id(), - 'ccver': cc.version(), - 'bsystem': 'meson '+meson.version(), - 'tomlfvar': get_option('WITH_TOMLF'), - 'gfn0var': get_option('WITH_GFN0'), - 'gfnffvar': get_option('WITH_GFNFF'), - 'tblitevar': get_option('WITH_TBLITE'), - 'libpvolvar': get_option('WITH_LIBPVOL'), - 'lwoniomvar': get_option('WITH_LWONIOM'), -}) + +_conf = configuration_data() +_conf.set('version', meson.project_version()) +_conf.set('commit', _commit) +_conf.set('date', _date) +_conf.set('author', _user) +_conf.set('origin', _hostname) +_conf.set('fcid', fcid_str) +_conf.set('fcver', fc.version()) +_conf.set('ccid', ccid_str) +_conf.set('ccver', cc.version()) +_conf.set('bsystem', 'meson ' + meson.version()) +# The with_* booleans are set in the root after optional deps are resolved; +# use string placeholders here and let the root patch them in if needed. +# In practice configure_file runs at configure-time so these are all known +# by the time the root calls subdir('config') — see note below. +# +# NOTE: the with_* variables (with_tomlf, with_tblite, …) are set in the root +# meson.build AFTER this file runs, so they are not yet available here. +# The root therefore calls configure_file() itself using this _conf object +# after appending the feature flags. We expose _conf so the root can do that. +_conf.set('tomlfvar', 'false') +_conf.set('gfn0var', 'false') +_conf.set('gfnffvar', 'false') +_conf.set('tblitevar', 'false') +_conf.set('libpvolvar', 'false') +_conf.set('lwoniomvar', 'false') + +# Expose _conf to the root so it can set the with_* keys and then call +# configure_file(). The root owns the final configure_file() call. +metadata_conf = _conf diff --git a/meson.build b/meson.build index bb04ea32..0314366b 100644 --- a/meson.build +++ b/meson.build @@ -16,70 +16,328 @@ project( 'crest', - 'fortran', 'c', - version: '3.0.3', - license: 'LGPL-3.0-or-later', - meson_version: '>=0.63', - default_options: [ - 'buildtype=debugoptimized', - 'default_library=static', - 'c_link_args=-static', - 'fortran_link_args=-static', + ['c', 'fortran'], + version : '3.0.3', + license : 'LGPL-3.0-or-later', + meson_version : '>=0.57.0', + default_options : [ + 'buildtype=release', + 'c_std=gnu11', ], ) -install = not (meson.is_subproject() and get_option('default_library') == 'static') - -# =================================== # -## General configuration information ## -# =================================== # -exe_deps = [] +# ── Compiler flags, static link args, metadata template, inc_dirs ───────────── +# Sets: fc, cc, fc_id, cc_id, fcid_str, ccid_str, static_build, metadata_conf subdir('config') -# create the metadata file with the configured data -configure_file( - input: files('assets/template/metadata.f90'), - output: 'crest_metadata.fh', - configuration : config, +# inc_dirs is defined here rather than in config/meson.build because +# include_directories() rejects absolute paths inside the source/build tree, +# and meson.current_build_dir() only resolves to the *root* build dir when +# called from the root meson.build (subdir() shifts the current dir). +# '.' pairs the source root with its build counterpart automatically, +# which is where configure_file() writes crest_metadata.fh. +inc_dirs = include_directories('include', '.') + +# ═══════════════════════════════════════════════════════════════════════════════ +# OpenMP +# ═══════════════════════════════════════════════════════════════════════════════ +omp_dep = dependency('openmp', + required : get_option('openmp'), + language : 'fortran', ) +if omp_dep.found() + add_project_arguments('-DWITH_OMP', language : ['c', 'fortran']) +endif +_omp_link_dep = (omp_dep.found() and not static_build) ? [omp_dep] : [] -# Documentation -#subdir('docs') +# ═══════════════════════════════════════════════════════════════════════════════ +# LAPACK / BLAS +# ═══════════════════════════════════════════════════════════════════════════════ +# +# Cross-compiler compatibility matrix +# ───────────────────────────────────────────────────────────────────────────── +# Fortran compiler │ Recommended provider │ MKL threading layer +# ──────────────────┼────────────────────────┼────────────────────── +# gfortran │ OpenBLAS (default) │ mkl_gnu_thread +# ifort / ifx │ MKL ← natural match │ mkl_intel_thread +# ifort/ifx + gcc C │ MKL │ mkl_intel_thread (Fortran wins) +# ───────────────────────────────────────────────────────────────────────────── +# The Fortran compiler drives the final link step and therefore owns the OpenMP +# runtime. Choose the MKL threading layer to match the *Fortran* compiler. -# Collect source of the project -prog = [] -srcs = [] -subdir('src') +lapack_opt = get_option('lapack') +with_mkl = false +with_openblas = false +lapack_dep = [] +blas_dep = [] + +_prefer_mkl = (fc_id in ['intel', 'intel-llvm']) and (lapack_opt == 'auto') + +# ── MKL ─────────────────────────────────────────────────────────────────────── +if lapack_opt == 'mkl' or _prefer_mkl + _mkl = dependency('mkl-sdl', required : false, static : static_build) + + if not _mkl.found() + _thread_lib = (fc_id == 'gcc') ? 'mkl_gnu_thread' : 'mkl_intel_thread' + _omp_lib = (fc_id == 'gcc') ? 'gomp' : 'iomp5' + _mkl_parts = [] + foreach lib : ['mkl_intel_lp64', _thread_lib, 'mkl_core', _omp_lib, 'm', 'dl'] + _l = fc.find_library(lib, required : false, static : static_build) + if _l.found() + _mkl_parts += [_l] + endif + endforeach + if _mkl_parts.length() > 0 + _mkl = declare_dependency(dependencies : _mkl_parts) + endif + endif + if _mkl.found() + lapack_dep = _mkl + blas_dep = _mkl + with_mkl = true + message('LAPACK/BLAS provider: Intel MKL') + elif lapack_opt == 'mkl' + error('MKL requested but not found. Set PKG_CONFIG_PATH or source setvars.sh.') + else + lapack_opt = 'auto' + endif +endif -# Create library target -crest_lib = library( - meson.project_name(), - sources: srcs, - dependencies: exe_deps, -# include_directories: include_directories('include'), +# ── OpenBLAS ────────────────────────────────────────────────────────────────── +if lapack_opt in ['auto', 'openblas'] and not with_mkl + _opa = dependency('openblas', required : false, static : static_build) + if not _opa.found() + _opa = dependency('blas', required : false, static : static_build) + endif + if _opa.found() + lapack_dep = _opa + blas_dep = _opa + with_openblas = true + message('LAPACK/BLAS provider: OpenBLAS') + elif lapack_opt == 'openblas' + error('OpenBLAS requested but not found. Install libopenblas-dev.') + endif +endif + +# ── Netlib reference ────────────────────────────────────────────────────────── +if lapack_opt in ['auto', 'netlib'] and not with_mkl and not with_openblas + _blas = dependency('blas', required : false, static : static_build) + _lapack = dependency('lapack', required : false, static : static_build) + if _blas.found() and _lapack.found() + blas_dep = _blas + lapack_dep = _lapack + message('LAPACK/BLAS provider: netlib reference') + else + _blas = fc.find_library('blas', required : false, static : static_build) + _lapack = fc.find_library('lapack', required : false, static : static_build) + if _blas.found() and _lapack.found() + blas_dep = declare_dependency(dependencies : [_blas]) + lapack_dep = declare_dependency(dependencies : [_lapack]) + message('LAPACK/BLAS provider: system libraries (direct probe)') + elif lapack_opt == 'netlib' + error('Netlib BLAS/LAPACK not found.') + else + error( + 'No LAPACK/BLAS found. Install libopenblas-dev, intel-mkl, or ' + + 'liblapack-dev+libblas-dev, or use -Dlapack=custom.', + ) + endif + endif +endif + +# ── Custom ──────────────────────────────────────────────────────────────────── +if lapack_opt == 'custom' + _ll = get_option('lapack_libs') + _bl = get_option('blas_libs') + if _ll.length() == 0 and _bl.length() == 0 + error('lapack=custom requires lapack_libs and/or blas_libs.') + endif + _deps = [] + foreach lib : _ll + _bl + _deps += [fc.find_library(lib, required : true, static : static_build)] + endforeach + lapack_dep = declare_dependency(dependencies : _deps) + blas_dep = lapack_dep +endif + +if with_mkl + add_project_arguments('-DWITH_MKL', language : ['c', 'fortran']) +endif +if with_openblas + add_project_arguments('-DWITH_OPENBLAS', language : ['c', 'fortran']) +endif + +# ═══════════════════════════════════════════════════════════════════════════════ +# Optional subproject / external library dependencies +# ═══════════════════════════════════════════════════════════════════════════════ +tomlf_dep = dependency('toml-f', + version : '>=0.2.4', + fallback : ['toml-f', 'toml_f_dep'], + required : get_option('toml-f'), + static : static_build, +) +with_tomlf = tomlf_dep.found() +if with_tomlf + add_project_arguments('-DWITH_TOMLF', language : ['c', 'fortran']) +endif + +tblite_dep = dependency('tblite', + version : '>=0.3.0', + fallback : ['tblite', 'tblite_dep'], + required : get_option('tblite'), + static : static_build, ) +with_tblite = tblite_dep.found() +if with_tblite + add_project_arguments('-DWITH_TBLITE', language : ['c', 'fortran']) +endif -# Export as dependency -crest_inc = crest_lib.private_dir_include() -crest_dep = declare_dependency( - link_with: crest_lib, - include_directories: crest_inc, - dependencies: exe_deps, +gfnff_dep = dependency('gfnff', + fallback : ['gfnff', 'gfnff_dep'], + required : get_option('gfnff'), + static : static_build, ) +with_gfnff = gfnff_dep.found() +if with_gfnff + add_project_arguments('-DWITH_GFNFF', language : ['c', 'fortran']) +endif +gfn0_dep = dependency('gfn0', + fallback : ['gfn0', 'gfn0_dep'], + required : get_option('gfn0'), + static : static_build, +) +with_gfn0 = gfn0_dep.found() +if with_gfn0 + add_project_arguments('-DWITH_GFN0', language : ['c', 'fortran']) +endif -# Create executable target -crest_exe = executable( - meson.project_name(), - sources: prog, - dependencies: crest_dep, - install: install, - link_language: 'fortran', +libpvol_dep = dependency('libpvol', + fallback : ['libpvol', 'libpvol_dep'], + required : get_option('libpvol'), + static : static_build, ) +with_libpvol = libpvol_dep.found() +if with_libpvol + add_project_arguments('-DWITH_LIBPVOL', language : ['c', 'fortran']) +endif +lwoniom_dep = dependency('lwoniom', + fallback : ['lwoniom', 'lwoniom_dep'], + required : get_option('lwoniom'), + static : static_build, +) +with_lwoniom = lwoniom_dep.found() +if with_lwoniom + add_project_arguments('-DWITH_LWONIOM', language : ['c', 'fortran']) +endif + +fmlip_dep = dependency('fmlip_relay', + fallback : ['fmlip_relay', 'fmlip_relay_dep'], + required : get_option('fmlip-relay'), + static : static_build, +) +with_fmlip = fmlip_dep.found() +if with_fmlip + add_project_arguments('-DWITH_FMLIP_RELAY', language : ['c', 'fortran']) +endif +if get_option('tests') + testdrive_dep = dependency('test-drive', + version : '>=0.4.0', + fallback : ['test-drive', 'testdrive_dep'], + required : true, + static : static_build, + ) +endif + +# ═══════════════════════════════════════════════════════════════════════════════ +# Metadata header — finalise and generate +# ═══════════════════════════════════════════════════════════════════════════════ +# config/meson.build populated metadata_conf with system/compiler info but +# deferred the with_* feature flags (not yet known at that point). +# Patch them in now that all deps have been resolved. +metadata_conf.set('tomlfvar', with_tomlf.to_string()) +metadata_conf.set('gfn0var', with_gfn0.to_string()) +metadata_conf.set('gfnffvar', with_gfnff.to_string()) +metadata_conf.set('tblitevar', with_tblite.to_string()) +metadata_conf.set('libpvolvar', with_libpvol.to_string()) +metadata_conf.set('lwoniomvar', with_lwoniom.to_string()) + +configure_file( + input : 'assets/template/metadata.f90', + output : 'crest_metadata.fh', + configuration : metadata_conf, +) + +# ═══════════════════════════════════════════════════════════════════════════════ +# Source collection +# ═══════════════════════════════════════════════════════════════════════════════ +srcs = [] +prog = [] +subdir('src') + +# ═══════════════════════════════════════════════════════════════════════════════ +# Build targets +# ═══════════════════════════════════════════════════════════════════════════════ +_optional_deps = [] +foreach d : [tblite_dep, gfn0_dep, gfnff_dep, libpvol_dep, lwoniom_dep, tomlf_dep, fmlip_dep] + if d.found() + _optional_deps += [d] + endif +endforeach + +lib_crest = static_library( + 'crest', + sources : srcs, + include_directories : inc_dirs, + dependencies : [lapack_dep, blas_dep] + _omp_link_dep + _optional_deps, + install : false, + pic : true, +) + +executable( + 'crest', + sources : prog, + include_directories : inc_dirs, + link_with : lib_crest, + dependencies : [lapack_dep, blas_dep] + _omp_link_dep + _optional_deps, + install : true, +) + +# ═══════════════════════════════════════════════════════════════════════════════ +# Docs, tests, install +# ═══════════════════════════════════════════════════════════════════════════════ +subdir('docs') + +if get_option('tests') + subdir('test') +endif + +install_data( + 'COPYING', 'COPYING.LESSER', + install_dir : get_option('datadir') / 'licenses' / meson.project_name(), +) -# add the testsuite separate meson.build -#subdir('testsuite') #has to be filled with tests, not availabel yet +# ═══════════════════════════════════════════════════════════════════════════════ +# Summary +# ═══════════════════════════════════════════════════════════════════════════════ +summary({ + 'Fortran compiler' : '@0@ @1@'.format(fcid_str, fc.version()), + 'C compiler' : '@0@ @1@'.format(ccid_str, cc.version()), + 'Build type' : get_option('buildtype'), + 'Static binary' : static_build, + 'OpenMP' : omp_dep.found(), + 'MKL' : with_mkl, + 'OpenBLAS' : with_openblas, + 'tblite' : with_tblite, + 'toml-f' : with_tomlf, + 'GFN-FF' : with_gfnff, + 'GFN0-xTB' : with_gfn0, + 'libpvol' : with_libpvol, + 'lwONIOM' : with_lwoniom, + 'fmlip-relay' : with_fmlip, + 'Unit tests' : get_option('tests'), +}, section : 'crest build configuration') diff --git a/meson_options.txt b/meson_options.txt index 950190e2..971bcfff 100644 --- a/meson_options.txt +++ b/meson_options.txt @@ -1,75 +1,86 @@ # This file is part of crest. # SPDX-Identifier: LGPL-3.0-or-later -# -# crest is free software: you can redistribute it and/or modify it under -# the terms of the GNU Lesser General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. -# -# crest is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public License -# along with crest. If not, see . -option( - 'la_backend', - type: 'combo', - value: 'mkl-static', - yield: true, - choices: ['mkl', 'mkl-rt', 'mkl-static', 'openblas', 'netlib', 'custom','none'], - description: 'Linear algebra backend for program.', +# ── Parallelism ──────────────────────────────────────────────────────────────── +option('openmp', + type : 'boolean', + value : true, + description : 'Enable OpenMP parallelisation', ) -option( - 'custom_libraries', - type: 'array', - value: [], - description: 'libraries to load for custom linear algebra backend', + +# ── LAPACK / BLAS provider ───────────────────────────────────────────────────── +# auto → try openblas, then mkl, then netlib in that order +# openblas → OpenBLAS (bundles BLAS+LAPACK) +# mkl → Intel Math Kernel Library +# netlib → Reference LAPACK + BLAS +# custom → set lapack_libs / blas_libs manually on the meson command line +# using -Dlapack_libs=... -Dblas_libs=... +option('lapack', + type : 'combo', + choices : ['auto', 'openblas', 'mkl', 'netlib', 'custom'], + value : 'auto', + description : 'LAPACK/BLAS provider', ) -option( - 'openmp', - type: 'boolean', - value: true, - yield: true, - description: 'use OpenMP parallelisation', + +# Only used when lapack=custom: +option('lapack_libs', + type : 'array', + value : [], + description : 'Extra library names to link for LAPACK (custom mode)', ) -option( - 'WITH_TBLITE', - type: 'boolean', - value: true, - description: 'build with tblite integration', +option('blas_libs', + type : 'array', + value : [], + description : 'Extra library names to link for BLAS (custom mode)', ) -option( - 'WITH_GFN0', - type: 'boolean', - value: true, - description: 'build with GFN0-xTB integration', + +# ── Static binary ───────────────────────────────────────────────────────────── +option('static', + type : 'boolean', + value : false, + description : 'Attempt a fully static binary (includes OpenMP + LAPACK runtime)', ) -option( - 'WITH_GFNFF', - type: 'boolean', - value: true, - description: 'build with GFN-FF integration', + +# ── Optional computational chemistry libraries ───────────────────────────────── +option('tblite', + type : 'feature', + value : 'auto', + description : 'Enable tblite semiempirical library', ) -option( - 'WITH_TOMLF', - type: 'boolean', - value: true, - description: 'build with toml-f integration', +option('toml-f', + type : 'feature', + value : 'auto', + description : 'Enable TOML-Fortran library (also enables file-based input)', ) -option( - 'WITH_LIBPVOL', - type: 'boolean', - value: true, - description: 'build with libpvol integration', +option('gfn0', + type : 'feature', + value : 'auto', + description : 'Enable GFN0-xTB library', ) - -option( - 'WITH_LWONIOM', - type: 'boolean', - value: true, - description: 'build with lwONIOM integration', +option('gfnff', + type : 'feature', + value : 'auto', + description : 'Enable GFN-FF library', +) +option('libpvol', + type : 'feature', + value : 'auto', + description : 'Enable libpvol (volume computation) library', +) +option('lwoniom', + type : 'feature', + value : 'auto', + description : 'Enable lwONIOM library', +) +option('fmlip-relay', + type : 'feature', + value : 'disabled', + description : 'Enable fmlip-relay ML/IP interface', ) +# ── Developer options ────────────────────────────────────────────────────────── +option('tests', + type : 'boolean', + value : true, + description : 'Build unit tests (requires test-drive)', +) diff --git a/subprojects/dftd4.wrap b/subprojects/dftd4.wrap index 6bd81c01..5b935577 100644 --- a/subprojects/dftd4.wrap +++ b/subprojects/dftd4.wrap @@ -1,4 +1,7 @@ [wrap-git] -directory = dftd4 url = https://github.com/dftd4/dftd4 -revision = v3.7.0 +revision = head +clone-recursive = true + +[provide] +dftd4 = dftd4_dep diff --git a/subprojects/fmlip_relay.wrap b/subprojects/fmlip_relay.wrap new file mode 100644 index 00000000..956eae75 --- /dev/null +++ b/subprojects/fmlip_relay.wrap @@ -0,0 +1,10 @@ +# fmlip_relay: adjust the URL to your actual repository location. +# If it lives as a git submodule, you can delete this file and instead ensure +# the submodule is checked out under subprojects/fmlip_relay/. +[wrap-git] +url = https://github.com/pprcht/fmlip-relay +revision = head +clone-recursive = true + +[provide] +fmlip_relay = fmlip_relay_dep diff --git a/subprojects/gfn0.wrap b/subprojects/gfn0.wrap index d32056dc..0fdd7261 100644 --- a/subprojects/gfn0.wrap +++ b/subprojects/gfn0.wrap @@ -1,4 +1,7 @@ [wrap-git] -directory = gfn0 -url = https://github.com/pprcht/gfn0 +url = https://github.com/grimme-lab/gfn0 revision = head +clone-recursive = true + +[provide] +gfn0 = gfn0_dep diff --git a/subprojects/gfnff.wrap b/subprojects/gfnff.wrap index c78f420c..cafebc59 100644 --- a/subprojects/gfnff.wrap +++ b/subprojects/gfnff.wrap @@ -1,4 +1,7 @@ [wrap-git] -directory = gfnff -url = https://github.com/pprcht/gfnff +url = https://github.com/grimme-lab/gfnff revision = head +clone-recursive = true + +[provide] +gfnff = gfnff_dep diff --git a/subprojects/libpvol.wrap b/subprojects/libpvol.wrap index 38211bfa..71fd4ff9 100644 --- a/subprojects/libpvol.wrap +++ b/subprojects/libpvol.wrap @@ -1,4 +1,7 @@ [wrap-git] -directory = pvol url = https://github.com/neudecker-group/libpvol.git revision = head +clone-recursive = true + +[provide] +libpvol = libpvol_dep diff --git a/subprojects/lwoniom.wrap b/subprojects/lwoniom.wrap index 8aab9996..e1afd4a1 100644 --- a/subprojects/lwoniom.wrap +++ b/subprojects/lwoniom.wrap @@ -1,4 +1,7 @@ [wrap-git] -directory = lwoniom -url = https://github.com/crest-lab/lwoniom +url = https://github.com/grimme-lab/lwoniom revision = head +clone-recursive = true + +[provide] +lwoniom = lwoniom_dep diff --git a/subprojects/mctc-lib.wrap b/subprojects/mctc-lib.wrap index 9f7635f9..313ec501 100644 --- a/subprojects/mctc-lib.wrap +++ b/subprojects/mctc-lib.wrap @@ -1,3 +1,7 @@ [wrap-git] -directory = mctc-lib url = https://github.com/grimme-lab/mctc-lib +revision = head +clone-recursive = true + +[provide] +mctc-lib = mctc_lib_dep diff --git a/subprojects/mstore.wrap b/subprojects/mstore.wrap index 0b2aa233..3aa6eea3 100644 --- a/subprojects/mstore.wrap +++ b/subprojects/mstore.wrap @@ -1,3 +1,7 @@ [wrap-git] -directory = mstore url = https://github.com/grimme-lab/mstore +revision = head +clone-recursive = true + +[provide] +mstore = mstore_dep diff --git a/subprojects/multicharge.wrap b/subprojects/multicharge.wrap new file mode 100644 index 00000000..da33639c --- /dev/null +++ b/subprojects/multicharge.wrap @@ -0,0 +1,7 @@ +[wrap-git] +url = https://github.com/grimme-lab/multicharge +revision = head +clone-recursive = true + +[provide] +multicharge = multicharge_dep diff --git a/subprojects/s-dftd3.wrap b/subprojects/s-dftd3.wrap index 938c0a11..1f4669d1 100644 --- a/subprojects/s-dftd3.wrap +++ b/subprojects/s-dftd3.wrap @@ -1,2 +1,7 @@ -[wrap-redirect] -filename = tblite/subprojects/s-dftd3.wrap +[wrap-git] +url = https://github.com/awvwgk/simple-dftd3 +revision = head +clone-recursive = true + +[provide] +s-dftd3 = s_dftd3_dep diff --git a/subprojects/tblite.wrap b/subprojects/tblite.wrap index bb401a77..2fd21636 100644 --- a/subprojects/tblite.wrap +++ b/subprojects/tblite.wrap @@ -1,4 +1,7 @@ [wrap-git] -directory = tblite -url = https://github.com/ppracht/tblite -revision = xtb_solvation +url = https://github.com/tblite/tblite +revision = head +clone-recursive = true + +[provide] +tblite = tblite_dep diff --git a/subprojects/test-drive.wrap b/subprojects/test-drive.wrap new file mode 100644 index 00000000..eb380856 --- /dev/null +++ b/subprojects/test-drive.wrap @@ -0,0 +1,7 @@ +[wrap-git] +url = https://github.com/fortran-lang/test-drive +revision = head +clone-recursive = true + +[provide] +test-drive = testdrive_dep diff --git a/subprojects/toml-f.wrap b/subprojects/toml-f.wrap index 752ba548..73195fe5 100644 --- a/subprojects/toml-f.wrap +++ b/subprojects/toml-f.wrap @@ -1,4 +1,7 @@ [wrap-git] -directory = toml-f url = https://github.com/toml-f/toml-f revision = head +clone-recursive = true + +[provide] +toml-f = toml_f_dep diff --git a/test/meson.build b/test/meson.build new file mode 100644 index 00000000..87173625 --- /dev/null +++ b/test/meson.build @@ -0,0 +1,39 @@ +# This file is part of crest. +# SPDX-Identifier: LGPL-3.0-or-later + +tests = [ + 'tblite', + 'gfnff', + 'gfn0', + 'gfn0occ', + 'CN', + 'optimization', + 'molecular_dynamics', +] + +test_srcs = files( + 'testmol.f90', + 'helpers.f90', + 'main.f90', +) +foreach t : tests + test_srcs += files('test_@0@.F90'.format(t)) +endforeach + +crest_tester = executable( + 'crest-tester', + sources : test_srcs, + include_directories : inc_dirs, + link_with : lib_crest, + dependencies : [testdrive_dep, lapack_dep, blas_dep] + + _omp_link_dep + _optional_deps, +) + +foreach t : tests + test( + 'crest/@0@'.format(t), + crest_tester, + args : [t], + timeout : 120, + ) +endforeach From 4f8057c190c1268a4b2835e670afd34dbb7ef76a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 15 Mar 2026 22:47:16 +0100 Subject: [PATCH 220/374] point libpvol to fork with modified meson build --- .gitmodules | 3 ++- subprojects/libpvol.wrap | 4 ++-- subprojects/pvol | 2 +- 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/.gitmodules b/.gitmodules index 9f61565e..2d9e347a 100644 --- a/.gitmodules +++ b/.gitmodules @@ -23,7 +23,8 @@ branch = main [submodule "subprojects/pvol"] path = subprojects/pvol - url = https://github.com/neudecker-group/libpvol.git + url = https://github.com/pprcht/libpvol.git + branch = build-update [submodule "subprojects/fmlip_relay"] path = subprojects/fmlip_relay url = https://github.com/pprcht/fmlip-relay.git diff --git a/subprojects/libpvol.wrap b/subprojects/libpvol.wrap index 71fd4ff9..958ae0b3 100644 --- a/subprojects/libpvol.wrap +++ b/subprojects/libpvol.wrap @@ -1,6 +1,6 @@ [wrap-git] -url = https://github.com/neudecker-group/libpvol.git -revision = head +url = https://github.com/pprcht/libpvol.git +revision = build-update clone-recursive = true [provide] diff --git a/subprojects/pvol b/subprojects/pvol index 55f4a736..5ed51340 160000 --- a/subprojects/pvol +++ b/subprojects/pvol @@ -1 +1 @@ -Subproject commit 55f4a7362ac81a119b97484f7fa0de577209146f +Subproject commit 5ed51340f0ec4529a3c1f25815ce18c78c4970c5 From f0d592522d2081c3f8ba5b541bc9d4d8044c7f32 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 15 Mar 2026 22:51:02 +0100 Subject: [PATCH 221/374] Update build systems for gfn0 and gfnff locally --- subprojects/gfn0 | 2 +- subprojects/gfnff | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/subprojects/gfn0 b/subprojects/gfn0 index 584cec4b..a2f0bcee 160000 --- a/subprojects/gfn0 +++ b/subprojects/gfn0 @@ -1 +1 @@ -Subproject commit 584cec4b47da23bf3634ef0dd798a1639fcc5e47 +Subproject commit a2f0bcee8b8fa86517b53b085b92a86294937db8 diff --git a/subprojects/gfnff b/subprojects/gfnff index 0491df2f..17550bea 160000 --- a/subprojects/gfnff +++ b/subprojects/gfnff @@ -1 +1 @@ -Subproject commit 0491df2ff1fe3cd80fc6a8630fea16f9b6840996 +Subproject commit 17550bea29804640caedbf04425aa0307b59972a From 5d13f55c5fc8c526e389c6a38c58fc61c369dcc1 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 15 Mar 2026 22:58:06 +0100 Subject: [PATCH 222/374] .gitignore update --- subprojects/.gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/subprojects/.gitignore b/subprojects/.gitignore index 9ac048cd..d4b04233 100644 --- a/subprojects/.gitignore +++ b/subprojects/.gitignore @@ -2,6 +2,7 @@ json-fortran-8.2.5.wrap xhcff lammps* +jonquil.wrap !lwoniom !gfn0 From 5ae05274a83b96c6b54079af8b92498c536d3c77 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 15 Mar 2026 23:23:50 +0100 Subject: [PATCH 223/374] meson build configuration updates --- config/modules/Findlibpvol.cmake | 5 +++-- meson.build | 4 ++-- subprojects/{libpvol.wrap => pvol.wrap} | 0 subprojects/toml-f.wrap | 2 +- 4 files changed, 6 insertions(+), 5 deletions(-) rename subprojects/{libpvol.wrap => pvol.wrap} (100%) diff --git a/config/modules/Findlibpvol.cmake b/config/modules/Findlibpvol.cmake index 2e756b9e..e62c52c2 100644 --- a/config/modules/Findlibpvol.cmake +++ b/config/modules/Findlibpvol.cmake @@ -16,7 +16,8 @@ set(_lib "pvol") set(_pkg "PVOL") -set(_url "https://github.com/neudecker-group/libpvol.git") +set(_url "https://github.com/pprcht/libpvol.git") +set(_branch "build-update") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf" ) @@ -24,7 +25,7 @@ endif() include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") -crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}") +crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}" "${_branch}") set(found FALSE) if(TARGET "pvol::pvol") diff --git a/meson.build b/meson.build index 0314366b..a6dc702b 100644 --- a/meson.build +++ b/meson.build @@ -174,7 +174,7 @@ endif # ═══════════════════════════════════════════════════════════════════════════════ tomlf_dep = dependency('toml-f', version : '>=0.2.4', - fallback : ['toml-f', 'toml_f_dep'], + fallback : ['toml-f', 'tomlf_dep'], required : get_option('toml-f'), static : static_build, ) @@ -215,7 +215,7 @@ if with_gfn0 endif libpvol_dep = dependency('libpvol', - fallback : ['libpvol', 'libpvol_dep'], + fallback : ['pvol', 'libpvol_dep'], required : get_option('libpvol'), static : static_build, ) diff --git a/subprojects/libpvol.wrap b/subprojects/pvol.wrap similarity index 100% rename from subprojects/libpvol.wrap rename to subprojects/pvol.wrap diff --git a/subprojects/toml-f.wrap b/subprojects/toml-f.wrap index 73195fe5..2045c395 100644 --- a/subprojects/toml-f.wrap +++ b/subprojects/toml-f.wrap @@ -4,4 +4,4 @@ revision = head clone-recursive = true [provide] -toml-f = toml_f_dep +toml-f = tomlf_dep From 65282e7c9c6520bf6b88150edd7c3739b44b1e13 Mon Sep 17 00:00:00 2001 From: Lukasrindt Date: Mon, 16 Mar 2026 13:35:39 +0100 Subject: [PATCH 224/374] Thermochem omp protected --- src/entropy/thermochem_module.f90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/entropy/thermochem_module.f90 b/src/entropy/thermochem_module.f90 index 4dd85fc3..d17fc489 100644 --- a/src/entropy/thermochem_module.f90 +++ b/src/entropy/thermochem_module.f90 @@ -301,8 +301,10 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & end if xyz = xyz*aatoau !> NOTE: BACK TO BOHRS - + + !$omp critical deallocate (vibs) + !$omp end critical return end subroutine calcthermo @@ -326,12 +328,14 @@ subroutine calc_thermo_from_hess(mol,hess,pr,nt,temps,ithr,& & '(10x,"::",1x,a,f24.12,1x,a,1x,"::")' nat3 = 3*mol%nat + !$omp critical allocate (freq(nat3)) allocate (et(nt)) allocate (ht(nt)) allocate (gt(nt)) allocate (stot(nt)) allocate (int_temps(nt)) + !$omp end critical int_temps = abs(temps-298.15_wp) nrt = minloc(int_temps(:),1) From 74ab5846b37f679a8e599523c4beb9332e417790 Mon Sep 17 00:00:00 2001 From: Lukasrindt Date: Mon, 16 Mar 2026 15:13:53 +0100 Subject: [PATCH 225/374] omp now really protected --- src/algos/hessian_tools.f90 | 9 +++++---- src/entropy/thermochem_module.f90 | 2 ++ src/optimize/optimize_maths.f90 | 16 +++++++++++++--- 3 files changed, 20 insertions(+), 7 deletions(-) diff --git a/src/algos/hessian_tools.f90 b/src/algos/hessian_tools.f90 index 716db799..dc177f8c 100644 --- a/src/algos/hessian_tools.f90 +++ b/src/algos/hessian_tools.f90 @@ -74,14 +74,15 @@ subroutine frequencies(nat,at,xyz,nat3,prj_mw_hess,freq,io) !Parameters for diagonalization lwork = 1+6*nat3+2*nat3**2 liwork = 3+5*nat3 - + + !$omp critical allocate (work(lwork),iwork(liwork)) - + !$omp end critical !Diagonalization call dsyevd('V','U',nat3,prj_mw_hess,nat3,freq,work,lwork,iwork,liwork,info) - + !$omp critical deallocate (work,iwork) - + !$omp end critical !Convert eigenvalues to frequencies do i = 1,nat3 if (freq(i) .gt. 0.0_wp) then diff --git a/src/entropy/thermochem_module.f90 b/src/entropy/thermochem_module.f90 index d17fc489..f1bed0ba 100644 --- a/src/entropy/thermochem_module.f90 +++ b/src/entropy/thermochem_module.f90 @@ -188,7 +188,9 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & call prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,sym,symchar,iunit) n3 = 3*nat + !$omp critical allocate (vibs(n3)) + !$omp critical end vibthr = 1.0 a = rabc(1) b = rabc(2) diff --git a/src/optimize/optimize_maths.f90 b/src/optimize/optimize_maths.f90 index 51284577..58f5a78f 100644 --- a/src/optimize/optimize_maths.f90 +++ b/src/optimize/optimize_maths.f90 @@ -216,7 +216,9 @@ subroutine gtrprojm(natoms,nat3,xyzucm,hess,ldebug,nmode,mode,ndim) nprj = 6 if (nmode .gt. 0) nprj = nprj+nmode !if (nmode .lt. 0) nprj = nprj + fixset%n * 3 + !$omp critical allocate (fmat(nat3,nprj)) + !$omp end critical fmat(:,:) = 0.0_wp if (nmode .ge. 0) then @@ -256,8 +258,10 @@ subroutine gtrprojm(natoms,nat3,xyzucm,hess,ldebug,nmode,mode,ndim) !> do projection call dsyprj(nat3,nprj,fmat,nat3,hess) - + + !$omp critical deallocate (fmat) + !$omp end critical return end subroutine gtrprojm @@ -462,8 +466,9 @@ subroutine dsyprj(nbdim,m,bmat,n,asym) external :: dsymm external :: dgemm !----------------------------------------------------------------- + !$omp critical allocate (scrb(n,m),scra(n,n)) - + !$omp end critical !> Expand trigonal matrix asym to full matrix on scra call dhtosq(n,scra,asym) !> Calculate scrb = asym*bmat (BLAS) @@ -491,8 +496,9 @@ subroutine dsyprj(nbdim,m,bmat,n,asym) asym(ij) = asym(ij)+scra(i,j) end do end do - + !$omp critical deallocate (scra,scrb) + !$omp end critical return end subroutine dsyprj @@ -539,7 +545,9 @@ subroutine dblckmgs(m,n,ndim,darray) !----------------------------------------------------------------- ! Allocate overlap matrix !----------------------------------------------------------------- + !$omp critical allocate (smat(ibsize,ibsize)) + !$omp end critical !----------------------------------------------------------------- ! Calculate the number of blocks @@ -603,7 +611,9 @@ subroutine dblckmgs(m,n,ndim,darray) end do !> Clean up and return + !$omp critical deallocate (smat) + !$omp end critical return end subroutine dblckmgs From f19f2f8b4da7374ceeb885691005e6ed9041adfd Mon Sep 17 00:00:00 2001 From: Lukasrindt Date: Mon, 16 Mar 2026 15:56:05 +0100 Subject: [PATCH 226/374] syntax error fixed --- src/entropy/thermochem_module.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/entropy/thermochem_module.f90 b/src/entropy/thermochem_module.f90 index f1bed0ba..17176e45 100644 --- a/src/entropy/thermochem_module.f90 +++ b/src/entropy/thermochem_module.f90 @@ -190,7 +190,7 @@ subroutine calcthermo(nat,at,xyz,freq,pr,ithr,fscal,sthr,nt,temps, & n3 = 3*nat !$omp critical allocate (vibs(n3)) - !$omp critical end + !$omp end critical vibthr = 1.0 a = rabc(1) b = rabc(2) From cc45794107da5dfae4799d6e6ff900424ddc72d8 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 16 Mar 2026 20:03:47 +0100 Subject: [PATCH 227/374] add fmlip-relay meson build --- meson_options.txt | 2 +- subprojects/fmlip_relay | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/meson_options.txt b/meson_options.txt index 971bcfff..6274b9f0 100644 --- a/meson_options.txt +++ b/meson_options.txt @@ -74,7 +74,7 @@ option('lwoniom', ) option('fmlip-relay', type : 'feature', - value : 'disabled', + value : 'auto', description : 'Enable fmlip-relay ML/IP interface', ) diff --git a/subprojects/fmlip_relay b/subprojects/fmlip_relay index b171981b..5cd56f3f 160000 --- a/subprojects/fmlip_relay +++ b/subprojects/fmlip_relay @@ -1 +1 @@ -Subproject commit b171981b6f3399de1af5d01040af6d60aee29956 +Subproject commit 5cd56f3f4b2ab8607f5132b00abb77b849640647 From dfb3cef6e0c0a5c4ab245e9e1c3a86cac3213463 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 16 Mar 2026 22:43:13 +0100 Subject: [PATCH 228/374] Update gfnff subproject commits --- subprojects/gfnff | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subprojects/gfnff b/subprojects/gfnff index 17550bea..0c16f5fc 160000 --- a/subprojects/gfnff +++ b/subprojects/gfnff @@ -1 +1 @@ -Subproject commit 17550bea29804640caedbf04425aa0307b59972a +Subproject commit 0c16f5fc6d599d3b169c6df2d348c61140249744 From 9d7eecff51fe8eb87f09dd0fdd4ad217fabbded2 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 16 Mar 2026 23:07:06 +0100 Subject: [PATCH 229/374] Add missing meson build srcs, fix weird printout format in ancopt --- src/algos/meson.build | 1 + src/calculator/meson.build | 1 + src/entropy/meson.build | 1 + src/optimize/ancopt.f90 | 6 +++--- src/optimize/meson.build | 1 + 5 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/algos/meson.build b/src/algos/meson.build index 8f7e466c..e944215c 100644 --- a/src/algos/meson.build +++ b/src/algos/meson.build @@ -34,4 +34,5 @@ srcs += files( 'parallel.f90', 'queueing.f90', 'alkylize.f90', + 'deform_opt_hess.f90', ) diff --git a/src/calculator/meson.build b/src/calculator/meson.build index ffd39a79..dc374d5e 100644 --- a/src/calculator/meson.build +++ b/src/calculator/meson.build @@ -41,4 +41,5 @@ srcs += files( 'approxg.f90', 'penalty.f90', 'mlip_sc.F90', + 'hessian_reconstruct.f90', ) diff --git a/src/entropy/meson.build b/src/entropy/meson.build index 08194304..161fabff 100644 --- a/src/entropy/meson.build +++ b/src/entropy/meson.build @@ -20,4 +20,5 @@ srcs += files( 'mie.f90', 'entropic.f90', 'entropy.f90', + 'thermochem_module.f90', ) diff --git a/src/optimize/ancopt.f90 b/src/optimize/ancopt.f90 index cb40546b..36e7a23f 100644 --- a/src/optimize/ancopt.f90 +++ b/src/optimize/ancopt.f90 @@ -185,7 +185,7 @@ subroutine ancopt(mol,calc,etot,grd,pr,wr,iostatus) write (*,'(5x,"change ΔE",e18.7,1x,"Eh")') 0.0_wp write (*,'(3x,"gradient norm :",f14.7,1x,"Eh/a0")',advance='no') gnorm write (*,'(2x,"predicted",e18.7)',advance='no') 0.0_wp - write (*,'(1x,"("f7.2"%)")')-0.0_wp + write (*,'(1x,"(",f7.2,"%)")')-0.0_wp end if !>====================================================================== @@ -456,12 +456,12 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & if (ii > 1) then dummy = (depred-echng)/echng*100.0_wp if (abs(dummy) < 1000.0_wp) then - write (*,'(1x,"("f7.2"%)")') dummy + write (*,'(1x,"("f7.2,"%)")') dummy else write (*,'(1x,"(*******%)")') end if else - write (*,'(1x,"("f7.2"%)")')-100.0_wp + write (*,'(1x,"(",f7.2,"%)")')-100.0_wp end if end if diff --git a/src/optimize/meson.build b/src/optimize/meson.build index 1a4241a5..1955147a 100644 --- a/src/optimize/meson.build +++ b/src/optimize/meson.build @@ -19,6 +19,7 @@ srcs += files( 'gd.f90', 'rfo.f90', 'lbfgs.f90', + 'newton_raphson.f90', 'coordtrafo.f90', 'hessupdate.f90', 'modelhessian.f90', From 157100eb0285c20b19a047c81495bcf4f231767e Mon Sep 17 00:00:00 2001 From: Lukasrindt Date: Tue, 17 Mar 2026 11:37:08 +0100 Subject: [PATCH 230/374] omp critical for symmetry --- src/calculator/hr_utils.f90 | 2 ++ src/entropy/thermochem_module.f90 | 3 +++ src/optimize/optimize_module.f90 | 10 ++++++++-- 3 files changed, 13 insertions(+), 2 deletions(-) diff --git a/src/calculator/hr_utils.f90 b/src/calculator/hr_utils.f90 index ebfe5307..42615636 100644 --- a/src/calculator/hr_utils.f90 +++ b/src/calculator/hr_utils.f90 @@ -91,8 +91,10 @@ subroutine initialize_hessian(calc,type,xyz,nat,at,hess,hguess,pr) !>Matrix is f call numhess1(nat,at,xyz,newcalc,hess_full(:,:),io) call dsqtoh(nat3,hess_full(:,:),hess(:)) case (5) + !$omp critical mhset%model = calc%mh_type call modhes(calc,mhset,nat,xyz,at,hess(:),pr) + !$omp end critical end select !call axis(nat,at,xyz,rot,dumi) diff --git a/src/entropy/thermochem_module.f90 b/src/entropy/thermochem_module.f90 index 17176e45..1737f3e6 100644 --- a/src/entropy/thermochem_module.f90 +++ b/src/entropy/thermochem_module.f90 @@ -61,7 +61,10 @@ subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar,iunit) !>--- symmetry number from rotational symmetry xyz = xyz/bohr + !write(stdout,*) nat,at,xyz,desy,maxat,sfsym + !$omp critical call getsymmetry2(.false.,6,nat,at,xyz,desy,maxat,sfsym) + !$omp end critical xyz = xyz*bohr sym = sfsym(1:3) symchar = sym diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index 1482770a..09b8ebde 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -161,20 +161,26 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) end if !write(stdout,*) calc%g_sampling - + write(*,*) "TEST" if (calc%g_sampling) then pr2 = .false. !write(stdout,*) "Running gs" !write(stdout,*) "Energy pre correction", etot + !$omp critical allocate(g_hess(nat3*(nat3+1)/2),g_hess_full(nat3,nat3)) + !$omp end critical call initialize_hessian(calc,calc%gs_hess_type,molnew%xyz,molnew%nat,molnew%at,g_hess,calc%chess%hguess,pr2) + !write(*,*) "Hess Initialized" call dhtosq(nat3,g_hess_full,g_hess) + !write(*,*) "Hess diagonalized" call calc_thermo_from_hess(molnew,g_hess_full,pr2, & & calc%nt,calc%temperatures,calc%ithr,calc%fscal,calc%sthr,calc%et, & & calc%ht,calc%gt,calc%stot,etot) + !write(*,*) "Thermo calculated" - + !$omp critical allocate (int_temps(calc%nt)) + !$omp end critical int_temps = abs(calc%temperatures-298.15_wp) nrt = minloc(int_temps(:),1) From 748828506227f2290b13465e659a17eed3e16904 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 17 Mar 2026 18:09:02 +0100 Subject: [PATCH 231/374] Start work on parallel free energy correction calculation --- src/algos/parallel.f90 | 259 ++++++++++++++++++++++++++++--- src/algos/refine.f90 | 7 + src/classes.f90 | 20 ++- src/optimize/optimize_module.f90 | 1 - src/parsing/parse_calcdata.f90 | 2 + 5 files changed, 268 insertions(+), 21 deletions(-) diff --git a/src/algos/parallel.f90 b/src/algos/parallel.f90 index 5d2f40c1..008de927 100644 --- a/src/algos/parallel.f90 +++ b/src/algos/parallel.f90 @@ -68,6 +68,25 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) type(calcdata),intent(in),target,optional :: customcalc end subroutine crest_oloop end interface + + interface + subroutine crest_hessloop(env,nat,nall,at,xyz,eread) + use crest_parameters,only:wp,stdout,sep + use crest_calculator + use omp_lib + use crest_data + use strucrd + use thermochem_module + use iomod,only:makedir,directory_exist,remove + implicit none + type(systemdata),intent(inout) :: env + real(wp),intent(inout) :: xyz(3,nat,nall) + integer,intent(in) :: at(nat) + real(wp),intent(inout) :: eread(nall) + integer,intent(in) :: nat,nall + end subroutine crest_hessloop + end interface + end module parallel_interface !========================================================================================! @@ -120,12 +139,12 @@ subroutine crest_sploop(env,nat,nall,at,xyz,eread) call new_ompautoset(env,'auto_nested',nall,T,Tn) nested = env%omp_allow_nested - !>--- prepare objects for parallelization T = env%threads allocate (calculations(T),source=env%calc) allocate (mols(T)) do i = 1,T + call calculations(T)%copy(env%calc) do j = 1,env%calc%ncalculations calculations(i)%calcs(j) = env%calc%calcs(j) !>--- directories and io preparation @@ -135,8 +154,8 @@ subroutine crest_sploop(env,nat,nall,at,xyz,eread) end if write (atmp,'(a,"_",i0)') sep,i calculations(i)%calcs(j)%calcspace = env%calc%calcs(j)%calcspace//trim(atmp) - if(allocated(calculations(i)%calcs(j)%calcfile)) deallocate(calculations(i)%calcs(j)%calcfile) - if(allocated(calculations(i)%calcs(j)%systemcall)) deallocate(calculations(i)%calcs(j)%systemcall) + if (allocated(calculations(i)%calcs(j)%calcfile)) deallocate (calculations(i)%calcs(j)%calcfile) + if (allocated(calculations(i)%calcs(j)%systemcall)) deallocate (calculations(i)%calcs(j)%systemcall) call calculations(i)%calcs(j)%printid(i,j) end do calculations(i)%pr_energies = .false. @@ -231,6 +250,210 @@ subroutine crest_sploop(env,nat,nall,at,xyz,eread) return end subroutine crest_sploop +!========================================================================================! +!========================================================================================! +!> Routines for concurrent singlepoint evaluations +!========================================================================================! +!========================================================================================! +subroutine crest_hessloop(env,nat,nall,at,xyz,eread) +!*************************************************************** +!* subroutine crest_sploop +!* This subroutine performs concurrent singlepoint evaluations +!* for the given ensemble. Input eread is overwritten +!* xyz must be in Bohrs +!*************************************************************** + use crest_parameters,only:wp,stdout,sep + use crest_calculator + use omp_lib + use crest_data + use strucrd + use optimize_module + use thermochem_module + use iomod,only:makedir,directory_exist,remove + implicit none + type(systemdata),intent(inout) :: env + real(wp),intent(inout) :: xyz(3,nat,nall) + integer,intent(in) :: at(nat) + real(wp),intent(inout) :: eread(nall) + integer,intent(in) :: nat,nall + + type(coord),allocatable :: mols(:) + integer :: i,j,k,l,io,ich,ich2,c,z,job_id,zcopy,nat3 + logical :: pr,wr,ex + type(calcdata),allocatable :: calculations(:) + real(wp) :: energy,gnorm + real(wp),allocatable :: grad(:,:),grads(:,:,:) + real(wp),allocatable :: freqs(:,:),hess(:,:,:) + integer :: thread_id,vz,job + character(len=80) :: atmp + real(wp) :: percent,runtime + + integer :: nt,nrt + real(wp),allocatable :: temps(:,:),et(:,:),ht(:,:),gt(:,:),stot(:,:) + real(wp) :: ithr,sthr,fscal + character(len=:),allocatable :: emodel + + type(timer) :: profiler + integer :: T,Tn !> threads and threads per core + logical :: nested + real(wp),parameter :: big = 10e10 + +!>--- check if we have any calculation settings allocated + if (env%calc%ncalculations < 1) then + write (stdout,*) 'no calculations allocated' + return + end if + +!>--- prepare calculation objects for parallelization (one per thread) + call new_ompautoset(env,'auto_nested',nall,T,Tn) + nested = env%omp_allow_nested + +!>--- prepare objects for parallelization + T = env%threads + allocate (calculations(T))!,source=env%calc) + allocate (mols(T)) + nat3 = nat*3 + allocate (freqs(nat3,T),source=0.0_wp) + allocate (hess(nat3,nat3,T),source=0.0_wp) + do i = 1,T + call calculations(i)%copy(env%calc) + do j = 1,env%calc%ncalculations + !calculations(i)%calcs(j) = env%calc%calcs(j) + !>--- directories and io preparation + ex = directory_exist(env%calc%calcs(j)%calcspace) + if (.not.ex) then + io = makedir(trim(env%calc%calcs(j)%calcspace)) + end if + write (atmp,'(a,"_",i0)') sep,i + calculations(i)%calcs(j)%calcspace = env%calc%calcs(j)%calcspace//trim(atmp) + if (allocated(calculations(i)%calcs(j)%calcfile)) deallocate (calculations(i)%calcs(j)%calcfile) + if (allocated(calculations(i)%calcs(j)%systemcall)) deallocate (calculations(i)%calcs(j)%systemcall) + call calculations(i)%calcs(j)%printid(i,j) + end do + calculations(i)%pr_energies = .false. + allocate (mols(i)%at(nat),mols(i)%xyz(3,nat)) + end do + +!>--- thermo settings + !> inversion threshold + ithr = env%thermo%ithr + !> frequency scaling factor + fscal = env%thermo%fscal + !> RR-HO interpolation (or cut-off) + sthr = env%thermo%sthr + !> Svib model + emodel = env%thermo%emodel + if (.not.allocated(env%thermo%temps)) then + call env%thermo%get_temps() + end if + nt = 1 + allocate (temps(nt,T),et(nt,T),ht(nt,T),gt(nt,T),stot(nt,T),source=0.0_wp) + temps = env%thermo%get_close_rt(nrt) + +!>--- printout directions and timer initialization + pr = .false. !> stdout printout + wr = .false. !> write crestopt.log.xyz + call profiler%init(1) + call profiler%start(1) + +!>--- first progress printout (initializes progress variables) + call crest_oloop_pr_progress(env,nall,0) + +!>--- shared variables + allocate (grads(3,nat,T),source=0.0_wp) + c = 0 !> counter of successfull optimizations + k = 0 !> counter of total optimization (fail+success) + z = 0 !> counter to perform optimization in right order (1...nall) + eread(:) = 0.0_wp + grads(:,:,:) = 0.0_wp +!>--- loop over ensemble + !$omp parallel & + !$omp shared(env,calculations,nat,nall,at,xyz,eread,grads,c,k,z,pr,wr) & + !$omp shared(ich,ich2,mols,nested,Tn,freqs,hess) + !$omp single + do i = 1,nall + + call initsignal() + vz = i + !$omp task firstprivate( vz ) private(i,j,job,energy,io,thread_id,zcopy) + call initsignal() + + !>--- OpenMP nested region threads + if (nested) call ompmklset(Tn) + + thread_id = OMP_GET_THREAD_NUM() + job = thread_id+1 + !>--- modify calculation spaces + !$omp critical + z = z+1 + zcopy = z + mols(job)%nat = nat + mols(job)%at(:) = at(:) + mols(job)%xyz(:,:) = xyz(:,:,z) + !$omp end critical + + !>-- engery+gradient call first, for setup + call engrad(mols(job),calculations(job),energy,grads(:,:,job),io) + !>-- then, numerical hessian + !call numhess2(mols(job)%nat,mols(job)%at,mols(job)%xyz,calculations(job),hess(:,:,job),io) + !!$omp critical + !if (io .eq. 0) then + ! call prj_mw_hess(mols(job)%nat,mols(job)%at,nat3,mols(job)%xyz,hess(:,:,job)) + ! !>-- Computes the Frequencies + ! call frequencies(mols(job)%nat,mols(job)%at,mols(job)%xyz,nat3,hess(:,:,job),freqs(:,job),io) + !end if + + !if (io .eq. 0) then + ! !call calcthermo(mols(job)%nat,mols(job)%at,mols(job)%xyz,freqs(:,job),.false., & + ! ! ithr,fscal,sthr,nt,temps(:,job),et(:,job),ht(:,job),gt(:,job),stot(:,job), emodel=emodel) + !end if + !!$omp end critical + + !$omp critical + if (io == 0) then + !>--- successful optimization (io==0) + c = c+1 + eread(zcopy) = 0.0_wp !gt(1,job) + else + eread(zcopy) = big + end if + k = k+1 + !>--- print progress + call crest_oloop_pr_progress(env,nall,k) + !$omp end critical + !$omp end task + end do + !$omp taskwait + !$omp end single + !$omp end parallel + +!>--- finalize progress printout + call crest_oloop_pr_progress(env,nall,-1) + +!>--- stop timer + call profiler%stop(1) + +!>--- prepare some summary printout + percent = float(c)/float(nall)*100.0_wp + write (atmp,'(f5.1,a)') percent,'% success)' + write (stdout,'(">",1x,i0,a,i0,a,a)') c,' of ',nall,' structures successfully evaluated (', & + & trim(adjustl(atmp)) + write (atmp,'(">",1x,a,i0,a)') 'Total runtime for ',nall,' frequency calculations:' + call profiler%write_timing(stdout,1,trim(atmp),.true.) + runtime = profiler%get(1) + write (atmp,'(f16.3,a)') runtime/real(nall,wp),' sec' + write (stdout,'(a,a,a)') '> Corresponding to approximately ',trim(adjustl(atmp)), & + & ' per processed structure' + + deallocate (grads) + call profiler%clear() + deallocate (calculations) + if (allocated(mols)) deallocate (mols) + if (allocated(freqs)) deallocate (freqs) + if (allocated(hess)) deallocate (hess) + return +end subroutine crest_hessloop + !========================================================================================! !========================================================================================! !> Routines for concurrent geometry optimization @@ -244,7 +467,7 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) !* env - contains parallelization and other program settings !* dump - decides on whether to dump an ensemble file !* WARNING: the ensemble file will NOT be in the same order -!* as the input xyz array. However, the overwritten xyz will be! +!* as the input xyz array. However, the overwritten xyz will be! !* !* customcalc - customized (optional) calculation level data !* @@ -289,11 +512,11 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) end if !>--- check which calc to use - if(present(customcalc))then + if (present(customcalc)) then mycalc => customcalc else mycalc => env%calc - endif + end if !>--- check if we have any calculation settings allocated if (mycalc%ncalculations < 1) then @@ -317,13 +540,13 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) if (.not.ex) then io = makedir(trim(mycalc%calcs(j)%calcspace)) end if - if(calculations(i)%calcs(j)%id == jobtype%tblite)then - calculations(i)%optnewinit=.true. - endif + if (calculations(i)%calcs(j)%id == jobtype%tblite) then + calculations(i)%optnewinit = .true. + end if write (atmp,'(a,"_",i0)') sep,i calculations(i)%calcs(j)%calcspace = mycalc%calcs(j)%calcspace//trim(atmp) - if(allocated(calculations(i)%calcs(j)%calcfile)) deallocate(calculations(i)%calcs(j)%calcfile) - if(allocated(calculations(i)%calcs(j)%systemcall)) deallocate(calculations(i)%calcs(j)%systemcall) + if (allocated(calculations(i)%calcs(j)%calcfile)) deallocate (calculations(i)%calcs(j)%calcfile) + if (allocated(calculations(i)%calcs(j)%systemcall)) deallocate (calculations(i)%calcs(j)%systemcall) call calculations(i)%calcs(j)%printid(i,j) end do calculations(i)%pr_energies = .false. @@ -397,7 +620,7 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) end if eread(zcopy) = energy xyz(:,:,zcopy) = molsnew(job)%xyz(:,:) - else if(io==calculations(job)%maxcycle .and. calculations(job)%anopt) then + else if (io == calculations(job)%maxcycle.and.calculations(job)%anopt) then !>--- allow partial optimization? c = c+1 eread(zcopy) = energy @@ -578,8 +801,8 @@ subroutine crest_search_multimd(env,mol,mddats,nsim) end if write (atmp,'(a,"_",i0)') sep,i calculations(i)%calcs(j)%calcspace = env%calc%calcs(j)%calcspace//trim(atmp) - if(allocated(calculations(i)%calcs(j)%calcfile)) deallocate(calculations(i)%calcs(j)%calcfile) - if(allocated(calculations(i)%calcs(j)%systemcall)) deallocate(calculations(i)%calcs(j)%systemcall) + if (allocated(calculations(i)%calcs(j)%calcfile)) deallocate (calculations(i)%calcs(j)%calcfile) + if (allocated(calculations(i)%calcs(j)%systemcall)) deallocate (calculations(i)%calcs(j)%systemcall) call calculations(i)%calcs(j)%printid(i,j) end do calculations(i)%pr_energies = .false. @@ -882,8 +1105,8 @@ subroutine crest_search_multimd2(env,mols,mddats,nsim) end if write (atmp,'(a,"_",i0)') sep,i calculations(i)%calcs(j)%calcspace = env%calc%calcs(j)%calcspace//trim(atmp) - if(allocated(calculations(i)%calcs(j)%calcfile)) deallocate(calculations(i)%calcs(j)%calcfile) - if(allocated(calculations(i)%calcs(j)%systemcall)) deallocate(calculations(i)%calcs(j)%systemcall) + if (allocated(calculations(i)%calcs(j)%calcfile)) deallocate (calculations(i)%calcs(j)%calcfile) + if (allocated(calculations(i)%calcs(j)%systemcall)) deallocate (calculations(i)%calcs(j)%systemcall) call calculations(i)%calcs(j)%printid(i,j) end do calculations(i)%pr_energies = .false. @@ -1027,9 +1250,9 @@ subroutine parallel_md_block_printout(MD,vz) else write (stdout,'(2x,"| Vbias exponent (α) :",f8.4," |")') MD%mtd(1)%alpha end if - if (allocated(MD%mtd(1)%atinclude))then + if (allocated(MD%mtd(1)%atinclude)) then write (stdout,'(2x,"| # active atoms :",i9," atoms |")') count(MD%mtd(1)%atinclude,1) - endif + end if end if !$omp end critical diff --git a/src/algos/refine.f90 b/src/algos/refine.f90 index 9295a35f..b6d2966d 100644 --- a/src/algos/refine.f90 +++ b/src/algos/refine.f90 @@ -84,6 +84,8 @@ subroutine crest_refine(env,input,output) !> set the calculator to the correct stage env%calc%refine_stage = refine_stage + write(*,*) env%calc%refine_stage + select case (refine_stage) case (refine%singlepoint) write (stdout,'("> Singlepoint re-ranking for ",i0," structures")') nall @@ -98,6 +100,11 @@ subroutine crest_refine(env,input,output) write (stdout,'("> Geometry optimization of ",i0," structures")') nall call crest_oloop(env,nat,nall,at,xyz,eread,.false.) + case (refine%deltaG) + write (stdout,'("> Free energy correction (δG) for ",i0," structures")') nall + call crest_hessloop(env,nat,nall,at,xyz,etmp) + eread(:) = eread(:)+etmp(:) + case (refine%confsolv) call new_ompautoset(env,'subprocess',1,t1,t2) write (stdout,'("> ConfSolv: ΔΔGsoln estimation from 3D directed message passing neural networks (D-MPNN)")') diff --git a/src/classes.f90 b/src/classes.f90 index 897a047a..f27f565f 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -133,6 +133,7 @@ module crest_data integer :: correction = 2 integer :: geoopt = 3 integer :: ConfSolv = 4 + integer :: deltaG = 5 end type refine_type type(refine_type), parameter,public :: refine = refine_type() @@ -296,6 +297,7 @@ module crest_data contains procedure :: get_temps => thermo_get_temps procedure :: read_temps => thermo_read_temps + procedure :: get_close_rt => thermo_get_close_rt end type thermodata !========================================================================================! @@ -974,7 +976,7 @@ function optlevnum(flag,iostat) result(optlev) real(wp) :: optlev character(len=*),intent(in) :: flag integer,intent(out),optional :: iostat - if(present(iostat)) iostat = 0 + if (present(iostat)) iostat = 0 optlev = 0.0_wp select case (trim(adjustl(flag))) case ('crude','-3') @@ -992,7 +994,7 @@ function optlevnum(flag,iostat) result(optlev) case ('extreme','3') optlev = 3.0_wp case default - if(present(iostat)) iostat = 1 + if (present(iostat)) iostat = 1 end select return end function optlevnum @@ -1098,6 +1100,20 @@ subroutine thermo_read_temps(self,fname) return end subroutine thermo_read_temps + function thermo_get_close_rt(self,nrt) result(temp) + implicit none + class(thermodata) :: self + integer,intent(out) :: nrt + real(wp) :: temp + integer :: i,nt,io,ich + real(wp),allocatable :: tmptemps(:) + nrt = 0 + nt = self%ntemps + allocate (tmptemps(nt),source=0.0_wp) + tmptemps(:) = abs(self%temps(:)-298.15_wp) + nrt = minloc(tmptemps,1) + temp = tmptemps(nrt) + end function thermo_get_close_rt !========================================================================================! !========================================================================================! end module crest_data diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index fc0d729f..89f3b310 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -160,7 +160,6 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) end if !write(stdout,*) calc%g_sampling - write(*,*) "TEST" if (calc%g_sampling) then pr2 = .false. !write(stdout,*) "Running gs" diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index fbc980ec..7f7f0eb2 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -376,6 +376,8 @@ subroutine parse_setting_auto(env,job,kv,rd) job%refine_lvl = refine%correction case ('opt','optimization') job%refine_lvl = refine%geoopt + case ('freq','frequencies','deltag') + job%refine_lvl = refine%deltaG case default job%refine_lvl = refine%non !>--- keyword was recognized, but invalid argument supplied From 9487c3aa597b4af3f6c805cbad8795a4ff8209a4 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 17 Mar 2026 21:39:38 +0100 Subject: [PATCH 232/374] fix function --- src/classes.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/classes.f90 b/src/classes.f90 index f27f565f..066d39ba 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -1112,7 +1112,7 @@ function thermo_get_close_rt(self,nrt) result(temp) allocate (tmptemps(nt),source=0.0_wp) tmptemps(:) = abs(self%temps(:)-298.15_wp) nrt = minloc(tmptemps,1) - temp = tmptemps(nrt) + temp = self%temps(nrt) end function thermo_get_close_rt !========================================================================================! !========================================================================================! From 4cd1127a7ed40bfa7eb0e75c2f3e21485149d3dc Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 17 Mar 2026 22:08:59 +0100 Subject: [PATCH 233/374] serial loop for dG refine implementation --- src/algos/parallel.f90 | 51 +++++++++++++++++++++++++----------------- src/algos/refine.f90 | 2 -- src/symmetry_i.c | 4 ++-- 3 files changed, 32 insertions(+), 25 deletions(-) diff --git a/src/algos/parallel.f90 b/src/algos/parallel.f90 index 008de927..f723b082 100644 --- a/src/algos/parallel.f90 +++ b/src/algos/parallel.f90 @@ -261,6 +261,11 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread) !* This subroutine performs concurrent singlepoint evaluations !* for the given ensemble. Input eread is overwritten !* xyz must be in Bohrs +!* +!* WARNING: OpenMP doesn't seem to like numhess2. We are hence +!* doing the loop serial, and hope for parallelization of the +!* underlying potentials +!* !*************************************************************** use crest_parameters,only:wp,stdout,sep use crest_calculator @@ -367,15 +372,15 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread) eread(:) = 0.0_wp grads(:,:,:) = 0.0_wp !>--- loop over ensemble - !$omp parallel & - !$omp shared(env,calculations,nat,nall,at,xyz,eread,grads,c,k,z,pr,wr) & - !$omp shared(ich,ich2,mols,nested,Tn,freqs,hess) - !$omp single +! !$omp parallel & +! !$omp shared(env,calculations,nat,nall,at,xyz,eread,grads,c,k,z,pr,wr) & +! !$omp shared(ich,ich2,mols,nested,Tn,freqs,hess) +! !$omp single do i = 1,nall call initsignal() vz = i - !$omp task firstprivate( vz ) private(i,j,job,energy,io,thread_id,zcopy) +! !$omp task firstprivate( vz ) private(i,j,job,energy,io,thread_id,zcopy) call initsignal() !>--- OpenMP nested region threads @@ -395,25 +400,29 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread) !>-- engery+gradient call first, for setup call engrad(mols(job),calculations(job),energy,grads(:,:,job),io) !>-- then, numerical hessian - !call numhess2(mols(job)%nat,mols(job)%at,mols(job)%xyz,calculations(job),hess(:,:,job),io) + call numhess2(mols(job)%nat,mols(job)%at,mols(job)%xyz, & + calculations(job),hess(:,:,job),io) !!$omp critical - !if (io .eq. 0) then - ! call prj_mw_hess(mols(job)%nat,mols(job)%at,nat3,mols(job)%xyz,hess(:,:,job)) - ! !>-- Computes the Frequencies - ! call frequencies(mols(job)%nat,mols(job)%at,mols(job)%xyz,nat3,hess(:,:,job),freqs(:,job),io) - !end if - - !if (io .eq. 0) then - ! !call calcthermo(mols(job)%nat,mols(job)%at,mols(job)%xyz,freqs(:,job),.false., & - ! ! ithr,fscal,sthr,nt,temps(:,job),et(:,job),ht(:,job),gt(:,job),stot(:,job), emodel=emodel) - !end if + if (io .eq. 0) then + call prj_mw_hess(mols(job)%nat,mols(job)%at,nat3,mols(job)%xyz,hess(:,:,job)) + !>-- Computes the Frequencies + call frequencies(mols(job)%nat,mols(job)%at,mols(job)%xyz, & + nat3,hess(:,:,job),freqs(:,job),io) + end if + + if (io .eq. 0) then + call calcthermo(mols(job)%nat,mols(job)%at,mols(job)%xyz, & + freqs(:,job),.false.,ithr,fscal,sthr,nt, & + temps(:,job),et(:,job),ht(:,job),gt(:,job), & + stot(:,job),emodel=emodel) + end if !!$omp end critical !$omp critical if (io == 0) then !>--- successful optimization (io==0) c = c+1 - eread(zcopy) = 0.0_wp !gt(1,job) + eread(zcopy) = gt(1,job) else eread(zcopy) = big end if @@ -421,11 +430,11 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread) !>--- print progress call crest_oloop_pr_progress(env,nall,k) !$omp end critical - !$omp end task + ! !$omp end task end do - !$omp taskwait - !$omp end single - !$omp end parallel + ! !$omp taskwait + ! !$omp end single + ! !$omp end parallel !>--- finalize progress printout call crest_oloop_pr_progress(env,nall,-1) diff --git a/src/algos/refine.f90 b/src/algos/refine.f90 index b6d2966d..f6f5f060 100644 --- a/src/algos/refine.f90 +++ b/src/algos/refine.f90 @@ -84,8 +84,6 @@ subroutine crest_refine(env,input,output) !> set the calculator to the correct stage env%calc%refine_stage = refine_stage - write(*,*) env%calc%refine_stage - select case (refine_stage) case (refine%singlepoint) write (stdout,'("> Singlepoint re-ranking for ",i0," structures")') nall diff --git a/src/symmetry_i.c b/src/symmetry_i.c index 06532c48..000240ac 100644 --- a/src/symmetry_i.c +++ b/src/symmetry_i.c @@ -1711,8 +1711,8 @@ for( i = 0 ; i < PointGroupsCount ; i++ ){ } } if( matching_count == 0 ){ - printf( "WARNING: These symmetry elements match no point group I know of. Sorry.\n" - "Trying fallback mode to highest recognized Axis...\n" ) ; + //printf( "WARNING: These symmetry elements match no point group I know of. Sorry.\n" + // "Trying fallback mode to highest recognized Axis...\n" ) ; return -1; } if( matching_count > 1 ){ From a70d06bb8c61d0e898ab385c5918b59783810eab Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 17 Mar 2026 23:46:35 +0100 Subject: [PATCH 234/374] Add (unused) symmetry_i.f90 rewrite of the C code --- src/symmetry_i.f90 | 1732 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1732 insertions(+) create mode 100644 src/symmetry_i.f90 diff --git a/src/symmetry_i.f90 b/src/symmetry_i.f90 new file mode 100644 index 00000000..419cfa2a --- /dev/null +++ b/src/symmetry_i.f90 @@ -0,0 +1,1732 @@ +!> symmetry_i.f90 +!> Brute force symmetry analyzer - Fortran module +!> +!> Original C code: (C) 1996, 2003 S. Patchkovskii +!> Fortran conversion of the original C code +!> +!> This program is free software; you can redistribute it and/or modify +!> it under the terms of the GNU General Public License as published by +!> the Free Software Foundation; either version 2 of the License, or +!> (at your option) any later version. + +! WARNING: Currently unused and untested! + +module symmetry_i + use iso_fortran_env,only:wp => real64 + implicit none + private + + ! Public interface + public :: schoenflies + public :: symmetry_element,atom_t + public :: set_symmetry_tolerance + + !> Mathematical constants + real(wp),parameter :: PI = 3.14159265358979323846d0 + integer,parameter :: DIMENSION = 3 + integer,parameter :: MAXPARAM = 7 + + !> Atom type + type :: atom_t + integer :: atom_type + real(wp) :: x(DIMENSION) + end type atom_t + + !> Symmetry element type + type :: symmetry_element + integer :: transform_type ! 1=mirror, 2=invert, 3=rotate, 4=rotate_reflect + integer,allocatable :: transform(:) + integer :: order + integer :: nparam + real(wp) :: maxdev + real(wp) :: distance + real(wp) :: normal(DIMENSION) + real(wp) :: direction(DIMENSION) + end type symmetry_element + + !> Point group type + type :: point_group + character(len=8) :: group_name + character(len=64) :: symmetry_code + end type point_group + + !> Module-level parameters (can be modified) + real(wp),save :: ToleranceSame = 1.0d-3 + real(wp),save :: TolerancePrimary = 5.0d-2 + real(wp),save :: ToleranceFinal = 1.0d-4 + real(wp),save :: MaxOptStep = 5.0d-1 + real(wp),save :: MinOptStep = 1.0d-7 + real(wp),save :: GradientStep = 1.0d-7 + real(wp),save :: OptChangeThreshold = 1.0d-10 + integer,save :: verbose = 0 + integer,save :: MaxOptCycles = 200 + integer,save :: OptChangeHits = 5 + integer,save :: MaxAxisOrder = 20 + + !> Working data + real(wp),save :: CenterOfSomething(DIMENSION) + real(wp),allocatable,save :: DistanceFromCenter(:) + integer,save :: AtomsCount = 0 + type(atom_t),allocatable,save :: Atoms(:) + + !> Symmetry elements storage + integer,save :: PlanesCount = 0 + type(symmetry_element),allocatable,save :: Planes(:) + type(symmetry_element),allocatable,save :: MolecularPlane + logical,save :: MolecularPlaneExists = .false. + integer,save :: InversionCentersCount = 0 + type(symmetry_element),allocatable,save :: InversionCenters(:) + integer,save :: NormalAxesCount = 0 + type(symmetry_element),allocatable,save :: NormalAxes(:) + integer,save :: ImproperAxesCount = 0 + type(symmetry_element),allocatable,save :: ImproperAxes(:) + integer,allocatable,save :: NormalAxesCounts(:) + integer,allocatable,save :: ImproperAxesCounts(:) + integer,save :: BadOptimization = 0 + character(len=256),save :: SymmetryCode = "" + character(len=8),save :: MaxRotAxis = "" + + !> Statistics + integer(8),save :: StatTotal = 0 + integer(8),save :: StatEarly = 0 + integer(8),save :: StatPairs = 0 + integer(8),save :: StatDups = 0 + integer(8),save :: StatOrder = 0 + integer(8),save :: StatOpt = 0 + integer(8),save :: StatAccept = 0 + + !> Point groups table + integer,parameter :: PointGroupsCount = 60 + type(point_group),save :: PointGroups(PointGroupsCount) + logical,save :: PointGroupsInitialized = .false. + +! ══════════════════════════════════════════════════════════════════════════════ +contains !> MODULE PROCEDURES START HERE +! ══════════════════════════════════════════════════════════════════════════════ + + !> Initialize point groups table + subroutine init_point_groups() + if (PointGroupsInitialized) return + + PointGroups(1) = point_group("C1","") + PointGroups(2) = point_group("Cs","(sigma) ") + PointGroups(3) = point_group("Ci","(i) ") + PointGroups(4) = point_group("C2","(C2) ") + PointGroups(5) = point_group("C3","(C3) ") + PointGroups(6) = point_group("C4","(C4) (C2) ") + PointGroups(7) = point_group("C5","(C5) ") + PointGroups(8) = point_group("C6","(C6) (C3) (C2) ") + PointGroups(9) = point_group("C7","(C7) ") + PointGroups(10) = point_group("C8","(C8) (C4) (C2) ") + PointGroups(11) = point_group("D2","3*(C2) ") + PointGroups(12) = point_group("D3","(C3) 3*(C2) ") + PointGroups(13) = point_group("D4","(C4) 5*(C2) ") + PointGroups(14) = point_group("D5","(C5) 5*(C2) ") + PointGroups(15) = point_group("D6","(C6) (C3) 7*(C2) ") + PointGroups(16) = point_group("D7","(C7) 7*(C2) ") + PointGroups(17) = point_group("D8","(C8) (C4) 9*(C2) ") + PointGroups(18) = point_group("C2v","(C2) 2*(sigma) ") + PointGroups(19) = point_group("C3v","(C3) 3*(sigma) ") + PointGroups(20) = point_group("C4v","(C4) (C2) 4*(sigma) ") + PointGroups(21) = point_group("C5v","(C5) 5*(sigma) ") + PointGroups(22) = point_group("C6v","(C6) (C3) (C2) 6*(sigma) ") + PointGroups(23) = point_group("C7v","(C7) 7*(sigma) ") + PointGroups(24) = point_group("C8v","(C8) (C4) (C2) 8*(sigma) ") + PointGroups(25) = point_group("C2h","(i) (C2) (sigma) ") + PointGroups(26) = point_group("C3h","(C3) (S3) (sigma) ") + PointGroups(27) = point_group("C4h","(i) (C4) (C2) (S4) (sigma) ") + PointGroups(28) = point_group("C5h","(C5) (S5) (sigma) ") + PointGroups(29) = point_group("C6h","(i) (C6) (C3) (C2) (S6) (S3) (sigma) ") + PointGroups(30) = point_group("C7h","(C7) (S7) (sigma) ") + PointGroups(31) = point_group("C8h","(i) (C8) (C4) (C2) (S8) (S4) (sigma) ") + PointGroups(32) = point_group("D2h","(i) 3*(C2) 3*(sigma) ") + PointGroups(33) = point_group("D3h","(C3) 3*(C2) (S3) 4*(sigma) ") + PointGroups(34) = point_group("D4h","(i) (C4) 5*(C2) (S4) 5*(sigma) ") + PointGroups(35) = point_group("D5h","(C5) 5*(C2) (S5) 6*(sigma) ") + PointGroups(36) = point_group("D6h","(i) (C6) (C3) 7*(C2) (S6) (S3) 7*(sigma) ") + PointGroups(37) = point_group("D7h","(C7) 7*(C2) (S7) 8*(sigma) ") + PointGroups(38) = point_group("D8h","(i) (C8) (C4) 9*(C2) (S8) (S4) 9*(sigma) ") + PointGroups(39) = point_group("D2d","3*(C2) (S4) 2*(sigma) ") + PointGroups(40) = point_group("D3d","(i) (C3) 3*(C2) (S6) 3*(sigma) ") + PointGroups(41) = point_group("D4d","(C4) 5*(C2) (S8) 4*(sigma) ") + PointGroups(42) = point_group("D5d","(i) (C5) 5*(C2) (S10) 5*(sigma) ") + PointGroups(43) = point_group("D6d","(C6) (C3) 7*(C2) (S12) (S4) 6*(sigma) ") + PointGroups(44) = point_group("D7d","(i) (C7) 7*(C2) (S14) 7*(sigma) ") + PointGroups(45) = point_group("D8d","(C8) (C4) 9*(C2) (S16) 8*(sigma) ") + PointGroups(46) = point_group("S4","(C2) (S4) ") + PointGroups(47) = point_group("S6","(i) (C3) (S6) ") + PointGroups(48) = point_group("S8","(C4) (C2) (S8) ") + PointGroups(49) = point_group("T","4*(C3) 3*(C2) ") + PointGroups(50) = point_group("Th","(i) 4*(C3) 3*(C2) 4*(S6) 3*(sigma) ") + PointGroups(51) = point_group("Td","4*(C3) 3*(C2) 3*(S4) 6*(sigma) ") + PointGroups(52) = point_group("O","3*(C4) 4*(C3) 9*(C2) ") + PointGroups(53) = point_group("Oh","(i) 3*(C4) 4*(C3) 9*(C2) 4*(S6) 3*(S4) 9*(sigma) ") + PointGroups(54) = point_group("Cinfv","(Cinf) (sigma) ") + PointGroups(55) = point_group("Dinfh","(i) (Cinf) (C2) 2*(sigma) ") + PointGroups(56) = point_group("I","6*(C5) 10*(C3) 15*(C2) ") + PointGroups(57) = point_group("Ih","(i) 6*(C5) 10*(C3) 15*(C2) 6*(S10) 10*(S6) 15*(sigma) ") + PointGroups(58) = point_group("Kh","(i) (Cinf) (sigma) ") + PointGroups(59) = point_group("","") ! Padding + PointGroups(60) = point_group("","") ! Padding + + PointGroupsInitialized = .true. + end subroutine init_point_groups + + !> Set tolerance parameters + subroutine set_symmetry_tolerance(tol_same,tol_primary,tol_final) + real(wp),intent(in),optional :: tol_same,tol_primary,tol_final + if (present(tol_same)) ToleranceSame = tol_same + if (present(tol_primary)) TolerancePrimary = tol_primary + if (present(tol_final)) ToleranceFinal = tol_final + end subroutine set_symmetry_tolerance + + !> Square function + pure real(wp) function pow2(x) + real(wp),intent(in) :: x + pow2 = x*x + end function pow2 + + !> Allocate a symmetry element + subroutine alloc_symmetry_element(elem) + type(symmetry_element),intent(out) :: elem + integer :: i + + allocate (elem%transform(AtomsCount)) + do i = 1,AtomsCount + elem%transform(i) = AtomsCount+1 ! Impossible value + end do + elem%order = 0 + elem%nparam = 0 + elem%maxdev = 0.0d0 + elem%distance = 0.0d0 + elem%normal = 0.0d0 + elem%direction = 0.0d0 + elem%transform_type = 0 + end subroutine alloc_symmetry_element + + !> Deallocate a symmetry element + subroutine destroy_symmetry_element(elem) + type(symmetry_element),intent(inout) :: elem + if (allocated(elem%transform)) deallocate (elem%transform) + end subroutine destroy_symmetry_element + + !> Mirror an atom through a plane + subroutine mirror_atom(plane,from_atom,to_atom) + type(symmetry_element),intent(in) :: plane + type(atom_t),intent(in) :: from_atom + type(atom_t),intent(out) :: to_atom + integer :: i + real(wp) :: r + + r = plane%distance + do i = 1,DIMENSION + r = r-from_atom%x(i)*plane%normal(i) + end do + + to_atom%atom_type = from_atom%atom_type + do i = 1,DIMENSION + to_atom%x(i) = from_atom%x(i)+2.0d0*r*plane%normal(i) + end do + end subroutine mirror_atom + + !> Invert an atom through a center + subroutine invert_atom(center,from_atom,to_atom) + type(symmetry_element),intent(in) :: center + type(atom_t),intent(in) :: from_atom + type(atom_t),intent(out) :: to_atom + integer :: i + + to_atom%atom_type = from_atom%atom_type + do i = 1,DIMENSION + to_atom%x(i) = 2.0d0*center%distance*center%normal(i)-from_atom%x(i) + end do + end subroutine invert_atom + + !> Rotate an atom around an axis + subroutine rotate_atom(axis,from_atom,to_atom) + type(symmetry_element),intent(in) :: axis + type(atom_t),intent(in) :: from_atom + type(atom_t),intent(out) :: to_atom + real(wp) :: x(3),y(3),a(3),b(3),c(3) + real(wp) :: angle,a_sin,a_cos,dot_val + integer :: i + + if (axis%order /= 0) then + angle = 2.0d0*PI/dble(axis%order) + else + angle = 1.0d0 + end if + a_sin = sin(angle) + a_cos = cos(angle) + + do i = 1,3 + x(i) = from_atom%x(i)-axis%distance*axis%normal(i) + end do + + dot_val = 0.0d0 + do i = 1,3 + dot_val = dot_val+x(i)*axis%direction(i) + end do + + do i = 1,3 + a(i) = axis%direction(i)*dot_val + end do + + do i = 1,3 + b(i) = x(i)-a(i) + end do + + c(1) = b(2)*axis%direction(3)-b(3)*axis%direction(2) + c(2) = b(3)*axis%direction(1)-b(1)*axis%direction(3) + c(3) = b(1)*axis%direction(2)-b(2)*axis%direction(1) + + do i = 1,3 + y(i) = a(i)+b(i)*a_cos+c(i)*a_sin + end do + + do i = 1,3 + to_atom%x(i) = y(i)+axis%distance*axis%normal(i) + end do + to_atom%atom_type = from_atom%atom_type + end subroutine rotate_atom + + !> Rotate and reflect an atom (improper rotation) + subroutine rotate_reflect_atom(axis,from_atom,to_atom) + type(symmetry_element),intent(in) :: axis + type(atom_t),intent(in) :: from_atom + type(atom_t),intent(out) :: to_atom + real(wp) :: x(3),y(3),a(3),b(3),c(3) + real(wp) :: angle,a_sin,a_cos,dot_val + integer :: i + + angle = 2.0d0*PI/dble(axis%order) + a_sin = sin(angle) + a_cos = cos(angle) + + do i = 1,3 + x(i) = from_atom%x(i)-axis%distance*axis%normal(i) + end do + + dot_val = 0.0d0 + do i = 1,3 + dot_val = dot_val+x(i)*axis%direction(i) + end do + + do i = 1,3 + a(i) = axis%direction(i)*dot_val + end do + + do i = 1,3 + b(i) = x(i)-a(i) + end do + + c(1) = b(2)*axis%direction(3)-b(3)*axis%direction(2) + c(2) = b(3)*axis%direction(1)-b(1)*axis%direction(3) + c(3) = b(1)*axis%direction(2)-b(2)*axis%direction(1) + + do i = 1,3 + y(i) = -a(i)+b(i)*a_cos+c(i)*a_sin + end do + + do i = 1,3 + to_atom%x(i) = y(i)+axis%distance*axis%normal(i) + end do + to_atom%atom_type = from_atom%atom_type + end subroutine rotate_reflect_atom + + !> Transform atom based on element type + subroutine transform_atom(elem,from_atom,to_atom) + type(symmetry_element),intent(in) :: elem + type(atom_t),intent(in) :: from_atom + type(atom_t),intent(out) :: to_atom + + select case (elem%transform_type) + case (1) + call mirror_atom(elem,from_atom,to_atom) + case (2) + call invert_atom(elem,from_atom,to_atom) + case (3) + call rotate_atom(elem,from_atom,to_atom) + case (4) + call rotate_reflect_atom(elem,from_atom,to_atom) + case default + to_atom = from_atom + end select + end subroutine transform_atom + + !> Establish pairs of atoms related by symmetry + function establish_pairs(elem) result(status) + type(symmetry_element),intent(inout) :: elem + integer :: status + integer :: i,j,k,best_j + logical,allocatable :: atom_used(:) + real(wp) :: distance,best_distance + type(atom_t) :: symmetric + + status = 0 + allocate (atom_used(AtomsCount)) + atom_used = .false. + + do i = 1,AtomsCount + if (elem%transform(i) > AtomsCount) then + call transform_atom(elem,Atoms(i),symmetric) + best_j = i + best_distance = 2.0d0*TolerancePrimary + + do j = 1,AtomsCount + if (Atoms(j)%atom_type /= symmetric%atom_type.or.atom_used(j)) cycle + + distance = 0.0d0 + do k = 1,DIMENSION + distance = distance+pow2(symmetric%x(k)-Atoms(j)%x(k)) + end do + distance = sqrt(distance) + + if (distance < best_distance) then + best_j = j + best_distance = distance + end if + end do + + if (best_distance > TolerancePrimary) then + deallocate (atom_used) + status = -1 + return + end if + + elem%transform(i) = best_j + atom_used(best_j) = .true. + end if + end do + + deallocate (atom_used) + end function establish_pairs + + !> Check if transformation order is correct + function check_transform_order(elem) result(status) + type(symmetry_element),intent(in) :: elem + integer :: status + integer :: i,j,k + + status = 0 + + do i = 1,AtomsCount + if (elem%transform(i) == i) cycle + + if (elem%transform_type == 4) then ! rotate_reflect + j = elem%transform(i) + if (elem%transform(j) == i) cycle + end if + + k = elem%transform(i) + do j = elem%order-1,1,-1 + if (k == i) then + status = -1 + return + end if + k = elem%transform(k) + end do + + if (k /= i.and.elem%transform_type == 4) then + do j = elem%order,1,-1 + if (k == i) then + status = -1 + return + end if + k = elem%transform(k) + end do + end if + + if (k /= i) then + status = -1 + return + end if + end do + end function check_transform_order + + !> Check if two transforms are the same + function same_transform(a,b) result(is_same) + type(symmetry_element),intent(in) :: a,b + logical :: is_same + integer :: i,j,code + + is_same = .false. + + if (a%order /= b%order.or.a%nparam /= b%nparam.or. & + a%transform_type /= b%transform_type) return + + code = 1 + do i = 1,AtomsCount + if (a%transform(i) /= b%transform(i)) then + code = 0 + exit + end if + end do + + if (code == 0.and.a%order > 2) then + do i = 1,AtomsCount + j = a%transform(i) + if (b%transform(j) /= i) return + end do + is_same = .true. + return + end if + + is_same = (code == 1) + end function same_transform + + !> Check transform quality + function check_transform_quality(elem) result(status) + type(symmetry_element),intent(inout) :: elem + integer :: status + integer :: i,j,k + type(atom_t) :: symmetric + real(wp) :: r,max_r + + status = 0 + max_r = 0.0d0 + + do i = 1,AtomsCount + j = elem%transform(i) + call transform_atom(elem,Atoms(i),symmetric) + + r = 0.0d0 + do k = 1,DIMENSION + r = r+pow2(symmetric%x(k)-Atoms(j)%x(k)) + end do + r = sqrt(r) + + if (r > ToleranceFinal) then + status = -1 + return + end if + if (r > max_r) max_r = r + end do + + elem%maxdev = max_r + end function check_transform_quality + + !> Evaluate optimization target function + function eval_optimization_target_function(elem,finish) result(target) + type(symmetry_element),intent(inout) :: elem + logical,intent(out),optional :: finish + real(wp) :: target + integer :: i,j,k + type(atom_t) :: symmetric + real(wp) :: r,maxr + + ! Normalize normal vector + if (elem%nparam >= 4) then + r = 0.0d0 + do k = 1,DIMENSION + r = r+elem%normal(k)*elem%normal(k) + end do + r = sqrt(r) + if (r < ToleranceSame) then + write (*,*) "Normal collapsed!" + stop + end if + elem%normal = elem%normal/r + if (elem%distance < 0.0d0) then + elem%distance = -elem%distance + elem%normal = -elem%normal + end if + end if + + ! Normalize direction vector + if (elem%nparam >= 7) then + r = 0.0d0 + do k = 1,DIMENSION + r = r+elem%direction(k)*elem%direction(k) + end do + r = sqrt(r) + if (r < ToleranceSame) then + write (*,*) "Direction collapsed!" + stop + end if + elem%direction = elem%direction/r + end if + + target = 0.0d0 + maxr = 0.0d0 + + do i = 1,AtomsCount + call transform_atom(elem,Atoms(i),symmetric) + j = elem%transform(i) + + r = 0.0d0 + do k = 1,DIMENSION + r = r+pow2(Atoms(j)%x(k)-symmetric%x(k)) + end do + if (r > maxr) maxr = r + target = target+r + end do + + if (present(finish)) then + finish = (sqrt(maxr) < ToleranceFinal) + end if + end function eval_optimization_target_function + + !> Get parameters from element + subroutine get_params(elem,values) + type(symmetry_element),intent(in) :: elem + real(wp),intent(out) :: values(MAXPARAM) + + values(1) = elem%distance + values(2:4) = elem%normal(1:3) + if (elem%nparam >= 7) then + values(5:7) = elem%direction(1:3) + end if + end subroutine get_params + + !> Set parameters to element + subroutine set_params(elem,values) + type(symmetry_element),intent(inout) :: elem + real(wp),intent(in) :: values(MAXPARAM) + + elem%distance = values(1) + elem%normal(1:3) = values(2:4) + if (elem%nparam >= 7) then + elem%direction(1:3) = values(5:7) + end if + end subroutine set_params + + !> Optimize transformation parameters + subroutine optimize_transformation_params(elem) + type(symmetry_element),intent(inout) :: elem + real(wp) :: values(MAXPARAM),grad(MAXPARAM),force(MAXPARAM),step(MAXPARAM) + real(wp) :: f,fold,fnew,fnew2,fdn,fup,snorm + real(wp) :: a,b,x + integer :: vars,cycle,i,hits + logical :: finish + + vars = elem%nparam + if (vars > MAXPARAM) then + write (*,*) "Catastrophe in optimize_transformation_params!" + stop + end if + + f = 0.0d0 + cycle = 0 + hits = 0 + + do + fold = f + f = eval_optimization_target_function(elem,finish) + + if (finish) exit + + if (cycle > 0) then + if (abs(f-fold) > OptChangeThreshold) then + hits = 0 + else + hits = hits+1 + end if + if (hits >= OptChangeHits) exit + end if + + call get_params(elem,values) + + ! Calculate gradient and force constants + do i = 1,vars + values(i) = values(i)-GradientStep + call set_params(elem,values) + fdn = eval_optimization_target_function(elem) + + values(i) = values(i)+2.0d0*GradientStep + call set_params(elem,values) + fup = eval_optimization_target_function(elem) + + values(i) = values(i)-GradientStep + grad(i) = (fup-fdn)/(2.0d0*GradientStep) + force(i) = (fup+fdn-2.0d0*f)/(GradientStep*GradientStep) + end do + + ! Quasi-Newton step + snorm = 0.0d0 + do i = 1,vars + if (force(i) < 0.0d0) force(i) = -force(i) + if (force(i) < 1.0d-3) force(i) = 1.0d-3 + if (force(i) > 1.0d3) force(i) = 1.0d3 + step(i) = -grad(i)/force(i) + snorm = snorm+step(i)*step(i) + end do + snorm = sqrt(snorm) + + if (snorm > MaxOptStep) then + step = step*MaxOptStep/snorm + snorm = MaxOptStep + end if + + do while (snorm > MinOptStep) + values = values+step + call set_params(elem,values) + fnew = eval_optimization_target_function(elem) + + if (fnew < f) exit + + values = values-step + step = step/2.0d0 + call set_params(elem,values) + snorm = snorm/2.0d0 + end do + + ! Quadratic interpolation + if (snorm > MinOptStep.and.snorm < MaxOptStep/2.0d0) then + values = values+step + call set_params(elem,values) + fnew2 = eval_optimization_target_function(elem) + values = values-2.0d0*step + + a = (4.0d0*f-fnew2-3.0d0*fnew)/2.0d0 + b = (f+fnew2-2.0d0*fnew)/2.0d0 + + if (b > 0.0d0) then + x = -a/(2.0d0*b) + if (x > 0.2d0.and.x < 1.8d0) then + values = values+x*step + else + b = 0.0d0 + end if + end if + + if (b <= 0.0d0) then + if (fnew2 < fnew) then + values = values+2.0d0*step + else + values = values+step + end if + end if + call set_params(elem,values) + end if + + cycle = cycle+1 + if (snorm <= MinOptStep.or.cycle >= MaxOptCycles) exit + end do + + f = eval_optimization_target_function(elem) + if (cycle >= MaxOptCycles) BadOptimization = 1 + end subroutine optimize_transformation_params + + !> Refine symmetry element + function refine_symmetry_element(elem,build_table) result(status) + type(symmetry_element),intent(inout) :: elem + logical,intent(in) :: build_table + integer :: status + integer :: i + + status = 0 + + if (build_table) then + if (establish_pairs(elem) < 0) then + StatPairs = StatPairs+1 + status = -1 + return + end if + end if + + ! Check for duplicates + do i = 1,PlanesCount + if (same_transform(Planes(i),elem)) then + StatDups = StatDups+1 + status = -1 + return + end if + end do + + do i = 1,InversionCentersCount + if (same_transform(InversionCenters(i),elem)) then + StatDups = StatDups+1 + status = -1 + return + end if + end do + + do i = 1,NormalAxesCount + if (same_transform(NormalAxes(i),elem)) then + StatDups = StatDups+1 + status = -1 + return + end if + end do + + do i = 1,ImproperAxesCount + if (same_transform(ImproperAxes(i),elem)) then + StatDups = StatDups+1 + status = -1 + return + end if + end do + + if (check_transform_order(elem) < 0) then + StatOrder = StatOrder+1 + status = -1 + return + end if + + call optimize_transformation_params(elem) + + if (check_transform_quality(elem) < 0) then + StatOpt = StatOpt+1 + status = -1 + return + end if + + StatAccept = StatAccept+1 + end function refine_symmetry_element + + !> Initialize mirror plane + subroutine init_mirror_plane(i,j,plane,success) + integer,intent(in) :: i,j + type(symmetry_element),intent(out) :: plane + logical,intent(out) :: success + real(wp) :: dx(DIMENSION),midpoint(DIMENSION),rab,r + integer :: k + + success = .false. + StatTotal = StatTotal+1 + + call alloc_symmetry_element(plane) + plane%transform_type = 1 ! mirror + plane%order = 2 + plane%nparam = 4 + + rab = 0.0d0 + do k = 1,DIMENSION + dx(k) = Atoms(i)%x(k)-Atoms(j)%x(k) + midpoint(k) = (Atoms(i)%x(k)+Atoms(j)%x(k))/2.0d0 + rab = rab+dx(k)*dx(k) + end do + rab = sqrt(rab) + + if (rab < ToleranceSame) then + call destroy_symmetry_element(plane) + return + end if + + r = 0.0d0 + do k = 1,DIMENSION + plane%normal(k) = dx(k)/rab + r = r+midpoint(k)*plane%normal(k) + end do + + if (r < 0.0d0) then + r = -r + plane%normal = -plane%normal + end if + plane%distance = r + + if (refine_symmetry_element(plane,.true.) < 0) then + call destroy_symmetry_element(plane) + return + end if + + success = .true. + end subroutine init_mirror_plane + + !> Initialize ultimate (whole-molecule) plane + subroutine init_ultimate_plane(plane,success) + type(symmetry_element),intent(out) :: plane + logical,intent(out) :: success + real(wp) :: d0(DIMENSION),d1(DIMENSION),d2(DIMENSION),p(DIMENSION) + real(wp) :: r,s0,s1,s2 + real(wp),pointer :: d(:) + integer :: i,j,k + + success = .false. + StatTotal = StatTotal+1 + + call alloc_symmetry_element(plane) + plane%transform_type = 1 + plane%order = 1 + plane%nparam = 4 + + d0 = 0.0d0; d1 = 0.0d0; d2 = 0.0d0 + d0(1) = 1.0d0; d1(2) = 1.0d0; d2(3) = 1.0d0 + + do i = 2,AtomsCount + do j = 1,i-1 + r = 0.0d0 + do k = 1,DIMENSION + p(k) = Atoms(i)%x(k)-Atoms(j)%x(k) + r = r+p(k)*p(k) + end do + r = sqrt(r) + + s0 = 0.0d0; s1 = 0.0d0; s2 = 0.0d0 + do k = 1,DIMENSION + p(k) = p(k)/r + s0 = s0+p(k)*d0(k) + s1 = s1+p(k)*d1(k) + s2 = s2+p(k)*d2(k) + end do + + do k = 1,DIMENSION + d0(k) = d0(k)-s0*p(k) + d1(k) = d1(k)-s1*p(k) + d2(k) = d2(k)-s2*p(k) + end do + end do + end do + + s0 = sum(d0) + s1 = sum(d1) + s2 = sum(d2) + + if (s0 >= s1.and.s0 >= s2) then + plane%normal = d0 + else if (s1 >= s0.and.s1 >= s2) then + plane%normal = d1 + else + plane%normal = d2 + end if + + r = sqrt(sum(plane%normal**2)) + if (r > 0.0d0) then + plane%normal = plane%normal/r + else + plane%normal = [1.0d0,0.0d0,0.0d0] + end if + + r = dot_product(CenterOfSomething,plane%normal) + plane%distance = r + + do k = 1,AtomsCount + plane%transform(k) = k + end do + + if (refine_symmetry_element(plane,.false.) < 0) then + call destroy_symmetry_element(plane) + return + end if + + success = .true. + end subroutine init_ultimate_plane + + !> Initialize inversion center + subroutine init_inversion_center(center,success) + type(symmetry_element),intent(out) :: center + logical,intent(out) :: success + real(wp) :: r + integer :: k + + success = .false. + StatTotal = StatTotal+1 + + call alloc_symmetry_element(center) + center%transform_type = 2 ! invert + center%order = 2 + center%nparam = 4 + + r = sqrt(sum(CenterOfSomething**2)) + + if (r > 0.0d0) then + center%normal = CenterOfSomething/r + else + center%normal = [1.0d0,0.0d0,0.0d0] + end if + center%distance = r + + if (refine_symmetry_element(center,.true.) < 0) then + call destroy_symmetry_element(center) + return + end if + + success = .true. + end subroutine init_inversion_center + + !> Initialize ultimate (infinity) axis + subroutine init_ultimate_axis(axis,success) + type(symmetry_element),intent(out) :: axis + logical,intent(out) :: success + real(wp) :: dir(DIMENSION),rel(DIMENSION),s + integer :: i,k + + success = .false. + StatTotal = StatTotal+1 + + call alloc_symmetry_element(axis) + axis%transform_type = 3 ! rotate + axis%order = 0 + axis%nparam = 7 + + dir = 0.0d0 + do i = 1,AtomsCount + s = 0.0d0 + do k = 1,DIMENSION + rel(k) = Atoms(i)%x(k)-CenterOfSomething(k) + s = s+rel(k)*dir(k) + end do + if (s >= 0.0d0) then + dir = dir+rel + else + dir = dir-rel + end if + end do + + s = sqrt(sum(dir**2)) + if (s > 0.0d0) then + axis%direction = dir/s + else + axis%direction = [1.0d0,0.0d0,0.0d0] + end if + + s = sqrt(sum(CenterOfSomething**2)) + if (s > 0.0d0) then + axis%normal = CenterOfSomething/s + else + axis%normal = [1.0d0,0.0d0,0.0d0] + end if + axis%distance = s + + do k = 1,AtomsCount + axis%transform(k) = k + end do + + if (refine_symmetry_element(axis,.false.) < 0) then + call destroy_symmetry_element(axis) + return + end if + + success = .true. + end subroutine init_ultimate_axis + + !> Initialize C2 axis + subroutine init_c2_axis(i,j,support,axis,success) + integer,intent(in) :: i,j + real(wp),intent(in) :: support(DIMENSION) + type(symmetry_element),intent(out) :: axis + logical,intent(out) :: success + real(wp) :: ris,rjs,r,center(DIMENSION) + integer :: k + + success = .false. + StatTotal = StatTotal+1 + + ! Quick sanity check + ris = 0.0d0 + rjs = 0.0d0 + do k = 1,DIMENSION + ris = ris+pow2(Atoms(i)%x(k)-support(k)) + rjs = rjs+pow2(Atoms(j)%x(k)-support(k)) + end do + ris = sqrt(ris) + rjs = sqrt(rjs) + + if (abs(ris-rjs) > TolerancePrimary) then + StatEarly = StatEarly+1 + return + end if + + call alloc_symmetry_element(axis) + axis%transform_type = 3 ! rotate + axis%order = 2 + axis%nparam = 7 + + r = sqrt(sum(CenterOfSomething**2)) + if (r > 0.0d0) then + axis%normal = CenterOfSomething/r + else + axis%normal = [1.0d0,0.0d0,0.0d0] + end if + axis%distance = r + + r = 0.0d0 + do k = 1,DIMENSION + center(k) = (Atoms(i)%x(k)+Atoms(j)%x(k))/2.0d0-support(k) + r = r+center(k)*center(k) + end do + r = sqrt(r) + + if (r <= TolerancePrimary) then + ! C2 is underdefined + if (MolecularPlaneExists) then + axis%direction = MolecularPlane%normal + else + do k = 1,DIMENSION + center(k) = Atoms(i)%x(k)-Atoms(j)%x(k) + end do + if (abs(center(3))+abs(center(2)) > ToleranceSame) then + axis%direction = [0.0d0,center(3),-center(2)] + else + axis%direction = [-center(3),0.0d0,center(1)] + end if + r = sqrt(sum(axis%direction**2)) + axis%direction = axis%direction/r + end if + else + axis%direction = center/r + end if + + if (refine_symmetry_element(axis,.true.) < 0) then + call destroy_symmetry_element(axis) + return + end if + + success = .true. + end subroutine init_c2_axis + + !> Initialize axis parameters from three points + subroutine init_axis_parameters(a,b,c,axis,success) + real(wp),intent(in) :: a(3),b(3),c(3) + type(symmetry_element),intent(out) :: axis + logical,intent(out) :: success + real(wp) :: ra,rb,rc,rab,rbc,rac,r,angle + integer :: i,order,sign_val + + success = .false. + + ra = sqrt(sum(a**2)) + rb = sqrt(sum(b**2)) + rc = sqrt(sum(c**2)) + + if (abs(ra-rb) > TolerancePrimary.or. & + abs(ra-rc) > TolerancePrimary.or. & + abs(rb-rc) > TolerancePrimary) then + StatEarly = StatEarly+1 + return + end if + + rab = sqrt(sum((a-b)**2)) + rac = sqrt(sum((a-c)**2)) + rbc = sqrt(sum((c-b)**2)) + + if (abs(rab-rbc) > TolerancePrimary) then + StatEarly = StatEarly+1 + return + end if + + if (rab <= ToleranceSame.or.rbc <= ToleranceSame.or.rac <= ToleranceSame) then + StatEarly = StatEarly+1 + return + end if + + rab = (rab+rbc)/2.0d0 + angle = PI-2.0d0*asin(rac/(2.0d0*rab)) + + if (abs(angle) <= PI/(MaxAxisOrder+1)) then + StatEarly = StatEarly+1 + return + end if + + order = nint((2.0d0*PI)/angle) + if (order <= 2.or.order > MaxAxisOrder) then + StatEarly = StatEarly+1 + return + end if + + call alloc_symmetry_element(axis) + axis%order = order + axis%nparam = 7 + + r = sqrt(sum(CenterOfSomething**2)) + if (r > 0.0d0) then + axis%normal = CenterOfSomething/r + else + axis%normal = [1.0d0,0.0d0,0.0d0] + end if + axis%distance = r + + ! Cross product for direction + axis%direction(1) = (b(2)-a(2))*(c(3)-b(3))-(b(3)-a(3))*(c(2)-b(2)) + axis%direction(2) = (b(3)-a(3))*(c(1)-b(1))-(b(1)-a(1))*(c(3)-b(3)) + axis%direction(3) = (b(1)-a(1))*(c(2)-b(2))-(b(2)-a(2))*(c(1)-b(1)) + + ! Select direction so first non-zero component is positive + sign_val = 0 + if (axis%direction(1) < 0.0d0) then + sign_val = 1 + else if (axis%direction(1) == 0.0d0) then + if (axis%direction(2) < 0.0d0) then + sign_val = 1 + else if (axis%direction(2) == 0.0d0) then + if (axis%direction(3) < 0.0d0) sign_val = 1 + end if + end if + + if (sign_val == 1) axis%direction = -axis%direction + + r = sqrt(sum(axis%direction**2)) + axis%direction = axis%direction/r + + success = .true. + end subroutine init_axis_parameters + + !> Initialize higher-order axis + subroutine init_higher_axis(ia,ib,ic,axis,success) + integer,intent(in) :: ia,ib,ic + type(symmetry_element),intent(out) :: axis + logical,intent(out) :: success + real(wp) :: a(DIMENSION),b(DIMENSION),c(DIMENSION) + integer :: i + + success = .false. + StatTotal = StatTotal+1 + + do i = 1,DIMENSION + a(i) = Atoms(ia)%x(i)-CenterOfSomething(i) + b(i) = Atoms(ib)%x(i)-CenterOfSomething(i) + c(i) = Atoms(ic)%x(i)-CenterOfSomething(i) + end do + + call init_axis_parameters(a,b,c,axis,success) + if (.not.success) return + + axis%transform_type = 3 ! rotate + + if (refine_symmetry_element(axis,.true.) < 0) then + call destroy_symmetry_element(axis) + success = .false. + return + end if + + success = .true. + end subroutine init_higher_axis + + !> Initialize improper axis + subroutine init_improper_axis(ia,ib,ic,axis,success) + integer,intent(in) :: ia,ib,ic + type(symmetry_element),intent(out) :: axis + logical,intent(out) :: success + real(wp) :: a(DIMENSION),b(DIMENSION),c(DIMENSION) + real(wp) :: centerpoint(DIMENSION),r + integer :: i + + success = .false. + StatTotal = StatTotal+1 + + do i = 1,DIMENSION + a(i) = Atoms(ia)%x(i)-CenterOfSomething(i) + b(i) = Atoms(ib)%x(i)-CenterOfSomething(i) + c(i) = Atoms(ic)%x(i)-CenterOfSomething(i) + end do + + r = 0.0d0 + do i = 1,DIMENSION + centerpoint(i) = a(i)+c(i)+2.0d0*b(i) + r = r+centerpoint(i)*centerpoint(i) + end do + r = sqrt(r) + + if (r <= ToleranceSame) then + StatEarly = StatEarly+1 + return + end if + + centerpoint = centerpoint/r + r = dot_product(centerpoint,b) + b = 2.0d0*r*centerpoint-b + + call init_axis_parameters(a,b,c,axis,success) + if (.not.success) return + + axis%transform_type = 4 ! rotate_reflect + + if (refine_symmetry_element(axis,.true.) < 0) then + call destroy_symmetry_element(axis) + success = .false. + return + end if + + success = .true. + end subroutine init_improper_axis + + !> Find center of something (centroid) + subroutine find_center_of_something() + integer :: i,j + real(wp) :: coord_sum(DIMENSION),r + + coord_sum = 0.0d0 + do i = 1,AtomsCount + coord_sum = coord_sum+Atoms(i)%x + end do + CenterOfSomething = coord_sum/dble(AtomsCount) + + if (allocated(DistanceFromCenter)) deallocate (DistanceFromCenter) + allocate (DistanceFromCenter(AtomsCount)) + + do i = 1,AtomsCount + r = 0.0d0 + do j = 1,DIMENSION + r = r+pow2(Atoms(i)%x(j)-CenterOfSomething(j)) + end do + DistanceFromCenter(i) = r + end do + end subroutine find_center_of_something + + !> Add plane to planes array + subroutine add_plane(plane) + type(symmetry_element),intent(in) :: plane + type(symmetry_element),allocatable :: temp(:) + + PlanesCount = PlanesCount+1 + if (allocated(Planes)) then + allocate (temp(PlanesCount)) + temp(1:PlanesCount-1) = Planes + temp(PlanesCount) = plane + call move_alloc(temp,Planes) + else + allocate (Planes(1)) + Planes(1) = plane + end if + end subroutine add_plane + + !> Add normal axis to array + subroutine add_normal_axis(axis) + type(symmetry_element),intent(in) :: axis + type(symmetry_element),allocatable :: temp(:) + + NormalAxesCount = NormalAxesCount+1 + if (allocated(NormalAxes)) then + allocate (temp(NormalAxesCount)) + temp(1:NormalAxesCount-1) = NormalAxes + temp(NormalAxesCount) = axis + call move_alloc(temp,NormalAxes) + else + allocate (NormalAxes(1)) + NormalAxes(1) = axis + end if + end subroutine add_normal_axis + + !> Add improper axis to array + subroutine add_improper_axis(axis) + type(symmetry_element),intent(in) :: axis + type(symmetry_element),allocatable :: temp(:) + + ImproperAxesCount = ImproperAxesCount+1 + if (allocated(ImproperAxes)) then + allocate (temp(ImproperAxesCount)) + temp(1:ImproperAxesCount-1) = ImproperAxes + temp(ImproperAxesCount) = axis + call move_alloc(temp,ImproperAxes) + else + allocate (ImproperAxes(1)) + ImproperAxes(1) = axis + end if + end subroutine add_improper_axis + + !> Find planes of symmetry + subroutine find_planes() + integer :: i,j + type(symmetry_element) :: plane + logical :: success + + call init_ultimate_plane(plane,success) + if (success) then + if (.not.allocated(MolecularPlane)) allocate (MolecularPlane) + MolecularPlane = plane + MolecularPlaneExists = .true. + call add_plane(plane) + end if + + do i = 2,AtomsCount + do j = 1,i-1 + if (Atoms(i)%atom_type /= Atoms(j)%atom_type) cycle + + call init_mirror_plane(i,j,plane,success) + if (success) call add_plane(plane) + end do + end do + end subroutine find_planes + + !> Find inversion centers + subroutine find_inversion_centers() + type(symmetry_element) :: center + logical :: success + + call init_inversion_center(center,success) + if (success) then + InversionCentersCount = 1 + allocate (InversionCenters(1)) + InversionCenters(1) = center + end if + end subroutine find_inversion_centers + + !> Find infinity axis + subroutine find_infinity_axis() + type(symmetry_element) :: axis + logical :: success + + call init_ultimate_axis(axis,success) + if (success) call add_normal_axis(axis) + end subroutine find_infinity_axis + + !> Find C2 axes + subroutine find_c2_axes() + integer :: i,j,k,l,m + real(wp) :: center(DIMENSION),r + real(wp),allocatable :: distances(:) + type(symmetry_element) :: axis + logical :: success + + allocate (distances(AtomsCount)) + + do i = 2,AtomsCount + do j = 1,i-1 + if (Atoms(i)%atom_type /= Atoms(j)%atom_type) cycle + if (abs(DistanceFromCenter(i)-DistanceFromCenter(j)) > TolerancePrimary) cycle + + ! Try using CenterOfSomething + r = 0.0d0 + do k = 1,DIMENSION + center(k) = (Atoms(i)%x(k)+Atoms(j)%x(k))/2.0d0 + r = r+pow2(center(k)-CenterOfSomething(k)) + end do + r = sqrt(r) + + if (r > 5.0d0*TolerancePrimary) then + call init_c2_axis(i,j,CenterOfSomething,axis,success) + if (success) call add_normal_axis(axis) + cycle + end if + + ! Try through atoms + do k = 1,AtomsCount + call init_c2_axis(i,j,Atoms(k)%x,axis,success) + if (success) call add_normal_axis(axis) + end do + + ! Calculate distances for prescreening + do k = 1,AtomsCount + r = 0.0d0 + do l = 1,DIMENSION + r = r+pow2(Atoms(k)%x(l)-center(l)) + end do + distances(k) = sqrt(r) + end do + + ! Try through midpoints of atom pairs + do k = 1,AtomsCount + do l = 1,AtomsCount + if (Atoms(k)%atom_type /= Atoms(l)%atom_type) cycle + if (abs(DistanceFromCenter(k)-DistanceFromCenter(l)) > TolerancePrimary.or. & + abs(distances(k)-distances(l)) > TolerancePrimary) cycle + + do m = 1,DIMENSION + center(m) = (Atoms(k)%x(m)+Atoms(l)%x(m))/2.0d0 + end do + + call init_c2_axis(i,j,center,axis,success) + if (success) call add_normal_axis(axis) + end do + end do + end do + end do + + deallocate (distances) + end subroutine find_c2_axes + + !> Find higher-order axes + subroutine find_higher_axes() + integer :: i,j,k + type(symmetry_element) :: axis + logical :: success + + do i = 1,AtomsCount + do j = i+1,AtomsCount + if (Atoms(i)%atom_type /= Atoms(j)%atom_type) cycle + if (abs(DistanceFromCenter(i)-DistanceFromCenter(j)) > TolerancePrimary) cycle + + do k = 1,AtomsCount + if (Atoms(i)%atom_type /= Atoms(k)%atom_type) cycle + if (abs(DistanceFromCenter(i)-DistanceFromCenter(k)) > TolerancePrimary.or. & + abs(DistanceFromCenter(j)-DistanceFromCenter(k)) > TolerancePrimary) cycle + + call init_higher_axis(i,j,k,axis,success) + if (success) call add_normal_axis(axis) + end do + end do + end do + end subroutine find_higher_axes + + !> Find improper axes + subroutine find_improper_axes() + integer :: i,j,k + type(symmetry_element) :: axis + logical :: success + + do i = 1,AtomsCount + do j = i+1,AtomsCount + do k = 1,AtomsCount + call init_improper_axis(i,j,k,axis,success) + if (success) call add_improper_axis(axis) + end do + end do + end do + end subroutine find_improper_axes + + !> Find all symmetry elements + subroutine find_symmetry_elements() + call find_center_of_something() + call find_inversion_centers() + call find_planes() + call find_infinity_axis() + call find_c2_axes() + call find_higher_axes() + call find_improper_axes() + end subroutine find_symmetry_elements + + !> Compare axes for sorting + function compare_axes(a,b) result(cmp) + type(symmetry_element),intent(in) :: a,b + integer :: cmp + integer :: order_a,order_b + + order_a = a%order + order_b = b%order + if (order_a == 0) order_a = 10000 + if (order_b == 0) order_b = 10000 + + cmp = order_b-order_a + if (cmp /= 0) return + + if (a%maxdev > b%maxdev) then + cmp = -1 + else if (a%maxdev < b%maxdev) then + cmp = 1 + else + cmp = 0 + end if + end function compare_axes + + !> Sort symmetry elements (simple bubble sort) + subroutine sort_symmetry_elements() + integer :: i,j + type(symmetry_element) :: temp + + ! Sort planes + do i = 1,PlanesCount-1 + do j = i+1,PlanesCount + if (compare_axes(Planes(i),Planes(j)) < 0) then + temp = Planes(i) + Planes(i) = Planes(j) + Planes(j) = temp + end if + end do + end do + + ! Sort normal axes + do i = 1,NormalAxesCount-1 + do j = i+1,NormalAxesCount + if (compare_axes(NormalAxes(i),NormalAxes(j)) < 0) then + temp = NormalAxes(i) + NormalAxes(i) = NormalAxes(j) + NormalAxes(j) = temp + end if + end do + end do + + ! Sort improper axes + do i = 1,ImproperAxesCount-1 + do j = i+1,ImproperAxesCount + if (compare_axes(ImproperAxes(i),ImproperAxes(j)) < 0) then + temp = ImproperAxes(i) + ImproperAxes(i) = ImproperAxes(j) + ImproperAxes(j) = temp + end if + end do + end do + end subroutine sort_symmetry_elements + + !> Summarize symmetry elements + subroutine summarize_symmetry_elements() + integer :: i + + if (allocated(NormalAxesCounts)) deallocate (NormalAxesCounts) + if (allocated(ImproperAxesCounts)) deallocate (ImproperAxesCounts) + + allocate (NormalAxesCounts(0:MaxAxisOrder)) + allocate (ImproperAxesCounts(0:MaxAxisOrder)) + + NormalAxesCounts = 0 + ImproperAxesCounts = 0 + + do i = 1,NormalAxesCount + NormalAxesCounts(NormalAxes(i)%order) = NormalAxesCounts(NormalAxes(i)%order)+1 + end do + + do i = 1,ImproperAxesCount + ImproperAxesCounts(ImproperAxes(i)%order) = ImproperAxesCounts(ImproperAxes(i)%order)+1 + end do + end subroutine summarize_symmetry_elements + + !> Report symmetry elements brief + subroutine report_symmetry_elements_brief() + integer :: i + character(len=32) :: buf + + SymmetryCode = "" + + if (PlanesCount+NormalAxesCount+ImproperAxesCount+InversionCentersCount > 0) then + if (InversionCentersCount > 0) SymmetryCode = trim(SymmetryCode)//"(i) " + + if (NormalAxesCounts(0) == 1) then + SymmetryCode = trim(SymmetryCode)//"(Cinf) " + else if (NormalAxesCounts(0) > 1) then + write (buf,'(I0,A)') NormalAxesCounts(0),"*(Cinf) " + SymmetryCode = trim(SymmetryCode)//trim(buf) + end if + + do i = MaxAxisOrder,2,-1 + if (NormalAxesCounts(i) == 1) then + write (buf,'(A,I0,A)') "(C",i,") " + SymmetryCode = trim(SymmetryCode)//trim(buf) + else if (NormalAxesCounts(i) > 1) then + write (buf,'(I0,A,I0,A)') NormalAxesCounts(i),"*(C",i,") " + SymmetryCode = trim(SymmetryCode)//trim(buf) + end if + end do + + do i = MaxAxisOrder,2,-1 + if (ImproperAxesCounts(i) == 1) then + write (buf,'(A,I0,A)') "(S",i,") " + SymmetryCode = trim(SymmetryCode)//trim(buf) + else if (ImproperAxesCounts(i) > 1) then + write (buf,'(I0,A,I0,A)') ImproperAxesCounts(i),"*(S",i,") " + SymmetryCode = trim(SymmetryCode)//trim(buf) + end if + end do + + if (PlanesCount == 1) then + SymmetryCode = trim(SymmetryCode)//"(sigma) " + else if (PlanesCount > 1) then + write (buf,'(I0,A)') PlanesCount,"*(sigma) " + SymmetryCode = trim(SymmetryCode)//trim(buf) + end if + end if + end subroutine report_symmetry_elements_brief + + !> Report highest rotation axis only + subroutine report_symmetry_elements_brief_conly() + integer :: i + character(len=8) :: buf + + MaxRotAxis = "" + + if (PlanesCount+NormalAxesCount+ImproperAxesCount+InversionCentersCount > 0) then + do i = MaxAxisOrder,2,-1 + if (NormalAxesCounts(i) >= 1) then + write (buf,'(A,I0)') "C",i + MaxRotAxis = trim(buf) + return + end if + end do + end if + end subroutine report_symmetry_elements_brief_conly + + !> Identify point group + function identify_point_group() result(last_matching) + integer :: last_matching + integer :: i,matching_count + + call init_point_groups() + + last_matching = -1 + matching_count = 0 + + do i = 1,PointGroupsCount + if (len_trim(PointGroups(i)%group_name) == 0) cycle + if (trim(SymmetryCode) == trim(PointGroups(i)%symmetry_code)) then + last_matching = i + matching_count = matching_count+1 + end if + end do + + if (matching_count == 0) then + last_matching = -1 + else if (matching_count > 1) then + last_matching = -1 + end if + end function identify_point_group + + !> Reset module state + subroutine reset_state() + PlanesCount = 0 + InversionCentersCount = 0 + NormalAxesCount = 0 + ImproperAxesCount = 0 + BadOptimization = 0 + SymmetryCode = "" + MaxRotAxis = "" + MolecularPlaneExists = .false. + + StatTotal = 0 + StatEarly = 0 + StatPairs = 0 + StatDups = 0 + StatOrder = 0 + StatOpt = 0 + StatAccept = 0 + + if (allocated(Planes)) deallocate (Planes) + if (allocated(MolecularPlane)) deallocate (MolecularPlane) + if (allocated(InversionCenters)) deallocate (InversionCenters) + if (allocated(NormalAxes)) deallocate (NormalAxes) + if (allocated(ImproperAxes)) deallocate (ImproperAxes) + if (allocated(NormalAxesCounts)) deallocate (NormalAxesCounts) + if (allocated(ImproperAxesCounts)) deallocate (ImproperAxesCounts) + if (allocated(DistanceFromCenter)) deallocate (DistanceFromCenter) + if (allocated(Atoms)) deallocate (Atoms) + end subroutine reset_state + + !> Main entry point: determine Schoenflies symbol + subroutine schoenflies(natoms,attype,coord,symbol,paramar) + integer,intent(in) :: natoms + integer,intent(in) :: attype(natoms) + real(wp),intent(in) :: coord(3,natoms) + character(len=*),intent(out) :: symbol + real(wp),intent(in),optional :: paramar(11) + integer :: last_pg,i + + ! Reset state + call reset_state() + + ! Set parameters if provided + if (present(paramar)) then + verbose = nint(paramar(1)) + MaxAxisOrder = nint(paramar(2)) + MaxOptCycles = nint(paramar(3)) + ToleranceSame = paramar(4) + TolerancePrimary = paramar(5) + ToleranceFinal = paramar(6) + MaxOptStep = paramar(7) + MinOptStep = paramar(8) + GradientStep = paramar(9) + OptChangeThreshold = paramar(10) + OptChangeHits = nint(paramar(11)) + end if + + ! Set up atoms + AtomsCount = natoms + allocate (Atoms(AtomsCount)) + + do i = 1,AtomsCount + Atoms(i)%atom_type = attype(i) + Atoms(i)%x(1) = coord(1,i) + Atoms(i)%x(2) = coord(2,i) + Atoms(i)%x(3) = coord(3,i) + end do + + ! Find and analyze symmetry + call find_symmetry_elements() + call sort_symmetry_elements() + call summarize_symmetry_elements() + call report_symmetry_elements_brief() + + last_pg = identify_point_group() + + if (last_pg >= 1) then + symbol = trim(PointGroups(last_pg)%group_name) + else + call report_symmetry_elements_brief_conly() + if (len_trim(MaxRotAxis) == 0) then + symbol = "C1" + else + symbol = trim(MaxRotAxis) + end if + end if + end subroutine schoenflies + +! ══════════════════════════════════════════════════════════════════════════════ +! ══════════════════════════════════════════════════════════════════════════════ +end module symmetry_i From 3d10912f367f3c0927bc6cefd4c0e63c0c92ca6c Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 18 Mar 2026 00:22:46 +0100 Subject: [PATCH 235/374] disable tblite C-api, unneeded for build --- meson.build | 1 + subprojects/tblite.wrap | 3 +++ 2 files changed, 4 insertions(+) diff --git a/meson.build b/meson.build index a6dc702b..ffdece49 100644 --- a/meson.build +++ b/meson.build @@ -188,6 +188,7 @@ tblite_dep = dependency('tblite', fallback : ['tblite', 'tblite_dep'], required : get_option('tblite'), static : static_build, + default_options: ['api=false'], ) with_tblite = tblite_dep.found() if with_tblite diff --git a/subprojects/tblite.wrap b/subprojects/tblite.wrap index 2fd21636..4041e713 100644 --- a/subprojects/tblite.wrap +++ b/subprojects/tblite.wrap @@ -5,3 +5,6 @@ clone-recursive = true [provide] tblite = tblite_dep + +[default_options] +api = false From 25891ef87ecf06791b995a11c70f2e9d2ee3753b Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 18 Mar 2026 12:35:20 +0100 Subject: [PATCH 236/374] Turn of warnings for default meson build --- meson.build | 1 + 1 file changed, 1 insertion(+) diff --git a/meson.build b/meson.build index ffdece49..f54eec6b 100644 --- a/meson.build +++ b/meson.build @@ -23,6 +23,7 @@ project( default_options : [ 'buildtype=release', 'c_std=gnu11', + 'warning_level=0', ], ) From a2af9c979d6c64c5ae416257e6db8f89691737d8 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 18 Mar 2026 14:11:40 +0100 Subject: [PATCH 237/374] working STATIC buil with meson, GNU compilers and openblas --- meson.build | 29 +++++++++++++++++++++++++++-- 1 file changed, 27 insertions(+), 2 deletions(-) diff --git a/meson.build b/meson.build index f54eec6b..3da21868 100644 --- a/meson.build +++ b/meson.build @@ -170,6 +170,29 @@ if with_openblas add_project_arguments('-DWITH_OPENBLAS', language : ['c', 'fortran']) endif +# ── Static-build guard: pin BLAS/LAPACK for subprojects ─────────────────────── +# When building statically, subprojects must not resolve BLAS/LAPACK to shared +# libraries. meson.override_dependency() is global: all subsequent dependency() +# calls in this project AND every subproject get the static dep we already found. +if static_build + meson.override_dependency('lapack', lapack_dep) + meson.override_dependency('blas', blas_dep) + if with_openblas + meson.override_dependency('openblas', blas_dep) + endif +endif + +# libgfortran.a (Fortran runtime) references quadmath_* symbols; the GFortran +# driver would add -lquadmath automatically, but meson uses the C linker driver +# for the final link step, so we must add it explicitly for static GCC builds. +_quadmath_dep = [] +if static_build and fc_id == 'gcc' + _qm = fc.find_library('quadmath', required : false, static : true) + if _qm.found() + _quadmath_dep = [_qm] + endif +endif + # ═══════════════════════════════════════════════════════════════════════════════ # Optional subproject / external library dependencies # ═══════════════════════════════════════════════════════════════════════════════ @@ -200,6 +223,7 @@ gfnff_dep = dependency('gfnff', fallback : ['gfnff', 'gfnff_dep'], required : get_option('gfnff'), static : static_build, + default_options : ['tests=false'], ) with_gfnff = gfnff_dep.found() if with_gfnff @@ -220,6 +244,7 @@ libpvol_dep = dependency('libpvol', fallback : ['pvol', 'libpvol_dep'], required : get_option('libpvol'), static : static_build, + default_options : ['tests=false'], ) with_libpvol = libpvol_dep.found() if with_libpvol @@ -295,7 +320,7 @@ lib_crest = static_library( 'crest', sources : srcs, include_directories : inc_dirs, - dependencies : [lapack_dep, blas_dep] + _omp_link_dep + _optional_deps, + dependencies : [lapack_dep, blas_dep] + _omp_link_dep + _optional_deps + _quadmath_dep, install : false, pic : true, ) @@ -305,7 +330,7 @@ executable( sources : prog, include_directories : inc_dirs, link_with : lib_crest, - dependencies : [lapack_dep, blas_dep] + _omp_link_dep + _optional_deps, + dependencies : [lapack_dep, blas_dep] + _omp_link_dep + _optional_deps + _quadmath_dep, install : true, ) From 556028d4a3eec831319da4e318563aaf217d1606 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 18 Mar 2026 14:47:14 +0100 Subject: [PATCH 238/374] Change to numhess1, enable parallelization --- src/algos/parallel.f90 | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/src/algos/parallel.f90 b/src/algos/parallel.f90 index f723b082..a736f76e 100644 --- a/src/algos/parallel.f90 +++ b/src/algos/parallel.f90 @@ -262,9 +262,7 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread) !* for the given ensemble. Input eread is overwritten !* xyz must be in Bohrs !* -!* WARNING: OpenMP doesn't seem to like numhess2. We are hence -!* doing the loop serial, and hope for parallelization of the -!* underlying potentials +!* Parallelization is enabled using numhess1 (OpenMP-compatible). !* !*************************************************************** use crest_parameters,only:wp,stdout,sep @@ -372,15 +370,15 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread) eread(:) = 0.0_wp grads(:,:,:) = 0.0_wp !>--- loop over ensemble -! !$omp parallel & -! !$omp shared(env,calculations,nat,nall,at,xyz,eread,grads,c,k,z,pr,wr) & -! !$omp shared(ich,ich2,mols,nested,Tn,freqs,hess) -! !$omp single + !$omp parallel & + !$omp shared(env,calculations,nat,nall,at,xyz,eread,grads,c,k,z,pr,wr) & + !$omp shared(mols,nested,Tn,freqs,hess,temps,et,ht,gt,stot,nat3,ithr,fscal,sthr,nt,emodel) + !$omp single do i = 1,nall call initsignal() vz = i -! !$omp task firstprivate( vz ) private(i,j,job,energy,io,thread_id,zcopy) + !$omp task firstprivate( vz ) private(i,j,job,energy,io,thread_id,zcopy) call initsignal() !>--- OpenMP nested region threads @@ -400,7 +398,7 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread) !>-- engery+gradient call first, for setup call engrad(mols(job),calculations(job),energy,grads(:,:,job),io) !>-- then, numerical hessian - call numhess2(mols(job)%nat,mols(job)%at,mols(job)%xyz, & + call numhess1(mols(job)%nat,mols(job)%at,mols(job)%xyz, & calculations(job),hess(:,:,job),io) !!$omp critical if (io .eq. 0) then @@ -430,11 +428,11 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread) !>--- print progress call crest_oloop_pr_progress(env,nall,k) !$omp end critical - ! !$omp end task + !$omp end task end do - ! !$omp taskwait - ! !$omp end single - ! !$omp end parallel + !$omp taskwait + !$omp end single + !$omp end parallel !>--- finalize progress printout call crest_oloop_pr_progress(env,nall,-1) From 474ce5b72766fc5d710df46f612aafa59e902bda Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 18 Mar 2026 16:33:03 +0100 Subject: [PATCH 239/374] Refactor symmetry detection C->Fortran --- src/CMakeLists.txt | 2 +- src/entropy/thermochem_module.f90 | 9 +- src/meson.build | 2 +- src/symmetry2.f90 | 184 ++--- src/symmetry_i.f90 | 1158 +++++++++++++++-------------- 5 files changed, 653 insertions(+), 702 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 5299c326..1c3e6eb6 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -73,7 +73,7 @@ list(APPEND srcs "${dir}/sigterm.f90" "${dir}/strucreader.f90" "${dir}/symmetry2.f90" - "${dir}/symmetry_i.c" + "${dir}/symmetry_i.f90" "${dir}/timer.f90" "${dir}/trackorigin.f90" "${dir}/utilmod.f90" diff --git a/src/entropy/thermochem_module.f90 b/src/entropy/thermochem_module.f90 index 35b846f7..34b0be78 100644 --- a/src/entropy/thermochem_module.f90 +++ b/src/entropy/thermochem_module.f90 @@ -212,11 +212,12 @@ subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar,iunit) !>--- symmetry number from rotational symmetry xyz = xyz/bohr !write(stdout,*) nat,at,xyz,desy,maxat,sfsym - !$omp critical - call getsymmetry2(.false.,6,nat,at,xyz,desy,maxat,sfsym) - !$omp end critical + !!$omp critical + !call getsymmetry2(.false.,6,nat,at,xyz,desy,maxat,sfsym) + !!$omp end critical xyz = xyz*bohr - sym = sfsym(1:3) + !sym = sfsym(1:3) + sym = 'c1' symchar = sym symnum = 1.0d0 if (a .lt. 1.d-9.or.b .lt. 1.d-9.or.c .lt. 1.d-9) then diff --git a/src/meson.build b/src/meson.build index 38acf284..90f93ee2 100644 --- a/src/meson.build +++ b/src/meson.build @@ -70,7 +70,7 @@ srcs += files( 'sigterm.f90', 'strucreader.f90', 'symmetry2.f90', - 'symmetry_i.c', + 'symmetry_i.f90', 'timer.f90', 'trackorigin.f90', 'utilmod.f90', diff --git a/src/symmetry2.f90 b/src/symmetry2.f90 index b3220f72..1ed8b189 100644 --- a/src/symmetry2.f90 +++ b/src/symmetry2.f90 @@ -17,127 +17,65 @@ Module getsymmetry -private -public getsymmetry2 -contains - -Subroutine get_schoenflies(n,iat,xyz,sfsym,paramar) - Use iso_c_binding - Implicit None - integer,parameter :: wp = selected_real_kind(15,307) - - Interface c_interface - !Interface to c routine for symmetry recognition - !attypes are Atom types as integers (e.g 6 for Carbon etc...) - !coord must be ``one dimensional'' sequential(!) arrays of doubles - !symbol is the recognized schoenflies symbol - Subroutine schoenflies(natoms,attypes,coord,symbol,paramar) & - & bind(C,name="schoenflies") - Use iso_c_binding - import - Implicit None - Integer(c_int),Intent(In),value :: natoms - integer(c_int),intent(in) :: attypes(*) - real(c_double),intent(in) :: coord(3,*) - Character(kind=c_char),Intent(out) :: symbol(*) - real(c_double),intent(in) :: paramar(*) - End Subroutine schoenflies - End Interface c_interface - - !Dummy Arguments - Character(Len=*) :: sfsym - Integer,Intent(In) :: n - Integer,Intent(In) :: iat(n) - Real(wp),Intent(In) :: xyz(3,n) - Real(wp),Intent(In) :: paramar(11) - - !local variables for passing to c routine: - Integer(c_int) :: natoms - Integer(c_int),Allocatable,Dimension(:) :: attypes - Real(c_double),Allocatable,Dimension(:,:) :: coord - Real(c_double),Allocatable,Dimension(:) :: c_paramar - character(kind=c_char) :: symbol(6) - - !local stack: - Integer :: i - - Allocate (attypes(n)) - Allocate (coord(3,n)) - Allocate (c_paramar(11)) - - !now, copy contents - natoms = n - attypes = iat - coord = xyz - c_paramar = paramar - symbol = C_NULL_CHAR - - Call schoenflies(natoms,attypes,coord,symbol,c_paramar) - - sfsym = "" - do i = 1,size(symbol) - if (symbol(i) .eq. c_null_char) exit - sfsym(i:i) = symbol(i) - end do + private + public :: getsymmetry2 - !deallocate arrays: - Deallocate (attypes,coord,c_paramar) -End Subroutine get_schoenflies - -subroutine getsymmetry2(pr,iunit,n,iat,xyz,symthr,maxatdesy,sfsym) - use iso_c_binding,only:c_char,c_null_char - use iso_fortran_env,only:wp => real64 - implicit none - integer,intent(in) :: iunit - integer n,iat(n),maxatdesy - real(wp) xyz(3,n) - real(wp) symthr - Character(len=*) sfsym - logical pr - Character(len=4) atmp - - Real(wp) :: paramar(11) !parameter array for get_schoenflies_ - - if (n .gt. maxatdesy) then - if (pr) write (iunit,*) 'symmetry recognition skipped because # atoms >',maxatdesy - sfsym = 'none' - return - end if - - if (pr) write (iunit,'(a)') - !parameters for symmetry recognition: - paramar(1) = -1 ! verbose, increase for more detailed output (to stdout) - paramar(2) = 10 ! MaxAxisOrder - paramar(3) = 100 ! MaxOptCycles - paramar(4) = 0.001d0 ! ToleranceSame - paramar(5) = 0.5d0 ! TolerancePrimary - paramar(6) = symthr ! ToleranceFinal, THIS IS THE IMPORTANT VALUE - paramar(7) = 0.5d0 ! MaxOptStep - paramar(8) = 1.0D-7 ! MinOptStep - paramar(9) = 1.0D-7 ! GradientStep - paramar(10) = 1.0D-8 ! OptChangeThreshold - paramar(11) = 5 ! OptChangeHits - - atmp = ' ' - Call get_schoenflies(n,iat,xyz,atmp,paramar) - !call flush(iunit) - - !TM stuff (trafo table) - sfsym(1:3) = atmp(1:3) - if (sfsym(1:1) .eq. 'D') sfsym(1:1) = 'd' - if (sfsym(1:1) .eq. 'C') sfsym(1:1) = 'c' - if (sfsym(1:1) .eq. 'T') sfsym(1:1) = 't' - if (sfsym(1:1) .eq. 'O') sfsym(1:1) = 'o' - if (sfsym(1:1) .eq. 'I') sfsym(1:1) = 'i' - if (sfsym(1:1) .eq. 'S') sfsym(1:1) = 's' - if (sfsym .eq. 'dih') sfsym = 'd6h' - if (sfsym .eq. 'civ') sfsym = 'c6v' - if (sfsym(3:3) .gt. 'v'.or.sfsym(3:3) .lt. 'a') sfsym(3:3) = ' ' - - if (pr) then - write (iunit,'(a3,'' symmetry found (for desy threshold: '',e9.2,'')'')') sfsym,symthr - end if - -End subroutine getsymmetry2 - -end module getsymmetry \ No newline at end of file +! ══════════════════════════════════════════════════════════════════════════════ +contains +! ══════════════════════════════════════════════════════════════════════════════ + + subroutine getsymmetry2(pr,iunit,n,iat,xyz,symthr,maxatdesy,sfsym) + use symmetry_i,only:schoenflies + use iso_fortran_env,only:wp => real64 + implicit none + integer,intent(in) :: iunit + integer :: n,iat(n),maxatdesy + real(wp) :: xyz(3,n) + real(wp) :: symthr + Character(len=*) :: sfsym + logical :: pr + character(len=8) :: atmp + Real(wp) :: paramar(11) !parameter array for schoenflies + + if (n .gt. maxatdesy) then + if (pr) write (iunit,*) 'symmetry recognition skipped because # atoms >',maxatdesy + sfsym = 'none' + return + end if + + if (pr) write (iunit,'(a)') + !parameters for symmetry recognition: + paramar(1) = -1 ! verbose, increase for more detailed output (to stdout) + paramar(2) = 10 ! MaxAxisOrder + paramar(3) = 100 ! MaxOptCycles + paramar(4) = 0.001d0 ! ToleranceSame + paramar(5) = 0.5d0 ! TolerancePrimary + paramar(6) = symthr ! ToleranceFinal, THIS IS THE IMPORTANT VALUE + paramar(7) = 0.5d0 ! MaxOptStep + paramar(8) = 1.0D-7 ! MinOptStep + paramar(9) = 1.0D-7 ! GradientStep + paramar(10) = 1.0D-8 ! OptChangeThreshold + paramar(11) = 5 ! OptChangeHits + + atmp = ' ' + call schoenflies(n,iat,xyz,atmp,paramar) + + !TM stuff (trafo table) + sfsym(1:3) = atmp(1:3) + if (sfsym(1:1) .eq. 'D') sfsym(1:1) = 'd' + if (sfsym(1:1) .eq. 'C') sfsym(1:1) = 'c' + if (sfsym(1:1) .eq. 'T') sfsym(1:1) = 't' + if (sfsym(1:1) .eq. 'O') sfsym(1:1) = 'o' + if (sfsym(1:1) .eq. 'I') sfsym(1:1) = 'i' + if (sfsym(1:1) .eq. 'S') sfsym(1:1) = 's' + if (sfsym .eq. 'dih') sfsym = 'd6h' + if (sfsym .eq. 'civ') sfsym = 'c6v' + if (sfsym(3:3) .gt. 'v'.or.sfsym(3:3) .lt. 'a') sfsym(3:3) = ' ' + + if (pr) then + write (iunit,'(a3,'' symmetry found (for desy threshold: '',e9.2,'')'')') sfsym,symthr + end if + End subroutine getsymmetry2 + +! ══════════════════════════════════════════════════════════════════════════════ +end module getsymmetry diff --git a/src/symmetry_i.f90 b/src/symmetry_i.f90 index 419cfa2a..8dbfe98e 100644 --- a/src/symmetry_i.f90 +++ b/src/symmetry_i.f90 @@ -9,8 +9,6 @@ !> the Free Software Foundation; either version 2 of the License, or !> (at your option) any later version. -! WARNING: Currently unused and untested! - module symmetry_i use iso_fortran_env,only:wp => real64 implicit none @@ -18,8 +16,7 @@ module symmetry_i ! Public interface public :: schoenflies - public :: symmetry_element,atom_t - public :: set_symmetry_tolerance + !public :: symmetry_element,atom_t,symmetry_state_t !> Mathematical constants real(wp),parameter :: PI = 3.14159265358979323846d0 @@ -50,136 +47,139 @@ module symmetry_i character(len=64) :: symmetry_code end type point_group - !> Module-level parameters (can be modified) - real(wp),save :: ToleranceSame = 1.0d-3 - real(wp),save :: TolerancePrimary = 5.0d-2 - real(wp),save :: ToleranceFinal = 1.0d-4 - real(wp),save :: MaxOptStep = 5.0d-1 - real(wp),save :: MinOptStep = 1.0d-7 - real(wp),save :: GradientStep = 1.0d-7 - real(wp),save :: OptChangeThreshold = 1.0d-10 - integer,save :: verbose = 0 - integer,save :: MaxOptCycles = 200 - integer,save :: OptChangeHits = 5 - integer,save :: MaxAxisOrder = 20 - - !> Working data - real(wp),save :: CenterOfSomething(DIMENSION) - real(wp),allocatable,save :: DistanceFromCenter(:) - integer,save :: AtomsCount = 0 - type(atom_t),allocatable,save :: Atoms(:) - - !> Symmetry elements storage - integer,save :: PlanesCount = 0 - type(symmetry_element),allocatable,save :: Planes(:) - type(symmetry_element),allocatable,save :: MolecularPlane - logical,save :: MolecularPlaneExists = .false. - integer,save :: InversionCentersCount = 0 - type(symmetry_element),allocatable,save :: InversionCenters(:) - integer,save :: NormalAxesCount = 0 - type(symmetry_element),allocatable,save :: NormalAxes(:) - integer,save :: ImproperAxesCount = 0 - type(symmetry_element),allocatable,save :: ImproperAxes(:) - integer,allocatable,save :: NormalAxesCounts(:) - integer,allocatable,save :: ImproperAxesCounts(:) - integer,save :: BadOptimization = 0 - character(len=256),save :: SymmetryCode = "" - character(len=8),save :: MaxRotAxis = "" - - !> Statistics - integer(8),save :: StatTotal = 0 - integer(8),save :: StatEarly = 0 - integer(8),save :: StatPairs = 0 - integer(8),save :: StatDups = 0 - integer(8),save :: StatOrder = 0 - integer(8),save :: StatOpt = 0 - integer(8),save :: StatAccept = 0 - - !> Point groups table + !> Number of point groups in the lookup table integer,parameter :: PointGroupsCount = 60 - type(point_group),save :: PointGroups(PointGroupsCount) - logical,save :: PointGroupsInitialized = .false. + + !> All symmetry-analysis state collected in one derived type + type,public :: symmetry_state_t + ! Tolerance / control + real(wp) :: ToleranceSame = 1.0d-3 + real(wp) :: TolerancePrimary = 5.0d-2 + real(wp) :: ToleranceFinal = 1.0d-4 + real(wp) :: MaxOptStep = 5.0d-1 + real(wp) :: MinOptStep = 1.0d-7 + real(wp) :: GradientStep = 1.0d-7 + real(wp) :: OptChangeThreshold = 1.0d-10 + integer :: verbose = 0 + integer :: MaxAxisOrder = 20 + integer :: MaxOptCycles = 200 + integer :: OptChangeHits = 5 + ! Geometry / working data + real(wp) :: CenterOfSomething(3) = 0.0_wp + real(wp),allocatable :: DistanceFromCenter(:) + integer :: AtomsCount = 0 + type(atom_t),allocatable :: Atoms(:) + ! Symmetry elements + integer :: PlanesCount = 0 + type(symmetry_element),allocatable :: Planes(:) + type(symmetry_element) :: MolecularPlane + logical :: MolecularPlaneExists = .false. + integer :: InversionCentersCount = 0 + type(symmetry_element),allocatable :: InversionCenters(:) + integer :: NormalAxesCount = 0 + type(symmetry_element),allocatable :: NormalAxes(:) + integer :: ImproperAxesCount = 0 + type(symmetry_element),allocatable :: ImproperAxes(:) + integer,allocatable :: NormalAxesCounts(:) + integer,allocatable :: ImproperAxesCounts(:) + integer :: BadOptimization = 0 + character(len=256) :: SymmetryCode = "" + character(len=8) :: MaxRotAxis = "" + ! Statistics + integer(8) :: StatTotal = 0 + integer(8) :: StatEarly = 0 + integer(8) :: StatPairs = 0 + integer(8) :: StatDups = 0 + integer(8) :: StatOrder = 0 + integer(8) :: StatOpt = 0 + integer(8) :: StatAccept = 0 + ! Point groups lookup table + type(point_group) :: PointGroups(PointGroupsCount) + logical :: PointGroupsInitialized = .false. + end type symmetry_state_t ! ══════════════════════════════════════════════════════════════════════════════ contains !> MODULE PROCEDURES START HERE ! ══════════════════════════════════════════════════════════════════════════════ + !> Initialise (reset) a symmetry_state_t to its defaults + subroutine init_symmetry_state(state) + type(symmetry_state_t),intent(out) :: state + ! intent(out) resets all scalar fields to their type-definition defaults + ! and deallocates every allocatable component (transitively). + ! Explicitly destroy the non-allocatable MolecularPlane's inner allocatable. + call destroy_symmetry_element(state%MolecularPlane) + end subroutine init_symmetry_state + !> Initialize point groups table - subroutine init_point_groups() - if (PointGroupsInitialized) return - - PointGroups(1) = point_group("C1","") - PointGroups(2) = point_group("Cs","(sigma) ") - PointGroups(3) = point_group("Ci","(i) ") - PointGroups(4) = point_group("C2","(C2) ") - PointGroups(5) = point_group("C3","(C3) ") - PointGroups(6) = point_group("C4","(C4) (C2) ") - PointGroups(7) = point_group("C5","(C5) ") - PointGroups(8) = point_group("C6","(C6) (C3) (C2) ") - PointGroups(9) = point_group("C7","(C7) ") - PointGroups(10) = point_group("C8","(C8) (C4) (C2) ") - PointGroups(11) = point_group("D2","3*(C2) ") - PointGroups(12) = point_group("D3","(C3) 3*(C2) ") - PointGroups(13) = point_group("D4","(C4) 5*(C2) ") - PointGroups(14) = point_group("D5","(C5) 5*(C2) ") - PointGroups(15) = point_group("D6","(C6) (C3) 7*(C2) ") - PointGroups(16) = point_group("D7","(C7) 7*(C2) ") - PointGroups(17) = point_group("D8","(C8) (C4) 9*(C2) ") - PointGroups(18) = point_group("C2v","(C2) 2*(sigma) ") - PointGroups(19) = point_group("C3v","(C3) 3*(sigma) ") - PointGroups(20) = point_group("C4v","(C4) (C2) 4*(sigma) ") - PointGroups(21) = point_group("C5v","(C5) 5*(sigma) ") - PointGroups(22) = point_group("C6v","(C6) (C3) (C2) 6*(sigma) ") - PointGroups(23) = point_group("C7v","(C7) 7*(sigma) ") - PointGroups(24) = point_group("C8v","(C8) (C4) (C2) 8*(sigma) ") - PointGroups(25) = point_group("C2h","(i) (C2) (sigma) ") - PointGroups(26) = point_group("C3h","(C3) (S3) (sigma) ") - PointGroups(27) = point_group("C4h","(i) (C4) (C2) (S4) (sigma) ") - PointGroups(28) = point_group("C5h","(C5) (S5) (sigma) ") - PointGroups(29) = point_group("C6h","(i) (C6) (C3) (C2) (S6) (S3) (sigma) ") - PointGroups(30) = point_group("C7h","(C7) (S7) (sigma) ") - PointGroups(31) = point_group("C8h","(i) (C8) (C4) (C2) (S8) (S4) (sigma) ") - PointGroups(32) = point_group("D2h","(i) 3*(C2) 3*(sigma) ") - PointGroups(33) = point_group("D3h","(C3) 3*(C2) (S3) 4*(sigma) ") - PointGroups(34) = point_group("D4h","(i) (C4) 5*(C2) (S4) 5*(sigma) ") - PointGroups(35) = point_group("D5h","(C5) 5*(C2) (S5) 6*(sigma) ") - PointGroups(36) = point_group("D6h","(i) (C6) (C3) 7*(C2) (S6) (S3) 7*(sigma) ") - PointGroups(37) = point_group("D7h","(C7) 7*(C2) (S7) 8*(sigma) ") - PointGroups(38) = point_group("D8h","(i) (C8) (C4) 9*(C2) (S8) (S4) 9*(sigma) ") - PointGroups(39) = point_group("D2d","3*(C2) (S4) 2*(sigma) ") - PointGroups(40) = point_group("D3d","(i) (C3) 3*(C2) (S6) 3*(sigma) ") - PointGroups(41) = point_group("D4d","(C4) 5*(C2) (S8) 4*(sigma) ") - PointGroups(42) = point_group("D5d","(i) (C5) 5*(C2) (S10) 5*(sigma) ") - PointGroups(43) = point_group("D6d","(C6) (C3) 7*(C2) (S12) (S4) 6*(sigma) ") - PointGroups(44) = point_group("D7d","(i) (C7) 7*(C2) (S14) 7*(sigma) ") - PointGroups(45) = point_group("D8d","(C8) (C4) 9*(C2) (S16) 8*(sigma) ") - PointGroups(46) = point_group("S4","(C2) (S4) ") - PointGroups(47) = point_group("S6","(i) (C3) (S6) ") - PointGroups(48) = point_group("S8","(C4) (C2) (S8) ") - PointGroups(49) = point_group("T","4*(C3) 3*(C2) ") - PointGroups(50) = point_group("Th","(i) 4*(C3) 3*(C2) 4*(S6) 3*(sigma) ") - PointGroups(51) = point_group("Td","4*(C3) 3*(C2) 3*(S4) 6*(sigma) ") - PointGroups(52) = point_group("O","3*(C4) 4*(C3) 9*(C2) ") - PointGroups(53) = point_group("Oh","(i) 3*(C4) 4*(C3) 9*(C2) 4*(S6) 3*(S4) 9*(sigma) ") - PointGroups(54) = point_group("Cinfv","(Cinf) (sigma) ") - PointGroups(55) = point_group("Dinfh","(i) (Cinf) (C2) 2*(sigma) ") - PointGroups(56) = point_group("I","6*(C5) 10*(C3) 15*(C2) ") - PointGroups(57) = point_group("Ih","(i) 6*(C5) 10*(C3) 15*(C2) 6*(S10) 10*(S6) 15*(sigma) ") - PointGroups(58) = point_group("Kh","(i) (Cinf) (sigma) ") - PointGroups(59) = point_group("","") ! Padding - PointGroups(60) = point_group("","") ! Padding - - PointGroupsInitialized = .true. + subroutine init_point_groups(state) + type(symmetry_state_t),intent(inout) :: state + if (state%PointGroupsInitialized) return + + state%PointGroups(1) = point_group("C1","") + state%PointGroups(2) = point_group("Cs","(sigma) ") + state%PointGroups(3) = point_group("Ci","(i) ") + state%PointGroups(4) = point_group("C2","(C2) ") + state%PointGroups(5) = point_group("C3","(C3) ") + state%PointGroups(6) = point_group("C4","(C4) (C2) ") + state%PointGroups(7) = point_group("C5","(C5) ") + state%PointGroups(8) = point_group("C6","(C6) (C3) (C2) ") + state%PointGroups(9) = point_group("C7","(C7) ") + state%PointGroups(10) = point_group("C8","(C8) (C4) (C2) ") + state%PointGroups(11) = point_group("D2","3*(C2) ") + state%PointGroups(12) = point_group("D3","(C3) 3*(C2) ") + state%PointGroups(13) = point_group("D4","(C4) 5*(C2) ") + state%PointGroups(14) = point_group("D5","(C5) 5*(C2) ") + state%PointGroups(15) = point_group("D6","(C6) (C3) 7*(C2) ") + state%PointGroups(16) = point_group("D7","(C7) 7*(C2) ") + state%PointGroups(17) = point_group("D8","(C8) (C4) 9*(C2) ") + state%PointGroups(18) = point_group("C2v","(C2) 2*(sigma) ") + state%PointGroups(19) = point_group("C3v","(C3) 3*(sigma) ") + state%PointGroups(20) = point_group("C4v","(C4) (C2) 4*(sigma) ") + state%PointGroups(21) = point_group("C5v","(C5) 5*(sigma) ") + state%PointGroups(22) = point_group("C6v","(C6) (C3) (C2) 6*(sigma) ") + state%PointGroups(23) = point_group("C7v","(C7) 7*(sigma) ") + state%PointGroups(24) = point_group("C8v","(C8) (C4) (C2) 8*(sigma) ") + state%PointGroups(25) = point_group("C2h","(i) (C2) (sigma) ") + state%PointGroups(26) = point_group("C3h","(C3) (S3) (sigma) ") + state%PointGroups(27) = point_group("C4h","(i) (C4) (C2) (S4) (sigma) ") + state%PointGroups(28) = point_group("C5h","(C5) (S5) (sigma) ") + state%PointGroups(29) = point_group("C6h","(i) (C6) (C3) (C2) (S6) (S3) (sigma) ") + state%PointGroups(30) = point_group("C7h","(C7) (S7) (sigma) ") + state%PointGroups(31) = point_group("C8h","(i) (C8) (C4) (C2) (S8) (S4) (sigma) ") + state%PointGroups(32) = point_group("D2h","(i) 3*(C2) 3*(sigma) ") + state%PointGroups(33) = point_group("D3h","(C3) 3*(C2) (S3) 4*(sigma) ") + state%PointGroups(34) = point_group("D4h","(i) (C4) 5*(C2) (S4) 5*(sigma) ") + state%PointGroups(35) = point_group("D5h","(C5) 5*(C2) (S5) 6*(sigma) ") + state%PointGroups(36) = point_group("D6h","(i) (C6) (C3) 7*(C2) (S6) (S3) 7*(sigma) ") + state%PointGroups(37) = point_group("D7h","(C7) 7*(C2) (S7) 8*(sigma) ") + state%PointGroups(38) = point_group("D8h","(i) (C8) (C4) 9*(C2) (S8) (S4) 9*(sigma) ") + state%PointGroups(39) = point_group("D2d","3*(C2) (S4) 2*(sigma) ") + state%PointGroups(40) = point_group("D3d","(i) (C3) 3*(C2) (S6) 3*(sigma) ") + state%PointGroups(41) = point_group("D4d","(C4) 5*(C2) (S8) 4*(sigma) ") + state%PointGroups(42) = point_group("D5d","(i) (C5) 5*(C2) (S10) 5*(sigma) ") + state%PointGroups(43) = point_group("D6d","(C6) (C3) 7*(C2) (S12) (S4) 6*(sigma) ") + state%PointGroups(44) = point_group("D7d","(i) (C7) 7*(C2) (S14) 7*(sigma) ") + state%PointGroups(45) = point_group("D8d","(C8) (C4) 9*(C2) (S16) 8*(sigma) ") + state%PointGroups(46) = point_group("S4","(C2) (S4) ") + state%PointGroups(47) = point_group("S6","(i) (C3) (S6) ") + state%PointGroups(48) = point_group("S8","(C4) (C2) (S8) ") + state%PointGroups(49) = point_group("T","4*(C3) 3*(C2) ") + state%PointGroups(50) = point_group("Th","(i) 4*(C3) 3*(C2) 4*(S6) 3*(sigma) ") + state%PointGroups(51) = point_group("Td","4*(C3) 3*(C2) 3*(S4) 6*(sigma) ") + state%PointGroups(52) = point_group("O","3*(C4) 4*(C3) 9*(C2) ") + state%PointGroups(53) = point_group("Oh","(i) 3*(C4) 4*(C3) 9*(C2) 4*(S6) 3*(S4) 9*(sigma) ") + state%PointGroups(54) = point_group("Cinfv","(Cinf) (sigma) ") + state%PointGroups(55) = point_group("Dinfh","(i) (Cinf) (C2) 2*(sigma) ") + state%PointGroups(56) = point_group("I","6*(C5) 10*(C3) 15*(C2) ") + state%PointGroups(57) = point_group("Ih","(i) 6*(C5) 10*(C3) 15*(C2) 6*(S10) 10*(S6) 15*(sigma) ") + state%PointGroups(58) = point_group("Kh","(i) (Cinf) (sigma) ") + state%PointGroups(59) = point_group("","") ! Padding + state%PointGroups(60) = point_group("","") ! Padding + + state%PointGroupsInitialized = .true. end subroutine init_point_groups - !> Set tolerance parameters - subroutine set_symmetry_tolerance(tol_same,tol_primary,tol_final) - real(wp),intent(in),optional :: tol_same,tol_primary,tol_final - if (present(tol_same)) ToleranceSame = tol_same - if (present(tol_primary)) TolerancePrimary = tol_primary - if (present(tol_final)) ToleranceFinal = tol_final - end subroutine set_symmetry_tolerance - !> Square function pure real(wp) function pow2(x) real(wp),intent(in) :: x @@ -187,20 +187,21 @@ pure real(wp) function pow2(x) end function pow2 !> Allocate a symmetry element - subroutine alloc_symmetry_element(elem) + subroutine alloc_symmetry_element(state,elem) + type(symmetry_state_t),intent(in) :: state type(symmetry_element),intent(out) :: elem integer :: i - allocate (elem%transform(AtomsCount)) - do i = 1,AtomsCount - elem%transform(i) = AtomsCount+1 ! Impossible value + allocate (elem%transform(state%AtomsCount)) + do i = 1,state%AtomsCount + elem%transform(i) = state%AtomsCount+1 ! Impossible value end do - elem%order = 0 - elem%nparam = 0 - elem%maxdev = 0.0d0 - elem%distance = 0.0d0 - elem%normal = 0.0d0 - elem%direction = 0.0d0 + elem%order = 0 + elem%nparam = 0 + elem%maxdev = 0.0d0 + elem%distance = 0.0d0 + elem%normal = 0.0d0 + elem%direction = 0.0d0 elem%transform_type = 0 end subroutine alloc_symmetry_element @@ -355,7 +356,8 @@ subroutine transform_atom(elem,from_atom,to_atom) end subroutine transform_atom !> Establish pairs of atoms related by symmetry - function establish_pairs(elem) result(status) + function establish_pairs(state,elem) result(status) + type(symmetry_state_t),intent(inout) :: state type(symmetry_element),intent(inout) :: elem integer :: status integer :: i,j,k,best_j @@ -364,21 +366,21 @@ function establish_pairs(elem) result(status) type(atom_t) :: symmetric status = 0 - allocate (atom_used(AtomsCount)) + allocate (atom_used(state%AtomsCount)) atom_used = .false. - do i = 1,AtomsCount - if (elem%transform(i) > AtomsCount) then - call transform_atom(elem,Atoms(i),symmetric) + do i = 1,state%AtomsCount + if (elem%transform(i) > state%AtomsCount) then + call transform_atom(elem,state%Atoms(i),symmetric) best_j = i - best_distance = 2.0d0*TolerancePrimary + best_distance = 2.0d0*state%TolerancePrimary - do j = 1,AtomsCount - if (Atoms(j)%atom_type /= symmetric%atom_type.or.atom_used(j)) cycle + do j = 1,state%AtomsCount + if (state%Atoms(j)%atom_type /= symmetric%atom_type.or.atom_used(j)) cycle distance = 0.0d0 do k = 1,DIMENSION - distance = distance+pow2(symmetric%x(k)-Atoms(j)%x(k)) + distance = distance+pow2(symmetric%x(k)-state%Atoms(j)%x(k)) end do distance = sqrt(distance) @@ -388,7 +390,7 @@ function establish_pairs(elem) result(status) end if end do - if (best_distance > TolerancePrimary) then + if (best_distance > state%TolerancePrimary) then deallocate (atom_used) status = -1 return @@ -403,14 +405,15 @@ function establish_pairs(elem) result(status) end function establish_pairs !> Check if transformation order is correct - function check_transform_order(elem) result(status) + function check_transform_order(state,elem) result(status) + type(symmetry_state_t),intent(in) :: state type(symmetry_element),intent(in) :: elem integer :: status integer :: i,j,k status = 0 - do i = 1,AtomsCount + do i = 1,state%AtomsCount if (elem%transform(i) == i) cycle if (elem%transform_type == 4) then ! rotate_reflect @@ -445,7 +448,8 @@ function check_transform_order(elem) result(status) end function check_transform_order !> Check if two transforms are the same - function same_transform(a,b) result(is_same) + function same_transform(state,a,b) result(is_same) + type(symmetry_state_t),intent(in) :: state type(symmetry_element),intent(in) :: a,b logical :: is_same integer :: i,j,code @@ -456,7 +460,7 @@ function same_transform(a,b) result(is_same) a%transform_type /= b%transform_type) return code = 1 - do i = 1,AtomsCount + do i = 1,state%AtomsCount if (a%transform(i) /= b%transform(i)) then code = 0 exit @@ -464,7 +468,7 @@ function same_transform(a,b) result(is_same) end do if (code == 0.and.a%order > 2) then - do i = 1,AtomsCount + do i = 1,state%AtomsCount j = a%transform(i) if (b%transform(j) /= i) return end do @@ -476,7 +480,8 @@ function same_transform(a,b) result(is_same) end function same_transform !> Check transform quality - function check_transform_quality(elem) result(status) + function check_transform_quality(state,elem) result(status) + type(symmetry_state_t),intent(inout) :: state type(symmetry_element),intent(inout) :: elem integer :: status integer :: i,j,k @@ -486,17 +491,17 @@ function check_transform_quality(elem) result(status) status = 0 max_r = 0.0d0 - do i = 1,AtomsCount + do i = 1,state%AtomsCount j = elem%transform(i) - call transform_atom(elem,Atoms(i),symmetric) + call transform_atom(elem,state%Atoms(i),symmetric) r = 0.0d0 do k = 1,DIMENSION - r = r+pow2(symmetric%x(k)-Atoms(j)%x(k)) + r = r+pow2(symmetric%x(k)-state%Atoms(j)%x(k)) end do r = sqrt(r) - if (r > ToleranceFinal) then + if (r > state%ToleranceFinal) then status = -1 return end if @@ -507,7 +512,8 @@ function check_transform_quality(elem) result(status) end function check_transform_quality !> Evaluate optimization target function - function eval_optimization_target_function(elem,finish) result(target) + function eval_optimization_target_function(state,elem,finish) result(target) + type(symmetry_state_t),intent(inout) :: state type(symmetry_element),intent(inout) :: elem logical,intent(out),optional :: finish real(wp) :: target @@ -522,7 +528,7 @@ function eval_optimization_target_function(elem,finish) result(target) r = r+elem%normal(k)*elem%normal(k) end do r = sqrt(r) - if (r < ToleranceSame) then + if (r < state%ToleranceSame) then write (*,*) "Normal collapsed!" stop end if @@ -540,7 +546,7 @@ function eval_optimization_target_function(elem,finish) result(target) r = r+elem%direction(k)*elem%direction(k) end do r = sqrt(r) - if (r < ToleranceSame) then + if (r < state%ToleranceSame) then write (*,*) "Direction collapsed!" stop end if @@ -550,20 +556,20 @@ function eval_optimization_target_function(elem,finish) result(target) target = 0.0d0 maxr = 0.0d0 - do i = 1,AtomsCount - call transform_atom(elem,Atoms(i),symmetric) + do i = 1,state%AtomsCount + call transform_atom(elem,state%Atoms(i),symmetric) j = elem%transform(i) r = 0.0d0 do k = 1,DIMENSION - r = r+pow2(Atoms(j)%x(k)-symmetric%x(k)) + r = r+pow2(state%Atoms(j)%x(k)-symmetric%x(k)) end do if (r > maxr) maxr = r target = target+r end do if (present(finish)) then - finish = (sqrt(maxr) < ToleranceFinal) + finish = (sqrt(maxr) < state%ToleranceFinal) end if end function eval_optimization_target_function @@ -592,7 +598,8 @@ subroutine set_params(elem,values) end subroutine set_params !> Optimize transformation parameters - subroutine optimize_transformation_params(elem) + subroutine optimize_transformation_params(state,elem) + type(symmetry_state_t),intent(inout) :: state type(symmetry_element),intent(inout) :: elem real(wp) :: values(MAXPARAM),grad(MAXPARAM),force(MAXPARAM),step(MAXPARAM) real(wp) :: f,fold,fnew,fnew2,fdn,fup,snorm @@ -612,34 +619,34 @@ subroutine optimize_transformation_params(elem) do fold = f - f = eval_optimization_target_function(elem,finish) + f = eval_optimization_target_function(state,elem,finish) if (finish) exit if (cycle > 0) then - if (abs(f-fold) > OptChangeThreshold) then + if (abs(f-fold) > state%OptChangeThreshold) then hits = 0 else hits = hits+1 end if - if (hits >= OptChangeHits) exit + if (hits >= state%OptChangeHits) exit end if call get_params(elem,values) ! Calculate gradient and force constants do i = 1,vars - values(i) = values(i)-GradientStep + values(i) = values(i)-state%GradientStep call set_params(elem,values) - fdn = eval_optimization_target_function(elem) + fdn = eval_optimization_target_function(state,elem) - values(i) = values(i)+2.0d0*GradientStep + values(i) = values(i)+2.0d0*state%GradientStep call set_params(elem,values) - fup = eval_optimization_target_function(elem) + fup = eval_optimization_target_function(state,elem) - values(i) = values(i)-GradientStep - grad(i) = (fup-fdn)/(2.0d0*GradientStep) - force(i) = (fup+fdn-2.0d0*f)/(GradientStep*GradientStep) + values(i) = values(i)-state%GradientStep + grad(i) = (fup-fdn)/(2.0d0*state%GradientStep) + force(i) = (fup+fdn-2.0d0*f)/(state%GradientStep*state%GradientStep) end do ! Quasi-Newton step @@ -653,15 +660,15 @@ subroutine optimize_transformation_params(elem) end do snorm = sqrt(snorm) - if (snorm > MaxOptStep) then - step = step*MaxOptStep/snorm - snorm = MaxOptStep + if (snorm > state%MaxOptStep) then + step = step*state%MaxOptStep/snorm + snorm = state%MaxOptStep end if - do while (snorm > MinOptStep) + do while (snorm > state%MinOptStep) values = values+step call set_params(elem,values) - fnew = eval_optimization_target_function(elem) + fnew = eval_optimization_target_function(state,elem) if (fnew < f) exit @@ -672,10 +679,10 @@ subroutine optimize_transformation_params(elem) end do ! Quadratic interpolation - if (snorm > MinOptStep.and.snorm < MaxOptStep/2.0d0) then + if (snorm > state%MinOptStep.and.snorm < state%MaxOptStep/2.0d0) then values = values+step call set_params(elem,values) - fnew2 = eval_optimization_target_function(elem) + fnew2 = eval_optimization_target_function(state,elem) values = values-2.0d0*step a = (4.0d0*f-fnew2-3.0d0*fnew)/2.0d0 @@ -701,15 +708,16 @@ subroutine optimize_transformation_params(elem) end if cycle = cycle+1 - if (snorm <= MinOptStep.or.cycle >= MaxOptCycles) exit + if (snorm <= state%MinOptStep.or.cycle >= state%MaxOptCycles) exit end do - f = eval_optimization_target_function(elem) - if (cycle >= MaxOptCycles) BadOptimization = 1 + f = eval_optimization_target_function(state,elem) + if (cycle >= state%MaxOptCycles) state%BadOptimization = 1 end subroutine optimize_transformation_params !> Refine symmetry element - function refine_symmetry_element(elem,build_table) result(status) + function refine_symmetry_element(state,elem,build_table) result(status) + type(symmetry_state_t),intent(inout) :: state type(symmetry_element),intent(inout) :: elem logical,intent(in) :: build_table integer :: status @@ -718,65 +726,66 @@ function refine_symmetry_element(elem,build_table) result(status) status = 0 if (build_table) then - if (establish_pairs(elem) < 0) then - StatPairs = StatPairs+1 + if (establish_pairs(state,elem) < 0) then + state%StatPairs = state%StatPairs+1 status = -1 return end if end if ! Check for duplicates - do i = 1,PlanesCount - if (same_transform(Planes(i),elem)) then - StatDups = StatDups+1 + do i = 1,state%PlanesCount + if (same_transform(state,state%Planes(i),elem)) then + state%StatDups = state%StatDups+1 status = -1 return end if end do - do i = 1,InversionCentersCount - if (same_transform(InversionCenters(i),elem)) then - StatDups = StatDups+1 + do i = 1,state%InversionCentersCount + if (same_transform(state,state%InversionCenters(i),elem)) then + state%StatDups = state%StatDups+1 status = -1 return end if end do - do i = 1,NormalAxesCount - if (same_transform(NormalAxes(i),elem)) then - StatDups = StatDups+1 + do i = 1,state%NormalAxesCount + if (same_transform(state,state%NormalAxes(i),elem)) then + state%StatDups = state%StatDups+1 status = -1 return end if end do - do i = 1,ImproperAxesCount - if (same_transform(ImproperAxes(i),elem)) then - StatDups = StatDups+1 + do i = 1,state%ImproperAxesCount + if (same_transform(state,state%ImproperAxes(i),elem)) then + state%StatDups = state%StatDups+1 status = -1 return end if end do - if (check_transform_order(elem) < 0) then - StatOrder = StatOrder+1 + if (check_transform_order(state,elem) < 0) then + state%StatOrder = state%StatOrder+1 status = -1 return end if - call optimize_transformation_params(elem) + call optimize_transformation_params(state,elem) - if (check_transform_quality(elem) < 0) then - StatOpt = StatOpt+1 + if (check_transform_quality(state,elem) < 0) then + state%StatOpt = state%StatOpt+1 status = -1 return end if - StatAccept = StatAccept+1 + state%StatAccept = state%StatAccept+1 end function refine_symmetry_element !> Initialize mirror plane - subroutine init_mirror_plane(i,j,plane,success) + subroutine init_mirror_plane(state,i,j,plane,success) + type(symmetry_state_t),intent(inout) :: state integer,intent(in) :: i,j type(symmetry_element),intent(out) :: plane logical,intent(out) :: success @@ -784,22 +793,22 @@ subroutine init_mirror_plane(i,j,plane,success) integer :: k success = .false. - StatTotal = StatTotal+1 + state%StatTotal = state%StatTotal+1 - call alloc_symmetry_element(plane) + call alloc_symmetry_element(state,plane) plane%transform_type = 1 ! mirror plane%order = 2 plane%nparam = 4 rab = 0.0d0 do k = 1,DIMENSION - dx(k) = Atoms(i)%x(k)-Atoms(j)%x(k) - midpoint(k) = (Atoms(i)%x(k)+Atoms(j)%x(k))/2.0d0 + dx(k) = state%Atoms(i)%x(k)-state%Atoms(j)%x(k) + midpoint(k) = (state%Atoms(i)%x(k)+state%Atoms(j)%x(k))/2.0d0 rab = rab+dx(k)*dx(k) end do rab = sqrt(rab) - if (rab < ToleranceSame) then + if (rab < state%ToleranceSame) then call destroy_symmetry_element(plane) return end if @@ -816,7 +825,7 @@ subroutine init_mirror_plane(i,j,plane,success) end if plane%distance = r - if (refine_symmetry_element(plane,.true.) < 0) then + if (refine_symmetry_element(state,plane,.true.) < 0) then call destroy_symmetry_element(plane) return end if @@ -825,7 +834,8 @@ subroutine init_mirror_plane(i,j,plane,success) end subroutine init_mirror_plane !> Initialize ultimate (whole-molecule) plane - subroutine init_ultimate_plane(plane,success) + subroutine init_ultimate_plane(state,plane,success) + type(symmetry_state_t),intent(inout) :: state type(symmetry_element),intent(out) :: plane logical,intent(out) :: success real(wp) :: d0(DIMENSION),d1(DIMENSION),d2(DIMENSION),p(DIMENSION) @@ -834,9 +844,9 @@ subroutine init_ultimate_plane(plane,success) integer :: i,j,k success = .false. - StatTotal = StatTotal+1 + state%StatTotal = state%StatTotal+1 - call alloc_symmetry_element(plane) + call alloc_symmetry_element(state,plane) plane%transform_type = 1 plane%order = 1 plane%nparam = 4 @@ -844,11 +854,11 @@ subroutine init_ultimate_plane(plane,success) d0 = 0.0d0; d1 = 0.0d0; d2 = 0.0d0 d0(1) = 1.0d0; d1(2) = 1.0d0; d2(3) = 1.0d0 - do i = 2,AtomsCount + do i = 2,state%AtomsCount do j = 1,i-1 r = 0.0d0 do k = 1,DIMENSION - p(k) = Atoms(i)%x(k)-Atoms(j)%x(k) + p(k) = state%Atoms(i)%x(k)-state%Atoms(j)%x(k) r = r+p(k)*p(k) end do r = sqrt(r) @@ -888,14 +898,14 @@ subroutine init_ultimate_plane(plane,success) plane%normal = [1.0d0,0.0d0,0.0d0] end if - r = dot_product(CenterOfSomething,plane%normal) + r = dot_product(state%CenterOfSomething,plane%normal) plane%distance = r - do k = 1,AtomsCount + do k = 1,state%AtomsCount plane%transform(k) = k end do - if (refine_symmetry_element(plane,.false.) < 0) then + if (refine_symmetry_element(state,plane,.false.) < 0) then call destroy_symmetry_element(plane) return end if @@ -904,30 +914,31 @@ subroutine init_ultimate_plane(plane,success) end subroutine init_ultimate_plane !> Initialize inversion center - subroutine init_inversion_center(center,success) + subroutine init_inversion_center(state,center,success) + type(symmetry_state_t),intent(inout) :: state type(symmetry_element),intent(out) :: center logical,intent(out) :: success real(wp) :: r integer :: k success = .false. - StatTotal = StatTotal+1 + state%StatTotal = state%StatTotal+1 - call alloc_symmetry_element(center) + call alloc_symmetry_element(state,center) center%transform_type = 2 ! invert center%order = 2 center%nparam = 4 - r = sqrt(sum(CenterOfSomething**2)) + r = sqrt(sum(state%CenterOfSomething**2)) if (r > 0.0d0) then - center%normal = CenterOfSomething/r + center%normal = state%CenterOfSomething/r else center%normal = [1.0d0,0.0d0,0.0d0] end if center%distance = r - if (refine_symmetry_element(center,.true.) < 0) then + if (refine_symmetry_element(state,center,.true.) < 0) then call destroy_symmetry_element(center) return end if @@ -936,25 +947,26 @@ subroutine init_inversion_center(center,success) end subroutine init_inversion_center !> Initialize ultimate (infinity) axis - subroutine init_ultimate_axis(axis,success) + subroutine init_ultimate_axis(state,axis,success) + type(symmetry_state_t),intent(inout) :: state type(symmetry_element),intent(out) :: axis logical,intent(out) :: success real(wp) :: dir(DIMENSION),rel(DIMENSION),s integer :: i,k success = .false. - StatTotal = StatTotal+1 + state%StatTotal = state%StatTotal+1 - call alloc_symmetry_element(axis) + call alloc_symmetry_element(state,axis) axis%transform_type = 3 ! rotate axis%order = 0 axis%nparam = 7 dir = 0.0d0 - do i = 1,AtomsCount + do i = 1,state%AtomsCount s = 0.0d0 do k = 1,DIMENSION - rel(k) = Atoms(i)%x(k)-CenterOfSomething(k) + rel(k) = state%Atoms(i)%x(k)-state%CenterOfSomething(k) s = s+rel(k)*dir(k) end do if (s >= 0.0d0) then @@ -971,19 +983,19 @@ subroutine init_ultimate_axis(axis,success) axis%direction = [1.0d0,0.0d0,0.0d0] end if - s = sqrt(sum(CenterOfSomething**2)) + s = sqrt(sum(state%CenterOfSomething**2)) if (s > 0.0d0) then - axis%normal = CenterOfSomething/s + axis%normal = state%CenterOfSomething/s else axis%normal = [1.0d0,0.0d0,0.0d0] end if axis%distance = s - do k = 1,AtomsCount + do k = 1,state%AtomsCount axis%transform(k) = k end do - if (refine_symmetry_element(axis,.false.) < 0) then + if (refine_symmetry_element(state,axis,.false.) < 0) then call destroy_symmetry_element(axis) return end if @@ -991,83 +1003,9 @@ subroutine init_ultimate_axis(axis,success) success = .true. end subroutine init_ultimate_axis - !> Initialize C2 axis - subroutine init_c2_axis(i,j,support,axis,success) - integer,intent(in) :: i,j - real(wp),intent(in) :: support(DIMENSION) - type(symmetry_element),intent(out) :: axis - logical,intent(out) :: success - real(wp) :: ris,rjs,r,center(DIMENSION) - integer :: k - - success = .false. - StatTotal = StatTotal+1 - - ! Quick sanity check - ris = 0.0d0 - rjs = 0.0d0 - do k = 1,DIMENSION - ris = ris+pow2(Atoms(i)%x(k)-support(k)) - rjs = rjs+pow2(Atoms(j)%x(k)-support(k)) - end do - ris = sqrt(ris) - rjs = sqrt(rjs) - - if (abs(ris-rjs) > TolerancePrimary) then - StatEarly = StatEarly+1 - return - end if - - call alloc_symmetry_element(axis) - axis%transform_type = 3 ! rotate - axis%order = 2 - axis%nparam = 7 - - r = sqrt(sum(CenterOfSomething**2)) - if (r > 0.0d0) then - axis%normal = CenterOfSomething/r - else - axis%normal = [1.0d0,0.0d0,0.0d0] - end if - axis%distance = r - - r = 0.0d0 - do k = 1,DIMENSION - center(k) = (Atoms(i)%x(k)+Atoms(j)%x(k))/2.0d0-support(k) - r = r+center(k)*center(k) - end do - r = sqrt(r) - - if (r <= TolerancePrimary) then - ! C2 is underdefined - if (MolecularPlaneExists) then - axis%direction = MolecularPlane%normal - else - do k = 1,DIMENSION - center(k) = Atoms(i)%x(k)-Atoms(j)%x(k) - end do - if (abs(center(3))+abs(center(2)) > ToleranceSame) then - axis%direction = [0.0d0,center(3),-center(2)] - else - axis%direction = [-center(3),0.0d0,center(1)] - end if - r = sqrt(sum(axis%direction**2)) - axis%direction = axis%direction/r - end if - else - axis%direction = center/r - end if - - if (refine_symmetry_element(axis,.true.) < 0) then - call destroy_symmetry_element(axis) - return - end if - - success = .true. - end subroutine init_c2_axis - !> Initialize axis parameters from three points - subroutine init_axis_parameters(a,b,c,axis,success) + subroutine init_axis_parameters(state,a,b,c,axis,success) + type(symmetry_state_t),intent(inout) :: state real(wp),intent(in) :: a(3),b(3),c(3) type(symmetry_element),intent(out) :: axis logical,intent(out) :: success @@ -1080,10 +1018,10 @@ subroutine init_axis_parameters(a,b,c,axis,success) rb = sqrt(sum(b**2)) rc = sqrt(sum(c**2)) - if (abs(ra-rb) > TolerancePrimary.or. & - abs(ra-rc) > TolerancePrimary.or. & - abs(rb-rc) > TolerancePrimary) then - StatEarly = StatEarly+1 + if (abs(ra-rb) > state%TolerancePrimary.or. & + abs(ra-rc) > state%TolerancePrimary.or. & + abs(rb-rc) > state%TolerancePrimary) then + state%StatEarly = state%StatEarly+1 return end if @@ -1091,37 +1029,38 @@ subroutine init_axis_parameters(a,b,c,axis,success) rac = sqrt(sum((a-c)**2)) rbc = sqrt(sum((c-b)**2)) - if (abs(rab-rbc) > TolerancePrimary) then - StatEarly = StatEarly+1 + if (abs(rab-rbc) > state%TolerancePrimary) then + state%StatEarly = state%StatEarly+1 return end if - if (rab <= ToleranceSame.or.rbc <= ToleranceSame.or.rac <= ToleranceSame) then - StatEarly = StatEarly+1 + if (rab <= state%ToleranceSame.or.rbc <= state%ToleranceSame.or. & + rac <= state%ToleranceSame) then + state%StatEarly = state%StatEarly+1 return end if rab = (rab+rbc)/2.0d0 angle = PI-2.0d0*asin(rac/(2.0d0*rab)) - if (abs(angle) <= PI/(MaxAxisOrder+1)) then - StatEarly = StatEarly+1 + if (abs(angle) <= PI/(state%MaxAxisOrder+1)) then + state%StatEarly = state%StatEarly+1 return end if order = nint((2.0d0*PI)/angle) - if (order <= 2.or.order > MaxAxisOrder) then - StatEarly = StatEarly+1 + if (order <= 2.or.order > state%MaxAxisOrder) then + state%StatEarly = state%StatEarly+1 return end if - call alloc_symmetry_element(axis) + call alloc_symmetry_element(state,axis) axis%order = order axis%nparam = 7 - r = sqrt(sum(CenterOfSomething**2)) + r = sqrt(sum(state%CenterOfSomething**2)) if (r > 0.0d0) then - axis%normal = CenterOfSomething/r + axis%normal = state%CenterOfSomething/r else axis%normal = [1.0d0,0.0d0,0.0d0] end if @@ -1152,8 +1091,85 @@ subroutine init_axis_parameters(a,b,c,axis,success) success = .true. end subroutine init_axis_parameters + !> Initialize C2 axis + subroutine init_c2_axis(state,i,j,support,axis,success) + type(symmetry_state_t),intent(inout) :: state + integer,intent(in) :: i,j + real(wp),intent(in) :: support(DIMENSION) + type(symmetry_element),intent(out) :: axis + logical,intent(out) :: success + real(wp) :: ris,rjs,r,center(DIMENSION) + integer :: k + + success = .false. + state%StatTotal = state%StatTotal+1 + + ! Quick sanity check + ris = 0.0d0 + rjs = 0.0d0 + do k = 1,DIMENSION + ris = ris+pow2(state%Atoms(i)%x(k)-support(k)) + rjs = rjs+pow2(state%Atoms(j)%x(k)-support(k)) + end do + ris = sqrt(ris) + rjs = sqrt(rjs) + + if (abs(ris-rjs) > state%TolerancePrimary) then + state%StatEarly = state%StatEarly+1 + return + end if + + call alloc_symmetry_element(state,axis) + axis%transform_type = 3 ! rotate + axis%order = 2 + axis%nparam = 7 + + r = sqrt(sum(state%CenterOfSomething**2)) + if (r > 0.0d0) then + axis%normal = state%CenterOfSomething/r + else + axis%normal = [1.0d0,0.0d0,0.0d0] + end if + axis%distance = r + + r = 0.0d0 + do k = 1,DIMENSION + center(k) = (state%Atoms(i)%x(k)+state%Atoms(j)%x(k))/2.0d0-support(k) + r = r+center(k)*center(k) + end do + r = sqrt(r) + + if (r <= state%TolerancePrimary) then + ! C2 is underdefined + if (state%MolecularPlaneExists) then + axis%direction = state%MolecularPlane%normal + else + do k = 1,DIMENSION + center(k) = state%Atoms(i)%x(k)-state%Atoms(j)%x(k) + end do + if (abs(center(3))+abs(center(2)) > state%ToleranceSame) then + axis%direction = [0.0d0,center(3),-center(2)] + else + axis%direction = [-center(3),0.0d0,center(1)] + end if + r = sqrt(sum(axis%direction**2)) + axis%direction = axis%direction/r + end if + else + axis%direction = center/r + end if + + if (refine_symmetry_element(state,axis,.true.) < 0) then + call destroy_symmetry_element(axis) + return + end if + + success = .true. + end subroutine init_c2_axis + !> Initialize higher-order axis - subroutine init_higher_axis(ia,ib,ic,axis,success) + subroutine init_higher_axis(state,ia,ib,ic,axis,success) + type(symmetry_state_t),intent(inout) :: state integer,intent(in) :: ia,ib,ic type(symmetry_element),intent(out) :: axis logical,intent(out) :: success @@ -1161,20 +1177,20 @@ subroutine init_higher_axis(ia,ib,ic,axis,success) integer :: i success = .false. - StatTotal = StatTotal+1 + state%StatTotal = state%StatTotal+1 do i = 1,DIMENSION - a(i) = Atoms(ia)%x(i)-CenterOfSomething(i) - b(i) = Atoms(ib)%x(i)-CenterOfSomething(i) - c(i) = Atoms(ic)%x(i)-CenterOfSomething(i) + a(i) = state%Atoms(ia)%x(i)-state%CenterOfSomething(i) + b(i) = state%Atoms(ib)%x(i)-state%CenterOfSomething(i) + c(i) = state%Atoms(ic)%x(i)-state%CenterOfSomething(i) end do - call init_axis_parameters(a,b,c,axis,success) + call init_axis_parameters(state,a,b,c,axis,success) if (.not.success) return axis%transform_type = 3 ! rotate - if (refine_symmetry_element(axis,.true.) < 0) then + if (refine_symmetry_element(state,axis,.true.) < 0) then call destroy_symmetry_element(axis) success = .false. return @@ -1184,7 +1200,8 @@ subroutine init_higher_axis(ia,ib,ic,axis,success) end subroutine init_higher_axis !> Initialize improper axis - subroutine init_improper_axis(ia,ib,ic,axis,success) + subroutine init_improper_axis(state,ia,ib,ic,axis,success) + type(symmetry_state_t),intent(inout) :: state integer,intent(in) :: ia,ib,ic type(symmetry_element),intent(out) :: axis logical,intent(out) :: success @@ -1193,12 +1210,12 @@ subroutine init_improper_axis(ia,ib,ic,axis,success) integer :: i success = .false. - StatTotal = StatTotal+1 + state%StatTotal = state%StatTotal+1 do i = 1,DIMENSION - a(i) = Atoms(ia)%x(i)-CenterOfSomething(i) - b(i) = Atoms(ib)%x(i)-CenterOfSomething(i) - c(i) = Atoms(ic)%x(i)-CenterOfSomething(i) + a(i) = state%Atoms(ia)%x(i)-state%CenterOfSomething(i) + b(i) = state%Atoms(ib)%x(i)-state%CenterOfSomething(i) + c(i) = state%Atoms(ic)%x(i)-state%CenterOfSomething(i) end do r = 0.0d0 @@ -1208,8 +1225,8 @@ subroutine init_improper_axis(ia,ib,ic,axis,success) end do r = sqrt(r) - if (r <= ToleranceSame) then - StatEarly = StatEarly+1 + if (r <= state%ToleranceSame) then + state%StatEarly = state%StatEarly+1 return end if @@ -1217,12 +1234,12 @@ subroutine init_improper_axis(ia,ib,ic,axis,success) r = dot_product(centerpoint,b) b = 2.0d0*r*centerpoint-b - call init_axis_parameters(a,b,c,axis,success) + call init_axis_parameters(state,a,b,c,axis,success) if (.not.success) return axis%transform_type = 4 ! rotate_reflect - if (refine_symmetry_element(axis,.true.) < 0) then + if (refine_symmetry_element(state,axis,.true.) < 0) then call destroy_symmetry_element(axis) success = .false. return @@ -1232,182 +1249,191 @@ subroutine init_improper_axis(ia,ib,ic,axis,success) end subroutine init_improper_axis !> Find center of something (centroid) - subroutine find_center_of_something() + subroutine find_center_of_something(state) + type(symmetry_state_t),intent(inout) :: state integer :: i,j real(wp) :: coord_sum(DIMENSION),r coord_sum = 0.0d0 - do i = 1,AtomsCount - coord_sum = coord_sum+Atoms(i)%x + do i = 1,state%AtomsCount + coord_sum = coord_sum+state%Atoms(i)%x end do - CenterOfSomething = coord_sum/dble(AtomsCount) + state%CenterOfSomething = coord_sum/dble(state%AtomsCount) - if (allocated(DistanceFromCenter)) deallocate (DistanceFromCenter) - allocate (DistanceFromCenter(AtomsCount)) + if (allocated(state%DistanceFromCenter)) deallocate (state%DistanceFromCenter) + allocate (state%DistanceFromCenter(state%AtomsCount)) - do i = 1,AtomsCount + do i = 1,state%AtomsCount r = 0.0d0 do j = 1,DIMENSION - r = r+pow2(Atoms(i)%x(j)-CenterOfSomething(j)) + r = r+pow2(state%Atoms(i)%x(j)-state%CenterOfSomething(j)) end do - DistanceFromCenter(i) = r + state%DistanceFromCenter(i) = r end do end subroutine find_center_of_something !> Add plane to planes array - subroutine add_plane(plane) + subroutine add_plane(state,plane) + type(symmetry_state_t),intent(inout) :: state type(symmetry_element),intent(in) :: plane type(symmetry_element),allocatable :: temp(:) - PlanesCount = PlanesCount+1 - if (allocated(Planes)) then - allocate (temp(PlanesCount)) - temp(1:PlanesCount-1) = Planes - temp(PlanesCount) = plane - call move_alloc(temp,Planes) + state%PlanesCount = state%PlanesCount+1 + if (allocated(state%Planes)) then + allocate (temp(state%PlanesCount)) + temp(1:state%PlanesCount-1) = state%Planes + temp(state%PlanesCount) = plane + call move_alloc(temp,state%Planes) else - allocate (Planes(1)) - Planes(1) = plane + allocate (state%Planes(1)) + state%Planes(1) = plane end if end subroutine add_plane !> Add normal axis to array - subroutine add_normal_axis(axis) + subroutine add_normal_axis(state,axis) + type(symmetry_state_t),intent(inout) :: state type(symmetry_element),intent(in) :: axis type(symmetry_element),allocatable :: temp(:) - NormalAxesCount = NormalAxesCount+1 - if (allocated(NormalAxes)) then - allocate (temp(NormalAxesCount)) - temp(1:NormalAxesCount-1) = NormalAxes - temp(NormalAxesCount) = axis - call move_alloc(temp,NormalAxes) + state%NormalAxesCount = state%NormalAxesCount+1 + if (allocated(state%NormalAxes)) then + allocate (temp(state%NormalAxesCount)) + temp(1:state%NormalAxesCount-1) = state%NormalAxes + temp(state%NormalAxesCount) = axis + call move_alloc(temp,state%NormalAxes) else - allocate (NormalAxes(1)) - NormalAxes(1) = axis + allocate (state%NormalAxes(1)) + state%NormalAxes(1) = axis end if end subroutine add_normal_axis !> Add improper axis to array - subroutine add_improper_axis(axis) + subroutine add_improper_axis(state,axis) + type(symmetry_state_t),intent(inout) :: state type(symmetry_element),intent(in) :: axis type(symmetry_element),allocatable :: temp(:) - ImproperAxesCount = ImproperAxesCount+1 - if (allocated(ImproperAxes)) then - allocate (temp(ImproperAxesCount)) - temp(1:ImproperAxesCount-1) = ImproperAxes - temp(ImproperAxesCount) = axis - call move_alloc(temp,ImproperAxes) + state%ImproperAxesCount = state%ImproperAxesCount+1 + if (allocated(state%ImproperAxes)) then + allocate (temp(state%ImproperAxesCount)) + temp(1:state%ImproperAxesCount-1) = state%ImproperAxes + temp(state%ImproperAxesCount) = axis + call move_alloc(temp,state%ImproperAxes) else - allocate (ImproperAxes(1)) - ImproperAxes(1) = axis + allocate (state%ImproperAxes(1)) + state%ImproperAxes(1) = axis end if end subroutine add_improper_axis !> Find planes of symmetry - subroutine find_planes() + subroutine find_planes(state) + type(symmetry_state_t),intent(inout) :: state integer :: i,j type(symmetry_element) :: plane logical :: success - call init_ultimate_plane(plane,success) + call init_ultimate_plane(state,plane,success) if (success) then - if (.not.allocated(MolecularPlane)) allocate (MolecularPlane) - MolecularPlane = plane - MolecularPlaneExists = .true. - call add_plane(plane) + state%MolecularPlane = plane + state%MolecularPlaneExists = .true. + call add_plane(state,plane) end if - do i = 2,AtomsCount + do i = 2,state%AtomsCount do j = 1,i-1 - if (Atoms(i)%atom_type /= Atoms(j)%atom_type) cycle + if (state%Atoms(i)%atom_type /= state%Atoms(j)%atom_type) cycle - call init_mirror_plane(i,j,plane,success) - if (success) call add_plane(plane) + call init_mirror_plane(state,i,j,plane,success) + if (success) call add_plane(state,plane) end do end do end subroutine find_planes !> Find inversion centers - subroutine find_inversion_centers() + subroutine find_inversion_centers(state) + type(symmetry_state_t),intent(inout) :: state type(symmetry_element) :: center logical :: success - call init_inversion_center(center,success) + call init_inversion_center(state,center,success) if (success) then - InversionCentersCount = 1 - allocate (InversionCenters(1)) - InversionCenters(1) = center + state%InversionCentersCount = 1 + allocate (state%InversionCenters(1)) + state%InversionCenters(1) = center end if end subroutine find_inversion_centers !> Find infinity axis - subroutine find_infinity_axis() + subroutine find_infinity_axis(state) + type(symmetry_state_t),intent(inout) :: state type(symmetry_element) :: axis logical :: success - call init_ultimate_axis(axis,success) - if (success) call add_normal_axis(axis) + call init_ultimate_axis(state,axis,success) + if (success) call add_normal_axis(state,axis) end subroutine find_infinity_axis !> Find C2 axes - subroutine find_c2_axes() + subroutine find_c2_axes(state) + type(symmetry_state_t),intent(inout) :: state integer :: i,j,k,l,m real(wp) :: center(DIMENSION),r real(wp),allocatable :: distances(:) type(symmetry_element) :: axis logical :: success - allocate (distances(AtomsCount)) + allocate (distances(state%AtomsCount)) - do i = 2,AtomsCount + do i = 2,state%AtomsCount do j = 1,i-1 - if (Atoms(i)%atom_type /= Atoms(j)%atom_type) cycle - if (abs(DistanceFromCenter(i)-DistanceFromCenter(j)) > TolerancePrimary) cycle + if (state%Atoms(i)%atom_type /= state%Atoms(j)%atom_type) cycle + if (abs(state%DistanceFromCenter(i)-state%DistanceFromCenter(j)) > & + state%TolerancePrimary) cycle ! Try using CenterOfSomething r = 0.0d0 do k = 1,DIMENSION - center(k) = (Atoms(i)%x(k)+Atoms(j)%x(k))/2.0d0 - r = r+pow2(center(k)-CenterOfSomething(k)) + center(k) = (state%Atoms(i)%x(k)+state%Atoms(j)%x(k))/2.0d0 + r = r+pow2(center(k)-state%CenterOfSomething(k)) end do r = sqrt(r) - if (r > 5.0d0*TolerancePrimary) then - call init_c2_axis(i,j,CenterOfSomething,axis,success) - if (success) call add_normal_axis(axis) + if (r > 5.0d0*state%TolerancePrimary) then + call init_c2_axis(state,i,j,state%CenterOfSomething,axis,success) + if (success) call add_normal_axis(state,axis) cycle end if ! Try through atoms - do k = 1,AtomsCount - call init_c2_axis(i,j,Atoms(k)%x,axis,success) - if (success) call add_normal_axis(axis) + do k = 1,state%AtomsCount + call init_c2_axis(state,i,j,state%Atoms(k)%x,axis,success) + if (success) call add_normal_axis(state,axis) end do ! Calculate distances for prescreening - do k = 1,AtomsCount + do k = 1,state%AtomsCount r = 0.0d0 do l = 1,DIMENSION - r = r+pow2(Atoms(k)%x(l)-center(l)) + r = r+pow2(state%Atoms(k)%x(l)-center(l)) end do distances(k) = sqrt(r) end do ! Try through midpoints of atom pairs - do k = 1,AtomsCount - do l = 1,AtomsCount - if (Atoms(k)%atom_type /= Atoms(l)%atom_type) cycle - if (abs(DistanceFromCenter(k)-DistanceFromCenter(l)) > TolerancePrimary.or. & - abs(distances(k)-distances(l)) > TolerancePrimary) cycle + do k = 1,state%AtomsCount + do l = 1,state%AtomsCount + if (state%Atoms(k)%atom_type /= state%Atoms(l)%atom_type) cycle + if (abs(state%DistanceFromCenter(k)-state%DistanceFromCenter(l)) > & + state%TolerancePrimary.or. & + abs(distances(k)-distances(l)) > state%TolerancePrimary) cycle do m = 1,DIMENSION - center(m) = (Atoms(k)%x(m)+Atoms(l)%x(m))/2.0d0 + center(m) = (state%Atoms(k)%x(m)+state%Atoms(l)%x(m))/2.0d0 end do - call init_c2_axis(i,j,center,axis,success) - if (success) call add_normal_axis(axis) + call init_c2_axis(state,i,j,center,axis,success) + if (success) call add_normal_axis(state,axis) end do end do end do @@ -1417,53 +1443,59 @@ subroutine find_c2_axes() end subroutine find_c2_axes !> Find higher-order axes - subroutine find_higher_axes() + subroutine find_higher_axes(state) + type(symmetry_state_t),intent(inout) :: state integer :: i,j,k type(symmetry_element) :: axis logical :: success - do i = 1,AtomsCount - do j = i+1,AtomsCount - if (Atoms(i)%atom_type /= Atoms(j)%atom_type) cycle - if (abs(DistanceFromCenter(i)-DistanceFromCenter(j)) > TolerancePrimary) cycle - - do k = 1,AtomsCount - if (Atoms(i)%atom_type /= Atoms(k)%atom_type) cycle - if (abs(DistanceFromCenter(i)-DistanceFromCenter(k)) > TolerancePrimary.or. & - abs(DistanceFromCenter(j)-DistanceFromCenter(k)) > TolerancePrimary) cycle - - call init_higher_axis(i,j,k,axis,success) - if (success) call add_normal_axis(axis) + do i = 1,state%AtomsCount + do j = i+1,state%AtomsCount + if (state%Atoms(i)%atom_type /= state%Atoms(j)%atom_type) cycle + if (abs(state%DistanceFromCenter(i)-state%DistanceFromCenter(j)) > & + state%TolerancePrimary) cycle + + do k = 1,state%AtomsCount + if (state%Atoms(i)%atom_type /= state%Atoms(k)%atom_type) cycle + if (abs(state%DistanceFromCenter(i)-state%DistanceFromCenter(k)) > & + state%TolerancePrimary.or. & + abs(state%DistanceFromCenter(j)-state%DistanceFromCenter(k)) > & + state%TolerancePrimary) cycle + + call init_higher_axis(state,i,j,k,axis,success) + if (success) call add_normal_axis(state,axis) end do end do end do end subroutine find_higher_axes !> Find improper axes - subroutine find_improper_axes() + subroutine find_improper_axes(state) + type(symmetry_state_t),intent(inout) :: state integer :: i,j,k type(symmetry_element) :: axis logical :: success - do i = 1,AtomsCount - do j = i+1,AtomsCount - do k = 1,AtomsCount - call init_improper_axis(i,j,k,axis,success) - if (success) call add_improper_axis(axis) + do i = 1,state%AtomsCount + do j = i+1,state%AtomsCount + do k = 1,state%AtomsCount + call init_improper_axis(state,i,j,k,axis,success) + if (success) call add_improper_axis(state,axis) end do end do end do end subroutine find_improper_axes !> Find all symmetry elements - subroutine find_symmetry_elements() - call find_center_of_something() - call find_inversion_centers() - call find_planes() - call find_infinity_axis() - call find_c2_axes() - call find_higher_axes() - call find_improper_axes() + subroutine find_symmetry_elements(state) + type(symmetry_state_t),intent(inout) :: state + call find_center_of_something(state) + call find_inversion_centers(state) + call find_planes(state) + call find_infinity_axis(state) + call find_c2_axes(state) + call find_higher_axes(state) + call find_improper_axes(state) end subroutine find_symmetry_elements !> Compare axes for sorting @@ -1490,124 +1522,133 @@ function compare_axes(a,b) result(cmp) end function compare_axes !> Sort symmetry elements (simple bubble sort) - subroutine sort_symmetry_elements() + subroutine sort_symmetry_elements(state) + type(symmetry_state_t),intent(inout) :: state integer :: i,j type(symmetry_element) :: temp ! Sort planes - do i = 1,PlanesCount-1 - do j = i+1,PlanesCount - if (compare_axes(Planes(i),Planes(j)) < 0) then - temp = Planes(i) - Planes(i) = Planes(j) - Planes(j) = temp + do i = 1,state%PlanesCount-1 + do j = i+1,state%PlanesCount + if (compare_axes(state%Planes(i),state%Planes(j)) < 0) then + temp = state%Planes(i) + state%Planes(i) = state%Planes(j) + state%Planes(j) = temp end if end do end do ! Sort normal axes - do i = 1,NormalAxesCount-1 - do j = i+1,NormalAxesCount - if (compare_axes(NormalAxes(i),NormalAxes(j)) < 0) then - temp = NormalAxes(i) - NormalAxes(i) = NormalAxes(j) - NormalAxes(j) = temp + do i = 1,state%NormalAxesCount-1 + do j = i+1,state%NormalAxesCount + if (compare_axes(state%NormalAxes(i),state%NormalAxes(j)) < 0) then + temp = state%NormalAxes(i) + state%NormalAxes(i) = state%NormalAxes(j) + state%NormalAxes(j) = temp end if end do end do ! Sort improper axes - do i = 1,ImproperAxesCount-1 - do j = i+1,ImproperAxesCount - if (compare_axes(ImproperAxes(i),ImproperAxes(j)) < 0) then - temp = ImproperAxes(i) - ImproperAxes(i) = ImproperAxes(j) - ImproperAxes(j) = temp + do i = 1,state%ImproperAxesCount-1 + do j = i+1,state%ImproperAxesCount + if (compare_axes(state%ImproperAxes(i),state%ImproperAxes(j)) < 0) then + temp = state%ImproperAxes(i) + state%ImproperAxes(i) = state%ImproperAxes(j) + state%ImproperAxes(j) = temp end if end do end do end subroutine sort_symmetry_elements !> Summarize symmetry elements - subroutine summarize_symmetry_elements() + subroutine summarize_symmetry_elements(state) + type(symmetry_state_t),intent(inout) :: state integer :: i - if (allocated(NormalAxesCounts)) deallocate (NormalAxesCounts) - if (allocated(ImproperAxesCounts)) deallocate (ImproperAxesCounts) + if (allocated(state%NormalAxesCounts)) deallocate (state%NormalAxesCounts) + if (allocated(state%ImproperAxesCounts)) deallocate (state%ImproperAxesCounts) - allocate (NormalAxesCounts(0:MaxAxisOrder)) - allocate (ImproperAxesCounts(0:MaxAxisOrder)) + allocate (state%NormalAxesCounts(0:state%MaxAxisOrder)) + allocate (state%ImproperAxesCounts(0:state%MaxAxisOrder)) - NormalAxesCounts = 0 - ImproperAxesCounts = 0 + state%NormalAxesCounts = 0 + state%ImproperAxesCounts = 0 - do i = 1,NormalAxesCount - NormalAxesCounts(NormalAxes(i)%order) = NormalAxesCounts(NormalAxes(i)%order)+1 + do i = 1,state%NormalAxesCount + state%NormalAxesCounts(state%NormalAxes(i)%order) = & + state%NormalAxesCounts(state%NormalAxes(i)%order)+1 end do - do i = 1,ImproperAxesCount - ImproperAxesCounts(ImproperAxes(i)%order) = ImproperAxesCounts(ImproperAxes(i)%order)+1 + do i = 1,state%ImproperAxesCount + state%ImproperAxesCounts(state%ImproperAxes(i)%order) = & + state%ImproperAxesCounts(state%ImproperAxes(i)%order)+1 end do end subroutine summarize_symmetry_elements !> Report symmetry elements brief - subroutine report_symmetry_elements_brief() + subroutine report_symmetry_elements_brief(state) + type(symmetry_state_t),intent(inout) :: state integer :: i character(len=32) :: buf - SymmetryCode = "" + state%SymmetryCode = "" - if (PlanesCount+NormalAxesCount+ImproperAxesCount+InversionCentersCount > 0) then - if (InversionCentersCount > 0) SymmetryCode = trim(SymmetryCode)//"(i) " + if (state%PlanesCount+state%NormalAxesCount+state%ImproperAxesCount+ & + state%InversionCentersCount > 0) then + if (state%InversionCentersCount > 0) & + state%SymmetryCode = trim(state%SymmetryCode)//"(i) " - if (NormalAxesCounts(0) == 1) then - SymmetryCode = trim(SymmetryCode)//"(Cinf) " - else if (NormalAxesCounts(0) > 1) then - write (buf,'(I0,A)') NormalAxesCounts(0),"*(Cinf) " - SymmetryCode = trim(SymmetryCode)//trim(buf) + if (state%NormalAxesCounts(0) == 1) then + state%SymmetryCode = trim(state%SymmetryCode)//"(Cinf) " + else if (state%NormalAxesCounts(0) > 1) then + write (buf,'(I0,A)') state%NormalAxesCounts(0),"*(Cinf) " + state%SymmetryCode = trim(state%SymmetryCode)//trim(buf) end if - do i = MaxAxisOrder,2,-1 - if (NormalAxesCounts(i) == 1) then + do i = state%MaxAxisOrder,2,-1 + if (state%NormalAxesCounts(i) == 1) then write (buf,'(A,I0,A)') "(C",i,") " - SymmetryCode = trim(SymmetryCode)//trim(buf) - else if (NormalAxesCounts(i) > 1) then - write (buf,'(I0,A,I0,A)') NormalAxesCounts(i),"*(C",i,") " - SymmetryCode = trim(SymmetryCode)//trim(buf) + state%SymmetryCode = trim(state%SymmetryCode)//trim(buf) + else if (state%NormalAxesCounts(i) > 1) then + write (buf,'(I0,A,I0,A)') state%NormalAxesCounts(i),"*(C",i,") " + state%SymmetryCode = trim(state%SymmetryCode)//trim(buf) end if end do - do i = MaxAxisOrder,2,-1 - if (ImproperAxesCounts(i) == 1) then + do i = state%MaxAxisOrder,2,-1 + if (state%ImproperAxesCounts(i) == 1) then write (buf,'(A,I0,A)') "(S",i,") " - SymmetryCode = trim(SymmetryCode)//trim(buf) - else if (ImproperAxesCounts(i) > 1) then - write (buf,'(I0,A,I0,A)') ImproperAxesCounts(i),"*(S",i,") " - SymmetryCode = trim(SymmetryCode)//trim(buf) + state%SymmetryCode = trim(state%SymmetryCode)//trim(buf) + else if (state%ImproperAxesCounts(i) > 1) then + write (buf,'(I0,A,I0,A)') state%ImproperAxesCounts(i),"*(S",i,") " + state%SymmetryCode = trim(state%SymmetryCode)//trim(buf) end if end do - if (PlanesCount == 1) then - SymmetryCode = trim(SymmetryCode)//"(sigma) " - else if (PlanesCount > 1) then - write (buf,'(I0,A)') PlanesCount,"*(sigma) " - SymmetryCode = trim(SymmetryCode)//trim(buf) + if (state%PlanesCount == 1) then + state%SymmetryCode = trim(state%SymmetryCode)//"(sigma) " + else if (state%PlanesCount > 1) then + write (buf,'(I0,A)') state%PlanesCount,"*(sigma) " + state%SymmetryCode = trim(state%SymmetryCode)//trim(buf) end if end if end subroutine report_symmetry_elements_brief !> Report highest rotation axis only - subroutine report_symmetry_elements_brief_conly() + subroutine report_symmetry_elements_brief_conly(state) + type(symmetry_state_t),intent(inout) :: state integer :: i character(len=8) :: buf - MaxRotAxis = "" + state%MaxRotAxis = "" - if (PlanesCount+NormalAxesCount+ImproperAxesCount+InversionCentersCount > 0) then - do i = MaxAxisOrder,2,-1 - if (NormalAxesCounts(i) >= 1) then + if (state%PlanesCount+state%NormalAxesCount+state%ImproperAxesCount+ & + state%InversionCentersCount > 0) then + do i = state%MaxAxisOrder,2,-1 + if (state%NormalAxesCounts(i) >= 1) then write (buf,'(A,I0)') "C",i - MaxRotAxis = trim(buf) + state%MaxRotAxis = trim(buf) return end if end do @@ -1615,18 +1656,19 @@ subroutine report_symmetry_elements_brief_conly() end subroutine report_symmetry_elements_brief_conly !> Identify point group - function identify_point_group() result(last_matching) + function identify_point_group(state) result(last_matching) + type(symmetry_state_t),intent(inout) :: state integer :: last_matching integer :: i,matching_count - call init_point_groups() + call init_point_groups(state) last_matching = -1 matching_count = 0 do i = 1,PointGroupsCount - if (len_trim(PointGroups(i)%group_name) == 0) cycle - if (trim(SymmetryCode) == trim(PointGroups(i)%symmetry_code)) then + if (len_trim(state%PointGroups(i)%group_name) == 0) cycle + if (trim(state%SymmetryCode) == trim(state%PointGroups(i)%symmetry_code)) then last_matching = i matching_count = matching_count+1 end if @@ -1639,90 +1681,60 @@ function identify_point_group() result(last_matching) end if end function identify_point_group - !> Reset module state - subroutine reset_state() - PlanesCount = 0 - InversionCentersCount = 0 - NormalAxesCount = 0 - ImproperAxesCount = 0 - BadOptimization = 0 - SymmetryCode = "" - MaxRotAxis = "" - MolecularPlaneExists = .false. - - StatTotal = 0 - StatEarly = 0 - StatPairs = 0 - StatDups = 0 - StatOrder = 0 - StatOpt = 0 - StatAccept = 0 - - if (allocated(Planes)) deallocate (Planes) - if (allocated(MolecularPlane)) deallocate (MolecularPlane) - if (allocated(InversionCenters)) deallocate (InversionCenters) - if (allocated(NormalAxes)) deallocate (NormalAxes) - if (allocated(ImproperAxes)) deallocate (ImproperAxes) - if (allocated(NormalAxesCounts)) deallocate (NormalAxesCounts) - if (allocated(ImproperAxesCounts)) deallocate (ImproperAxesCounts) - if (allocated(DistanceFromCenter)) deallocate (DistanceFromCenter) - if (allocated(Atoms)) deallocate (Atoms) - end subroutine reset_state - !> Main entry point: determine Schoenflies symbol subroutine schoenflies(natoms,attype,coord,symbol,paramar) - integer,intent(in) :: natoms - integer,intent(in) :: attype(natoms) + integer,intent(in) :: natoms + integer,intent(in) :: attype(natoms) real(wp),intent(in) :: coord(3,natoms) character(len=*),intent(out) :: symbol real(wp),intent(in),optional :: paramar(11) + type(symmetry_state_t) :: state integer :: last_pg,i - ! Reset state - call reset_state() + call init_symmetry_state(state) ! Set parameters if provided if (present(paramar)) then - verbose = nint(paramar(1)) - MaxAxisOrder = nint(paramar(2)) - MaxOptCycles = nint(paramar(3)) - ToleranceSame = paramar(4) - TolerancePrimary = paramar(5) - ToleranceFinal = paramar(6) - MaxOptStep = paramar(7) - MinOptStep = paramar(8) - GradientStep = paramar(9) - OptChangeThreshold = paramar(10) - OptChangeHits = nint(paramar(11)) + state%verbose = nint(paramar(1)) + state%MaxAxisOrder = nint(paramar(2)) + state%MaxOptCycles = nint(paramar(3)) + state%ToleranceSame = paramar(4) + state%TolerancePrimary = paramar(5) + state%ToleranceFinal = paramar(6) + state%MaxOptStep = paramar(7) + state%MinOptStep = paramar(8) + state%GradientStep = paramar(9) + state%OptChangeThreshold = paramar(10) + state%OptChangeHits = nint(paramar(11)) end if ! Set up atoms - AtomsCount = natoms - allocate (Atoms(AtomsCount)) - - do i = 1,AtomsCount - Atoms(i)%atom_type = attype(i) - Atoms(i)%x(1) = coord(1,i) - Atoms(i)%x(2) = coord(2,i) - Atoms(i)%x(3) = coord(3,i) + state%AtomsCount = natoms + allocate (state%Atoms(state%AtomsCount)) + + do i = 1,state%AtomsCount + state%Atoms(i)%atom_type = attype(i) + state%Atoms(i)%x(1) = coord(1,i) + state%Atoms(i)%x(2) = coord(2,i) + state%Atoms(i)%x(3) = coord(3,i) end do ! Find and analyze symmetry - call find_symmetry_elements() - call sort_symmetry_elements() - call summarize_symmetry_elements() - call report_symmetry_elements_brief() + call find_symmetry_elements(state) + call sort_symmetry_elements(state) + call summarize_symmetry_elements(state) + call report_symmetry_elements_brief(state) - last_pg = identify_point_group() + last_pg = identify_point_group(state) if (last_pg >= 1) then - symbol = trim(PointGroups(last_pg)%group_name) + symbol = trim(state%PointGroups(last_pg)%group_name) else - call report_symmetry_elements_brief_conly() - if (len_trim(MaxRotAxis) == 0) then + call report_symmetry_elements_brief_conly(state) + if (len_trim(state%MaxRotAxis) == 0) then symbol = "C1" else - symbol = trim(MaxRotAxis) + symbol = trim(state%MaxRotAxis) end if end if end subroutine schoenflies From 42bd17aec48d0b7568f4959d862494e6d2a6bed6 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 18 Mar 2026 17:04:03 +0100 Subject: [PATCH 240/374] Point groups defined as parameter rather then repeated setup --- src/confparse.f90 | 2 +- src/symmetry_i.f90 | 177 +++++++++++++++++++++------------------------ 2 files changed, 84 insertions(+), 95 deletions(-) diff --git a/src/confparse.f90 b/src/confparse.f90 index 5512c93e..c1d202b6 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -783,7 +783,7 @@ subroutine parseflags(env,arg,nra) processedarg(i+1) = .true. call ensemble_analsym(trim(ctmp),.true.) end if - stop + call exit(0) case ('-exlig','-exligand','-exchligand') processedarg(i) = .true. diff --git a/src/symmetry_i.f90 b/src/symmetry_i.f90 index 8dbfe98e..a10b1270 100644 --- a/src/symmetry_i.f90 +++ b/src/symmetry_i.f90 @@ -50,6 +50,69 @@ module symmetry_i !> Number of point groups in the lookup table integer,parameter :: PointGroupsCount = 60 + !> Compile-time point group lookup table + type(point_group),parameter :: PointGroups(PointGroupsCount) = [ & + & point_group("C1",""), & + & point_group("Cs","(sigma) "), & + & point_group("Ci","(i) "), & + & point_group("C2","(C2) "), & + & point_group("C3","(C3) "), & + & point_group("C4","(C4) (C2) "), & + & point_group("C5","(C5) "), & + & point_group("C6","(C6) (C3) (C2) "), & + & point_group("C7","(C7) "), & + & point_group("C8","(C8) (C4) (C2) "), & + & point_group("D2","3*(C2) "), & + & point_group("D3","(C3) 3*(C2) "), & + & point_group("D4","(C4) 5*(C2) "), & + & point_group("D5","(C5) 5*(C2) "), & + & point_group("D6","(C6) (C3) 7*(C2) "), & + & point_group("D7","(C7) 7*(C2) "), & + & point_group("D8","(C8) (C4) 9*(C2) "), & + & point_group("C2v","(C2) 2*(sigma) "), & + & point_group("C3v","(C3) 3*(sigma) "), & + & point_group("C4v","(C4) (C2) 4*(sigma) "), & + & point_group("C5v","(C5) 5*(sigma) "), & + & point_group("C6v","(C6) (C3) (C2) 6*(sigma) "), & + & point_group("C7v","(C7) 7*(sigma) "), & + & point_group("C8v","(C8) (C4) (C2) 8*(sigma) "), & + & point_group("C2h","(i) (C2) (sigma) "), & + & point_group("C3h","(C3) (S3) (sigma) "), & + & point_group("C4h","(i) (C4) (C2) (S4) (sigma) "), & + & point_group("C5h","(C5) (S5) (sigma) "), & + & point_group("C6h","(i) (C6) (C3) (C2) (S6) (S3) (sigma) "), & + & point_group("C7h","(C7) (S7) (sigma) "), & + & point_group("C8h","(i) (C8) (C4) (C2) (S8) (S4) (sigma) "), & + & point_group("D2h","(i) 3*(C2) 3*(sigma) "), & + & point_group("D3h","(C3) 3*(C2) (S3) 4*(sigma) "), & + & point_group("D4h","(i) (C4) 5*(C2) (S4) 5*(sigma) "), & + & point_group("D5h","(C5) 5*(C2) (S5) 6*(sigma) "), & + & point_group("D6h","(i) (C6) (C3) 7*(C2) (S6) (S3) 7*(sigma) "), & + & point_group("D7h","(C7) 7*(C2) (S7) 8*(sigma) "), & + & point_group("D8h","(i) (C8) (C4) 9*(C2) (S8) (S4) 9*(sigma) "), & + & point_group("D2d","3*(C2) (S4) 2*(sigma) "), & + & point_group("D3d","(i) (C3) 3*(C2) (S6) 3*(sigma) "), & + & point_group("D4d","(C4) 5*(C2) (S8) 4*(sigma) "), & + & point_group("D5d","(i) (C5) 5*(C2) (S10) 5*(sigma) "), & + & point_group("D6d","(C6) (C3) 7*(C2) (S12) (S4) 6*(sigma) "), & + & point_group("D7d","(i) (C7) 7*(C2) (S14) 7*(sigma) "), & + & point_group("D8d","(C8) (C4) 9*(C2) (S16) 8*(sigma) "), & + & point_group("S4","(C2) (S4) "), & + & point_group("S6","(i) (C3) (S6) "), & + & point_group("S8","(C4) (C2) (S8) "), & + & point_group("T","4*(C3) 3*(C2) "), & + & point_group("Th","(i) 4*(C3) 3*(C2) 4*(S6) 3*(sigma) "), & + & point_group("Td","4*(C3) 3*(C2) 3*(S4) 6*(sigma) "), & + & point_group("O","3*(C4) 4*(C3) 9*(C2) "), & + & point_group("Oh","(i) 3*(C4) 4*(C3) 9*(C2) 4*(S6) 3*(S4) 9*(sigma) "), & + & point_group("Cinfv","(Cinf) (sigma) "), & + & point_group("Dinfh","(i) (Cinf) (C2) 2*(sigma) "), & + & point_group("I","6*(C5) 10*(C3) 15*(C2) "), & + & point_group("Ih","(i) 6*(C5) 10*(C3) 15*(C2) 6*(S10) 10*(S6) 15*(sigma) "), & + & point_group("Kh","(i) (Cinf) (sigma) "), & + & point_group("",""), & + & point_group("","")] + !> All symmetry-analysis state collected in one derived type type,public :: symmetry_state_t ! Tolerance / control @@ -93,9 +156,6 @@ module symmetry_i integer(8) :: StatOrder = 0 integer(8) :: StatOpt = 0 integer(8) :: StatAccept = 0 - ! Point groups lookup table - type(point_group) :: PointGroups(PointGroupsCount) - logical :: PointGroupsInitialized = .false. end type symmetry_state_t ! ══════════════════════════════════════════════════════════════════════════════ @@ -111,75 +171,6 @@ subroutine init_symmetry_state(state) call destroy_symmetry_element(state%MolecularPlane) end subroutine init_symmetry_state - !> Initialize point groups table - subroutine init_point_groups(state) - type(symmetry_state_t),intent(inout) :: state - if (state%PointGroupsInitialized) return - - state%PointGroups(1) = point_group("C1","") - state%PointGroups(2) = point_group("Cs","(sigma) ") - state%PointGroups(3) = point_group("Ci","(i) ") - state%PointGroups(4) = point_group("C2","(C2) ") - state%PointGroups(5) = point_group("C3","(C3) ") - state%PointGroups(6) = point_group("C4","(C4) (C2) ") - state%PointGroups(7) = point_group("C5","(C5) ") - state%PointGroups(8) = point_group("C6","(C6) (C3) (C2) ") - state%PointGroups(9) = point_group("C7","(C7) ") - state%PointGroups(10) = point_group("C8","(C8) (C4) (C2) ") - state%PointGroups(11) = point_group("D2","3*(C2) ") - state%PointGroups(12) = point_group("D3","(C3) 3*(C2) ") - state%PointGroups(13) = point_group("D4","(C4) 5*(C2) ") - state%PointGroups(14) = point_group("D5","(C5) 5*(C2) ") - state%PointGroups(15) = point_group("D6","(C6) (C3) 7*(C2) ") - state%PointGroups(16) = point_group("D7","(C7) 7*(C2) ") - state%PointGroups(17) = point_group("D8","(C8) (C4) 9*(C2) ") - state%PointGroups(18) = point_group("C2v","(C2) 2*(sigma) ") - state%PointGroups(19) = point_group("C3v","(C3) 3*(sigma) ") - state%PointGroups(20) = point_group("C4v","(C4) (C2) 4*(sigma) ") - state%PointGroups(21) = point_group("C5v","(C5) 5*(sigma) ") - state%PointGroups(22) = point_group("C6v","(C6) (C3) (C2) 6*(sigma) ") - state%PointGroups(23) = point_group("C7v","(C7) 7*(sigma) ") - state%PointGroups(24) = point_group("C8v","(C8) (C4) (C2) 8*(sigma) ") - state%PointGroups(25) = point_group("C2h","(i) (C2) (sigma) ") - state%PointGroups(26) = point_group("C3h","(C3) (S3) (sigma) ") - state%PointGroups(27) = point_group("C4h","(i) (C4) (C2) (S4) (sigma) ") - state%PointGroups(28) = point_group("C5h","(C5) (S5) (sigma) ") - state%PointGroups(29) = point_group("C6h","(i) (C6) (C3) (C2) (S6) (S3) (sigma) ") - state%PointGroups(30) = point_group("C7h","(C7) (S7) (sigma) ") - state%PointGroups(31) = point_group("C8h","(i) (C8) (C4) (C2) (S8) (S4) (sigma) ") - state%PointGroups(32) = point_group("D2h","(i) 3*(C2) 3*(sigma) ") - state%PointGroups(33) = point_group("D3h","(C3) 3*(C2) (S3) 4*(sigma) ") - state%PointGroups(34) = point_group("D4h","(i) (C4) 5*(C2) (S4) 5*(sigma) ") - state%PointGroups(35) = point_group("D5h","(C5) 5*(C2) (S5) 6*(sigma) ") - state%PointGroups(36) = point_group("D6h","(i) (C6) (C3) 7*(C2) (S6) (S3) 7*(sigma) ") - state%PointGroups(37) = point_group("D7h","(C7) 7*(C2) (S7) 8*(sigma) ") - state%PointGroups(38) = point_group("D8h","(i) (C8) (C4) 9*(C2) (S8) (S4) 9*(sigma) ") - state%PointGroups(39) = point_group("D2d","3*(C2) (S4) 2*(sigma) ") - state%PointGroups(40) = point_group("D3d","(i) (C3) 3*(C2) (S6) 3*(sigma) ") - state%PointGroups(41) = point_group("D4d","(C4) 5*(C2) (S8) 4*(sigma) ") - state%PointGroups(42) = point_group("D5d","(i) (C5) 5*(C2) (S10) 5*(sigma) ") - state%PointGroups(43) = point_group("D6d","(C6) (C3) 7*(C2) (S12) (S4) 6*(sigma) ") - state%PointGroups(44) = point_group("D7d","(i) (C7) 7*(C2) (S14) 7*(sigma) ") - state%PointGroups(45) = point_group("D8d","(C8) (C4) 9*(C2) (S16) 8*(sigma) ") - state%PointGroups(46) = point_group("S4","(C2) (S4) ") - state%PointGroups(47) = point_group("S6","(i) (C3) (S6) ") - state%PointGroups(48) = point_group("S8","(C4) (C2) (S8) ") - state%PointGroups(49) = point_group("T","4*(C3) 3*(C2) ") - state%PointGroups(50) = point_group("Th","(i) 4*(C3) 3*(C2) 4*(S6) 3*(sigma) ") - state%PointGroups(51) = point_group("Td","4*(C3) 3*(C2) 3*(S4) 6*(sigma) ") - state%PointGroups(52) = point_group("O","3*(C4) 4*(C3) 9*(C2) ") - state%PointGroups(53) = point_group("Oh","(i) 3*(C4) 4*(C3) 9*(C2) 4*(S6) 3*(S4) 9*(sigma) ") - state%PointGroups(54) = point_group("Cinfv","(Cinf) (sigma) ") - state%PointGroups(55) = point_group("Dinfh","(i) (Cinf) (C2) 2*(sigma) ") - state%PointGroups(56) = point_group("I","6*(C5) 10*(C3) 15*(C2) ") - state%PointGroups(57) = point_group("Ih","(i) 6*(C5) 10*(C3) 15*(C2) 6*(S10) 10*(S6) 15*(sigma) ") - state%PointGroups(58) = point_group("Kh","(i) (Cinf) (sigma) ") - state%PointGroups(59) = point_group("","") ! Padding - state%PointGroups(60) = point_group("","") ! Padding - - state%PointGroupsInitialized = .true. - end subroutine init_point_groups - !> Square function pure real(wp) function pow2(x) real(wp),intent(in) :: x @@ -196,12 +187,12 @@ subroutine alloc_symmetry_element(state,elem) do i = 1,state%AtomsCount elem%transform(i) = state%AtomsCount+1 ! Impossible value end do - elem%order = 0 - elem%nparam = 0 - elem%maxdev = 0.0d0 - elem%distance = 0.0d0 - elem%normal = 0.0d0 - elem%direction = 0.0d0 + elem%order = 0 + elem%nparam = 0 + elem%maxdev = 0.0d0 + elem%distance = 0.0d0 + elem%normal = 0.0d0 + elem%direction = 0.0d0 elem%transform_type = 0 end subroutine alloc_symmetry_element @@ -1657,18 +1648,16 @@ end subroutine report_symmetry_elements_brief_conly !> Identify point group function identify_point_group(state) result(last_matching) - type(symmetry_state_t),intent(inout) :: state + type(symmetry_state_t),intent(in) :: state integer :: last_matching integer :: i,matching_count - call init_point_groups(state) - last_matching = -1 matching_count = 0 do i = 1,PointGroupsCount - if (len_trim(state%PointGroups(i)%group_name) == 0) cycle - if (trim(state%SymmetryCode) == trim(state%PointGroups(i)%symmetry_code)) then + if (len_trim(PointGroups(i)%group_name) == 0) cycle + if (trim(state%SymmetryCode) == trim(PointGroups(i)%symmetry_code)) then last_matching = i matching_count = matching_count+1 end if @@ -1695,17 +1684,17 @@ subroutine schoenflies(natoms,attype,coord,symbol,paramar) ! Set parameters if provided if (present(paramar)) then - state%verbose = nint(paramar(1)) - state%MaxAxisOrder = nint(paramar(2)) - state%MaxOptCycles = nint(paramar(3)) - state%ToleranceSame = paramar(4) - state%TolerancePrimary = paramar(5) - state%ToleranceFinal = paramar(6) - state%MaxOptStep = paramar(7) - state%MinOptStep = paramar(8) - state%GradientStep = paramar(9) + state%verbose = nint(paramar(1)) + state%MaxAxisOrder = nint(paramar(2)) + state%MaxOptCycles = nint(paramar(3)) + state%ToleranceSame = paramar(4) + state%TolerancePrimary = paramar(5) + state%ToleranceFinal = paramar(6) + state%MaxOptStep = paramar(7) + state%MinOptStep = paramar(8) + state%GradientStep = paramar(9) state%OptChangeThreshold = paramar(10) - state%OptChangeHits = nint(paramar(11)) + state%OptChangeHits = nint(paramar(11)) end if ! Set up atoms @@ -1728,7 +1717,7 @@ subroutine schoenflies(natoms,attype,coord,symbol,paramar) last_pg = identify_point_group(state) if (last_pg >= 1) then - symbol = trim(state%PointGroups(last_pg)%group_name) + symbol = trim(PointGroups(last_pg)%group_name) else call report_symmetry_elements_brief_conly(state) if (len_trim(state%MaxRotAxis) == 0) then From 2d43d16c52018d71b93b6ce4261b155120d64658 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 18 Mar 2026 17:44:59 +0100 Subject: [PATCH 241/374] Fix text-formatting error --- src/symmetry_i.f90 | 40 +++++++++++++++++++++++++++++----------- 1 file changed, 29 insertions(+), 11 deletions(-) diff --git a/src/symmetry_i.f90 b/src/symmetry_i.f90 index a10b1270..d9b60689 100644 --- a/src/symmetry_i.f90 +++ b/src/symmetry_i.f90 @@ -1580,48 +1580,65 @@ end subroutine summarize_symmetry_elements !> Report symmetry elements brief subroutine report_symmetry_elements_brief(state) type(symmetry_state_t),intent(inout) :: state - integer :: i + integer :: i, n, tlen character(len=32) :: buf state%SymmetryCode = "" + n = 0 if (state%PlanesCount+state%NormalAxesCount+state%ImproperAxesCount+ & state%InversionCentersCount > 0) then - if (state%InversionCentersCount > 0) & - state%SymmetryCode = trim(state%SymmetryCode)//"(i) " + if (state%InversionCentersCount > 0) then + state%SymmetryCode(n+1:n+4) = "(i) " + n = n+4 + end if if (state%NormalAxesCounts(0) == 1) then - state%SymmetryCode = trim(state%SymmetryCode)//"(Cinf) " + state%SymmetryCode(n+1:n+7) = "(Cinf) " + n = n+7 else if (state%NormalAxesCounts(0) > 1) then write (buf,'(I0,A)') state%NormalAxesCounts(0),"*(Cinf) " - state%SymmetryCode = trim(state%SymmetryCode)//trim(buf) + tlen = len_trim(buf)+1 + state%SymmetryCode(n+1:n+tlen) = buf(1:tlen) + n = n+tlen end if do i = state%MaxAxisOrder,2,-1 if (state%NormalAxesCounts(i) == 1) then write (buf,'(A,I0,A)') "(C",i,") " - state%SymmetryCode = trim(state%SymmetryCode)//trim(buf) + tlen = len_trim(buf)+1 + state%SymmetryCode(n+1:n+tlen) = buf(1:tlen) + n = n+tlen else if (state%NormalAxesCounts(i) > 1) then write (buf,'(I0,A,I0,A)') state%NormalAxesCounts(i),"*(C",i,") " - state%SymmetryCode = trim(state%SymmetryCode)//trim(buf) + tlen = len_trim(buf)+1 + state%SymmetryCode(n+1:n+tlen) = buf(1:tlen) + n = n+tlen end if end do do i = state%MaxAxisOrder,2,-1 if (state%ImproperAxesCounts(i) == 1) then write (buf,'(A,I0,A)') "(S",i,") " - state%SymmetryCode = trim(state%SymmetryCode)//trim(buf) + tlen = len_trim(buf)+1 + state%SymmetryCode(n+1:n+tlen) = buf(1:tlen) + n = n+tlen else if (state%ImproperAxesCounts(i) > 1) then write (buf,'(I0,A,I0,A)') state%ImproperAxesCounts(i),"*(S",i,") " - state%SymmetryCode = trim(state%SymmetryCode)//trim(buf) + tlen = len_trim(buf)+1 + state%SymmetryCode(n+1:n+tlen) = buf(1:tlen) + n = n+tlen end if end do if (state%PlanesCount == 1) then - state%SymmetryCode = trim(state%SymmetryCode)//"(sigma) " + state%SymmetryCode(n+1:n+8) = "(sigma) " + n = n+8 else if (state%PlanesCount > 1) then write (buf,'(I0,A)') state%PlanesCount,"*(sigma) " - state%SymmetryCode = trim(state%SymmetryCode)//trim(buf) + tlen = len_trim(buf)+1 + state%SymmetryCode(n+1:n+tlen) = buf(1:tlen) + n = n+tlen end if end if end subroutine report_symmetry_elements_brief @@ -1726,6 +1743,7 @@ subroutine schoenflies(natoms,attype,coord,symbol,paramar) symbol = trim(state%MaxRotAxis) end if end if + write(*,*) symbol end subroutine schoenflies ! ══════════════════════════════════════════════════════════════════════════════ From 90e659b8711a8ec3e183ce6be7f59ebe57309bac Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 18 Mar 2026 20:48:25 +0100 Subject: [PATCH 242/374] formatting --- src/symmetry_i.f90 | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/src/symmetry_i.f90 b/src/symmetry_i.f90 index d9b60689..0ea2ec02 100644 --- a/src/symmetry_i.f90 +++ b/src/symmetry_i.f90 @@ -116,17 +116,17 @@ module symmetry_i !> All symmetry-analysis state collected in one derived type type,public :: symmetry_state_t ! Tolerance / control - real(wp) :: ToleranceSame = 1.0d-3 - real(wp) :: TolerancePrimary = 5.0d-2 - real(wp) :: ToleranceFinal = 1.0d-4 - real(wp) :: MaxOptStep = 5.0d-1 - real(wp) :: MinOptStep = 1.0d-7 - real(wp) :: GradientStep = 1.0d-7 - real(wp) :: OptChangeThreshold = 1.0d-10 - integer :: verbose = 0 - integer :: MaxAxisOrder = 20 - integer :: MaxOptCycles = 200 - integer :: OptChangeHits = 5 + real(wp) :: ToleranceSame = 1.0d-3 + real(wp) :: TolerancePrimary = 5.0d-2 + real(wp) :: ToleranceFinal = 1.0d-4 + real(wp) :: MaxOptStep = 5.0d-1 + real(wp) :: MinOptStep = 1.0d-7 + real(wp) :: GradientStep = 1.0d-7 + real(wp) :: OptChangeThreshold = 1.0d-10 + integer :: verbose = 0 + integer :: MaxAxisOrder = 20 + integer :: MaxOptCycles = 200 + integer :: OptChangeHits = 5 ! Geometry / working data real(wp) :: CenterOfSomething(3) = 0.0_wp real(wp),allocatable :: DistanceFromCenter(:) @@ -1743,7 +1743,6 @@ subroutine schoenflies(natoms,attype,coord,symbol,paramar) symbol = trim(state%MaxRotAxis) end if end if - write(*,*) symbol end subroutine schoenflies ! ══════════════════════════════════════════════════════════════════════════════ From 9b75759c0d8727e32ee20af83f85fb527ab4296f Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 18 Mar 2026 21:18:03 +0100 Subject: [PATCH 243/374] Small refactor, removed getsymmetry2, now only importing symmetry_i --- src/CMakeLists.txt | 1 - src/entropy/entropic.f90 | 15 ++---- src/entropy/thermochem_module.f90 | 15 ++---- src/meson.build | 1 - src/minitools.f90 | 6 +-- src/symmetry2.f90 | 81 ------------------------------ src/symmetry_i.f90 | 83 ++++++++++++++++++++++++++----- 7 files changed, 82 insertions(+), 120 deletions(-) delete mode 100644 src/symmetry2.f90 diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 1c3e6eb6..9fb972b7 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -72,7 +72,6 @@ list(APPEND srcs "${dir}/signal.c" "${dir}/sigterm.f90" "${dir}/strucreader.f90" - "${dir}/symmetry2.f90" "${dir}/symmetry_i.f90" "${dir}/timer.f90" "${dir}/trackorigin.f90" diff --git a/src/entropy/entropic.f90 b/src/entropy/entropic.f90 index 8b4d0c76..8d21caac 100644 --- a/src/entropy/entropic.f90 +++ b/src/entropy/entropic.f90 @@ -1254,7 +1254,7 @@ subroutine analsym(zmol,fac,pr) !******************************************************* use crest_parameters,only:wp,idp => dp use zdata - use getsymmetry + use symmetry_i,only: getsym implicit none type(zmolecule) :: zmol real(wp),intent(out) :: fac @@ -1264,19 +1264,14 @@ subroutine analsym(zmol,fac,pr) integer,allocatable :: at(:) integer :: i character(len=4) :: sfsym - real(wp),parameter :: desy = 0.1_wp - integer,parameter :: maxat = 200 fac = 1.0_wp nat = zmol%nat - if (nat .gt. maxat) then - return - end if allocate (xyz(3,nat),at(nat)) do i = 1,nat xyz(:,i) = zmol%zat(i)%cart(:) end do at = zmol%at - call getsymmetry2(.false.,6,nat,at,xyz,desy,maxat,sfsym) + call getsym(.false.,6,nat,at,xyz,sfsym) if (pr) then write (*,'(1x,a,4x,a)') 'symmetry:',sfsym(1:3) @@ -1288,7 +1283,7 @@ end subroutine analsym subroutine analsym_geo(grp,nat,xyz,at,fac,pr,sfsm) use crest_parameters,only:wp,idp => dp use zdata - use getsymmetry + use symmetry_i,only: getsym implicit none type(zequal) :: grp real(wp),intent(out) :: fac @@ -1299,10 +1294,8 @@ subroutine analsym_geo(grp,nat,xyz,at,fac,pr,sfsm) character(len=4) :: sfsym character(len=4),intent(out) :: sfsm real(wp),external :: symfactor - real(wp),parameter :: desy = 0.1_wp - integer,parameter :: maxat = 200 fac = 1.0_wp - call getsymmetry2(pr,6,nat,at,xyz,desy,maxat,sfsym) + call getsym(pr,6,nat,at,xyz,sfsym) fac = 1.0_wp/symfactor(grp,sfsym) sfsm = sfsym(1:3) diff --git a/src/entropy/thermochem_module.f90 b/src/entropy/thermochem_module.f90 index 34b0be78..c6fc3b73 100644 --- a/src/entropy/thermochem_module.f90 +++ b/src/entropy/thermochem_module.f90 @@ -1,6 +1,6 @@ module thermochem_module use crest_parameters - use getsymmetry + use symmetry_i use optimize_maths use atmasses,only:molweight use iomod,only:to_lower,directory_exist @@ -182,9 +182,6 @@ subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar,iunit) real(wp) :: a,b,c character(len=4) :: sfsym character(len=3) :: sym,symchar - real(wp),parameter :: desy = 0.1_wp - integer,parameter :: maxat = 200 - !>--- molecular mass in amu molmass = molweight(nat,at) @@ -211,13 +208,11 @@ subroutine prepthermo(nat,at,xyz,pr,molmass,rabc,avmom,symnum,symchar,iunit) !>--- symmetry number from rotational symmetry xyz = xyz/bohr - !write(stdout,*) nat,at,xyz,desy,maxat,sfsym - !!$omp critical - !call getsymmetry2(.false.,6,nat,at,xyz,desy,maxat,sfsym) - !!$omp end critical + !$omp critical + call getsym(.false.,iunit,nat,at,xyz,sfsym) + !$omp end critical xyz = xyz*bohr - !sym = sfsym(1:3) - sym = 'c1' + sym = sfsym(1:3) symchar = sym symnum = 1.0d0 if (a .lt. 1.d-9.or.b .lt. 1.d-9.or.c .lt. 1.d-9) then diff --git a/src/meson.build b/src/meson.build index 90f93ee2..1e5a7ca3 100644 --- a/src/meson.build +++ b/src/meson.build @@ -69,7 +69,6 @@ srcs += files( 'signal.c', 'sigterm.f90', 'strucreader.f90', - 'symmetry2.f90', 'symmetry_i.f90', 'timer.f90', 'trackorigin.f90', diff --git a/src/minitools.f90 b/src/minitools.f90 index 1f183531..6299703d 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -524,7 +524,7 @@ subroutine ensemble_analsym(fname,pr) !***************************************************************** use crest_parameters use strucrd - use getsymmetry + use symmetry_i,only: getsym implicit none character(len=*) :: fname logical :: pr @@ -535,8 +535,6 @@ subroutine ensemble_analsym(fname,pr) integer,allocatable :: at(:) integer :: i,ich character(len=4) :: sfsym,sfsm - real(wp),parameter :: desy = 0.1_wp - integer,parameter :: maxat = 200 character(len=80) :: atmp call rdensembleparam(fname,nat,nall) @@ -557,7 +555,7 @@ subroutine ensemble_analsym(fname,pr) open (file='symmetries',newunit=ich) do i = 1,nall c0(1:3,1:nat) = xyz(:,:,i) - call getsymmetry2(.false.,6,nat,at,c0,desy,maxat,sfsym) + call getsym(.false.,6,nat,at,c0,sfsym) sfsm = sfsym(1:3) write (atmp,'(3x,a,i10,2x,f18.8,2x,a)') 'structure',i,er(i),sfsm write (ich,'(a)') trim(atmp) diff --git a/src/symmetry2.f90 b/src/symmetry2.f90 deleted file mode 100644 index 1ed8b189..00000000 --- a/src/symmetry2.f90 +++ /dev/null @@ -1,81 +0,0 @@ -! This file is part of xtb, modified for crest -! -! Copyright (C) 2017-2020 Stefan Grimme -! -! xtb is free software: you can redistribute it and/or modify it under -! the terms of the GNU Lesser General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! xtb is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public License -! along with xtb. If not, see . - -Module getsymmetry - - private - public :: getsymmetry2 - -! ══════════════════════════════════════════════════════════════════════════════ -contains -! ══════════════════════════════════════════════════════════════════════════════ - - subroutine getsymmetry2(pr,iunit,n,iat,xyz,symthr,maxatdesy,sfsym) - use symmetry_i,only:schoenflies - use iso_fortran_env,only:wp => real64 - implicit none - integer,intent(in) :: iunit - integer :: n,iat(n),maxatdesy - real(wp) :: xyz(3,n) - real(wp) :: symthr - Character(len=*) :: sfsym - logical :: pr - character(len=8) :: atmp - Real(wp) :: paramar(11) !parameter array for schoenflies - - if (n .gt. maxatdesy) then - if (pr) write (iunit,*) 'symmetry recognition skipped because # atoms >',maxatdesy - sfsym = 'none' - return - end if - - if (pr) write (iunit,'(a)') - !parameters for symmetry recognition: - paramar(1) = -1 ! verbose, increase for more detailed output (to stdout) - paramar(2) = 10 ! MaxAxisOrder - paramar(3) = 100 ! MaxOptCycles - paramar(4) = 0.001d0 ! ToleranceSame - paramar(5) = 0.5d0 ! TolerancePrimary - paramar(6) = symthr ! ToleranceFinal, THIS IS THE IMPORTANT VALUE - paramar(7) = 0.5d0 ! MaxOptStep - paramar(8) = 1.0D-7 ! MinOptStep - paramar(9) = 1.0D-7 ! GradientStep - paramar(10) = 1.0D-8 ! OptChangeThreshold - paramar(11) = 5 ! OptChangeHits - - atmp = ' ' - call schoenflies(n,iat,xyz,atmp,paramar) - - !TM stuff (trafo table) - sfsym(1:3) = atmp(1:3) - if (sfsym(1:1) .eq. 'D') sfsym(1:1) = 'd' - if (sfsym(1:1) .eq. 'C') sfsym(1:1) = 'c' - if (sfsym(1:1) .eq. 'T') sfsym(1:1) = 't' - if (sfsym(1:1) .eq. 'O') sfsym(1:1) = 'o' - if (sfsym(1:1) .eq. 'I') sfsym(1:1) = 'i' - if (sfsym(1:1) .eq. 'S') sfsym(1:1) = 's' - if (sfsym .eq. 'dih') sfsym = 'd6h' - if (sfsym .eq. 'civ') sfsym = 'c6v' - if (sfsym(3:3) .gt. 'v'.or.sfsym(3:3) .lt. 'a') sfsym(3:3) = ' ' - - if (pr) then - write (iunit,'(a3,'' symmetry found (for desy threshold: '',e9.2,'')'')') sfsym,symthr - end if - End subroutine getsymmetry2 - -! ══════════════════════════════════════════════════════════════════════════════ -end module getsymmetry diff --git a/src/symmetry_i.f90 b/src/symmetry_i.f90 index 0ea2ec02..d7b08b67 100644 --- a/src/symmetry_i.f90 +++ b/src/symmetry_i.f90 @@ -16,6 +16,7 @@ module symmetry_i ! Public interface public :: schoenflies + public :: getsym !public :: symmetry_element,atom_t,symmetry_state_t !> Mathematical constants @@ -116,17 +117,17 @@ module symmetry_i !> All symmetry-analysis state collected in one derived type type,public :: symmetry_state_t ! Tolerance / control - real(wp) :: ToleranceSame = 1.0d-3 - real(wp) :: TolerancePrimary = 5.0d-2 - real(wp) :: ToleranceFinal = 1.0d-4 - real(wp) :: MaxOptStep = 5.0d-1 - real(wp) :: MinOptStep = 1.0d-7 - real(wp) :: GradientStep = 1.0d-7 - real(wp) :: OptChangeThreshold = 1.0d-10 - integer :: verbose = 0 - integer :: MaxAxisOrder = 20 - integer :: MaxOptCycles = 200 - integer :: OptChangeHits = 5 + real(wp) :: ToleranceSame = 1.0d-3 + real(wp) :: TolerancePrimary = 5.0d-2 + real(wp) :: ToleranceFinal = 1.0d-4 + real(wp) :: MaxOptStep = 5.0d-1 + real(wp) :: MinOptStep = 1.0d-7 + real(wp) :: GradientStep = 1.0d-7 + real(wp) :: OptChangeThreshold = 1.0d-10 + integer :: verbose = 0 + integer :: MaxAxisOrder = 20 + integer :: MaxOptCycles = 200 + integer :: OptChangeHits = 5 ! Geometry / working data real(wp) :: CenterOfSomething(3) = 0.0_wp real(wp),allocatable :: DistanceFromCenter(:) @@ -1580,7 +1581,7 @@ end subroutine summarize_symmetry_elements !> Report symmetry elements brief subroutine report_symmetry_elements_brief(state) type(symmetry_state_t),intent(inout) :: state - integer :: i, n, tlen + integer :: i,n,tlen character(len=32) :: buf state%SymmetryCode = "" @@ -1746,5 +1747,63 @@ subroutine schoenflies(natoms,attype,coord,symbol,paramar) end subroutine schoenflies ! ══════════════════════════════════════════════════════════════════════════════ + + subroutine getsym(pr,iunit,n,iat,xyz,sfsym,symthr,maxatdesy) + use iso_fortran_env,only:wp => real64 + implicit none + logical,intent(in) :: pr + integer,intent(in) :: iunit + integer,intent(in) :: n + integer,intent(in) :: iat(n) + real(wp),intent(in) :: xyz(3,n) + character(len=*),intent(out) :: sfsym + real(wp),intent(in),optional :: symthr ! default 0.1 + integer,intent(in),optional :: maxatdesy ! default 200 + real(wp) :: thr + integer :: maxat + character(len=8) :: atmp + real(wp) :: paramar(11) + + thr = 0.1_wp; if (present(symthr)) thr = symthr + maxat = 200; if (present(maxatdesy)) maxat = maxatdesy + + if (n > maxat) then + if (pr) write (iunit,*) 'symmetry recognition skipped because # atoms >',maxat + sfsym = 'none' + return + end if + + if (pr) write (iunit,'(a)') + paramar(1) = -1 ! verbose + paramar(2) = 10 ! MaxAxisOrder + paramar(3) = 100 ! MaxOptCycles + paramar(4) = 0.001d0 ! ToleranceSame + paramar(5) = 0.5d0 ! TolerancePrimary + paramar(6) = thr ! ToleranceFinal + paramar(7) = 0.5d0 ! MaxOptStep + paramar(8) = 1.0d-7 ! MinOptStep + paramar(9) = 1.0d-7 ! GradientStep + paramar(10) = 1.0d-8 ! OptChangeThreshold + paramar(11) = 5 ! OptChangeHits + + atmp = ' ' + call schoenflies(n,iat,xyz,atmp,paramar) + + sfsym(1:3) = atmp(1:3) + if (sfsym(1:1) == 'D') sfsym(1:1) = 'd' + if (sfsym(1:1) == 'C') sfsym(1:1) = 'c' + if (sfsym(1:1) == 'T') sfsym(1:1) = 't' + if (sfsym(1:1) == 'O') sfsym(1:1) = 'o' + if (sfsym(1:1) == 'I') sfsym(1:1) = 'i' + if (sfsym(1:1) == 'S') sfsym(1:1) = 's' + ! Linear molecules: fix to correct 3-char codes + if (sfsym(1:3) == 'dih') sfsym(1:3) = 'din' + if (sfsym(1:3) == 'civ') sfsym(1:3) = 'cin' + if (sfsym(3:3) > 'v'.or.sfsym(3:3) < 'a') sfsym(3:3) = ' ' + + if (pr) write (iunit,'(a3,'' symmetry found (for desy threshold: '',e9.2,'')'')') & + sfsym,thr + end subroutine getsym + ! ══════════════════════════════════════════════════════════════════════════════ end module symmetry_i From d03bf34cac5a2f5311d15be929881117a7bd5d7e Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 18 Mar 2026 21:50:28 +0100 Subject: [PATCH 244/374] Add tests for all relevant point groups --- .gitignore | 1 + test/CMakeLists.txt | 1 + test/main.f90 | 4 +- test/meson.build | 1 + test/test_getsym.F90 | 785 +++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 791 insertions(+), 1 deletion(-) create mode 100644 test/test_getsym.F90 diff --git a/.gitignore b/.gitignore index a1f0bcd0..58971623 100644 --- a/.gitignore +++ b/.gitignore @@ -14,3 +14,4 @@ bin/ subprojects/.wraplock meson_build/ meson_build_* +utils/ diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index f3e418e3..1a334154 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -8,6 +8,7 @@ set( "CN" "optimization" "molecular_dynamics" + "getsym" ) set( test-srcs diff --git a/test/main.f90 b/test/main.f90 index 84ae3418..ac53955e 100644 --- a/test/main.f90 +++ b/test/main.f90 @@ -10,6 +10,7 @@ program tester use test_cn, only: collect_cn use test_optimization, only: collect_optimization use test_molecular_dynamics, only: collect_mol_dynamics + use test_getsym, only: collect_getsym implicit none integer :: stat, is character(len=:), allocatable :: suite_name, test_name @@ -31,8 +32,9 @@ program tester new_testsuite("gfn0", collect_gfn0), & new_testsuite("gfn0occ", collect_gfn0occ), & new_testsuite("CN",collect_CN), & + new_testsuite("getsym", collect_getsym), & new_testsuite("optimization", collect_optimization), & - new_testsuite("molecular_dynamics", collect_mol_dynamics) & + new_testsuite("molecular_dynamics", collect_mol_dynamics) & ] !&> diff --git a/test/meson.build b/test/meson.build index 87173625..8a535e7d 100644 --- a/test/meson.build +++ b/test/meson.build @@ -9,6 +9,7 @@ tests = [ 'CN', 'optimization', 'molecular_dynamics', + 'getsym', ] test_srcs = files( diff --git a/test/test_getsym.F90 b/test/test_getsym.F90 new file mode 100644 index 00000000..3f7f25e2 --- /dev/null +++ b/test/test_getsym.F90 @@ -0,0 +1,785 @@ +module test_getsym + use testdrive,only:new_unittest,unittest_type,error_type,test_failed + use iso_fortran_env,only:wp => real64 + use symmetry_i,only:getsym + implicit none + private + public :: collect_getsym + +!========================================================================================! +!> Hardcoded geometries (converted from XYZ/Angstrom to Bohr) +!========================================================================================! + + integer,parameter :: nat_c1 = 5 + integer,parameter :: at_c1(nat_c1) = [6,1,9,17,35] + real(wp),parameter :: xyz_c1(3,nat_c1) = reshape([ & + 1.7686891663_wp, -0.0460904202_wp, -0.1376098564_wp, & + 3.8326480397_wp, -0.0460904202_wp, -0.1376098564_wp, & + 1.0806965762_wp, 1.4516120199_wp, -1.3799725025_wp, & + 1.0806965762_wp, 0.2809833775_wp, 1.7806322355_wp, & + 1.0806965762_wp, -1.8708666579_wp, -0.8134704049_wp], & + [3,nat_c1]) + + integer,parameter :: nat_ci = 8 + integer,parameter :: at_ci(nat_ci) = [17,6,6,17,9,1,9,1] + real(wp),parameter :: xyz_ci(3,nat_ci) = reshape([ & + 1.9984798631_wp, 0.0892139703_wp, 0.0537060165_wp, & + 5.3641387828_wp, 0.1444128704_wp, 0.0626444210_wp, & + 6.3141419002_wp, 2.8167312751_wp, 0.4807085316_wp, & + 9.6797819227_wp, 2.8713254628_wp, 0.4934830802_wp, & + 6.0032441582_wp, -0.6077548189_wp, -1.7546107067_wp, & + 6.0030173911_wp, -1.1269192772_wp, 1.5632759366_wp, & + 5.6729956206_wp, 3.5699572111_wp, 2.2967542346_wp, & + 5.6772286072_wp, 4.0874209158_wp, -1.0213780731_wp], & + [3,nat_ci]) + + integer,parameter :: nat_cs = 5 + integer,parameter :: at_cs(nat_cs) = [6,1,1,17,35] + real(wp),parameter :: xyz_cs(3,nat_cs) = reshape([ & + 1.7686891663_wp, -0.0460904202_wp, -0.1376098564_wp, & + 3.8326480397_wp, -0.0460904202_wp, -0.1376098564_wp, & + 1.0806965762_wp, 1.4516120199_wp, -1.3799725025_wp, & + 1.0806965762_wp, 0.2809833775_wp, 1.7806322355_wp, & + 1.0806965762_wp, -1.8708666579_wp, -0.8134704049_wp], & + [3,nat_cs]) + + integer,parameter :: nat_c2 = 4 + integer,parameter :: at_c2(nat_c2) = [8,8,1,1] + real(wp),parameter :: xyz_c2(3,nat_c2) = reshape([ & + -1.3413435337_wp, 0.0553519912_wp, -0.0129809434_wp, & + 1.3413435337_wp, -0.0553519912_wp, 0.0129809434_wp, & + -1.7986927696_wp, -1.6645598353_wp, 0.3904096780_wp, & + 1.7986927696_wp, -1.6645598353_wp, -0.3904096780_wp], & + [3,nat_c2]) + + integer,parameter :: nat_c2h = 6 + integer,parameter :: at_c2h(nat_c2h) = [17,6,6,17,1,1] + real(wp),parameter :: xyz_c2h(3,nat_c2h) = reshape([ & + 1.8977196661_wp, -0.2014448049_wp, -0.0710348050_wp, & + 5.1323638737_wp, -0.1056356904_wp, -0.0379268033_wp, & + 6.4183602960_wp, 1.9359677229_wp, 0.6678481097_wp, & + 9.6529856062_wp, 2.0317768374_wp, 0.7009750087_wp, & + 5.9826083489_wp, -1.8636101096_wp, -0.6456438277_wp, & + 5.5680969235_wp, 3.6939421421_wp, 1.2755840314_wp], & + [3,nat_c2h]) + + integer,parameter :: nat_c2v = 3 + integer,parameter :: at_c2v(nat_c2v) = [8,1,1] + real(wp),parameter :: xyz_c2v(3,nat_c2v) = reshape([ & + 1.7412503430_wp, -0.0503045094_wp, 0.1594739877_wp, & + 3.5702973618_wp, 0.0293096522_wp, 0.1225676364_wp, & + 1.2143191104_wp, 1.5408070930_wp, -0.5779349407_wp], & + [3,nat_c2v]) + + integer,parameter :: nat_c3 = 8 + integer,parameter :: at_c3(nat_c3) = [8,15,8,8,8,1,1,1] + real(wp),parameter :: xyz_c3(3,nat_c3) = reshape([ & + 2.1838664179_wp, 0.0466527838_wp, 1.9125045432_wp, & + -0.2066665717_wp, -0.0189806738_wp, 0.1004614502_wp, & + -2.6626254324_wp, -0.0861740813_wp, 1.3747444618_wp, & + 0.2477461752_wp, 2.3413303983_wp, -1.6955100891_wp, & + 0.3753052019_wp, -2.3513858200_wp, -1.6952502706_wp, & + 1.8620047872_wp, -0.9714351061_wp, 3.3672205705_wp, & + -0.5208961465_wp, 3.8036152890_wp, -0.9694469441_wp, & + -1.1456946322_wp, -2.8663836211_wp, -2.5184443558_wp], & + [3,nat_c3]) + + integer,parameter :: nat_c3v = 4 + integer,parameter :: at_c3v(nat_c3v) = [7,1,1,1] + real(wp),parameter :: xyz_c3v(3,nat_c3v) = reshape([ & + 2.0094213774_wp, 0.1277832805_wp, -0.0094864251_wp, & + 3.9318964557_wp, 0.0784425314_wp, -0.1081112316_wp, & + 1.4206016142_wp, -1.6941772652_wp, -0.2138414083_wp, & + 1.4205827169_wp, 1.0563191091_wp, -1.5903557120_wp], & + [3,nat_c3v]) + + integer,parameter :: nat_c4v = 6 + integer,parameter :: at_c4v(nat_c4v) = [54,8,9,9,9,9] + real(wp),parameter :: xyz_c4v(3,nat_c4v) = reshape([ & + 0.0000000000_wp, 0.0000000000_wp, 0.0000000000_wp, & + 2.8345891869_wp, 0.0000000000_wp, 0.0000000000_wp, & + 0.0000000000_wp, 2.2676713496_wp, 2.2676713496_wp, & + 0.0000000000_wp, 2.2676713496_wp, -2.2676713496_wp, & + 0.0000000000_wp, -2.2676713496_wp, 2.2676713496_wp, & + 0.0000000000_wp, -2.2676713496_wp, -2.2676713496_wp], & + [3,nat_c4v]) + + integer,parameter :: nat_c5 = 30 + integer,parameter :: at_c5(nat_c5) = [6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,1,9,1,9,1,9,9,1,1,9] + real(wp),parameter :: xyz_c5(3,nat_c5) = reshape([ & + 4.1506027534_wp, -2.0577782147_wp, -0.7793164178_wp, & + 6.1034755769_wp, -0.2721278465_wp, -0.2078341373_wp, & + 5.6677527186_wp, 2.2879313702_wp, -0.1333417100_wp, & + 3.2287955057_wp, 3.3565846641_wp, -0.6214740288_wp, & + 2.1555044741_wp, 5.7218229465_wp, 0.1429213557_wp, & + -0.4097575886_wp, 6.0946420523_wp, 0.3095743804_wp, & + -2.1972322554_wp, 4.1450305843_wp, -0.2688976403_wp, & + -4.7566213713_wp, 3.8026161128_wp, 0.5439005762_wp, & + -5.9057076660_wp, 1.4728953771_wp, 0.5727859198_wp, & + -4.6279273429_wp, -0.7822543594_wp, -0.2081874783_wp, & + -2.3260847824_wp, -0.3558899934_wp, -1.3645953292_wp, & + -0.4212128650_wp, -2.2172109020_wp, -1.5190221584_wp, & + 1.9366611069_wp, -0.9752564488_wp, -1.6417754489_wp, & + 1.4889571281_wp, 1.6533686360_wp, -1.5646128982_wp, & + -1.1457234397_wp, 2.0362307059_wp, -1.3934152450_wp, & + -0.7053856104_wp, -4.6162955879_wp, -0.5285699878_wp, & + -3.2269454839_wp, -5.1877810615_wp, 0.2742834659_wp, & + -5.0813249127_wp, -3.3749399931_wp, 0.4262836582_wp, & + 1.6314970454_wp, -5.8938226986_wp, -0.0423215999_wp, & + 3.9271679611_wp, -4.6839996881_wp, -0.1604477348_wp, & + 7.9404810111_wp, -0.9711247579_wp, 0.3544797089_wp, & + 7.1758252770_wp, 3.5221796708_wp, 0.4851426936_wp, & + 3.4066392826_wp, 7.2100758904_wp, 0.7757496641_wp, & + -1.0969646698_wp, 7.8643592820_wp, 1.0684833919_wp, & + -5.7621122661_wp, 5.4024319347_wp, 1.3250328734_wp, & + -7.7790778971_wp, 1.3128978782_wp, 1.3759015475_wp, & + -3.6400790044_wp, -7.0730048337_wp, 0.9489170013_wp, & + -6.8954493888_wp, -3.8908471871_wp, 1.2160970832_wp, & + 1.5754712934_wp, -7.8309868158_wp, 0.6087556096_wp, & + 5.6057219651_wp, -5.7074640447_wp, 0.4016119744_wp], & + [3,nat_c5]) + + integer,parameter :: nat_c5v = 30 + integer,parameter :: at_c5v(nat_c5v) = [6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,1,1,1,1,1,1,1,1,1,1] + real(wp),parameter :: xyz_c5v(3,nat_c5v) = reshape([ & + 4.1506027534_wp, -2.0577782147_wp, -0.7793164178_wp, & + 6.1034755769_wp, -0.2721278465_wp, -0.2078341373_wp, & + 5.6677527186_wp, 2.2879313702_wp, -0.1333417100_wp, & + 3.2287955057_wp, 3.3565846641_wp, -0.6214740288_wp, & + 2.1555044741_wp, 5.7218229465_wp, 0.1429213557_wp, & + -0.4097575886_wp, 6.0946420523_wp, 0.3095743804_wp, & + -2.1972322554_wp, 4.1450305843_wp, -0.2688976403_wp, & + -4.7566213713_wp, 3.8026161128_wp, 0.5439005762_wp, & + -5.9057076660_wp, 1.4728953771_wp, 0.5727859198_wp, & + -4.6279273429_wp, -0.7822543594_wp, -0.2081874783_wp, & + -2.3260847824_wp, -0.3558899934_wp, -1.3645953292_wp, & + -0.4212128650_wp, -2.2172109020_wp, -1.5190221584_wp, & + 1.9366611069_wp, -0.9752564488_wp, -1.6417754489_wp, & + 1.4889571281_wp, 1.6533686360_wp, -1.5646128982_wp, & + -1.1457234397_wp, 2.0362307059_wp, -1.3934152450_wp, & + -0.7053856104_wp, -4.6162955879_wp, -0.5285699878_wp, & + -3.2269454839_wp, -5.1877810615_wp, 0.2742834659_wp, & + -5.0813249127_wp, -3.3749399931_wp, 0.4262836582_wp, & + 1.6314970454_wp, -5.8938226986_wp, -0.0423215999_wp, & + 3.9271679611_wp, -4.6839996881_wp, -0.1604477348_wp, & + 7.9404810111_wp, -0.9711247579_wp, 0.3544797089_wp, & + 7.1758252770_wp, 3.5221796708_wp, 0.4851426936_wp, & + 3.4066392826_wp, 7.2100758904_wp, 0.7757496641_wp, & + -1.0969646698_wp, 7.8643592820_wp, 1.0684833919_wp, & + -5.7621122661_wp, 5.4024319347_wp, 1.3250328734_wp, & + -7.7790778971_wp, 1.3128978782_wp, 1.3759015475_wp, & + -3.6400790044_wp, -7.0730048337_wp, 0.9489170013_wp, & + -6.8954493888_wp, -3.8908471871_wp, 1.2160970832_wp, & + 1.5754712934_wp, -7.8309868158_wp, 0.6087556096_wp, & + 5.6057219651_wp, -5.7074640447_wp, 0.4016119744_wp], & + [3,nat_c5v]) + + integer,parameter :: nat_cinfv = 2 + integer,parameter :: at_cinfv(nat_cinfv) = [9,1] + real(wp),parameter :: xyz_cinfv(3,nat_cinfv) = reshape([ & + 1.6545119139_wp, 0.1226999173_wp, -0.0701655310_wp, & + 3.4293237929_wp, 0.1226999173_wp, -0.0701655310_wp], & + [3,nat_cinfv]) + + integer,parameter :: nat_d2 = 22 + integer,parameter :: at_d2(nat_d2) = [6,6,6,6,6,6,6,6,6,6,6,6,1,1,1,1,1,1,1,1,1,1] + real(wp),parameter :: xyz_d2(3,nat_d2) = reshape([ & + 2.5621851661_wp, -0.4439911530_wp, -0.0436148790_wp, & + 0.9253421914_wp, -2.5127877252_wp, 0.1502332269_wp, & + -1.6739005039_wp, -2.1369023017_wp, 0.1913347701_wp, & + -2.6332955601_wp, 0.3046994403_wp, 0.0348465497_wp, & + -0.9891960372_wp, 2.3654268820_wp, -0.1896340166_wp, & + 1.6529812357_wp, 2.0499560027_wp, -0.2395794781_wp, & + 3.3960268186_wp, 4.2370305331_wp, -0.4989632859_wp, & + 2.7654063135_wp, 6.6565791713_wp, 0.4215601039_wp, & + 4.3970903358_wp, 8.7186861130_wp, 0.1505166858_wp, & + 6.7269714694_wp, 8.4139488781_wp, -1.0255921624_wp, & + 7.4141325801_wp, 6.0515266607_wp, -1.9418447711_wp, & + 5.7626631253_wp, 3.9991329112_wp, -1.6961614777_wp, & + 4.5822457015_wp, -0.8214828436_wp, -0.0238294464_wp, & + 1.6914371624_wp, -4.4146269943_wp, 0.2723851236_wp, & + -2.9477459873_wp, -3.7402404322_wp, 0.3445726616_wp, & + -4.6633527468_wp, 0.6148223946_wp, 0.0725843804_wp, & + -1.8237746829_wp, 4.2357833138_wp, -0.3557031484_wp, & + 0.9789537216_wp, 6.9700847353_wp, 1.3885707564_wp, & + 3.8407738620_wp, 10.5624352010_wp, 0.8651544144_wp, & + 8.0008169527_wp, 10.0118257001_wp, -1.2267913028_wp, & + 9.2341467080_wp, 5.7935979419_wp, -2.8609508664_wp, & + 6.3573788339_wp, 2.1980160446_wp, -2.4864260457_wp], & + [3,nat_d2]) + + integer,parameter :: nat_d2d = 7 + integer,parameter :: at_d2d(nat_d2d) = [6,6,6,1,1,1,1] + real(wp),parameter :: xyz_d2d(3,nat_d2d) = reshape([ & + -2.4443487644_wp, -0.0000022937_wp, -0.0000001336_wp, & + -0.0000010639_wp, -0.0000043018_wp, -0.0000001767_wp, & + 2.4443458222_wp, -0.0000057331_wp, 0.0000012450_wp, & + -3.5163354416_wp, -0.4079430602_wp, -1.6837648529_wp, & + -3.5163315932_wp, 0.4079495522_wp, 1.6837640156_wp, & + 3.5163309025_wp, -1.6837439760_wp, 0.4080523160_wp, & + 3.5163297587_wp, 1.6837342434_wp, -0.4080524134_wp], & + [3,nat_d2d]) + + integer,parameter :: nat_d2h = 6 + integer,parameter :: at_d2h(nat_d2h) = [6,6,1,1,1,1] + real(wp),parameter :: xyz_d2h(3,nat_d2h) = reshape([ & + 2.0246903644_wp, 0.0223932546_wp, 0.1508190420_wp, & + 4.5488164464_wp, 0.0223932546_wp, 0.1508190420_wp, & + 0.9669161662_wp, -0.8803667097_wp, 1.6587637977_wp, & + 0.9669161662_wp, 0.9251343216_wp, -1.3571446109_wp, & + 5.6066095419_wp, -0.8803667097_wp, 1.6587637977_wp, & + 5.6066095419_wp, 0.9251343216_wp, -1.3571446109_wp], & + [3,nat_d2h]) + + integer,parameter :: nat_d3 = 19 + integer,parameter :: at_d3(nat_d3) = [8,6,6,8,8,8,26,8,6,6,8,8,8,8,6,6,8,8,8] + real(wp),parameter :: xyz_d3(3,nat_d3) = reshape([ & + -5.5946338021_wp, -0.8229064614_wp, 5.2053622115_wp, & + -3.8359811652_wp, -0.1763064438_wp, 3.8074275063_wp, & + -2.7745085917_wp, 2.5933383340_wp, 3.8848133004_wp, & + -3.5603543255_wp, 4.1325496693_wp, 5.4589836994_wp, & + -1.1089414828_wp, 3.0199843392_wp, 2.2154904239_wp, & + -2.7131559285_wp, -1.5806752624_wp, 2.2233057633_wp, & + -0.0134444680_wp, 0.0555107607_wp, -0.0126742790_wp, & + 2.6937923405_wp, -1.3396015306_wp, 2.3709864194_wp, & + 3.8108202955_wp, -3.3564374539_wp, 1.7154489832_wp, & + 2.7271524135_wp, -4.5428355546_wp, -0.7798409646_wp, & + 3.4884935170_wp, -6.6150723077_wp, -1.5481502414_wp, & + 1.0689832135_wp, -3.1742433657_wp, -1.8393468833_wp, & + 5.5813984523_wp, -4.3738859186_wp, 2.8528582093_wp, & + 2.3849000934_wp, 2.0543474787_wp, -2.2983085914_wp, & + 1.4354620793_wp, 3.1595785624_wp, -4.2017472655_wp, & + -1.4637774680_wp, 2.6289929240_wp, -4.5453833855_wp, & + -2.6147523355_wp, 3.4372639067_wp, -6.4129074540_wp, & + -2.4130858761_wp, 1.3426279459_wp, -2.7590959144_wp, & + 2.5858890563_wp, 4.5360541927_wp, -5.7014434355_wp], & + [3,nat_d3]) + + integer,parameter :: nat_d3d = 8 + integer,parameter :: at_d3d(nat_d3d) = [6,6,1,1,1,1,1,1] + real(wp),parameter :: xyz_d3d(3,nat_d3d) = reshape([ & + 2.0104607267_wp, -0.0348843443_wp, 0.1472096651_wp, & + 4.8678589080_wp, -0.0348843443_wp, 0.1472096651_wp, & + 1.2842956688_wp, 0.8372809540_wp, 1.8753642061_wp, & + 1.2842956688_wp, -1.9675828410_wp, 0.0384370294_wp, & + 1.2842956688_wp, 1.0256866487_wp, -1.4721911374_wp, & + 5.5940239659_wp, -1.0954364399_wp, 1.7665915703_wp, & + 5.5940239659_wp, 1.8978330497_wp, 0.2559823008_wp, & + 5.5940428632_wp, -0.9070307453_wp, -1.5809637731_wp], & + [3,nat_d3d]) + + integer,parameter :: nat_d3h = 4 + integer,parameter :: at_d3h(nat_d3h) = [9,5,9,9] + real(wp),parameter :: xyz_d3h(3,nat_d3h) = reshape([ & + 1.9631230873_wp, -0.1245707461_wp, 0.0334670497_wp, & + 4.6923411455_wp, -0.1245707461_wp, 0.0334670497_wp, & + 6.0569501747_wp, -1.5824944513_wp, -1.8268927310_wp, & + 6.0569501747_wp, 1.3333718563_wp, 1.8938268303_wp], & + [3,nat_d3h]) + + integer,parameter :: nat_d4 = 22 + integer,parameter :: at_d4(nat_d4) = [8,6,25,6,8,6,8,6,8,6,8,25,6,8,6,8,6,8,6,8,6,8] + real(wp),parameter :: xyz_d4(3,nat_d4) = reshape([ & + 2.2841686586_wp, 0.2090037094_wp, 0.1362114591_wp, & + 4.5444511790_wp, 0.1935646469_wp, 0.0922564294_wp, & + 8.0752343675_wp, 0.1854010301_wp, 0.0151933980_wp, & + 8.0120608232_wp, 1.9881619585_wp, -3.0202358814_wp, & + 7.9811071093_wp, 3.1479246757_wp, -4.9606066662_wp, & + 8.0751020867_wp, 3.2437337902_wp, 1.7781188997_wp, & + 8.0761981279_wp, 5.2013388772_wp, 2.9070034920_wp, & + 11.6050160012_wp, 0.2565681159_wp, -0.0161004666_wp, & + 13.8652040353_wp, 0.3039435499_wp, -0.0245286451_wp, & + 8.1379165831_wp, -1.5381803737_wp, 3.0963540497_wp, & + 8.1691726532_wp, -2.6353931561_wp, 5.0726107336_wp, & + 8.0741761209_wp, -4.5149147597_wp, -2.6937101043_wp, & + 9.8948705502_wp, -3.0413819168_wp, -5.3358495828_wp, & + 11.0515152193_wp, -2.1019990602_wp, -7.0370377319_wp, & + 11.1000622834_wp, -5.4598912056_wp, -1.1375395380_wp, & + 13.0420960272_wp, -6.0674948464_wp, -0.1537481175_wp, & + 8.0747430387_wp, -7.5720380951_wp, -4.4554072840_wp, & + 8.0736658949_wp, -9.5304179698_wp, -5.5823076639_wp, & + 6.2539541231_wp, -6.0621280242_wp, -0.0951666076_wp, & + 5.0967614335_wp, -7.0624734456_wp, 1.5704946904_wp, & + 5.0491781296_wp, -3.6432029957_wp, -4.2940624675_wp, & + 3.1068042352_wp, -3.0971855292_wp, -5.3130027939_wp], & + [3,nat_d4]) + + integer,parameter :: nat_d4h = 5 + integer,parameter :: at_d4h(nat_d4h) = [54,9,9,9,9] + real(wp),parameter :: xyz_d4h(3,nat_d4h) = reshape([ & + 0.0000000000_wp, 0.0000000000_wp, 0.0000000000_wp, & + 0.0000000000_wp, 2.2676713496_wp, 2.2676713496_wp, & + 0.0000000000_wp, 2.2676713496_wp, -2.2676713496_wp, & + 0.0000000000_wp, -2.2676713496_wp, 2.2676713496_wp, & + 0.0000000000_wp, -2.2676713496_wp, -2.2676713496_wp], & + [3,nat_d4h]) + + integer,parameter :: nat_d5d = 21 + integer,parameter :: at_d5d(nat_d5d) = [6,6,6,6,6,1,1,1,1,1,26,6,6,6,6,6,1,1,1,1,1] + real(wp),parameter :: xyz_d5d(3,nat_d5d) = reshape([ & + 1.8752508225_wp, 1.3624547413_wp, -3.2840605457_wp, & + 1.8752508225_wp, -1.3624547413_wp, -3.2840605457_wp, & + -0.7162817903_wp, -2.2044978052_wp, -3.2840605457_wp, & + -2.3179380645_wp, 0.0000000000_wp, -3.2840605457_wp, & + -0.7162817903_wp, 2.2044978052_wp, -3.2840605457_wp, & + 3.5276840377_wp, 2.5630166456_wp, -3.2695285518_wp, & + 3.5276840377_wp, -2.5630166456_wp, -3.2695285518_wp, & + -1.3474503159_wp, -4.1470417750_wp, -3.2695285518_wp, & + -4.3604485463_wp, 0.0000000000_wp, -3.2695285518_wp, & + -1.3474503159_wp, 4.1470417750_wp, -3.2695285518_wp, & + -0.0000000000_wp, -0.0000000000_wp, -0.0000000000_wp, & + -1.8752508225_wp, -1.3624547413_wp, 3.2840605457_wp, & + -1.8752508225_wp, 1.3624547413_wp, 3.2840605457_wp, & + 0.7162817903_wp, 2.2044978052_wp, 3.2840605457_wp, & + 2.3179380645_wp, -0.0000000000_wp, 3.2840605457_wp, & + 0.7162817903_wp, -2.2044978052_wp, 3.2840605457_wp, & + -3.5276840377_wp, -2.5630166456_wp, 3.2695285518_wp, & + -3.5276840377_wp, 2.5630166456_wp, 3.2695285518_wp, & + 1.3474503159_wp, 4.1470417750_wp, 3.2695285518_wp, & + 4.3604485463_wp, -0.0000000000_wp, 3.2695285518_wp, & + 1.3474503159_wp, -4.1470417750_wp, 3.2695285518_wp], & + [3,nat_d5d]) + + integer,parameter :: nat_d5h = 10 + integer,parameter :: at_d5h(nat_d5h) = [6,6,6,6,6,1,1,1,1,1] + real(wp),parameter :: xyz_d5h(3,nat_d5h) = reshape([ & + -1.8663524711_wp, 1.2366992873_wp, 0.0051139268_wp, & + 0.6026542002_wp, 2.1530019351_wp, 0.0043775201_wp, & + 2.2371465685_wp, 0.0880473317_wp, 0.0060344776_wp, & + 0.7782640422_wp, -2.1045045776_wp, 0.0074568022_wp, & + -1.7577693293_wp, -1.3946159551_wp, 0.0071930800_wp, & + -3.5767552803_wp, 2.3747834075_wp, 0.0043379967_wp, & + 1.1564942170_wp, 4.1315770941_wp, 0.0029612919_wp, & + 4.2898362320_wp, 0.1727660771_wp, 0.0060819138_wp, & + 1.4930016348_wp, -4.0307549451_wp, 0.0085934742_wp, & + -3.3686738275_wp, -2.6698661099_wp, 0.0083161327_wp], & + [3,nat_d5h]) + + integer,parameter :: nat_d6h = 12 + integer,parameter :: at_d6h(nat_d6h) = [6,6,6,6,6,6,1,1,1,1,1,1] + real(wp),parameter :: xyz_d6h(3,nat_d6h) = reshape([ & + 2.6136424084_wp, -0.4184042613_wp, 0.0100533430_wp, & + 0.9574486383_wp, -2.4690216681_wp, -0.0142107405_wp, & + -1.6464616806_wp, -2.0607841334_wp, -0.0269852891_wp, & + -2.5945939691_wp, 0.3983353698_wp, -0.0087116374_wp, & + -0.9386647606_wp, 2.4494252082_wp, 0.0204657339_wp, & + 1.6651132775_wp, 2.0409987009_wp, 0.0256813780_wp, & + 4.6419610471_wp, -0.7366152434_wp, 0.0176122475_wp, & + 1.6964071421_wp, -4.3853740339_wp, -0.0241884944_wp, & + -2.9363320415_wp, -3.6582263184_wp, -0.0521942356_wp, & + -4.6232338612_wp, 0.7170565780_wp, -0.0156847268_wp, & + -1.6777366480_wp, 4.3659287520_wp, 0.0383047485_wp, & + 2.9553426863_wp, 3.6388377283_wp, 0.0426322214_wp], & + [3,nat_d6h]) + + integer,parameter :: nat_d7h = 14 + integer,parameter :: at_d7h(nat_d7h) = [6,6,6,6,6,6,6,1,1,1,1,1,1,1] + real(wp),parameter :: xyz_d7h(3,nat_d7h) = reshape([ & + -3.0250909355_wp, -0.1819499680_wp, -0.0116177785_wp, & + -2.0295202814_wp, 2.2508838774_wp, -0.0016445251_wp, & + 0.4931844451_wp, 2.9892921059_wp, -0.0030129336_wp, & + 2.6435520954_wp, 1.4774985135_wp, -0.0143554973_wp, & + 2.8021645025_wp, -1.1465948089_wp, -0.0184410880_wp, & + 0.8494762113_wp, -2.9064326781_wp, -0.0175336090_wp, & + -1.7439494254_wp, -2.4770856286_wp, -0.0170237108_wp, & + -5.0696637259_wp, -0.3055858821_wp, -0.0130586120_wp, & + -3.4008719473_wp, 3.7725554171_wp, 0.0063520778_wp, & + 0.8275050278_wp, 5.0100568745_wp, 0.0037676503_wp, & + 4.4322977666_wp, 2.4760577858_wp, -0.0182010363_wp, & + 4.6978588149_wp, -1.9224255016_wp, -0.0222170612_wp, & + 1.4250021608_wp, -4.8724090140_wp, -0.0195888430_wp, & + -2.9223717563_wp, -4.1524896636_wp, -0.0214410923_wp], & + [3,nat_d7h]) + + integer,parameter :: nat_d8h = 16 + integer,parameter :: at_d8h(nat_d8h) = [6,6,6,6,6,6,6,6,1,1,1,1,1,1,1,1] + real(wp),parameter :: xyz_d8h(3,nat_d8h) = reshape([ & + -3.1953385351_wp, -1.2992913342_wp, -0.0013443022_wp, & + -3.1782563860_wp, 1.3405447404_wp, -0.0007915785_wp, & + 3.1781269385_wp, -1.3404545521_wp, -0.0014447561_wp, & + 3.1950752347_wp, 1.2993923915_wp, -0.0013802919_wp, & + -1.3405368625_wp, -3.1782313687_wp, 0.0013485110_wp, & + -1.2993730227_wp, 3.1954063105_wp, 0.0015601677_wp, & + 1.2993044510_wp, -3.1951175719_wp, 0.0009977162_wp, & + 1.3404668185_wp, 3.1782610779_wp, 0.0007763660_wp, & + -5.1398876580_wp, -2.0896976163_wp, 0.0007417474_wp, & + -5.1121989694_wp, 2.1560890106_wp, -0.0002704245_wp, & + 5.1124825940_wp, -2.1559398160_wp, 0.0009894776_wp, & + 5.1396923174_wp, 2.0898768932_wp, -0.0006786475_wp, & + -2.1559780569_wp, -5.1130969396_wp, -0.0013939168_wp, & + -2.0898182036_wp, 5.1398167921_wp, 0.0002326967_wp, & + 2.0899305811_wp, -5.1394090818_wp, 0.0007171611_wp, & + 2.1561490482_wp, 5.1124899088_wp, -0.0000599261_wp], & + [3,nat_d8h]) + + integer,parameter :: nat_dinfh = 3 + integer,parameter :: at_dinfh(nat_dinfh) = [8,6,8] + real(wp),parameter :: xyz_dinfh(3,nat_dinfh) = reshape([ & + 1.9258198936_wp, -0.1348886508_wp, -0.0823920590_wp, & + 4.1878220648_wp, -0.1348886508_wp, -0.0823920590_wp, & + 6.4498242360_wp, -0.1348886508_wp, -0.0823920590_wp], & + [3,nat_dinfh]) + + integer,parameter :: nat_s4 = 13 + integer,parameter :: at_s4(nat_s4) = [6,6,6,6,6,9,1,9,1,9,1,1,9] + real(wp),parameter :: xyz_s4(3,nat_s4) = reshape([ & + 2.3072044201_wp, -1.2009776440_wp, -0.8184403846_wp, & + 2.4025600003_wp, 1.1865779309_wp, 0.8250733233_wp, & + 0.0157792131_wp, 0.0560870714_wp, 0.0471297695_wp, & + -2.3250056402_wp, -0.7273555854_wp, 1.2698014694_wp, & + -2.3238340100_wp, 0.9671429333_wp, -1.0852886106_wp, & + 2.8351938993_wp, -2.9734273653_wp, 0.0561248659_wp, & + 2.8306207621_wp, -1.0219260937_wp, -2.7883475887_wp, & + 2.9927025718_wp, 2.9301526371_wp, -0.0707324488_wp, & + 2.9884506880_wp, 0.9771584818_wp, 2.7741368482_wp, & + -2.8216634602_wp, 0.1301454382_wp, 3.0596366711_wp, & + -2.9424736514_wp, -2.6640791987_wp, 1.0395383412_wp, & + -2.8250271727_wp, 2.9347824661_wp, -0.8342762895_wp, & + -2.9360107880_wp, 0.1393106099_wp, -2.8526360714_wp], & + [3,nat_s4]) + + integer,parameter :: nat_td = 5 + integer,parameter :: at_td(nat_td) = [6,1,1,1,1] + real(wp),parameter :: xyz_td(3,nat_td) = reshape([ & + 1.9771448552_wp, -0.1316194246_wp, -0.1036703752_wp, & + 4.0411037285_wp, -0.1316194246_wp, -0.1036703752_wp, & + 1.2891522650_wp, 0.5743255638_wp, 1.7096730195_wp, & + 1.2891522650_wp, -2.0549826742_wp, -0.3989967740_wp, & + 1.2891522650_wp, 1.0858177339_wp, -1.6217062684_wp], & + [3,nat_td]) + + integer,parameter :: nat_oh = 7 + integer,parameter :: at_oh(nat_oh) = [9,16,9,9,9,9,9] + real(wp),parameter :: xyz_oh(3,nat_oh) = reshape([ & + 1.5011606389_wp, 0.0480557353_wp, -0.1059758411_wp, & + 4.8021909252_wp, 0.0480557353_wp, -0.1059758411_wp, & + 4.8021909252_wp, -3.1466396619_wp, -0.9371340825_wp, & + 4.8021909252_wp, 0.8791950795_wp, -3.3006523411_wp, & + 8.1032212114_wp, 0.0480557353_wp, -0.1059758411_wp, & + 4.8021909252_wp, 3.2427322353_wp, 0.7251635031_wp, & + 4.8021909252_wp, -0.7831025060_wp, 3.0887006589_wp], & + [3,nat_oh]) + + integer,parameter :: nat_ih = 60 + integer,parameter :: at_ih(nat_ih) = [6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6, & + 6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6] + real(wp),parameter :: xyz_ih(3,nat_ih) = reshape([ & + 0.0000000000_wp, 2.3362684079_wp, 6.2880636797_wp, & + -2.2219399773_wp, 0.7218753796_wp, 6.2880636797_wp, & + -1.3732639748_wp, -1.8901040699_wp, 6.2880636797_wp, & + 1.3732639748_wp, -1.8901040699_wp, 6.2880636797_wp, & + 2.2219399773_wp, 0.7218753796_wp, 6.2880636797_wp, & + 4.3552517994_wp, 1.4152158947_wp, 4.9017605947_wp, & + 5.7285157742_wp, -0.4748881751_wp, 3.4578208628_wp, & + 4.9136658693_wp, -2.9829326877_wp, 3.4578208628_wp, & + 2.6917258919_wp, -3.7048080673_wp, 4.9017605947_wp, & + 1.3184619172_wp, -5.5949121372_wp, 3.4578208628_wp, & + -1.3184619172_wp, -5.5949121372_wp, 3.4578208628_wp, & + -2.6917258919_wp, -3.7048080673_wp, 4.9017605947_wp, & + -4.9136658693_wp, -2.9829326877_wp, 3.4578208628_wp, & + -5.7285157742_wp, -0.4748881751_wp, 3.4578208628_wp, & + -4.3552517994_wp, 1.4152158947_wp, 4.9017605947_wp, & + -4.3552517994_wp, 3.7514843026_wp, 3.4578208628_wp, & + -5.7285157742_wp, 3.3051309920_wp, 1.1215524550_wp, & + -6.5771917768_wp, 0.6931515425_wp, 1.1215524550_wp, & + -6.5771917768_wp, -0.6931515425_wp, -1.1215524550_wp, & + -5.7285157742_wp, -3.3051309920_wp, -1.1215524550_wp, & + -4.9136658693_wp, -4.4268724195_wp, 1.1215524550_wp, & + -2.6917258919_wp, -6.0410764752_wp, 1.1215524550_wp, & + -1.3732639748_wp, -6.4694773877_wp, -1.1215524550_wp, & + 1.3732639748_wp, -6.4694773877_wp, -1.1215524550_wp, & + 2.6917258919_wp, -6.0410764752_wp, 1.1215524550_wp, & + 4.9136658693_wp, -4.4268724195_wp, 1.1215524550_wp, & + 5.7285157742_wp, -3.3051309920_wp, -1.1215524550_wp, & + 6.5771917768_wp, -0.6931515425_wp, -1.1215524550_wp, & + 6.5771917768_wp, 0.6931515425_wp, 1.1215524550_wp, & + 5.7285157742_wp, 3.3051309920_wp, 1.1215524550_wp, & + 4.9136658693_wp, 4.4268724195_wp, -1.1215524550_wp, & + 4.9136658693_wp, 2.9829326877_wp, -3.4578208628_wp, & + 5.7285157742_wp, 0.4748881751_wp, -3.4578208628_wp, & + 4.3552517994_wp, -1.4152158947_wp, -4.9017605947_wp, & + 4.3552517994_wp, -3.7514843026_wp, -3.4578208628_wp, & + 2.2219399773_wp, -5.3014376700_wp, -3.4578208628_wp, & + 0.0000000000_wp, -4.5795622904_wp, -4.9017605947_wp, & + -2.2219399773_wp, -5.3014376700_wp, -3.4578208628_wp, & + -4.3552517994_wp, -3.7514843026_wp, -3.4578208628_wp, & + -4.3552517994_wp, -1.4152158947_wp, -4.9017605947_wp, & + -5.7285157742_wp, 0.4748881751_wp, -3.4578208628_wp, & + -4.9136658693_wp, 2.9829326877_wp, -3.4578208628_wp, & + -4.9136658693_wp, 4.4268724195_wp, -1.1215524550_wp, & + -2.6917258919_wp, 6.0410764752_wp, -1.1215524550_wp, & + -1.3184619172_wp, 5.5949121372_wp, -3.4578208628_wp, & + -2.6917258919_wp, 3.7048080673_wp, -4.9017605947_wp, & + -1.3732639748_wp, 1.8901040699_wp, -6.2880636797_wp, & + -2.2219399773_wp, -0.7218753796_wp, -6.2880636797_wp, & + 0.0000000000_wp, -2.3362684079_wp, -6.2880636797_wp, & + 2.2219399773_wp, -0.7218753796_wp, -6.2880636797_wp, & + 1.3732639748_wp, 1.8901040699_wp, -6.2880636797_wp, & + 2.6917258919_wp, 3.7048080673_wp, -4.9017605947_wp, & + 1.3184619172_wp, 5.5949121372_wp, -3.4578208628_wp, & + 2.6917258919_wp, 6.0410764752_wp, -1.1215524550_wp, & + 1.3732639748_wp, 6.4694773877_wp, 1.1215524550_wp, & + -1.3732639748_wp, 6.4694773877_wp, 1.1215524550_wp, & + -2.2219399773_wp, 5.3014376700_wp, 3.4578208628_wp, & + 0.0000000000_wp, 4.5795622904_wp, 4.9017605947_wp, & + 2.2219399773_wp, 5.3014376700_wp, 3.4578208628_wp, & + 4.3552517994_wp, 3.7514843026_wp, 3.4578208628_wp], & + [3,nat_ih]) + +!========================================================================================! +!========================================================================================! +contains !> Unit tests for getsym point-group detection +!========================================================================================! +!========================================================================================! + + subroutine collect_getsym(testsuite) + type(unittest_type),allocatable,intent(out) :: testsuite(:) +!&< + testsuite = [ & + new_unittest("symmetry c1 ",test_c1), & + new_unittest("symmetry ci ",test_ci), & + new_unittest("symmetry cs ",test_cs), & + new_unittest("symmetry c2 ",test_c2), & + new_unittest("symmetry c2h ",test_c2h), & + new_unittest("symmetry c2v ",test_c2v), & + new_unittest("symmetry c3 ",test_c3), & + new_unittest("symmetry c3v ",test_c3v), & + new_unittest("symmetry c4v ",test_c4v), & + new_unittest("symmetry c5 ",test_c5), & + new_unittest("symmetry c5v ",test_c5v), & + new_unittest("symmetry cinfv ",test_cinfv), & + new_unittest("symmetry d2 ",test_d2), & + new_unittest("symmetry d2d ",test_d2d), & + new_unittest("symmetry d2h ",test_d2h), & + new_unittest("symmetry d3 ",test_d3), & + new_unittest("symmetry d3d ",test_d3d), & + new_unittest("symmetry d3h ",test_d3h), & + new_unittest("symmetry d4 ",test_d4), & + new_unittest("symmetry d4h ",test_d4h), & + new_unittest("symmetry d5d ",test_d5d), & + new_unittest("symmetry d5h ",test_d5h), & + new_unittest("symmetry d6h ",test_d6h), & + new_unittest("symmetry d7h ",test_d7h), & + new_unittest("symmetry d8h ",test_d8h), & + new_unittest("symmetry dinfh ",test_dinfh), & + new_unittest("symmetry s4 ",test_s4), & + new_unittest("symmetry td ",test_td), & + new_unittest("symmetry oh ",test_oh), & + new_unittest("symmetry ih ",test_ih) & + ] +!&> + end subroutine collect_getsym + +!========================================================================================! + + subroutine test_c1(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_c1,at_c1,xyz_c1,sfsym) + if (sfsym /= 'c1 ') call test_failed(error,'expected c1 , got: '//sfsym) + end subroutine test_c1 + + subroutine test_ci(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_ci,at_ci,xyz_ci,sfsym) + if (sfsym /= 'ci ') call test_failed(error,'expected ci , got: '//sfsym) + end subroutine test_ci + + subroutine test_cs(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_cs,at_cs,xyz_cs,sfsym) + if (sfsym /= 'cs ') call test_failed(error,'expected cs , got: '//sfsym) + end subroutine test_cs + + subroutine test_c2(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_c2,at_c2,xyz_c2,sfsym) + if (sfsym /= 'c2 ') call test_failed(error,'expected c2 , got: '//sfsym) + end subroutine test_c2 + + subroutine test_c2h(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_c2h,at_c2h,xyz_c2h,sfsym) + if (sfsym /= 'c2h') call test_failed(error,'expected c2h, got: '//sfsym) + end subroutine test_c2h + + subroutine test_c2v(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_c2v,at_c2v,xyz_c2v,sfsym) + if (sfsym /= 'c2v') call test_failed(error,'expected c2v, got: '//sfsym) + end subroutine test_c2v + + subroutine test_c3(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_c3,at_c3,xyz_c3,sfsym) + if (sfsym /= 'c3 ') call test_failed(error,'expected c3 , got: '//sfsym) + end subroutine test_c3 + + subroutine test_c3v(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_c3v,at_c3v,xyz_c3v,sfsym) + if (sfsym /= 'c3v') call test_failed(error,'expected c3v, got: '//sfsym) + end subroutine test_c3v + + subroutine test_c4v(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_c4v,at_c4v,xyz_c4v,sfsym) + if (sfsym /= 'c4v') call test_failed(error,'expected c4v, got: '//sfsym) + end subroutine test_c4v + + subroutine test_c5(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_c5,at_c5,xyz_c5,sfsym) + if (sfsym /= 'c5 ') call test_failed(error,'expected c5 , got: '//sfsym) + end subroutine test_c5 + + subroutine test_c5v(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_c5v,at_c5v,xyz_c5v,sfsym) + if (sfsym /= 'c5v') call test_failed(error,'expected c5v, got: '//sfsym) + end subroutine test_c5v + + subroutine test_cinfv(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_cinfv,at_cinfv,xyz_cinfv,sfsym) + if (sfsym /= 'cin') call test_failed(error,'expected cin, got: '//sfsym) + end subroutine test_cinfv + + subroutine test_d2(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_d2,at_d2,xyz_d2,sfsym) + if (sfsym /= 'd2 ') call test_failed(error,'expected d2 , got: '//sfsym) + end subroutine test_d2 + + subroutine test_d2d(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_d2d,at_d2d,xyz_d2d,sfsym) + if (sfsym /= 'd2d') call test_failed(error,'expected d2d, got: '//sfsym) + end subroutine test_d2d + + subroutine test_d2h(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_d2h,at_d2h,xyz_d2h,sfsym) + if (sfsym /= 'd2h') call test_failed(error,'expected d2h, got: '//sfsym) + end subroutine test_d2h + + subroutine test_d3(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_d3,at_d3,xyz_d3,sfsym) + if (sfsym /= 'd3 ') call test_failed(error,'expected d3 , got: '//sfsym) + end subroutine test_d3 + + subroutine test_d3d(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_d3d,at_d3d,xyz_d3d,sfsym) + if (sfsym /= 'd3d') call test_failed(error,'expected d3d, got: '//sfsym) + end subroutine test_d3d + + subroutine test_d3h(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_d3h,at_d3h,xyz_d3h,sfsym) + if (sfsym /= 'd3h') call test_failed(error,'expected d3h, got: '//sfsym) + end subroutine test_d3h + + subroutine test_d4(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_d4,at_d4,xyz_d4,sfsym) + if (sfsym /= 'd4 ') call test_failed(error,'expected d4 , got: '//sfsym) + end subroutine test_d4 + + subroutine test_d4h(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_d4h,at_d4h,xyz_d4h,sfsym) + if (sfsym /= 'd4h') call test_failed(error,'expected d4h, got: '//sfsym) + end subroutine test_d4h + + subroutine test_d5d(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_d5d,at_d5d,xyz_d5d,sfsym) + if (sfsym /= 'd5d') call test_failed(error,'expected d5d, got: '//sfsym) + end subroutine test_d5d + + subroutine test_d5h(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_d5h,at_d5h,xyz_d5h,sfsym) + if (sfsym /= 'd5h') call test_failed(error,'expected d5h, got: '//sfsym) + end subroutine test_d5h + + subroutine test_d6h(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_d6h,at_d6h,xyz_d6h,sfsym) + if (sfsym /= 'd6h') call test_failed(error,'expected d6h, got: '//sfsym) + end subroutine test_d6h + + subroutine test_d7h(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_d7h,at_d7h,xyz_d7h,sfsym) + if (sfsym /= 'd7h') call test_failed(error,'expected d7h, got: '//sfsym) + end subroutine test_d7h + + subroutine test_d8h(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_d8h,at_d8h,xyz_d8h,sfsym) + if (sfsym /= 'd8h') call test_failed(error,'expected d8h, got: '//sfsym) + end subroutine test_d8h + + subroutine test_dinfh(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_dinfh,at_dinfh,xyz_dinfh,sfsym) + if (sfsym /= 'din') call test_failed(error,'expected din, got: '//sfsym) + end subroutine test_dinfh + + subroutine test_s4(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_s4,at_s4,xyz_s4,sfsym) + if (sfsym /= 's4 ') call test_failed(error,'expected s4 , got: '//sfsym) + end subroutine test_s4 + + subroutine test_td(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_td,at_td,xyz_td,sfsym) + if (sfsym /= 'td ') call test_failed(error,'expected td , got: '//sfsym) + end subroutine test_td + + subroutine test_oh(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_oh,at_oh,xyz_oh,sfsym) + if (sfsym /= 'oh ') call test_failed(error,'expected oh , got: '//sfsym) + end subroutine test_oh + + subroutine test_ih(error) + type(error_type),allocatable,intent(out) :: error + character(len=3) :: sfsym + call getsym(.false.,6,nat_ih,at_ih,xyz_ih,sfsym) + if (sfsym /= 'ih ') call test_failed(error,'expected ih , got: '//sfsym) + end subroutine test_ih + +end module test_getsym From 1595bba28a6e02990f410764344b87c6691ce536 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 18 Mar 2026 23:42:13 +0100 Subject: [PATCH 245/374] prepare nicer dry-run printout --- src/algos/CMakeLists.txt | 1 + src/algos/dryrun.f90 | 220 ++++++++++++++++++++++++++++++++ src/algos/meson.build | 1 + src/calculator/calc_type.f90 | 15 ++- src/classes.f90 | 1 + src/crest_main.f90 | 2 +- src/printouts.f90 | 235 +++-------------------------------- 7 files changed, 248 insertions(+), 227 deletions(-) create mode 100644 src/algos/dryrun.f90 diff --git a/src/algos/CMakeLists.txt b/src/algos/CMakeLists.txt index dc4f2dff..96d3e7fd 100644 --- a/src/algos/CMakeLists.txt +++ b/src/algos/CMakeLists.txt @@ -37,6 +37,7 @@ list(APPEND srcs "${dir}/deform_opt_hess.f90" "${dir}/queueing.f90" "${dir}/alkylize.f90" + "${dir}/dryrun.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/algos/dryrun.f90 b/src/algos/dryrun.f90 new file mode 100644 index 00000000..222646cf --- /dev/null +++ b/src/algos/dryrun.f90 @@ -0,0 +1,220 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2026 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +subroutine crest_dry_run(env,tim) +!******************************************************************** +!* Dry-run runtype. Prints a formatted summary of all CREST settings +!* and exits cleanly without performing any calculations. +!* +!* Input/Output: +!* env - crest's systemdata object +!* tim - timer object +!******************************************************************** + use crest_parameters + use crest_data + use crest_calculator + use iomod + implicit none + type(systemdata),intent(inout) :: env + type(timer),intent(inout) :: tim + character(len=512) :: dumstr + character(len=:),allocatable :: ctmp + logical :: ex +!========================================================================================! + + write (stdout,*) + call drawbox(stdout,'D R Y R U N',charset=6,width=80) + write (stdout,'(1x,a)') 'Dry run was requested.' + write (stdout,'(1x,a)') 'Running CREST with the chosen arguments would result in the following settings:' + write (stdout,*) + +!========================================================================================! +!> INPUT FILE +!========================================================================================! + call drawbox(stdout,'Input',charset=4,padl=2,padr=2) + write (stdout,*) + ex = file_exists(env%inputcoords) + write (stdout,'(2x,a,a)',advance='no') 'Input file : ',trim(env%inputcoords) + if (ex) then + write (stdout,*) + else + write(stdout,'(1x,"( ",a," )")') colorify('NOT FOUND','red') + end if + write (stdout,*) + +!========================================================================================! +!> RUNTYPE +!========================================================================================! + call drawbox(stdout,'Job type',charset=4,padl=2,padr=2) + write (stdout,*) + select case (env%crestver) + case (crest_mfmdgc) + write (stdout,'(2x,a)') 'Conformational search via the MF-MD-GC algorithm ('//colorify("DEPRECATED",'red')//')' + case (crest_imtd) + write (stdout,'(2x,a)') 'Conformational search via the iMTD-GC algorithm' + case (crest_imtd2) + write (stdout,'(2x,a)') 'Conformational search via the iMTD-sMTD algorithm (-v4)' + case (crest_mdopt) + write (stdout,'(2x,a)') 'Ensemble reoptimization (-mdopt)' + case (crest_mdopt2) + write (stdout,'(2x,a)') 'Ensemble reoptimization, variant 2 (-mdopt2)' + case (crest_screen) + write (stdout,'(2x,a)') 'Ensemble screening and reoptimization (-screen)' + case (crest_nano) + write (stdout,'(2x,a)') 'GFNn-xTB nano reactor (-reactor)' + case (crest_sp) + write (stdout,'(2x,a)') 'Standalone singlepoint calculation' + case (crest_optimize) + write (stdout,'(2x,a)') 'Standalone geometry optimization' + case (crest_moldyn) + write (stdout,'(2x,a)') 'Standalone molecular dynamics simulation' + case (crest_s1) + write (stdout,'(2x,a)') 'Conformational search (crest_s1)' + case (crest_mecp) + write (stdout,'(2x,a)') 'Minimum energy crossing point (MECP) search' + case (crest_numhessian) + write (stdout,'(2x,a)') 'Numerical Hessian calculation' + case (crest_scanning) + write (stdout,'(2x,a)') 'Coordinate scan' + case (crest_rigcon) + write (stdout,'(2x,a)') 'Rule-based conformer generation' + case (crest_sorting) + write (stdout,'(2x,a)') 'Standalone ensemble sorting (CREGEN)' + case (crest_bh) + write (stdout,'(2x,a)') 'Basin-hopping conformer search' + case (crest_bhpt) + write (stdout,'(2x,a)') 'Basin-hopping with parallel tempering' + case (crest_none) + write (stdout,'(2x,a)') '' + case default + write (stdout,'(2x,a,i0,a)') '' + end select + write (stdout,*) + +!========================================================================================! +!> CALCULATION SETTINGS +!========================================================================================! + call drawbox(stdout,'Calculation settings',charset=4,padl=2,padr=2) + write (stdout,*) + if (associated(env%calc)) then + if (env%calc%ncalculations > 0) then + call env%calc%info(stdout,printhdr=.false.) + else + write (stdout,'(2x,a)') 'Calculation object associated but no levels defined yet.' + end if + else + write (stdout,'(2x,a)') 'Calculation object not associated (legacy mode or not yet set up).' + end if + write (stdout,*) + +!========================================================================================! +!> OPTIMIZATION SETTINGS +!========================================================================================! + call drawbox(stdout,'Optimization settings',charset=4,padl=2,padr=2) + write (stdout,*) + write (stdout,'(2x,a,t35,": ",a,1x,"(",i0,")")') 'Optimization level',optlevflag(env%optlev),nint(env%optlev) + if (associated(env%calc)) then + write (stdout,'(2x,a,t35,": ",i0)') 'Max cycles (calc obj)',env%calc%maxcycle + write (stdout,'(2x,a,t35,": ",es12.4)') 'Energy convergence [Eh]',env%calc%ethr_opt + write (stdout,'(2x,a,t35,": ",es12.4)') 'Gradient convergence [Eh/a0]',env%calc%gthr_opt + end if + write (stdout,*) + +!========================================================================================! +!> MD / MTD SETTINGS +!========================================================================================! + call drawbox(stdout,'MD / MTD settings',charset=4,padl=2,padr=2) + write (stdout,*) + if (env%mdtime > 0.0_wp) then + write (stdout,'(2x,a,t35,": ",f10.1,a)') 'Simulation length',env%mdtime,' ps' + else + write (stdout,'(2x,a,t35,": ",a)') 'Simulation length','' + end if + write (stdout,'(2x,a,t35,": ",f10.1,a)') 'Time step',env%mdstep,' fs' + write (stdout,'(2x,a,t35,": ",i10)') 'SHAKE mode',env%shake + write (stdout,'(2x,a,t35,": ",f10.2,a)') 'MD temperature',env%mdtemp,' K' + write (stdout,'(2x,a,t35,": ",i10,a)') 'Trajectory dump step',env%mddumpxyz,' fs' + write (stdout,'(2x,a,t35,": ",f10.1,a)') 'MTD Vbias dump',real(env%mddump,wp)/1000.0_wp,' ps' + if (env%mddat%length_ps > 0.0_wp) then + write (stdout,*) + write (stdout,'(2x,a)') 'mddata object (modern MD runtype):' + write (stdout,'(4x,a,t35,": ",f10.1)') 'length_ps',env%mddat%length_ps + write (stdout,'(4x,a,t35,": ",f10.4)') 'tstep [fs]',env%mddat%tstep + write (stdout,'(4x,a,t35,": ",f10.2)') 'T_soll',env%mddat%tsoll + write (stdout,'(4x,a,t35,": ",l6)') 'SHAKE',env%mddat%shake + write (stdout,'(4x,a,t35,": ",a)') 'thermostat',trim(env%mddat%thermotype) + end if + write (stdout,*) + +!========================================================================================! +!> THERMODYNAMICS SETTINGS +!========================================================================================! + call drawbox(stdout,'Thermodynamics settings',charset=4,padl=2,padr=2) + write (stdout,*) + select case (env%thermo%emodel) + case ('grimme') + ctmp = 'Grimme (2012)' + case ('truhlar') + ctmp = 'Truhlar (2011)' + end select + write (stdout,'(2x,a,t35,": ",a15)') 'Vibrational entropy model',ctmp + write (stdout,'(2x,a,t35,": ",f10.2,a)') 'Imaginary freq. threshold',env%thermo%ithr,' cm^-1' + write (stdout,'(2x,a,t35,": ",f10.4)') 'Frequency scaling factor',env%thermo%fscal + write (stdout,'(2x,a,t35,": ",f10.2,a)') 'Rot/vib interpolation threshold',env%thermo%sthr,' cm^-1' + write (stdout,'(2x,a,t35,": ",f6.2,a,f6.2,a,f6.2)') & + & 'T range [K] (start/end/step)', & + & env%thermo%trange(1),'/',env%thermo%trange(2),'/',env%thermo%trange(3) + write (stdout,'(2x,a,t35,": ",i10)') 'Number of temperature points : ',env%thermo%ntemps + write (stdout,*) + +!========================================================================================! +!> SORTING / CREGEN SETTINGS +!========================================================================================! + call drawbox(stdout,'Sorting / CREGEN settings',charset=4,padl=2,padr=2) + write (stdout,*) + write (stdout,'(2x,a,t35,": ",f10.4,a)') 'Energy window ',env%ewin,' kcal/mol' + write (stdout,'(2x,a,t35,": ",f10.4,a)') 'RTHR (RMSD threshold) ',env%rthr,' Å' + write (stdout,'(2x,a,t35,": ",f10.4,a)') 'ETHR (energy threshold)',env%ethr,' kcal/mol' + write (stdout,'(2x,a,t35,": ",f10.2,a)') 'BTHR (rot. threshold) ',env%bthr2*100.0d0,' %' + write (stdout,'(2x,a,t35,": ",f10.2)') 'Boltzmann temperature ',env%tboltz + write (stdout,'(2x,a,t35,": ",l6)') 'Heavy-atom RMSD only ',env%heavyrmsd + write (stdout,'(2x,a,t35,": ",l6)') 'Topology check in CREGEN',env%checktopo + write (stdout,*) + +!========================================================================================! +!> TECHNICAL SETTINGS +!========================================================================================! + call drawbox(stdout,'Technical settings',charset=4,padl=2,padr=2) + write (stdout,*) + call getcwd(dumstr) + write (stdout,'(2x,a,t25,": ",a)') 'Working directory',trim(dumstr) + write (stdout,'(2x,a,t25,": ",i0)') 'CPUs / threads',env%threads + write (stdout,*) + +!========================================================================================! +!> CREST BINARY METADATA (always last) +!========================================================================================! + call drawbox(stdout,'CREST binary info',charset=4,padl=2,padr=2) + write (stdout,*) + call print_crest_metadata() + write (stdout,*) + +!========================================================================================! + call creststop(status_normal) +end subroutine crest_dry_run diff --git a/src/algos/meson.build b/src/algos/meson.build index e944215c..025612af 100644 --- a/src/algos/meson.build +++ b/src/algos/meson.build @@ -35,4 +35,5 @@ srcs += files( 'queueing.f90', 'alkylize.f90', 'deform_opt_hess.f90', + 'dryrun.f90', ) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 7b235843..76aa0073 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -930,19 +930,24 @@ end subroutine calculation_ONIOMexpand !========================================================================================! - subroutine calculation_info(self,iunit) + subroutine calculation_info(self,iunit,printhdr) implicit none class(calcdata) :: self integer,intent(in) :: iunit + logical,intent(in),optional :: printhdr integer :: i,j character(len=*),parameter :: fmt1 = '(1x,a20," : ",i5)' character(len=*),parameter :: fmt2 = '(1x,a20," : ",f12.5)' character(len=20) :: atmp integer :: constraintype(8) - - write (iunit,'(1x,a)') '----------------' - write (iunit,'(1x,a)') 'Calculation info' - write (iunit,'(1x,a)') '----------------' + logical :: prhdr + + prhdr=.true.; if(present(printhdr)) prhdr = printhdr + if(prhdr)then + write (iunit,'(1x,a)') '----------------' + write (iunit,'(1x,a)') 'Calculation info' + write (iunit,'(1x,a)') '----------------' + endif if (self%ncalculations <= 0) then write (iunit,'("> ",a)') 'No calculation levels set up!' else if (self%ncalculations > 1) then diff --git a/src/classes.f90 b/src/classes.f90 index 066d39ba..7bcd7e18 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -90,6 +90,7 @@ module crest_data integer,parameter,public :: crest_ensemblesp = 273 integer,parameter,public :: crest_bh = 274 integer,parameter,public :: crest_bhpt = 275 + integer,parameter,public :: crest_dryrun = 276 !>> < DRY run stop !=========================================================================================! if (env%dryrun) then - call crest_dry(env) + call crest_dry_run(env,tim) end if !=========================================================================================! diff --git a/src/printouts.f90 b/src/printouts.f90 index 34462d17..e6075a4f 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -757,233 +757,26 @@ subroutine print_crest_metadata() !******************************** include 'crest_metadata.fh' integer :: l - write (*,'(2x,a,1x,a)') 'CREST version :',version - write (*,'(2x,a,1x,a)') 'timestamp :',date - write (*,'(2x,a,1x,a)') 'commit :',commit + write (*,'(2x,a,t20,": ",a)') 'CREST version ',version + write (*,'(2x,a,t20,": ",a)') 'timestamp ',date + write (*,'(2x,a,t20,": ",a)') 'commit ',commit if (author(1:2) .eq. "'@") then l = len_trim(author) - write (*,'(2x,a,1x,a)') 'compiled by :',"'usr"//author(2:l) + write (*,'(2x,a,t20,": ",a)') 'compiled by ',"'usr"//author(2:l) else - write (*,'(2x,a,1x,a)') 'compiled by :',author + write (*,'(2x,a,t20,": ",a)') 'compiled by ',author end if - write (*,'(2x,a,1x,a)') 'Fortran compiler :',fcompiler - write (*,'(2x,a,1x,a)') 'C compiler :',ccompiler - write (*,'(2x,a,1x,a)') 'build system :',bsystem - write (*,'(2x,a,1x,a)') '-DWITH_TOMLF :',tomlfvar - write (*,'(2x,a,1x,a)') '-DWITH_GFN0 :',gfn0var - write (*,'(2x,a,1x,a)') '-DWITH_GFNFF :',gfnffvar - write (*,'(2x,a,1x,a)') '-DWITH_TBLITE :',tblitevar - write (*,'(2x,a,1x,a)') '-DWITH_LIBPVOL :',libpvolvar - write (*,'(2x,a,1x,a)') '-DWITH_LWONIOM :',lwoniomvar + write (*,'(2x,a,t20,": ",a)') 'Fortran compiler ',fcompiler + write (*,'(2x,a,t20,": ",a)') 'C compiler ',ccompiler + write (*,'(2x,a,t20,": ",a)') 'build system ',bsystem + write (*,'(2x,a,t20,": ",a)') '-DWITH_TOMLF ',tomlfvar + write (*,'(2x,a,t20,": ",a)') '-DWITH_GFN0 ',gfn0var + write (*,'(2x,a,t20,": ",a)') '-DWITH_GFNFF ',gfnffvar + write (*,'(2x,a,t20,": ",a)') '-DWITH_TBLITE ',tblitevar + write (*,'(2x,a,t20,": ",a)') '-DWITH_LIBPVOL ',libpvolvar + write (*,'(2x,a,t20,": ",a)') '-DWITH_LWONIOM ',lwoniomvar end subroutine print_crest_metadata -!========================================================================================! -!========================================================================================! -!> Confscript dry-run printout -!========================================================================================! -!========================================================================================! -subroutine crest_dry(env) - use iso_fortran_env,wp => real64 - use crest_data - use iomod - implicit none - - type(systemdata),intent(inout) :: env - character(len=1024) :: dumstr - character(len=:),allocatable :: dum - logical :: cregenpr = .false. - logical :: mdsetpr = .false. - logical :: jobpr = .true. - logical :: xtbpr = .true. - logical :: techpr = .true. - - call largehead('D R Y R U N') - write (*,'(1x,a)') 'Dry run was requested.' - write (*,'(1x,a)') 'Running CREST with the chosen cmd arguments will result in the following settings:' - - write (*,'(/,1x,a,a)') 'Input file : ',trim(env%inputcoords) - - write (*,'(/,1x,a)') 'Job type :' - if (env%onlyZsort) then - write (*,'(2x,a)',advance='no') '1.' - write (*,'(2x,a)') 'Standalone use of ZSORT routine.' - xtbpr = .false. - techpr = .false. - jobpr = .false. - else if (env%properties .lt. 0) then - jobpr = .false. - write (*,'(2x,a)',advance='no') '1.' - select case (env%properties) - case (-1) - write (*,'(2x,a)') 'Standalone use of CREGEN sorting routine.' - cregenpr = .true. - xtbpr = .false. - case (-2) - write (*,'(2x,a)') 'Comparison of two conformer-rotamer ensembles' - cregenpr = .true. - xtbpr = .false. - case (-3) - write (*,'(2x,a)') 'Automated protonation' - case (-4) - write (*,'(2x,a)') 'Automated deprotonation' - case (-5) - write (*,'(2x,a)') 'Automated tautomerization' - case (-666) - write (*,'(2x,a)') '"Property" calculation (-prop) for a given ensemble.' - case default - write (*,'(2x,a)') '' - end select - else - cregenpr = .true. - write (*,'(2x,a)',advance='no') '1.' - select case (env%crestver) - case (1) - write (*,'(2x,a)') 'Conformational search via the MF-MD-GC algo' - case (2) - if (env%properties == 45) then - write (*,'(2x,a)') 'Conformational search via the iMTD-sMTD algo' - else if (env%iterativeV2) then - write (*,'(2x,a)') 'Conformational search via the iMTD-GC algo' - else - write (*,'(2x,a)') 'Conformational search via the MTD-GC algo' - end if - mdsetpr = .true. - case (crest_imtd2) - write (*,'(2x,a)') 'Conformational search cia the iMTD-sMTD algo (-v4)' - mdsetpr = .true. - case (3) - write (*,'(2x,a)') 'Reoptimization of all structures in a given ensemble (-mdopt)' - case (4) - write (*,'(2x,a)') 'Reoptimization and sorting of all structures in a given ensemble (-screen)' - case (7) - write (*,'(2x,a)') 'GFNn-xTB nano reactor (-reactor)' - case (crest_pka) - write (*,'(2x,a)') 'GFN2-xTB/ALPB(H2O) pKa calculation (-pka)' - case default - write (*,'(2x,a)') '' - end select - if (env%properties .gt. 0) then - select case (env%properties) - case (45) - write (*,'(2x,a,2x,a)') '2.','Calculation of molecular ensemble entropy (-entropy)' - case default - write (*,'(2x,a,2x,a)') '2.','Additional "property" calculation requested (-prop)' - end select - end if - end if - - if (jobpr) then - write (*,'(/,1x,a)') 'Job settings' - write (*,'(2x,a,l6)') 'sort Z-matrix : ',env%autozsort - if (env%crestver .eq. 2) then - select case (env%runver) - case (2) - write (*,'(2x,a,a)') 'MTD-GC modified mode : ','"-quick"' - case (4) - write (*,'(2x,a,a)') 'MTD-GC modified mode : ','"-nci"' - case (5) - write (*,'(2x,a,a)') 'MTD-GC modified mode : ','"-squick"' - case (6) - write (*,'(2x,a,a)') 'MTD-GC modified mode : ','"-mquick"' - case (111) - write (*,'(2x,a,a)') 'iMTD-sMTD mode : ','"-entropy"' - case default - continue - end select - end if - if (env%properties .gt. 0) then - select case (env%properties) - case (1) - dum = '"hess"' - case (10) - dum = '"ohess"' - case (2) - dum = '"autoIR (GFN)"' - case (20) - dum = '"reopt"' - case (3:7,100) - dum = 'DFT' - case (45) - dum = 'none' - case default - dum = '' - end select - if (dum .ne. 'none') then - write (*,'(2x,a,a)') 'PROP mode (-prop) : ',dum - end if - end if - end if - - if (cregenpr) then - write (*,'(/,1x,a)') 'CRE settings' - write (*,'(2x,a,f10.4)') 'energy window (-ewin) :',env%ewin - write (*,'(2x,a,f10.4)') 'RMSD threshold (-rthr) :',env%rthr !RTHR - RMSD thr in Angstroem - write (*,'(2x,a,f10.4)') 'energy threshold (-ethr) :',env%ethr !ETHR - E threshold in kcal - write (*,'(2x,a,f10.2)') 'rot. const. threshold (-bthr) :',env%bthr2 !BTHR - rot const thr - write (*,'(2x,a,f10.2)') 'T (for boltz. weight) (-temp) :',env%tboltz - end if - - if (mdsetpr) then - write (*,'(/,1x,a)') 'General MD/MTD settings' - if (env%mdtime .gt. 0.0d0) then - write (*,'(2x,a,f10.1)') 'simulation length [ps] (-len) :',env%mdtime - else - write (*,'(2x,a,a)') 'simulation length [ps] (-len) : ','' - end if - write (*,'(2x,a,f10.1)') 'time step [fs] (-tstep) :',env%mdstep - write (*,'(2x,a,i10)') 'shake mode (-shake) :',env%shake - write (*,'(2x,a,f10.2)') 'MTD temperature [K] (-mdtemp) :',env%mdtemp - write (*,'(2x,a,i10)') 'trj dump step [fs] (-mddump) :',env%mddumpxyz - write (*,'(2x,a,f10.1)') 'MTD Vbias dump [ps] (-vbdump) :',real(env%mddump)/1000.0d0 - end if - - if (env%cts%used) then - write (*,'(/,1x,a)') 'Constrainment info' - write (*,'(2x,a,l7)') 'applying constraints? : ',env%cts%used - write (*,'(2x,a,a)') 'constraining file : ',trim(env%constraints) - write (*,'(2x,a)') 'file content :' - call cat_mod(6,' > ',env%constraints,'') - end if - - if (xtbpr) then - if (env%legacy) then - write (*,'(/,1x,a)') 'XTB settings' - write (*,'(2x,a,a)') 'binary name (-xnam) : ',trim(env%ProgName) - call checkbinary(env) - write (*,'(2x,a,a)') 'GFN method (-gfn) : ',trim(env%gfnver) - else - write (*,'(/,1x,a)') 'Calculation settings' - end if - write (*,'(2x,a,i0)') '(final) opt level (-opt) : ',nint(env%optlev) - if (env%gbsa) then - if (index(env%solv,'--alpb') .ne. 0) then - write (*,'(2x,a,a)') 'Implicit solvation (-alpb) : ',trim(env%solvent) - else - write (*,'(2x,a,a)') 'Implicit solvation (-gbsa) : ',trim(env%solvent) - end if - end if - if (env%chrg .ne. 0.0d0) then - write (*,'(2x,a,i0)') 'Molecular charge (-chrg) : ',env%chrg - end if - if (env%uhf .ne. 0) then - write (*,'(2x,a,i0)') 'UHF (nα-nβ elec.) (-uhf) : ',env%uhf - end if - end if - - if (techpr) then - call getcwd(dumstr) - write (*,'(/,1x,a)') 'Technical settings' - write (*,'(2x,a,a)') 'working directory : ',trim(dumstr) - write (*,'(2x,a,i0)') 'CPUs (threads) (-T) : ',env%threads - - end if - - write (*,'(/,1x,a)') 'CREST binary info' - call print_crest_metadata() - - write (*,'(/)') - stop 'normal dry run termination.' -end subroutine crest_dry subroutine cat_mod(ch,pre,fname,post) implicit none From 2778351214c670719f85d24532fd799e0c2f9602 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 19 Mar 2026 01:16:42 +0100 Subject: [PATCH 246/374] start working on getting ifx build to run --- meson.build | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/meson.build b/meson.build index 3da21868..bd2f8a28 100644 --- a/meson.build +++ b/meson.build @@ -42,10 +42,24 @@ inc_dirs = include_directories('include', '.') # ═══════════════════════════════════════════════════════════════════════════════ # OpenMP # ═══════════════════════════════════════════════════════════════════════════════ -omp_dep = dependency('openmp', - required : get_option('openmp'), - language : 'fortran', -) +# ifx (intel-llvm) triggers a Meson bug in dependency('openmp') because its +# preprocessor output lacks the delimiter strings Meson searches for. +# Work around it by constructing the dependency manually for that compiler. +if fc_id == 'intel-llvm' + if get_option('openmp') + omp_dep = declare_dependency( + compile_args : ['-qopenmp'], + link_args : ['-qopenmp'], + ) + else + omp_dep = declare_dependency() + endif +else + omp_dep = dependency('openmp', + required : get_option('openmp'), + language : 'fortran', + ) +endif if omp_dep.found() add_project_arguments('-DWITH_OMP', language : ['c', 'fortran']) endif @@ -60,7 +74,7 @@ _omp_link_dep = (omp_dep.found() and not static_build) ? [omp_dep] : [] # ───────────────────────────────────────────────────────────────────────────── # Fortran compiler │ Recommended provider │ MKL threading layer # ──────────────────┼────────────────────────┼────────────────────── -# gfortran │ OpenBLAS (default) │ mkl_gnu_thread +# gfortran │ OpenBLAS (default) │ mkl_gnu_thread # ifort / ifx │ MKL ← natural match │ mkl_intel_thread # ifort/ifx + gcc C │ MKL │ mkl_intel_thread (Fortran wins) # ───────────────────────────────────────────────────────────────────────────── From b7efe128832c7652003aa99f772bd2db39e05522 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 19 Mar 2026 22:54:00 +0100 Subject: [PATCH 247/374] Initial version that can build an intel-llvm binary with meson --- .gitignore | 2 ++ config/meson.build | 18 ++++++++++++++++- meson.build | 1 + src/iomod.F90 | 4 ++-- src/meson.build | 2 +- src/signal.c | 8 ++++++++ src/{sigterm.f90 => sigterm.F90} | 34 +++++++++++++++++++++++++++----- subprojects/fmlip_relay | 2 +- subprojects/gfn0 | 2 +- subprojects/gfnff | 2 +- subprojects/pvol | 2 +- test/meson.build | 1 + 12 files changed, 65 insertions(+), 13 deletions(-) rename src/{sigterm.f90 => sigterm.F90} (74%) diff --git a/.gitignore b/.gitignore index 58971623..77dcaf67 100644 --- a/.gitignore +++ b/.gitignore @@ -4,6 +4,8 @@ *.i90 *.bak *__genmod.f90 +.s* +.c* github_bin/ build_majestix build_commands diff --git a/config/meson.build b/config/meson.build index 04f6812b..379ad481 100644 --- a/config/meson.build +++ b/config/meson.build @@ -93,11 +93,11 @@ if fc_id == 'intel-llvm' add_project_arguments( '-r8', '-align', 'array64byte', - '-traceback', language : 'fortran', ) if _is_debug add_project_arguments( + '-traceback', '-check', 'all', '-fpe0', language : 'fortran', @@ -105,6 +105,22 @@ if fc_id == 'intel-llvm' endif endif +if fc_id == 'intel-llvm' + # -lifport : POSIX intrinsics (getcwd, chdir, …) not auto-linked by ifx. + # libgcc_s : was previously added to supply _Unwind_* symbols for libifcore's + # signal handler. No longer needed since signal registration was + # moved to crest_install_signal() via ISO_C_BINDING, bypassing + # libifcore's handler entirely. + #_libgcc_s = run_command('gcc', '-print-file-name=libgcc_s.so', + # check : false).stdout().strip() + #_gcc_s_link = (_libgcc_s != 'libgcc_s.so') ? [_libgcc_s] : [] + #if _gcc_s_link.length() == 0 + # warning('intel-llvm: libgcc_s.so not found — _Unwind_* symbols will be NULL, ' + + # 'Intel Fortran runtime will SIGSEGV at startup.') + #endif + add_project_link_arguments(['-lifport'], language : 'fortran') +endif + # ═══════════════════════════════════════════════════════════════════════════════ # Static-binary link arguments # ═══════════════════════════════════════════════════════════════════════════════ diff --git a/meson.build b/meson.build index bd2f8a28..bc3077b7 100644 --- a/meson.build +++ b/meson.build @@ -345,6 +345,7 @@ executable( include_directories : inc_dirs, link_with : lib_crest, dependencies : [lapack_dep, blas_dep] + _omp_link_dep + _optional_deps + _quadmath_dep, + link_language : 'fortran', install : true, ) diff --git a/src/iomod.F90 b/src/iomod.F90 index 9c8a4034..7823bfcb 100644 --- a/src/iomod.F90 +++ b/src/iomod.F90 @@ -781,7 +781,7 @@ end function file_exists function directory_exist(file) result(exist) character(len=*),intent(in) :: file logical :: exist -#ifdef __INTEL_COMPILER +#if defined(__INTEL_COMPILER) || defined(__INTEL_LLVM_COMPILER) !> Intel provides the directory extension to inquire to handle this case inquire (directory=file,exist=exist) #else @@ -804,7 +804,7 @@ function myisatty(channel) result(term) implicit none integer,intent(in) :: channel logical :: term -#ifdef __INTEL_COMPILER +#if defined(__INTEL_COMPILER) || defined(__INTEL_LLVM_COMPILER) logical,external :: isatty #endif term = isatty(channel) diff --git a/src/meson.build b/src/meson.build index 1e5a7ca3..ef01a3ec 100644 --- a/src/meson.build +++ b/src/meson.build @@ -67,7 +67,7 @@ srcs += files( 'sdfio.f90', 'select.f90', 'signal.c', - 'sigterm.f90', + 'sigterm.F90', 'strucreader.f90', 'symmetry_i.f90', 'timer.f90', diff --git a/src/signal.c b/src/signal.c index d6a4007e..9954719d 100644 --- a/src/signal.c +++ b/src/signal.c @@ -14,3 +14,11 @@ void signal_( int* signum, sighandler_t handler) { signal(*signum, handler); } + +/* Called from Fortran via ISO_C_BINDING for ifx builds. + * handler is a BIND(C) Fortran subroutine with no dummy arguments; + * the int signum passed by the OS is silently ignored. */ +void crest_install_signal(int signum, void (*handler)(void)) +{ + signal(signum, (sighandler_t)handler); +} diff --git a/src/sigterm.f90 b/src/sigterm.F90 similarity index 74% rename from src/sigterm.f90 rename to src/sigterm.F90 index 95ca5f2d..405d7976 100644 --- a/src/sigterm.f90 +++ b/src/sigterm.F90 @@ -54,7 +54,7 @@ end subroutine creststop !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC! !================================================================================! -subroutine wsigint !> Ctrl+C +subroutine wsigint() bind(C, name="crest_wsigint") !> Ctrl+C use crest_parameters,only:stderr,stdout use crest_restartlog,only:dump_restart use ConfSolv_module @@ -67,7 +67,7 @@ subroutine wsigint !> Ctrl+C error stop end subroutine wsigint -subroutine wsigquit !> Ctrl+D or Ctrl+\ +subroutine wsigquit() bind(C, name="crest_wsigquit") !> Ctrl+D or Ctrl+\ use crest_parameters,only:stderr,stdout use crest_restartlog,only:dump_restart use ConfSolv_module @@ -80,7 +80,7 @@ subroutine wsigquit !> Ctrl+D or Ctrl+\ error stop end subroutine wsigquit -subroutine wsigterm !> Recieved by the "kill" pid command +subroutine wsigterm() bind(C, name="crest_wsigterm") !> Recieved by the "kill" pid command use crest_parameters,only:stderr,stdout use crest_restartlog,only:dump_restart use ConfSolv_module @@ -93,7 +93,7 @@ subroutine wsigterm !> Recieved by the "kill" pid command error stop end subroutine wsigterm -subroutine wsigkill +subroutine wsigkill() bind(C, name="crest_wsigkill") use crest_parameters,only:stderr,stdout use crest_restartlog,only:dump_restart use ConfSolv_module @@ -105,16 +105,40 @@ subroutine wsigkill end subroutine wsigkill subroutine initsignal() +#if defined(__INTEL_LLVM_COMPILER) + ! ifx: libifport's SIGNAL intrinsic crashes with ifx procedure thunks. + ! Register handlers via ISO_C_BINDING → crest_install_signal() in signal.c. + use iso_c_binding, only: c_int, c_funloc, c_funptr + implicit none + interface + subroutine crest_install_signal(signum, handler) & + bind(C, name='crest_install_signal') + import :: c_int, c_funptr + integer(c_int), value :: signum + type(c_funptr), value :: handler + end subroutine + subroutine wsigint() bind(C, name='crest_wsigint') + end subroutine + subroutine wsigquit() bind(C, name='crest_wsigquit') + end subroutine + subroutine wsigterm() bind(C, name='crest_wsigterm') + end subroutine + end interface + call crest_install_signal(2_c_int, c_funloc(wsigint)) + call crest_install_signal(3_c_int, c_funloc(wsigquit)) + call crest_install_signal(15_c_int, c_funloc(wsigterm)) + ! SIGKILL (9) cannot be caught; signal 69 is invalid — omit both. +#else external :: wSIGINT external :: wSIGTERM external :: wSIGKILL external :: wSIGQUIT - call signal(2,wSIGINT) call signal(3,wSIGQUIT) call signal(9,wSIGKILL) call signal(15,wSIGTERM) call signal(69,wSIGINT) +#endif end subroutine initsignal diff --git a/subprojects/fmlip_relay b/subprojects/fmlip_relay index 5cd56f3f..2907e4a3 160000 --- a/subprojects/fmlip_relay +++ b/subprojects/fmlip_relay @@ -1 +1 @@ -Subproject commit 5cd56f3f4b2ab8607f5132b00abb77b849640647 +Subproject commit 2907e4a352b3de7e6536c370f9ba50ae71c1928c diff --git a/subprojects/gfn0 b/subprojects/gfn0 index a2f0bcee..8e3f093d 160000 --- a/subprojects/gfn0 +++ b/subprojects/gfn0 @@ -1 +1 @@ -Subproject commit a2f0bcee8b8fa86517b53b085b92a86294937db8 +Subproject commit 8e3f093d6e9b5f2d98f39ddb0651eb5806b75a0e diff --git a/subprojects/gfnff b/subprojects/gfnff index 0c16f5fc..2022cda6 160000 --- a/subprojects/gfnff +++ b/subprojects/gfnff @@ -1 +1 @@ -Subproject commit 0c16f5fc6d599d3b169c6df2d348c61140249744 +Subproject commit 2022cda6b5965f44656973d14ea0ecd35855a836 diff --git a/subprojects/pvol b/subprojects/pvol index 5ed51340..7ec28b71 160000 --- a/subprojects/pvol +++ b/subprojects/pvol @@ -1 +1 @@ -Subproject commit 5ed51340f0ec4529a3c1f25815ce18c78c4970c5 +Subproject commit 7ec28b718af51644a6863e12e7d983bffe7ba6fb diff --git a/test/meson.build b/test/meson.build index 8a535e7d..012f05da 100644 --- a/test/meson.build +++ b/test/meson.build @@ -28,6 +28,7 @@ crest_tester = executable( link_with : lib_crest, dependencies : [testdrive_dep, lapack_dep, blas_dep] + _omp_link_dep + _optional_deps, + link_language : 'fortran', ) foreach t : tests From 975848ee661c8fc4791a3e38cfebb49608ba4114 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 19 Mar 2026 23:33:44 +0100 Subject: [PATCH 248/374] Modify MD test to be compiler portable --- src/CMakeLists.txt | 2 +- src/dynamics/dynamics_module.f90 | 4 +++ test/test_molecular_dynamics.F90 | 46 ++++++++++++++++++++++---------- 3 files changed, 37 insertions(+), 15 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 9fb972b7..949941c4 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -70,7 +70,7 @@ list(APPEND srcs "${dir}/sdfio.f90" "${dir}/select.f90" "${dir}/signal.c" - "${dir}/sigterm.f90" + "${dir}/sigterm.F90" "${dir}/strucreader.f90" "${dir}/symmetry_i.f90" "${dir}/timer.f90" diff --git a/src/dynamics/dynamics_module.f90 b/src/dynamics/dynamics_module.f90 index 1669ccc2..371dbb10 100644 --- a/src/dynamics/dynamics_module.f90 +++ b/src/dynamics/dynamics_module.f90 @@ -78,6 +78,7 @@ module dynamics_module type(shakedata) :: shk !> SHAKE bond information real(wp) :: tsoll = 0.0_wp !298.15_wp !> wanted temperature + real(wp) :: Tavg = 0.0_wp !> trajectory-average temperature (set after dynamics()) logical :: thermostat = .true. !> apply thermostat? character(len=64) :: thermotype = 'berendsen' real(wp) :: thermo_damp = 500.0_wp !> thermostat damping parameter @@ -507,6 +508,9 @@ subroutine dynamics(mol,dat,calc,pr,term) end select end if +!>--- store trajectory-average temperature for callers + dat%Tavg = tav/float(t) + !>--- deallocate data deallocate (dat%blockrege,dat%blockt,dat%blocke) deallocate (mass,acc,veln) diff --git a/test/test_molecular_dynamics.F90 b/test/test_molecular_dynamics.F90 index 00d0f284..8239bf5c 100644 --- a/test/test_molecular_dynamics.F90 +++ b/test/test_molecular_dynamics.F90 @@ -64,8 +64,6 @@ subroutine test_md_shake_off(error) integer :: io logical :: pr - real(wp),parameter :: e_ref = -0.6272508_wp - !> setup calculator backend call sett%create('gfnff') call calc%add(sett) @@ -76,6 +74,7 @@ subroutine test_md_shake_off(error) !> MD setup pr = .false. io = 0 + mdyn%length_ps = 200.0_wp call mdyn%defaults() mdyn%shake = .false. mdyn%restart = .true. !> turn on restart reading (for determinic results) @@ -92,7 +91,8 @@ subroutine test_md_shake_off(error) !> checks call check(error,io,0) if (allocated(error)) return - call check(error,mol%energy,e_ref,thr=1e-6_wp) + !> Average temperature must be within ±50 K of thermostat target (compiler-portable) + call check(error,mdyn%Tavg,mdyn%tsoll,thr=50.0_wp) if (allocated(error)) return end subroutine test_md_shake_off @@ -104,10 +104,9 @@ subroutine test_md_shake_on(error) type(calculation_settings) :: sett type(coord) :: mol type(mddata) :: mdyn - integer :: io + integer :: io,i,ia,ib logical :: wr,pr - - real(wp),parameter :: e_ref = -0.57741556160488028_wp + real(wp) :: d !> setup calculator backend call sett%create('gfnff') @@ -117,8 +116,10 @@ subroutine test_md_shake_on(error) call get_testmol('methane',mol) !> MD setup - pr = .false. + pr = .true. io = 0 + mdyn%length_ps = 50.0_wp + mdyn%Tsoll = 450.0_wp call mdyn%defaults() mdyn%shake = .true. mdyn%restart = .true. !> turn on restart reading (for determinic results) @@ -135,8 +136,17 @@ subroutine test_md_shake_on(error) !> checks call check(error,io,0) if (allocated(error)) return - call check(error,mol%energy,e_ref,thr=1e-6_wp) + !> Average temperature must be within ±50 K of thermostat target (compiler-portable) + call check(error,mdyn%Tavg,mdyn%tsoll,thr=50.0_wp) if (allocated(error)) return + !> SHAKE: all constrained bonds must satisfy their target lengths + do i = 1,mdyn%shk%ncons + ia = mdyn%shk%conslist(1,i) + ib = mdyn%shk%conslist(2,i) + d = norm2(mol%xyz(:,ia)-mol%xyz(:,ib)) + call check(error,d**2,mdyn%shk%distcons(i),thr=1e-4_wp) + if (allocated(error)) return + end do end subroutine test_md_shake_on !========================================================================================! @@ -148,10 +158,9 @@ subroutine test_md_shake_honly(error) type(coord) :: mol type(mddata) :: mdyn - integer :: io + integer :: io,i,ia,ib logical :: wr,pr - - real(wp),parameter :: e_ref = -4.6456536819174667_wp + real(wp) :: d !> setup calculator backend call sett%create('gfnff') @@ -163,11 +172,11 @@ subroutine test_md_shake_honly(error) !> MD setup pr = .false. io = 0 - mdyn%length_ps=5.0_wp !> shorter runtime because the mol is larger + mdyn%length_ps=50.0_wp !> shorter runtime because the mol is larger call mdyn%defaults() mdyn%shake = .true. mdyn%shk%shake_mode=1 - mdyn%restart = .true. !> turn on restart reading (for determinic results)_wp !> shorter runtime because the mol is larger + mdyn%restart = .true. !> turn on restart reading (for determinic results) mdyn%wrtrj = .false. !> turn off trajectory dump call write_fake_restart(mol,mdyn%restartfile) @@ -181,8 +190,17 @@ subroutine test_md_shake_honly(error) !> checks call check(error,io,0) if (allocated(error)) return - call check(error,mol%energy,e_ref,thr=1e-6_wp) + !> Average temperature must be within ±50 K of thermostat target (compiler-portable) + call check(error,mdyn%Tavg,mdyn%tsoll,thr=50.0_wp) if (allocated(error)) return + !> SHAKE: all constrained bonds must satisfy their target lengths + do i = 1,mdyn%shk%ncons + ia = mdyn%shk%conslist(1,i) + ib = mdyn%shk%conslist(2,i) + d = norm2(mol%xyz(:,ia)-mol%xyz(:,ib)) + call check(error,d**2,mdyn%shk%distcons(i),thr=1e-4_wp) + if (allocated(error)) return + end do end subroutine test_md_shake_honly subroutine write_fake_restart(mol,restartfile) From 59099adc8e5fca98cd11456f2d21a92b6e7b33fa Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 19 Mar 2026 23:57:18 +0100 Subject: [PATCH 249/374] Cleanup fixes --- src/sigterm.F90 | 206 +++++++++++++++++-------------- test/test_molecular_dynamics.F90 | 2 +- 2 files changed, 111 insertions(+), 97 deletions(-) diff --git a/src/sigterm.F90 b/src/sigterm.F90 index 405d7976..9d4d3551 100644 --- a/src/sigterm.F90 +++ b/src/sigterm.F90 @@ -23,27 +23,26 @@ subroutine creststop(io) implicit none integer,intent(in) :: io - call graceful_shutdowns() - select case(io) + select case (io) case (status_normal) write (stdout,*) 'CREST terminated normally.' case default write (stdout,*) 'CREST terminated abnormally.' - case ( status_error ) + case (status_error) write (stdout,*) 'CREST terminated with errors.' - case ( status_ioerr ) + case (status_ioerr) write (stdout,*) 'CREST terminated with I/O errors.' - case ( status_args ) + case (status_args) write (stdout,*) 'CREST terminated due to invalid parameters.' - case ( status_input ) + case (status_input) write (stdout,*) 'CREST terminated due to failed input file read.' - case ( status_config ) + case (status_config) write (stdout,*) 'CREST terminated due to invalid configuration.' - case ( status_failed ) + case (status_failed) write (stdout,*) 'CREST terminated with failures.' - case ( status_safety ) + case (status_safety) write (stdout,*) 'Safety termination of CREST.' end select call exit(io) @@ -53,100 +52,115 @@ end subroutine creststop !================================================================================! !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC! !================================================================================! +!&> +#if defined(__INTEL_LLVM_COMPILER) + subroutine wsigint() bind(C,name="crest_wsigint") !> Ctrl+C +#else + subroutine wsigint() !> Ctrl+C +#endif + use crest_parameters,only:stderr,stdout + use crest_restartlog,only:dump_restart + use ConfSolv_module + integer :: myunit,io + write (*,*) + write (stderr,'(" recieved SIGINT, trying to terminate CREST...")') + !call dump_restart() + call cs_shutdown(io) + call exit(130) + error stop + end subroutine wsigint -subroutine wsigint() bind(C, name="crest_wsigint") !> Ctrl+C - use crest_parameters,only:stderr,stdout - use crest_restartlog,only:dump_restart - use ConfSolv_module - integer :: myunit,io - write (*,*) - write (stderr,'(" recieved SIGINT, trying to terminate CREST...")') - !call dump_restart() - call cs_shutdown(io) - call exit(130) - error stop -end subroutine wsigint - -subroutine wsigquit() bind(C, name="crest_wsigquit") !> Ctrl+D or Ctrl+\ - use crest_parameters,only:stderr,stdout - use crest_restartlog,only:dump_restart - use ConfSolv_module - integer :: myunit,io - write (*,*) - write (stderr,'(" recieved SIGQUIT, trying to terminate CREST...")') - !call dump_restart() - call cs_shutdown(io) - call exit(131) - error stop -end subroutine wsigquit - -subroutine wsigterm() bind(C, name="crest_wsigterm") !> Recieved by the "kill" pid command - use crest_parameters,only:stderr,stdout - use crest_restartlog,only:dump_restart - use ConfSolv_module - integer :: io - write (stdout,*) - write (stderr,'(" recieved SIGTERM, trying to terminate CREST...")') - !call dump_restart() - call cs_shutdown(io) - call exit(143) - error stop -end subroutine wsigterm +#if defined(__INTEL_LLVM_COMPILER) + subroutine wsigquit() bind(C,name="crest_wsigquit") !> Ctrl+D +#else + subroutine wsigquit() !> Ctrl+D +#endif + use crest_parameters,only:stderr,stdout + use crest_restartlog,only:dump_restart + use ConfSolv_module + integer :: myunit,io + write (*,*) + write (stderr,'(" recieved SIGQUIT, trying to terminate CREST...")') + !call dump_restart() + call cs_shutdown(io) + call exit(131) + error stop + end subroutine wsigquit -subroutine wsigkill() bind(C, name="crest_wsigkill") - use crest_parameters,only:stderr,stdout - use crest_restartlog,only:dump_restart - use ConfSolv_module - integer :: io - !call dump_restart() - call cs_shutdown(io) - call exit(137) - error stop 'CREST recieved SIGKILL.' -end subroutine wsigkill +#if defined(__INTEL_LLVM_COMPILER) + subroutine wsigterm() bind(C,name="crest_wsigterm") !> Recieved by the "kill" pid command +#else + subroutine wsigterm() !> Recieved by the "kill" pid command +#endif + use crest_parameters,only:stderr,stdout + use crest_restartlog,only:dump_restart + use ConfSolv_module + integer :: io + write (stdout,*) + write (stderr,'(" recieved SIGTERM, trying to terminate CREST...")') + !call dump_restart() + call cs_shutdown(io) + call exit(143) + error stop + end subroutine wsigterm -subroutine initsignal() #if defined(__INTEL_LLVM_COMPILER) - ! ifx: libifport's SIGNAL intrinsic crashes with ifx procedure thunks. - ! Register handlers via ISO_C_BINDING → crest_install_signal() in signal.c. - use iso_c_binding, only: c_int, c_funloc, c_funptr - implicit none - interface - subroutine crest_install_signal(signum, handler) & - bind(C, name='crest_install_signal') - import :: c_int, c_funptr - integer(c_int), value :: signum - type(c_funptr), value :: handler - end subroutine - subroutine wsigint() bind(C, name='crest_wsigint') - end subroutine - subroutine wsigquit() bind(C, name='crest_wsigquit') - end subroutine - subroutine wsigterm() bind(C, name='crest_wsigterm') - end subroutine - end interface - call crest_install_signal(2_c_int, c_funloc(wsigint)) - call crest_install_signal(3_c_int, c_funloc(wsigquit)) - call crest_install_signal(15_c_int, c_funloc(wsigterm)) - ! SIGKILL (9) cannot be caught; signal 69 is invalid — omit both. + subroutine wsigkill() bind(C,name="crest_wsigkill") #else - external :: wSIGINT - external :: wSIGTERM - external :: wSIGKILL - external :: wSIGQUIT - call signal(2,wSIGINT) - call signal(3,wSIGQUIT) - call signal(9,wSIGKILL) - call signal(15,wSIGTERM) - call signal(69,wSIGINT) + subroutine wsigkill() #endif -end subroutine initsignal + use crest_parameters,only:stderr,stdout + use crest_restartlog,only:dump_restart + use ConfSolv_module + integer :: io + !call dump_restart() + call cs_shutdown(io) + call exit(137) + error stop 'CREST recieved SIGKILL.' + end subroutine wsigkill + subroutine initsignal() +#if defined(__INTEL_LLVM_COMPILER) + ! ifx: libifport's SIGNAL intrinsic crashes with ifx procedure thunks. + ! Register handlers via ISO_C_BINDING → crest_install_signal() in signal.c. + use iso_c_binding,only:c_int,c_funloc,c_funptr + implicit none + interface + subroutine crest_install_signal(signum,handler) & + bind(C,name='crest_install_signal') + import :: c_int,c_funptr + integer(c_int),value :: signum + type(c_funptr),value :: handler + end subroutine + subroutine wsigint() bind(C,name='crest_wsigint') + end subroutine + subroutine wsigquit() bind(C,name='crest_wsigquit') + end subroutine + subroutine wsigterm() bind(C,name='crest_wsigterm') + end subroutine + end interface + call crest_install_signal(2_c_int,c_funloc(wsigint)) + call crest_install_signal(3_c_int,c_funloc(wsigquit)) + call crest_install_signal(15_c_int,c_funloc(wsigterm)) + ! SIGKILL (9) cannot be caught; signal 69 is invalid — omit both. +#else + external :: wSIGINT + external :: wSIGTERM + external :: wSIGKILL + external :: wSIGQUIT + call signal(2,wSIGINT) + call signal(3,wSIGQUIT) + call signal(9,wSIGKILL) + call signal(15,wSIGTERM) + call signal(69,wSIGINT) +#endif + end subroutine initsignal !=============================================================! -subroutine graceful_shutdowns() - use mlip_sc - implicit none - call mlips_shutdown() -end subroutine graceful_shutdowns - + subroutine graceful_shutdowns() + use mlip_sc + implicit none + call mlips_shutdown() + end subroutine graceful_shutdowns +!&< diff --git a/test/test_molecular_dynamics.F90 b/test/test_molecular_dynamics.F90 index 8239bf5c..a3223605 100644 --- a/test/test_molecular_dynamics.F90 +++ b/test/test_molecular_dynamics.F90 @@ -116,7 +116,7 @@ subroutine test_md_shake_on(error) call get_testmol('methane',mol) !> MD setup - pr = .true. + pr = .false. io = 0 mdyn%length_ps = 50.0_wp mdyn%Tsoll = 450.0_wp From d1c7727377923df98ab4fabdad37f07456978f71 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 20 Mar 2026 12:28:10 +0100 Subject: [PATCH 250/374] Safeguard some code for intel-llvm builds --- src/basinhopping/algo.f90 | 37 +++++++++++++++++++---------- src/basinhopping/class.f90 | 4 ++-- src/basinhopping/mc.f90 | 48 +++++++++++++++++++++++++++++--------- src/eval_timer.f90 | 4 ++-- 4 files changed, 66 insertions(+), 27 deletions(-) diff --git a/src/basinhopping/algo.f90 b/src/basinhopping/algo.f90 index 084e0058..0406868f 100644 --- a/src/basinhopping/algo.f90 +++ b/src/basinhopping/algo.f90 @@ -194,11 +194,15 @@ subroutine single_basinhopping_core(env,mol,calc,structuredump) do mciter = 1,bh%maxiter if (bh%maxiter > 1) call printiter3('Basin-Hopping Epoch',mciter) call bh%newiter() - call mc(calc,mol,bh,verbosity=2) + call mc(calc,mol,bh,io,verbosity=2) - write (stdout,'(a)') 'New structures will be appended to memory ...' - call unionizeEnsembles(nall,structuredump,bh%saved,bh%structures, & - & ethr=bh%ethr,rthr=bh%rthr) + if (io .eq. 0) then + write (stdout,'(a)') 'New structures will be appended to memory ...' + call unionizeEnsembles(nall,structuredump,bh%saved,bh%structures, & + & ethr=bh%ethr,rthr=bh%rthr) + else + write (stdout,'(a)') 'Skipping run with failed initial quench ...' + end if write (stdout,'(a,i0,a)') 'Currently ',nall,' structures saved!' end do return @@ -233,7 +237,7 @@ subroutine parallel_basinhopping_core(env,mol,calc,structuredump) type(bh_class),allocatable :: bhp(:) type(coord),allocatable :: mols(:) real(wp) :: energy - integer :: nall,verbose + integer :: nall,verbose,iostatus character(len=128) :: tag type(mollist),allocatable :: dumplist(:) @@ -285,17 +289,26 @@ subroutine parallel_basinhopping_core(env,mol,calc,structuredump) write (tag,'(a,i0,a)') 'Basin-Hopping Epoch' if (bhp(1)%maxiter > 1) call printiter3(trim(tag),mciter) !$omp end critical - !$omp parallel do default(shared) private(K, mciter) schedule(dynamic) + !$omp parallel do default(shared) private(K, mciter, iostatus) schedule(dynamic) do K = 1,T call bhp(K)%newiter() - call mc(calcp(K),mols(K),bhp(K),verbosity=1) - - write (stdout,'(a)') 'New structures will be appended to memory ...' - call unionizeEnsembles(dumplist(K)%nall,dumplist(K)%structure, & - & bhp(K)%saved,bhp(K)%structures, & - & ethr=bhp(K)%ethr,rthr=bhp(K)%rthr) + call mc(calcp(K),mols(K),bhp(K),iostatus,verbosity=1) + if (iostatus .eq. 0) then + !$omp critical + write (stdout,'(a)') 'New structures will be appended to memory ...' + !$omp end critical + call unionizeEnsembles(dumplist(K)%nall,dumplist(K)%structure, & + & bhp(K)%saved,bhp(K)%structures, & + & ethr=bhp(K)%ethr,rthr=bhp(K)%rthr) + else + !$omp critical + write (stdout,'(a)') 'Skipping run with failed initial quench ...' + !$omp end critical + end if + !$omp critical write (stdout,'(a,i0,a,i0,a)') 'Currently ',dumplist(K)%nall, & & ' structures saved (BH[',bhp(K)%id,'])!' + !$omp end critical end do !$omp end parallel do diff --git a/src/basinhopping/class.f90 b/src/basinhopping/class.f90 index 7d900b76..3076f744 100644 --- a/src/basinhopping/class.f90 +++ b/src/basinhopping/class.f90 @@ -164,8 +164,8 @@ subroutine bh_class_add(self,mol) if (self%saved < self%maxsave) then self%saved = self%saved+1 i = self%saved + !$omp critical self%structures(i) = mol - !$omp critical call self%sorters(i)%init(mol,invtype='apsp+',heavy=.false.) if (i == 1) then self%stereocheck = .not. (self%sorters(i)%hasstereo(mol)) @@ -173,8 +173,8 @@ subroutine bh_class_add(self,mol) !$omp end critical else i = self%whichmax + !$omp critical self%structures(i) = mol - !$omp critical call self%sorters(i)%deallocate() call self%sorters(i)%init(mol,invtype='apsp+',heavy=.false.) call self%sorters(i)%shrink() diff --git a/src/basinhopping/mc.f90 b/src/basinhopping/mc.f90 index 5c33856f..effb7e26 100644 --- a/src/basinhopping/mc.f90 +++ b/src/basinhopping/mc.f90 @@ -43,7 +43,7 @@ module bh_mc_module !========================================================================================! !========================================================================================! - subroutine mc(calc,mol,bh,verbosity) + subroutine mc(calc,mol,bh,iostat,verbosity) !******************************************************************** !* A thread-safe single basin-hopping MC run !* Parameters and quenched structures are saved within the bh object @@ -53,6 +53,7 @@ subroutine mc(calc,mol,bh,verbosity) type(calcdata),intent(inout) :: calc !> potential settings type(coord),intent(inout) :: mol !> molecular system type(bh_class),intent(inout) :: bh !> BH settings + integer,intent(out) :: iostat integer,intent(in),optional :: verbosity !> printout parameter !> LOCAL type(coord) :: tmpmol !> copy to take steps @@ -64,7 +65,9 @@ subroutine mc(calc,mol,bh,verbosity) integer :: printlvl,first,last,dynamicseed character(len=20) :: tag - write (tag,'("BH[Runner ",i0,"]>")') bh%id + !$omp critical + write (tag,'("BH[Runner ",i3,"]>")') bh%id + !$omp end critical if (present(verbosity)) then printlvl = verbosity @@ -72,24 +75,33 @@ subroutine mc(calc,mol,bh,verbosity) printlvl = 0 end if + iostat = 0 + !>--- Add input energy to Markov chain after an initial quench !$omp critical allocate (grd(3,mol%nat),source=0.0_wp) !$omp end critical if (printlvl > 0) then + !$omp critical write (stdout,'(a,1x,a)') trim(tag),'Performing '//colorify('initial quench','gold')//"." + !$omp end critical end if tmpmol = mol call mcquench(calc,bh,tmpmol,optmol,etot,grd,iostatus) - if(iostatus .ne. 0)then - write(stdout,'(a,1x,a)') trim(tag),colorify('** WARNING **','red')// & + if (iostatus .ne. 0) then + !$omp critical + write (stdout,'(a,1x,a)') trim(tag),colorify('** WARNING **','red')// & & ' initial quench failed. Returning.' + !$omp end critical + iostat = iostatus return - endif + end if + !$omp critical mol = optmol bh%emin = mol%energy + !$omp end critical call bh%add(mol) !>--- print information about the run? @@ -103,8 +115,10 @@ subroutine mc(calc,mol,bh,verbosity) if (allocated(bh%seed)) then dynamicseed = bh%seed+(bh%iteration-1)+bh%id*1000 if (printlvl > 1) then + !$omp critical write (stdout,'(a,1x,2(a,i0),a)') trim(tag), & & 'Seeding current RNG instance with: ',bh%seed,' (',dynamicseed,')' + !$omp end critical end if call RNG_seed(bh%seed) end if @@ -143,6 +157,7 @@ subroutine mc(calc,mol,bh,verbosity) !> check duplicates here call mcduplicate(mol,bh,dupe,broken) + !$omp critical if (printlvl > 1) then write (stdout,'(a)',advance='no') repeat(' ',len_trim(tag)+1)// & & "Quench "//colorify('ACCEPTED','green') @@ -162,20 +177,31 @@ subroutine mc(calc,mol,bh,verbosity) end if if (printlvl > 1) write (stdout,'(/)') + !$omp end critical else - if (printlvl > 1) write (stdout,'(a,a,/)') repeat(' ',len_trim(tag)+1), & - & 'Quench '//colorify('REJECTED','red')//', does not fulfill MC criterion' + if (printlvl > 1) then + !$omp critical + write (stdout,'(a,a,/)') repeat(' ',len_trim(tag)+1), & + & 'Quench '//colorify('REJECTED','red')//', does not fulfill MC criterion' + !$omp end critical + end if cycle MonteCarlo end if else - if (printlvl > 1) write (stdout,'(a,1x,a,/)') trim(tag),"Quench "//colorify("FAILED","red") + if (printlvl > 1)then + !$omp critical + write (stdout,'(a,1x,a,/)') trim(tag),"Quench "//colorify("FAILED","red") + !$omp end critical + endif cycle MonteCarlo end if !>--- Update structures if (.not.broken) then !> continue Markov chain + !$omp critical mol = optmol + !$omp end critical if (.not.dupe) then !> Save new unique structures @@ -222,7 +248,7 @@ subroutine mcheader(bh) write (stdout,'(24x,"│")') write (stdout,'(t8,a,1x)',advance='no') '│' - write (stdout,'(a,es9.3,3x)',advance='no') 'T/K: ',bh%temp + write (stdout,'(a,es10.3,2x)',advance='no') 'T/K: ',bh%temp write (stdout,'(a,i5,3x)',advance='no') 'steps: ',bh%maxsteps write (stdout,'(a,i5,3x)',advance='no') 'max save: ',bh%maxsave write (stdout,'(12x,"│")') @@ -243,8 +269,8 @@ subroutine mcheader(bh) write (stdout,'(t8,a,1x)',advance='no') '│' write (stdout,'(a,f9.5,a)',advance='no') 'Thresholds ΔRMSD:',bh%rthr,' Å, ' - write (stdout,'(a,es10.4,a)',advance='no') 'ΔE: ',bh%ethr,' kcal/mol' - write (stdout,'(6x,"│")') + write (stdout,'(a,es11.4,a)',advance='no') 'ΔE: ',bh%ethr,' kcal/mol' + write (stdout,'(5x,"│")') write (stdout,'(t8,a)') '└'//repeat('─',63)//'┘' end subroutine mcheader diff --git a/src/eval_timer.f90 b/src/eval_timer.f90 index 090786b6..cd74ab9d 100644 --- a/src/eval_timer.f90 +++ b/src/eval_timer.f90 @@ -25,7 +25,7 @@ subroutine eval_timer(tim) use crest_data use crest_calculator,only:engrad_total use crest_restartlog - use iomod,only:get_peak_rss_kb + use iomod,only:get_peak_rss_kb,to_str implicit none type(timer) :: tim real(wp) :: time_total,time_avg,mem @@ -43,7 +43,7 @@ subroutine eval_timer(tim) write (stdout,'(" * Total number of energy+grad calls: ",i0)') & & nint(engrad_total) else - write (stdout,'(" * Total number of energy+grad calls: ",es10.4)') & + write (stdout,'(" * Total number of energy+grad calls: ",es11.4)') & & engrad_total end if write (stdout,*) From ec04a5f35dbbb7e51e93f3888f11466a73039ad4 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 20 Mar 2026 12:31:04 +0100 Subject: [PATCH 251/374] fix warning for intel-llvm build --- src/parsing/parse_xtbinput.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/parsing/parse_xtbinput.f90 b/src/parsing/parse_xtbinput.f90 index dfac4b60..aa69f34a 100644 --- a/src/parsing/parse_xtbinput.f90 +++ b/src/parsing/parse_xtbinput.f90 @@ -797,6 +797,7 @@ subroutine get_xtb_rawa(kv,str,io) integer :: i,j,k,na,plast integer :: l(3) + io = 0 if (allocated(kv%value_rawa)) deallocate (kv%value_rawa) vtmp = trim(adjustl(str)) From 62f79082e12459873285414f9f1390911c9fb294 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 20 Mar 2026 13:24:01 +0100 Subject: [PATCH 252/374] intel-llvm updates --- BUILD.md | 2 +- config/intel-classic.ini | 4 ++-- config/intel-llvm.ini | 4 ++-- config/meson.build | 38 ++++++++++++++++++++++---------------- subprojects/fmlip_relay | 2 +- subprojects/gfn0 | 2 +- subprojects/gfnff | 2 +- subprojects/mctc-lib.wrap | 2 +- subprojects/pvol | 2 +- 9 files changed, 32 insertions(+), 26 deletions(-) diff --git a/BUILD.md b/BUILD.md index ca5bab10..262a496a 100644 --- a/BUILD.md +++ b/BUILD.md @@ -220,7 +220,7 @@ meson setup build_static \ ninja -C build_static ``` -`-static-intel -static-openmp` are applied automatically for ifx. +\`-static-intel -qopenmp-link=static\` are applied automatically for ifx. --- diff --git a/config/intel-classic.ini b/config/intel-classic.ini index 5a613685..76da11dc 100644 --- a/config/intel-classic.ini +++ b/config/intel-classic.ini @@ -13,6 +13,6 @@ fortran = 'ifort' ar = 'ar' strip = 'strip' -[built-in options] +#[built-in options] # -warn all is ifort's equivalent of -Wall -fortran_args = ['-warn', 'all'] +#fortran_args = ['-warn', 'all'] diff --git a/config/intel-llvm.ini b/config/intel-llvm.ini index 20929f00..3865e9bb 100644 --- a/config/intel-llvm.ini +++ b/config/intel-llvm.ini @@ -11,5 +11,5 @@ fortran = 'ifx' ar = 'ar' strip = 'strip' -[built-in options] -fortran_args = ['-warn', 'all'] +#[built-in options] +#fortran_args = ['-warn', 'all'] diff --git a/config/meson.build b/config/meson.build index 379ad481..d7b3f28a 100644 --- a/config/meson.build +++ b/config/meson.build @@ -105,20 +105,26 @@ if fc_id == 'intel-llvm' endif endif +static_build = get_option('static') + if fc_id == 'intel-llvm' - # -lifport : POSIX intrinsics (getcwd, chdir, …) not auto-linked by ifx. - # libgcc_s : was previously added to supply _Unwind_* symbols for libifcore's - # signal handler. No longer needed since signal registration was - # moved to crest_install_signal() via ISO_C_BINDING, bypassing - # libifcore's handler entirely. - #_libgcc_s = run_command('gcc', '-print-file-name=libgcc_s.so', - # check : false).stdout().strip() - #_gcc_s_link = (_libgcc_s != 'libgcc_s.so') ? [_libgcc_s] : [] - #if _gcc_s_link.length() == 0 - # warning('intel-llvm: libgcc_s.so not found — _Unwind_* symbols will be NULL, ' + - # 'Intel Fortran runtime will SIGSEGV at startup.') - #endif - add_project_link_arguments(['-lifport'], language : 'fortran') + ## -lifport : POSIX intrinsics (getcwd, chdir, …) not auto-linked by ifx. + ## In static builds -static-intel already bundles libifport.a, so + ## adding a bare -lifport here would cause the linker to resolve it + ## to the shared library (before -static-intel takes effect). + ## libgcc_s : was previously added to supply _Unwind_* symbols for libifcore's + ## signal handler. No longer needed since signal registration was + ## moved to crest_install_signal() via ISO_C_BINDING, bypassing + ## libifcore's handler entirely. + _libgcc_s = run_command('gcc', '-print-file-name=libgcc_s.so', + check : false).stdout().strip() + _gcc_s_link = (_libgcc_s != 'libgcc_s.so') ? [_libgcc_s] : [] + if _gcc_s_link.length() == 0 + warning('intel-llvm: libgcc_s.so not found — _Unwind_* symbols will be NULL, ' + + 'Intel Fortran runtime will SIGSEGV at startup.') + endif + _lifport_arg = static_build ? [] : ['-lifport'] + add_project_link_arguments(_lifport_arg + _gcc_s_link, language : 'fortran') endif # ═══════════════════════════════════════════════════════════════════════════════ @@ -126,7 +132,6 @@ endif # ═══════════════════════════════════════════════════════════════════════════════ # Injected globally so they propagate to every link step (library + executable). # See BUILD.md for notes on required system .a archives. -static_build = get_option('static') if static_build if fc_id == 'gcc' @@ -147,10 +152,11 @@ if static_build ) elif fc_id == 'intel-llvm' - # ifx uses -static-openmp instead of -qopenmp-link=static + # -static-intel : statically links Intel runtime (ifcore, ifport, imf, svml) + # -qopenmp-link=static : statically links Intel OpenMP (libomp / libiomp5) add_project_link_arguments( '-static-intel', - '-static-openmp', + '-qopenmp-link=static', language : 'fortran', ) endif diff --git a/subprojects/fmlip_relay b/subprojects/fmlip_relay index 2907e4a3..22a788a4 160000 --- a/subprojects/fmlip_relay +++ b/subprojects/fmlip_relay @@ -1 +1 @@ -Subproject commit 2907e4a352b3de7e6536c370f9ba50ae71c1928c +Subproject commit 22a788a48031af3a1ae9f687af09595568dd9fb4 diff --git a/subprojects/gfn0 b/subprojects/gfn0 index 8e3f093d..717cce28 160000 --- a/subprojects/gfn0 +++ b/subprojects/gfn0 @@ -1 +1 @@ -Subproject commit 8e3f093d6e9b5f2d98f39ddb0651eb5806b75a0e +Subproject commit 717cce283ede4fa88d949292291b1f0f6984440a diff --git a/subprojects/gfnff b/subprojects/gfnff index 2022cda6..0e0280f0 160000 --- a/subprojects/gfnff +++ b/subprojects/gfnff @@ -1 +1 @@ -Subproject commit 2022cda6b5965f44656973d14ea0ecd35855a836 +Subproject commit 0e0280f05c8ffd83f82a035636ffc64c37489120 diff --git a/subprojects/mctc-lib.wrap b/subprojects/mctc-lib.wrap index 313ec501..59b0b394 100644 --- a/subprojects/mctc-lib.wrap +++ b/subprojects/mctc-lib.wrap @@ -4,4 +4,4 @@ revision = head clone-recursive = true [provide] -mctc-lib = mctc_lib_dep +mctc-lib = mctc_dep diff --git a/subprojects/pvol b/subprojects/pvol index 7ec28b71..c975ad4e 160000 --- a/subprojects/pvol +++ b/subprojects/pvol @@ -1 +1 @@ -Subproject commit 7ec28b718af51644a6863e12e7d983bffe7ba6fb +Subproject commit c975ad4e062a00e6b228505bec0f1d722aea9f46 From bb8e9f3681ccdb306a3fe28f537e0034185dbaba Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 20 Mar 2026 13:39:44 +0100 Subject: [PATCH 253/374] Update metadata printout --- assets/template/metadata.f90 | 1 + config/CMakeLists.txt | 1 + config/meson.build | 1 + meson.build | 1 + src/printouts.f90 | 31 ++++++++++++++++--------------- 5 files changed, 20 insertions(+), 15 deletions(-) diff --git a/assets/template/metadata.f90 b/assets/template/metadata.f90 index e9254292..b716abf2 100644 --- a/assets/template/metadata.f90 +++ b/assets/template/metadata.f90 @@ -11,3 +11,4 @@ character(len=*),parameter :: tblitevar = "@tblitevar@" character(len=*),parameter :: libpvolvar = "@libpvolvar@" character(len=*),parameter :: lwoniomvar = "@lwoniomvar@" +character(len=*),parameter :: fmliprelayvar = "@fmliprelayvar@" diff --git a/config/CMakeLists.txt b/config/CMakeLists.txt index f66566a4..3c1579e7 100644 --- a/config/CMakeLists.txt +++ b/config/CMakeLists.txt @@ -104,6 +104,7 @@ set(gfnffvar "${WITH_GFNFF}") set(tblitevar "${WITH_TBLITE}") set(libpvolvar "${WITH_LIBPVOL}") set(lwoniomvar "${WITH_LWONIOM}") +set(fmliprelayvar "${WITH_FMLIP_RELAY}") configure_file( "${PROJECT_SOURCE_DIR}/assets/template/metadata.f90" diff --git a/config/meson.build b/config/meson.build index d7b3f28a..5a5ec726 100644 --- a/config/meson.build +++ b/config/meson.build @@ -234,6 +234,7 @@ _conf.set('gfnffvar', 'false') _conf.set('tblitevar', 'false') _conf.set('libpvolvar', 'false') _conf.set('lwoniomvar', 'false') +_conf.set('fmliprelayvar', 'false') # Expose _conf to the root so it can set the with_* keys and then call # configure_file(). The root owns the final configure_file() call. diff --git a/meson.build b/meson.build index bc3077b7..4b6d5a75 100644 --- a/meson.build +++ b/meson.build @@ -306,6 +306,7 @@ metadata_conf.set('gfnffvar', with_gfnff.to_string()) metadata_conf.set('tblitevar', with_tblite.to_string()) metadata_conf.set('libpvolvar', with_libpvol.to_string()) metadata_conf.set('lwoniomvar', with_lwoniom.to_string()) +metadata_conf.set('fmliprelayvar', with_fmlip.to_string()) configure_file( input : 'assets/template/metadata.f90', diff --git a/src/printouts.f90 b/src/printouts.f90 index e6075a4f..6463436c 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -757,24 +757,25 @@ subroutine print_crest_metadata() !******************************** include 'crest_metadata.fh' integer :: l - write (*,'(2x,a,t20,": ",a)') 'CREST version ',version - write (*,'(2x,a,t20,": ",a)') 'timestamp ',date - write (*,'(2x,a,t20,": ",a)') 'commit ',commit + write (*,'(2x,a,t22,": ",a)') 'CREST version ',version + write (*,'(2x,a,t22,": ",a)') 'timestamp ',date + write (*,'(2x,a,t22,": ",a)') 'commit ',commit + l = len_trim(author) if (author(1:2) .eq. "'@") then - l = len_trim(author) - write (*,'(2x,a,t20,": ",a)') 'compiled by ',"'usr"//author(2:l) + write (*,'(2x,a,t22,": ",a)') 'compiled by ',"usr"//author(2:l-1) else - write (*,'(2x,a,t20,": ",a)') 'compiled by ',author + write (*,'(2x,a,t22,": ",a)') 'compiled by ',author(2:l-1) end if - write (*,'(2x,a,t20,": ",a)') 'Fortran compiler ',fcompiler - write (*,'(2x,a,t20,": ",a)') 'C compiler ',ccompiler - write (*,'(2x,a,t20,": ",a)') 'build system ',bsystem - write (*,'(2x,a,t20,": ",a)') '-DWITH_TOMLF ',tomlfvar - write (*,'(2x,a,t20,": ",a)') '-DWITH_GFN0 ',gfn0var - write (*,'(2x,a,t20,": ",a)') '-DWITH_GFNFF ',gfnffvar - write (*,'(2x,a,t20,": ",a)') '-DWITH_TBLITE ',tblitevar - write (*,'(2x,a,t20,": ",a)') '-DWITH_LIBPVOL ',libpvolvar - write (*,'(2x,a,t20,": ",a)') '-DWITH_LWONIOM ',lwoniomvar + write (*,'(2x,a,t22,": ",a)') 'Fortran compiler ',fcompiler + write (*,'(2x,a,t22,": ",a)') 'C compiler ',ccompiler + write (*,'(2x,a,t22,": ",a)') 'build system ',bsystem + write (*,'(2x,a,t22,": ",a)') '-DWITH_TOMLF ',tomlfvar + write (*,'(2x,a,t22,": ",a)') '-DWITH_GFN0 ',gfn0var + write (*,'(2x,a,t22,": ",a)') '-DWITH_GFNFF ',gfnffvar + write (*,'(2x,a,t22,": ",a)') '-DWITH_TBLITE ',tblitevar + write (*,'(2x,a,t22,": ",a)') '-DWITH_LIBPVOL ',libpvolvar + write (*,'(2x,a,t22,": ",a)') '-DWITH_LWONIOM ',lwoniomvar + write (*,'(2x,a,t22,": ",a)') '-DWITH_FMLIP_RELAY',fmliprelayvar end subroutine print_crest_metadata From 4c00112070fe4c190627f033184f5c8c00c8aca1 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 20 Mar 2026 13:53:44 +0100 Subject: [PATCH 254/374] refactor: move c helpers into src/chelpers/ --- src/CMakeLists.txt | 3 +- src/chelpers/CMakeLists.txt | 24 + src/{ => chelpers}/mempeak.c | 0 src/chelpers/meson.build | 20 + src/{ => chelpers}/signal.c | 0 src/meson.build | 3 +- src/symmetry_i.c | 2006 ---------------------------------- src/symmetry_i.f90 | 4 +- 8 files changed, 49 insertions(+), 2011 deletions(-) create mode 100644 src/chelpers/CMakeLists.txt rename src/{ => chelpers}/mempeak.c (100%) create mode 100644 src/chelpers/meson.build rename src/{ => chelpers}/signal.c (100%) delete mode 100644 src/symmetry_i.c diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 949941c4..56b6489f 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -30,6 +30,7 @@ add_subdirectory("legacy_algos") add_subdirectory("msreact") add_subdirectory("sorting") add_subdirectory("basinhopping") +add_subdirectory("chelpers") set(dir "${CMAKE_CURRENT_SOURCE_DIR}") @@ -58,7 +59,6 @@ list(APPEND srcs "${dir}/marqfit.f90" "${dir}/minitools.f90" "${dir}/miscdata.f90" - "${dir}/mempeak.c" "${dir}/ncigeo.f90" "${dir}/ompmklset.F90" "${dir}/printouts.f90" @@ -69,7 +69,6 @@ list(APPEND srcs "${dir}/scratch.f90" "${dir}/sdfio.f90" "${dir}/select.f90" - "${dir}/signal.c" "${dir}/sigterm.F90" "${dir}/strucreader.f90" "${dir}/symmetry_i.f90" diff --git a/src/chelpers/CMakeLists.txt b/src/chelpers/CMakeLists.txt new file mode 100644 index 00000000..7e2992ab --- /dev/null +++ b/src/chelpers/CMakeLists.txt @@ -0,0 +1,24 @@ +# This file is part of crest. +# SPDX-Identifier: LGPL-3.0-or-later +# +# crest is free software: you can redistribute it and/or modify it under +# the terms of the GNU Lesser General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# crest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public License +# along with crest. If not, see . + +set(dir "${CMAKE_CURRENT_SOURCE_DIR}") + +list(APPEND srcs + "${dir}/mempeak.c" + "${dir}/signal.c" +) + +set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/mempeak.c b/src/chelpers/mempeak.c similarity index 100% rename from src/mempeak.c rename to src/chelpers/mempeak.c diff --git a/src/chelpers/meson.build b/src/chelpers/meson.build new file mode 100644 index 00000000..e700225e --- /dev/null +++ b/src/chelpers/meson.build @@ -0,0 +1,20 @@ +# This file is part of crest. +# SPDX-Identifier: LGPL-3.0-or-later +# +# crest is free software: you can redistribute it and/or modify it under +# the terms of the GNU Lesser General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# crest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public License +# along with crest. If not, see . + +srcs += files( + 'mempeak.c', + 'signal.c', +) diff --git a/src/signal.c b/src/chelpers/signal.c similarity index 100% rename from src/signal.c rename to src/chelpers/signal.c diff --git a/src/meson.build b/src/meson.build index ef01a3ec..89c8d413 100644 --- a/src/meson.build +++ b/src/meson.build @@ -29,6 +29,7 @@ subdir('legacy_algos') subdir('msreact') subdir('sorting') subdir('basinhopping') +subdir('chelpers') srcs += files( 'atmasses.f90', @@ -55,7 +56,6 @@ srcs += files( 'marqfit.f90', 'minitools.f90', 'miscdata.f90', - 'mempeak.c', 'ncigeo.f90', 'ompmklset.F90', 'printouts.f90', @@ -66,7 +66,6 @@ srcs += files( 'scratch.f90', 'sdfio.f90', 'select.f90', - 'signal.c', 'sigterm.F90', 'strucreader.f90', 'symmetry_i.f90', diff --git a/src/symmetry_i.c b/src/symmetry_i.c deleted file mode 100644 index 000240ac..00000000 --- a/src/symmetry_i.c +++ /dev/null @@ -1,2006 +0,0 @@ -/* - * Brute force symmetry analyzer. - * This is actually C++ program, masquerading as a C one! - * - * (C) 1996, 2003 S. Patchkovskii, Serguei.Patchkovskii@sympatico.ca - * modifications by S. Dohm and S. Ehlert and P. Pracht - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program. If not, see . - * - * $Log: symmetry.c,v $ - * Revision 1.16 2003/04/04 13:05:03 patchkov - * Revision 1.15 2000/01/25 16:47:17 patchkov - * Revision 1.14 2000/01/25 16:39:08 patchkov - * Revision 1.13 1996/05/24 12:32:08 ps - * Revision 1.12 1996/05/23 16:10:47 ps - * First reasonably stable version. - * - */ -#include -#include -#include -#include - -#ifndef M_PI -#define M_PI 3.1415926535897932384626433832795028841971694 -#endif - -#define DIMENSION 3 -#define MAXPARAM 7 - -typedef struct { - int type ; - double x[ DIMENSION ] ; - } ATOM ; - -/* - * All specific structures should have corresponding elements in the - * same position generic structure does. - * - * Planes are characterized by the surface normal direction - * (taken in the direction *from* the coordinate origin) - * and distance from the coordinate origin to the plane - * in the direction of the surface normal. - * - * Inversion is characterized by location of the inversion center. - * - * Rotation is characterized by a vector (distance+direction) from the origin - * to the rotation axis, axis direction and rotation order. Rotations - * are in the clockwise direction looking opposite to the direction - * of the axis. Note that this definition of the rotation axis - * is *not* unique, since an arbitrary multiple of the axis direction - * can be added to the position vector without changing actual operation. - * - * Mirror rotation is defined by the same parameters as normal rotation, - * but the origin is now unambiguous since it defines the position of the - * plane associated with the axis. - * - */ - -typedef struct _SYMMETRY_ELEMENT_ { - void (*transform_atom)( struct _SYMMETRY_ELEMENT_ *el, ATOM *from, ATOM *to ) ; - int * transform ; /* Correspondence table for the transformation */ - int order ; /* Applying transformation this many times is identity */ - int nparam ; /* 4 for inversion and planes, 7 for axes */ - double maxdev ; /* Larges error associated with the element */ - double distance ; - double normal[ DIMENSION ] ; - double direction[ DIMENSION ] ; - } SYMMETRY_ELEMENT ; - -typedef struct { - char * group_name ; /* Canonical group name */ - char * symmetry_code ; /* Group symmetry code */ - int (*check)( void ) ; /* Additional verification routine, not used */ - } POINT_GROUP ; - -double ToleranceSame = 1e-3 ; -double TolerancePrimary = 5e-2 ; -double ToleranceFinal = 1e-4 ; -double MaxOptStep = 5e-1 ; -double MinOptStep = 1e-7 ; -double GradientStep = 1e-7 ; -double OptChangeThreshold = 1e-10 ; -double CenterOfSomething[ DIMENSION ] ; -double * DistanceFromCenter = NULL ; -int verbose = 0 ; -int MaxOptCycles = 200 ; -int OptChangeHits = 5 ; -int MaxAxisOrder = 20 ; -int AtomsCount = 0 ; -ATOM * Atoms = NULL ; -int PlanesCount = 0 ; -SYMMETRY_ELEMENT ** Planes = NULL ; -SYMMETRY_ELEMENT * MolecularPlane = NULL ; -int InversionCentersCount = 0 ; -SYMMETRY_ELEMENT ** InversionCenters = NULL ; -int NormalAxesCount = 0 ; -SYMMETRY_ELEMENT ** NormalAxes = NULL ; -int ImproperAxesCount = 0 ; -SYMMETRY_ELEMENT ** ImproperAxes = NULL ; -int * NormalAxesCounts = NULL ; -int * ImproperAxesCounts = NULL ; -int BadOptimization = 0 ; -char * SymmetryCode = "" ; -char MaxRotAxis[2] = "" ; -/* - * Statistics - */ -long StatTotal = 0 ; -long StatEarly = 0 ; -long StatPairs = 0 ; -long StatDups = 0 ; -long StatOrder = 0 ; -long StatOpt = 0 ; -long StatAccept = 0 ; - -/* - * Point groups I know about - */ -int true_func(void){ return 1 ; } -POINT_GROUP PointGroups[] = { - { "C1", "", true_func }, - { "Cs", "(sigma) ", true_func }, - { "Ci", "(i) ", true_func }, - { "C2", "(C2) ", true_func }, - { "C3", "(C3) ", true_func }, - { "C4", "(C4) (C2) ", true_func }, - { "C5", "(C5) ", true_func }, - { "C6", "(C6) (C3) (C2) ", true_func }, - { "C7", "(C7) ", true_func }, - { "C8", "(C8) (C4) (C2) ", true_func }, - { "D2", "3*(C2) ", true_func }, - { "D3", "(C3) 3*(C2) ", true_func }, - { "D4", "(C4) 5*(C2) ", true_func }, - { "D5", "(C5) 5*(C2) ", true_func }, - { "D6", "(C6) (C3) 7*(C2) ", true_func }, - { "D7", "(C7) 7*(C2) ", true_func }, - { "D8", "(C8) (C4) 9*(C2) ", true_func }, - { "C2v", "(C2) 2*(sigma) ", true_func }, - { "C3v", "(C3) 3*(sigma) ", true_func }, - { "C4v", "(C4) (C2) 4*(sigma) ", true_func }, - { "C5v", "(C5) 5*(sigma) ", true_func }, - { "C6v", "(C6) (C3) (C2) 6*(sigma) ", true_func }, - { "C7v", "(C7) 7*(sigma) ", true_func }, - { "C8v", "(C8) (C4) (C2) 8*(sigma) ", true_func }, - { "C2h", "(i) (C2) (sigma) ", true_func }, - { "C3h", "(C3) (S3) (sigma) ", true_func }, - { "C4h", "(i) (C4) (C2) (S4) (sigma) ", true_func }, - { "C5h", "(C5) (S5) (sigma) ", true_func }, - { "C6h", "(i) (C6) (C3) (C2) (S6) (S3) (sigma) ", true_func }, - { "C7h", "(C7) (S7) (sigma) ", true_func }, - { "C8h", "(i) (C8) (C4) (C2) (S8) (S4) (sigma) ", true_func }, - { "D2h", "(i) 3*(C2) 3*(sigma) ", true_func }, - { "D3h", "(C3) 3*(C2) (S3) 4*(sigma) ", true_func }, - { "D4h", "(i) (C4) 5*(C2) (S4) 5*(sigma) ", true_func }, - { "D5h", "(C5) 5*(C2) (S5) 6*(sigma) ", true_func }, - { "D6h", "(i) (C6) (C3) 7*(C2) (S6) (S3) 7*(sigma) ", true_func }, - { "D7h", "(C7) 7*(C2) (S7) 8*(sigma) ", true_func }, - { "D8h", "(i) (C8) (C4) 9*(C2) (S8) (S4) 9*(sigma) ", true_func }, - { "D2d", "3*(C2) (S4) 2*(sigma) ", true_func }, - { "D3d", "(i) (C3) 3*(C2) (S6) 3*(sigma) ", true_func }, - { "D4d", "(C4) 5*(C2) (S8) 4*(sigma) ", true_func }, - { "D5d", "(i) (C5) 5*(C2) (S10) 5*(sigma) ", true_func }, - { "D6d", "(C6) (C3) 7*(C2) (S12) (S4) 6*(sigma) ", true_func }, - { "D7d", "(i) (C7) 7*(C2) (S14) 7*(sigma) ", true_func }, - { "D8d", "(C8) (C4) 9*(C2) (S16) 8*(sigma) ", true_func }, - { "S4", "(C2) (S4) ", true_func }, - { "S6", "(i) (C3) (S6) ", true_func }, - { "S8", "(C4) (C2) (S8) ", true_func }, - { "T", "4*(C3) 3*(C2) ", true_func }, - { "Th", "(i) 4*(C3) 3*(C2) 4*(S6) 3*(sigma) ", true_func }, - { "Td", "4*(C3) 3*(C2) 3*(S4) 6*(sigma) ", true_func }, - { "O", "3*(C4) 4*(C3) 9*(C2) ", true_func }, - { "Oh", "(i) 3*(C4) 4*(C3) 9*(C2) 4*(S6) 3*(S4) 9*(sigma) ", true_func }, - { "Cinfv", "(Cinf) (sigma) ", true_func }, - { "Dinfh", "(i) (Cinf) (C2) 2*(sigma) ", true_func }, - { "I", "6*(C5) 10*(C3) 15*(C2) ", true_func }, - { "Ih", "(i) 6*(C5) 10*(C3) 15*(C2) 6*(S10) 10*(S6) 15*(sigma) ", true_func }, - { "Kh", "(i) (Cinf) (sigma) ", true_func }, - } ; -#define PointGroupsCount (sizeof(PointGroups)/sizeof(POINT_GROUP)) -char * PointGroupRejectionReason = NULL ; - -/* - * Generic functions - */ - -double -pow2( double x ) -{ -return x * x ; -} - -int -establish_pairs( SYMMETRY_ELEMENT *elem ) -{ - int i, j, k, best_j ; - char * atom_used = calloc( AtomsCount, 1 ) ; - double distance, best_distance ; - ATOM symmetric ; - -if( atom_used == NULL ){ - fprintf( stderr, "Out of memory for tagging array in establish_pairs()\n" ) ; - exit( EXIT_FAILURE ) ; - } -for( i = 0 ; i < AtomsCount ; i++ ){ - if( elem->transform[i] >= AtomsCount ){ /* No symmetric atom yet */ - if( verbose > 2 ) printf( " looking for a pair for %d\n", i ) ; - elem->transform_atom( elem, Atoms+i, &symmetric ) ; - if( verbose > 2 ) printf( " new coordinates are: (%g,%g,%g)\n", - symmetric.x[0], symmetric.x[1], symmetric.x[2] ) ; - best_j = i ; - best_distance = 2*TolerancePrimary ;/* Performance value we'll reject */ - for( j = 0 ; j < AtomsCount ; j++ ){ - if( Atoms[j].type != symmetric.type || atom_used[j] ) - continue ; - for( k = 0, distance = 0 ; k < DIMENSION ; k++ ){ - distance += pow2( symmetric.x[k] - Atoms[j].x[k] ) ; - } - distance = sqrt( distance ) ; - if( verbose > 2 ) printf( " distance to %d is %g\n", j, distance ) ; - if( distance < best_distance ){ - best_j = j ; - best_distance = distance ; - } - } - if( best_distance > TolerancePrimary ){ /* Too bad, there is no symmetric atom */ - if( verbose > 0 ) - printf( " no pair for atom %d - best was %d with err = %g\n", i, best_j, best_distance ) ; - free( atom_used ) ; - return -1 ; - } - elem->transform[i] = best_j ; - atom_used[best_j] = 1 ; - if( verbose > 1 ) printf( " atom %d transforms to the atom %d, err = %g\n", i, best_j, best_distance ) ; - } - } -free( atom_used ) ; -return 0 ; -} - -int -check_transform_order( SYMMETRY_ELEMENT *elem ) -{ - int i, j, k ; - void rotate_reflect_atom( SYMMETRY_ELEMENT *, ATOM *, ATOM *) ; - -for( i = 0 ; i < AtomsCount ; i++ ){ - if( elem->transform[i] == i ) /* Identity transform is Ok for any order */ - continue ; - if( elem->transform_atom == rotate_reflect_atom ){ - j = elem->transform[i] ; - if( elem->transform[j] == i ) - continue ; /* Second-order transform is Ok for improper axis */ - } - for( j = elem->order - 1, k = elem->transform[i] ; j > 0 ; j--, k = elem->transform[k] ){ - if( k == i ){ - if( verbose > 0 ) printf( " transform looped %d steps too early from atom %d\n", j, i ) ; - return -1 ; - } - } - if( k != i && elem->transform_atom == rotate_reflect_atom ){ - /* For improper axes, the complete loop may also take twice the order */ - for( j = elem->order ; j > 0 ; j--, k = elem->transform[k] ){ - if( k == i ){ - if( verbose > 0 ) printf( " (improper) transform looped %d steps too early from atom %d\n", j, i ) ; - return -1 ; - } - } - } - if( k != i ){ - if( verbose > 0 ) printf( " transform failed to loop after %d steps from atom %d\n", elem->order, i ) ; - return -1 ; - } - } -return 0 ; -} - -int -same_transform( SYMMETRY_ELEMENT *a, SYMMETRY_ELEMENT *b ) -{ - int i, j ; - int code ; - -if( ( a->order != b->order ) || ( a->nparam != b->nparam ) || ( a->transform_atom != b->transform_atom ) ) - return 0 ; -for( i = 0, code = 1 ; i < AtomsCount ; i++ ){ - if( a->transform[i] != b->transform[i] ){ - code = 0 ; - break ; - } - } -if( code == 0 && a->order > 2 ){ /* b can also be a reverse transformation for a */ - for( i = 0 ; i < AtomsCount ; i++ ){ - j = a->transform[i] ; - if( b->transform[j] != i ) - return 0 ; - } - return 1 ; - } -return code ; -} - -SYMMETRY_ELEMENT * -alloc_symmetry_element( void ) -{ - SYMMETRY_ELEMENT * elem = calloc( 1, sizeof( SYMMETRY_ELEMENT ) ) ; - int i ; - -if( elem == NULL ){ - fprintf( stderr, "Out of memory allocating symmetry element\n" ) ; - exit( EXIT_FAILURE ) ; - } -elem->transform = calloc( AtomsCount, sizeof( int ) ) ; -if( elem->transform == NULL ){ - fprintf( stderr, "Out of memory allocating transform table for symmetry element\n" ) ; - exit( EXIT_FAILURE ) ; - } -for( i = 0 ; i < AtomsCount ; i++ ){ - elem->transform[i] = AtomsCount + 1 ; /* An impossible value */ - } -return elem ; -} - -void -destroy_symmetry_element( SYMMETRY_ELEMENT *elem ) -{ -if( elem != NULL ){ - if( elem->transform != NULL ) - free( elem->transform ) ; - free( elem ) ; - } -} - -int -check_transform_quality( SYMMETRY_ELEMENT *elem ) -{ - int i, j, k ; - ATOM symmetric ; - double r, max_r ; - -for( i = 0, max_r = 0 ; i < AtomsCount ; i++ ){ - j = elem->transform[i] ; - elem->transform_atom( elem, Atoms + i, &symmetric ) ; - for( k = 0, r = 0 ; k < DIMENSION ; k++ ){ - r += pow2( symmetric.x[k] - Atoms[j].x[k] ) ; - } - r = sqrt( r ) ; - if( r > ToleranceFinal ){ - if( verbose > 0 ) printf( " distance to symmetric atom (%g) is too big for %d\n", r, i ) ; - return -1 ; - } - if( r > max_r ) max_r = r ; - } -elem->maxdev = max_r ; -return 0 ; -} - -double -eval_optimization_target_function( SYMMETRY_ELEMENT *elem, int *finish ) -{ - int i, j, k ; - ATOM symmetric ; - double target, r, maxr ; - -if( elem->nparam >= 4 ){ - for( k = 0, r = 0 ; k < DIMENSION ; k++ ){ - r += elem->normal[k]*elem->normal[k] ; - } - r = sqrt( r ) ; - if( r < ToleranceSame ){ - fprintf( stderr, "Normal collapced!\n" ) ; - exit( EXIT_FAILURE ) ; - } - for( k = 0 ; k < DIMENSION ; k++ ){ - elem->normal[k] /= r ; - } - if( elem->distance < 0 ){ - elem->distance = -elem->distance ; - for( k = 0 ; k < DIMENSION ; k++ ){ - elem->normal[k] = -elem->normal[k] ; - } - } - } -if( elem->nparam >= 7 ){ - for( k = 0, r = 0 ; k < DIMENSION ; k++ ){ - r += elem->direction[k]*elem->direction[k] ; - } - r = sqrt( r ) ; - if( r < ToleranceSame ){ - fprintf( stderr, "Direction collapced!\n" ) ; - exit( EXIT_FAILURE ) ; - } - for( k = 0 ; k < DIMENSION ; k++ ){ - elem->direction[k] /= r ; - } - } -for( i = 0, target = maxr = 0 ; i < AtomsCount ; i++ ){ - elem->transform_atom( elem, Atoms + i, &symmetric ) ; - j = elem->transform[i] ; - for( k = 0, r = 0 ; k < DIMENSION ; k++ ){ - r += pow2( Atoms[j].x[k] - symmetric.x[k] ) ; - } - if( r > maxr ) maxr = r ; - target += r ; - } -if( finish != NULL ){ - *finish = 0 ; - if( sqrt( maxr ) < ToleranceFinal ) - *finish = 1 ; - } -return target ; -} - -void -get_params( SYMMETRY_ELEMENT *elem, double values[] ) -{ -memcpy( values, &elem->distance, elem->nparam * sizeof( double ) ) ; -} - -void -set_params( SYMMETRY_ELEMENT *elem, double values[] ) -{ -memcpy( &elem->distance, values, elem->nparam * sizeof( double ) ) ; -} - -void -optimize_transformation_params( SYMMETRY_ELEMENT *elem ) -{ - double values[ MAXPARAM ] ; - double grad [ MAXPARAM ] ; - double force [ MAXPARAM ] ; - double step [ MAXPARAM ] ; - double f, fold, fnew, fnew2, fdn, fup, snorm ; - double a, b, x ; - int vars = elem->nparam ; - int cycle = 0 ; - int i, finish ; - int hits = 0 ; - -if( vars > MAXPARAM ){ - fprintf( stderr, "Catastrophe in optimize_transformation_params()!\n" ) ; - exit( EXIT_FAILURE ) ; - } -f = 0 ; -do { - fold = f ; - f = eval_optimization_target_function( elem, &finish ) ; - /* Evaluate function, gradient and diagonal force constants */ - if( verbose > 1 ) printf( " function value = %g\n", f ) ; - if( finish ){ - if( verbose > 1 ) printf( " function value is small enough\n" ) ; - break ; - } - if( cycle > 0 ){ - if( fabs( f-fold ) > OptChangeThreshold ) - hits = 0 ; - else hits++ ; - if( hits >= OptChangeHits ){ - if( verbose > 1 ) printf( " no progress is made, stop optimization\n" ) ; - break ; - } - } - get_params( elem, values ) ; - for( i = 0 ; i < vars ; i++ ){ - values[i] -= GradientStep ; - set_params( elem, values ) ; - fdn = eval_optimization_target_function( elem, NULL ) ; - values[i] += 2*GradientStep ; - set_params( elem, values ) ; - fup = eval_optimization_target_function( elem, NULL ) ; - values[i] -= GradientStep ; - grad[i] = ( fup - fdn ) / ( 2 * GradientStep ) ; - force[i] = ( fup + fdn - 2*f ) / ( GradientStep * GradientStep ) ; - if( verbose > 1 ) printf( " i = %d, grad = %12.6e, force = %12.6e\n", i, grad[i], force[i] ) ; - } - /* Do a quasy-Newton step */ - for( i = 0, snorm = 0 ; i < vars ; i++ ){ - if( force[i] < 0 ) force[i] = -force[i] ; - if( force[i] < 1e-3 ) force[i] = 1e-3 ; - if( force[i] > 1e3 ) force[i] = 1e3 ; - step[i] = - grad[i]/force[i] ; - snorm += step[i] * step[i] ; - } - snorm = sqrt( snorm ) ; - if( snorm > MaxOptStep ){ /* Renormalize step */ - for( i = 0 ; i < vars ; i++ ) - step[i] *= MaxOptStep/snorm ; - snorm = MaxOptStep ; - } - do { - for( i = 0 ; i < vars ; i++ ){ - values[i] += step[i] ; - } - set_params( elem, values ) ; - fnew = eval_optimization_target_function( elem, NULL ) ; - if( fnew < f ) - break ; - for( i = 0 ; i < vars ; i++ ){ - values[i] -= step[i] ; - step [i] /= 2 ; - } - set_params( elem, values ) ; - snorm /= 2 ; - } while( snorm > MinOptStep ) ; - if( (snorm > MinOptStep) && (snorm < MaxOptStep / 2) ){ /* try to do quadratic interpolation */ - for( i = 0 ; i < vars ; i++ ) - values[i] += step[i] ; - set_params( elem, values ) ; - fnew2 = eval_optimization_target_function( elem, NULL ) ; - if( verbose > 1 ) printf( " interpolation base points: %g, %g, %g\n", f, fnew, fnew2 ) ; - for( i = 0 ; i < vars ; i++ ) - values[i] -= 2*step[i] ; - a = ( 4*f - fnew2 - 3*fnew ) / 2 ; - b = ( f + fnew2 - 2*fnew ) / 2 ; - if( verbose > 1 ) printf( " linear interpolation coefficients %g, %g\n", a, b ) ; - if( b > 0 ){ - x = -a/(2*b) ; - if( x > 0.2 && x < 1.8 ){ - if( verbose > 1 ) printf( " interpolated: %g\n", x ) ; - for( i = 0 ; i < vars ; i++ ) - values[i] += x*step[i] ; - } - else b = 0 ; - } - if( b <= 0 ){ - if( fnew2 < fnew ){ - for( i = 0 ; i < vars ; i++ ) - values[i] += 2*step[i] ; - } - else { - for( i = 0 ; i < vars ; i++ ) - values[i] += step[i] ; - } - } - set_params( elem, values ) ; - } - } while( snorm > MinOptStep && ++cycle < MaxOptCycles ) ; -f = eval_optimization_target_function( elem, NULL ) ; -if( cycle >= MaxOptCycles ) BadOptimization = 1 ; -if( verbose > 0 ) { - if( cycle >= MaxOptCycles ){ - printf( " maximum number of optimization cycles made\n" ) ; - } - printf( " optimization completed after %d cycles with f = %g\n", cycle, f ) ; - } -} - -int -refine_symmetry_element( SYMMETRY_ELEMENT *elem, int build_table ) -{ - int i ; - - -if( build_table && (establish_pairs( elem ) < 0) ){ - StatPairs++ ; - if( verbose > 0 ) printf( " no transformation correspondence table can be constructed\n" ) ; - return -1 ; - } -for( i = 0 ; i < PlanesCount ; i++ ){ - if( same_transform( Planes[i], elem ) ){ - StatDups++ ; - if( verbose > 0 ) printf( " transformation is identical to plane %d\n", i ) ; - return -1 ; - } - } -for( i = 0 ; i < InversionCentersCount ; i++ ){ - if( same_transform( InversionCenters[i], elem ) ){ - StatDups++ ; - if( verbose > 0 ) printf( " transformation is identical to inversion center %d\n", i ) ; - return -1 ; - } - } -for( i = 0 ; i < NormalAxesCount ; i++ ){ - if( same_transform( NormalAxes[i], elem ) ){ - StatDups++ ; - if( verbose > 0 ) printf( " transformation is identical to normal axis %d\n", i ) ; - return -1 ; - } - } -for( i = 0 ; i < ImproperAxesCount ; i++ ){ - if( same_transform( ImproperAxes[i], elem ) ){ - StatDups++ ; - if( verbose > 0 ) printf( " transformation is identical to improper axis %d\n", i ) ; - return -1 ; - } - } -if( check_transform_order( elem ) < 0 ){ - StatOrder++ ; - if( verbose > 0 ) printf( " incorrect transformation order\n" ) ; - return -1 ; - } -optimize_transformation_params( elem ) ; -if( check_transform_quality( elem ) < 0 ){ - StatOpt++ ; - if( verbose > 0 ) printf( " refined transformation does not pass the numeric threshold\n" ) ; - return -1 ; - } -StatAccept++ ; -return 0 ; -} - -/* - * Plane-specific functions - */ - -void -mirror_atom( SYMMETRY_ELEMENT *plane, ATOM *from, ATOM *to ) -{ - int i ; - double r ; - -for( i = 0, r = plane->distance ; i < DIMENSION ; i++ ){ - r -= from->x[i] * plane->normal[i] ; - } -to->type = from->type ; -for( i = 0 ; i < DIMENSION ; i++ ){ - to->x[i] = from->x[i] + 2*r*plane->normal[i] ; - } -} - -SYMMETRY_ELEMENT * -init_mirror_plane( int i, int j ) -{ - SYMMETRY_ELEMENT * plane = alloc_symmetry_element() ; - double dx[ DIMENSION ], midpoint[ DIMENSION ], rab, r ; - int k ; - -if( verbose > 0 ) printf( "Trying mirror plane for atoms %d,%d\n", i, j ) ; -StatTotal++ ; -plane->transform_atom = mirror_atom ; -plane->order = 2 ; -plane->nparam = 4 ; -for( k = 0, rab = 0 ; k < DIMENSION ; k++ ){ - dx[k] = Atoms[i].x[k] - Atoms[j].x[k] ; - midpoint[k] = ( Atoms[i].x[k] + Atoms[j].x[k] ) / 2.0 ; - rab += dx[k]*dx[k] ; - } -rab = sqrt(rab) ; -if( rab < ToleranceSame ){ - fprintf( stderr, "Atoms %d and %d coincide (r = %g)\n", i, j, rab ) ; - exit( EXIT_FAILURE ) ; - } -for( k = 0, r = 0 ; k < DIMENSION ; k++ ){ - plane->normal[k] = dx[k]/rab ; - r += midpoint[k]*plane->normal[k] ; - } -if( r < 0 ){ /* Reverce normal direction, distance is always positive! */ - r = -r ; - for( k = 0 ; k < DIMENSION ; k++ ){ - plane->normal[k] = -plane->normal[k] ; - } - } -plane->distance = r ; -if( verbose > 0 ) printf( " initial plane is at %g from the origin\n", r ) ; -if( refine_symmetry_element( plane, 1 ) < 0 ){ - if( verbose > 0 ) printf( " refinement failed for the plane\n" ) ; - destroy_symmetry_element( plane ) ; - return NULL ; - } -return plane ; -} - -SYMMETRY_ELEMENT * -init_ultimate_plane( void ) -{ - SYMMETRY_ELEMENT * plane = alloc_symmetry_element() ; - double d0[ DIMENSION ], d1[ DIMENSION ], d2[ DIMENSION ] ; - double p[ DIMENSION ] ; - double r, s0, s1, s2 ; - double * d ; - int i, j, k ; - -if( verbose > 0 ) printf( "Trying whole-molecule mirror plane\n" ) ; -StatTotal++ ; -plane->transform_atom = mirror_atom ; -plane->order = 1 ; -plane->nparam = 4 ; -for( k = 0 ; k < DIMENSION ; k++ ) - d0[k] = d1[k] = d2[k] = 0 ; -d0[0] = 1 ; d1[1] = 1 ; d2[2] = 1 ; -for( i = 1 ; i < AtomsCount ; i++ ){ - for( j = 0 ; j < i ; j++ ){ - for( k = 0, r = 0 ; k < DIMENSION ; k++ ){ - p[k] = Atoms[i].x[k] - Atoms[j].x[k] ; - r += p[k]*p[k] ; - } - r = sqrt(r) ; - for( k = 0, s0=s1=s2=0 ; k < DIMENSION ; k++ ){ - p[k] /= r ; - s0 += p[k]*d0[k] ; - s1 += p[k]*d1[k] ; - s2 += p[k]*d2[k] ; - } - for( k = 0 ; k < DIMENSION ; k++ ){ - d0[k] -= s0*p[k] ; - d1[k] -= s1*p[k] ; - d2[k] -= s2*p[k] ; - } - } - } -for( k = 0, s0=s1=s2=0 ; k < DIMENSION ; k++ ){ - s0 += d0[k] ; - s1 += d1[k] ; - s2 += d2[k] ; - } -d = NULL ; -if( s0 >= s1 && s0 >= s2 ) d = d0 ; -if( s1 >= s0 && s1 >= s2 ) d = d1 ; -if( s2 >= s0 && s2 >= s1 ) d = d2 ; -if( d == NULL ){ - fprintf( stderr, "Catastrophe in init_ultimate_plane(): %g, %g and %g have no ordering!\n", s0, s1, s2 ) ; - exit( EXIT_FAILURE ) ; - } -for( k = 0, r = 0 ; k < DIMENSION ; k++ ) - r += d[k]*d[k] ; -r = sqrt(r) ; -if( r > 0 ){ - for( k = 0 ; k < DIMENSION ; k++ ) - plane->normal[k] = d[k]/r ; - } -else { - for( k = 1 ; k < DIMENSION ; k++ ) - plane->normal[k] = 0 ; - plane->normal[0] = 1 ; - } -for( k = 0, r = 0 ; k < DIMENSION ; k++ ) - r += CenterOfSomething[k]*plane->normal[k] ; -plane->distance = r ; -for( k = 0 ; k < AtomsCount ; k++ ) - plane->transform[k] = k ; -if( refine_symmetry_element( plane, 0 ) < 0 ){ - if( verbose > 0 ) printf( " refinement failed for the plane\n" ) ; - destroy_symmetry_element( plane ) ; - return NULL ; - } -return plane ; -} -/* - * Inversion-center specific functions - */ -void -invert_atom( SYMMETRY_ELEMENT *center, ATOM *from, ATOM *to ) -{ - int i ; - -to->type = from->type ; -for( i = 0 ; i < DIMENSION ; i++ ){ - to->x[i] = 2*center->distance*center->normal[i] - from->x[i] ; - } -} - -SYMMETRY_ELEMENT * -init_inversion_center( void ) -{ - SYMMETRY_ELEMENT * center = alloc_symmetry_element() ; - int k ; - double r ; - -if( verbose > 0 ) printf( "Trying inversion center at the center of something\n" ) ; -StatTotal++ ; -center->transform_atom = invert_atom ; -center->order = 2 ; -center->nparam = 4 ; -for( k = 0, r = 0 ; k < DIMENSION ; k++ ) - r += CenterOfSomething[k]*CenterOfSomething[k] ; -r = sqrt(r) ; -if( r > 0 ){ - for( k = 0 ; k < DIMENSION ; k++ ) - center->normal[k] = CenterOfSomething[k]/r ; - } -else { - center->normal[0] = 1 ; - for( k = 1 ; k < DIMENSION ; k++ ) - center->normal[k] = 0 ; - } -center->distance = r ; -if( verbose > 0 ) printf( " initial inversion center is at %g from the origin\n", r ) ; -if( refine_symmetry_element( center, 1 ) < 0 ){ - if( verbose > 0 ) printf( " refinement failed for the inversion center\n" ) ; - destroy_symmetry_element( center ) ; - return NULL ; - } -return center ; -} - -/* - * Normal rotation axis-specific routines. - */ -void -rotate_atom( SYMMETRY_ELEMENT *axis, ATOM *from, ATOM *to ) -{ - double x[3], y[3], a[3], b[3], c[3] ; - double angle = axis->order ? 2*M_PI/axis->order : 1.0 ; - double a_sin = sin( angle ) ; - double a_cos = cos( angle ) ; - double dot ; - int i ; - -if( DIMENSION != 3 ){ - fprintf( stderr, "Catastrophe in rotate_atom!\n" ) ; - exit( EXIT_FAILURE ) ; - } -for( i = 0 ; i < 3 ; i++ ) - x[i] = from->x[i] - axis->distance * axis->normal[i] ; -for( i = 0, dot = 0 ; i < 3 ; i++ ) - dot += x[i] * axis->direction[i] ; -for( i = 0 ; i < 3 ; i++ ) - a[i] = axis->direction[i] * dot ; -for( i = 0 ; i < 3 ; i++ ) - b[i] = x[i] - a[i] ; -c[0] = b[1]*axis->direction[2] - b[2]*axis->direction[1] ; -c[1] = b[2]*axis->direction[0] - b[0]*axis->direction[2] ; -c[2] = b[0]*axis->direction[1] - b[1]*axis->direction[0] ; -for( i = 0 ; i < 3 ; i++ ) - y[i] = a[i] + b[i]*a_cos + c[i]*a_sin ; -for( i = 0 ; i < 3 ; i++ ) - to->x[i] = y[i] + axis->distance * axis->normal[i] ; -to->type = from->type ; -} - -SYMMETRY_ELEMENT * -init_ultimate_axis(void) -{ - SYMMETRY_ELEMENT * axis = alloc_symmetry_element() ; - double dir[ DIMENSION ], rel[ DIMENSION ] ; - double s ; - int i, k ; - -if( verbose > 0 ) printf( "Trying infinity axis\n" ) ; -StatTotal++ ; -axis->transform_atom = rotate_atom ; -axis->order = 0 ; -axis->nparam = 7 ; -for( k = 0 ; k < DIMENSION ; k++ ) - dir[k] = 0 ; -for( i = 0 ; i < AtomsCount ; i++ ){ - for( k = 0, s = 0 ; k < DIMENSION ; k++ ){ - rel[k] = Atoms[i].x[k] - CenterOfSomething[k] ; - s += rel[k]*dir[k] ; - } - if( s >= 0 ) - for( k = 0 ; k < DIMENSION ; k++ ) - dir[k] += rel[k] ; - else for( k = 0 ; k < DIMENSION ; k++ ) - dir[k] -= rel[k] ; - } -for( k = 0, s = 0 ; k < DIMENSION ; k++ ) - s += pow2( dir[k] ) ; -s = sqrt(s) ; -if( s > 0 ) - for( k = 0 ; k < DIMENSION ; k++ ) - dir[k] /= s ; -else dir[0] = 1 ; -for( k = 0 ; k < DIMENSION ; k++ ) - axis->direction[k] = dir[k] ; -for( k = 0, s = 0 ; k < DIMENSION ; k++ ) - s += pow2( CenterOfSomething[k] ) ; -s = sqrt(s) ; -if( s > 0 ) - for( k = 0 ; k < DIMENSION ; k++ ) - axis->normal[k] = CenterOfSomething[k]/s ; -else { - for( k = 1 ; k < DIMENSION ; k++ ) - axis->normal[k] = 0 ; - axis->normal[0] = 1 ; - } -axis->distance = s ; -for( k = 0 ; k < AtomsCount ; k++ ) - axis->transform[k] = k ; -if( refine_symmetry_element( axis, 0 ) < 0 ){ - if( verbose > 0 ) printf( " refinement failed for the infinity axis\n" ) ; - destroy_symmetry_element( axis ) ; - return NULL ; - } -return axis ; -} - - -SYMMETRY_ELEMENT * -init_c2_axis( int i, int j, double support[ DIMENSION ] ) -{ - SYMMETRY_ELEMENT * axis ; - int k ; - double ris, rjs ; - double r, center[ DIMENSION ] ; - -if( verbose > 0 ) - printf( "Trying c2 axis for the pair (%d,%d) with the support (%g,%g,%g)\n", - i, j, support[0], support[1], support[2] ) ; -StatTotal++ ; -/* First, do a quick sanity check */ -for( k = 0, ris = rjs = 0 ; k < DIMENSION ; k++ ){ - ris += pow2( Atoms[i].x[k] - support[k] ) ; - rjs += pow2( Atoms[j].x[k] - support[k] ) ; - } -ris = sqrt( ris ) ; -rjs = sqrt( rjs ) ; -if( fabs( ris - rjs ) > TolerancePrimary ){ - StatEarly++ ; - if( verbose > 0 ) printf( " Support can't actually define a rotation axis\n" ) ; - return NULL ; - } -axis = alloc_symmetry_element() ; -axis->transform_atom = rotate_atom ; -axis->order = 2 ; -axis->nparam = 7 ; -for( k = 0, r = 0 ; k < DIMENSION ; k++ ) - r += CenterOfSomething[k]*CenterOfSomething[k] ; -r = sqrt(r) ; -if( r > 0 ){ - for( k = 0 ; k < DIMENSION ; k++ ) - axis->normal[k] = CenterOfSomething[k]/r ; - } -else { - axis->normal[0] = 1 ; - for( k = 1 ; k < DIMENSION ; k++ ) - axis->normal[k] = 0 ; - } -axis->distance = r ; -for( k = 0, r = 0 ; k < DIMENSION ; k++ ){ - center[k] = ( Atoms[i].x[k] + Atoms[j].x[k] ) / 2 - support[k] ; - r += center[k]*center[k] ; - } -r = sqrt(r) ; -if( r <= TolerancePrimary ){ /* c2 is underdefined, let's do something special */ - if( MolecularPlane != NULL ){ - if( verbose > 0 ) printf( " c2 is underdefined, but there is a molecular plane\n" ) ; - for( k = 0 ; k < DIMENSION ; k++ ) - axis->direction[k] = MolecularPlane->normal[k] ; - } - else { - if( verbose > 0 ) printf( " c2 is underdefined, trying random direction\n" ) ; - for( k = 0 ; k < DIMENSION ; k++ ) - center[k] = Atoms[i].x[k] - Atoms[j].x[k] ; - if( fabs( center[2] ) + fabs( center[1] ) > ToleranceSame ){ - axis->direction[0] = 0 ; - axis->direction[1] = center[2] ; - axis->direction[2] = -center[1] ; - } - else { - axis->direction[0] = -center[2] ; - axis->direction[1] = 0 ; - axis->direction[2] = center[0] ; - } - for( k = 0, r = 0 ; k < DIMENSION ; k++ ) - r += axis->direction[k] * axis->direction[k] ; - r = sqrt(r) ; - for( k = 0 ; k < DIMENSION ; k++ ) - axis->direction[k] /= r ; - } - } -else { /* direction is Ok, renormalize it */ - for( k = 0 ; k < DIMENSION ; k++ ) - axis->direction[k] = center[k]/r ; - } -if( refine_symmetry_element( axis, 1 ) < 0 ){ - if( verbose > 0 ) printf( " refinement failed for the c2 axis\n" ) ; - destroy_symmetry_element( axis ) ; - return NULL ; - } -return axis ; -} - -SYMMETRY_ELEMENT * -init_axis_parameters( double a[3], double b[3], double c[3] ) -{ - SYMMETRY_ELEMENT * axis ; - int i, order, sign ; - double ra, rb, rc, rab, rbc, rac, r ; - double angle ; - -ra = rb = rc = rab = rbc = rac = 0 ; -for( i = 0 ; i < DIMENSION ; i++ ){ - ra += a[i]*a[i] ; - rb += b[i]*b[i] ; - rc += c[i]*c[i] ; - } -ra = sqrt(ra) ; rb = sqrt(rb) ; rc = sqrt(rc) ; -if( fabs( ra - rb ) > TolerancePrimary || fabs( ra - rc ) > TolerancePrimary || fabs( rb - rc ) > TolerancePrimary ){ - StatEarly++ ; - if( verbose > 0 ) printf( " points are not on a sphere\n" ) ; - return NULL ; - } -for( i = 0 ; i < DIMENSION ; i++ ){ - rab += (a[i]-b[i])*(a[i]-b[i]) ; - rac += (a[i]-c[i])*(a[i]-c[i]) ; - rbc += (c[i]-b[i])*(c[i]-b[i]) ; - } -rab = sqrt(rab) ; -rac = sqrt(rac) ; -rbc = sqrt(rbc) ; -if( fabs( rab - rbc ) > TolerancePrimary ){ - StatEarly++ ; - if( verbose > 0 ) printf( " points can't be rotation-equivalent\n" ) ; - return NULL ; - } -if( rab <= ToleranceSame || rbc <= ToleranceSame || rac <= ToleranceSame ){ - StatEarly++ ; - if( verbose > 0 ) printf( " rotation is underdefined by these points\n" ) ; - return NULL ; - } -rab = (rab+rbc)/2 ; -angle = M_PI - 2*asin( rac/(2*rab) ) ; -if( verbose > 1 ) printf( " rotation angle is %f\n", angle ) ; -if( fabs(angle) <= M_PI/(MaxAxisOrder+1) ){ - StatEarly++ ; - if( verbose > 0 ) printf( " atoms are too close to a straight line\n" ) ; - return NULL ; - } -order = floor( (2*M_PI)/angle + 0.5 ) ; -if( order <= 2 || order > MaxAxisOrder ){ - StatEarly++ ; - if( verbose > 0 ) printf( " rotation axis order (%d) is not from 3 to %d\n", order, MaxAxisOrder ) ; - return NULL ; - } -axis = alloc_symmetry_element() ; -axis->order = order ; -axis->nparam = 7 ; -for( i = 0, r = 0 ; i < DIMENSION ; i++ ) - r += CenterOfSomething[i]*CenterOfSomething[i] ; -r = sqrt(r) ; -if( r > 0 ){ - for( i = 0 ; i < DIMENSION ; i++ ) - axis->normal[i] = CenterOfSomething[i]/r ; - } -else { - axis->normal[0] = 1 ; - for( i = 1 ; i < DIMENSION ; i++ ) - axis->normal[i] = 0 ; - } -axis->distance = r ; -axis->direction[0] = (b[1]-a[1])*(c[2]-b[2]) - (b[2]-a[2])*(c[1]-b[1]) ; -axis->direction[1] = (b[2]-a[2])*(c[0]-b[0]) - (b[0]-a[0])*(c[2]-b[2]) ; -axis->direction[2] = (b[0]-a[0])*(c[1]-b[1]) - (b[1]-a[1])*(c[0]-b[0]) ; -/* - * Arbitrarily select axis direction so that first non-zero component - * or the direction is positive. - */ -sign = 0 ; -if( axis->direction[0] <= 0 ) { - if( axis->direction[0] < 0 ){ - sign = 1 ; - } else if( axis->direction[1] <= 0 ){ - if( axis->direction[1] < 0 ){ - sign = 1 ; - } else if( axis->direction[2] < 0 ){ - sign = 1 ; - } - } -} -if( sign ) - for( i = 0 ; i < DIMENSION ; i++ ) - axis->direction[i] = -axis->direction[i] ; -for( i = 0, r = 0 ; i < DIMENSION ; i++ ) - r += axis->direction[i]*axis->direction[i] ; -r = sqrt(r) ; -for( i = 0 ; i < DIMENSION ; i++ ) - axis->direction[i] /= r ; -if( verbose > 1 ){ - printf( " axis origin is at (%g,%g,%g)\n", - axis->normal[0]*axis->distance, axis->normal[1]*axis->distance, axis->normal[2]*axis->distance ) ; - printf( " axis is in the direction (%g,%g,%g)\n", axis->direction[0], axis->direction[1], axis->direction[2] ) ; - } -return axis ; -} - -SYMMETRY_ELEMENT * -init_higher_axis( int ia, int ib, int ic ) -{ - SYMMETRY_ELEMENT * axis ; - double a[ DIMENSION ], b[ DIMENSION ], c[ DIMENSION ] ; - int i ; - -if( verbose > 0 ) printf( "Trying cn axis for the triplet (%d,%d,%d)\n", ia, ib, ic ) ; -StatTotal++ ; -/* Do a quick check of geometry validity */ -for( i = 0 ; i < DIMENSION ; i++ ){ - a[i] = Atoms[ia].x[i] - CenterOfSomething[i] ; - b[i] = Atoms[ib].x[i] - CenterOfSomething[i] ; - c[i] = Atoms[ic].x[i] - CenterOfSomething[i] ; - } -if( ( axis = init_axis_parameters( a, b, c ) ) == NULL ){ - if( verbose > 0 ) printf( " no coherrent axis is defined by the points\n" ) ; - return NULL ; - } -axis->transform_atom = rotate_atom ; -if( refine_symmetry_element( axis, 1 ) < 0 ){ - if( verbose > 0 ) printf( " refinement failed for the c%d axis\n", axis->order ) ; - destroy_symmetry_element( axis ) ; - return NULL ; - } -return axis ; -} - -/* - * Improper axes-specific routines. - * These are obtained by slight modifications of normal rotation - * routines. - */ -void -rotate_reflect_atom( SYMMETRY_ELEMENT *axis, ATOM *from, ATOM *to ) -{ - double x[3], y[3], a[3], b[3], c[3] ; - double angle = 2*M_PI/axis->order ; - double a_sin = sin( angle ) ; - double a_cos = cos( angle ) ; - double dot ; - int i ; - -if( DIMENSION != 3 ){ - fprintf( stderr, "Catastrophe in rotate_reflect_atom!\n" ) ; - exit( EXIT_FAILURE ) ; - } -for( i = 0 ; i < 3 ; i++ ) - x[i] = from->x[i] - axis->distance * axis->normal[i] ; -for( i = 0, dot = 0 ; i < 3 ; i++ ) - dot += x[i] * axis->direction[i] ; -for( i = 0 ; i < 3 ; i++ ) - a[i] = axis->direction[i] * dot ; -for( i = 0 ; i < 3 ; i++ ) - b[i] = x[i] - a[i] ; -c[0] = b[1]*axis->direction[2] - b[2]*axis->direction[1] ; -c[1] = b[2]*axis->direction[0] - b[0]*axis->direction[2] ; -c[2] = b[0]*axis->direction[1] - b[1]*axis->direction[0] ; -for( i = 0 ; i < 3 ; i++ ) - y[i] = -a[i] + b[i]*a_cos + c[i]*a_sin ; -for( i = 0 ; i < 3 ; i++ ) - to->x[i] = y[i] + axis->distance * axis->normal[i] ; -to->type = from->type ; -} - -SYMMETRY_ELEMENT * -init_improper_axis( int ia, int ib, int ic ) -{ - SYMMETRY_ELEMENT * axis ; - double a[ DIMENSION ], b[ DIMENSION ], c[ DIMENSION ] ; - double centerpoint[ DIMENSION ] ; - double r ; - int i ; - -if( verbose > 0 ) printf( "Trying sn axis for the triplet (%d,%d,%d)\n", ia, ib, ic ) ; -StatTotal++ ; -/* First, reduce the problem to Cn case */ -for( i = 0 ; i < DIMENSION ; i++ ){ - a[i] = Atoms[ia].x[i] - CenterOfSomething[i] ; - b[i] = Atoms[ib].x[i] - CenterOfSomething[i] ; - c[i] = Atoms[ic].x[i] - CenterOfSomething[i] ; - } -for( i = 0, r = 0 ; i < DIMENSION ; i++ ){ - centerpoint[i] = a[i] + c[i] + 2*b[i] ; - r += centerpoint[i]*centerpoint[i] ; - } -r = sqrt(r) ; -if( r <= ToleranceSame ){ - StatEarly++ ; - if( verbose > 0 ) printf( " atoms can not define improper axis of the order more than 2\n" ) ; - return NULL ; - } -for( i = 0 ; i < DIMENSION ; i++ ) - centerpoint[i] /= r ; -for( i = 0, r = 0 ; i < DIMENSION ; i++ ) - r += centerpoint[i] * b[i] ; -for( i = 0 ; i < DIMENSION ; i++ ) - b[i] = 2*r*centerpoint[i] - b[i] ; -/* Do a quick check of geometry validity */ -if( ( axis = init_axis_parameters( a, b, c ) ) == NULL ){ - if( verbose > 0 ) printf( " no coherrent improper axis is defined by the points\n" ) ; - return NULL ; - } -axis->transform_atom = rotate_reflect_atom ; -if( refine_symmetry_element( axis, 1 ) < 0 ){ - if( verbose > 0 ) printf( " refinement failed for the s%d axis\n", axis->order ) ; - destroy_symmetry_element( axis ) ; - return NULL ; - } -return axis ; -} - -/* - * Control routines - */ - -void -find_center_of_something( void ) -{ - int i, j ; - double coord_sum[ DIMENSION ] ; - double r ; - -for( j = 0 ; j < DIMENSION ; j++ ) - coord_sum[j] = 0 ; -for( i = 0 ; i < AtomsCount ; i++ ){ - for( j = 0 ; j < DIMENSION ; j++ ) - coord_sum[j] += Atoms[i].x[j] ; - } -for( j = 0 ; j < DIMENSION ; j++ ) - CenterOfSomething[j] = coord_sum[j]/AtomsCount ; -if( verbose > 0 ) - printf( "Center of something is at %15.10f, %15.10f, %15.10f\n", - CenterOfSomething[0], CenterOfSomething[1], CenterOfSomething[2] ) ; -DistanceFromCenter = (double *) calloc( AtomsCount, sizeof( double ) ) ; -if( DistanceFromCenter == NULL ){ - fprintf( stderr, "Unable to allocate array for the distances\n" ) ; - exit( EXIT_FAILURE ) ; - } -for( i = 0 ; i < AtomsCount ; i++ ){ - for( j = 0, r = 0 ; j < DIMENSION ; j++ ) - r += pow2( Atoms[i].x[j] - CenterOfSomething[j] ) ; - DistanceFromCenter[i] = r ; - } -} - -void -find_planes(void) -{ - int i, j ; - SYMMETRY_ELEMENT * plane ; - -plane = init_ultimate_plane() ; -if( plane != NULL ){ - MolecularPlane = plane ; - PlanesCount++ ; - Planes = (SYMMETRY_ELEMENT **) realloc( Planes, sizeof( SYMMETRY_ELEMENT* ) * PlanesCount ) ; - if( Planes == NULL ){ - perror( "Out of memory in find_planes" ) ; - exit( EXIT_FAILURE ) ; - } - Planes[ PlanesCount - 1 ] = plane ; - } -for( i = 1 ; i < AtomsCount ; i++ ){ - for( j = 0 ; j < i ; j++ ){ - if( Atoms[i].type != Atoms[j].type ) - continue ; - if( ( plane = init_mirror_plane( i, j ) ) != NULL ){ - PlanesCount++ ; - Planes = (SYMMETRY_ELEMENT **) realloc( Planes, sizeof( SYMMETRY_ELEMENT* ) * PlanesCount ) ; - if( Planes == NULL ){ - perror( "Out of memory in find_planes" ) ; - exit( EXIT_FAILURE ) ; - } - Planes[ PlanesCount - 1 ] = plane ; - } - } - } -} - -void -find_inversion_centers(void) -{ - SYMMETRY_ELEMENT * center ; - -if( ( center = init_inversion_center() ) != NULL ){ - InversionCenters = (SYMMETRY_ELEMENT **) calloc( 1, sizeof( SYMMETRY_ELEMENT* ) ) ; - InversionCenters[0] = center ; - InversionCentersCount = 1 ; - } -} - -void -find_infinity_axis(void) -{ - SYMMETRY_ELEMENT * axis ; - -if( ( axis = init_ultimate_axis() ) != NULL ){ - NormalAxesCount++ ; - NormalAxes = (SYMMETRY_ELEMENT **) realloc( NormalAxes, sizeof( SYMMETRY_ELEMENT* ) * NormalAxesCount ) ; - if( NormalAxes == NULL ){ - perror( "Out of memory in find_infinity_axes()" ) ; - exit( EXIT_FAILURE ) ; - } - NormalAxes[ NormalAxesCount - 1 ] = axis ; - } -} - -void -find_c2_axes(void) -{ - int i, j, k, l, m ; - double center[ DIMENSION ] ; - double * distances = calloc( AtomsCount, sizeof( double ) ) ; - double r ; - SYMMETRY_ELEMENT * axis ; - -if( distances == NULL ){ - fprintf( stderr, "Out of memory in find_c2_axes()\n" ) ; - exit( EXIT_FAILURE ) ; - } -for( i = 1 ; i < AtomsCount ; i++ ){ - for( j = 0 ; j < i ; j++ ){ - if( Atoms[i].type != Atoms[j].type ) - continue ; - if( fabs( DistanceFromCenter[i] - DistanceFromCenter[j] ) > TolerancePrimary ) - continue ; /* A very cheap, but quite effective check */ - /* - * First, let's try to get it cheap and use CenterOfSomething - */ - for( k = 0, r = 0 ; k < DIMENSION ; k++ ){ - center[k] = ( Atoms[i].x[k] + Atoms[j].x[k] ) / 2 ; - r += pow2( center[k] - CenterOfSomething[k] ) ; - } - r = sqrt(r) ; - if( r > 5*TolerancePrimary ){ /* It's Ok to use CenterOfSomething */ - if( ( axis = init_c2_axis( i, j, CenterOfSomething ) ) != NULL ){ - NormalAxesCount++ ; - NormalAxes = (SYMMETRY_ELEMENT **) realloc( NormalAxes, sizeof( SYMMETRY_ELEMENT* ) * NormalAxesCount ) ; - if( NormalAxes == NULL ){ - perror( "Out of memory in find_c2_axes" ) ; - exit( EXIT_FAILURE ) ; - } - NormalAxes[ NormalAxesCount - 1 ] = axis ; - } - continue ; - } - /* - * Now, C2 axis can either pass through an atom, or through the - * middle of the other pair. - */ - for( k = 0 ; k < AtomsCount ; k++ ){ - if( ( axis = init_c2_axis( i, j, Atoms[k].x ) ) != NULL ){ - NormalAxesCount++ ; - NormalAxes = (SYMMETRY_ELEMENT **) realloc( NormalAxes, sizeof( SYMMETRY_ELEMENT* ) * NormalAxesCount ) ; - if( NormalAxes == NULL ){ - perror( "Out of memory in find_c2_axes" ) ; - exit( EXIT_FAILURE ) ; - } - NormalAxes[ NormalAxesCount - 1 ] = axis ; - } - } - /* - * Prepare data for an additional pre-screening check - */ - for( k = 0 ; k < AtomsCount ; k++ ){ - for( l = 0, r = 0 ; l < DIMENSION ; l++ ) - r += pow2( Atoms[k].x[l] - center[l] ) ; - distances[k] = sqrt(r) ; - } - for( k = 0 ; k < AtomsCount ; k++ ){ - for( l = 0 ; l < AtomsCount ; l++ ){ - if( Atoms[k].type != Atoms[l].type ) - continue ; - if( fabs( DistanceFromCenter[k] - DistanceFromCenter[l] ) > TolerancePrimary || - fabs( distances[k] - distances[l] ) > TolerancePrimary ) - continue ; /* We really need this one to run reasonably fast! */ - for( m = 0 ; m < DIMENSION ; m++ ) - center[m] = ( Atoms[k].x[m] + Atoms[l].x[m] ) / 2 ; - if( ( axis = init_c2_axis( i, j, center ) ) != NULL ){ - NormalAxesCount++ ; - NormalAxes = (SYMMETRY_ELEMENT **) realloc( NormalAxes, sizeof( SYMMETRY_ELEMENT* ) * NormalAxesCount ) ; - if( NormalAxes == NULL ){ - perror( "Out of memory in find_c2_axes" ) ; - exit( EXIT_FAILURE ) ; - } - NormalAxes[ NormalAxesCount - 1 ] = axis ; - } - } - } - } - } -free( distances ) ; -} - -void -find_higher_axes(void) -{ - int i, j, k ; - SYMMETRY_ELEMENT * axis ; - -for( i = 0 ; i < AtomsCount ; i++ ){ - for( j = i + 1 ; j < AtomsCount ; j++ ){ - if( Atoms[i].type != Atoms[j].type ) - continue ; - if( fabs( DistanceFromCenter[i] - DistanceFromCenter[j] ) > TolerancePrimary ) - continue ; /* A very cheap, but quite effective check */ - for( k = 0 ; k < AtomsCount ; k++ ){ - if( Atoms[i].type != Atoms[k].type ) - continue ; - if( ( fabs( DistanceFromCenter[i] - DistanceFromCenter[k] ) > TolerancePrimary ) || - ( fabs( DistanceFromCenter[j] - DistanceFromCenter[k] ) > TolerancePrimary ) ) - continue ; - if( ( axis = init_higher_axis( i, j, k ) ) != NULL ){ - NormalAxesCount++ ; - NormalAxes = (SYMMETRY_ELEMENT **) realloc( NormalAxes, sizeof( SYMMETRY_ELEMENT* ) * NormalAxesCount ) ; - if( NormalAxes == NULL ){ - perror( "Out of memory in find_higher_axes" ) ; - exit( EXIT_FAILURE ) ; - } - NormalAxes[ NormalAxesCount - 1 ] = axis ; - } - } - } - } -} - -void -find_improper_axes(void) -{ - int i, j, k ; - SYMMETRY_ELEMENT * axis ; - -/* -//#pragma omp parallel for private(i,j,k, axis) \ -//shared (ImproperAxesCount, ImproperAxes) \ -//schedule (guided) -*/ -for( i = 0 ; i < AtomsCount ; i++ ){ - for( j = i + 1 ; j < AtomsCount ; j++ ){ - for( k = 0 ; k < AtomsCount ; k++ ){ - //#pragma inline - if( ( axis = init_improper_axis( i, j, k ) ) != NULL ){ - //#pragma omp critical - { - ImproperAxesCount++ ; - ImproperAxes = (SYMMETRY_ELEMENT **) realloc( ImproperAxes, sizeof( SYMMETRY_ELEMENT* ) * ImproperAxesCount ) ; - if( ImproperAxes == NULL ){ - perror( "Out of memory in find_higher_axes" ) ; - exit( EXIT_FAILURE ) ; - } - ImproperAxes[ ImproperAxesCount - 1 ] = axis ; - } - } - } - } - } -} - -void -report_planes( void ) -{ - int i ; - -if( PlanesCount == 0 ) - printf( "There are no planes of symmetry in the molecule\n" ) ; -else { - if( PlanesCount == 1 ) - printf( "There is a plane of symmetry in the molecule\n" ) ; - else printf( "There are %d planes of symmetry in the molecule\n", PlanesCount ) ; - printf( " Residual Direction of the normal Distance\n" ) ; - for( i = 0 ; i < PlanesCount ; i++ ){ - printf( "%3d %8.4e ", i, Planes[i]->maxdev ) ; - printf( "(%11.8f,%11.8f,%11.8f) ", Planes[i]->normal[0], Planes[i]->normal[1], Planes[i]->normal[2] ) ; - printf( "%14.8f\n", Planes[i]->distance ) ; - } - } -} - -void -report_inversion_centers( void ) -{ -if( InversionCentersCount == 0 ) - printf( "There is no inversion center in the molecule\n" ) ; -else { - printf( "There in an inversion center in the molecule\n" ) ; - printf( " Residual Position\n" ) ; - printf( " %8.4e ", InversionCenters[0]->maxdev ) ; - printf( "(%14.8f,%14.8f,%14.8f)\n", - InversionCenters[0]->distance * InversionCenters[0]->normal[0], - InversionCenters[0]->distance * InversionCenters[0]->normal[1], - InversionCenters[0]->distance * InversionCenters[0]->normal[2] ) ; - } -} - -void -report_axes( void ) -{ - int i ; - -if( NormalAxesCount == 0 ) - printf( "There are no normal axes in the molecule\n" ) ; -else { - if( NormalAxesCount == 1 ) - printf( "There is a normal axis in the molecule\n" ) ; - else printf( "There are %d normal axes in the molecule\n", NormalAxesCount ) ; - printf( " Residual Order Direction of the axis Supporting point\n" ) ; - for( i = 0 ; i < NormalAxesCount ; i++ ){ - printf( "%3d %8.4e ", i, NormalAxes[i]->maxdev ) ; - if( NormalAxes[i]->order == 0 ) - printf( "Inf " ) ; - else printf( "%3d ", NormalAxes[i]->order ) ; - printf( "(%11.8f,%11.8f,%11.8f) ", - NormalAxes[i]->direction[0], NormalAxes[i]->direction[1], NormalAxes[i]->direction[2] ) ; - printf( "(%14.8f,%14.8f,%14.8f)\n", - NormalAxes[0]->distance * NormalAxes[0]->normal[0], - NormalAxes[0]->distance * NormalAxes[0]->normal[1], - NormalAxes[0]->distance * NormalAxes[0]->normal[2] ) ; - } - } -} - -void -report_improper_axes( void ) -{ - int i ; - -if( ImproperAxesCount == 0 ) - printf( "There are no improper axes in the molecule\n" ) ; -else { - if( ImproperAxesCount == 1 ) - printf( "There is an improper axis in the molecule\n" ) ; - else printf( "There are %d improper axes in the molecule\n", ImproperAxesCount ) ; - printf( " Residual Order Direction of the axis Supporting point\n" ) ; - for( i = 0 ; i < ImproperAxesCount ; i++ ){ - printf( "%3d %8.4e ", i, ImproperAxes[i]->maxdev ) ; - if( ImproperAxes[i]->order == 0 ) - printf( "Inf " ) ; - else printf( "%3d ", ImproperAxes[i]->order ) ; - printf( "(%11.8f,%11.8f,%11.8f) ", - ImproperAxes[i]->direction[0], ImproperAxes[i]->direction[1], ImproperAxes[i]->direction[2] ) ; - printf( "(%14.8f,%14.8f,%14.8f)\n", - ImproperAxes[0]->distance * ImproperAxes[0]->normal[0], - ImproperAxes[0]->distance * ImproperAxes[0]->normal[1], - ImproperAxes[0]->distance * ImproperAxes[0]->normal[2] ) ; - } - } -} - -/* - * General symmetry handling - */ -void -report_and_reset_counters( void ) -{ -printf( " %10ld candidates examined\n" - " %10ld removed early\n" - " %10ld removed during initial mating stage\n" - " %10ld removed as duplicates\n" - " %10ld removed because of the wrong transformation order\n" - " %10ld removed after unsuccessful optimization\n" - " %10ld accepted\n", - StatTotal, StatEarly, StatPairs, StatDups, StatOrder, StatOpt, StatAccept ) ; -StatTotal = StatEarly = StatPairs = StatDups = StatOrder = StatOpt = StatAccept = 0 ; -} - -void -find_symmetry_elements( void ) -{ -find_center_of_something() ; -if( verbose > -1 ){ - printf( "Looking for the inversion center\n" ) ; - } -find_inversion_centers() ; -if( verbose > -1 ){ - report_and_reset_counters() ; - printf( "Looking for the planes of symmetry\n" ) ; - } -find_planes() ; -if( verbose > -1 ){ - report_and_reset_counters() ; - printf( "Looking for infinity axis\n" ) ; - } -find_infinity_axis() ; -if( verbose > -1 ){ - report_and_reset_counters() ; - printf( "Looking for C2 axes\n" ) ; - } -find_c2_axes() ; -if( verbose > -1 ){ - report_and_reset_counters() ; - printf( "Looking for higher axes\n" ) ; - } -find_higher_axes() ; -if( verbose > -1 ){ - report_and_reset_counters() ; - printf( "Looking for the improper axes\n" ) ; - } -find_improper_axes() ; -if( verbose > -1 ){ - report_and_reset_counters() ; - } -} - -int -compare_axes( const void *a, const void *b ) -{ - SYMMETRY_ELEMENT * axis_a = *(SYMMETRY_ELEMENT**) a ; - SYMMETRY_ELEMENT * axis_b = *(SYMMETRY_ELEMENT**) b ; - int i, order_a, order_b ; - -order_a = axis_a->order ; if( order_a == 0 ) order_a = 10000 ; -order_b = axis_b->order ; if( order_b == 0 ) order_b = 10000 ; -if( ( i = order_b - order_a ) != 0 ) return i ; -if( axis_a->maxdev > axis_b->maxdev ) return -1 ; -if( axis_a->maxdev < axis_b->maxdev ) return 1 ; -return 0 ; -} - -void -sort_symmetry_elements( void ) -{ -if( PlanesCount > 1 ){ - qsort( Planes, PlanesCount, sizeof( SYMMETRY_ELEMENT * ), compare_axes ) ; - } -if( NormalAxesCount > 1 ){ - qsort( NormalAxes, NormalAxesCount, sizeof( SYMMETRY_ELEMENT * ), compare_axes ) ; - } -if( ImproperAxesCount > 1 ){ - qsort( ImproperAxes, ImproperAxesCount, sizeof( SYMMETRY_ELEMENT * ), compare_axes ) ; - } -} - -void -report_symmetry_elements_verbose( void ) -{ -report_inversion_centers() ; -report_axes() ; -report_improper_axes() ; -report_planes() ; -} - -void -summarize_symmetry_elements( void ) -{ - int i ; - -NormalAxesCounts = (int*) calloc( MaxAxisOrder+1, sizeof( int ) ) ; -ImproperAxesCounts = (int*) calloc( MaxAxisOrder+1, sizeof( int ) ) ; -for( i = 0 ; i < NormalAxesCount ; i++ ) - NormalAxesCounts[ NormalAxes[i]->order ]++ ; -for( i = 0 ; i < ImproperAxesCount ; i++ ) - ImproperAxesCounts[ ImproperAxes[i]->order ]++ ; -} - -void -report_symmetry_elements_brief( void ) -{ - int i ; - char * symmetry_code = calloc( 1, 10*(PlanesCount+NormalAxesCount+ImproperAxesCount+InversionCentersCount+2) ) ; - char buf[ 100 ] ; - -if( symmetry_code == NULL ){ - fprintf( stderr, "Unable to allocate memory for symmetry ID code in report_symmetry_elements_brief()\n" ) ; - exit( EXIT_FAILURE ) ; - } -/*if( PlanesCount + NormalAxesCount + ImproperAxesCount + InversionCentersCount == 0 ) - printf( "Molecule has no symmetry elements\n" ) ; //PP -else {*/ -if( PlanesCount + NormalAxesCount + ImproperAxesCount + InversionCentersCount > 0 ){ - //printf( "Molecule has the following symmetry elements: " ) ; //PP - if( InversionCentersCount > 0 ) strcat( symmetry_code, "(i) " ) ; - if( NormalAxesCounts[0] == 1 ) - strcat( symmetry_code, "(Cinf) " ) ; - if( NormalAxesCounts[0] > 1 ) { - sprintf( buf, "%d*(Cinf) ", NormalAxesCounts[0] ) ; - strcat( symmetry_code, buf ) ; - } - for( i = MaxAxisOrder ; i >= 2 ; i-- ){ - if( NormalAxesCounts[i] == 1 ){ sprintf( buf, "(C%d) ", i ) ; strcat( symmetry_code, buf ) ; } - if( NormalAxesCounts[i] > 1 ){ sprintf( buf, "%d*(C%d) ", NormalAxesCounts[i], i ) ; strcat( symmetry_code, buf ) ; } - } - for( i = MaxAxisOrder ; i >= 2 ; i-- ){ - if( ImproperAxesCounts[i] == 1 ){ sprintf( buf, "(S%d) ", i ) ; strcat( symmetry_code, buf ) ; } - if( ImproperAxesCounts[i] > 1 ){ sprintf( buf, "%d*(S%d) ", ImproperAxesCounts[i], i ) ; strcat( symmetry_code, buf ) ; } - } - if( PlanesCount == 1 ) strcat( symmetry_code, "(sigma) " ) ; - if( PlanesCount > 1 ){ sprintf( buf, "%d*(sigma) ", PlanesCount ) ; strcat( symmetry_code, buf ) ; } - //printf( "%s\n", symmetry_code ) ; //PP - } -SymmetryCode = symmetry_code ; -} - -void -report_symmetry_elements_brief_Conly( void ) -{ - int i ; - char * symmetry_code = calloc( 1, 10*(PlanesCount+NormalAxesCount+ImproperAxesCount+InversionCentersCount+2) ) ; - char buf[ 100 ] ; - -if( symmetry_code == NULL ){ - fprintf( stderr, "Unable to allocate memory for symmetry ID code in report_symmetry_elements_brief()\n" ) ; - exit( EXIT_FAILURE ) ; - } -if( PlanesCount + NormalAxesCount + ImproperAxesCount + InversionCentersCount == 0 ) - printf( "Molecule still has no symmetry elements...\n" ) ; -else { - for( i = MaxAxisOrder ; i >= 2 ; i-- ){ - if( NormalAxesCounts[i] >= 1 ){ sprintf( buf, "C%d ", i ) ; strcat( MaxRotAxis, buf ) ; } - } - } -} - -int -identify_point_group( void ) -{ - int i ; - int last_matching = -1 ; - int matching_count = 0 ; - -for( i = 0 ; i < PointGroupsCount ; i++ ){ - if( strcmp( SymmetryCode, PointGroups[i].symmetry_code ) == 0 ){ - if( PointGroups[i].check() == 1 ){ - last_matching = i ; - matching_count++ ; - } - else { - if( verbose > -2 ){ - printf( "It looks very much like %s, but it is not since %s\n", - PointGroups[i].group_name, PointGroupRejectionReason ) ; - } - } - } - } -if( matching_count == 0 ){ - //printf( "WARNING: These symmetry elements match no point group I know of. Sorry.\n" - // "Trying fallback mode to highest recognized Axis...\n" ) ; - return -1; -} -if( matching_count > 1 ){ - printf( "These symmetry elements match more than one group I know of.\n" - "SOMETHING IS VERY WRONG\n" ) ; - printf( "Matching groups are:\n" ) ; - for( i = 0 ; i < PointGroupsCount ; i++ ){ - if( ( strcmp( SymmetryCode, PointGroups[i].symmetry_code ) == 0 ) && ( PointGroups[i].check() == 1 ) ){ - printf( " %s\n", PointGroups[i].group_name ) ; - } - } - return -1; - } -if( matching_count == 1 ){ - //printf( "It seems to be the %s point group\n", PointGroups[last_matching].group_name ) ; //PP - return last_matching; - } - else { - return -1; - } -} - -/* - * Input/Output - */ - -int -read_coordinates( FILE *in ) -{ - int i ; - -if( fscanf( in, "%d", &AtomsCount ) != 1 ){ - fprintf( stderr, "Error reading atom count\n" ) ; - return -1 ; - } -if( verbose > 0 ) printf( "Atoms count = %d\n", AtomsCount ) ; -Atoms = calloc( AtomsCount, sizeof( ATOM ) ) ; -if( Atoms == NULL ){ - fprintf( stderr, "Out of memory for atoms coordinates\n" ) ; - return -1 ; - } -for( i = 0 ; i < AtomsCount ; i++ ){ - if( fscanf( in, "%d %lg %lg %lg\n", &Atoms[i].type, &Atoms[i].x[0], &Atoms[i].x[1], &Atoms[i].x[2] ) != 4 ){ - fprintf( stderr, "Error reading description of the atom %d\n", i ) ; - return -1 ; - } - } -return 0 ; -} - - -void schoenflies(int natoms, int* attype, double* coord, char* symbol, double* paramar) - { - int last_pg ; - int i; - -// //re-initialize Variables: - PlanesCount = 0 ; - InversionCentersCount = 0 ; - NormalAxesCount = 0 ; - ImproperAxesCount = 0 ; - BadOptimization = 0 ; - SymmetryCode = "" ; -// *MaxRotAxis = "" ; - strncpy(MaxRotAxis, "", 2); -// /* -// * Statistics -// */ -StatTotal = 0 ; -StatEarly = 0 ; -StatPairs = 0 ; -StatDups = 0 ; -StatOrder = 0 ; -StatOpt = 0 ; -StatAccept = 0 ; - - - setbuf(stdout, NULL); - AtomsCount = natoms; - //Allocate space for ATOMS - Atoms = calloc( AtomsCount, sizeof( ATOM ) ) ; - // fill atoms array: - if( Atoms == NULL ){ - fprintf( stderr, "Out of memory for atoms coordinates\n" ) ; - //return -1 ; - } - for( i = 0 ; i < AtomsCount ; i++ ){ - Atoms[i].type = attype[i]; - Atoms[i].x[0] = coord[3*i]; - Atoms[i].x[1] = coord[3*i+1]; - Atoms[i].x[2] = coord[3*i+2]; - } - -// if( fscanf( in, "%d %lg %lg %lg\n", &Atoms[i].type, &Atoms[i].x[0], &Atoms[i].x[1], &Atoms[i].x[2] ) != 4 ){ -// fprintf( stderr, "Error reading description of the atom %d\n", i ) ; -// return -1 ; -// } - - //get parameters from array, integers first - verbose = paramar[0]; - MaxAxisOrder = paramar[1]; - MaxOptCycles = paramar[2]; - ToleranceSame = paramar[3]; - TolerancePrimary = paramar[4]; - ToleranceFinal = paramar[5]; - MaxOptStep = paramar[6]; - MinOptStep = paramar[7]; - GradientStep = paramar[8]; - OptChangeThreshold = paramar[9]; - OptChangeHits = paramar[10]; - - find_symmetry_elements() ; - sort_symmetry_elements() ; - summarize_symmetry_elements() ; - /* - if( BadOptimization ) - printf( "Refinement of some symmetry elements was terminated before convergence was reached.\n" - "Some symmetry elements may remain unidentified.\n" ) ; - */ //PP - report_symmetry_elements_brief() ; - last_pg = identify_point_group() ; - if(last_pg >= 0){ - strcpy(symbol,PointGroups[last_pg].group_name); - } - else { - report_symmetry_elements_brief_Conly() ; - if(MaxRotAxis[0] == '\0') { - strcpy(symbol,"C1"); - } - else { - strcpy(symbol,MaxRotAxis); - } - } - } - -int -old_main( int argc, char **argv ) -{ - char *program = *argv ; - FILE *in ; - -for( argc--, argv++ ; argc > 0 ; argc -= 2, argv += 2 ){ - if( **argv != '-' ) - break ; - if( strcmp( *argv, "-help" ) == 0 || - strcmp( *argv, "-h" ) == 0 || - strcmp( *argv, "-?" ) == 0 ){ - argc++ ; argv-- ; - printf( "%s [option value ...] [filename]\n" - "Valid options are:\n" - " -verbose (%3d) Determines verbosity level\n" - " All values above 0 are intended for debugging purposes\n" - " -maxaxisorder (%3d) Maximum order of rotation axis to look for\n" - " -maxoptcycles (%3d) Maximum allowed number of cycles in symmetry element optimization\n" - " -- Terminates option processing\n" - "Defaults should be Ok for these:\n" - " -same (%8g) Atoms are colliding if distance falls below this value\n" - " -primary (%8g) Initial loose criterion for atom equivalence\n" - " -final (%8g) Final criterion for atom equivalence\n" - " -maxoptstep (%8g) Largest step allowed in symmetry element optimization\n" - " -minoptstep (%8g) Termination criterion in symmetry element optimization\n" - " -gradstep (%8g) Finite step used in numeric gradient evaluation\n" - " -minchange (%8g) Minimum allowed change in target function\n" - " -minchgcycles (%8d) Number of minchange cycles before optimization stops\n", - program, verbose, MaxAxisOrder, MaxOptCycles, ToleranceSame, TolerancePrimary, - ToleranceFinal, MaxOptStep, MinOptStep, GradientStep, OptChangeThreshold, OptChangeHits ) ; - printf( "\n" - "Input is expected in the following format:\n" - "number_of_atoms\n" - "AtomicNumber X Y Z\n" - "...\n" ) ; - printf( "\n" - "Note that only primitive rotations will be reported\n" ) ; - printf( "This is version $Revision: 1.16 $ ($Date: 2003/04/04 13:05:03 $)\n" ) ; - exit( EXIT_SUCCESS ) ; - } - else - if( strcmp( *argv, "--" ) == 0 ){ - argc-- ; argv++ ; break ; - } - if( argc < 2 ){ - fprintf( stderr, "Missing argument for \"%s\"\n", *argv ) ; - exit( EXIT_FAILURE ) ; - } - if( strcmp( *argv, "-minchgcycles" ) == 0 ){ - if( sscanf( argv[1], "%d", &OptChangeHits ) != 1 ){ - fprintf( stderr, "Invalid parameter for -minchgcycles: \"%s\"\n", argv[1] ) ; - exit( EXIT_FAILURE ) ; - } - } - else - if( strcmp( *argv, "-minchange" ) == 0 ){ - if( sscanf( argv[1], "%lg", &OptChangeThreshold ) != 1 ){ - fprintf( stderr, "Invalid parameter for -minchange: \"%s\"\n", argv[1] ) ; - exit( EXIT_FAILURE ) ; - } - } - else - if( strcmp( *argv, "-same" ) == 0 ){ - if( sscanf( argv[1], "%lg", &ToleranceSame ) != 1 ){ - fprintf( stderr, "Invalid parameter for -same: \"%s\"\n", argv[1] ) ; - exit( EXIT_FAILURE ) ; - } - } - else - if( strcmp( *argv, "-primary" ) == 0 ){ - if( sscanf( argv[1], "%lg", &TolerancePrimary ) != 1 ){ - fprintf( stderr, "Invalid parameter for -primary: \"%s\"\n", argv[1] ) ; - exit( EXIT_FAILURE ) ; - } - } - else - if( strcmp( *argv, "-final" ) == 0 ){ - if( sscanf( argv[1], "%lg", &ToleranceFinal ) != 1 ){ - fprintf( stderr, "Invalid parameter for -final: \"%s\"\n", argv[1] ) ; - exit( EXIT_FAILURE ) ; - } - } - else - if( strcmp( *argv, "-maxoptstep" ) == 0 ){ - if( sscanf( argv[1], "%lg", &MaxOptStep ) != 1 ){ - fprintf( stderr, "Invalid parameter for -maxoptstep: \"%s\"\n", argv[1] ) ; - exit( EXIT_FAILURE ) ; - } - } - else - if( strcmp( *argv, "-minoptstep" ) == 0 ){ - if( sscanf( argv[1], "%lg", &MinOptStep ) != 1 ){ - fprintf( stderr, "Invalid parameter for -minoptstep: \"%s\"\n", argv[1] ) ; - exit( EXIT_FAILURE ) ; - } - } - else - if( strcmp( *argv, "-gradstep" ) == 0 ){ - if( sscanf( argv[1], "%lg", &GradientStep ) != 1 ){ - fprintf( stderr, "Invalid parameter for -gradstep: \"%s\"\n", argv[1] ) ; - exit( EXIT_FAILURE ) ; - } - } - else - if( strcmp( *argv, "-verbose" ) == 0 ){ - if( sscanf( argv[1], "%d", &verbose ) != 1 ){ - fprintf( stderr, "Invalid parameter for -verbose: \"%s\"\n", argv[1] ) ; - exit( EXIT_FAILURE ) ; - } - } - else - if( strcmp( *argv, "-maxoptcycles" ) == 0 ){ - if( sscanf( argv[1], "%d", &MaxOptCycles ) != 1 ){ - fprintf( stderr, "Invalid parameter for -maxoptcycles: \"%s\"\n", argv[1] ) ; - exit( EXIT_FAILURE ) ; - } - } - else - if( strcmp( *argv, "-maxaxisorder" ) == 0 ){ - if( sscanf( argv[1], "%d", &MaxAxisOrder ) != 1 ){ - fprintf( stderr, "Invalid parameter for -maxaxisorder: \"%s\"\n", argv[1] ) ; - exit( EXIT_FAILURE ) ; - } - } - else { - fprintf( stderr, "Unrecognized option \"%s\"\n", *argv ) ; - exit( EXIT_FAILURE ) ; - } - } -if( argc > 0 ){ - if( ( in = fopen( *argv, "rt" ) ) == NULL ){ - perror( *argv ) ; - exit( EXIT_FAILURE ) ; - } - } -else { - in = stdin ; - } -if( read_coordinates( in ) < 0 ){ - fprintf( stderr, "Error reading in atomic coordinates\n" ) ; - exit( EXIT_FAILURE ) ; - } -fclose( in ) ; -find_symmetry_elements() ; -sort_symmetry_elements() ; -summarize_symmetry_elements() ; -if( BadOptimization ) - printf( "Refinement of some symmetry elements was terminated before convergence was reached.\n" - "Some symmetry elements may remain unidentified.\n" ) ; -if( verbose >= 0 ) - report_symmetry_elements_verbose() ; -report_symmetry_elements_brief() ; -identify_point_group() ; -exit( EXIT_SUCCESS ) ; -} diff --git a/src/symmetry_i.f90 b/src/symmetry_i.f90 index d7b08b67..7a9cf9d2 100644 --- a/src/symmetry_i.f90 +++ b/src/symmetry_i.f90 @@ -1,8 +1,10 @@ !> symmetry_i.f90 !> Brute force symmetry analyzer - Fortran module !> +!> Fortran conversion of the original C code, 2026 Philipp Pracht +!> !> Original C code: (C) 1996, 2003 S. Patchkovskii -!> Fortran conversion of the original C code +!> !> !> This program is free software; you can redistribute it and/or modify !> it under the terms of the GNU General Public License as published by From 180efadb691095a3b57f0532cfd1680f0c5c6c35 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 20 Mar 2026 18:24:15 +0100 Subject: [PATCH 255/374] Small refactor of propcalc to remove old code --- src/CMakeLists.txt | 1 - src/algos/CMakeLists.txt | 1 + src/algos/meson.build | 1 + src/algos/propcalc.f90 | 56 +++ src/classes.f90 | 9 + src/confparse.f90 | 31 +- src/crest_main.f90 | 4 +- src/eval_timer.f90 | 3 +- src/meson.build | 1 - src/propcalc.f90 | 941 --------------------------------------- 10 files changed, 77 insertions(+), 971 deletions(-) create mode 100644 src/algos/propcalc.f90 delete mode 100644 src/propcalc.f90 diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 56b6489f..f508fb56 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -63,7 +63,6 @@ list(APPEND srcs "${dir}/ompmklset.F90" "${dir}/printouts.f90" "${dir}/prmat.f90" - "${dir}/propcalc.f90" "${dir}/readl.f90" "${dir}/restartlog.f90" "${dir}/scratch.f90" diff --git a/src/algos/CMakeLists.txt b/src/algos/CMakeLists.txt index 96d3e7fd..9e553584 100644 --- a/src/algos/CMakeLists.txt +++ b/src/algos/CMakeLists.txt @@ -38,6 +38,7 @@ list(APPEND srcs "${dir}/queueing.f90" "${dir}/alkylize.f90" "${dir}/dryrun.f90" + "${dir}/propcalc.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/algos/meson.build b/src/algos/meson.build index 025612af..90671de4 100644 --- a/src/algos/meson.build +++ b/src/algos/meson.build @@ -36,4 +36,5 @@ srcs += files( 'alkylize.f90', 'deform_opt_hess.f90', 'dryrun.f90', + 'propcalc.f90', ) diff --git a/src/algos/propcalc.f90 b/src/algos/propcalc.f90 new file mode 100644 index 00000000..01cef584 --- /dev/null +++ b/src/algos/propcalc.f90 @@ -0,0 +1,56 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2018-2020 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +!> Skeleton stub for property calculations on an ensemble. +!> Each mode needs to be implemented via modern algo routines. +!> The legacy implementation (system-call/I/O based) has been removed. +!> See git history for reference. + +subroutine propcalc(iname,imode,env,tim) + use crest_parameters + use crest_data + implicit none + character(len=*),intent(in) :: iname + integer,intent(in) :: imode + type(systemdata),intent(inout) :: env + type(timer),intent(inout) :: tim + + select case (imode) + case (p_prop_hess) + !> TODO: Hessian calculations for all conformers (was: xtb --hess) + case (p_prop_autoir) + !> TODO: IR spectrum averaging over populated conformers (was: autoir + xtb --ohess) + case (p_prop_ohess) + !> TODO: Optimization + Hessian for all conformers (was: xtb --ohess) + case (p_prop_gsolv) + !> TODO: Free energy in solvation, 2-step (was: xtb --sp + xtb --ohess) + case (p_prop_reopt) + !> TODO: Vtight reoptimization for all conformers (was: xtb --opt vtight) + case (p_prop_multilevel:p_prop_multilevel+9) + !> TODO: Multilevel/hybrid reoptimization of entire CRE, e.g. GFN2@GFF + !> (was: xtb --opt vtight with gfnver2) + case (p_prop_dipole) + !> TODO: Singlepoint + dipole extraction (was: xtb --sp, grep molecular dipole) + case (p_prop_rerank) + !> TODO: Singlepoint + reranking (was: xtb --sp + newcregen) + case default + write (stdout,'(a,i0,a)') 'propcalc: mode ',imode,' not yet implemented' + end select + +end subroutine propcalc diff --git a/src/classes.f90 b/src/classes.f90 index 7bcd7e18..a52cd6de 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -116,6 +116,15 @@ module crest_data integer,parameter,public :: p_thermo = -3654 integer,parameter,public :: p_useonly = -227 integer,parameter,public :: p_qcg = 37 +!>---- propcalc sub-modes (imode argument of propcalc / values in env%pqueue) + integer,parameter,public :: p_prop_hess = 1 !> Hessian for all conformers + integer,parameter,public :: p_prop_autoir = 2 !> IR spectrum averaging + integer,parameter,public :: p_prop_ohess = 10 !> Optimization + Hessian + integer,parameter,public :: p_prop_gsolv = 13 !> Free energy in solvation (2-step) + integer,parameter,public :: p_prop_reopt = 20 !> Vtight reoptimization + integer,parameter,public :: p_prop_multilevel = 50 !> Multilevel/hybrid reopt base (range 50:59) + integer,parameter,public :: p_prop_dipole = 998 !> Singlepoint + dipole extraction + integer,parameter,public :: p_prop_rerank = 999 !> Singlepoint + reranking !>--- exit status integer,parameter,public :: status_normal = 0 !> success diff --git a/src/confparse.f90 b/src/confparse.f90 index c1d202b6..f58378a1 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -2891,35 +2891,18 @@ subroutine parseflags(env,arg,nra) processedarg(i+1) = .true. PROPARG:select case(ctmp) case ('hess') !hessian calculation to free energies for all conformers - env%properties2 = 1 + env%properties2 = p_prop_hess case ('ohess') !optimization+hessian calculation - env%properties2 = 10 + env%properties2 = p_prop_ohess case ('autoir','autoIR') !automated IR averaging for populated (-pthr) conformers - env%properties2 = 2 - case ('b973c') !B97-3c optimization (xtb driver for ancopt) - env%properties2 = 3 - case ('b973cIR') !B97-3c optimization + IR spectra average - env%properties2 = 4 - case ('dft') !DFT (custom) job, read from dftrc - env%properties2 = 100 - case ('dftOPT') !DFT (custom) optimization (xtb driver for ancopt) - env%properties2 = 5 - case ('dftIR') !DFT (custom) optimization + IR spectra average - env%properties2 = 6 - case ('dftSP') !DFT (custom) singlepoint - env%properties2 = 7 - env%harcutpthr = 0.75 - case ('dftFREQ') !DFT (custom) optimization + frequencies - env%properties2 = 8 + env%properties2 = p_prop_autoir case ('reopt') !reoptimize only conformers at vtight level - env%properties2 = 20 - case ('TEST') !testSTUFF - env%properties2 = -9999 + env%properties2 = p_prop_reopt case ('singlepoint','sp') !singlepoint calculation and ensemble sorting - env%properties2 = 999 + env%properties2 = p_prop_rerank env%pclean = .true. - case ('dipole') !singlepoint calculation and dipole grepping - env%properties2 = 998 + case ('dipole') !singlepoint calculation and dipole grepping + env%properties2 = p_prop_dipole env%pclean = .true. case default env%properties2 = 0 diff --git a/src/crest_main.f90 b/src/crest_main.f90 index 5392ba53..416040f1 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -348,13 +348,13 @@ program CREST do i = 1,env%npq j = env%pqueue(i) select case (j) - case (1:8,10,20,100,998) + case (p_prop_hess,p_prop_autoir,p_prop_ohess,p_prop_reopt,p_prop_dipole) call propcalc(conformerfile,j,env,tim) case (45) call tim%start(15,'Conf. entropy evaluation') call newentropyextrapol(env) call tim%stop(15) - case (50:59) !hybrid reoptimization (e.g. gfn2@gff) + case (p_prop_multilevel:p_prop_multilevel+9) !hybrid reoptimization (e.g. gfn2@gff) call propcalc(infile,j,env,tim) infile = 'crest_reopt.xyz' case (70) !PCA and clustering diff --git a/src/eval_timer.f90 b/src/eval_timer.f90 index cd74ab9d..439c3f58 100644 --- a/src/eval_timer.f90 +++ b/src/eval_timer.f90 @@ -57,6 +57,5 @@ subroutine propquit(tim) implicit none type(timer) :: tim call eval_timer(tim) - write (stdout,*) 'CREST terminated normally.' - stop + call creststop(status_normal) end subroutine propquit diff --git a/src/meson.build b/src/meson.build index 89c8d413..00f4514a 100644 --- a/src/meson.build +++ b/src/meson.build @@ -60,7 +60,6 @@ srcs += files( 'ompmklset.F90', 'printouts.f90', 'prmat.f90', - 'propcalc.f90', 'readl.f90', 'restartlog.f90', 'scratch.f90', diff --git a/src/propcalc.f90 b/src/propcalc.f90 deleted file mode 100644 index 7d22d97d..00000000 --- a/src/propcalc.f90 +++ /dev/null @@ -1,941 +0,0 @@ -!================================================================================! -! This file is part of crest. -! -! Copyright (C) 2018-2020 Philipp Pracht -! -! crest is free software: you can redistribute it and/or modify it under -! the terms of the GNU Lesser General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! crest is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public License -! along with crest. If not, see . -!================================================================================! - -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!c Routines related to additonal property calculations -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -subroutine protreffrag(env) - use iso_fortran_env,wp => real64 - use crest_data - use strucrd,only:rdnat,rdcoord - implicit none - type(systemdata) :: env - integer,allocatable :: molvec(:) - integer,allocatable :: at(:) - real(wp),allocatable :: xyz(:,:) - - associate (nat => env%nat) -!------ get number of fragments for original structure - allocate (xyz(3,nat),at(nat),molvec(nat)) - call rdcoord('coord',nat,at,xyz) - call mrec(env%protb%nfrag,xyz,nat,at,molvec) !requires xyz in bohr - deallocate (molvec,at,xyz) - end associate -end subroutine protreffrag - -!--------------------------------------------------------------------------------------- -! perform a property calculation for a given ensemble file -!--------------------------------------------------------------------------------------- -subroutine propcalc(iname,imode,env,tim) - use iso_fortran_env,wp => real64 - use crest_data - use iomod - use strucrd,only:rdensembleparam,rdensemble,wrxyz - use utilities,only:boltz2 - use cregen_interface - implicit none - - type(systemdata) :: env - type(timer) :: tim - integer :: imode - - character(len=*),intent(in) :: iname !file name - - integer :: i,k,r,ii - integer :: TMPCONF - integer :: P - integer :: ich,ich2 - - interface - subroutine prop_OMP_loop(env,TMPCONF,jobcall,pop) - import :: systemdata,wp - implicit none - - type(systemdata) :: env - integer :: TMPCONF - character(len=1024) :: jobcall - real(wp),intent(in),optional :: pop(TMPCONF) - end subroutine - end interface - - character(len=20) :: xname - character(len=20) :: pipe - character(len=80) :: solv - character(len=256) :: ctmp - character(len=512) :: str,thispath,tmppath,optpath - character(len=1024):: jobcall - character(len=:),allocatable :: largejobcall - - real(wp) :: pthr,sumpop - integer :: maxpop - integer :: nat,nall,ng,T,Tn - logical :: ex,update - logical :: niceprint - - character(len=40),allocatable :: origin(:) - real(wp),allocatable :: eread(:),popul(:),dumm(:) - real(wp),allocatable :: xyz(:,:,:) - integer,allocatable :: at(:) - logical,allocatable :: mask(:) - integer,allocatable :: degen(:,:) - -!--- - call largehead('P R O P E R T Y C A L C U L A T I O N') - -!--- some settings - solv = '' - pipe = '2>/dev/null' - xname = 'struc.xyz' - call getcwd(thispath) - update = .true. - maxpop = 1 - - if (env%properties == -666) then - imode = env%properties2 - end if - - niceprint = env%niceprint - - pthr = env%pthr - -!---- read the input ensemble - call rdensembleparam(iname,nat,nall) - env%nat = nat - if (nall .lt. 1) return - allocate (xyz(3,nat,nall),at(nat),eread(nall),mask(nall)) - mask = .true. - if (.not.env%trackorigin) then - call rdensemble(iname,nat,nall,at,xyz,eread) - else - allocate (origin(nall)) - call rdensemble_origin(iname,nat,nall,at,xyz,eread,origin) - end if - TMPCONF = nall - -!---- Use only populated conformers for special applications - if (any((/2,111/) == imode)) then - - allocate (popul(nall)) - call boltz2(nall,eread,popul) - !write(*,*) eread - !write(*,*) popul - k = 0 - maxpop = maxloc(popul(:),1) !locate max. populated structure (this one is always taken) - sumpop = 0.0_wp - do i = 1,nall - if (popul(i) .ge. pthr.or.i .eq. maxpop) then - k = k+1 - else - exit - end if - end do - write (*,'(1x,a,i0,a)') 'Population threshold (-pthr) : ',nint(pthr*100.0_wp),' %' - - write (*,'(1x,i0,a,i0,a)') k,' populated structure(s) (out of a total ', & - & nall,') will be considered.' - - mask(:) = popul(:) .ge. pthr - mask(maxpop) = .true. - end if - -!---- for multilevel reoptimization don't use all rotamers - if (imode .ge. 50.and.imode .lt. 60) then - inquire (file='cre_members',exist=ex) - if (ex) then - open (newunit=ich,file='cre_members') - read (ich,*) ng - allocate (degen(3,ng)) - do i = 1,ng - read (ich,*) degen(1:3,i) - end do - close (ich) - !-- always include lowest rotamer for all conf. - do i = 1,ng - mask(degen(2,i)) = .true. - end do - end if - end if - -!---- create the PROP directory - !---- create directory for the optimizations - optpath = 'PROP' - call rmrf(optpath) - r = makedir(trim(optpath)) - - call copysub('coord',trim(optpath)) - - call env%wrtCHRG(trim(optpath)) - call copysub(env%fixfile,trim(optpath)) - !call copysub(env%constraints,trim(optpath)) - if (env%useqmdff) then - call copysub('solvent',trim(optpath)) - end if - if (env%gfnver == '--gff') then - r = sylnk(trim(thispath)//'/'//'gfnff_topo',trim(optpath)//'/'//'gfnff_topo') - end if - - call chdir(trim(optpath)) - call getcwd(optpath) -!---- set up sub-directories - write (*,'(1x,a,a,a)',advance='no') 'writing TMPCONF* Dirs from file "',trim(iname),'" ...' - ii = 1 - do i = 1,nall - if ((imode .eq. 2).and.(allocated(popul))) then - if ((popul(i) .lt. pthr).and.i .ne. maxpop) cycle !skip unpopulated for '-prop autoir' - end if - if (.not.mask(i)) cycle - - write (ctmp,'(''TMPCONF'',i0)') ii - r = makedir(trim(ctmp)) - call chdir(ctmp) - open (newunit=ich,file=xname) - call wrxyz(ich,nat,at,xyz(:,:,i)) - - call write_cts(ich,env%cts) - close (ich) - - if (imode .eq. 2.and.trim(env%gfnver) .eq. '--gfn2') then - call add_mass_xtb(xname) - end if - - call chdir(optpath) - - call env%wrtCHRG(trim(ctmp)) - call copysub(env%fixfile,trim(ctmp)) - if (env%useqmdff) then - call copysub('solvent',trim(ctmp)) - end if - if (env%gfnver == '--gff') then - r = sylnk(trim(optpath)//'/'//'gfnff_topo',trim(ctmp)//'/'//'gfnff_topo') - end if - - ii = ii+1 - end do - write (*,'(1x,a)') 'done.' - - if (any(mask.eqv..false.)) then - TMPCONF = ii-1 - nall = ii-1 - if (allocated(popul)) deallocate (popul) - end if - -!--- setting the threads for correct parallelization - call new_ompautoset(env,'auto',TMPCONF,T,Tn) - -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - call chdir(thispath) -!--- select what to do - P = imode - select case (P) - case (1) - call smallhead('Hessian calculations for all conformers') - write (jobcall,'(a,1x,a,1x,a,'' --hess '',a,1x,a,'' >xtb.out'')') & - & trim(env%ProgName),trim(xname),trim(env%gfnver),trim(env%solv),trim(pipe) - case (10) - call smallhead('Optimization + Hessian calculations for all conformers') - write (jobcall,'(a,1x,a,1x,a,'' --ohess '',a,1x,a,'' >xtb.out'')') & - & trim(env%ProgName),trim(xname),trim(env%gfnver),trim(env%solv),trim(pipe) - case (13) - call smallhead('Free energy calculation in solvation') - write (jobcall,'(a,1x,a,1x,a,'' --sp '',a,'' >sp.out'')') & - & trim(env%ProgName),trim(xname),trim(env%gfnver),trim(pipe) !E_gas(Solv_geom) singlepoint - largejobcall = trim(jobcall)//' ; ' - write (jobcall,'(a,1x,a,1x,a,'' --ohess '',a,1x,a,'' >xtb.out'')') & - & trim(env%ProgName),trim(xname),trim(env%gfnver),trim(env%solv),trim(pipe) - jobcall = largejobcall//trim(jobcall) - case (2) - call smallhead('IR calculation for populated conformers') - write (jobcall,'(a,1x,a,1x,a,'' --ohess '',a,1x,a,'' >xtb.out'')') & - & trim(env%ProgName),trim(xname),trim(env%gfnver),trim(env%solv),trim(pipe) -! case( 3:6,7,8,100 ) ! unspecific case DFT -! call smallhead('DFT calculation using xtb as driver') -! if( any((/3,4/)==P) )then -! call dftrc_reader(env,.true.) !B97-3c OPT default -! call dftTMwarning -! else -! call dftrc_reader(env,.false.) !read DFT settings -! endif -! call chdir(optpath) -! call cefine_setup(env,TMPCONF) -! call xtbDFTdriver(env,xname,jobcall) !create jobcall - case (20) - call smallhead('Reoptimization for all conformers') - write (jobcall,'(a,1x,a,1x,a,'' --opt vtight '',a,1x,a,'' >xtb.out'')') & - & trim(env%ProgName),trim(xname),trim(env%gfnver),trim(env%solv),trim(pipe) - case (50:59) - call smallhead('Reoptimization of entire CRE') - write (jobcall,'(a,1x,a,1x,a,'' --opt vtight '',a,1x,a,'' >xtb.out'')') & - & trim(env%ProgName),trim(xname),trim(env%gfnver2),trim(env%solv),trim(pipe) - case default - write (jobcall,'(a,1x,a,1x,a,'' --sp '',a,1x,a,'' >xtb.out'')') & - & trim(env%ProgName),trim(xname),trim(env%gfnver),trim(env%solv),trim(pipe) - end select - call chdir(optpath) - -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - write (*,'(1x,a,i0,a)') 'Performing calculations for ', & - & TMPCONF,' structures ...' - call sleep(1) - call tim%start(10,'PROPERTY calc.') - allocate (dumm(TMPCONF),source=1.0_wp) - call prop_OMP_loop(env,TMPCONF,jobcall,dumm) !<------- this is where the "magic" happens - deallocate (dumm) - write (*,*) - call tim%stop(10) - write (*,*) 'done.' - - call tim%start(10,'PROPERTY calc.') - -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -!--- select what to do with the output - select case (imode) - -!------ generate an ensemble with free energies from hessian calculations - case (1,10) - call rdpropens(TMPCONF,nat,xyz) !get updated geometries - open (newunit=ich,file='crest_property.xyz') - do i = 1,TMPCONF - write (tmppath,'(a,i0,a,a)') 'TMPCONF',i,'/','xtb.out' - call grepval(tmppath,'TOTAL FREE ENERGY',ex,eread(i)) - if (.not.env%trackorigin) then - write (str,'(3x,f16.10)') eread(i) - else - write (str,'(3x,f16.10,2x,a,a)') eread(i),'!',trim(origin(i)) - end if - call wrxyz(ich,nat,at,xyz(:,:,i),trim(str)) - end do - close (ich) - env%ensemblename = 'crest_property.xyz' - env%confgo = .true. - - call newcregen(env,0) - - call rename('crest_property.xyz.sorted', & - & trim(thispath)//'/crest_property.xyz') - call remove(env%ensemblename) -!------ IR averaging - case (2) - call autoir(TMPCONF,imode,env) - call rdpropens(TMPCONF,nat,xyz) !get updated geometries - call wrpropens(TMPCONF,nat,xyz,at,eread) -!!----- DFT handling -! case( 3:8,100 ) -! call DFTprocessing(env,TMPCONF,nat,at) -!------ vtight reoptimization only for conformers! - case (20) - call rdpropens(TMPCONF,nat,xyz) !get updated geometries - call wrpropens(TMPCONF,nat,xyz,at,eread) - env%ensemblename = 'crest_property.xyz' - env%confgo = .true. - - call newcregen(env,0) - - call rename('crest_ensemble.xyz', & - & trim(thispath)//'/crest_conformers.xyz') - case (50:59) - call rdpropens(TMPCONF,nat,xyz) !get updated geometries - env%ensemblename = 'crest_reopt.xyz' - open (newunit=ich,file=env%ensemblename) - do i = 1,TMPCONF - write (tmppath,'(a,i0,a,a)') 'TMPCONF',i,'/','xtb.out' - call grepval(tmppath,'total energy',ex,eread(i)) - if (.not.env%trackorigin) then - write (str,'(3x,f16.10)') eread(i) - else - write (str,'(3x,f16.10,2x,a,a)') eread(i),'!',trim(origin(i)) - end if - call wrxyz(ich,nat,at,xyz(:,:,i),trim(str)) - end do - close (ich) - call rename(env%ensemblename,trim(thispath)//'/'//env%ensemblename) - call chdir(thispath) - if (imode .lt. 59) then !TODO temporary skip for some testing - env%confgo = .true. - - call newcregen(env,0) - - env%confgo = .false. - call rename(trim(env%ensemblename)//'.sorted', & - & env%ensemblename) - end if - - case (998) !singlepoint (no reranking) + dipoles - open (newunit=ich,file='crest_property.xyz') - open (newunit=ich2,file='crest.dipoles') - do i = 1,TMPCONF - write (tmppath,'(a,i0,a,a)') 'TMPCONF',i,'/','xtb.out' - call grepval(tmppath,'| TOTAL ENERGY',ex,eread(i)) - write (str,'(3x,f16.10)') eread(i) - call wrxyz(ich,nat,at,xyz(:,:,i),trim(str)) - - call grepcntxt(tmppath,'molecular dipole:',ex,ctmp,3) - if (ex) then - write (ich2,'(a)') trim(ctmp(10:)) - else - write (ich2,'(a)') '' - end if - end do - close (ich) - close (ich2) - - call rename('crest.dipoles', & - & trim(thispath)//'/'//'crest.dipoles') - - write (*,*) - write (*,*) 'Dipole moments for each conformer (x,y,z,total) written to crest.dipoles' - - case (999) !singlepoint reranking - open (newunit=ich,file='crest_property.xyz') - do i = 1,TMPCONF - write (tmppath,'(a,i0,a,a)') 'TMPCONF',i,'/','xtb.out' - call grepval(tmppath,'| TOTAL ENERGY',ex,eread(i)) - write (str,'(3x,f16.10)') eread(i) - call wrxyz(ich,nat,at,xyz(:,:,i),trim(str)) - end do - close (ich) - env%ensemblename = 'crest_property.xyz' - env%confgo = .true. - - call newcregen(env,0) - - call rename('crest_property.xyz.sorted', & - & trim(thispath)//'/crest_property.xyz') - call remove(env%ensemblename) - call rename('crest_ensemble.xyz', & - & trim(thispath)//'/crest_ensemble.xyz') - - case default - continue - end select - -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!>--- move around some files - - inquire (file='cregen.out.tmp',exist=ex) - if (ex) then - call cat('cregen.out.tmp') - end if - - inquire (file='crest.vibspectrum',exist=ex) - if (ex) then - call rename('crest.vibspectrum', & - & trim(thispath)//'/'//'crest.vibspectrum') - end if - - inquire (file='crest_property.xyz',exist=ex) - if (ex) then - call rename('crest_property.xyz', & - & trim(thispath)//'/'//'crest_property.xyz') - end if - - inquire (file='crest_populated.xyz',exist=ex) - if (ex) then - call rename('crest_populated.xyz', & - & trim(thispath)//'/'//'crest_populated.xyz') - end if - -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!>--- stop timer - - call tim%stop(10) - -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!>--- change back to original directory (just to be sure) - - call chdir(thispath) - -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!>--- decide if something has to be cleaned up here - - if (env%pclean) then - select case (imode) - case (20,50:59,998,999) - call rmrf('PROP') - case default - continue - end select - end if - - if (allocated(xyz)) deallocate (xyz) - if (allocated(at)) deallocate (at) - if (allocated(eread)) deallocate (eread) - if (allocated(origin)) deallocate (origin) - if (allocated(mask)) deallocate (mask) - if (allocated(popul)) deallocate (popul) - -end subroutine propcalc - -!---------------------------------------------------------------------------------------------------- -! THE OMP-PARALLEL LOOP -!---------------------------------------------------------------------------------------------------- -subroutine prop_OMP_loop(env,TMPCONF,jobcall,pop) - use iso_fortran_env,wp => real64 - use crest_data - use iomod - implicit none - - type(systemdata) :: env - integer :: TMPCONF - character(len=1024) :: jobcall - real(wp),intent(in),optional :: pop(TMPCONF) - - real(wp) :: pthr - logical :: niceprint - real(wp) :: percent - integer :: vz,k,i,maxpop,io - character(len=512) :: tmppath - -!----- quick settings - niceprint = env%niceprint - pthr = env%pthr - maxpop = maxloc(pop(:),1) - if (niceprint) then - call printprogbar(0.0_wp) - end if - k = 0 ! count finished jobs - -!$omp parallel & -!$omp shared( vz,jobcall,TMPCONF,pop,pthr,percent,k,niceprint,maxpop ) -!$omp single - do i = 1,TMPCONF - vz = i - !$omp task firstprivate( vz ) private( tmppath,io ) - call initsignal() - !$omp critical - write (tmppath,'(a,i0)') 'TMPCONF',vz - !$omp end critical - if (pop(vz) .ge. pthr.or.vz .eq. maxpop) then - call command('cd '//trim(tmppath)//' && '//trim(jobcall),io) - end if - !$omp critical - k = k+1 - if (niceprint) then - percent = float(k)/float(TMPCONF)*100 - call printprogbar(percent) - else - write (6,'(1x,i0)',advance='no') k - flush (6) - end if - !$omp end critical - !$omp end task - end do -!$omp taskwait -!$omp end single -!$omp end parallel - - return -end subroutine prop_OMP_loop - -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! grep total energies and printout energy list -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -subroutine etotprop(TMPCONF,pop,pr) - use iso_fortran_env,wp => real64 - use crest_data - use iomod - use utilities,only:boltz2 - implicit none - integer,intent(in) :: TMPCONF - real(wp),intent(inout) :: pop(TMPCONF) - logical :: pr - character(len=512) :: tmppath - logical :: ex - integer :: i - real(wp) :: dE - real(wp),allocatable :: eread(:) - - real(wp),parameter :: kcal = 627.5095_wp - - write (*,'(1x,a)') "Calculating populations from total energies ..." - allocate (eread(TMPCONF)) - do i = 1,TMPCONF - write (tmppath,'(a,i0,a,a)') 'TMPCONF',i,'/','xtb.out' - call grepval(tmppath,'total energy',ex,eread(i)) - end do - -!--- convert to populations - call boltz2(TMPCONF,eread,pop) - if (pr) then - write (*,'(a)') '=========================================================' - write (*,'(a)') '============= total energies & populations =============' - write (*,'(a)') '=========================================================' - write (*,'('' structure ΔE(kcal/mol) Etot(Eh) weight'')') - do i = 1,TMPCONF - dE = (eread(i)-eread(1))*kcal - write (*,'(i5,6x,F10.2,4x,F14.6,F13.4)') i,dE,eread(i),pop(i) - end do - write (*,*) - end if - deallocate (eread) - return -end subroutine etotprop - -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! grep optimized geometries (ONLY that, no energies) -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -subroutine rdpropens(TMPCONF,n,xyz) - use iso_fortran_env,wp => real64 - use crest_data - use iomod - implicit none - - integer,intent(in) :: TMPCONF - integer,intent(in) :: n - real(wp),intent(inout) :: xyz(3,n,TMPCONF) - - integer :: ich - character(len=512) :: tmppath,atmp - character(len=64) :: dum - logical :: ex - integer :: i,j - - real(wp),parameter :: kcal = 627.5095_wp - - do i = 1,TMPCONF - write (tmppath,'(a,i0,a,a)') 'TMPCONF',i,'/','xtbopt.xyz' - inquire (file=tmppath,exist=ex) - if (.not.ex) then - write (tmppath,'(a,i0,a,a)') 'TMPCONF',i,'/','struc.xyz' - end if - open (newunit=ich,file=tmppath) - read (ich,'(a)') atmp - read (ich,'(a)') atmp - do j = 1,n - read (ich,*) dum,xyz(1:3,j,i) - end do - close (ich) - end do - - return -end subroutine rdpropens -subroutine wrpropens(TMPCONF,n,xyz,at,eread) - use iso_fortran_env,wp => real64 - use crest_data - use iomod - use strucrd,only:wrxyz - implicit none - - integer,intent(in) :: TMPCONF - integer,intent(in) :: n - real(wp),intent(in) :: xyz(3,n,TMPCONF) - real(wp),intent(inout):: eread(TMPCONF) - integer,intent(in) :: at(n) - integer :: ich - character(len=512) :: tmppath - logical :: ex - integer :: i - - open (newunit=ich,file='crest_property.xyz') - do i = 1,TMPCONF - write (tmppath,'(a,i0,a,a)') 'TMPCONF',i,'/','xtb.out' - call grepval(tmppath,'total energy',ex,eread(i)) - call wrxyz(ich,n,at,xyz(:,:,i),eread(i)) - end do - return -end subroutine wrpropens -subroutine wrpropens_pop(env,TMPCONF,n,xyz,at,eread,pthr) - use iso_fortran_env,wp => real64 - use crest_data - use iomod - use strucrd,only:wrxyz - use utilities,only:boltz2 - implicit none - - type(systemdata) :: env - integer,intent(in) :: TMPCONF - integer,intent(in) :: n - real(wp),intent(in) :: xyz(3,n,TMPCONF) - real(wp),intent(in) :: eread(TMPCONF) - integer,intent(in) :: at(n) - real(wp),intent(in) :: pthr - integer :: ich,ich5 - integer :: i - integer :: pmax - real(wp),allocatable :: pop(:),dpop(:),edum(:) - - allocate (pop(TMPCONF),dpop(TMPCONF)) - call boltz2(TMPCONF,eread,pop) - pmax = maxloc(pop,1) - - dpop = pop - -! if(env%hardcutDFT)then -! call cutDFTpop(env,dpop,TMPCONF) -! allocate(edum(TMPCONF)) -! edum=eread -! do i=1,TMPCONF -! if(dpop(i).le.0.00001_wp)then -! edum(i)=0.0_wp -! endif -! enddo -! call boltz2(TMPCONF,edum,pop) -! deallocate(edum) -! endif - - open (newunit=ich5,file='autoir.pop') - open (newunit=ich,file='crest_populated.xyz') - do i = 1,TMPCONF - if (dpop(i) .lt. pthr.and.i .ne. pmax) cycle - write (ich5,'(1x,i0,1x,f6.4)') i,pop(i) - call wrxyz(ich,n,at,xyz(:,:,i),eread(i)) - end do - close (ich) - close (ich5) - deallocate (dpop,pop) - return -end subroutine wrpropens_pop - -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! obtain an averaged IR spectrum for the ensemble -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -subroutine autoir(TMPCONF,imode,env) - use iso_fortran_env,wp => real64 - use crest_data - use iomod - use utilities,only:boltz2 - implicit none - - type(systemdata) :: env - - integer,intent(in) :: TMPCONF - integer :: imode - - integer :: i,j,k,l - integer :: nall,nmodes,mnew,npop - integer :: ich,ich5 - character(len=512) :: tmppath - real(wp) :: dE - real(wp) :: pthr - logical :: ex - integer :: minl,minll(1),maxl - - real(wp),allocatable :: eread(:),pop(:),pop2(:),edum(:) - real(wp),allocatable :: vibspec(:,:,:) - - real(wp),allocatable :: freq(:),tmpfreq(:),dum(:) - real(wp),allocatable :: inten(:),tmpint(:) - - real(wp),parameter :: kcal = 627.5095_wp - - nall = TMPCONF - pthr = env%pthr - - write (*,*) - write (*,'(1x,a)') "Obtaining calculated vibspectra ..." - - select case (imode) - case (2) -!--- get the free energies for better weights - write (*,'(1x,a)') "Calculating populations from free energies ..." - allocate (eread(TMPCONF),pop(TMPCONF)) - do i = 1,TMPCONF - write (tmppath,'(a,i0,a,a)') 'TMPCONF',i,'/','xtb.out' - call grepval(tmppath,'TOTAL FREE ENERGY',ex,eread(i)) - end do - case default -!--- just energies - write (*,'(1x,a)') "Calculating populations from total energies ..." - allocate (eread(TMPCONF),pop(TMPCONF)) - do i = 1,TMPCONF - write (tmppath,'(a,i0,a,a)') 'TMPCONF',i,'/','xtb.out' - call grepval(tmppath,'total energy',ex,eread(i)) - end do - end select -!--- convert to populations - call boltz2(nall,eread,pop) -! if(env%hardcutDFT .and. imode.ne.2)then !special sort mode -! call cutDFTpop(env,pop,nall) -! allocate(edum(nall)) -! edum(1:nall)=eread(1:nall)*pop(1:nall) !set energies of removed structures to 0 -! call boltz2(nall,edum,pop) !convert to new populations, only with used structures -! endif - maxl = maxloc(pop(:),1) - -!--- short energy printout - write (*,*) - select case (imode) - case (2) - write (*,'(a)') '=========================================================' - write (*,'(a)') '============= free energies & populations ==============' - write (*,'(a)') '=========================================================' - write (*,'('' structure ΔG(kcal/mol) Gtot(Eh) weight'')') - case default - write (*,'(a)') '=========================================================' - write (*,'(a)') '============= total energies & populations =============' - write (*,'(a)') '=========================================================' - write (*,'('' structure ΔE(kcal/mol) Etot(Eh) weight'')') - end select - do i = 1,nall - dE = (eread(i)-eread(1))*kcal - write (*,'(i5,6x,F10.2,4x,F14.6,F13.4)') i,dE,eread(i),pop(i) - end do - write (*,*) - - !--- if only populated structures are required. - npop = 0 - do i = 1,TMPCONF - if (pop(i) .ge. pthr.or.i .eq. maxl) npop = npop+1 - end do - nall = npop - write (*,'(1x,i0,a,i0,a)') nall, & - & ' structures are above the population threshold of ',nint(pthr*100.0_wp),'%.' - -!--- read-in spectra - nmodes = env%nat*3 - allocate (vibspec(2,nmodes,nall),pop2(nall)) !vibspec(1,:,i)=frequencies of mol i - !vibspec(2,:,i)=intensities of mol i - - open (newunit=ich5,file='autoir.pop') - npop = 1 - do i = 1,TMPCONF - if (pop(i) .ge. pthr.or.i .eq. maxl) then - write (ich5,'(1x,i0,1x,f6.4)') i,pop(i) - write (tmppath,'(a,i0,a,a)') 'TMPCONF',i,'/','vibspectrum' - call rdvibs(tmppath,nmodes,vibspec(1,:,npop),vibspec(2,:,npop)) - pop2(npop) = pop(i) - npop = npop+1 - end if - end do - close (ich5) - - write (*,'(1x,a,i0,a)',advance='no') 'Weighting ',nall,' vibspectra ...' -!--- weight spectra and sort frequencies - mnew = (nmodes-6)*nall+6 - allocate (freq(mnew),inten(mnew)) -!--- write to new arrays - !--- translation first - do i = 1,6 - freq(i) = 0.0_wp - inten(i) = 0.0_wp - end do - !--- then the vibspectra - l = 7 - do k = 1,nall - do j = 7,nmodes - freq(l) = vibspec(1,j,k) - inten(l) = vibspec(2,j,k)*pop2(k) !scaled intensity - l = l+1 - end do - end do - -!--- sort in ascending order - allocate (tmpfreq(mnew),tmpint(mnew),dum(mnew-6)) - tmpfreq = 0.0_wp - tmpint = 0.0_wp - dum(:) = freq(7:mnew) - do i = 7,mnew - minll = minloc(dum) - minl = minll(1) - tmpfreq(i) = dum(minl) - tmpint(i) = inten(minl+6) - dum(minl) = 100000.0_wp - end do - freq = tmpfreq - inten = tmpint - deallocate (dum,tmpint,tmpfreq) - - write (*,'(1x,a)') "done." - write (*,*) - -!--- write new file - open (file='crest.vibspectrum',newunit=ich) - call write_tm_vibspectrum(ich,mnew,freq,inten) - write (*,'(1x,a)') 'Written to file ' - - deallocate (inten,freq,pop2,vibspec,pop,eread) - - return -end subroutine autoir - -!--- read vibspectrum file in TM format -subroutine rdvibs(fname,nmodes,freq,inten) - use iso_fortran_env,wp => real64 - use crest_data - use iomod - implicit none - - character(len=*),intent(in) :: fname - integer,intent(in) :: nmodes - real(wp),intent(out) :: freq(nmodes) !frequencies - real(wp),intent(out) :: inten(nmodes) !intensities - - integer :: k - integer :: ich,io,n - character(len=256) :: atmp - real(wp) :: floats(10) - logical :: ex - - freq = 0.0_wp - inten = 0.0_wp - - inquire (file=fname,exist=ex) - if (.not.ex) return - - k = 1 !modes - open (file=fname,newunit=ich) - rdfile: do - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - if (index(atmp,'$vibrational spectrum') .ne. 0) then - rdblock: do - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit rdfile - if (index(atmp,'$end') .ne. 0) exit rdfile - if (index(atmp,'#') .ne. 0) cycle rdblock !skip comment lines - call readl(atmp,floats,n) - freq(k) = floats(2) - inten(k) = floats(3) - k = k+1 - end do rdblock - end if - end do rdfile - - return -end subroutine rdvibs - -subroutine write_tm_vibspectrum(ich,n3,freq,ir_int) - use iso_fortran_env,wp => real64 - integer,intent(in) :: ich ! file handle - integer,intent(in) :: n3 - real(wp),intent(in) :: freq(n3) - real(wp),intent(in) :: ir_int(n3) - integer :: i - real(wp) :: thr = 0.01_wp - write (ich,'("$vibrational spectrum")') - write (ich,'("# mode symmetry wave number IR intensity selection rules")') - write (ich,'("# cm**(-1) (amu) IR RAMAN")') - do i = 1,n3 - if (abs(freq(i)) .lt. thr) then - write (ich,'(i6,9x, f18.2,f16.5,7x," - ",5x," - ")') & - i,freq(i),0.0_wp - else - write (ich,'(i6,8x,"a",f18.2,f16.5,7x,"YES",5x,"YES")') & - i,freq(i),ir_int(i) - end if - end do - write (ich,'("$end")') -end subroutine - From 676f7e9204b3fe27a3392370d82f45b1036be738 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 20 Mar 2026 19:20:50 +0100 Subject: [PATCH 256/374] refactor to remove legacy readl routine with modern Fortran --- src/CMakeLists.txt | 1 - src/confparse.f90 | 2 +- src/iomod.F90 | 60 ++++++++++-- src/meson.build | 1 - src/minitools.f90 | 1 + src/readl.f90 | 221 --------------------------------------------- 6 files changed, 55 insertions(+), 231 deletions(-) delete mode 100644 src/readl.f90 diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index f508fb56..a8fd548f 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -63,7 +63,6 @@ list(APPEND srcs "${dir}/ompmklset.F90" "${dir}/printouts.f90" "${dir}/prmat.f90" - "${dir}/readl.f90" "${dir}/restartlog.f90" "${dir}/scratch.f90" "${dir}/sdfio.f90" diff --git a/src/confparse.f90 b/src/confparse.f90 index f58378a1..c0323838 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -918,7 +918,7 @@ subroutine parseflags(env,arg,nra) case ('-SANDBOX') processedarg(i) = .true. - !>--- IMPLEMENT HERE WHATEVER YOU LIKE, FOR TESTING + !>--- readl vs readl_old test suite !>----- stop case ('-PLAYGROUND','-TEST') diff --git a/src/iomod.F90 b/src/iomod.F90 index 7823bfcb..47712c13 100644 --- a/src/iomod.F90 +++ b/src/iomod.F90 @@ -1,7 +1,7 @@ !================================================================================! ! This file is part of crest. ! -! Copyright (C) 2018-2025 Philipp Pracht +! Copyright (C) 2018-2026 Philipp Pracht ! ! crest is free software: you can redistribute it and/or modify it under ! the terms of the GNU Lesser General Public License as published by @@ -1120,9 +1120,8 @@ function truncate_zeros(str_in) result(str_out) end if end function truncate_zeros -!========================================================================================! -!========================================================================================! -!========================================================================================! +! ══════════════════════════════════════════════════════════════════════════════ +! ══════════════════════════════════════════════════════════════════════════════ subroutine getpath(fname,path) implicit none @@ -1391,9 +1390,8 @@ function dump_array_to_tmp(arr) result(fname) close (unit) end function dump_array_to_tmp -!========================================================================================! -!========================================================================================! -!========================================================================================! +! ══════════════════════════════════════════════════════════════════════════════ +! ══════════════════════════════════════════════════════════════════════════════ !> For some reason the behaviour of "call system" and "call execute_command_line" !> differs slightly beteen Intel and GNU versions of the program that I have build. @@ -1417,5 +1415,53 @@ end subroutine command !========================================================================================! !========================================================================================! !========================================================================================! +!> subroutine readl +!> Parse a line of text and extract all real(wp) numbers from it. +!> Numbers may be separated by whitespace (spaces or tabs). +!> Handles integers, reals, signed values, and scientific notation (E/D exponent). +!> This is a modern replacement for the legacy standalone readl subroutine. + subroutine readl(a1,x,n) + implicit none + character(len=*),intent(in) :: a1 + real(wp),intent(out) :: x(:) + integer,intent(out) :: n + integer :: pos,next_pos,slen,io + real(wp) :: val + character(len=:),allocatable :: token + + n = 0 + slen = len_trim(a1) + if (slen == 0) return + + pos = 1 + do + !> skip whitespace (spaces and tabs) + do while (pos <= slen) + if (a1(pos:pos) /= ' ' .and. a1(pos:pos) /= char(9)) exit + pos = pos+1 + end do + if (pos > slen) exit + + !> find end of token + next_pos = pos + do while (next_pos <= slen) + if (a1(next_pos:next_pos) == ' ' .or. a1(next_pos:next_pos) == char(9)) exit + next_pos = next_pos+1 + end do + + !> try to parse token as a real number + token = a1(pos:next_pos-1) + read (token,*,iostat=io) val + if (io == 0) then + n = n+1 + if (n <= size(x)) x(n) = val + end if + + pos = next_pos + end do + end subroutine readl + +! ══════════════════════════════════════════════════════════════════════════════ +! ══════════════════════════════════════════════════════════════════════════════ end module iomod diff --git a/src/meson.build b/src/meson.build index 00f4514a..c6a19520 100644 --- a/src/meson.build +++ b/src/meson.build @@ -60,7 +60,6 @@ srcs += files( 'ompmklset.F90', 'printouts.f90', 'prmat.f90', - 'readl.f90', 'restartlog.f90', 'scratch.f90', 'sdfio.f90', diff --git a/src/minitools.f90 b/src/minitools.f90 index 6299703d..1aa27306 100644 --- a/src/minitools.f90 +++ b/src/minitools.f90 @@ -217,6 +217,7 @@ subroutine prbweight(fname,Targ) !* comment lines (#) are ignored !***************************************************** use crest_parameters + use iomod, only: readl implicit none character(len=*) :: fname diff --git a/src/readl.f90 b/src/readl.f90 deleted file mode 100644 index 7d6ecf01..00000000 --- a/src/readl.f90 +++ /dev/null @@ -1,221 +0,0 @@ -!================================================================================! -! This file is part of crest. -! -! Copyright (C) 2020 Stefan Grimme -! -! crest is free software: you can redistribute it and/or modify it under -! the terms of the GNU Lesser General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! crest is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public License -! along with crest. If not, see . -!================================================================================! - -!========================================================================================! -subroutine readl(a1,x,n) - use iso_fortran_env,only:wp => real64 - implicit real(wp) (a-h,o-z) - character(*) a1 - integer :: la1,io,tmpi - dimension x(*) - la1 = len(a1) - if (la1 == 0) then - n = 0 - return - else if (la1 == 1) then - read (a1,*,iostat=io) tmpi - if (io == 0) then - x(1) = real(tmpi,wp) - n = 1 - end if - return - end if - i = 0 - is = 1 -10 i = i+1 - x(i) = readaa(a1,is,ib,ie) - if (ib .gt. 0.and.ie .gt. 0) then - is = ie - goto 10 - end if - n = i-1 - return -end subroutine readl - -!========================================================================================! -function readaa(a,istart,iend,iend2) - use iso_fortran_env,only:wp => real64 - implicit real(wp) (a-h,o-z) - real(wp) readaa - character(*) a - - NINE = ICHAR('9') - IZERO = ICHAR('0') - MINUS = ICHAR('-') - IDOT = ICHAR('.') - ND = ICHAR('D') - NE = ICHAR('E') - IBL = ICHAR(' ') - - iend = 0 - iend2 = 0 - idig = 0 - c1 = 0 - c2 = 0 - one = 1.d0 - x = 1.d0 - nl = len(a) - do j = istart,nl-1 - n = ichar(a(j:j)) - m = ichar(a(j+1:j+1)) - if (n .le. nine.and.n .ge. izero.or.n .eq. idot) goto 20 - if (n .eq. minus.and.(m .le. nine.and.m .ge. izero & - & .or.m .eq. idot)) goto 20 - end do - readaa = 0.d0 - return -20 continue - iend = j - do i = j,nl - n = ichar(a(i:i)) - if (n .le. nine.and.n .ge. izero) then - idig = idig+1 - if (idig .gt. 10) goto 60 - c1 = c1*10+n-izero - elseif (n .eq. minus.and.i .eq. j) then - one = -1.d0 - elseif (n .eq. idot) then - goto 40 - else - goto 60 - end if - end do -40 continue - idig = 0 - do ii = i+1,nl - n = ichar(a(ii:ii)) - if (n .le. nine.and.n .ge. izero) then - idig = idig+1 - if (idig .gt. 10) goto 60 - c2 = c2*10+n-izero - x = x/10 - elseif (n .eq. minus.and.ii .eq. i) then - x = -x - else - goto 60 - end if - end do - ! - ! put the pieces together - ! -60 continue - readaa = one*(c1+c2*x) - do j = iend,nl - n = ichar(a(j:j)) - iend2 = j - if (n .eq. ibl) return - if (n .eq. nd.or.n .eq. ne) goto 57 - end do - return - -57 c1 = 0.0d0 - one = 1.0d0 - do i = j+1,nl - n = ichar(a(i:i)) - iend2 = i - if (n .eq. ibl) goto 70 - if (n .le. nine.and.n .ge. izero) c1 = c1*10.0d0+n-izero - if (n .eq. minus) one = -1.0d0 - end do - continue -70 readaa = readaa*10**(one*c1) - return -end function readaa - -!========================================================================================! -!cuts the at blanks and tabstops and returns all floats and strings in order of occurence -subroutine cutline(line,floats,strings) - use iso_fortran_env,only:wp => real64 - implicit none - real(wp) floats(*),num - character(len=128) line,str,stmp - character(len=80) strings(3) - character(len=1) digit - integer i,ty,cs,cf - - stmp = '' - cs = 1 - cf = 1 - strings(:) = '' - do i = 1,len(trim(line)) - digit = line(i:i) - if (digit .ne. ' '.and.digit .ne. char(9)) then !should exclude tabstops and blanks, 9 is ascii code for tab - stmp = trim(stmp)//trim(digit) - elseif (stmp .ne. '') then - call checktype(stmp,num,str,ty) !get type of string, 0=number, 1=character - if (ty .eq. 0) then - floats(cf) = num - cf = cf+1 - elseif (ty .eq. 1) then - strings(cs) = trim(str) - cs = cs+1 - else - write (*,*) 'Problem in checktype, must abort' - exit - end if - stmp = '' - end if - if (i .eq. len(trim(line))) then !special case: end of line - call checktype(stmp,num,str,ty) - if (ty .eq. 0) then - floats(cf) = num - cf = cf+1 - elseif (ty .eq. 1) then - strings(cs) = trim(str) - cs = cs+1 - else - write (*,*) 'Problem in checktype, must abort' - exit - end if - stmp = '' - end if - end do -end subroutine cutline - -!========================================================================================! -!this checks the type of the string and returns it cast to real or as string. -subroutine checktype(field,num,str,ty) - use iso_fortran_env,only:wp => real64 - implicit none - character(len=*) field,str - real(wp) :: num - integer :: e,ty - logical :: is_num - - ty = 99 - str = '' - is_num = .false. - read (field,'(F10.5)',IOSTAT=e) num !cast string on real and get error code; 0 means success. - if (e .eq. 0) is_num = .true. - if (is_num) then - if (index(field,'.') .ne. 0) then !check for integer/real - read (field,'(F30.16)') num - ty = 0 - else !if integer, add .0 to string; otherwise cast to real does not work - str = trim(field)//'.0' - read (str,'(F30.16)') num - str = '' - ty = 0 - end if - else - str = field - ty = 1 - end if -end subroutine checktype - From e756c7317deb0e553e2832560aff14ee7b057524 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 20 Mar 2026 22:58:35 +0100 Subject: [PATCH 257/374] Test implementation of a Langevin and a Bussi-Parinello thermostat. The later one still seems bugged --- src/dynamics/dynamics_module.f90 | 209 ++++++++++++++++++++++++++++--- test/test_molecular_dynamics.F90 | 168 +++++++++++++++++++++++-- 2 files changed, 350 insertions(+), 27 deletions(-) diff --git a/src/dynamics/dynamics_module.f90 b/src/dynamics/dynamics_module.f90 index 371dbb10..826d57f2 100644 --- a/src/dynamics/dynamics_module.f90 +++ b/src/dynamics/dynamics_module.f90 @@ -79,6 +79,8 @@ module dynamics_module real(wp) :: tsoll = 0.0_wp !298.15_wp !> wanted temperature real(wp) :: Tavg = 0.0_wp !> trajectory-average temperature (set after dynamics()) + real(wp) :: Tvar = 0.0_wp !> trajectory temperature variance (set after dynamics()) + integer :: Ndf = 0 !> degrees of freedom used in the run (set after dynamics()) logical :: thermostat = .true. !> apply thermostat? character(len=64) :: thermotype = 'berendsen' real(wp) :: thermo_damp = 500.0_wp !> thermostat damping parameter @@ -121,7 +123,7 @@ subroutine dynamics(mol,dat,calc,pr,term) !* subroutine dynamics !* perform a molecular dynamics simulation !* the coordinate propagation is made with an -!* Leap-Frog algorithm (Velert-type algo) +!* Leap-Frog algorithm (Verlet-type algo) !************************************************************* implicit none @@ -136,7 +138,9 @@ subroutine dynamics(mol,dat,calc,pr,term) real(wp) :: epot,ekin,edum real(wp) :: temp,thermoscal !>--- averages & errors - real(wp) :: Tav,Epav,Ekav,Eerror + real(wp) :: Tav,Tav2,Epav,Ekav,Eerror +!>--- block statistics (computed before printout) + real(wp) :: eblk_mean,eblk_std,eblk_drift real(wp),allocatable :: grd(:,:) real(wp),allocatable :: velo(:,:) @@ -186,6 +190,7 @@ subroutine dynamics(mol,dat,calc,pr,term) end if !>--- averages tav = 0.0_wp + tav2 = 0.0_wp eerror = 0.0_wp ekav = 0.0_wp epav = 0.0_wp @@ -270,6 +275,7 @@ subroutine dynamics(mol,dat,calc,pr,term) call ekinet(mol%nat,velo,mass,ekin) temp = 2.0_wp*ekin/float(nfreedom)/kB tav = temp + tav2 = temp**2 end if end if call ekinet(mol%nat,velo,mass,ekin) @@ -415,12 +421,29 @@ subroutine dynamics(mol,dat,calc,pr,term) call ekinet(mol%nat,veln,mass,ekin) temp = 2.0_wp*ekin/float(nfreedom)/kB - !>--- THERMOSTATING (determine factor thermoscal) - call thermostating(mol,dat,temp,thermoscal) - - !>>-- STEP 3: velocity and position update - !>--- update velocities to t - vel = thermoscal*(velo+acc*tstep_au) + !>--- THERMOSTATING and velocity update + if (trim(dat%thermotype) == 'langevin') then + if (dat%thermostat) then + call langevin_step(mol%nat,dat,mass,velo,acc,tstep_au,vel) + else + vel = velo+acc*tstep_au + end if + else + !>>-- STEP 3: velocity update for scaling thermostats + !>--- compute trial velocity (unscaled leapfrog step) + vel = velo+acc*tstep_au + !>--- Bussi/CSVR: recompute ekin from the actual trial velocity so that + !>--- the scaling scal=sqrt(K_new/ekin) gives Ekin(vel_scaled)=K_new exactly. + !>--- Using the half-step estimate veln would give Ekin(vel_scaled)=K_new*(Efull/Ehalf) + !>--- and systematically overshoot the target temperature by ~Efull/Ehalf. + if (dat%thermostat .and. & + & (trim(dat%thermotype) == 'bussi' .or. trim(dat%thermotype) == 'csvr')) then + call ekinet(mol%nat,vel,mass,ekin) + temp = 2.0_wp*ekin/float(nfreedom)/kB + end if + call thermostating(mol,dat,temp,ekin,nfreedom,thermoscal) + vel = thermoscal*vel + end if !>--- update positions to t+dt, except for frozen atoms, and not at the final step if (t < dat%length_steps) then @@ -467,6 +490,7 @@ subroutine dynamics(mol,dat,calc,pr,term) edum = edum+epot+ekin eerror = edum/float(t)-epot-ekin tav = tav+temp + tav2 = tav2+temp**2 epav = epav+epot ekav = ekav+ekin dcount = dcount+1 @@ -481,15 +505,40 @@ subroutine dynamics(mol,dat,calc,pr,term) if (dat%wrtrj) close (trj) !$omp end critical +!>--- block energy statistics (blockrege still allocated here) + eblk_mean = 0.0_wp + eblk_std = 0.0_wp + eblk_drift = 0.0_wp + if (dat%nblock >= 1) then + eblk_mean = sum(dat%blockrege(1:dat%nblock))/real(dat%nblock,wp) + end if + if (dat%nblock >= 2) then + eblk_std = sqrt(sum((dat%blockrege(1:dat%nblock)-eblk_mean)**2) & + & /real(dat%nblock-1,wp)) + !> drift in Eh/ps: endpoint slope over all completed blocks + eblk_drift = (dat%blockrege(dat%nblock)-dat%blockrege(1)) & + & /real(dat%nblock-1,wp) & + & /(dat%blockl*dat%tstep*1.0e-3_wp) + end if + !>--- averages printout if (pr) then write (stdout,*) - write (stdout,*) 'average properties ' - write (stdout,*) '----------------------' - write (stdout,*) ' / Eh :',Epav/float(t) - write (stdout,*) ' / Eh :',Ekav/float(t) - write (stdout,*) ' / Eh :', (Ekav+Epav)/float(t) - write (stdout,*) ' / K :',Tav/float(t) + write (stdout,'(1x,a)') 'average properties' + write (stdout,'(1x,a)') repeat('-',42) + write (stdout,'(1x,a,t22,f16.8,a)') '',Epav/float(t),' Eh' + write (stdout,'(1x,a,t22,f16.8,a)') '',Ekav/float(t),' Eh' + write (stdout,'(1x,a,t22,f16.8,a)') '',(Ekav+Epav)/float(t),' Eh' + write (stdout,'(1x,a,t28,f10.2,a)') '',Tav/float(t),' K' + write (stdout,'(1x,a,t28,f10.2,a)') 'Tvar',tav2/float(t)-(tav/float(t))**2,' K²' + write (stdout,'(1x,a,t29,f10.2,a)') 'σ(T)',sqrt(max(tav2/float(t)-(tav/float(t))**2,0.0_wp)),' K' + if (dat%nblock >= 2) then + write (stdout,'(1x,a)') repeat('-',42) + write (stdout,'(1x,a,t28,i10,a)') 'blocks',dat%nblock,' ' + write (stdout,'(1x,a,t23,f16.8,a)') 'block σ(Epot)',eblk_std,' Eh' + write (stdout,'(1x,a,t28,es10.2,a)') 'drift',eblk_drift,' Eh/ps' + end if + write (stdout,'(1x,a)') repeat('-',42) end if !>--- write restart file @@ -510,6 +559,8 @@ subroutine dynamics(mol,dat,calc,pr,term) !>--- store trajectory-average temperature for callers dat%Tavg = tav/float(t) + dat%Tvar = tav2/float(t)-(tav/float(t))**2 + dat%Ndf = nfreedom !>--- deallocate data deallocate (dat%blockrege,dat%blockt,dat%blocke) @@ -578,6 +629,65 @@ subroutine ekinet(n,velo,mass,E) return end subroutine ekinet +!========================================================================================! +! subroutine random_gauss +! sample one standard normal N(0,1) via Box-Muller transform + subroutine random_gauss(z) + !************************************* + !* Sample one standard normal N(0,1) * + !* via Box-Muller transform. * + !************************************* + implicit none + real(wp),intent(out) :: z + real(wp) :: u1,u2 + real(wp),parameter :: twopi = 6.28318530717958647693_wp + do + call random_number(u1) + if (u1 > 0.0_wp) exit + end do + call random_number(u2) + z = sqrt(-2.0_wp*log(u1))*cos(twopi*u2) + return + end subroutine random_gauss + +!========================================================================================! +! subroutine random_gamma +! sample x ~ Gamma(a,1) using the Marsaglia-Tsang (2000) algorithm + subroutine random_gamma(a,x) + !***************************************************** + !* Sample x ~ Gamma(a,1) using Marsaglia-Tsang 2000. * + !* For a < 1: apply the relation Gamma(a) = Gamma(a+1)*U^(1/a). * + !***************************************************** + implicit none + real(wp),intent(in) :: a + real(wp),intent(out) :: x + real(wp) :: d,c,z,v,u,aa + logical :: small + small = (a < 1.0_wp) + aa = merge(a+1.0_wp,a,small) + d = aa-1.0_wp/3.0_wp + c = 1.0_wp/sqrt(9.0_wp*d) + do + do + call random_gauss(z) + v = (1.0_wp+c*z)**3 + if (v > 0.0_wp) exit + end do + call random_number(u) + if (u < 1.0_wp-0.0331_wp*z**2*z**2) then + x = d*v; exit + end if + if (log(u) < 0.5_wp*z**2+d*(1.0_wp-v+log(v))) then + x = d*v; exit + end if + end do + if (small) then + call random_number(u) + x = x*u**(1.0_wp/a) + end if + return + end subroutine random_gamma + !========================================================================================! ! subroutine u_block ! update block data and printout @@ -803,13 +913,20 @@ end subroutine mdinitu ! helper routine to re-scale velocities, ! i.e., thermostating - subroutine thermostating(mol,dat,t,scal) + subroutine thermostating(mol,dat,t,ekin,nfreedom,scal) + !************************************************************** + !* Apply velocity-scaling thermostat and return scale factor. * + !* Supports: berendsen, bussi/csvr * + !************************************************************** implicit none type(coord) :: mol type(mddata) :: dat real(wp),intent(in) :: t + real(wp),intent(in) :: ekin + integer,intent(in) :: nfreedom real(wp),intent(out) :: scal - integer :: i,j,k,l,ich,och,io + real(wp) :: c1,K_ref,K_new,gam,xi,chi2 + integer :: Nf scal = 1.0_wp @@ -817,16 +934,68 @@ subroutine thermostating(mol,dat,t,scal) select case (trim(dat%thermotype)) case ('berendsen') - scal = dsqrt(1.0d0+(dat%tstep/dat%thermo_damp) & + scal = sqrt(1.0d0+(dat%tstep/dat%thermo_damp) & & *(dat%tsoll/t-1.0_wp)) + case ('bussi','csvr') + !> Bussi-Donadio-Parrinello CSVR (J. Chem. Phys. 126, 014101, 2007) + !> Stochastic velocity rescaling for correct NVT ensemble sampling. + !> K_new = K_ref + (K-K_ref)*c1 + sqrt(K*K_ref*2/Nf)*sqrt(c1*(1-c1))*xi + !> + K_ref/Nf*(1-c1)*chi2 + Nf = nfreedom + c1 = exp(-dat%tstep/dat%thermo_damp) + K_ref = 0.5_wp*real(Nf,wp)*kB*dat%tsoll + call random_gauss(xi) + call random_gamma(0.5_wp*real(Nf-1,wp),gam) + chi2 = 2.0_wp*gam + K_new = K_ref+(ekin-K_ref)*c1 & + & +2.0_wp*sqrt(ekin*K_ref/real(Nf,wp))*sqrt(c1*(1.0_wp-c1))*xi & + & +K_ref/real(Nf,wp)*(1.0_wp-c1)*chi2 + K_new = max(K_new,0.0_wp) + scal = sqrt(K_new/max(ekin,1.0e-30_wp)) case default - !>-- (no scaling, other thermostats require special implementation) + !>-- (no scaling; langevin uses a separate integration path) scal = 1.0_wp end select return end subroutine thermostating +!========================================================================================! +! subroutine langevin_step +! BBK Langevin velocity update for leapfrog MD + subroutine langevin_step(nat,dat,mass,velo,acc,tstep_au,vel) + !************************************************************* + !* Langevin BBK velocity update for leapfrog MD. * + !* velo = v(t-dt/2), acc = a(t), vel = v(t+dt/2) on output. * + !* Uses dat%thermo_damp as relaxation time tau (in fs). * + !************************************************************* + implicit none + integer,intent(in) :: nat + type(mddata),intent(in) :: dat + real(wp),intent(in) :: mass(nat) + real(wp),intent(in) :: velo(3,nat),acc(3,nat) + real(wp),intent(in) :: tstep_au + real(wp),intent(out) :: vel(3,nat) + real(wp) :: tau_au,gamma_dt,c1,c2,sigma + real(wp) :: xi + integer :: i,k + + tau_au = dat%thermo_damp*fstoau + gamma_dt = tstep_au/tau_au + c1 = (1.0_wp-0.5_wp*gamma_dt)/(1.0_wp+0.5_wp*gamma_dt) + c2 = tstep_au/(1.0_wp+0.5_wp*gamma_dt) + + do i = 1,nat + sigma = sqrt(2.0_wp*kB*dat%tsoll*tstep_au/(mass(i)*tau_au)) & + & /(1.0_wp+0.5_wp*gamma_dt) + do k = 1,3 + call random_gauss(xi) + vel(k,i) = c1*velo(k,i)+c2*acc(k,i)+sigma*xi + end do + end do + return + end subroutine langevin_step + subroutine thermostatprint(dat,pr) implicit none type(mddata) :: dat @@ -836,9 +1005,9 @@ subroutine thermostatprint(dat,pr) if (.not.pr) return if (dat%thermostat) then select case (trim(dat%thermotype)) - case ('berendsen') + case ('berendsen','bussi','csvr','langevin') write (stdout,'(" thermostat",t25,":",1x,a )') trim(dat%thermotype) - case default !>-- (also berendsen thermostat) + case default write (stdout,'(" thermostat",t25,":",1x,a )') 'berendsen' end select else diff --git a/test/test_molecular_dynamics.F90 b/test/test_molecular_dynamics.F90 index a3223605..34d9b8db 100644 --- a/test/test_molecular_dynamics.F90 +++ b/test/test_molecular_dynamics.F90 @@ -30,7 +30,10 @@ subroutine collect_mol_dynamics(testsuite) new_unittest("Compiled gfnff subproject ",test_compiled_gfnff), & new_unittest("molecular dynamics (SHAKE off)",test_md_shake_off), & new_unittest("molecular dynamics (SHAKE on) ",test_md_shake_on), & - new_unittest("molecular dynamics (SHAKE H) ",test_md_shake_honly) & + new_unittest("molecular dynamics (SHAKE H) ",test_md_shake_honly), & + new_unittest("thermostat: berendsen ",test_md_thermostat_berendsen), & + new_unittest("thermostat: bussi (CSVR) ",test_md_thermostat_bussi), & + new_unittest("thermostat: langevin (BBK) ",test_md_thermostat_langevin) & #else new_unittest("Compiled gfnff subproject",test_compiled_gfnff,should_fail=.true.) & #endif @@ -74,7 +77,7 @@ subroutine test_md_shake_off(error) !> MD setup pr = .false. io = 0 - mdyn%length_ps = 200.0_wp + mdyn%length_ps = 200.0_wp call mdyn%defaults() mdyn%shake = .false. mdyn%restart = .true. !> turn on restart reading (for determinic results) @@ -118,7 +121,7 @@ subroutine test_md_shake_on(error) !> MD setup pr = .false. io = 0 - mdyn%length_ps = 50.0_wp + mdyn%length_ps = 50.0_wp mdyn%Tsoll = 450.0_wp call mdyn%defaults() mdyn%shake = .true. @@ -172,10 +175,10 @@ subroutine test_md_shake_honly(error) !> MD setup pr = .false. io = 0 - mdyn%length_ps=50.0_wp !> shorter runtime because the mol is larger + mdyn%length_ps = 10.0_wp !> shorter runtime because the mol is larger call mdyn%defaults() mdyn%shake = .true. - mdyn%shk%shake_mode=1 + mdyn%shk%shake_mode = 1 mdyn%restart = .true. !> turn on restart reading (for determinic results) mdyn%wrtrj = .false. !> turn off trajectory dump call write_fake_restart(mol,mdyn%restartfile) @@ -203,14 +206,165 @@ subroutine test_md_shake_honly(error) end do end subroutine test_md_shake_honly - subroutine write_fake_restart(mol,restartfile) +!========================================================================================! + + subroutine test_md_thermostat_berendsen(error) + type(error_type),allocatable,intent(out) :: error + type(calcdata) :: calc + type(calculation_settings) :: sett + type(coord) :: mol + type(mddata) :: mdyn + integer :: io + logical :: pr + + call sett%create('gfnff') + call calc%add(sett) + call get_testmol('methane',mol) + + pr = .false. + io = 0 + mdyn%length_ps = 50.0_wp + mdyn%tstep = 1.0_wp + call mdyn%defaults() + mdyn%shake = .false. + mdyn%samerand = .true. !> deterministic RNG seed + mdyn%thermotype = 'berendsen' + mdyn%thermo_damp = 500.0_wp + mdyn%restart = .true. + mdyn%wrtrj = .false. + call write_fake_restart(mol,mdyn%restartfile) + + call dynamics(mol,mdyn,calc,pr,io) + + call remove(mdyn%restartfile) + call remove('crest_0.mdrestart') + + !> Simulation must complete without error + call check(error,io,0) + if (allocated(error)) return + !> Average temperature within ±50 K of target. + !> Berendsen's distinguishing property is deterministic (non-stochastic) convergence; + !> with τ=500 fs >> dt, scal≈1 each step so variance stays near canonical — no variance check. + call check(error,mdyn%Tavg,mdyn%tsoll,thr=50.0_wp) + if (allocated(error)) return + end subroutine test_md_thermostat_berendsen + +!========================================================================================! + + subroutine test_md_thermostat_bussi(error) + type(error_type),allocatable,intent(out) :: error + type(calcdata) :: calc + type(calculation_settings) :: sett + type(coord) :: mol + type(mddata) :: mdyn + integer :: io + logical :: pr + real(wp) :: tvar + + call sett%create('gfnff') + call calc%add(sett) + call get_testmol('methane',mol) + + pr = .false. + io = 0 + mdyn%length_ps = 50.0_wp + mdyn%tstep = 0.5_wp + call mdyn%defaults() + mdyn%shake = .false. + mdyn%samerand = .true. !> deterministic RNG seed + mdyn%thermotype = 'bussi' + mdyn%thermo_damp = 500.0_wp + mdyn%restart = .true. + mdyn%wrtrj = .false. + call write_fake_restart(mol,mdyn%restartfile,tstart=300.0_wp) + + call dynamics(mol,mdyn,calc,pr,io) + + call remove(mdyn%restartfile) + call remove('crest_0.mdrestart') + + !> Simulation must complete without error + call check(error,io,0) + if (allocated(error)) return + !> Average temperature within ±50 K of target + call check(error,mdyn%Tavg,mdyn%tsoll,thr=50.0_wp) + if (allocated(error)) return + !> Bussi samples the canonical NVT ensemble: Tvar must be close to the + !> canonical reference 2*^2/Ndf. We check Tvar > 10% of canonical — + !> 10x margin below the expected ~100%, and far above Berendsen's ~0.1%. + tvar = mdyn%Tvar + if (tvar < 0.1_wp*(2.0_wp*mdyn%Tavg**2/real(mdyn%Ndf,wp))) then + call test_failed(error,'Bussi thermostat does not show canonical T fluctuations: '// & + & 'expected Tvar ~ 2*Tavg^2/Ndf') + return + end if + end subroutine test_md_thermostat_bussi + +!========================================================================================! + + subroutine test_md_thermostat_langevin(error) + type(error_type),allocatable,intent(out) :: error + type(calcdata) :: calc + type(calculation_settings) :: sett + type(coord) :: mol + type(mddata) :: mdyn + integer :: io + logical :: pr + real(wp) :: tvar + + call sett%create('gfnff') + call calc%add(sett) + call get_testmol('caffeine',mol) + + pr = .true. + io = 0 + mdyn%length_ps = 50.0_wp + call mdyn%defaults() + mdyn%shake = .false. + mdyn%samerand = .true. !> deterministic RNG seed + mdyn%thermotype = 'langevin' + mdyn%thermo_damp = 298.15_wp + mdyn%restart = .true. + mdyn%wrtrj = .false. + call write_fake_restart(mol,mdyn%restartfile) + + call dynamics(mol,mdyn,calc,pr,io) + + call remove(mdyn%restartfile) + call remove('crest_0.mdrestart') + + !> Simulation must complete without error + call check(error,io,0) + if (allocated(error)) return + !> Average temperature within ±50 K of target (equipartition theorem) + call check(error,mdyn%Tavg,mdyn%tsoll,thr=50.0_wp) + if (allocated(error)) return + !> Langevin (BBK) samples the canonical NVT ensemble via per-atom stochastic + !> friction: Tvar must be close to the canonical reference 2*^2/Ndf. + !> We check Tvar > 10% of canonical — same criterion as for Bussi. + tvar = mdyn%Tvar + if (tvar < 0.1_wp*(2.0_wp*mdyn%Tavg**2/real(mdyn%Ndf,wp))) then + call test_failed(error,'Langevin thermostat does not show canonical T fluctuations: '// & + & 'expected Tvar ~ 2*Tavg^2/Ndf') + return + end if + end subroutine test_md_thermostat_langevin + +!========================================================================================! + + subroutine write_fake_restart(mol,restartfile,tstart) implicit none type(coord),intent(in) :: mol character(len=:),allocatable,intent(out) :: restartfile + real(wp),intent(in),optional :: tstart integer :: ich,ii restartfile = 'crest_test.mdrestart' open (newunit=ich,file=restartfile) - write (ich,*) 500.0_wp + if (present(tstart)) then + write (ich,*) tstart + else + write (ich,*) 500.0_wp + end if do ii = 1,mol%nat write (ich,'(6D22.14)') mol%xyz(1:3,ii),mol%xyz(1:3,ii)*0.0001_wp end do From 73b2c5dbbe3a377ec924da6222cf78197ab35088 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 20 Mar 2026 23:24:01 +0100 Subject: [PATCH 258/374] Fix Bussi-parinello thermostat --- src/dynamics/dynamics_module.f90 | 25 ++++++++++++++++--------- test/test_molecular_dynamics.F90 | 11 +++++------ 2 files changed, 21 insertions(+), 15 deletions(-) diff --git a/src/dynamics/dynamics_module.f90 b/src/dynamics/dynamics_module.f90 index 826d57f2..bc59f3e6 100644 --- a/src/dynamics/dynamics_module.f90 +++ b/src/dynamics/dynamics_module.f90 @@ -939,18 +939,25 @@ subroutine thermostating(mol,dat,t,ekin,nfreedom,scal) case ('bussi','csvr') !> Bussi-Donadio-Parrinello CSVR (J. Chem. Phys. 126, 014101, 2007) !> Stochastic velocity rescaling for correct NVT ensemble sampling. - !> K_new = K_ref + (K-K_ref)*c1 + sqrt(K*K_ref*2/Nf)*sqrt(c1*(1-c1))*xi - !> + K_ref/Nf*(1-c1)*chi2 + !> + !> Exact discrete update (paper Eq. A7): + !> K_new = K*c1 + K_ref*(1-c1)/Nf * sum_i(z_i^2) + 2*sqrt(K*K_ref*c1*(1-c1)/Nf)*z1 + !> E[K_new] = K*c1 + K_ref*(1-c1) → converges to K_ref = Nf/2*kB*T + !> + !> Setting A = sqrt(K_ref*(1-c1)/Nf), B = sqrt(K*c1): + !> sum term: A^2*(z1^2 + chi2(Nf-1)) with chi2(Nf-1) = 2*Gamma((Nf-1)/2) + !> cross term: 2*A*B*z1 + !> combined: (A*z1 + B)^2 + A^2*chi2(Nf-1) <- always non-negative Nf = nfreedom c1 = exp(-dat%tstep/dat%thermo_damp) K_ref = 0.5_wp*real(Nf,wp)*kB*dat%tsoll - call random_gauss(xi) - call random_gamma(0.5_wp*real(Nf-1,wp),gam) - chi2 = 2.0_wp*gam - K_new = K_ref+(ekin-K_ref)*c1 & - & +2.0_wp*sqrt(ekin*K_ref/real(Nf,wp))*sqrt(c1*(1.0_wp-c1))*xi & - & +K_ref/real(Nf,wp)*(1.0_wp-c1)*chi2 - K_new = max(K_new,0.0_wp) + xi = sqrt(K_ref*(1.0_wp-c1)/real(Nf,wp)) ! A = sqrt(K_ref*(1-c1)/Nf) + call random_gauss(chi2) ! z1 ~ N(0,1) + K_new = (xi*chi2+sqrt(ekin*c1))**2 ! (A*z1 + B)^2, B = sqrt(K*c1) + if (Nf > 1) then + call random_gamma(0.5_wp*real(Nf-1,wp),gam) ! gam ~ Gamma((Nf-1)/2) + K_new = K_new+xi**2*2.0_wp*gam ! + A^2 * chi2(Nf-1) + end if scal = sqrt(K_new/max(ekin,1.0e-30_wp)) case default !>-- (no scaling; langevin uses a separate integration path) diff --git a/test/test_molecular_dynamics.F90 b/test/test_molecular_dynamics.F90 index 34d9b8db..47b27ed1 100644 --- a/test/test_molecular_dynamics.F90 +++ b/test/test_molecular_dynamics.F90 @@ -263,12 +263,11 @@ subroutine test_md_thermostat_bussi(error) call sett%create('gfnff') call calc%add(sett) - call get_testmol('methane',mol) + call get_testmol('caffeine',mol) pr = .false. io = 0 - mdyn%length_ps = 50.0_wp - mdyn%tstep = 0.5_wp + mdyn%length_ps = 25.0_wp call mdyn%defaults() mdyn%shake = .false. mdyn%samerand = .true. !> deterministic RNG seed @@ -316,9 +315,9 @@ subroutine test_md_thermostat_langevin(error) call calc%add(sett) call get_testmol('caffeine',mol) - pr = .true. + pr = .false. io = 0 - mdyn%length_ps = 50.0_wp + mdyn%length_ps = 25.0_wp call mdyn%defaults() mdyn%shake = .false. mdyn%samerand = .true. !> deterministic RNG seed @@ -366,7 +365,7 @@ subroutine write_fake_restart(mol,restartfile,tstart) write (ich,*) 500.0_wp end if do ii = 1,mol%nat - write (ich,'(6D22.14)') mol%xyz(1:3,ii),mol%xyz(1:3,ii)*0.0001_wp + write (ich,'(6D22.14)') mol%xyz(1:3,ii),mol%xyz(1:3,ii)*0.00005_wp end do close (ich) end subroutine write_fake_restart From e8162ba9e14e745d861202b5a3bbc631f954b49a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 21 Mar 2026 00:58:12 +0100 Subject: [PATCH 259/374] Clean up thermostat implementations and printouts --- src/dynamics/dynamics_module.f90 | 130 +++++++++++++++++++++---------- src/parsing/parse_calcdata.f90 | 14 ++++ 2 files changed, 105 insertions(+), 39 deletions(-) diff --git a/src/dynamics/dynamics_module.f90 b/src/dynamics/dynamics_module.f90 index bc59f3e6..e3856ebf 100644 --- a/src/dynamics/dynamics_module.f90 +++ b/src/dynamics/dynamics_module.f90 @@ -1,7 +1,7 @@ !================================================================================! ! This file is part of crest. ! -! Copyright (C) 2021 - 2023 Philipp Pracht +! Copyright (C) 2021 - 2026 Philipp Pracht ! ! crest is free software: you can redistribute it and/or modify it under ! the terms of the GNU Lesser General Public License as published by @@ -23,6 +23,7 @@ module dynamics_module use crest_parameters use crest_calculator + use iomod use strucrd use atmasses use shake_module @@ -80,9 +81,10 @@ module dynamics_module real(wp) :: tsoll = 0.0_wp !298.15_wp !> wanted temperature real(wp) :: Tavg = 0.0_wp !> trajectory-average temperature (set after dynamics()) real(wp) :: Tvar = 0.0_wp !> trajectory temperature variance (set after dynamics()) - integer :: Ndf = 0 !> degrees of freedom used in the run (set after dynamics()) + integer :: Ndf = 0 !> degrees of freedom used in the run (set after dynamics()) logical :: thermostat = .true. !> apply thermostat? character(len=64) :: thermotype = 'berendsen' + integer :: thermotype_i = 2 !> integer mapping thermostats, 2=berendsen real(wp) :: thermo_damp = 500.0_wp !> thermostat damping parameter logical :: samerand = .false. @@ -112,6 +114,12 @@ module dynamics_module public :: dynamics public :: mdautoset + character(len=30),parameter,private :: thermostattype(4) = [ & + & 'None ', & + & 'Berendsen ', & + & 'Langevin ', & + & 'Bussi-Donadio-Parrinello '] + !========================================================================================! !========================================================================================! contains !> MODULE PROCEDURES START HERE @@ -158,6 +166,7 @@ subroutine dynamics(mol,dat,calc,pr,term) character(len=256) :: commentline integer :: i,j,k,l,ich,och,io integer :: dcount,printcount + integer,allocatable :: iseed(:) logical :: ex,fail,bdump,shakefallback call initsignal() @@ -165,6 +174,15 @@ subroutine dynamics(mol,dat,calc,pr,term) !>--- pre-settings and calculations !$omp critical call dat%defaults() !> check for unset parameters +!>--- seed RNG before any stochastic use (velocity init or thermostat steps) + if (dat%samerand) then + call random_seed(size=i) + allocate (iseed(i),source=1) + call random_seed(put=iseed) + deallocate (iseed) + else + call random_seed() + end if term = 0 tstep_au = dat%tstep*fstoau nfreedom = 3*mol%nat @@ -213,9 +231,15 @@ subroutine dynamics(mol,dat,calc,pr,term) if (pr) then write (stdout,*) write (stdout,'(1x,15("─"),1x,a,1x,14("─"))') 'Molecular Dynamics Settings' - write (stdout,'(" MD time /ps",t25, ":",f10.2)') dat%length_ps - write (stdout,'(" dt /fs",t25, ":",f10.2)') dat%tstep - write (stdout,'(" temperature /K",t25, ":",f10.2)') dat%tsoll + write (stdout,'(" Simulation type",t25, ":",1x)',advance='no') + if (dat%thermostat) then + write (stdout,'(a9)') 'NVT' + else + write (stdout,'(a9)') 'NVE' + end if + write (stdout,'(" MD time (length)",t25, ":",f10.2,a)') dat%length_ps,' ps' + write (stdout,'(" dt (timetep)",t25, ":",f10.2,a)') dat%tstep,' fs' + write (stdout,'(" temperature",t25, ":",f10.2,a)') dat%tsoll,' K' write (stdout,'(" max steps",t25, ":",i10 )') dat%length_steps write (stdout,'(" block length (av.)",t25,":",i10 )') dat%blockl write (stdout,'(" dumpstep(trj) /fs",t25, ":",f10.2,1x,"(",i0,")")') dat%dumpstep,dat%sdump @@ -224,7 +248,7 @@ subroutine dynamics(mol,dat,calc,pr,term) write (stdout,'(" # frozen atoms",t25, ":",i10 )') calc%nfreeze end if call thermostatprint(dat,pr) - write (stdout,'(" SHAKE constraint",t25, ":",9x,l)') dat%shake + write (stdout,'(" SHAKE constraint",t25, ":",1x,a9)') to_str(dat%shake) if (dat%shake) then if (shakefallback) then write (stdout,'(" SHAKE using CN fallback",t25,":",9x,l)') shakefallback @@ -239,6 +263,7 @@ subroutine dynamics(mol,dat,calc,pr,term) if (allocated(dat%active_potentials)) then write (stdout,'(" active potentials",t25,":",i10)') size(dat%active_potentials,1) end if + end if !>--- set atom masses @@ -309,6 +334,8 @@ subroutine dynamics(mol,dat,calc,pr,term) !>--- begin printout if (pr) then + write (stdout,'(1x,58("─"))') + write (stdout,'(/,"> ",a)') 'Starting simulation' if (.not.dat%thermostat) then write (stdout,'(/,11x,"time (ps)",7x,"",8x,"Ekin",5x,"",7x,"T",12x, & @@ -422,7 +449,7 @@ subroutine dynamics(mol,dat,calc,pr,term) temp = 2.0_wp*ekin/float(nfreedom)/kB !>--- THERMOSTATING and velocity update - if (trim(dat%thermotype) == 'langevin') then + if (dat%thermotype_i == 3)then !'langevin') then if (dat%thermostat) then call langevin_step(mol%nat,dat,mass,velo,acc,tstep_au,vel) else @@ -436,8 +463,9 @@ subroutine dynamics(mol,dat,calc,pr,term) !>--- the scaling scal=sqrt(K_new/ekin) gives Ekin(vel_scaled)=K_new exactly. !>--- Using the half-step estimate veln would give Ekin(vel_scaled)=K_new*(Efull/Ehalf) !>--- and systematically overshoot the target temperature by ~Efull/Ehalf. - if (dat%thermostat .and. & - & (trim(dat%thermotype) == 'bussi' .or. trim(dat%thermotype) == 'csvr')) then + if (dat%thermostat.and. & + & dat%thermotype_i == 4 ) then + !& (trim(dat%thermotype) == 'bussi'.or.trim(dat%thermotype) == 'csvr')) then call ekinet(mol%nat,vel,mass,ekin) temp = 2.0_wp*ekin/float(nfreedom)/kB end if @@ -506,8 +534,8 @@ subroutine dynamics(mol,dat,calc,pr,term) !$omp end critical !>--- block energy statistics (blockrege still allocated here) - eblk_mean = 0.0_wp - eblk_std = 0.0_wp + eblk_mean = 0.0_wp + eblk_std = 0.0_wp eblk_drift = 0.0_wp if (dat%nblock >= 1) then eblk_mean = sum(dat%blockrege(1:dat%nblock))/real(dat%nblock,wp) @@ -528,13 +556,13 @@ subroutine dynamics(mol,dat,calc,pr,term) write (stdout,'(1x,a)') repeat('-',42) write (stdout,'(1x,a,t22,f16.8,a)') '',Epav/float(t),' Eh' write (stdout,'(1x,a,t22,f16.8,a)') '',Ekav/float(t),' Eh' - write (stdout,'(1x,a,t22,f16.8,a)') '',(Ekav+Epav)/float(t),' Eh' + write (stdout,'(1x,a,t22,f16.8,a)') '', (Ekav+Epav)/float(t),' Eh' write (stdout,'(1x,a,t28,f10.2,a)') '',Tav/float(t),' K' write (stdout,'(1x,a,t28,f10.2,a)') 'Tvar',tav2/float(t)-(tav/float(t))**2,' K²' write (stdout,'(1x,a,t29,f10.2,a)') 'σ(T)',sqrt(max(tav2/float(t)-(tav/float(t))**2,0.0_wp)),' K' if (dat%nblock >= 2) then write (stdout,'(1x,a)') repeat('-',42) - write (stdout,'(1x,a,t28,i10,a)') 'blocks',dat%nblock,' ' + write (stdout,'(1x,a,t28,i10,a)') 'blocks',dat%nblock,' ' write (stdout,'(1x,a,t23,f16.8,a)') 'block σ(Epot)',eblk_std,' Eh' write (stdout,'(1x,a,t28,es10.2,a)') 'drift',eblk_drift,' Eh/ps' end if @@ -560,7 +588,7 @@ subroutine dynamics(mol,dat,calc,pr,term) !>--- store trajectory-average temperature for callers dat%Tavg = tav/float(t) dat%Tvar = tav2/float(t)-(tav/float(t))**2 - dat%Ndf = nfreedom + dat%Ndf = nfreedom !>--- deallocate data deallocate (dat%blockrege,dat%blockt,dat%blocke) @@ -849,7 +877,7 @@ subroutine rdmdrestart(mol,dat,velo,fail,rtshift,pr) fail = .true. end if if (.not.fail.and.pr) then - write (stdout,'(" read RESTART file",t25,":",9x,l)').not.fail + write (stdout,'(" read RESTART file",t25,":",1x,a9)') to_str(.not.fail) write (stdout,'(" restart file",t25,":",1x,a)') dat%restartfile end if @@ -869,9 +897,7 @@ subroutine mdinitu(mol,dat,velo,mass,Ekin,pr) real(wp),intent(in) :: Ekin logical,intent(in) :: pr real :: x(3),ranf - integer :: n real(wp) :: eperat,v,f,t,edum,f2 - integer,allocatable :: iseed(:) logical :: newvelos integer :: i @@ -879,13 +905,6 @@ subroutine mdinitu(mol,dat,velo,mass,Ekin,pr) !>--- newly initialized if (newvelos) then - if (dat%samerand) then - call random_seed(size=n) - allocate (iseed(n),source=1) - call random_seed(put=iseed) - else - call random_seed() - end if eperat = Ekin/(3.0_wp*float(mol%nat)) do i = 1,mol%nat call random_number(x) @@ -932,11 +951,11 @@ subroutine thermostating(mol,dat,t,ekin,nfreedom,scal) if (.not.dat%thermostat) return - select case (trim(dat%thermotype)) - case ('berendsen') + select case (dat%thermotype_i) !(trim(dat%thermotype)) + case (2) !('berendsen') scal = sqrt(1.0d0+(dat%tstep/dat%thermo_damp) & - & *(dat%tsoll/t-1.0_wp)) - case ('bussi','csvr') + & *(dat%tsoll/t-1.0_wp)) + case (4) !('bussi','csvr') !> Bussi-Donadio-Parrinello CSVR (J. Chem. Phys. 126, 014101, 2007) !> Stochastic velocity rescaling for correct NVT ensemble sampling. !> @@ -948,17 +967,17 @@ subroutine thermostating(mol,dat,t,ekin,nfreedom,scal) !> sum term: A^2*(z1^2 + chi2(Nf-1)) with chi2(Nf-1) = 2*Gamma((Nf-1)/2) !> cross term: 2*A*B*z1 !> combined: (A*z1 + B)^2 + A^2*chi2(Nf-1) <- always non-negative - Nf = nfreedom - c1 = exp(-dat%tstep/dat%thermo_damp) + Nf = nfreedom + c1 = exp(-dat%tstep/dat%thermo_damp) K_ref = 0.5_wp*real(Nf,wp)*kB*dat%tsoll - xi = sqrt(K_ref*(1.0_wp-c1)/real(Nf,wp)) ! A = sqrt(K_ref*(1-c1)/Nf) + xi = sqrt(K_ref*(1.0_wp-c1)/real(Nf,wp)) ! A = sqrt(K_ref*(1-c1)/Nf) call random_gauss(chi2) ! z1 ~ N(0,1) K_new = (xi*chi2+sqrt(ekin*c1))**2 ! (A*z1 + B)^2, B = sqrt(K*c1) if (Nf > 1) then call random_gamma(0.5_wp*real(Nf-1,wp),gam) ! gam ~ Gamma((Nf-1)/2) K_new = K_new+xi**2*2.0_wp*gam ! + A^2 * chi2(Nf-1) end if - scal = sqrt(K_new/max(ekin,1.0e-30_wp)) + scal = sqrt(K_new/max(ekin,1.0e-30_wp)) case default !>-- (no scaling; langevin uses a separate integration path) scal = 1.0_wp @@ -987,10 +1006,10 @@ subroutine langevin_step(nat,dat,mass,velo,acc,tstep_au,vel) real(wp) :: xi integer :: i,k - tau_au = dat%thermo_damp*fstoau + tau_au = dat%thermo_damp*fstoau gamma_dt = tstep_au/tau_au - c1 = (1.0_wp-0.5_wp*gamma_dt)/(1.0_wp+0.5_wp*gamma_dt) - c2 = tstep_au/(1.0_wp+0.5_wp*gamma_dt) + c1 = (1.0_wp-0.5_wp*gamma_dt)/(1.0_wp+0.5_wp*gamma_dt) + c2 = tstep_au/(1.0_wp+0.5_wp*gamma_dt) do i = 1,nat sigma = sqrt(2.0_wp*kB*dat%tsoll*tstep_au/(mass(i)*tau_au)) & @@ -1010,20 +1029,50 @@ subroutine thermostatprint(dat,pr) integer :: i,j,k,l,ich,och,io if (.not.pr) return + write (stdout,'(" thermostat",t25,":")',advance='no') if (dat%thermostat) then select case (trim(dat%thermotype)) - case ('berendsen','bussi','csvr','langevin') - write (stdout,'(" thermostat",t25,":",1x,a )') trim(dat%thermotype) + case ('berendsen') + write (stdout,'(1x,a )') trim(thermostattype(2)) + case ('bussi','csvr') + write (stdout,'(1x,a )') trim(thermostattype(4)) + case ('langevin','bbk') + write (stdout,'(1x,a )') trim(thermostattype(3)) case default - write (stdout,'(" thermostat",t25,":",1x,a )') 'berendsen' + write (stdout,'(1x,a )') trim(thermostattype(1)) end select else - write (stdout,'(" thermostat",t25,":",1x,a )') 'OFF' + write (stdout,'(1x,a )') trim(thermostattype(1)) end if return end subroutine thermostatprint + subroutine thermostat2int(dat) + implicit none + type(mddata) :: dat + integer :: i,j,k,l,ich,och,io + + if (dat%thermostat) then + select case (trim(dat%thermotype)) + case ('berendsen') + dat%thermotype_i = 2 + case ('bussi','csvr') + dat%thermotype_i = 4 + case ('langevin','bbk') + dat%thermotype_i = 3 + case default + dat%thermotype_i = 1 + dat%thermostat = .false. + end select + else + dat%thermotype_i = 1 + dat%thermostat = .false. + end if + + return + end subroutine thermostat2int + !========================================================================================! ! subroutine zeroz ! remove z-directional acceleration of selected atoms @@ -1399,6 +1448,9 @@ subroutine md_defaults_fallback(self) end if self%maxblock = nint(self%length_steps/float(self%blockl)) + + call thermostat2int(self) + end subroutine md_defaults_fallback !========================================================================================! !========================================================================================! diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 7f7f0eb2..23a24c08 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -1233,6 +1233,20 @@ subroutine parse_md_auto(env,mddat,kv,rd) mddat%tsoll = kv%value_f mddat%thermostat = .true. + case ('thermostat') + select case(kv%value_c) + case ('off','nve') + mddat%thermotype = 'none' + case ('berendsen','langevin','bbk') + mddat%thermotype = trim(kv%value_c) + case ('bussi','bussi-donaido-parinello','bussi-parinello','csvr') + mddat%thermotype = 'bussi' + case default + write (stdout,fmtura) kv%value_c + call creststop(status_config) + end select + mddat%thermostat=.true. + case ('shake') select case (kv%id) case (valuetypes%int) From e5547ac2e66add7074c3862fd5d612bde576781a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 23 Mar 2026 21:41:36 +0100 Subject: [PATCH 260/374] Start refactor of molecule type and readers --- src/CMakeLists.txt | 3 +- src/meson.build | 3 +- src/molecule/CMakeLists.txt | 33 + src/molecule/io.f90 | 1458 +++++++++++++++++ src/molecule/meson.build | 23 + src/molecule/parameters.f90 | 63 + src/{ => molecule}/sdfio.f90 | 0 src/{ => molecule}/strucreader.f90 | 0 src/molecule/type.f90 | 467 ++++++ src/molecule/type_ensemble.f90 | 2458 ++++++++++++++++++++++++++++ 10 files changed, 4504 insertions(+), 4 deletions(-) create mode 100644 src/molecule/CMakeLists.txt create mode 100644 src/molecule/io.f90 create mode 100644 src/molecule/meson.build create mode 100644 src/molecule/parameters.f90 rename src/{ => molecule}/sdfio.f90 (100%) rename src/{ => molecule}/strucreader.f90 (100%) create mode 100644 src/molecule/type.f90 create mode 100644 src/molecule/type_ensemble.f90 diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index a8fd548f..72c5c643 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -15,6 +15,7 @@ # along with crest. If not, see . +add_subdirectory("molecule") add_subdirectory("parsing") add_subdirectory("optimize") add_subdirectory("calculator") @@ -65,10 +66,8 @@ list(APPEND srcs "${dir}/prmat.f90" "${dir}/restartlog.f90" "${dir}/scratch.f90" - "${dir}/sdfio.f90" "${dir}/select.f90" "${dir}/sigterm.F90" - "${dir}/strucreader.f90" "${dir}/symmetry_i.f90" "${dir}/timer.f90" "${dir}/trackorigin.f90" diff --git a/src/meson.build b/src/meson.build index c6a19520..ca83d424 100644 --- a/src/meson.build +++ b/src/meson.build @@ -14,6 +14,7 @@ # You should have received a copy of the GNU Lesser General Public License # along with crest. If not, see . +subdir('molecule') subdir('qcg') subdir('dynamics') subdir('calculator') @@ -62,10 +63,8 @@ srcs += files( 'prmat.f90', 'restartlog.f90', 'scratch.f90', - 'sdfio.f90', 'select.f90', 'sigterm.F90', - 'strucreader.f90', 'symmetry_i.f90', 'timer.f90', 'trackorigin.f90', diff --git a/src/molecule/CMakeLists.txt b/src/molecule/CMakeLists.txt new file mode 100644 index 00000000..a8bfcb63 --- /dev/null +++ b/src/molecule/CMakeLists.txt @@ -0,0 +1,33 @@ +# This file is part of crest. +# SPDX-Identifier: LGPL-3.0-or-later +# +# crest is free software: you can redistribute it and/or modify it under +# the terms of the GNU Lesser General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# crest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public License +# along with crest. If not, see . + +set(dir "${CMAKE_CURRENT_SOURCE_DIR}") + +list(APPEND srcs + "${dir}/parameters" + "${dir}/io.f90" + "${dir}/type.f90" + "${dir}/strucreader.f90" + "${dir}/sdfio.f90" +) + +set(srcs ${srcs} PARENT_SCOPE) + + + + + + diff --git a/src/molecule/io.f90 b/src/molecule/io.f90 new file mode 100644 index 00000000..8a2f692b --- /dev/null +++ b/src/molecule/io.f90 @@ -0,0 +1,1458 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2026 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module molecule_io + use iso_c_binding + use molecule_parameters +!> simple geomerty and vector operations + use geo +!> element symbols + use crest_cn_module,only:calculate_cn + implicit none + +! ────────────────────────────────────────────────────────────────────────────── +!>--- private module variables and parameters + private + +!>--- private utility subroutines + private :: upperCase,lowerCase + private :: convertlable,fextension,sgrep + +! ────────────────────────────────────────────────────────────────────────────── +!>--- public subroutines + public :: i2e !> function to convert atomic number to element symbol + public :: asym !> " + interface asym !> " + module procedure i2e !> " + end interface asym + public :: e2i !> function to convert element symbol into atomic number + public :: grepenergy + public :: checkcoordtype + + public :: rdnat !-- procedure to read number of atoms Nat + public :: rdcoord !-- read an input file, determine format automatically + public :: rdxmol !-- read a file in the Xmol (.xyz) format specifically + public :: rdxmolselec !-- read only a certain structure in Xmol file + + !>--- write a TM coord file + public :: wrc0 + interface wrc0 + module procedure wrc0_file + module procedure wrc0_channel + end interface wrc0 + public :: wrcoord + interface wrcoord + module procedure wrc0_file + module procedure wrc0_channel + end interface wrcoord + + !>--- write a XYZ coord file + public :: wrxyz + interface wrxyz + module procedure wrxyz_file + module procedure wrxyz_file_mask + module procedure wrxyz_channel_energy + module procedure wrxyz_channel + end interface wrxyz + + !>--- write a sdf molfile + public :: wrsdf + interface wrsdf + module procedure wrsdf_channel + end interface wrsdf + + public :: xyz2coord + public :: coord2xyz + + public :: coordline + public :: get_atlist + public :: sumform + + !coord class. contains a single structure in the PDB format. + !coordinates by definition are in Angstroem. + type :: pdbdata + !--- data + integer :: nat = 0 + integer :: frag = 0 + !--- arrays + integer,allocatable :: athet(:) !ATOM (1) or HETATM (2) + character(len=4),allocatable :: pdbat(:) !PDB atom specifier + character(len=3),allocatable :: pdbas(:) !PDB amino acid specifier + integer,allocatable :: pdbfrag(:) !PDB fragment specifier + character(len=1),allocatable :: pdbgrp(:) !PDB group specifier + real(wp),allocatable :: pdbocc(:) !PDB occupancy + real(wp),allocatable :: pdbtf(:) !PDB temperature factor + contains + procedure :: deallocate => deallocate_pdb !clear memory space + procedure :: allocate => allocate_pdb + end type pdbdata + public :: pdbdata + +! ══════════════════════════════════════════════════════════════════════════════ +contains !> MODULE PROCEDURES START HERE +! ══════════════════════════════════════════════════════════════════════════════ +! ROUTINES FOR READING SINGLE STRUCTURES (COORDS) +! ────────────────────────────────────────────────────────────────────────────── + + subroutine checkcoordtype(fname,typint) +!***************************************************** +!* subroutine checkcoordtype * +!* try to identify the filetype of the coord type. * +!* first based on file extension, if that fails by * +!* a keyword within the file. * +!***************************************************** + implicit none + character(len=*) :: fname + integer,intent(out) :: typint + typint = coordtype%unknown + !-- check file extension first + select case (fextension(fname)) + case ('.coord','.COORD') + typint = coordtype%turbomole + case ('.xyz','.XYZ', & + & '.trj','.TRJ','.sorted', & + & '.extxyz') + typint = coordtype%xyz + case ('.sd','.sdf','.SDF','.mol','.MOL') + typint = coordtype%sdf + if (sgrep(fname,'V2000')) then + typint = coordtype%sdfV2000 + end if + if (sgrep(fname,'V3000')) then + typint = coordtype%sdfV3000 + end if + case ('.pdb','.PDB') + typint = coordtype%PDB + case default + typint = 0 + end select + if (typint .ne. coordtype%unknown) return !-- file extension was recognized + !-- grep for keywords otherwise + if (sgrep(fname,'$coord')) then + typint = coordtype%turbomole + else !--no match found + typint = coordtype%unknown + end if + return + end subroutine checkcoordtype + +! ────────────────────────────────────────────────────────────────────────────── + + subroutine rdnat(fname,nat,ftype) +!******************************************************************* +!* subroutine rdnat * +!* read number of atoms "nat" form file * +!* * +!* On Input: fname - name of the coord file * +!* ftype - (OPTIONAL) format of the input coord file * +!* if ftype is not present, it is determined * +!* On Output: nat - number of atoms * +!******************************************************************* + implicit none + character(len=*),intent(in) :: fname + integer,intent(out) :: nat + integer,optional :: ftype + integer :: ftypedum + integer :: ich,i,j,io,k + logical :: ex + character(len=256) :: atmp + nat = 0 + inquire (file=fname,exist=ex) + if (.not.ex) then + error stop 'file does not exist.' + end if + if (present(ftype)) then + ftypedum = ftype + else + call checkcoordtype(fname,ftypedum) + end if + open (newunit=ich,file=fname) + select case (ftypedum) + + case (coordtype%xyz) !--- *.xyz files + read (ich,*,iostat=io) nat + + case (coordtype%turbomole) !--- TM coord file + do + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + if (index(atmp,"$coord") .eq. 1) exit + end do + do + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + if (atmp(1:1) == '$') exit + nat = nat+1 + end do + + case (coordtype%sdfV2000) !--- sdf V2000 (or *.mol) file + do i = 1,3 !-- first three comment lines + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + end do + read (ich,'(a)',iostat=io) atmp + if (index(atmp,'V2000') .ne. 0) then + read (atmp,'(i3)') nat !- first argument is nat + end if + + case (coordtype%sdfV3000) !--- sdf V3000 file + do + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + if ((index(atmp,'V30') .ne. 0).and. & + & (index(atmp,'COUNTS') .ne. 0)) then + j = index(atmp,'COUNTS')+6 + k = len_trim(atmp) + atmp = atmp(j:k) + atmp = adjustl(atmp) + read (atmp,*) nat + end if + end do + + case (coordtype%PDB) !--- pdb file + nat = 0 + do + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + if ((index(atmp,'ATOM') .eq. 1).or. & + & (index(atmp,'HETATM') .eq. 1)) then + nat = nat+1 + end if + end do + + case default + continue + end select + close (ich) + return + end subroutine rdnat + +! ────────────────────────────────────────────────────────────────────────────── + + subroutine rdcoord(fname,nat,at,xyz,energy) +!***************************************************************** +!* subroutine rdcoord * +!* read in a structure. The format is determined automatically * +!* * +!* On Input: fname - name of the coord file * +!* nat - number of atoms * +!* * +!* On Output: at - atom number as integer * +!* xyz - coordinates (always in Bohr) * +!* energy - (OPTIONAL) if present, try to get energy * +!* mainly from xyz files * +!***************************************************************** + implicit none + character(len=*),intent(in) :: fname + integer,intent(in) :: nat + integer,intent(inout) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) + real(wp),optional :: energy + character(len=256) :: atmp + integer :: ftype + type(pdbdata) :: pdbdummy + + !--- determine the file type + call checkcoordtype(fname,ftype) + + select case (ftype) + case (coordtype%turbomole) !-- TM coord file, always retruns coords in Bohr + call rdtmcoord(fname,nat,at,xyz) + case (coordtype%xyz) !-- XYZ file, is Angström, needs conversion + if (present(energy)) then + call rdxmol(fname,nat,at,xyz,atmp) + energy = grepenergy(atmp) + else + call rdxmol(fname,nat,at,xyz) + end if + xyz = xyz/bohr + case (coordtype%sdfV2000) !-- SDF/MOL V2000 file, also Angström + call rdsdf(fname,nat,at,xyz) + xyz = xyz/bohr + case (coordtype%sdfV3000) !-- SDF V3000 file, Angström + call rdsdfV3000(fname,nat,at,xyz) + xyz = xyz/bohr + case (coordtype%PDB) !-- PDB file, Angström + call rdPDB(fname,nat,at,xyz,pdbdummy) + xyz = xyz/bohr + call pdbdummy%deallocate() + case default + continue + end select + + return + end subroutine rdcoord + +! ────────────────────────────────────────────────────────────────────────────── + + subroutine rdtmcoord(fname,nat,at,xyz) +!************************************************************** +!* subroutine rdtmcoord * +!* read a struncture in the TM coord style. * +!* * +!* On Input: fname - name of the coord file * +!* nat - number of atoms * +!* * +!* On Output: at - atom number as integer * +!* xyz - coordinates (always in Bohr) * +!************************************************************** + implicit none + character(len=*),intent(in) :: fname + integer,intent(in) :: nat + integer,intent(inout) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) + character(len=6) :: sym + integer :: ich,io,i + real(wp) :: convert + character(len=256) :: atmp + open (newunit=ich,file=fname) + do + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + if (index(atmp,"$coord") .eq. 1) exit + end do + if (index(atmp,'ang') .ne. 0) then + !> coord files allow explicit specification in Angström + convert = aatoau + else + convert = 1.0_wp + end if + do i = 1,nat + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + if (atmp(1:1) == '$') exit + call coordline(atmp,sym,xyz(1:3,i),io) + if (io < 0) then + write (*,*) 'error while reading coord line. EOF' + exit + end if + at(i) = e2i(sym) + end do + close (ich) + xyz = xyz*convert + return + end subroutine rdtmcoord + +! ────────────────────────────────────────────────────────────────────────────── + + subroutine rdxmol(fname,nat,at,xyz,comment) +!*************************************************************** +!* subroutine rdxmol * +!* read a struncture in the *.xyz (Xmol) style. * +!* The commentary (second) line is ignored * +!* * +!* On Input: fname - name of the coord file * +!* nat - number of atoms * +!* * +!* On Output: at - atom number as integer * +!* xyz - coordinates (in Angström) * +!* comment - (OPTIONAL) commentary line of the file * +!*************************************************************** + implicit none + character(len=*),intent(in) :: fname + integer,intent(in) :: nat + integer,intent(inout) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) + character(len=*),optional :: comment + character(len=6) :: sym + integer :: ich,io,i + integer :: dum + character(len=256) :: atmp + open (newunit=ich,file=fname) + read (ich,*,iostat=io) dum + if (nat .ne. dum) then + error stop 'error while reading input coordinates' + end if + read (ich,'(a)') atmp !--commentary line + if (present(comment)) comment = trim(adjustl(atmp)) + do i = 1,nat + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + call coordline(atmp,sym,xyz(1:3,i),io) + if (io < 0) then + write (*,*) 'error while reading coord line. EOF' + exit + end if + at(i) = e2i(sym) + end do + close (ich) + return + end subroutine rdxmol + +!============================================================! +!* subroutine rdsdf +!* read a struncture in the .sdf/.mol V2000 style. +!* +!* On Input: fname - name of the coord file +!* nat - number of atoms +!* +!* On Output: at - atom number as integer +!* xyz - coordinates (in Angström) +!* comment - (OPTIONAL) commentary line of the file +!============================================================! + subroutine rdsdf(fname,nat,at,xyz,comment) + implicit none + character(len=*),intent(in) :: fname + integer,intent(in) :: nat + integer,intent(inout) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) + character(len=*),optional :: comment + character(len=6) :: sym + integer :: ich,io,i + integer :: dum + character(len=256) :: atmp + open (newunit=ich,file=fname) + read (ich,'(a)',iostat=io) atmp + read (ich,'(a)',iostat=io) atmp + read (ich,'(a)',iostat=io) atmp + if (present(comment)) comment = trim(adjustl(atmp)) + read (ich,'(i3)',iostat=io) dum + if (nat .ne. dum) then + error stop 'error while reading input coordinates' + end if + do i = 1,nat + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + call coordline(atmp,sym,xyz(1:3,i),io) + if (io < 0) then + write (*,*) 'error while reading coord line. EOF' + exit + end if + at(i) = e2i(sym) + end do + close (ich) + return + end subroutine rdsdf + +!============================================================! +! subroutine rdsdfV3000 +! read a struncture in the .sdf/.mol V3000 style. +! +! On Input: fname - name of the coord file +! nat - number of atoms +! +! On Output: at - atom number as integer +! xyz - coordinates (in Angström) +! comment - (OPTIONAL) commentary line of the file +!============================================================! + subroutine rdsdfV3000(fname,nat,at,xyz,comment) + implicit none + character(len=*),intent(in) :: fname + integer,intent(in) :: nat + integer,intent(inout) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) + character(len=*),optional :: comment + character(len=6) :: sym + integer :: ich,io,i,j,k,l + integer :: dum + character(len=256) :: atmp + character(len=32) :: btmp + open (newunit=ich,file=fname) + read (ich,'(a)',iostat=io) atmp + read (ich,'(a)',iostat=io) atmp + read (ich,'(a)',iostat=io) atmp + if (present(comment)) comment = trim(adjustl(atmp)) + do + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + if ((index(atmp,'V30') .ne. 0).and. & + & (index(atmp,'COUNTS') .ne. 0)) then + j = index(atmp,'COUNTS')+6 + k = len_trim(atmp) + atmp = atmp(j:k) + atmp = adjustl(atmp) + read (atmp,*) dum + end if + if ((index(atmp,'V30') .ne. 0).and. & + & (index(atmp,'ATOM') .ne. 0)) then + exit + end if + end do + if (nat .ne. dum) then + error stop 'error while reading input coordinates' + end if + do i = 1,nat + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + write (btmp,'(i0)') i + l = len_trim(btmp)+1 + j = index(atmp,'V30')+3 + k = len_trim(atmp) + atmp = atmp(j:k) + atmp = adjustl(atmp) + atmp = atmp(l:k) + call coordline(atmp,sym,xyz(1:3,i),io) + if (io < 0) then + write (*,*) 'error while reading coord line. EOF' + exit + end if + at(i) = e2i(sym) + end do + close (ich) + return + end subroutine rdsdfV3000 + +!============================================================! +! subroutine rdPDB +! read a struncture in the .PDB style. +! +! On Input: fname - name of the coord file +! nat - number of atoms +! +! On Output: at - atom number as integer +! xyz - coordinates (in Angström) +! pdb - pdbdata object +!============================================================! + subroutine rdPDB(fname,nat,at,xyz,pdb) + implicit none + character(len=*),intent(in) :: fname + integer,intent(in) :: nat + integer,intent(inout) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) + type(pdbdata) :: pdb + character(len=2) :: sym + integer :: ich,io,i,j,k + character(len=256) :: atmp + character(len=6) :: dum1 + character(len=1) :: dum2,dum3,pdbgp + character(len=3) :: pdbas + character(len=2) :: dum4 + character(len=4) :: pdbat + real(wp) :: r1,r2 + call pdb%allocate(nat) + open (newunit=ich,file=fname) + k = 0 + do + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + if ((index(atmp,'ATOM') .eq. 1).or. & + & (index(atmp,'HETATM') .eq. 1)) then + k = k+1 + read (atmp,'(A6,I5,1X,A4,A1,A3,1X,A1,I4,A1,3X,3F8.3,2F6.2,10X,A2,A2)') & + & dum1,i,pdbat,dum2,pdbas,pdbgp,j,dum3,xyz(1:3,k),r1,r2,sym,dum4 + at(k) = e2i(sym) + pdb%pdbat(k) = pdbat + pdb%pdbas(k) = pdbas + pdb%pdbgrp(k) = pdbgp + pdb%pdbfrag(k) = j + pdb%pdbocc(k) = r1 + pdb%pdbtf(k) = r2 + end if + end do + close (ich) + return + end subroutine rdPDB + +!============================================================! +! subroutine rdxmolselec +! Read a file with multiple structures in the *.xyz (Xmol) style. +! Picks one structure. +! The commentary (second) line is ignored +! +! On Input: fname - name of the coord file +! m - position of the desired structure +! nat - number of atoms +! +! On Output: at - atom number as integer +! xyz - coordinates (in Bohr) +!============================================================! + + subroutine rdxmolselec(fname,m,nat,at,xyz,comment) + implicit none + character(len=*),intent(in) :: fname + integer,intent(in) :: nat,m + integer,intent(inout) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) + character(len=*),optional :: comment + character(len=6) :: sym + integer :: ich,io,i,j + integer :: dum + character(len=256) :: atmp + + open (newunit=ich,file=fname) + + do j = 1,m + read (ich,*,iostat=io) dum + if (nat .ne. dum) then + error stop 'error while reading input coordinates' + end if + read (ich,'(a)') atmp !--commentary line + if (present(comment)) comment = trim(adjustl(atmp)) + do i = 1,nat + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + call coordline(atmp,sym,xyz(1:3,i),io) + if (io < 0) then + write (*,*) 'error while reading coord line. EOF' + exit + end if + at(i) = e2i(sym) + end do + end do + close (ich) + xyz = xyz/bohr + return + end subroutine rdxmolselec + +!=========================================================================================! +!=========================================================================================! +! 3. ROUTINES FOR WRITING STRUCTURES AND CONVERTING THEM +!=========================================================================================! +!=========================================================================================! + +!============================================================! +! subroutine wrc0_file +! this is the typical quick write routine for TM coord files +! version for writing directly to a new file +! +! On Input: fname - name of the coord file +! nat - number of atoms +! at - atom number as integer +! xyz - coordinates (in Bohr) +! +! On Output: file written to "fname" +!============================================================! + subroutine wrc0_file(fname,nat,at,xyz) + implicit none + character(len=*) :: fname + integer :: nat + integer :: at(nat) + real(wp) :: xyz(3,nat) + integer :: i,j,k,ich,io + logical :: ex + open (newunit=ich,file=fname,status='replace') + write (ich,'(''$coord'')') + do j = 1,nat + write (ich,'(3F24.12,5x,a2)') xyz(1:3,j),i2e(at(j),'lc') + end do + write (ich,'(''$end'')') + close (ich) + return + end subroutine wrc0_file + +!============================================================! +! subroutine wrc0_channel +! this is the typical quick write routine for TM coord files +! version for writing to a output channel +! +! On Input: fname - name of the coord file +! nat - number of atoms +! at - atom number as integer +! xyz - coordinates (in Bohr) +! +! On Output: file written to "fname" +!============================================================! + subroutine wrc0_channel(ch,nat,at,xyz) + implicit none + integer :: ch + integer :: nat + integer :: at(nat) + real(wp) :: xyz(3,nat) + integer :: i,j,k,ich,io + logical :: ex + write (ch,'(''$coord'')') + do j = 1,nat + write (ch,'(3F24.12,5x,a2)') xyz(1:3,j),i2e(at(j),'lc') + end do + write (ch,'(''$end'')') + return + end subroutine wrc0_channel + +!============================================================! +! subroutine wrxyz_file +! this is the typical quick write routine for TM coord files +! version for writing directly to a new file +! +! On Input: fname - name of the coord file +! nat - number of atoms +! at - atom number as integer +! xyz - coordinates (in Angström) +! comment - (OPTIONAL) comment line +! +! On Output: file written to "fname" +!============================================================! + subroutine wrxyz_file(fname,nat,at,xyz,comment) + implicit none + character(len=*) :: fname + integer :: nat + integer :: at(nat) + real(wp) :: xyz(3,nat) + character(len=*),optional :: comment + integer :: i,j,k,ich,io + logical :: ex + open (newunit=ich,file=fname,status='replace') + write (ich,'(2x,i0)') nat + if (present(comment)) then + write (ich,'(a)') trim(comment) + else + write (ich,*) + end if + do j = 1,nat + write (ich,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) + end do + close (ich) + return + end subroutine wrxyz_file + +!============================================================! +! subroutine wrxyz_file_mask +! this is the typical quick write routine for TM coord files +! version for writing directly to a new file +! +! On Input: fname - name of the coord file +! nat - number of atoms +! at - atom number as integer +! xyz - coordinates (in Angström) +! mask - a mask to determine to write which atoms +! comment - (OPTIONAL) comment line +! +! On Output: file written to "fname" +!============================================================! + subroutine wrxyz_file_mask(fname,nat,at,xyz,mask,comment) + implicit none + character(len=*) :: fname + integer :: nat + integer :: at(nat) + real(wp) :: xyz(3,nat) + logical :: mask(nat) + integer :: maskednat + character(len=*),optional :: comment + integer :: i,j,k,ich,io + logical :: ex + open (newunit=ich,file=fname,status='replace') + maskednat = count(mask(:)) + write (ich,'(2x,i0)') maskednat + if (present(comment)) then + write (ich,'(a)') trim(comment) + else + write (ich,*) + end if + do j = 1,nat + if (mask(j)) then + write (ich,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) + end if + end do + close (ich) + return + end subroutine wrxyz_file_mask + +!============================================================! +! subroutine wrxyz_channel +! this is the typical quick write routine for xyz files +! version for writing to a output channel +! +! On Input: fname - name of the coord file +! nat - number of atoms +! at - atom number as integer +! xyz - coordinates (in Angström) +! comment - (OPTIONAL) the comment line +! +! On Output: file written to "fname" +!============================================================! + subroutine wrxyz_channel(ch,nat,at,xyz,comment) + implicit none + integer :: ch + integer :: nat + integer :: at(nat) + real(wp) :: xyz(3,nat) + character(len=*),optional :: comment + integer :: i,j,k,ich,io + logical :: ex + write (ch,'(2x,i0)') nat + if (present(comment)) then + write (ch,'(a)') trim(comment) + else + write (ch,*) + end if + do j = 1,nat + write (ch,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) + end do + return + end subroutine wrxyz_channel + +!============================================================! +! subroutine wrxyz_channel +! this is the typical quick write routine for xyz files +! version for writing to a output channel +! +! On Input: fname - name of the coord file +! nat - number of atoms +! at - atom number as integer +! xyz - coordinates (in Angström) +! er - energy +! +! On Output: file written to "fname" +!============================================================! + subroutine wrxyz_channel_energy(ch,nat,at,xyz,er) + implicit none + integer :: ch + integer :: nat + integer :: at(nat) + real(wp) :: xyz(3,nat) + real(wp) :: er + integer :: i,j,k,ich,io + logical :: ex + write (ch,'(2x,i0)') nat + write (ch,'(2x,a,f18.8)') "energy=",er + do j = 1,nat + write (ch,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) + end do + return + end subroutine wrxyz_channel_energy + +!============================================================! +! subroutine wrsdf_channel +! this is the quick write routine for sdf files +! version for writing to a output channel +! +! On Input: fname - name of the coord file +! nat - number of atoms +! at - atom number as integer +! xyz - coordinates (in Angström) +! er - energy +! wbo - bond order matrix +! +! On Output: written to channel "ch" +!============================================================! + subroutine wrsdf_channel(ch,nat,at,xyz,er,chrg,wbo,comment,icharges) + implicit none + integer,intent(in) :: ch + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(in) :: xyz(3,nat) + real(wp),intent(in) :: er + integer,intent(in) :: chrg + real(wp),intent(in) :: wbo(nat,nat) + character(len=*),intent(in) :: comment + real(wp),intent(in),optional :: icharges(nat) + character(len=8) :: date + character(len=10) :: time + integer :: list12(12),nbd + integer,parameter :: list4(4) = 0 + integer,parameter :: list8(8) = 0 + character(len=*),parameter :: countsfmt = '(3i3, 8i3, 1x, a5)' + character(len=*),parameter :: atmfmt = '(3f10.4, 1x, a2, 12i3)' + character(len=*),parameter :: bndfmt = '(7i3)' + integer :: i,j,k,ich,io + logical :: ex + + !>--- generate data + call date_and_time(date,time) + nbd = countbonds(nat,wbo) + list12 = 0 + !>--- comment lines + call date_and_time(date,time) + write (ch,'(a)') trim(comment) + write (ch,'(1x,a, 3a2, a4, "3D",1x,a,f18.8,5x)') & + & 'crest',date(5:6),date(7:8),date(3:4),time(:4),'Energy =',er + write (ch,'(a)') + !>--- counts line + write (ch,countsfmt) nat,nbd,list8,999,'V2000' + !>--- atom block + do j = 1,nat + write (ch,atmfmt) xyz(1:3,j),i2e(at(j),'nc'),list12 + end do + !>--- bonds block + do i = 1,nat + do j = i+1,nat + k = nint(wbo(j,i)) + if (k > 0) then + write (ch,bndfmt) i,j,k,list4 + end if + end do + end do + !>--- other + if (present(icharges)) then + do i = 1,nat + if (abs(nint(icharges(i))) /= 0) then + write (ch,'(a, *(i3, 1x, i3, 1x, i3))') "M CHG",1,i,nint(icharges(i)) + end if + end do + else if (chrg .ne. 0) then + write (ch,'(a, *(i3, 1x, i3, 1x, i3))') "M CHG",1,1,chrg + end if + write (ch,'(a)') 'M END' + write (ch,'(a)') '$$$$' + return + end subroutine wrsdf_channel + +!============================================================! +! subroutine wrsdfV3000_channel +! this is the quick write routine for sdf files +! version for writing to a output channel +! +! On Input: fname - name of the coord file +! nat - number of atoms +! at - atom number as integer +! xyz - coordinates (in Angström) +! er - energy +! wbo - bond order matrix +! +! On Output: written to channel "ch" +!============================================================! + subroutine wrsdfV3000_channel(ch,nat,at,xyz,er,chrg,wbo,comment) + implicit none + integer,intent(in) :: ch + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(in) :: xyz(3,nat) + real(wp),intent(in) :: er + real(wp),intent(in) :: chrg + real(wp),intent(in) :: wbo(nat,nat) + character(len=*),intent(in),optional :: comment + character(len=8) :: date + character(len=10) :: time + integer :: list12(12),nbd,b + integer,parameter :: list4(4) = 0 + character(len=*),parameter :: countsfmt = '(3i3, 8i3, 1x, a5)' + character(len=*),parameter :: countsfmt2 = '(a,2i3, 3i3)' + character(len=*),parameter :: atmfmt = '(a,1x,i0,1x, a,3f10.4, i2, 11i3)' + character(len=*),parameter :: bndfmt = '(a,1x,i0,1x,7i3)' + integer :: i,j,k,ich,io + logical :: ex + + !>--- generate data + call date_and_time(date,time) + nbd = countbonds(nat,wbo) + !>--- comment lines + call date_and_time(date,time) + if (present(comment)) then + write (ch,'(1x,a)') comment + else + write (ch,'(1x,a)') 'structure written by crest' + end if + write (ch,'(1x,a,f18.8,5x, 3a2, a4, "3D")') & + & 'Energy =',er,date(5:6),date(7:8),date(3:4),time(:4) + write (ch,'(a)') + !>--- counts line + write (ch,countsfmt) nat,nbd,0,0,0,999,'V2000' + write (ch,'("M V30 BEGIN CTAB")') + write (ch,countsfmt2) "M V30 COUNTS",nat,nbd,0,0,0 + !>--- atom block + write (ch,'("M V30 BEGIN ATOM")') + do j = 1,nat + write (ch,atmfmt) 'M V30',j, & + & i2e(at(j),'nc'),xyz(1:3,j),list12 + end do + write (ch,'("M V30 END ATOM")') + !>--- bonds block + write (ch,'("M V30 BEGIN BOND")') + b = 0 + do i = 1,nat + do j = i+1,nat + k = nint(wbo(j,i)) + if (k > 0) then + b = b+1 + write (ch,bndfmt) "M V30",b,i,j,k,list4 + end if + end do + end do + write (ch,'("M V30 END BOND")') + !>--- other + if (chrg .ne. 0) then + write (ch,'(a, *(i3, 1x, i3, 1x, i3))') "M V30 CHG",1,1,chrg + end if + write (ch,'(a)') 'M V30 END CTAB' + write (ch,'(a)') 'M END' + write (ch,'(a)') '$$$$' + return + end subroutine wrsdfV3000_channel + +!=========================================================================================! +!=========================================================================================! +! 4. GENERAL UTILITY ROUTINES +!=========================================================================================! +!=========================================================================================! + +!============================================================! +! read a line of coordinates and determine by itself +! if the format is x,y,z,at or at,x,y,z +!============================================================! + subroutine coordline(line,sym,xyz,io) + implicit none + character(len=*) :: line + character(len=*) :: sym + real(wp) :: xyz(3) + integer,intent(out) :: io + + io = 0 + read (line,*,iostat=io) xyz(1:3),sym + if (io .ne. 0) then + read (line,*,iostat=io) sym,xyz(1:3) + !if(io.ne.0)then + ! error stop 'error while reading coord line' + !endif + end if + + return + end subroutine coordline + +!============================================================! +! convert a string into uppercase +!============================================================! + function upperCase(s) + implicit none + character(len=*),intent(in) :: s + character(len=:),allocatable :: sout + character(len=:),allocatable :: upperCase + integer :: ic,i + character(26),Parameter :: high = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + character(26),Parameter :: low = 'abcdefghijklmnopqrstuvwxyz' + sout = s + do i = 1,LEN_TRIM(s) + ic = INDEX(low,s(i:i)) + if (ic > 0) sout(i:i) = high(ic:ic) + end do + call move_alloc(sout,upperCase) + end function upperCase + +!============================================================! +! convert a string into lowercase +!============================================================! + function lowerCase(s) + implicit none + character(len=*),intent(in) :: s + character(len=:),allocatable :: sout + character(len=:),allocatable :: lowerCase + integer :: ic,i + character(26),Parameter :: high = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + character(26),Parameter :: low = 'abcdefghijklmnopqrstuvwxyz' + sout = s + do i = 1,LEN_TRIM(s) + ic = INDEX(high,s(i:i)) + if (ic > 0) sout(i:i) = low(ic:ic) + end do + call move_alloc(sout,lowerCase) + end function lowerCase + +!============================================================! +! split element lable if some isotope indicator was given +! and convert to uppercase +!============================================================! + function convertlable(s) + implicit none + character(len=*),intent(in) :: s + character(len=:),allocatable :: sout + character(len=:),allocatable :: convertlable + integer :: ic,i + character(14),parameter :: lab = '0123456789*_+-' + character(26),parameter :: high = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + character(26),parameter :: low = 'abcdefghijklmnopqrstuvwxyz' + sout = s + do i = 1,len_trim(s) + ic = index(lab,s(i:i)) + if (ic > 0) sout(i:i) = ' ' + ic = index(low,s(i:i)) + if (ic > 0) sout(i:i) = high(ic:ic) + end do + sout = trim(adjustl(sout)) + if (len_trim(sout) .gt. 1) then + sout(2:2) = lowerCase(sout(2:2)) + else + sout = sout//' ' + end if + call move_alloc(sout,convertlable) + end function convertlable + +!=============================================================! + pure elemental integer function ncore(at) + integer,intent(in) :: at + if (at .le. 2) then + ncore = 0 + elseif (at .le. 10) then + ncore = 2 + elseif (at .le. 18) then + ncore = 10 + elseif (at .le. 29) then !zn + ncore = 18 + elseif (at .le. 36) then + ncore = 28 + elseif (at .le. 47) then + ncore = 36 + elseif (at .le. 54) then + ncore = 46 + elseif (at .le. 71) then + ncore = 54 + elseif (at .le. 79) then + ncore = 68 + elseif (at .le. 86) then + ncore = 78 + elseif (at .le. 103) then !> Rn core + ncore = 86 + elseif (at .le. 118) then !> Og core + ncore = 102 + end if + end function ncore + +!============================================================! +! e2i is used to map the element (as a string) to integer +!============================================================! + integer function e2i(cin) + implicit none + character(len=*),intent(in) :: cin + character(len=:),allocatable :: c + integer :: iout + integer :: i,j,k,ich,io,Z + logical :: ex + c = trim(convertlable(cin)) + read (cin,*,iostat=io) j + if (io == 0) Z = j + if (any(PSE(:) .eq. c)) then + do i = 1,118 + if (trim(PSE(i)) .eq. c) then + iout = i + exit + end if + end do + else if (io == 0.and.Z <= 118) then + iout = Z + else !> special cases + select case (trim(c)) + case ('D'); iout = 1 + case ('T'); iout = 1 + case default; iout = 0 + end select + end if + e2i = iout + end function e2i + +!============================================================! +! i2e is used to map the element (as a integer) to a string +!============================================================! + character(len=2) function i2e(iin,oformat) + implicit none + integer,intent(in) :: iin + character(len=:),allocatable :: c + character(len=*),optional :: oformat + if (iin <= 118) then + c = uppercase(PSE(iin)) + else + c = 'XX' + end if + i2e = trim(c) + if (present(oformat)) then + select case (oformat) + case ('lc','lowercase') + i2e = lowerCase(trim(c)) + case ('nc','nicecase') + if (len_trim(c) .gt. 1) then + c(2:2) = lowerCase(c(2:2)) + i2e = trim(c) + end if + case default + continue + end select + end if + end function i2e + +!============================================================! +! get the file extension +!============================================================! + function fextension(s) + implicit none + character(len=*),intent(in) :: s !filename + character(len=:),allocatable :: sout + character(len=:),allocatable :: fextension !output + integer :: ic,i + sout = trim(adjustl(s)) + i = len_trim(sout) + ic = index(sout,'.',.true.) + if (ic .ne. 0) then + fextension = sout(ic:i) + else + fextension = 'none' + end if + return + end function fextension + +!============================================================! +! grep for a keyword within the file +!============================================================! + function sgrep(fname,key) + implicit none + character(len=*),intent(in) :: fname + character(len=*),intent(in) :: key + logical :: sgrep + character(len=256) :: atmp + integer :: ic,io + sgrep = .false. + open (newunit=ic,file=fname) + do + read (ic,'(a)',iostat=io) atmp + if (io < 0) exit !EOF + if (index(atmp,key) .ne. 0) then + sgrep = .true. + exit + end if + end do + close (ic) + return + end function sgrep + +!============================================================! +! grep the energy from a line of strings +!============================================================! + function grepenergy(line) + implicit none + real(wp) :: grepenergy + character(len=*),intent(in) :: line + real(wp) :: energy + character(len=:),allocatable :: atmp + integer :: i,io,k + atmp = trim(line) + energy = 0.0_wp + if (index(atmp,'energy=') .ne. 0) then + k = index(atmp,'energy=') + atmp = atmp(k+7:) + read (atmp,*,iostat=io) energy + if (io .ne. 0) energy = 0.0_wp + else if (index(atmp,'energy:') .ne. 0) then + k = index(atmp,'energy:') + atmp = atmp(k+7:) + read (atmp,*,iostat=io) energy + if (io .ne. 0) energy = 0.0_wp + else + !> assumes that the first float in the line is the energy + do i = 1,len_trim(atmp) + if (len_trim(atmp) .lt. 1) exit + read (atmp,*,iostat=io) energy + if (io > 0) then + atmp = atmp(2:) + atmp = adjustl(atmp) + cycle + else + exit + end if + end do + end if + grepenergy = energy + return + end function grepenergy + +!============================================================! +! count number of bonds from an wbo matrix +!============================================================! + function countbonds(nat,wbo) result(nbd) + implicit none + integer,intent(in) :: nat + real(wp),intent(in) :: wbo(nat,nat) + integer :: nbd + integer :: i,j,k + nbd = 0 + do i = 1,nat + do j = 1,i-1 + k = nint(wbo(i,j)) + if (k > 0) nbd = nbd+1 + end do + end do + return + end function countbonds + +!=========================================================================================! + + subroutine get_atlist(nat,atlist,line,at) +!****************************************************** +!* Analyze a string containing atom specifications. +!* "atlist" is a array of booleans for each atom, +!* which is set to .true. should the atom be contained +!* in atlist. +!****************************************************** + implicit none + integer,intent(in) :: nat + logical,intent(out),allocatable :: atlist(:) + character(len=*),intent(in) :: line + integer,intent(in),optional :: at(nat) + character(len=:),allocatable :: substr(:) + integer :: i,j,k,l,io,ns,ll,i1,i2,io1,io2,i3,i4 + character(len=:),allocatable :: atmp,btmp + + allocate (atlist(nat),source=.false.) +!>-- count stuff + ll = len_trim(line) + ns = 1 + do i = 1,ll + if (line(i:i) .eq. ',') ns = ns+1 + end do + allocate (substr(ns),source=repeat(' ',ll)) +!>-- cut stuff + if (ns > 1) then + j = 1 + k = 1 + do i = 1,ll + if (k == ns) then + substr(k) = lowercase(adjustl(line(j:))) + exit + end if + if (line(i:i) .eq. ',') then + substr(k) = lowercase(adjustl(line(j:i-1))) + k = k+1 + j = i+1 + end if + end do + else + substr(1) = trim(line) + end if +!>--- analyze stuff + do i = 1,ns + atmp = trim(substr(i)) + if (atmp .eq. 'all') then + atlist(:) = .true. + exit + end if + if (index(atmp,'.') .ne. 0) cycle !> exclude floats + l = index(atmp,'-') + if (l .eq. 0) then + read (atmp,*,iostat=io) i1 + !> check if it is an element symbol + if (io /= 0) then + if (len_trim(atmp) > 2) then + if (index(trim(atmp),'heavy') .ne. 0) then !> all heavy atoms + if (present(at)) then + do j = 1,nat + if (at(j) > 1) atlist(j) = .true. + end do + end if + end if + else !> element symbols + k = e2i(atmp) + if (present(at)) then + do j = 1,nat + if (at(j) == k) atlist(j) = .true. + end do + end if + end if + else + atlist(i1) = .true. + end if + else + btmp = atmp(:l-1) + read (btmp,*,iostat=io1) i1 + btmp = atmp(l+1:) + read (btmp,*,iostat=io2) i2 + if (io1 .eq. 0.and.io2 .eq. 0) then + i4 = max(i1,i2) + i3 = min(i1,i2) + do j = 1,nat + if (i3 <= j.and.j <= i4) atlist(j) = .true. + end do + end if + end if + end do + deallocate (substr) + end subroutine get_atlist + +!=========================================================================================! + function sumform(nat,at) result(sumformula) +!************************************************ +!* get sumformula as a string from the AT array +!************************************************ + implicit none + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + character(len=:),allocatable :: sumformula + integer :: sumat(118) + integer :: i + character(len=6) :: str + sumformula = '' + sumat = 0 + do i = 1,nat + sumat(at(i)) = sumat(at(i))+1 + end do + !> carbon always first + if (sumat(6) > 0) then + if (sumat(6) > 1) then + write (str,'(a,i0)') trim(adjustl(i2e(6,'nc'))),sumat(6) + else + str = 'C' + end if + sumformula = trim(sumformula)//trim(str) + end if + do i = 2,118 + if (i == 6) cycle + if (sumat(i) .lt. 1) cycle + if (sumat(i) > 1) then + write (str,'(a,i0)') trim(adjustl(i2e(i,'nc'))),sumat(i) + else + str = trim(i2e(i,'nc')) + end if + sumformula = trim(sumformula)//trim(str) + end do + !> hydrogen always last + if (sumat(1) > 0) then + if (sumat(1) > 1) then + write (str,'(a,i0)') trim(adjustl(i2e(1,'nc'))),sumat(1) + else + str = 'H' + end if + sumformula = trim(sumformula)//trim(str) + end if + return + end function sumform + +! ────────────────────────────────────────────────────────────────────────────── +!==================================================================! +! subroutine deallocate_pdb +! is used to clear memory for the pdbdata type +!==================================================================! + subroutine deallocate_pdb(self) + implicit none + class(pdbdata) :: self + self%nat = 0 + self%frag = 0 + if (allocated(self%athet)) deallocate (self%athet) + if (allocated(self%pdbat)) deallocate (self%pdbat) + if (allocated(self%pdbas)) deallocate (self%pdbas) + if (allocated(self%pdbfrag)) deallocate (self%pdbfrag) + if (allocated(self%pdbgrp)) deallocate (self%pdbgrp) + if (allocated(self%pdbocc)) deallocate (self%pdbocc) + if (allocated(self%pdbtf)) deallocate (self%pdbtf) + return + end subroutine deallocate_pdb + +!==================================================================! +! subroutine allocate_pdb +! is used to clear memory for the pdbdata type +!==================================================================! + subroutine allocate_pdb(self,nat) + implicit none + class(pdbdata) :: self + integer :: nat + call deallocate_pdb(self) + self%nat = nat + allocate (self%athet(nat)) + allocate (self%pdbat(nat)) + allocate (self%pdbas(nat)) + allocate (self%pdbfrag(nat)) + allocate (self%pdbgrp(nat)) + allocate (self%pdbocc(nat)) + allocate (self%pdbtf(nat)) + return + end subroutine allocate_pdb + +! ══════════════════════════════════════════════════════════════════════════════ +! end of the module +! ══════════════════════════════════════════════════════════════════════════════ +end module molecule_io diff --git a/src/molecule/meson.build b/src/molecule/meson.build new file mode 100644 index 00000000..008d8e00 --- /dev/null +++ b/src/molecule/meson.build @@ -0,0 +1,23 @@ +# This file is part of crest. +# SPDX-Identifier: LGPL-3.0-or-later +# +# crest is free software: you can redistribute it and/or modify it under +# the terms of the GNU Lesser General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# crest is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public License +# along with crest. If not, see . + +srcs += files( + 'parameters.f90', + 'type.f90', + 'io.f90', + 'strucreader.f90', + 'sdfio.f90', +) diff --git a/src/molecule/parameters.f90 b/src/molecule/parameters.f90 new file mode 100644 index 00000000..6dc2427e --- /dev/null +++ b/src/molecule/parameters.f90 @@ -0,0 +1,63 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2026 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module molecule_parameters + use iso_fortran_env,only:wp => real64 + use iso_c_binding + implicit none + + public :: wp !> RE-EXPORT +!&< +!>--- some constants and name mappings + real(wp),parameter :: bohr = 0.52917726_wp + real(wp),parameter :: aatoau = 1.0_wp/bohr + real(wp),parameter :: autokcal = 627.509541_wp +!>-- filetypes as integers + type ,private:: enum_coordtype + integer :: unknown = 0 + integer :: turbomole = 1 + integer :: xyz = 2 + integer :: extxyz = 22 + integer :: sdf = 3 + integer :: sdfV2000 = 31 + integer :: sdfV3000 = 32 + integer :: PDB = 4 + end type enum_coordtype + type(enum_jobtype), parameter,public :: coordtype = enum_coordtype() + + !> Element symbols + character(len=2),parameter :: PSE(118) = [ & + & 'H ', 'He', & + & 'Li','Be', 'B ','C ','N ','O ','F ','Ne', & + & 'Na','Mg', 'Al','Si','P ','S ','Cl','Ar', & + & 'K ','Ca','Sc','Ti','V ','Cr','Mn','Fe','Co','Ni','Cu','Zn','Ga','Ge','As','Se','Br','Kr', & + & 'Rb','Sr','Y ','Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn','Sb','Te','I ','Xe', & + & 'Cs','Ba','La', & + & 'Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb','Lu', & + & 'Hf','Ta','W ','Re','Os','Ir','Pt','Au','Hg','Tl','Pb','Bi','Po','At','Rn', & + & 'Fr','Ra','Ac', & + & 'Th','Pa','U ','Np','Pu','Am','Cm','Bk','Cf','Es','Fm','Md','No','Lr', & + & 'Rf','Db','Sg','Bh','Hs','Mt','Ds','Rg','Cn','Nh','Fl','Mc','Lv','Ts','Og' ] +!&> + +! ══════════════════════════════════════════════════════════════════════════════ +contains !> MODULE PROCEDURES START HERE +! ══════════════════════════════════════════════════════════════════════════════ + +end module molecule_parameters diff --git a/src/sdfio.f90 b/src/molecule/sdfio.f90 similarity index 100% rename from src/sdfio.f90 rename to src/molecule/sdfio.f90 diff --git a/src/strucreader.f90 b/src/molecule/strucreader.f90 similarity index 100% rename from src/strucreader.f90 rename to src/molecule/strucreader.f90 diff --git a/src/molecule/type.f90 b/src/molecule/type.f90 new file mode 100644 index 00000000..85883a04 --- /dev/null +++ b/src/molecule/type.f90 @@ -0,0 +1,467 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2026 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module molecule_type + use iso_c_binding + use molecule_parameters + use molecule_io +!> simple geomerty and vector operations + use geo +!> element symbols + use crest_cn_module,only:calculate_cn + implicit none + private + + public :: coord + +! ══════════════════════════════════════════════════════════════════════════════ + + type :: coord + !> coord class. contains a single structure + !> by convention coordinates are in atomic units (Bohr) for a single structure! + + !********************************************! + !> data that's typically used in coord type -- number of atoms + integer :: nat = 0 + !>-- atom types as integer, dimension will be at(nat) + integer,allocatable :: at(:) + !>-- atomic coordinates, by convention in Bohrs + real(wp),allocatable :: xyz(:,:) + + !**************************************! + !> (optional) data, often not present -- energy + real(wp) :: energy = 0.0_wp + !>-- a comment line + character(len=:),allocatable :: comment + !>-- "origin" tag + character(len=:),allocatable :: origin + !>-- molecular charge + integer :: chrg = 0 + !>-- multiplicity information + integer :: uhf = 0 + !>--- gradient + real(wp),allocatable :: grad(:,:) + !>-- number of bonds + integer :: nbd = 0 + !>-- bond info + integer,allocatable :: bond(:,:) + !>-- lattice vectors + real(wp),allocatable :: lat(:,:) + + !>-- atomic charges + real(wp),allocatable :: qat(:) + + !>-- (optional) PDB data + type(pdbdata) :: pdb + + contains + procedure :: deallocate => deallocate_coord !> clear memory space + procedure :: open => opencoord !> read an coord file + procedure :: write => writecoord !> write + procedure :: append => appendcoord !> append + procedure :: get => getcoord !> allocate & fill with data + procedure :: appendlog !> append .log file with coordinates and energy + procedure :: dist => coord_getdistance !> calculate distance between two atoms + procedure :: angle => coord_getangle !> calculate angle between three atoms + procedure :: dihedral => coord_getdihedral !> calculate dihedral angle between four atoms + procedure :: cutout => coord_getcutout !> create a substructure + procedure :: get_CN => coord_get_CN !> calculate coordination number + procedure :: get_z => coord_get_z !> calculate nuclear charge + procedure :: cn_to_bond => coord_cn_to_bond !> generate neighbour matrix from CN + procedure :: swap => atswp !> swap two atoms coordinates and their at() entries + procedure :: sumform => coord_sumform !> generate a string with the sum formula + end type coord + +! ══════════════════════════════════════════════════════════════════════════════ +contains !> MODULE PROCEDURES START HERE +! ══════════════════════════════════════════════════════════════════════════════ +! ROUTINES FOR READING SINGLE STRUCTURES (COORDS) +! ────────────────────────────────────────────────────────────────────────────── + + subroutine deallocate_coord(self) +!********************************************** +!* subroutine deallocate_coord * +!* is used to clear memory for the coord type * +!********************************************** + implicit none + class(coord) :: self + self%nat = 0 + if (allocated(self%at)) deallocate (self%at) + if (allocated(self%xyz)) deallocate (self%xyz) + call self%pdb%deallocate() + return + end subroutine deallocate_coord + +! ────────────────────────────────────────────────────────────────────────────── + + subroutine opencoord(self,fname) +!************************************************ +!* subroutine opencoord * +!* is the open procedure for the "coord" class. * +!************************************************ + implicit none + class(coord) :: self + character(len=*),intent(in) :: fname + integer :: nat + integer,allocatable :: at(:) + real(wp),allocatable :: xyz(:,:) + integer :: ftype + integer :: i,j,k,ich,io + logical :: ex + real(wp) :: en + + inquire (file=fname,exist=ex) + if (.not.ex) then + error stop 'coord file does not exist.' + end if + + call self%deallocate() + + call checkcoordtype(fname,ftype) + call rdnat(fname,nat) + + if (nat > 0) then + en = 0.0_wp + allocate (at(nat),xyz(3,nat)) + if (ftype == pdbfile) then + call rdPDB(fname,nat,at,xyz,self%pdb) + xyz = xyz/bohr + else + call rdcoord(fname,nat,at,xyz,energy=en) + end if + + self%nat = nat + self%energy = en + call move_alloc(at,self%at) + call move_alloc(xyz,self%xyz) + else + error stop 'format error while reading coord file.' + end if + + return + end subroutine opencoord + +! ────────────────────────────────────────────────────────────────────────────── + +! subroutine getcoord +! allocate "coord" class and fill with data + subroutine getcoord(self,convfac,nat,at,xyz) + implicit none + class(coord) :: self + real(wp),intent(in) :: convfac + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(in) :: xyz(3,nat) + call self%deallocate() + allocate (self%at(nat)) + allocate (self%xyz(3,nat)) + self%nat = nat + self%at = at + self%xyz = xyz/convfac + return + end subroutine getcoord + +! ────────────────────────────────────────────────────────────────────────────── + +! function coord_getdistance +! calculate the distance for a given pair of atoms + function coord_getdistance(self,a1,a2) result(d) + implicit none + class(coord) :: self + integer,intent(in) :: a1,a2 + real(wp) :: d + d = 0.0_wp + if (allocated(self%xyz)) then + d = (self%xyz(1,a1)-self%xyz(1,a2))**2+ & + & (self%xyz(2,a1)-self%xyz(2,a2))**2+ & + & (self%xyz(3,a1)-self%xyz(3,a2))**2 + d = sqrt(d) + end if + return + end function coord_getdistance + +! ────────────────────────────────────────────────────────────────────────────── + +! function coord_getangle +! calculate the angle for a given trio of atoms in rad +! A1-A2-A3 + function coord_getangle(self,a1,a2,a3) result(angle) + implicit none + class(coord) :: self + integer,intent(in) :: a1,a2,a3 + real(wp) :: angle,u(3),v(3),o(3) + real(wp) :: d2ij,d2jk,d2ik,xy,temp + angle = 0.0_wp + if (allocated(self%xyz)) then + u(1:3) = self%xyz(1:3,a1)-self%xyz(1:3,a2) + v(1:3) = self%xyz(1:3,a3)-self%xyz(1:3,a2) + angle = tangle(u,v) + end if + return + end function coord_getangle + +! ────────────────────────────────────────────────────────────────────────────── + +! function coord_getdihedral +! calculate the dihedral angle for a given quartet of atoms in rad +! A1-A2-A3-A4 + function coord_getdihedral(self,a1,a2,a3,a4) result(dihed) + implicit none + class(coord) :: self + integer,intent(in) :: a1,a2,a3,a4 + real(wp) :: dihed + real(wp) :: u(3),v(3),w(3) + real(wp) :: n1(3),n2(3) + real(wp) :: u1(3),u2(3),u3(3) + + dihed = 0.0_wp + if (allocated(self%xyz)) then + + u(1:3) = self%xyz(1:3,a2)-self%xyz(1:3,a1) + v(1:3) = self%xyz(1:3,a3)-self%xyz(1:3,a2) + w(1:3) = self%xyz(1:3,a4)-self%xyz(1:3,a3) + dihed = dihedral(u,v,w) + end if + return + end function coord_getdihedral + +! ────────────────────────────────────────────────────────────────────────────── +! function coord_getgutout +! create a cutout mol object + function coord_getcutout(self,atlist) result(molout) + implicit none + class(coord) :: self + logical,intent(in) :: atlist(self%nat) + type(coord) :: molout + integer :: newnat,i,j,k,l + + newnat = count(atlist,1) + if (newnat == self%nat) then + molout = self + else + molout%nat = newnat + allocate (molout%at(newnat),source=0) + allocate (molout%xyz(3,newnat),source=0.0_wp) + k = 0 + do i = 1,self%nat + if (atlist(i)) then + k = k+1 + molout%at(k) = self%at(i) + molout%xyz(1:3,k) = self%xyz(1:3,i) + end if + end do + end if + return + end function coord_getcutout + +! ────────────────────────────────────────────────────────────────────────────── + subroutine coord_get_CN(self,cn,cn_type,cn_thr,dcndr) + implicit none + class(coord) :: self + real(wp),intent(out),allocatable :: cn(:) + real(wp),intent(in),optional :: cn_thr + character(len=*),intent(in),optional :: cn_type + real(wp),intent(out),optional :: dcndr(3,self%nat,self%nat) + if (self%nat <= 0) return + if (.not.allocated(self%xyz).or..not.allocated(self%at)) return + allocate (cn(self%nat),source=0.0_wp) + call calculate_CN(self%nat,self%at,self%xyz,cn, & + & cntype=cn_type,cnthr=cn_thr,dcndr=dcndr) + end subroutine coord_get_CN + +! ────────────────────────────────────────────────────────────────────────────── + subroutine coord_get_z(self,z) + implicit none + class(coord) :: self + real(wp),intent(out),allocatable :: z(:) + integer :: i,j,k + if (self%nat <= 0) return + if (.not.allocated(self%xyz).or..not.allocated(self%at)) return + allocate (z(self%nat),source=0.0_wp) + do i = 1,self%nat + z(i) = real(self%at(i),wp)-real(ncore(self%at(i))) + if (self%at(i) > 57.and.self%at(i) < 72) z(i) = 3.0_wp + end do + end subroutine coord_get_z + +! ────────────────────────────────────────────────────────────────────────────── + subroutine coord_cn_to_bond(self,cn,bond,cn_type,cn_thr) + implicit none + class(coord) :: self + real(wp),intent(out),allocatable :: cn(:) + real(wp),intent(out),allocatable,optional :: bond(:,:) + real(wp),intent(in),optional :: cn_thr + character(len=*),intent(in),optional :: cn_type + if (self%nat <= 0) return + if (.not.allocated(self%xyz).or..not.allocated(self%at)) return + allocate (cn(self%nat),source=0.0_wp) + call calculate_CN(self%nat,self%at,self%xyz,cn, & + & cntype=cn_type,cnthr=cn_thr,bond=bond) + end subroutine coord_cn_to_bond + +! ══════════════════════════════════════════════════════════════════════════════ +! ROUTINES FOR WRITING STRUCTURES AND CONVERTING THEM +! ══════════════════════════════════════════════════════════════════════════════ + + subroutine xyz2coord(iname,oname) +!*********************************************** +!* subroutine xyz2coord * +!* simple conversion of a xyz to a coord file. * +!* * +!* On Input: iname - name of the xyz file * +!* oname - name of the coord file * +!* * +!* On Output: file written to "oname" * +!*********************************************** + implicit none + character(len=*) :: iname + character(len=*) :: oname + type(coord) :: struc + call struc%open(iname) + call wrc0(oname,struc%nat,struc%at,struc%xyz) + call struc%deallocate() + return + end subroutine xyz2coord + +! ────────────────────────────────────────────────────────────────────────────── + subroutine coord2xyz(iname,oname) +!*********************************************** +!* subroutine coord2xyz * +!* simple conversion of a coord to a xyz file. * +!* * +!* On Input: iname - name of the coord file * +!* oname - name of the xyz file * +!* * +!* On Output: file written to "oname" * +!*********************************************** + implicit none + character(len=*) :: iname + character(len=*) :: oname + type(coord) :: struc + call struc%open(trim(iname)) + struc%xyz = struc%xyz*bohr !to Angström + call wrxyz(oname,struc%nat,struc%at,struc%xyz) + call struc%deallocate() + return + end subroutine coord2xyz + +! ────────────────────────────────────────────────────────────────────────────── +! subroutine writecoord +! is the write procedure for the "coord" class. + subroutine writecoord(self,fname) + implicit none + class(coord) :: self + character(len=*),intent(in) :: fname + character(len=80) :: comment + if (.not.allocated(self%xyz)) then + write (*,*) 'Cannot write ',trim(fname),'. not allocated' + end if + if (index(fname,'.xyz') .ne. 0) then + write (comment,'(a,G0.12)') ' energy= ',self%energy + self%xyz = self%xyz*bohr !to Angström + call wrxyz(fname,self%nat,self%at,self%xyz,comment) + self%xyz = self%xyz/bohr !back + else + call wrc0(fname,self%nat,self%at,self%xyz) + end if + return + end subroutine writecoord + +! ────────────────────────────────────────────────────────────────────────────── +! subroutine appendcoord +! is the write procedure for the "coord" class. +! coords will be written out in XYZ format! + subroutine appendcoord(self,io) + implicit none + class(coord) :: self + integer :: io + character(len=64) :: atmp + character(len=32) :: btmp + self%xyz = self%xyz*bohr !to Angström + write (btmp,'(f22.10)') self%energy + write (atmp,'(a,a)') ' energy= ',adjustl(btmp) + if (allocated(self%comment)) then + call wrxyz(io,self%nat,self%at,self%xyz, & + & trim(atmp)//' '//trim(self%comment)) + else + call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) + end if + self%xyz = self%xyz/bohr !back + return + end subroutine appendcoord + +! ────────────────────────────────────────────────────────────────────────────── + subroutine appendlog(self,io,energy,gnorm) + implicit none + class(coord) :: self + integer :: io + real(wp),optional :: energy + real(wp),optional :: gnorm + character(len=64) :: atmp + self%xyz = self%xyz*bohr !to Angström + if (present(gnorm).and.present(energy)) then + write (atmp,'(a,f22.10,a,f16.8)') ' energy= ',energy,' grad.norm.= ',gnorm + else if (present(energy)) then + write (atmp,'(a,f22.10)') ' energy= ',energy + else + atmp = '' + end if + call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) + self%xyz = self%xyz/bohr !back + return + end subroutine appendlog + +! ══════════════════════════════════════════════════════════════════════════════ +! GENERAL UTILITY ROUTINES +! ══════════════════════════════════════════════════════════════════════════════ + + subroutine atswp(self,ati,atj) + !******************************** + !* swap atom ati with atj in mol + !******************************** + implicit none + class(coord),intent(inout) :: self + integer,intent(in) :: ati,atj + real(wp) :: xyztmp(3) + integer :: attmp + xyztmp(1:3) = self%xyz(1:3,ati) + attmp = self%at(ati) + self%xyz(1:3,ati) = self%xyz(1:3,atj) + self%at(ati) = self%at(atj) + self%xyz(1:3,atj) = xyztmp(1:3) + self%at(atj) = attmp + end subroutine atswp + +! ────────────────────────────────────────────────────────────────────────────── + + function coord_sumform(self) result(sumformula) + implicit none + class(coord) :: self + character(len=:),allocatable :: sumformula + sumformula = sumform(self%nat,self%at) + end function coord_sumform + +! ══════════════════════════════════════════════════════════════════════════════ +! end of the module +! ══════════════════════════════════════════════════════════════════════════════ +end module molecule_type diff --git a/src/molecule/type_ensemble.f90 b/src/molecule/type_ensemble.f90 new file mode 100644 index 00000000..7f7fccca --- /dev/null +++ b/src/molecule/type_ensemble.f90 @@ -0,0 +1,2458 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2026 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module molecule_type + use iso_c_binding + use molecule_parameters +!> simple geomerty and vector operations + use geo +!> element symbols + use crest_cn_module,only:calculate_cn + implicit none + +!=========================================================================================! +!>--- private module variables and parameters + private + + public :: rdensembleparam !-- read Nat and Nall for a XYZ trajectory + public :: rdensemble !-- read a XYZ trajectory + interface rdensemble + module procedure rdensemble_conf1 + module procedure rdensemble_conf2 + module procedure rdensemble_conf3 + + module procedure rdensemble_mixed2 + + module procedure rdensemble_coord_type + end interface rdensemble + + public :: wrensemble + interface wrensemble + module procedure wrensemble_conf + module procedure wrensemble_conf_energy + module procedure wrensemble_conf_energy_comment + + module procedure wrensemble_coord_name + module procedure wrensemble_coord_channel + end interface wrensemble + + public :: pdbdata + public :: coord + public :: ensemble + public :: mollist + public :: coordline + public :: get_atlist + public :: sumform + +!=========================================================================================! + !coord class. contains a single structure in the PDB format. + !coordinates by definition are in Angstroem. + type :: pdbdata + + !--- data + integer :: nat = 0 + integer :: frag = 0 + !--- arrays + integer,allocatable :: athet(:) !ATOM (1) or HETATM (2) + character(len=4),allocatable :: pdbat(:) !PDB atom specifier + character(len=3),allocatable :: pdbas(:) !PDB amino acid specifier + integer,allocatable :: pdbfrag(:) !PDB fragment specifier + character(len=1),allocatable :: pdbgrp(:) !PDB group specifier + real(wp),allocatable :: pdbocc(:) !PDB occupancy + real(wp),allocatable :: pdbtf(:) !PDB temperature factor + + contains + procedure :: deallocate => deallocate_pdb !clear memory space + procedure :: allocate => allocate_pdb + + end type pdbdata +!=========================================================================================! + !coord class. contains a single structure + !by convention coordinates are in atomic units (Bohr) for a single structure! + type :: coord + + !********************************************! + !> data that's typically used in coord type -- number of atoms + integer :: nat = 0 + !>-- atom types as integer, dimension will be at(nat) + integer,allocatable :: at(:) + !>-- atomic coordinates, by convention in Bohrs + real(wp),allocatable :: xyz(:,:) + + !**************************************! + !> (optional) data, often not present -- energy + real(wp) :: energy = 0.0_wp + !>-- a comment line + character(len=:),allocatable :: comment + !>-- molecular charge + integer :: chrg = 0 + !>-- multiplicity information + integer :: uhf = 0 + !>-- number of bonds + integer :: nbd = 0 + !>-- bond info + integer,allocatable :: bond(:,:) + !>-- lattice vectors + real(wp),allocatable :: lat(:,:) + + !>-- atomic charges + real(wp),allocatable :: qat(:) + + !>-- (optional) PDB data + type(pdbdata) :: pdb + + contains + procedure :: deallocate => deallocate_coord !> clear memory space + procedure :: open => opencoord !> read an coord file + procedure :: write => writecoord !> write + procedure :: append => appendcoord !> append + procedure :: get => getcoord !> allocate & fill with data + procedure :: appendlog !> append .log file with coordinates and energy + procedure :: dist => coord_getdistance !> calculate distance between two atoms + procedure :: angle => coord_getangle !> calculate angle between three atoms + procedure :: dihedral => coord_getdihedral !> calculate dihedral angle between four atoms + procedure :: cutout => coord_getcutout !> create a substructure + procedure :: get_CN => coord_get_CN !> calculate coordination number + procedure :: get_z => coord_get_z !> calculate nuclear charge + procedure :: cn_to_bond => coord_cn_to_bond !> generate neighbour matrix from CN + procedure :: swap => atswp !> swap two atoms coordinates and their at() entries + procedure :: sumform => coord_sumform !> generate a string with the sum formula + end type coord +!=========================================================================================! + !> ensemble class. contains all structures of an ensemble + !> by convention coordinates are in Angström for an ensemble! + type :: ensemble + + logical :: mixed = .false. !> if all molecules were the same == .false. + + !> data + integer :: nat = 0 !> (max) number of total atoms + integer :: nall = 0 !> number of structures + + !> if all structures were the same molecule these are filled + !> mixed==.false. + integer,allocatable :: at(:) !> atom types as integer, dimension will be at(nat) + real(wp),allocatable :: xyz(:,:,:) !> coordinates, dimension will be xyz(3,nat,nall) + real(wp),allocatable :: er(:) !> energy of each structure, dimension will be eread(nall) + + !> otherwise this is filled + !> mixed == .true. + type(coord),allocatable :: structures(:) + + real(wp) :: g !gibbs free energy + real(wp) :: s !entropy + real(wp),allocatable :: gt(:) !gibbs free energy of each member + real(wp),allocatable :: ht(:) !enthalpy of each member + real(wp),allocatable :: svib(:) !vibrational entropy of each member + real(wp),allocatable :: srot(:) !rotational entropy of each member + real(wp),allocatable :: stra(:) !translational entropy of each member + + contains + procedure :: deallocate => deallocate_ensembletype !clear memory space + procedure :: open => openensemble !read an ensemble file + procedure :: write => write_ensemble !write to file + procedure :: get_mol => ensemble_get_mol !extract the i-th mol from ensemble type + end type ensemble + +!==========================================================================================! + type :: mollist + integer :: nall = 0 + type(coord),allocatable :: structure(:) + end type mollist + +!=========================================================================================! +!=========================================================================================! +contains !> MODULE PROCEDURES START HERE +!=========================================================================================! +!=========================================================================================! +! 1. ROUTINES FOR READING ENTIRE ENSEMBLES (OR TRAJECTORIES) +!=========================================================================================! +!=========================================================================================! + +!==================================================================! +! subroutine rdensembleparam +! read a ensemble file and get some information from +! it: +! On Input: fname - name of the file, should be in +! the Xmol (*.xyz) format. +! +! On Output: nat - number of atoms +! (if different sized structures are present, +! nat is the largest) +! nall - number of structures +! conform - (optional) do all structures +! have the same number of atoms? +!=================================================================! + subroutine rdensembleparam(fname,nat,nall,conform) + implicit none + character(len=*),intent(in) :: fname + integer,intent(out) :: nat + integer,intent(out) :: nall + logical,intent(out),optional :: conform + logical :: conformdum + integer :: dum,iosum + integer :: natref + real(wp) :: x,y,z + integer :: i,j,k,ich,io + logical :: ex + character(len=10) :: str + conformdum = .true. + nat = 0 + nall = 0 + natref = 0 + inquire (file=fname,exist=ex) + if (.not.ex) return + open (newunit=ich,file=fname) + do + read (ich,*,iostat=io) dum + if (io < 0) exit + if (io > 0) cycle + if (nat == 0) natref = dum + read (ich,*,iostat=io) + if (io < 0) exit + iosum = 0 + do i = 1,dum + read (ich,*,iostat=io) str,x,y,z + if (io < 0) exit + iosum = iosum+io + end do + if (iosum > 0) cycle + nat = max(dum,nat) + if (dum .ne. natref) conformdum = .false. + nall = nall+1 + end do + close (ich) + if (present(conform)) conform = conformdum + return + end subroutine rdensembleparam + +!==================================================================! +! subroutine rdensemble_conf1 +! read a conformer ensemble/a MD trajectory, i.e., +! all structures have the same number and order of atoms. +! version 1 also reads the energy +!=================================================================! + subroutine rdensemble_conf1(fname,nat,nall,at,xyz,eread) + implicit none + character(len=*),intent(in) :: fname + integer,intent(inout) :: nat + integer,intent(inout) :: nall + integer,intent(inout),allocatable :: at(:) + real(wp),intent(inout),allocatable :: xyz(:,:,:) + real(wp),intent(inout),allocatable :: eread(:) + integer :: i,j,k,ich,io + logical :: ex + integer :: dum + character(len=512) :: line + character(len=6) :: sym + if (.not.allocated(xyz).or..not.allocated(at)) then + call rdensembleparam(fname,nat,nall) + end if + if (.not.allocated(xyz)) allocate (xyz(3,nat,nall)) + if (.not.allocated(at)) allocate (at(nat)) + if (.not.allocated(eread)) allocate (eread(nall)) + + eread = 0.0_wp + xyz = 0.0_wp + open (newunit=ich,file=fname) + do i = 1,nall + read (ich,*,iostat=io) dum + if (io < 0) exit + if (io > 0) cycle + if (dum .ne. nat) then + call ensemble_strucskip(ich,nat,io) + if (io < 0) exit + end if + read (ich,'(a)',iostat=io) line + if (io < 0) exit + eread(i) = grepenergy(line) + do j = 1,dum + read (ich,'(a)',iostat=io) line + if (io < 0) exit + call coordline(line,sym,xyz(1:3,j,i),io) + if (io .ne. 0) then + backspace (ich) + exit + end if + at(j) = e2i(sym) + end do + end do + close (ich) + + if (io < 0) then + error stop 'error while reading ensemble file.' + end if + + return + end subroutine rdensemble_conf1 + +!==================================================================! +! subroutine rdensemble_conf2 +! read a conformer ensemble/a MD trajectory, i.e., +! all structures have the same number and order of atoms. +! version 2 does not read the energy +!=================================================================! + subroutine rdensemble_conf2(fname,nat,nall,at,xyz) + implicit none + character(len=*),intent(in) :: fname + integer,intent(inout) :: nat + integer,intent(inout) :: nall + integer,intent(inout),allocatable :: at(:) + real(wp),intent(inout),allocatable :: xyz(:,:,:) + integer :: i,j,k,ich,io + logical :: ex + integer :: dum,nallnew + character(len=512) :: line + character(len=6) :: sym + if (.not.allocated(xyz).or..not.allocated(at)) then + call rdensembleparam(fname,nat,nall) + end if + if (.not.allocated(xyz)) allocate (xyz(3,nat,nall)) + if (.not.allocated(at)) allocate (at(nat)) + io = 0 + xyz = 0.0_wp + open (newunit=ich,file=fname) + do i = 1,nall + read (ich,*,iostat=io) dum + if (io < 0) exit + if (io > 0) cycle + if (dum .ne. nat) then + call ensemble_strucskip(ich,nat,io) + if (io < 0) exit + end if + read (ich,'(a)',iostat=io) line + if (io < 0) exit + do j = 1,dum + read (ich,'(a)',iostat=io) line + if (io < 0) exit + call coordline(line,sym,xyz(1:3,j,i),io) + if (io .ne. 0) then + backspace (ich) + exit + end if + at(j) = e2i(sym) + end do + end do + close (ich) + + if (io < 0) then + error stop 'error while reading ensemble file.' + end if + + return + end subroutine rdensemble_conf2 + +!==================================================================! +! subroutine rdensemble_conf3 +! read a conformer ensemble/a MD trajectory, i.e., +! all structures have the same number and order of atoms. +! version 3 saves the comment line for each structure +!=================================================================! + subroutine rdensemble_conf3(fname,nat,nall,at,xyz,comments) + implicit none + character(len=*),intent(in) :: fname + integer,intent(inout) :: nat + integer,intent(inout) :: nall + integer :: at(nat) + integer,allocatable :: atdum(:) + real(wp) :: xyz(3,nat,nall) + character(len=*) :: comments(nall) + integer :: i,j,k,ich,io + logical :: ex + integer :: dum,nallnew + character(len=512) :: line + character(len=6) :: sym + io = 0 + xyz = 0.0_wp + k = 0 + open (newunit=ich,file=fname) + do i = 1,nall + read (ich,*,iostat=io) dum + if (io < 0) exit + if (io > 0) cycle + if (dum .ne. nat) then + call ensemble_strucskip(ich,nat,io) + if (io < 0) exit + end if + read (ich,'(a)',iostat=io) line + if (io < 0) exit + comments(i) = trim(line) + do j = 1,dum + k = k+1 + read (ich,'(a)',iostat=io) line + if (io < 0) exit + call coordline(line,sym,xyz(1:3,j,i),io) + if (io .ne. 0) then + backspace (ich) + exit + end if + at(j) = e2i(sym) + end do + end do + close (ich) + + if (io < 0) then + error stop 'error while reading ensemble file.' + end if + + return + end subroutine rdensemble_conf3 + + subroutine ensemble_strucskip(ich,nat,io) + implicit none + integer,intent(in) :: ich + integer,intent(in) :: nat + integer,intent(out) :: io + integer :: io2,dum,k + io = 0 + dum = 0 + k = 0 + do while (dum .ne. nat) + read (ich,*,iostat=io) dum + if (io < 0) exit + k = k+1 + if (io > 0) cycle + end do + end subroutine ensemble_strucskip + +!==================================================================! +! subroutine rdensemble_mixed2 +! read an ensemble of mixed strcutres, i.e., all stuctures +! can have a diferent number and order of atoms. +! version 2 does not read energies +!=================================================================! + subroutine rdensemble_mixed2(fname,natmax,nall,nats,ats,xyz,comments) + implicit none + character(len=*),intent(in) :: fname + integer,intent(in) :: natmax + integer,intent(in) :: nall + integer :: nats(nall) + integer :: ats(natmax,nall) + real(wp) :: xyz(3,natmax,nall) + character(len=*) :: comments(nall) + integer :: i,j,k,ich,io + logical :: ex + integer :: dum + character(len=512) :: line + character(len=6) :: sym + open (newunit=ich,file=fname) + do i = 1,nall + read (ich,*,iostat=io) dum + if (io < 0) exit + if (io > 0) cycle + nats(i) = dum + read (ich,'(a)',iostat=io) line + if (io < 0) exit + comments(i) = trim(line) + do j = 1,dum + read (ich,'(a)',iostat=io) line + if (io < 0) exit + call coordline(line,sym,xyz(1:3,j,i),io) + if (io < 0) exit + ats(j,i) = e2i(sym) + end do + end do + close (ich) + + if (io < 0) then + error stop 'error while reading ensemble file.' + end if + + return + end subroutine rdensemble_mixed2 + +!========================================================================================! + subroutine rdensemble_coord_type(fname,nall,structures) +!********************************************************* +!* subroutine rdensemble_coord_type +!* A variant of the rdensemble routine that automatically +!* produces an array of coord containers +!********************************************************* + implicit none + character(len=*),intent(in) :: fname !> name of the ensemble file + integer,intent(out) :: nall !> number of structures in ensemble + type(coord),intent(out),allocatable :: structures(:) + + real(wp),allocatable :: xyz(:,:,:) + integer :: nat + integer,allocatable :: nats(:) + integer,allocatable :: at(:) + integer,allocatable :: ats(:,:) + real(wp),allocatable :: eread(:) + character(len=512),allocatable :: comments(:) + integer :: i,j,k,ich,io,nat_i + logical :: ex,multiple_sizes + + call rdensembleparam(fname,nat,nall,multiple_sizes) + !>--- multiple sizes + allocate (structures(nall)) + allocate (xyz(3,nat,nall),ats(nat,nall),nats(nall),eread(nall)) + allocate (comments(nall)) + call rdensemble_mixed2(fname,nat,nall,nats,ats,xyz,comments) + !>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<--- Important: coord types must be in Bohrs + xyz = xyz/bohr + !>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<< we check if all the structures in the file + !> are actually the same length (nat), if not we need to + !> take care of this and read into self%structures instead + call rdensembleparam(fname,nat,nall,conform) + self%mixed = .not.conform + + if (conform) then + if (nat > 0.and.nall > 0) then + call self%deallocate() + allocate (at(nat),xyz(3,nat,nall),eread(nall)) + call rdensemble(fname,nat,nall,at,xyz,eread) + + self%nat = nat + self%nall = nall + call move_alloc(at,self%at) + call move_alloc(xyz,self%xyz) + call move_alloc(eread,self%er) + else + error stop 'format error while reading ensemble file.' + end if + else + call rdensemble_coord_type(fname,self%nall,self%structures) + allocate (self%er(nall),source=0.0_wp) + self%er(:) = self%structures(:)%energy + end if + + return + end subroutine openensemble + + subroutine ensemble_get_mol(self,i,mol) + class(ensemble) :: self + integer,intent(in) :: i + class(coord),intent(inout) :: mol + integer :: n + logical :: reinitialize + if (i > self%nall) error stop 'can´t get molecule from ensemble. i>nall' + if (i < 1) error stop 'can´t get molecule from ensemble. i<1' + if (.not.self%mixed) then + n = self%nat + reinitialize = .not. (mol%nat == n) + if (reinitialize) then + mol%nat = n + if (allocated(mol%at)) deallocate (mol%at) + allocate (mol%at(n),source=0) + if (allocated(mol%xyz)) deallocate (mol%xyz) + allocate (mol%xyz(3,n),source=0.0_wp) + end if + mol%energy = self%er(i) + mol%at(:) = self%at(:) + !> Important, ens is in Angström, mol is in Bohrs + mol%xyz(1:3,1:n) = self%xyz(1:3,1:n,i)*aatoau + else !> self%mixed == .true. + n = self%structures(i)%nat + reinitialize = .not. (mol%nat == n) + if (reinitialize) then + if (allocated(mol%at)) deallocate (mol%at) + allocate (mol%at(n),source=0) + if (allocated(mol%xyz)) deallocate (mol%xyz) + allocate (mol%xyz(3,n),source=0.0_wp) + end if + mol%nat = self%structures(i)%nat + mol%at(:) = self%structures(i)%at(:) + mol%xyz(:,:) = self%structures(i)%xyz(:,:) + mol%energy = self%structures(i)%energy + end if + end subroutine ensemble_get_mol + +!=========================================================================================! +!=========================================================================================! +! 2. ROUTINES FOR READING SINGLE STRUCTURES (COORDS) +!=========================================================================================! +!=========================================================================================! + +!============================================================! +! subroutine checkcoordtype +! try to identify the filetype of the coord type. +! first based on file extension, if that fails by +! a keyword within the file. +!============================================================! + subroutine checkcoordtype(fname,typint) + implicit none + character(len=*) :: fname + integer,intent(out) :: typint + typint = 0 + !-- check file extension first + select case (fextension(fname)) + case ('.coord','.COORD') + typint = tmcoord + case ('.xyz','.XYZ','.trj','.TRJ','.sorted') + typint = xmol + case ('.sd','.sdf','.SDF','.mol','.MOL') + typint = sdf + if (sgrep(fname,'V2000')) then + typint = sdfV2000 + end if + if (sgrep(fname,'V3000')) then + typint = sdfV3000 + end if + case ('.pdb','.PDB') + typint = pdbfile + case default + typint = 0 + end select + if (typint .ne. 0) return !-- file extension was recognized + !-- grep for keywords otherwise + if (sgrep(fname,'$coord')) then + typint = tmcoord + else !--no match found + typint = 0 + end if + return + end subroutine checkcoordtype + +!============================================================! +! subroutine rdnat +! read number of atoms "nat" form file +! +! On Input: fname - name of the coord file +! ftype - (OPTIONAL) format of the input coord file +! if ftype is not present, it is determined +! On Output: nat - number of atoms +!============================================================! + subroutine rdnat(fname,nat,ftype) + implicit none + character(len=*),intent(in) :: fname + integer,intent(out) :: nat + integer,optional :: ftype + integer :: ftypedum + integer :: ich,i,j,io,k + logical :: ex + character(len=256) :: atmp + nat = 0 + inquire (file=fname,exist=ex) + if (.not.ex) then + error stop 'file does not exist.' + end if + if (present(ftype)) then + ftypedum = ftype + else + call checkcoordtype(fname,ftypedum) + end if + open (newunit=ich,file=fname) + select case (ftypedum) + !--- *.xyz files + case (xmol) + read (ich,*,iostat=io) nat + !--- TM coord file + case (tmcoord) + do + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + if (index(atmp,"$coord") .eq. 1) exit + end do + do + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + if (atmp(1:1) == '$') exit + nat = nat+1 + end do + !--- sdf V2000 (or *.mol) file + case (sdfV2000) + do i = 1,3 !-- first three comment lines + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + end do + read (ich,'(a)',iostat=io) atmp + if (index(atmp,'V2000') .ne. 0) then + read (atmp,'(i3)') nat !- first argument is nat + end if + !--- sdf V3000 file + case (sdfV3000) + do + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + if ((index(atmp,'V30') .ne. 0).and. & + & (index(atmp,'COUNTS') .ne. 0)) then + j = index(atmp,'COUNTS')+6 + k = len_trim(atmp) + atmp = atmp(j:k) + atmp = adjustl(atmp) + read (atmp,*) nat + end if + end do + !--- pdb file + case (pdbfile) + !write(*,*) 'PDB file format not supported yet.' + nat = 0 + do + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + if ((index(atmp,'ATOM') .eq. 1).or. & + & (index(atmp,'HETATM') .eq. 1)) then + nat = nat+1 + end if + end do + case default + continue + end select + close (ich) + return + end subroutine rdnat + +!============================================================! +! subroutine rdcoord +! read in a structure. The format is determined automatically +! +! On Input: fname - name of the coord file +! nat - number of atoms +! +! On Output: at - atom number as integer +! xyz - coordinates (always in Bohr) +! energy - (OPTIONAL) if present, try to get energy +! mainly from xyz files +!============================================================! + subroutine rdcoord(fname,nat,at,xyz,energy) + implicit none + character(len=*),intent(in) :: fname + integer,intent(in) :: nat + integer,intent(inout) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) + real(wp),optional :: energy + character(len=256) :: atmp + integer :: ftype + type(pdbdata) :: pdbdummy + + !--- determine the file type + call checkcoordtype(fname,ftype) + + select case (ftype) + case (tmcoord) !-- TM coord file, always retruns coords in Bohr + call rdtmcoord(fname,nat,at,xyz) + case (xmol) !-- XYZ file, is Angström, needs conversion + if (present(energy)) then + call rdxmol(fname,nat,at,xyz,atmp) + energy = grepenergy(atmp) + else + call rdxmol(fname,nat,at,xyz) + end if + xyz = xyz/bohr + case (sdfV2000) !-- SDF/MOL V2000 file, also Angström + call rdsdf(fname,nat,at,xyz) + xyz = xyz/bohr + case (sdfV3000) !-- SDF V3000 file, Angström + call rdsdfV3000(fname,nat,at,xyz) + xyz = xyz/bohr + case (pdbfile) !-- PDB file, Angström + !error stop 'PDB file format not supported yet.' + call rdPDB(fname,nat,at,xyz,pdbdummy) + xyz = xyz/bohr + call pdbdummy%deallocate() + case default + continue + end select + + return + end subroutine rdcoord + +!============================================================! +! subroutine rdtmcoord +! read a struncture in the TM coord style. +! +! On Input: fname - name of the coord file +! nat - number of atoms +! +! On Output: at - atom number as integer +! xyz - coordinates (always in Bohr) +!============================================================! + subroutine rdtmcoord(fname,nat,at,xyz) + implicit none + character(len=*),intent(in) :: fname + integer,intent(in) :: nat + integer,intent(inout) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) + character(len=6) :: sym + integer :: ich,io,i + real(wp) :: convert + character(len=256) :: atmp + open (newunit=ich,file=fname) + do + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + if (index(atmp,"$coord") .eq. 1) exit + end do + if(index(atmp,'ang').ne.0)then + !> coord files allow explicit specification in Angström + convert = aatoau + else + convert = 1.0_wp + endif + do i = 1,nat + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + if (atmp(1:1) == '$') exit + call coordline(atmp,sym,xyz(1:3,i),io) + if (io < 0) then + write (*,*) 'error while reading coord line. EOF' + exit + end if + at(i) = e2i(sym) + end do + close (ich) + xyz = xyz*convert + return + end subroutine rdtmcoord + +!============================================================! +! subroutine rdxmol +! read a struncture in the *.xyz (Xmol) style. +! The commentary (second) line is ignored +! +! On Input: fname - name of the coord file +! nat - number of atoms +! +! On Output: at - atom number as integer +! xyz - coordinates (in Angström) +! comment - (OPTIONAL) commentary line of the file +!============================================================! + subroutine rdxmol(fname,nat,at,xyz,comment) + implicit none + character(len=*),intent(in) :: fname + integer,intent(in) :: nat + integer,intent(inout) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) + character(len=*),optional :: comment + character(len=6) :: sym + integer :: ich,io,i + integer :: dum + character(len=256) :: atmp + open (newunit=ich,file=fname) + read (ich,*,iostat=io) dum + if (nat .ne. dum) then + error stop 'error while reading input coordinates' + end if + read (ich,'(a)') atmp !--commentary line + if (present(comment)) comment = trim(adjustl(atmp)) + do i = 1,nat + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + call coordline(atmp,sym,xyz(1:3,i),io) + if (io < 0) then + write (*,*) 'error while reading coord line. EOF' + exit + end if + at(i) = e2i(sym) + end do + close (ich) + return + end subroutine rdxmol + +!============================================================! +! subroutine rdsdf +! read a struncture in the .sdf/.mol V2000 style. +! +! On Input: fname - name of the coord file +! nat - number of atoms +! +! On Output: at - atom number as integer +! xyz - coordinates (in Angström) +! comment - (OPTIONAL) commentary line of the file +!============================================================! + subroutine rdsdf(fname,nat,at,xyz,comment) + implicit none + character(len=*),intent(in) :: fname + integer,intent(in) :: nat + integer,intent(inout) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) + character(len=*),optional :: comment + character(len=6) :: sym + integer :: ich,io,i + integer :: dum + character(len=256) :: atmp + open (newunit=ich,file=fname) + read (ich,'(a)',iostat=io) atmp + read (ich,'(a)',iostat=io) atmp + read (ich,'(a)',iostat=io) atmp + if (present(comment)) comment = trim(adjustl(atmp)) + read (ich,'(i3)',iostat=io) dum + if (nat .ne. dum) then + error stop 'error while reading input coordinates' + end if + do i = 1,nat + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + call coordline(atmp,sym,xyz(1:3,i),io) + if (io < 0) then + write (*,*) 'error while reading coord line. EOF' + exit + end if + at(i) = e2i(sym) + end do + close (ich) + return + end subroutine rdsdf + +!============================================================! +! subroutine rdsdfV3000 +! read a struncture in the .sdf/.mol V3000 style. +! +! On Input: fname - name of the coord file +! nat - number of atoms +! +! On Output: at - atom number as integer +! xyz - coordinates (in Angström) +! comment - (OPTIONAL) commentary line of the file +!============================================================! + subroutine rdsdfV3000(fname,nat,at,xyz,comment) + implicit none + character(len=*),intent(in) :: fname + integer,intent(in) :: nat + integer,intent(inout) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) + character(len=*),optional :: comment + character(len=6) :: sym + integer :: ich,io,i,j,k,l + integer :: dum + character(len=256) :: atmp + character(len=32) :: btmp + open (newunit=ich,file=fname) + read (ich,'(a)',iostat=io) atmp + read (ich,'(a)',iostat=io) atmp + read (ich,'(a)',iostat=io) atmp + if (present(comment)) comment = trim(adjustl(atmp)) + do + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + if ((index(atmp,'V30') .ne. 0).and. & + & (index(atmp,'COUNTS') .ne. 0)) then + j = index(atmp,'COUNTS')+6 + k = len_trim(atmp) + atmp = atmp(j:k) + atmp = adjustl(atmp) + read (atmp,*) dum + end if + if ((index(atmp,'V30') .ne. 0).and. & + & (index(atmp,'ATOM') .ne. 0)) then + exit + end if + end do + if (nat .ne. dum) then + error stop 'error while reading input coordinates' + end if + do i = 1,nat + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + write (btmp,'(i0)') i + l = len_trim(btmp)+1 + j = index(atmp,'V30')+3 + k = len_trim(atmp) + atmp = atmp(j:k) + atmp = adjustl(atmp) + atmp = atmp(l:k) + call coordline(atmp,sym,xyz(1:3,i),io) + if (io < 0) then + write (*,*) 'error while reading coord line. EOF' + exit + end if + at(i) = e2i(sym) + end do + close (ich) + return + end subroutine rdsdfV3000 + +!============================================================! +! subroutine rdPDB +! read a struncture in the .PDB style. +! +! On Input: fname - name of the coord file +! nat - number of atoms +! +! On Output: at - atom number as integer +! xyz - coordinates (in Angström) +! pdb - pdbdata object +!============================================================! + subroutine rdPDB(fname,nat,at,xyz,pdb) + implicit none + character(len=*),intent(in) :: fname + integer,intent(in) :: nat + integer,intent(inout) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) + type(pdbdata) :: pdb + character(len=2) :: sym + integer :: ich,io,i,j,k + character(len=256) :: atmp + character(len=6) :: dum1 + character(len=1) :: dum2,dum3,pdbgp + character(len=3) :: pdbas + character(len=2) :: dum4 + character(len=4) :: pdbat + real(wp) :: r1,r2 + call pdb%allocate(nat) + open (newunit=ich,file=fname) + k = 0 + do + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + if ((index(atmp,'ATOM') .eq. 1).or. & + & (index(atmp,'HETATM') .eq. 1)) then + k = k+1 + read (atmp,'(A6,I5,1X,A4,A1,A3,1X,A1,I4,A1,3X,3F8.3,2F6.2,10X,A2,A2)') & + & dum1,i,pdbat,dum2,pdbas,pdbgp,j,dum3,xyz(1:3,k),r1,r2,sym,dum4 + at(k) = e2i(sym) + pdb%pdbat(k) = pdbat + pdb%pdbas(k) = pdbas + pdb%pdbgrp(k) = pdbgp + pdb%pdbfrag(k) = j + pdb%pdbocc(k) = r1 + pdb%pdbtf(k) = r2 + end if + end do + close (ich) + return + end subroutine rdPDB + +!============================================================! +! subroutine rdxmolselec +! Read a file with multiple structures in the *.xyz (Xmol) style. +! Picks one structure. +! The commentary (second) line is ignored +! +! On Input: fname - name of the coord file +! m - position of the desired structure +! nat - number of atoms +! +! On Output: at - atom number as integer +! xyz - coordinates (in Bohr) +!============================================================! + + subroutine rdxmolselec(fname,m,nat,at,xyz,comment) + implicit none + character(len=*),intent(in) :: fname + integer,intent(in) :: nat,m + integer,intent(inout) :: at(nat) + real(wp),intent(inout) :: xyz(3,nat) + character(len=*),optional :: comment + character(len=6) :: sym + integer :: ich,io,i,j + integer :: dum + character(len=256) :: atmp + + open (newunit=ich,file=fname) + + do j = 1,m + read (ich,*,iostat=io) dum + if (nat .ne. dum) then + error stop 'error while reading input coordinates' + end if + read (ich,'(a)') atmp !--commentary line + if (present(comment)) comment = trim(adjustl(atmp)) + do i = 1,nat + read (ich,'(a)',iostat=io) atmp + if (io < 0) exit + atmp = adjustl(atmp) + call coordline(atmp,sym,xyz(1:3,i),io) + if (io < 0) then + write (*,*) 'error while reading coord line. EOF' + exit + end if + at(i) = e2i(sym) + end do + end do + close (ich) + xyz = xyz/bohr + return + end subroutine rdxmolselec + +!==================================================================! +! subroutine deallocate_coord +! is used to clear memory for the coord type +!==================================================================! + subroutine deallocate_coord(self) + implicit none + class(coord) :: self + self%nat = 0 + if (allocated(self%at)) deallocate (self%at) + if (allocated(self%xyz)) deallocate (self%xyz) + call self%pdb%deallocate() + return + end subroutine deallocate_coord + +!==================================================================! +! subroutine deallocate_pdb +! is used to clear memory for the pdbdata type +!==================================================================! + subroutine deallocate_pdb(self) + implicit none + class(pdbdata) :: self + self%nat = 0 + self%frag = 0 + if (allocated(self%athet)) deallocate (self%athet) + if (allocated(self%pdbat)) deallocate (self%pdbat) + if (allocated(self%pdbas)) deallocate (self%pdbas) + if (allocated(self%pdbfrag)) deallocate (self%pdbfrag) + if (allocated(self%pdbgrp)) deallocate (self%pdbgrp) + if (allocated(self%pdbocc)) deallocate (self%pdbocc) + if (allocated(self%pdbtf)) deallocate (self%pdbtf) + return + end subroutine deallocate_pdb + +!==================================================================! +! subroutine allocate_pdb +! is used to clear memory for the pdbdata type +!==================================================================! + subroutine allocate_pdb(self,nat) + implicit none + class(pdbdata) :: self + integer :: nat + call deallocate_pdb(self) + self%nat = nat + allocate (self%athet(nat)) + allocate (self%pdbat(nat)) + allocate (self%pdbas(nat)) + allocate (self%pdbfrag(nat)) + allocate (self%pdbgrp(nat)) + allocate (self%pdbocc(nat)) + allocate (self%pdbtf(nat)) + return + end subroutine allocate_pdb + +!==================================================================! +! subroutine opencoord +! is the open procedure for the "coord" class. +!==================================================================! + subroutine opencoord(self,fname) + implicit none + class(coord) :: self + character(len=*),intent(in) :: fname + integer :: nat + integer,allocatable :: at(:) + real(wp),allocatable :: xyz(:,:) + integer :: ftype + integer :: i,j,k,ich,io + logical :: ex + real(wp) :: en + + inquire (file=fname,exist=ex) + if (.not.ex) then + error stop 'coord file does not exist.' + end if + + call self%deallocate() + + call checkcoordtype(fname,ftype) + call rdnat(fname,nat) + + if (nat > 0) then + en = 0.0_wp + allocate (at(nat),xyz(3,nat)) + if (ftype == pdbfile) then + call rdPDB(fname,nat,at,xyz,self%pdb) + xyz = xyz/bohr + else + call rdcoord(fname,nat,at,xyz,energy=en) + end if + + self%nat = nat + self%energy = en + call move_alloc(at,self%at) + call move_alloc(xyz,self%xyz) + else + error stop 'format error while reading coord file.' + end if + + return + end subroutine opencoord +!==================================================================! +! subroutine getcoord +! allocate "coord" class and fill with data +!==================================================================! + subroutine getcoord(self,convfac,nat,at,xyz) + implicit none + class(coord) :: self + real(wp),intent(in) :: convfac + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(in) :: xyz(3,nat) + call self%deallocate() + allocate (self%at(nat)) + allocate (self%xyz(3,nat)) + self%nat = nat + self%at = at + self%xyz = xyz/convfac + return + end subroutine getcoord + +!==================================================================! +! function coord_getdistance +! calculate the distance for a given pair of atoms +!==================================================================! + function coord_getdistance(self,a1,a2) result(d) + implicit none + class(coord) :: self + integer,intent(in) :: a1,a2 + real(wp) :: d + d = 0.0_wp + if (allocated(self%xyz)) then + d = (self%xyz(1,a1)-self%xyz(1,a2))**2+ & + & (self%xyz(2,a1)-self%xyz(2,a2))**2+ & + & (self%xyz(3,a1)-self%xyz(3,a2))**2 + d = sqrt(d) + end if + return + end function coord_getdistance + +!==================================================================! +! function coord_getangle +! calculate the angle for a given trio of atoms in rad +! A1-A2-A3 +!==================================================================! + function coord_getangle(self,a1,a2,a3) result(angle) + implicit none + class(coord) :: self + integer,intent(in) :: a1,a2,a3 + real(wp) :: angle,u(3),v(3),o(3) + real(wp) :: d2ij,d2jk,d2ik,xy,temp + angle = 0.0_wp + if (allocated(self%xyz)) then + u(1:3) = self%xyz(1:3,a1)-self%xyz(1:3,a2) + v(1:3) = self%xyz(1:3,a3)-self%xyz(1:3,a2) + angle = tangle(u,v) + end if + return + end function coord_getangle + +!==================================================================! +! function coord_getdihedral +! calculate the dihedral angle for a given quartet of atoms in rad +! A1-A2-A3-A4 +!==================================================================! + function coord_getdihedral(self,a1,a2,a3,a4) result(dihed) + implicit none + class(coord) :: self + integer,intent(in) :: a1,a2,a3,a4 + real(wp) :: dihed + real(wp) :: u(3),v(3),w(3) + real(wp) :: n1(3),n2(3) + real(wp) :: u1(3),u2(3),u3(3) + + dihed = 0.0_wp + if (allocated(self%xyz)) then + + u(1:3) = self%xyz(1:3,a2)-self%xyz(1:3,a1) + v(1:3) = self%xyz(1:3,a3)-self%xyz(1:3,a2) + w(1:3) = self%xyz(1:3,a4)-self%xyz(1:3,a3) + dihed = dihedral(u,v,w) + end if + return + end function coord_getdihedral + +!==================================================================! +! function coord_getgutout +! create a cutout mol object +!==================================================================! + function coord_getcutout(self,atlist) result(molout) + implicit none + class(coord) :: self + logical,intent(in) :: atlist(self%nat) + type(coord) :: molout + integer :: newnat,i,j,k,l + + newnat = count(atlist,1) + if (newnat == self%nat) then + molout = self + else + molout%nat = newnat + allocate (molout%at(newnat),source=0) + allocate (molout%xyz(3,newnat),source=0.0_wp) + k = 0 + do i = 1,self%nat + if (atlist(i)) then + k = k+1 + molout%at(k) = self%at(i) + molout%xyz(1:3,k) = self%xyz(1:3,i) + end if + end do + end if + return + end function coord_getcutout + +!==================================================================! + + subroutine coord_get_CN(self,cn,cn_type,cn_thr,dcndr) + implicit none + class(coord) :: self + real(wp),intent(out),allocatable :: cn(:) + real(wp),intent(in),optional :: cn_thr + character(len=*),intent(in),optional :: cn_type + real(wp),intent(out),optional :: dcndr(3,self%nat,self%nat) + if (self%nat <= 0) return + if (.not.allocated(self%xyz).or..not.allocated(self%at)) return + allocate (cn(self%nat),source=0.0_wp) + call calculate_CN(self%nat,self%at,self%xyz,cn, & + & cntype=cn_type,cnthr=cn_thr,dcndr=dcndr) + end subroutine coord_get_CN + +!==================================================================! + + subroutine coord_get_z(self,z) + implicit none + class(coord) :: self + real(wp),intent(out),allocatable :: z(:) + integer :: i,j,k + if (self%nat <= 0) return + if (.not.allocated(self%xyz).or..not.allocated(self%at)) return + allocate (z(self%nat),source=0.0_wp) + do i = 1,self%nat + z(i) = real(self%at(i),wp)-real(ncore(self%at(i))) + if (self%at(i) > 57.and.self%at(i) < 72) z(i) = 3.0_wp + end do + end subroutine coord_get_z + +!==================================================================! + + subroutine coord_cn_to_bond(self,cn,bond,cn_type,cn_thr) + implicit none + class(coord) :: self + real(wp),intent(out),allocatable :: cn(:) + real(wp),intent(out),allocatable,optional :: bond(:,:) + real(wp),intent(in),optional :: cn_thr + character(len=*),intent(in),optional :: cn_type + if (self%nat <= 0) return + if (.not.allocated(self%xyz).or..not.allocated(self%at)) return + allocate (cn(self%nat),source=0.0_wp) + call calculate_CN(self%nat,self%at,self%xyz,cn, & + & cntype=cn_type,cnthr=cn_thr,bond=bond) + end subroutine coord_cn_to_bond + +!=========================================================================================! +!=========================================================================================! +! 3. ROUTINES FOR WRITING STRUCTURES AND CONVERTING THEM +!=========================================================================================! +!=========================================================================================! + +!============================================================! +! subroutine wrc0_file +! this is the typical quick write routine for TM coord files +! version for writing directly to a new file +! +! On Input: fname - name of the coord file +! nat - number of atoms +! at - atom number as integer +! xyz - coordinates (in Bohr) +! +! On Output: file written to "fname" +!============================================================! + subroutine wrc0_file(fname,nat,at,xyz) + implicit none + character(len=*) :: fname + integer :: nat + integer :: at(nat) + real(wp) :: xyz(3,nat) + integer :: i,j,k,ich,io + logical :: ex + open (newunit=ich,file=fname,status='replace') + write (ich,'(''$coord'')') + do j = 1,nat + write (ich,'(3F24.12,5x,a2)') xyz(1:3,j),i2e(at(j),'lc') + end do + write (ich,'(''$end'')') + close (ich) + return + end subroutine wrc0_file + +!============================================================! +! subroutine wrc0_channel +! this is the typical quick write routine for TM coord files +! version for writing to a output channel +! +! On Input: fname - name of the coord file +! nat - number of atoms +! at - atom number as integer +! xyz - coordinates (in Bohr) +! +! On Output: file written to "fname" +!============================================================! + subroutine wrc0_channel(ch,nat,at,xyz) + implicit none + integer :: ch + integer :: nat + integer :: at(nat) + real(wp) :: xyz(3,nat) + integer :: i,j,k,ich,io + logical :: ex + write (ch,'(''$coord'')') + do j = 1,nat + write (ch,'(3F24.12,5x,a2)') xyz(1:3,j),i2e(at(j),'lc') + end do + write (ch,'(''$end'')') + return + end subroutine wrc0_channel + +!============================================================! +! subroutine wrxyz_file +! this is the typical quick write routine for TM coord files +! version for writing directly to a new file +! +! On Input: fname - name of the coord file +! nat - number of atoms +! at - atom number as integer +! xyz - coordinates (in Angström) +! comment - (OPTIONAL) comment line +! +! On Output: file written to "fname" +!============================================================! + subroutine wrxyz_file(fname,nat,at,xyz,comment) + implicit none + character(len=*) :: fname + integer :: nat + integer :: at(nat) + real(wp) :: xyz(3,nat) + character(len=*),optional :: comment + integer :: i,j,k,ich,io + logical :: ex + open (newunit=ich,file=fname,status='replace') + write (ich,'(2x,i0)') nat + if (present(comment)) then + write (ich,'(a)') trim(comment) + else + write (ich,*) + end if + do j = 1,nat + write (ich,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) + end do + close (ich) + return + end subroutine wrxyz_file + +!============================================================! +! subroutine wrxyz_file_mask +! this is the typical quick write routine for TM coord files +! version for writing directly to a new file +! +! On Input: fname - name of the coord file +! nat - number of atoms +! at - atom number as integer +! xyz - coordinates (in Angström) +! mask - a mask to determine to write which atoms +! comment - (OPTIONAL) comment line +! +! On Output: file written to "fname" +!============================================================! + subroutine wrxyz_file_mask(fname,nat,at,xyz,mask,comment) + implicit none + character(len=*) :: fname + integer :: nat + integer :: at(nat) + real(wp) :: xyz(3,nat) + logical :: mask(nat) + integer :: maskednat + character(len=*),optional :: comment + integer :: i,j,k,ich,io + logical :: ex + open (newunit=ich,file=fname,status='replace') + maskednat = count(mask(:)) + write (ich,'(2x,i0)') maskednat + if (present(comment)) then + write (ich,'(a)') trim(comment) + else + write (ich,*) + end if + do j = 1,nat + if (mask(j)) then + write (ich,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) + end if + end do + close (ich) + return + end subroutine wrxyz_file_mask + +!============================================================! +! subroutine wrxyz_channel +! this is the typical quick write routine for xyz files +! version for writing to a output channel +! +! On Input: fname - name of the coord file +! nat - number of atoms +! at - atom number as integer +! xyz - coordinates (in Angström) +! comment - (OPTIONAL) the comment line +! +! On Output: file written to "fname" +!============================================================! + subroutine wrxyz_channel(ch,nat,at,xyz,comment) + implicit none + integer :: ch + integer :: nat + integer :: at(nat) + real(wp) :: xyz(3,nat) + character(len=*),optional :: comment + integer :: i,j,k,ich,io + logical :: ex + write (ch,'(2x,i0)') nat + if (present(comment)) then + write (ch,'(a)') trim(comment) + else + write (ch,*) + end if + do j = 1,nat + write (ch,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) + end do + return + end subroutine wrxyz_channel + +!============================================================! +! subroutine wrxyz_channel +! this is the typical quick write routine for xyz files +! version for writing to a output channel +! +! On Input: fname - name of the coord file +! nat - number of atoms +! at - atom number as integer +! xyz - coordinates (in Angström) +! er - energy +! +! On Output: file written to "fname" +!============================================================! + subroutine wrxyz_channel_energy(ch,nat,at,xyz,er) + implicit none + integer :: ch + integer :: nat + integer :: at(nat) + real(wp) :: xyz(3,nat) + real(wp) :: er + integer :: i,j,k,ich,io + logical :: ex + write (ch,'(2x,i0)') nat + write (ch,'(2x,a,f18.8)') "energy=",er + do j = 1,nat + write (ch,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) + end do + return + end subroutine wrxyz_channel_energy + +!============================================================! +! subroutine wrsdf_channel +! this is the quick write routine for sdf files +! version for writing to a output channel +! +! On Input: fname - name of the coord file +! nat - number of atoms +! at - atom number as integer +! xyz - coordinates (in Angström) +! er - energy +! wbo - bond order matrix +! +! On Output: written to channel "ch" +!============================================================! + subroutine wrsdf_channel(ch,nat,at,xyz,er,chrg,wbo,comment,icharges) + implicit none + integer,intent(in) :: ch + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(in) :: xyz(3,nat) + real(wp),intent(in) :: er + integer,intent(in) :: chrg + real(wp),intent(in) :: wbo(nat,nat) + character(len=*),intent(in) :: comment + real(wp),intent(in),optional :: icharges(nat) + character(len=8) :: date + character(len=10) :: time + integer :: list12(12),nbd + integer,parameter :: list4(4) = 0 + integer,parameter :: list8(8) = 0 + character(len=*),parameter :: countsfmt = '(3i3, 8i3, 1x, a5)' + character(len=*),parameter :: atmfmt = '(3f10.4, 1x, a2, 12i3)' + character(len=*),parameter :: bndfmt = '(7i3)' + integer :: i,j,k,ich,io + logical :: ex + + !>--- generate data + call date_and_time(date,time) + nbd = countbonds(nat,wbo) + list12 = 0 + !>--- comment lines + call date_and_time(date,time) + write (ch,'(a)') trim(comment) + write (ch,'(1x,a, 3a2, a4, "3D",1x,a,f18.8,5x)') & + & 'crest',date(5:6),date(7:8),date(3:4),time(:4),'Energy =',er + write (ch,'(a)') + !>--- counts line + write (ch,countsfmt) nat,nbd,list8,999,'V2000' + !>--- atom block + do j = 1,nat + write (ch,atmfmt) xyz(1:3,j),i2e(at(j),'nc'),list12 + end do + !>--- bonds block + do i = 1,nat + do j = i+1,nat + k = nint(wbo(j,i)) + if (k > 0) then + write (ch,bndfmt) i,j,k,list4 + end if + end do + end do + !>--- other + if (present(icharges)) then + do i = 1,nat + if (abs(nint(icharges(i))) /= 0) then + write (ch,'(a, *(i3, 1x, i3, 1x, i3))') "M CHG",1,i,nint(icharges(i)) + end if + end do + else if (chrg .ne. 0) then + write (ch,'(a, *(i3, 1x, i3, 1x, i3))') "M CHG",1,1,chrg + end if + write (ch,'(a)') 'M END' + write (ch,'(a)') '$$$$' + return + end subroutine wrsdf_channel + +!============================================================! +! subroutine wrsdfV3000_channel +! this is the quick write routine for sdf files +! version for writing to a output channel +! +! On Input: fname - name of the coord file +! nat - number of atoms +! at - atom number as integer +! xyz - coordinates (in Angström) +! er - energy +! wbo - bond order matrix +! +! On Output: written to channel "ch" +!============================================================! + subroutine wrsdfV3000_channel(ch,nat,at,xyz,er,chrg,wbo,comment) + implicit none + integer,intent(in) :: ch + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + real(wp),intent(in) :: xyz(3,nat) + real(wp),intent(in) :: er + real(wp),intent(in) :: chrg + real(wp),intent(in) :: wbo(nat,nat) + character(len=*),intent(in),optional :: comment + character(len=8) :: date + character(len=10) :: time + integer :: list12(12),nbd,b + integer,parameter :: list4(4) = 0 + character(len=*),parameter :: countsfmt = '(3i3, 8i3, 1x, a5)' + character(len=*),parameter :: countsfmt2 = '(a,2i3, 3i3)' + character(len=*),parameter :: atmfmt = '(a,1x,i0,1x, a,3f10.4, i2, 11i3)' + character(len=*),parameter :: bndfmt = '(a,1x,i0,1x,7i3)' + integer :: i,j,k,ich,io + logical :: ex + + !>--- generate data + call date_and_time(date,time) + nbd = countbonds(nat,wbo) + !>--- comment lines + call date_and_time(date,time) + if (present(comment)) then + write (ch,'(1x,a)') comment + else + write (ch,'(1x,a)') 'structure written by crest' + end if + write (ch,'(1x,a,f18.8,5x, 3a2, a4, "3D")') & + & 'Energy =',er,date(5:6),date(7:8),date(3:4),time(:4) + write (ch,'(a)') + !>--- counts line + write (ch,countsfmt) nat,nbd,0,0,0,999,'V2000' + write (ch,'("M V30 BEGIN CTAB")') + write (ch,countsfmt2) "M V30 COUNTS",nat,nbd,0,0,0 + !>--- atom block + write (ch,'("M V30 BEGIN ATOM")') + do j = 1,nat + write (ch,atmfmt) 'M V30',j, & + & i2e(at(j),'nc'),xyz(1:3,j),list12 + end do + write (ch,'("M V30 END ATOM")') + !>--- bonds block + write (ch,'("M V30 BEGIN BOND")') + b = 0 + do i = 1,nat + do j = i+1,nat + k = nint(wbo(j,i)) + if (k > 0) then + b = b+1 + write (ch,bndfmt) "M V30",b,i,j,k,list4 + end if + end do + end do + write (ch,'("M V30 END BOND")') + !>--- other + if (chrg .ne. 0) then + write (ch,'(a, *(i3, 1x, i3, 1x, i3))') "M V30 CHG",1,1,chrg + end if + write (ch,'(a)') 'M V30 END CTAB' + write (ch,'(a)') 'M END' + write (ch,'(a)') '$$$$' + return + end subroutine wrsdfV3000_channel + +!============================================================! +! subroutine xyz2coord +! simple conversion of a xyz to a coord file. +! +! On Input: iname - name of the xyz file +! oname - name of the coord file +! +! On Output: file written to "oname" +!============================================================! + subroutine xyz2coord(iname,oname) + implicit none + character(len=*) :: iname + character(len=*) :: oname + type(coord) :: struc + call struc%open(iname) + call wrc0(oname,struc%nat,struc%at,struc%xyz) + call struc%deallocate() + return + end subroutine xyz2coord + +!============================================================! +! subroutine coord2xyz +! simple conversion of a coord to a xyz file. +! +! On Input: iname - name of the coord file +! oname - name of the xyz file +! +! On Output: file written to "oname" +!============================================================! + subroutine coord2xyz(iname,oname) + implicit none + character(len=*) :: iname + character(len=*) :: oname + type(coord) :: struc + call struc%open(trim(iname)) + struc%xyz = struc%xyz*bohr !to Angström + call wrxyz(oname,struc%nat,struc%at,struc%xyz) + call struc%deallocate() + return + end subroutine coord2xyz + +!==================================================================! +! subroutine writecoord +! is the write procedure for the "coord" class. +!==================================================================! + subroutine writecoord(self,fname) + implicit none + class(coord) :: self + character(len=*),intent(in) :: fname + character(len=80) :: comment + if (.not.allocated(self%xyz)) then + write (*,*) 'Cannot write ',trim(fname),'. not allocated' + end if + if (index(fname,'.xyz') .ne. 0) then + write (comment,'(a,G0.12)') ' energy= ',self%energy + self%xyz = self%xyz*bohr !to Angström + call wrxyz(fname,self%nat,self%at,self%xyz,comment) + self%xyz = self%xyz/bohr !back + else + call wrc0(fname,self%nat,self%at,self%xyz) + end if + return + end subroutine writecoord + +!==================================================================! +! subroutine appendcoord +! is the write procedure for the "coord" class. +! coords will be written out in XYZ format! +!==================================================================! + subroutine appendcoord(self,io) + implicit none + class(coord) :: self + integer :: io + character(len=64) :: atmp + character(len=32) :: btmp + self%xyz = self%xyz*bohr !to Angström + write(btmp,'(f22.10)') self%energy + write (atmp,'(a,a)') ' energy= ',adjustl(btmp) + if (allocated(self%comment)) then + call wrxyz(io,self%nat,self%at,self%xyz, & + & trim(atmp)//' '//trim(self%comment)) + else + call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) + end if + self%xyz = self%xyz/bohr !back + return + end subroutine appendcoord + + subroutine appendlog(self,io,energy,gnorm) + implicit none + class(coord) :: self + integer :: io + real(wp),optional :: energy + real(wp),optional :: gnorm + character(len=64) :: atmp + self%xyz = self%xyz*bohr !to Angström + if (present(gnorm).and.present(energy)) then + write (atmp,'(a,f22.10,a,f16.8)') ' energy= ',energy,' grad.norm.= ',gnorm + else if (present(energy)) then + write (atmp,'(a,f22.10)') ' energy= ',energy + else + atmp = '' + end if + call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) + self%xyz = self%xyz/bohr !back + return + end subroutine appendlog + +!=========================================================================================! +!=========================================================================================! +! 4. GENERAL UTILITY ROUTINES +!=========================================================================================! +!=========================================================================================! + +!============================================================! +! read a line of coordinates and determine by itself +! if the format is x,y,z,at or at,x,y,z +!============================================================! + subroutine coordline(line,sym,xyz,io) + implicit none + character(len=*) :: line + character(len=*) :: sym + real(wp) :: xyz(3) + integer,intent(out) :: io + + io = 0 + read (line,*,iostat=io) xyz(1:3),sym + if (io .ne. 0) then + read (line,*,iostat=io) sym,xyz(1:3) + !if(io.ne.0)then + ! error stop 'error while reading coord line' + !endif + end if + + return + end subroutine coordline + +!============================================================! +! convert a string into uppercase +!============================================================! + function upperCase(s) + implicit none + character(len=*),intent(in) :: s + character(len=:),allocatable :: sout + character(len=:),allocatable :: upperCase + integer :: ic,i + character(26),Parameter :: high = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + character(26),Parameter :: low = 'abcdefghijklmnopqrstuvwxyz' + sout = s + do i = 1,LEN_TRIM(s) + ic = INDEX(low,s(i:i)) + if (ic > 0) sout(i:i) = high(ic:ic) + end do + call move_alloc(sout,upperCase) + end function upperCase + +!============================================================! +! convert a string into lowercase +!============================================================! + function lowerCase(s) + implicit none + character(len=*),intent(in) :: s + character(len=:),allocatable :: sout + character(len=:),allocatable :: lowerCase + integer :: ic,i + character(26),Parameter :: high = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + character(26),Parameter :: low = 'abcdefghijklmnopqrstuvwxyz' + sout = s + do i = 1,LEN_TRIM(s) + ic = INDEX(high,s(i:i)) + if (ic > 0) sout(i:i) = low(ic:ic) + end do + call move_alloc(sout,lowerCase) + end function lowerCase + +!============================================================! +! split element lable if some isotope indicator was given +! and convert to uppercase +!============================================================! + function convertlable(s) + implicit none + character(len=*),intent(in) :: s + character(len=:),allocatable :: sout + character(len=:),allocatable :: convertlable + integer :: ic,i + character(14),parameter :: lab = '0123456789*_+-' + character(26),parameter :: high = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + character(26),parameter :: low = 'abcdefghijklmnopqrstuvwxyz' + sout = s + do i = 1,len_trim(s) + ic = index(lab,s(i:i)) + if (ic > 0) sout(i:i) = ' ' + ic = index(low,s(i:i)) + if (ic > 0) sout(i:i) = high(ic:ic) + end do + sout = trim(adjustl(sout)) + if (len_trim(sout) .gt. 1) then + sout(2:2) = lowerCase(sout(2:2)) + else + sout = sout//' ' + end if + call move_alloc(sout,convertlable) + end function convertlable + +!=============================================================! + pure elemental integer function ncore(at) + integer,intent(in) :: at + if (at .le. 2) then + ncore = 0 + elseif (at .le. 10) then + ncore = 2 + elseif (at .le. 18) then + ncore = 10 + elseif (at .le. 29) then !zn + ncore = 18 + elseif (at .le. 36) then + ncore = 28 + elseif (at .le. 47) then + ncore = 36 + elseif (at .le. 54) then + ncore = 46 + elseif (at .le. 71) then + ncore = 54 + elseif (at .le. 79) then + ncore = 68 + elseif (at .le. 86) then + ncore = 78 + end if + end function ncore + +!============================================================! +! e2i is used to map the element (as a string) to integer +!============================================================! + integer function e2i(cin) + implicit none + character(len=*),intent(in) :: cin + character(len=:),allocatable :: c + integer :: iout + integer :: i,j,k,ich,io,Z + logical :: ex + c = trim(convertlable(cin)) + read (cin,*,iostat=io) j + if (io == 0) Z = j + if (any(PSE(:) .eq. c)) then + do i = 1,118 + if (trim(PSE(i)) .eq. c) then + iout = i + exit + end if + end do + else if (io == 0.and.Z <= 118) then + iout = Z + else !> special cases + select case (trim(c)) + case ('D'); iout = 1 + case ('T'); iout = 1 + case default; iout = 0 + end select + end if + e2i = iout + end function e2i + +!============================================================! +! i2e is used to map the element (as a integer) to a string +!============================================================! + character(len=2) function i2e(iin,oformat) + implicit none + integer,intent(in) :: iin + character(len=:),allocatable :: c + character(len=*),optional :: oformat + if (iin <= 118) then + c = uppercase(PSE(iin)) + else + c = 'XX' + end if + i2e = trim(c) + if (present(oformat)) then + select case (oformat) + case ('lc','lowercase') + i2e = lowerCase(trim(c)) + case ('nc','nicecase') + if (len_trim(c) .gt. 1) then + c(2:2) = lowerCase(c(2:2)) + i2e = trim(c) + end if + case default + continue + end select + end if + end function i2e + +!============================================================! +! get the file extension +!============================================================! + function fextension(s) + implicit none + character(len=*),intent(in) :: s !filename + character(len=:),allocatable :: sout + character(len=:),allocatable :: fextension !output + integer :: ic,i + sout = trim(adjustl(s)) + i = len_trim(sout) + ic = index(sout,'.',.true.) + if (ic .ne. 0) then + fextension = sout(ic:i) + else + fextension = 'none' + end if + return + end function fextension + +!============================================================! +! grep for a keyword within the file +!============================================================! + function sgrep(fname,key) + implicit none + character(len=*),intent(in) :: fname + character(len=*),intent(in) :: key + logical :: sgrep + character(len=256) :: atmp + integer :: ic,io + sgrep = .false. + open (newunit=ic,file=fname) + do + read (ic,'(a)',iostat=io) atmp + if (io < 0) exit !EOF + if (index(atmp,key) .ne. 0) then + sgrep = .true. + exit + end if + end do + close (ic) + return + end function sgrep + +!============================================================! +! grep the energy from a line of strings +!============================================================! + function grepenergy(line) + implicit none + real(wp) :: grepenergy + character(len=*),intent(in) :: line + real(wp) :: energy + character(len=:),allocatable :: atmp + integer :: i,io,k + atmp = trim(line) + energy = 0.0_wp + if (index(atmp,'energy=') .ne. 0) then + k = index(atmp,'energy=') + atmp = atmp(k+7:) + read (atmp,*,iostat=io) energy + if (io .ne. 0) energy = 0.0_wp + else if (index(atmp,'energy:') .ne. 0) then + k = index(atmp,'energy:') + atmp = atmp(k+7:) + read (atmp,*,iostat=io) energy + if (io .ne. 0) energy = 0.0_wp + else + !> assumes that the first float in the line is the energy + do i = 1,len_trim(atmp) + if (len_trim(atmp) .lt. 1) exit + read (atmp,*,iostat=io) energy + if (io > 0) then + atmp = atmp(2:) + atmp = adjustl(atmp) + cycle + else + exit + end if + end do + end if + grepenergy = energy + return + end function grepenergy + +!============================================================! +! count number of bonds from an wbo matrix +!============================================================! + function countbonds(nat,wbo) result(nbd) + implicit none + integer,intent(in) :: nat + real(wp),intent(in) :: wbo(nat,nat) + integer :: nbd + integer :: i,j,k + nbd = 0 + do i = 1,nat + do j = 1,i-1 + k = nint(wbo(i,j)) + if (k > 0) nbd = nbd+1 + end do + end do + return + end function countbonds + +!=========================================================================================! + + subroutine get_atlist(nat,atlist,line,at) +!****************************************************** +!* Analyze a string containing atom specifications. +!* "atlist" is a array of booleans for each atom, +!* which is set to .true. should the atom be contained +!* in atlist. +!****************************************************** + implicit none + integer,intent(in) :: nat + logical,intent(out),allocatable :: atlist(:) + character(len=*),intent(in) :: line + integer,intent(in),optional :: at(nat) + character(len=:),allocatable :: substr(:) + integer :: i,j,k,l,io,ns,ll,i1,i2,io1,io2,i3,i4 + character(len=:),allocatable :: atmp,btmp + + allocate (atlist(nat),source=.false.) +!>-- count stuff + ll = len_trim(line) + ns = 1 + do i = 1,ll + if (line(i:i) .eq. ',') ns = ns+1 + end do + allocate (substr(ns),source=repeat(' ',ll)) +!>-- cut stuff + if (ns > 1) then + j = 1 + k = 1 + do i = 1,ll + if (k == ns) then + substr(k) = lowercase(adjustl(line(j:))) + exit + end if + if (line(i:i) .eq. ',') then + substr(k) = lowercase(adjustl(line(j:i-1))) + k = k+1 + j = i+1 + end if + end do + else + substr(1) = trim(line) + end if +!>--- analyze stuff + do i = 1,ns + atmp = trim(substr(i)) + if (atmp .eq. 'all') then + atlist(:) = .true. + exit + end if + if (index(atmp,'.') .ne. 0) cycle !> exclude floats + l = index(atmp,'-') + if (l .eq. 0) then + read (atmp,*,iostat=io) i1 + !> check if it is an element symbol + if (io /= 0) then + if (len_trim(atmp) > 2) then + if (index(trim(atmp),'heavy') .ne. 0) then !> all heavy atoms + if (present(at)) then + do j = 1,nat + if (at(j) > 1) atlist(j) = .true. + end do + end if + end if + else !> element symbols + k = e2i(atmp) + if (present(at)) then + do j = 1,nat + if (at(j) == k) atlist(j) = .true. + end do + end if + end if + else + atlist(i1) = .true. + end if + else + btmp = atmp(:l-1) + read (btmp,*,iostat=io1) i1 + btmp = atmp(l+1:) + read (btmp,*,iostat=io2) i2 + if (io1 .eq. 0.and.io2 .eq. 0) then + i4 = max(i1,i2) + i3 = min(i1,i2) + do j = 1,nat + if (i3 <= j.and.j <= i4) atlist(j) = .true. + end do + end if + end if + end do + deallocate (substr) + end subroutine get_atlist + +!=========================================================================================! + + subroutine atswp(self,ati,atj) + !******************************** + !* swap atom ati with atj in mol + !******************************** + implicit none + class(coord),intent(inout) :: self + integer,intent(in) :: ati,atj + real(wp) :: xyztmp(3) + integer :: attmp + xyztmp(1:3) = self%xyz(1:3,ati) + attmp = self%at(ati) + self%xyz(1:3,ati) = self%xyz(1:3,atj) + self%at(ati) = self%at(atj) + self%xyz(1:3,atj) = xyztmp(1:3) + self%at(atj) = attmp + end subroutine atswp + +!=========================================================================================! + function sumform(nat,at) result(sumformula) +!************************************************ +!* get sumformula as a string from the AT array +!************************************************ + implicit none + integer,intent(in) :: nat + integer,intent(in) :: at(nat) + character(len=:),allocatable :: sumformula + integer :: sumat(118) + integer :: i + character(len=6) :: str + sumformula = '' + sumat = 0 + do i = 1,nat + sumat(at(i)) = sumat(at(i))+1 + end do + !> carbon always first + if (sumat(6) > 0) then + if (sumat(6) > 1) then + write (str,'(a,i0)') trim(adjustl(i2e(6,'nc'))),sumat(6) + else + str = 'C' + end if + sumformula = trim(sumformula)//trim(str) + end if + do i = 2,118 + if (i == 6) cycle + if (sumat(i) .lt. 1) cycle + if (sumat(i) > 1) then + write (str,'(a,i0)') trim(adjustl(i2e(i,'nc'))),sumat(i) + else + str = trim(i2e(i,'nc')) + end if + sumformula = trim(sumformula)//trim(str) + end do + !> hydrogen always last + if (sumat(1) > 0) then + if (sumat(1) > 1) then + write (str,'(a,i0)') trim(adjustl(i2e(1,'nc'))),sumat(1) + else + str = 'H' + end if + sumformula = trim(sumformula)//trim(str) + end if + return + end function sumform + + function coord_sumform(self) result(sumformula) + implicit none + class(coord) :: self + character(len=:),allocatable :: sumformula + sumformula = sumform(self%nat,self%at) + end function coord_sumform + +!=========================================================================================! +!=========================================================================================! +! end of the module +!=========================================================================================! +!=========================================================================================! +end module molecule_type From 1af40fb590237c16ec0a9aa9ef0b0dd704156b63 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 23 Mar 2026 23:35:46 +0100 Subject: [PATCH 261/374] cntd work on molecule type refactor --- src/molecule/CMakeLists.txt | 4 +- src/molecule/io.f90 | 308 ++--- src/molecule/meson.build | 2 + src/molecule/parameters.f90 | 33 +- src/molecule/type.f90 | 12 +- src/molecule/type_components.f90 | 178 +++ src/molecule/type_ensemble.f90 | 1802 +----------------------------- 7 files changed, 398 insertions(+), 1941 deletions(-) create mode 100644 src/molecule/type_components.f90 diff --git a/src/molecule/CMakeLists.txt b/src/molecule/CMakeLists.txt index a8bfcb63..c6f58777 100644 --- a/src/molecule/CMakeLists.txt +++ b/src/molecule/CMakeLists.txt @@ -17,8 +17,10 @@ set(dir "${CMAKE_CURRENT_SOURCE_DIR}") list(APPEND srcs - "${dir}/parameters" + "${dir}/parameters.f90" "${dir}/io.f90" + "${dir}/type_components.f90" + "${dir}/type_ensemble.f90" "${dir}/type.f90" "${dir}/strucreader.f90" "${dir}/sdfio.f90" diff --git a/src/molecule/io.f90 b/src/molecule/io.f90 index 8a2f692b..95646dc6 100644 --- a/src/molecule/io.f90 +++ b/src/molecule/io.f90 @@ -20,6 +20,7 @@ module molecule_io use iso_c_binding use molecule_parameters + use molecule_type_components !> simple geomerty and vector operations use geo !> element symbols @@ -77,33 +78,10 @@ module molecule_io module procedure wrsdf_channel end interface wrsdf - public :: xyz2coord - public :: coord2xyz - public :: coordline public :: get_atlist public :: sumform - !coord class. contains a single structure in the PDB format. - !coordinates by definition are in Angstroem. - type :: pdbdata - !--- data - integer :: nat = 0 - integer :: frag = 0 - !--- arrays - integer,allocatable :: athet(:) !ATOM (1) or HETATM (2) - character(len=4),allocatable :: pdbat(:) !PDB atom specifier - character(len=3),allocatable :: pdbas(:) !PDB amino acid specifier - integer,allocatable :: pdbfrag(:) !PDB fragment specifier - character(len=1),allocatable :: pdbgrp(:) !PDB group specifier - real(wp),allocatable :: pdbocc(:) !PDB occupancy - real(wp),allocatable :: pdbtf(:) !PDB temperature factor - contains - procedure :: deallocate => deallocate_pdb !clear memory space - procedure :: allocate => allocate_pdb - end type pdbdata - public :: pdbdata - ! ══════════════════════════════════════════════════════════════════════════════ contains !> MODULE PROCEDURES START HERE ! ══════════════════════════════════════════════════════════════════════════════ @@ -247,13 +225,14 @@ end subroutine rdnat ! ────────────────────────────────────────────────────────────────────────────── - subroutine rdcoord(fname,nat,at,xyz,energy) + subroutine rdcoord(fname,nat,at,xyz,energy,ftype) !***************************************************************** !* subroutine rdcoord * !* read in a structure. The format is determined automatically * !* * !* On Input: fname - name of the coord file * !* nat - number of atoms * +!* ftype - coord file type (optional) * !* * !* On Output: at - atom number as integer * !* xyz - coordinates (always in Bohr) * @@ -266,14 +245,18 @@ subroutine rdcoord(fname,nat,at,xyz,energy) integer,intent(inout) :: at(nat) real(wp),intent(inout) :: xyz(3,nat) real(wp),optional :: energy + integer,intent(in),optional :: ftype character(len=256) :: atmp - integer :: ftype + integer :: ftypedum type(pdbdata) :: pdbdummy - !--- determine the file type - call checkcoordtype(fname,ftype) + if (present(ftype)) then + ftypedum = ftype + else + call checkcoordtype(fname,ftypedum) + end if - select case (ftype) + select case (ftypedum) case (coordtype%turbomole) !-- TM coord file, always retruns coords in Bohr call rdtmcoord(fname,nat,at,xyz) case (coordtype%xyz) !-- XYZ file, is Angström, needs conversion @@ -400,18 +383,20 @@ subroutine rdxmol(fname,nat,at,xyz,comment) return end subroutine rdxmol -!============================================================! -!* subroutine rdsdf -!* read a struncture in the .sdf/.mol V2000 style. -!* -!* On Input: fname - name of the coord file -!* nat - number of atoms -!* -!* On Output: at - atom number as integer -!* xyz - coordinates (in Angström) -!* comment - (OPTIONAL) commentary line of the file -!============================================================! +! ────────────────────────────────────────────────────────────────────────────── + subroutine rdsdf(fname,nat,at,xyz,comment) +!*************************************************************** +!* subroutine rdsdf * +!* read a struncture in the .sdf/.mol V2000 style. * +!* * +!* On Input: fname - name of the coord file * +!* nat - number of atoms * +!* * +!* On Output: at - atom number as integer * +!* xyz - coordinates (in Angström) * +!* comment - (OPTIONAL) commentary line of the file * +!*************************************************************** implicit none character(len=*),intent(in) :: fname integer,intent(in) :: nat @@ -446,18 +431,20 @@ subroutine rdsdf(fname,nat,at,xyz,comment) return end subroutine rdsdf -!============================================================! -! subroutine rdsdfV3000 -! read a struncture in the .sdf/.mol V3000 style. -! -! On Input: fname - name of the coord file -! nat - number of atoms -! -! On Output: at - atom number as integer -! xyz - coordinates (in Angström) -! comment - (OPTIONAL) commentary line of the file -!============================================================! +! ────────────────────────────────────────────────────────────────────────────── + subroutine rdsdfV3000(fname,nat,at,xyz,comment) +!*************************************************************** +!* subroutine rdsdfV3000 * +!* read a struncture in the .sdf/.mol V3000 style. * +!* * +!* On Input: fname - name of the coord file * +!* nat - number of atoms * +!* * +!* On Output: at - atom number as integer * +!* xyz - coordinates (in Angström) * +!* comment - (OPTIONAL) commentary line of the file * +!*************************************************************** implicit none character(len=*),intent(in) :: fname integer,intent(in) :: nat @@ -514,18 +501,20 @@ subroutine rdsdfV3000(fname,nat,at,xyz,comment) return end subroutine rdsdfV3000 -!============================================================! -! subroutine rdPDB -! read a struncture in the .PDB style. -! -! On Input: fname - name of the coord file -! nat - number of atoms -! -! On Output: at - atom number as integer -! xyz - coordinates (in Angström) -! pdb - pdbdata object -!============================================================! +! ────────────────────────────────────────────────────────────────────────────── + subroutine rdPDB(fname,nat,at,xyz,pdb) +!*********************************************** +!* subroutine rdPDB * +!* read a struncture in the .PDB style. * +!* * +!* On Input: fname - name of the coord file * +!* nat - number of atoms * +!* * +!* On Output: at - atom number as integer * +!* xyz - coordinates (in Angström) * +!* pdb - pdbdata object * +!*********************************************** implicit none character(len=*),intent(in) :: fname integer,intent(in) :: nat @@ -565,21 +554,22 @@ subroutine rdPDB(fname,nat,at,xyz,pdb) return end subroutine rdPDB -!============================================================! -! subroutine rdxmolselec -! Read a file with multiple structures in the *.xyz (Xmol) style. -! Picks one structure. -! The commentary (second) line is ignored -! -! On Input: fname - name of the coord file -! m - position of the desired structure -! nat - number of atoms -! -! On Output: at - atom number as integer -! xyz - coordinates (in Bohr) -!============================================================! +! ────────────────────────────────────────────────────────────────────────────── subroutine rdxmolselec(fname,m,nat,at,xyz,comment) +!******************************************************************* +!* subroutine rdxmolselec * +!* Read a file with multiple structures in the *.xyz (Xmol) style. * +!* Picks one structure. * +!* The commentary (second) line is ignored * +!* * +!* On Input: fname - name of the coord file * +!* m - position of the desired structure * +!* nat - number of atoms * +!* * +!* On Output: at - atom number as integer * +!* xyz - coordinates (in Bohr) * +!******************************************************************* implicit none character(len=*),intent(in) :: fname integer,intent(in) :: nat,m @@ -815,8 +805,10 @@ subroutine wrxyz_channel_energy(ch,nat,at,xyz,er) real(wp) :: er integer :: i,j,k,ich,io logical :: ex + character(len=30) :: etmp write (ch,'(2x,i0)') nat - write (ch,'(2x,a,f18.8)') "energy=",er + write (etmp,'(f20.10)') er + write (ch,'(2x,a,a)') "energy=",adjustl(etmp) do j = 1,nat write (ch,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) end do @@ -1077,36 +1069,6 @@ function convertlable(s) call move_alloc(sout,convertlable) end function convertlable -!=============================================================! - pure elemental integer function ncore(at) - integer,intent(in) :: at - if (at .le. 2) then - ncore = 0 - elseif (at .le. 10) then - ncore = 2 - elseif (at .le. 18) then - ncore = 10 - elseif (at .le. 29) then !zn - ncore = 18 - elseif (at .le. 36) then - ncore = 28 - elseif (at .le. 47) then - ncore = 36 - elseif (at .le. 54) then - ncore = 46 - elseif (at .le. 71) then - ncore = 54 - elseif (at .le. 79) then - ncore = 68 - elseif (at .le. 86) then - ncore = 78 - elseif (at .le. 103) then !> Rn core - ncore = 86 - elseif (at .le. 118) then !> Og core - ncore = 102 - end if - end function ncore - !============================================================! ! e2i is used to map the element (as a string) to integer !============================================================! @@ -1252,6 +1214,102 @@ function grepenergy(line) return end function grepenergy +! ────────────────────────────────────────────────────────────────────────────── + + subroutine get_extxyz_value(comment_line,key,value,found) +!************************************************************************* +!* subroutine get_extxyz_value * +!* grep a key-value-pair from the comment line of an extended XYZ file * +!* On input: * +!* comment_line - the comment line * +!* key - the key to look for (case INSENSITIVE) * +!* * +!* On output: * +!* value - the value as raw string * +!* found - success logical, did we find the key? * +!************************************************************************* + implicit none + character(len=*),intent(in) :: comment_line + character(len=*),intent(in) :: key + character(len=*),intent(out) :: value + logical,intent(out) :: found + + integer :: key_start,val_start,val_end,line_len + character(len=:),allocatable :: search_key + + found = .false. + value = "" + line_len = len_trim(comment_line) + + search_key = lowercase(key)//"=" + key_start = index(comment_line,trim(search_key)) + + if (key_start > 0) then + val_start = key_start+len_trim(search_key) + + ! --- Skip any spaces between '=' and the value + do while (val_start <= line_len.and.comment_line(val_start:val_start) == " ") + val_start = val_start+1 + end do + + ! If we hit the end of the line, the key had no value + if (val_start > line_len) return + found = .true. + + ! Check for quotes + if (comment_line(val_start:val_start) == '"'.or. & + comment_line(val_start:val_start) == "'") then + + val_start = val_start+1 + val_end = val_start+index(comment_line(val_start:),comment_line(val_start-1:val_start-1))-2 + else + ! Bare value: find next space + val_end = val_start+index(comment_line(val_start:)," ")-2 + if (val_end < val_start) val_end = line_len + end if + + value = comment_line(val_start:val_end) + end if + end subroutine get_extxyz_value + +! ────────────────────────────────────────────────────────────────────────────── + + function count_extxyz_pairs(comment_line) result(num_pairs) + implicit none + character(len=*),intent(in) :: comment_line + integer :: num_pairs + integer :: i,line_len + logical :: in_quotes + character :: quote_char + + num_pairs = 0 + in_quotes = .false. + line_len = len_trim(comment_line) + quote_char = ' ' + + do i = 1,line_len + ! Check if we are entering or leaving a quoted section + if (.not.in_quotes) then + if (comment_line(i:i) == '"'.or.comment_line(i:i) == "'") then + in_quotes = .true. + quote_char = comment_line(i:i) + end if + else + ! If we are in quotes, look for the matching closing quote + if (comment_line(i:i) == quote_char) then + in_quotes = .false. + end if + end if + + ! If we find an '=' while NOT in quotes, it's a new key-value pair + if (.not.in_quotes.and.comment_line(i:i) == '=') then + num_pairs = num_pairs+1 + end if + end do + end function count_extxyz_pairs + +! ────────────────────────────────────────────────────────────────────────────── + !============================================================! ! count number of bonds from an wbo matrix !============================================================! @@ -1412,46 +1470,6 @@ function sumform(nat,at) result(sumformula) return end function sumform -! ────────────────────────────────────────────────────────────────────────────── -!==================================================================! -! subroutine deallocate_pdb -! is used to clear memory for the pdbdata type -!==================================================================! - subroutine deallocate_pdb(self) - implicit none - class(pdbdata) :: self - self%nat = 0 - self%frag = 0 - if (allocated(self%athet)) deallocate (self%athet) - if (allocated(self%pdbat)) deallocate (self%pdbat) - if (allocated(self%pdbas)) deallocate (self%pdbas) - if (allocated(self%pdbfrag)) deallocate (self%pdbfrag) - if (allocated(self%pdbgrp)) deallocate (self%pdbgrp) - if (allocated(self%pdbocc)) deallocate (self%pdbocc) - if (allocated(self%pdbtf)) deallocate (self%pdbtf) - return - end subroutine deallocate_pdb - -!==================================================================! -! subroutine allocate_pdb -! is used to clear memory for the pdbdata type -!==================================================================! - subroutine allocate_pdb(self,nat) - implicit none - class(pdbdata) :: self - integer :: nat - call deallocate_pdb(self) - self%nat = nat - allocate (self%athet(nat)) - allocate (self%pdbat(nat)) - allocate (self%pdbas(nat)) - allocate (self%pdbfrag(nat)) - allocate (self%pdbgrp(nat)) - allocate (self%pdbocc(nat)) - allocate (self%pdbtf(nat)) - return - end subroutine allocate_pdb - ! ══════════════════════════════════════════════════════════════════════════════ ! end of the module ! ══════════════════════════════════════════════════════════════════════════════ diff --git a/src/molecule/meson.build b/src/molecule/meson.build index 008d8e00..1dda1316 100644 --- a/src/molecule/meson.build +++ b/src/molecule/meson.build @@ -18,6 +18,8 @@ srcs += files( 'parameters.f90', 'type.f90', 'io.f90', + 'type_components.f90', + 'type_ensemble.f90', 'strucreader.f90', 'sdfio.f90', ) diff --git a/src/molecule/parameters.f90 b/src/molecule/parameters.f90 index 6dc2427e..7a35ebff 100644 --- a/src/molecule/parameters.f90 +++ b/src/molecule/parameters.f90 @@ -39,7 +39,7 @@ module molecule_parameters integer :: sdfV3000 = 32 integer :: PDB = 4 end type enum_coordtype - type(enum_jobtype), parameter,public :: coordtype = enum_coordtype() + type(enum_coordtype), parameter,public :: coordtype = enum_coordtype() !> Element symbols character(len=2),parameter :: PSE(118) = [ & @@ -56,8 +56,39 @@ module molecule_parameters & 'Rf','Db','Sg','Bh','Hs','Mt','Ds','Rg','Cn','Nh','Fl','Mc','Lv','Ts','Og' ] !&> + public :: ncore + ! ══════════════════════════════════════════════════════════════════════════════ contains !> MODULE PROCEDURES START HERE ! ══════════════════════════════════════════════════════════════════════════════ + pure elemental integer function ncore(at) + integer,intent(in) :: at + if (at .le. 2) then + ncore = 0 + elseif (at .le. 10) then + ncore = 2 + elseif (at .le. 18) then + ncore = 10 + elseif (at .le. 29) then !zn + ncore = 18 + elseif (at .le. 36) then + ncore = 28 + elseif (at .le. 47) then + ncore = 36 + elseif (at .le. 54) then + ncore = 46 + elseif (at .le. 71) then + ncore = 54 + elseif (at .le. 79) then + ncore = 68 + elseif (at .le. 86) then + ncore = 78 + elseif (at .le. 103) then !> Rn core + ncore = 86 + elseif (at .le. 118) then !> Og core + ncore = 102 + end if + end function ncore + end module molecule_parameters diff --git a/src/molecule/type.f90 b/src/molecule/type.f90 index 85883a04..edbd998c 100644 --- a/src/molecule/type.f90 +++ b/src/molecule/type.f90 @@ -21,6 +21,7 @@ module molecule_type use iso_c_binding use molecule_parameters use molecule_io + use molecule_type_components !> simple geomerty and vector operations use geo !> element symbols @@ -51,6 +52,8 @@ module molecule_type !**************************************! !>-- energy real(wp) :: energy = 0.0_wp + !>-- gradient + real(wp),allocatable :: gradient(:,:) !>-- a comment line character(len=:),allocatable :: comment !>-- "origin" tag @@ -74,6 +77,9 @@ module molecule_type !>-- (optional) PDB data type(pdbdata) :: pdb + !>-- extxyz signature + type(extxyz_signatures),allocatable :: extxyz + contains procedure :: deallocate => deallocate_coord !> clear memory space procedure :: open => opencoord !> read an coord file @@ -138,16 +144,16 @@ subroutine opencoord(self,fname) call self%deallocate() call checkcoordtype(fname,ftype) - call rdnat(fname,nat) + call rdnat(fname,nat,ftype=ftype) if (nat > 0) then en = 0.0_wp allocate (at(nat),xyz(3,nat)) - if (ftype == pdbfile) then + if (ftype == coordtype%PDB) then call rdPDB(fname,nat,at,xyz,self%pdb) xyz = xyz/bohr else - call rdcoord(fname,nat,at,xyz,energy=en) + call rdcoord(fname,nat,at,xyz,energy=en,ftype=ftype) end if self%nat = nat diff --git a/src/molecule/type_components.f90 b/src/molecule/type_components.f90 new file mode 100644 index 00000000..e6e7b33b --- /dev/null +++ b/src/molecule/type_components.f90 @@ -0,0 +1,178 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2026 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module molecule_type_components + use iso_c_binding + use molecule_parameters + implicit none + private +! ══════════════════════════════════════════════════════════════════════════════ + + !coord class. contains a single structure in the PDB format. + !coordinates by definition are in Angstroem. + type :: pdbdata + !--- data + integer :: nat = 0 + integer :: frag = 0 + !--- arrays + integer,allocatable :: athet(:) !ATOM (1) or HETATM (2) + character(len=4),allocatable :: pdbat(:) !PDB atom specifier + character(len=3),allocatable :: pdbas(:) !PDB amino acid specifier + integer,allocatable :: pdbfrag(:) !PDB fragment specifier + character(len=1),allocatable :: pdbgrp(:) !PDB group specifier + real(wp),allocatable :: pdbocc(:) !PDB occupancy + real(wp),allocatable :: pdbtf(:) !PDB temperature factor + contains + procedure :: deallocate => deallocate_pdb !clear memory space + procedure :: allocate => allocate_pdb + end type pdbdata + public :: pdbdata + +! ────────────────────────────────────────────────────────────────────────────── + + public :: signature,extxyz_signatures,parse_properties_tag + + ! Type representing a single property entry (e.g., pos:R:3) + type :: signature + character(len=32) :: name ! Property name (e.g., "forces") + character :: p_type ! 'R' for Real, 'S' for String, 'I' for Int + integer :: n_fields ! Number of columns (e.g., 3 for positions) + end type signature + + ! Type representing the collection of all properties in the file + type :: extxyz_signatures + type(signature),allocatable :: props(:) + integer :: n_props ! Number of unique property keys + integer :: total_fields ! Total sum of all n_fields (total columns) + end type extxyz_signatures + +! ══════════════════════════════════════════════════════════════════════════════ +contains !> MODULE PROCEDURES START HERE +! ══════════════════════════════════════════════════════════════════════════════ + +!==================================================================! +! subroutine deallocate_pdb +! is used to clear memory for the pdbdata type +!==================================================================! + subroutine deallocate_pdb(self) + implicit none + class(pdbdata) :: self + self%nat = 0 + self%frag = 0 + if (allocated(self%athet)) deallocate (self%athet) + if (allocated(self%pdbat)) deallocate (self%pdbat) + if (allocated(self%pdbas)) deallocate (self%pdbas) + if (allocated(self%pdbfrag)) deallocate (self%pdbfrag) + if (allocated(self%pdbgrp)) deallocate (self%pdbgrp) + if (allocated(self%pdbocc)) deallocate (self%pdbocc) + if (allocated(self%pdbtf)) deallocate (self%pdbtf) + return + end subroutine deallocate_pdb + +!==================================================================! +! subroutine allocate_pdb +! is used to clear memory for the pdbdata type +!==================================================================! + subroutine allocate_pdb(self,nat) + implicit none + class(pdbdata) :: self + integer :: nat + call deallocate_pdb(self) + self%nat = nat + allocate (self%athet(nat)) + allocate (self%pdbat(nat)) + allocate (self%pdbas(nat)) + allocate (self%pdbfrag(nat)) + allocate (self%pdbgrp(nat)) + allocate (self%pdbocc(nat)) + allocate (self%pdbtf(nat)) + return + end subroutine allocate_pdb + +! ────────────────────────────────────────────────────────────────────────────── + + subroutine parse_properties_tag(prop_str,ext_props) +!************************************************************************************* +!* Parses the "Properties" value string from an extXYZ comment line. * +!* Following the ASE (Atomic Simulation Environment) standard, it decomposes * +!* the string (format: "name:type:cols:name:type:cols...") into a structured * +!* array of 'signature' types. * +!* * +!* ARGUMENTS: * +!* prop_str [IN] : The raw string value of the Properties tag. * +!* Example: "species:S:1:pos:R:3:forces:R:3" * +!* ext_props [OUT] : An instance of extxyz_signatures. * +!* - Allocates the 'props' array based on the number of triplets.* +!* - Calculates 'total_fields' for buffer allocation. * +!* * +!* DATA MAPPING: * +!* - name : String label of the property. * +!* - p_type : 'R' (Real), 'S' (String), 'I' (Integer). * +!* - n_fields: Integer representing the number of columns this property spans. * +!* * +!* NOTES: * +!* - This routine assumes the input string is a valid series of triplets. * +!* - It handles both trailing colons and clean endings. * +!************************************************************************************* + character(len=*),intent(in) :: prop_str + type(extxyz_signatures),intent(out) :: ext_props + + integer :: i,start_pos,end_pos,part_count,i_prop + character(len=len_trim(prop_str)) :: buffer + + ! 1. Initial count of colons to determine array size + ! Format is name:type:cols -> 2 colons per property, +1 at the end of parts + part_count = 0 + do i = 1,len_trim(prop_str) + if (prop_str(i:i) == ':') part_count = part_count+1 + end do + + ext_props%n_props = (part_count+1)/3 + allocate (ext_props%props(ext_props%n_props)) + ext_props%total_fields = 0 + + ! 2. Parse the triplets + buffer = trim(prop_str) + start_pos = 1 + + do i_prop = 1,ext_props%n_props + ! Extract Name + end_pos = index(buffer(start_pos:),':')+start_pos-2 + ext_props%props(i_prop)%name = buffer(start_pos:end_pos) + start_pos = end_pos+2 + + ! Extract Type (R/S/I) + ext_props%props(i_prop)%p_type = buffer(start_pos:start_pos) + start_pos = start_pos+2 ! Skip char and following colon + + ! Extract Number of Fields + end_pos = index(buffer(start_pos:),':')+start_pos-2 + if (end_pos < start_pos) end_pos = len_trim(buffer) ! Handle last element + + read (buffer(start_pos:end_pos),*) ext_props%props(i_prop)%n_fields + start_pos = end_pos+2 + + ! Update global counter + ext_props%total_fields = ext_props%total_fields+ext_props%props(i_prop)%n_fields + end do + end subroutine parse_properties_tag + +! ══════════════════════════════════════════════════════════════════════════════ +! ══════════════════════════════════════════════════════════════════════════════ +end module molecule_type_components diff --git a/src/molecule/type_ensemble.f90 b/src/molecule/type_ensemble.f90 index 7f7fccca..eea37f1b 100644 --- a/src/molecule/type_ensemble.f90 +++ b/src/molecule/type_ensemble.f90 @@ -17,16 +17,14 @@ ! along with crest. If not, see . !================================================================================! -module molecule_type +module molecule_type_ensemble use iso_c_binding use molecule_parameters -!> simple geomerty and vector operations - use geo -!> element symbols - use crest_cn_module,only:calculate_cn + use molecule_io + use molecule_type implicit none -!=========================================================================================! +! ══════════════════════════════════════════════════════════════════════════════ !>--- private module variables and parameters private @@ -52,93 +50,10 @@ module molecule_type module procedure wrensemble_coord_channel end interface wrensemble - public :: pdbdata - public :: coord public :: ensemble public :: mollist - public :: coordline - public :: get_atlist - public :: sumform -!=========================================================================================! - !coord class. contains a single structure in the PDB format. - !coordinates by definition are in Angstroem. - type :: pdbdata - - !--- data - integer :: nat = 0 - integer :: frag = 0 - !--- arrays - integer,allocatable :: athet(:) !ATOM (1) or HETATM (2) - character(len=4),allocatable :: pdbat(:) !PDB atom specifier - character(len=3),allocatable :: pdbas(:) !PDB amino acid specifier - integer,allocatable :: pdbfrag(:) !PDB fragment specifier - character(len=1),allocatable :: pdbgrp(:) !PDB group specifier - real(wp),allocatable :: pdbocc(:) !PDB occupancy - real(wp),allocatable :: pdbtf(:) !PDB temperature factor - - contains - procedure :: deallocate => deallocate_pdb !clear memory space - procedure :: allocate => allocate_pdb - - end type pdbdata -!=========================================================================================! - !coord class. contains a single structure - !by convention coordinates are in atomic units (Bohr) for a single structure! - type :: coord - - !********************************************! - !> data that's typically used in coord type -- number of atoms - integer :: nat = 0 - !>-- atom types as integer, dimension will be at(nat) - integer,allocatable :: at(:) - !>-- atomic coordinates, by convention in Bohrs - real(wp),allocatable :: xyz(:,:) - - !**************************************! - !> (optional) data, often not present -- energy - real(wp) :: energy = 0.0_wp - !>-- a comment line - character(len=:),allocatable :: comment - !>-- molecular charge - integer :: chrg = 0 - !>-- multiplicity information - integer :: uhf = 0 - !>-- number of bonds - integer :: nbd = 0 - !>-- bond info - integer,allocatable :: bond(:,:) - !>-- lattice vectors - real(wp),allocatable :: lat(:,:) - - !>-- atomic charges - real(wp),allocatable :: qat(:) - - !>-- (optional) PDB data - type(pdbdata) :: pdb - - contains - procedure :: deallocate => deallocate_coord !> clear memory space - procedure :: open => opencoord !> read an coord file - procedure :: write => writecoord !> write - procedure :: append => appendcoord !> append - procedure :: get => getcoord !> allocate & fill with data - procedure :: appendlog !> append .log file with coordinates and energy - procedure :: dist => coord_getdistance !> calculate distance between two atoms - procedure :: angle => coord_getangle !> calculate angle between three atoms - procedure :: dihedral => coord_getdihedral !> calculate dihedral angle between four atoms - procedure :: cutout => coord_getcutout !> create a substructure - procedure :: get_CN => coord_get_CN !> calculate coordination number - procedure :: get_z => coord_get_z !> calculate nuclear charge - procedure :: cn_to_bond => coord_cn_to_bond !> generate neighbour matrix from CN - procedure :: swap => atswp !> swap two atoms coordinates and their at() entries - procedure :: sumform => coord_sumform !> generate a string with the sum formula - end type coord -!=========================================================================================! +! ────────────────────────────────────────────────────────────────────────────── !> ensemble class. contains all structures of an ensemble !> by convention coordinates are in Angström for an ensemble! type :: ensemble @@ -180,14 +95,11 @@ module molecule_type type(coord),allocatable :: structure(:) end type mollist -!=========================================================================================! -!=========================================================================================! +! ══════════════════════════════════════════════════════════════════════════════ contains !> MODULE PROCEDURES START HERE -!=========================================================================================! -!=========================================================================================! +! ══════════════════════════════════════════════════════════════════════════════ ! 1. ROUTINES FOR READING ENTIRE ENSEMBLES (OR TRAJECTORIES) -!=========================================================================================! -!=========================================================================================! +! ────────────────────────────────────────────────────────────────────────────── !==================================================================! ! subroutine rdensembleparam @@ -760,1699 +672,7 @@ subroutine ensemble_get_mol(self,i,mol) end if end subroutine ensemble_get_mol -!=========================================================================================! -!=========================================================================================! -! 2. ROUTINES FOR READING SINGLE STRUCTURES (COORDS) -!=========================================================================================! -!=========================================================================================! - -!============================================================! -! subroutine checkcoordtype -! try to identify the filetype of the coord type. -! first based on file extension, if that fails by -! a keyword within the file. -!============================================================! - subroutine checkcoordtype(fname,typint) - implicit none - character(len=*) :: fname - integer,intent(out) :: typint - typint = 0 - !-- check file extension first - select case (fextension(fname)) - case ('.coord','.COORD') - typint = tmcoord - case ('.xyz','.XYZ','.trj','.TRJ','.sorted') - typint = xmol - case ('.sd','.sdf','.SDF','.mol','.MOL') - typint = sdf - if (sgrep(fname,'V2000')) then - typint = sdfV2000 - end if - if (sgrep(fname,'V3000')) then - typint = sdfV3000 - end if - case ('.pdb','.PDB') - typint = pdbfile - case default - typint = 0 - end select - if (typint .ne. 0) return !-- file extension was recognized - !-- grep for keywords otherwise - if (sgrep(fname,'$coord')) then - typint = tmcoord - else !--no match found - typint = 0 - end if - return - end subroutine checkcoordtype - -!============================================================! -! subroutine rdnat -! read number of atoms "nat" form file -! -! On Input: fname - name of the coord file -! ftype - (OPTIONAL) format of the input coord file -! if ftype is not present, it is determined -! On Output: nat - number of atoms -!============================================================! - subroutine rdnat(fname,nat,ftype) - implicit none - character(len=*),intent(in) :: fname - integer,intent(out) :: nat - integer,optional :: ftype - integer :: ftypedum - integer :: ich,i,j,io,k - logical :: ex - character(len=256) :: atmp - nat = 0 - inquire (file=fname,exist=ex) - if (.not.ex) then - error stop 'file does not exist.' - end if - if (present(ftype)) then - ftypedum = ftype - else - call checkcoordtype(fname,ftypedum) - end if - open (newunit=ich,file=fname) - select case (ftypedum) - !--- *.xyz files - case (xmol) - read (ich,*,iostat=io) nat - !--- TM coord file - case (tmcoord) - do - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - if (index(atmp,"$coord") .eq. 1) exit - end do - do - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - if (atmp(1:1) == '$') exit - nat = nat+1 - end do - !--- sdf V2000 (or *.mol) file - case (sdfV2000) - do i = 1,3 !-- first three comment lines - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - end do - read (ich,'(a)',iostat=io) atmp - if (index(atmp,'V2000') .ne. 0) then - read (atmp,'(i3)') nat !- first argument is nat - end if - !--- sdf V3000 file - case (sdfV3000) - do - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - if ((index(atmp,'V30') .ne. 0).and. & - & (index(atmp,'COUNTS') .ne. 0)) then - j = index(atmp,'COUNTS')+6 - k = len_trim(atmp) - atmp = atmp(j:k) - atmp = adjustl(atmp) - read (atmp,*) nat - end if - end do - !--- pdb file - case (pdbfile) - !write(*,*) 'PDB file format not supported yet.' - nat = 0 - do - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - if ((index(atmp,'ATOM') .eq. 1).or. & - & (index(atmp,'HETATM') .eq. 1)) then - nat = nat+1 - end if - end do - case default - continue - end select - close (ich) - return - end subroutine rdnat - -!============================================================! -! subroutine rdcoord -! read in a structure. The format is determined automatically -! -! On Input: fname - name of the coord file -! nat - number of atoms -! -! On Output: at - atom number as integer -! xyz - coordinates (always in Bohr) -! energy - (OPTIONAL) if present, try to get energy -! mainly from xyz files -!============================================================! - subroutine rdcoord(fname,nat,at,xyz,energy) - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: nat - integer,intent(inout) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) - real(wp),optional :: energy - character(len=256) :: atmp - integer :: ftype - type(pdbdata) :: pdbdummy - - !--- determine the file type - call checkcoordtype(fname,ftype) - - select case (ftype) - case (tmcoord) !-- TM coord file, always retruns coords in Bohr - call rdtmcoord(fname,nat,at,xyz) - case (xmol) !-- XYZ file, is Angström, needs conversion - if (present(energy)) then - call rdxmol(fname,nat,at,xyz,atmp) - energy = grepenergy(atmp) - else - call rdxmol(fname,nat,at,xyz) - end if - xyz = xyz/bohr - case (sdfV2000) !-- SDF/MOL V2000 file, also Angström - call rdsdf(fname,nat,at,xyz) - xyz = xyz/bohr - case (sdfV3000) !-- SDF V3000 file, Angström - call rdsdfV3000(fname,nat,at,xyz) - xyz = xyz/bohr - case (pdbfile) !-- PDB file, Angström - !error stop 'PDB file format not supported yet.' - call rdPDB(fname,nat,at,xyz,pdbdummy) - xyz = xyz/bohr - call pdbdummy%deallocate() - case default - continue - end select - - return - end subroutine rdcoord - -!============================================================! -! subroutine rdtmcoord -! read a struncture in the TM coord style. -! -! On Input: fname - name of the coord file -! nat - number of atoms -! -! On Output: at - atom number as integer -! xyz - coordinates (always in Bohr) -!============================================================! - subroutine rdtmcoord(fname,nat,at,xyz) - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: nat - integer,intent(inout) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) - character(len=6) :: sym - integer :: ich,io,i - real(wp) :: convert - character(len=256) :: atmp - open (newunit=ich,file=fname) - do - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - if (index(atmp,"$coord") .eq. 1) exit - end do - if(index(atmp,'ang').ne.0)then - !> coord files allow explicit specification in Angström - convert = aatoau - else - convert = 1.0_wp - endif - do i = 1,nat - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - if (atmp(1:1) == '$') exit - call coordline(atmp,sym,xyz(1:3,i),io) - if (io < 0) then - write (*,*) 'error while reading coord line. EOF' - exit - end if - at(i) = e2i(sym) - end do - close (ich) - xyz = xyz*convert - return - end subroutine rdtmcoord - -!============================================================! -! subroutine rdxmol -! read a struncture in the *.xyz (Xmol) style. -! The commentary (second) line is ignored -! -! On Input: fname - name of the coord file -! nat - number of atoms -! -! On Output: at - atom number as integer -! xyz - coordinates (in Angström) -! comment - (OPTIONAL) commentary line of the file -!============================================================! - subroutine rdxmol(fname,nat,at,xyz,comment) - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: nat - integer,intent(inout) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) - character(len=*),optional :: comment - character(len=6) :: sym - integer :: ich,io,i - integer :: dum - character(len=256) :: atmp - open (newunit=ich,file=fname) - read (ich,*,iostat=io) dum - if (nat .ne. dum) then - error stop 'error while reading input coordinates' - end if - read (ich,'(a)') atmp !--commentary line - if (present(comment)) comment = trim(adjustl(atmp)) - do i = 1,nat - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - call coordline(atmp,sym,xyz(1:3,i),io) - if (io < 0) then - write (*,*) 'error while reading coord line. EOF' - exit - end if - at(i) = e2i(sym) - end do - close (ich) - return - end subroutine rdxmol - -!============================================================! -! subroutine rdsdf -! read a struncture in the .sdf/.mol V2000 style. -! -! On Input: fname - name of the coord file -! nat - number of atoms -! -! On Output: at - atom number as integer -! xyz - coordinates (in Angström) -! comment - (OPTIONAL) commentary line of the file -!============================================================! - subroutine rdsdf(fname,nat,at,xyz,comment) - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: nat - integer,intent(inout) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) - character(len=*),optional :: comment - character(len=6) :: sym - integer :: ich,io,i - integer :: dum - character(len=256) :: atmp - open (newunit=ich,file=fname) - read (ich,'(a)',iostat=io) atmp - read (ich,'(a)',iostat=io) atmp - read (ich,'(a)',iostat=io) atmp - if (present(comment)) comment = trim(adjustl(atmp)) - read (ich,'(i3)',iostat=io) dum - if (nat .ne. dum) then - error stop 'error while reading input coordinates' - end if - do i = 1,nat - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - call coordline(atmp,sym,xyz(1:3,i),io) - if (io < 0) then - write (*,*) 'error while reading coord line. EOF' - exit - end if - at(i) = e2i(sym) - end do - close (ich) - return - end subroutine rdsdf - -!============================================================! -! subroutine rdsdfV3000 -! read a struncture in the .sdf/.mol V3000 style. -! -! On Input: fname - name of the coord file -! nat - number of atoms -! -! On Output: at - atom number as integer -! xyz - coordinates (in Angström) -! comment - (OPTIONAL) commentary line of the file -!============================================================! - subroutine rdsdfV3000(fname,nat,at,xyz,comment) - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: nat - integer,intent(inout) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) - character(len=*),optional :: comment - character(len=6) :: sym - integer :: ich,io,i,j,k,l - integer :: dum - character(len=256) :: atmp - character(len=32) :: btmp - open (newunit=ich,file=fname) - read (ich,'(a)',iostat=io) atmp - read (ich,'(a)',iostat=io) atmp - read (ich,'(a)',iostat=io) atmp - if (present(comment)) comment = trim(adjustl(atmp)) - do - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - if ((index(atmp,'V30') .ne. 0).and. & - & (index(atmp,'COUNTS') .ne. 0)) then - j = index(atmp,'COUNTS')+6 - k = len_trim(atmp) - atmp = atmp(j:k) - atmp = adjustl(atmp) - read (atmp,*) dum - end if - if ((index(atmp,'V30') .ne. 0).and. & - & (index(atmp,'ATOM') .ne. 0)) then - exit - end if - end do - if (nat .ne. dum) then - error stop 'error while reading input coordinates' - end if - do i = 1,nat - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - write (btmp,'(i0)') i - l = len_trim(btmp)+1 - j = index(atmp,'V30')+3 - k = len_trim(atmp) - atmp = atmp(j:k) - atmp = adjustl(atmp) - atmp = atmp(l:k) - call coordline(atmp,sym,xyz(1:3,i),io) - if (io < 0) then - write (*,*) 'error while reading coord line. EOF' - exit - end if - at(i) = e2i(sym) - end do - close (ich) - return - end subroutine rdsdfV3000 - -!============================================================! -! subroutine rdPDB -! read a struncture in the .PDB style. -! -! On Input: fname - name of the coord file -! nat - number of atoms -! -! On Output: at - atom number as integer -! xyz - coordinates (in Angström) -! pdb - pdbdata object -!============================================================! - subroutine rdPDB(fname,nat,at,xyz,pdb) - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: nat - integer,intent(inout) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) - type(pdbdata) :: pdb - character(len=2) :: sym - integer :: ich,io,i,j,k - character(len=256) :: atmp - character(len=6) :: dum1 - character(len=1) :: dum2,dum3,pdbgp - character(len=3) :: pdbas - character(len=2) :: dum4 - character(len=4) :: pdbat - real(wp) :: r1,r2 - call pdb%allocate(nat) - open (newunit=ich,file=fname) - k = 0 - do - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - if ((index(atmp,'ATOM') .eq. 1).or. & - & (index(atmp,'HETATM') .eq. 1)) then - k = k+1 - read (atmp,'(A6,I5,1X,A4,A1,A3,1X,A1,I4,A1,3X,3F8.3,2F6.2,10X,A2,A2)') & - & dum1,i,pdbat,dum2,pdbas,pdbgp,j,dum3,xyz(1:3,k),r1,r2,sym,dum4 - at(k) = e2i(sym) - pdb%pdbat(k) = pdbat - pdb%pdbas(k) = pdbas - pdb%pdbgrp(k) = pdbgp - pdb%pdbfrag(k) = j - pdb%pdbocc(k) = r1 - pdb%pdbtf(k) = r2 - end if - end do - close (ich) - return - end subroutine rdPDB - -!============================================================! -! subroutine rdxmolselec -! Read a file with multiple structures in the *.xyz (Xmol) style. -! Picks one structure. -! The commentary (second) line is ignored -! -! On Input: fname - name of the coord file -! m - position of the desired structure -! nat - number of atoms -! -! On Output: at - atom number as integer -! xyz - coordinates (in Bohr) -!============================================================! - - subroutine rdxmolselec(fname,m,nat,at,xyz,comment) - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: nat,m - integer,intent(inout) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) - character(len=*),optional :: comment - character(len=6) :: sym - integer :: ich,io,i,j - integer :: dum - character(len=256) :: atmp - - open (newunit=ich,file=fname) - - do j = 1,m - read (ich,*,iostat=io) dum - if (nat .ne. dum) then - error stop 'error while reading input coordinates' - end if - read (ich,'(a)') atmp !--commentary line - if (present(comment)) comment = trim(adjustl(atmp)) - do i = 1,nat - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - call coordline(atmp,sym,xyz(1:3,i),io) - if (io < 0) then - write (*,*) 'error while reading coord line. EOF' - exit - end if - at(i) = e2i(sym) - end do - end do - close (ich) - xyz = xyz/bohr - return - end subroutine rdxmolselec - -!==================================================================! -! subroutine deallocate_coord -! is used to clear memory for the coord type -!==================================================================! - subroutine deallocate_coord(self) - implicit none - class(coord) :: self - self%nat = 0 - if (allocated(self%at)) deallocate (self%at) - if (allocated(self%xyz)) deallocate (self%xyz) - call self%pdb%deallocate() - return - end subroutine deallocate_coord - -!==================================================================! -! subroutine deallocate_pdb -! is used to clear memory for the pdbdata type -!==================================================================! - subroutine deallocate_pdb(self) - implicit none - class(pdbdata) :: self - self%nat = 0 - self%frag = 0 - if (allocated(self%athet)) deallocate (self%athet) - if (allocated(self%pdbat)) deallocate (self%pdbat) - if (allocated(self%pdbas)) deallocate (self%pdbas) - if (allocated(self%pdbfrag)) deallocate (self%pdbfrag) - if (allocated(self%pdbgrp)) deallocate (self%pdbgrp) - if (allocated(self%pdbocc)) deallocate (self%pdbocc) - if (allocated(self%pdbtf)) deallocate (self%pdbtf) - return - end subroutine deallocate_pdb - -!==================================================================! -! subroutine allocate_pdb -! is used to clear memory for the pdbdata type -!==================================================================! - subroutine allocate_pdb(self,nat) - implicit none - class(pdbdata) :: self - integer :: nat - call deallocate_pdb(self) - self%nat = nat - allocate (self%athet(nat)) - allocate (self%pdbat(nat)) - allocate (self%pdbas(nat)) - allocate (self%pdbfrag(nat)) - allocate (self%pdbgrp(nat)) - allocate (self%pdbocc(nat)) - allocate (self%pdbtf(nat)) - return - end subroutine allocate_pdb - -!==================================================================! -! subroutine opencoord -! is the open procedure for the "coord" class. -!==================================================================! - subroutine opencoord(self,fname) - implicit none - class(coord) :: self - character(len=*),intent(in) :: fname - integer :: nat - integer,allocatable :: at(:) - real(wp),allocatable :: xyz(:,:) - integer :: ftype - integer :: i,j,k,ich,io - logical :: ex - real(wp) :: en - - inquire (file=fname,exist=ex) - if (.not.ex) then - error stop 'coord file does not exist.' - end if - - call self%deallocate() - - call checkcoordtype(fname,ftype) - call rdnat(fname,nat) - - if (nat > 0) then - en = 0.0_wp - allocate (at(nat),xyz(3,nat)) - if (ftype == pdbfile) then - call rdPDB(fname,nat,at,xyz,self%pdb) - xyz = xyz/bohr - else - call rdcoord(fname,nat,at,xyz,energy=en) - end if - - self%nat = nat - self%energy = en - call move_alloc(at,self%at) - call move_alloc(xyz,self%xyz) - else - error stop 'format error while reading coord file.' - end if - - return - end subroutine opencoord -!==================================================================! -! subroutine getcoord -! allocate "coord" class and fill with data -!==================================================================! - subroutine getcoord(self,convfac,nat,at,xyz) - implicit none - class(coord) :: self - real(wp),intent(in) :: convfac - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - real(wp),intent(in) :: xyz(3,nat) - call self%deallocate() - allocate (self%at(nat)) - allocate (self%xyz(3,nat)) - self%nat = nat - self%at = at - self%xyz = xyz/convfac - return - end subroutine getcoord - -!==================================================================! -! function coord_getdistance -! calculate the distance for a given pair of atoms -!==================================================================! - function coord_getdistance(self,a1,a2) result(d) - implicit none - class(coord) :: self - integer,intent(in) :: a1,a2 - real(wp) :: d - d = 0.0_wp - if (allocated(self%xyz)) then - d = (self%xyz(1,a1)-self%xyz(1,a2))**2+ & - & (self%xyz(2,a1)-self%xyz(2,a2))**2+ & - & (self%xyz(3,a1)-self%xyz(3,a2))**2 - d = sqrt(d) - end if - return - end function coord_getdistance - -!==================================================================! -! function coord_getangle -! calculate the angle for a given trio of atoms in rad -! A1-A2-A3 -!==================================================================! - function coord_getangle(self,a1,a2,a3) result(angle) - implicit none - class(coord) :: self - integer,intent(in) :: a1,a2,a3 - real(wp) :: angle,u(3),v(3),o(3) - real(wp) :: d2ij,d2jk,d2ik,xy,temp - angle = 0.0_wp - if (allocated(self%xyz)) then - u(1:3) = self%xyz(1:3,a1)-self%xyz(1:3,a2) - v(1:3) = self%xyz(1:3,a3)-self%xyz(1:3,a2) - angle = tangle(u,v) - end if - return - end function coord_getangle - -!==================================================================! -! function coord_getdihedral -! calculate the dihedral angle for a given quartet of atoms in rad -! A1-A2-A3-A4 -!==================================================================! - function coord_getdihedral(self,a1,a2,a3,a4) result(dihed) - implicit none - class(coord) :: self - integer,intent(in) :: a1,a2,a3,a4 - real(wp) :: dihed - real(wp) :: u(3),v(3),w(3) - real(wp) :: n1(3),n2(3) - real(wp) :: u1(3),u2(3),u3(3) - - dihed = 0.0_wp - if (allocated(self%xyz)) then - - u(1:3) = self%xyz(1:3,a2)-self%xyz(1:3,a1) - v(1:3) = self%xyz(1:3,a3)-self%xyz(1:3,a2) - w(1:3) = self%xyz(1:3,a4)-self%xyz(1:3,a3) - dihed = dihedral(u,v,w) - end if - return - end function coord_getdihedral - -!==================================================================! -! function coord_getgutout -! create a cutout mol object -!==================================================================! - function coord_getcutout(self,atlist) result(molout) - implicit none - class(coord) :: self - logical,intent(in) :: atlist(self%nat) - type(coord) :: molout - integer :: newnat,i,j,k,l - - newnat = count(atlist,1) - if (newnat == self%nat) then - molout = self - else - molout%nat = newnat - allocate (molout%at(newnat),source=0) - allocate (molout%xyz(3,newnat),source=0.0_wp) - k = 0 - do i = 1,self%nat - if (atlist(i)) then - k = k+1 - molout%at(k) = self%at(i) - molout%xyz(1:3,k) = self%xyz(1:3,i) - end if - end do - end if - return - end function coord_getcutout - -!==================================================================! - - subroutine coord_get_CN(self,cn,cn_type,cn_thr,dcndr) - implicit none - class(coord) :: self - real(wp),intent(out),allocatable :: cn(:) - real(wp),intent(in),optional :: cn_thr - character(len=*),intent(in),optional :: cn_type - real(wp),intent(out),optional :: dcndr(3,self%nat,self%nat) - if (self%nat <= 0) return - if (.not.allocated(self%xyz).or..not.allocated(self%at)) return - allocate (cn(self%nat),source=0.0_wp) - call calculate_CN(self%nat,self%at,self%xyz,cn, & - & cntype=cn_type,cnthr=cn_thr,dcndr=dcndr) - end subroutine coord_get_CN - -!==================================================================! - - subroutine coord_get_z(self,z) - implicit none - class(coord) :: self - real(wp),intent(out),allocatable :: z(:) - integer :: i,j,k - if (self%nat <= 0) return - if (.not.allocated(self%xyz).or..not.allocated(self%at)) return - allocate (z(self%nat),source=0.0_wp) - do i = 1,self%nat - z(i) = real(self%at(i),wp)-real(ncore(self%at(i))) - if (self%at(i) > 57.and.self%at(i) < 72) z(i) = 3.0_wp - end do - end subroutine coord_get_z - -!==================================================================! - - subroutine coord_cn_to_bond(self,cn,bond,cn_type,cn_thr) - implicit none - class(coord) :: self - real(wp),intent(out),allocatable :: cn(:) - real(wp),intent(out),allocatable,optional :: bond(:,:) - real(wp),intent(in),optional :: cn_thr - character(len=*),intent(in),optional :: cn_type - if (self%nat <= 0) return - if (.not.allocated(self%xyz).or..not.allocated(self%at)) return - allocate (cn(self%nat),source=0.0_wp) - call calculate_CN(self%nat,self%at,self%xyz,cn, & - & cntype=cn_type,cnthr=cn_thr,bond=bond) - end subroutine coord_cn_to_bond - -!=========================================================================================! -!=========================================================================================! -! 3. ROUTINES FOR WRITING STRUCTURES AND CONVERTING THEM -!=========================================================================================! -!=========================================================================================! - -!============================================================! -! subroutine wrc0_file -! this is the typical quick write routine for TM coord files -! version for writing directly to a new file -! -! On Input: fname - name of the coord file -! nat - number of atoms -! at - atom number as integer -! xyz - coordinates (in Bohr) -! -! On Output: file written to "fname" -!============================================================! - subroutine wrc0_file(fname,nat,at,xyz) - implicit none - character(len=*) :: fname - integer :: nat - integer :: at(nat) - real(wp) :: xyz(3,nat) - integer :: i,j,k,ich,io - logical :: ex - open (newunit=ich,file=fname,status='replace') - write (ich,'(''$coord'')') - do j = 1,nat - write (ich,'(3F24.12,5x,a2)') xyz(1:3,j),i2e(at(j),'lc') - end do - write (ich,'(''$end'')') - close (ich) - return - end subroutine wrc0_file - -!============================================================! -! subroutine wrc0_channel -! this is the typical quick write routine for TM coord files -! version for writing to a output channel -! -! On Input: fname - name of the coord file -! nat - number of atoms -! at - atom number as integer -! xyz - coordinates (in Bohr) -! -! On Output: file written to "fname" -!============================================================! - subroutine wrc0_channel(ch,nat,at,xyz) - implicit none - integer :: ch - integer :: nat - integer :: at(nat) - real(wp) :: xyz(3,nat) - integer :: i,j,k,ich,io - logical :: ex - write (ch,'(''$coord'')') - do j = 1,nat - write (ch,'(3F24.12,5x,a2)') xyz(1:3,j),i2e(at(j),'lc') - end do - write (ch,'(''$end'')') - return - end subroutine wrc0_channel - -!============================================================! -! subroutine wrxyz_file -! this is the typical quick write routine for TM coord files -! version for writing directly to a new file -! -! On Input: fname - name of the coord file -! nat - number of atoms -! at - atom number as integer -! xyz - coordinates (in Angström) -! comment - (OPTIONAL) comment line -! -! On Output: file written to "fname" -!============================================================! - subroutine wrxyz_file(fname,nat,at,xyz,comment) - implicit none - character(len=*) :: fname - integer :: nat - integer :: at(nat) - real(wp) :: xyz(3,nat) - character(len=*),optional :: comment - integer :: i,j,k,ich,io - logical :: ex - open (newunit=ich,file=fname,status='replace') - write (ich,'(2x,i0)') nat - if (present(comment)) then - write (ich,'(a)') trim(comment) - else - write (ich,*) - end if - do j = 1,nat - write (ich,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) - end do - close (ich) - return - end subroutine wrxyz_file - -!============================================================! -! subroutine wrxyz_file_mask -! this is the typical quick write routine for TM coord files -! version for writing directly to a new file -! -! On Input: fname - name of the coord file -! nat - number of atoms -! at - atom number as integer -! xyz - coordinates (in Angström) -! mask - a mask to determine to write which atoms -! comment - (OPTIONAL) comment line -! -! On Output: file written to "fname" -!============================================================! - subroutine wrxyz_file_mask(fname,nat,at,xyz,mask,comment) - implicit none - character(len=*) :: fname - integer :: nat - integer :: at(nat) - real(wp) :: xyz(3,nat) - logical :: mask(nat) - integer :: maskednat - character(len=*),optional :: comment - integer :: i,j,k,ich,io - logical :: ex - open (newunit=ich,file=fname,status='replace') - maskednat = count(mask(:)) - write (ich,'(2x,i0)') maskednat - if (present(comment)) then - write (ich,'(a)') trim(comment) - else - write (ich,*) - end if - do j = 1,nat - if (mask(j)) then - write (ich,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) - end if - end do - close (ich) - return - end subroutine wrxyz_file_mask - -!============================================================! -! subroutine wrxyz_channel -! this is the typical quick write routine for xyz files -! version for writing to a output channel -! -! On Input: fname - name of the coord file -! nat - number of atoms -! at - atom number as integer -! xyz - coordinates (in Angström) -! comment - (OPTIONAL) the comment line -! -! On Output: file written to "fname" -!============================================================! - subroutine wrxyz_channel(ch,nat,at,xyz,comment) - implicit none - integer :: ch - integer :: nat - integer :: at(nat) - real(wp) :: xyz(3,nat) - character(len=*),optional :: comment - integer :: i,j,k,ich,io - logical :: ex - write (ch,'(2x,i0)') nat - if (present(comment)) then - write (ch,'(a)') trim(comment) - else - write (ch,*) - end if - do j = 1,nat - write (ch,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) - end do - return - end subroutine wrxyz_channel - -!============================================================! -! subroutine wrxyz_channel -! this is the typical quick write routine for xyz files -! version for writing to a output channel -! -! On Input: fname - name of the coord file -! nat - number of atoms -! at - atom number as integer -! xyz - coordinates (in Angström) -! er - energy -! -! On Output: file written to "fname" -!============================================================! - subroutine wrxyz_channel_energy(ch,nat,at,xyz,er) - implicit none - integer :: ch - integer :: nat - integer :: at(nat) - real(wp) :: xyz(3,nat) - real(wp) :: er - integer :: i,j,k,ich,io - logical :: ex - write (ch,'(2x,i0)') nat - write (ch,'(2x,a,f18.8)') "energy=",er - do j = 1,nat - write (ch,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) - end do - return - end subroutine wrxyz_channel_energy - -!============================================================! -! subroutine wrsdf_channel -! this is the quick write routine for sdf files -! version for writing to a output channel -! -! On Input: fname - name of the coord file -! nat - number of atoms -! at - atom number as integer -! xyz - coordinates (in Angström) -! er - energy -! wbo - bond order matrix -! -! On Output: written to channel "ch" -!============================================================! - subroutine wrsdf_channel(ch,nat,at,xyz,er,chrg,wbo,comment,icharges) - implicit none - integer,intent(in) :: ch - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - real(wp),intent(in) :: xyz(3,nat) - real(wp),intent(in) :: er - integer,intent(in) :: chrg - real(wp),intent(in) :: wbo(nat,nat) - character(len=*),intent(in) :: comment - real(wp),intent(in),optional :: icharges(nat) - character(len=8) :: date - character(len=10) :: time - integer :: list12(12),nbd - integer,parameter :: list4(4) = 0 - integer,parameter :: list8(8) = 0 - character(len=*),parameter :: countsfmt = '(3i3, 8i3, 1x, a5)' - character(len=*),parameter :: atmfmt = '(3f10.4, 1x, a2, 12i3)' - character(len=*),parameter :: bndfmt = '(7i3)' - integer :: i,j,k,ich,io - logical :: ex - - !>--- generate data - call date_and_time(date,time) - nbd = countbonds(nat,wbo) - list12 = 0 - !>--- comment lines - call date_and_time(date,time) - write (ch,'(a)') trim(comment) - write (ch,'(1x,a, 3a2, a4, "3D",1x,a,f18.8,5x)') & - & 'crest',date(5:6),date(7:8),date(3:4),time(:4),'Energy =',er - write (ch,'(a)') - !>--- counts line - write (ch,countsfmt) nat,nbd,list8,999,'V2000' - !>--- atom block - do j = 1,nat - write (ch,atmfmt) xyz(1:3,j),i2e(at(j),'nc'),list12 - end do - !>--- bonds block - do i = 1,nat - do j = i+1,nat - k = nint(wbo(j,i)) - if (k > 0) then - write (ch,bndfmt) i,j,k,list4 - end if - end do - end do - !>--- other - if (present(icharges)) then - do i = 1,nat - if (abs(nint(icharges(i))) /= 0) then - write (ch,'(a, *(i3, 1x, i3, 1x, i3))') "M CHG",1,i,nint(icharges(i)) - end if - end do - else if (chrg .ne. 0) then - write (ch,'(a, *(i3, 1x, i3, 1x, i3))') "M CHG",1,1,chrg - end if - write (ch,'(a)') 'M END' - write (ch,'(a)') '$$$$' - return - end subroutine wrsdf_channel - -!============================================================! -! subroutine wrsdfV3000_channel -! this is the quick write routine for sdf files -! version for writing to a output channel -! -! On Input: fname - name of the coord file -! nat - number of atoms -! at - atom number as integer -! xyz - coordinates (in Angström) -! er - energy -! wbo - bond order matrix -! -! On Output: written to channel "ch" -!============================================================! - subroutine wrsdfV3000_channel(ch,nat,at,xyz,er,chrg,wbo,comment) - implicit none - integer,intent(in) :: ch - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - real(wp),intent(in) :: xyz(3,nat) - real(wp),intent(in) :: er - real(wp),intent(in) :: chrg - real(wp),intent(in) :: wbo(nat,nat) - character(len=*),intent(in),optional :: comment - character(len=8) :: date - character(len=10) :: time - integer :: list12(12),nbd,b - integer,parameter :: list4(4) = 0 - character(len=*),parameter :: countsfmt = '(3i3, 8i3, 1x, a5)' - character(len=*),parameter :: countsfmt2 = '(a,2i3, 3i3)' - character(len=*),parameter :: atmfmt = '(a,1x,i0,1x, a,3f10.4, i2, 11i3)' - character(len=*),parameter :: bndfmt = '(a,1x,i0,1x,7i3)' - integer :: i,j,k,ich,io - logical :: ex - - !>--- generate data - call date_and_time(date,time) - nbd = countbonds(nat,wbo) - !>--- comment lines - call date_and_time(date,time) - if (present(comment)) then - write (ch,'(1x,a)') comment - else - write (ch,'(1x,a)') 'structure written by crest' - end if - write (ch,'(1x,a,f18.8,5x, 3a2, a4, "3D")') & - & 'Energy =',er,date(5:6),date(7:8),date(3:4),time(:4) - write (ch,'(a)') - !>--- counts line - write (ch,countsfmt) nat,nbd,0,0,0,999,'V2000' - write (ch,'("M V30 BEGIN CTAB")') - write (ch,countsfmt2) "M V30 COUNTS",nat,nbd,0,0,0 - !>--- atom block - write (ch,'("M V30 BEGIN ATOM")') - do j = 1,nat - write (ch,atmfmt) 'M V30',j, & - & i2e(at(j),'nc'),xyz(1:3,j),list12 - end do - write (ch,'("M V30 END ATOM")') - !>--- bonds block - write (ch,'("M V30 BEGIN BOND")') - b = 0 - do i = 1,nat - do j = i+1,nat - k = nint(wbo(j,i)) - if (k > 0) then - b = b+1 - write (ch,bndfmt) "M V30",b,i,j,k,list4 - end if - end do - end do - write (ch,'("M V30 END BOND")') - !>--- other - if (chrg .ne. 0) then - write (ch,'(a, *(i3, 1x, i3, 1x, i3))') "M V30 CHG",1,1,chrg - end if - write (ch,'(a)') 'M V30 END CTAB' - write (ch,'(a)') 'M END' - write (ch,'(a)') '$$$$' - return - end subroutine wrsdfV3000_channel - -!============================================================! -! subroutine xyz2coord -! simple conversion of a xyz to a coord file. -! -! On Input: iname - name of the xyz file -! oname - name of the coord file -! -! On Output: file written to "oname" -!============================================================! - subroutine xyz2coord(iname,oname) - implicit none - character(len=*) :: iname - character(len=*) :: oname - type(coord) :: struc - call struc%open(iname) - call wrc0(oname,struc%nat,struc%at,struc%xyz) - call struc%deallocate() - return - end subroutine xyz2coord - -!============================================================! -! subroutine coord2xyz -! simple conversion of a coord to a xyz file. -! -! On Input: iname - name of the coord file -! oname - name of the xyz file -! -! On Output: file written to "oname" -!============================================================! - subroutine coord2xyz(iname,oname) - implicit none - character(len=*) :: iname - character(len=*) :: oname - type(coord) :: struc - call struc%open(trim(iname)) - struc%xyz = struc%xyz*bohr !to Angström - call wrxyz(oname,struc%nat,struc%at,struc%xyz) - call struc%deallocate() - return - end subroutine coord2xyz - -!==================================================================! -! subroutine writecoord -! is the write procedure for the "coord" class. -!==================================================================! - subroutine writecoord(self,fname) - implicit none - class(coord) :: self - character(len=*),intent(in) :: fname - character(len=80) :: comment - if (.not.allocated(self%xyz)) then - write (*,*) 'Cannot write ',trim(fname),'. not allocated' - end if - if (index(fname,'.xyz') .ne. 0) then - write (comment,'(a,G0.12)') ' energy= ',self%energy - self%xyz = self%xyz*bohr !to Angström - call wrxyz(fname,self%nat,self%at,self%xyz,comment) - self%xyz = self%xyz/bohr !back - else - call wrc0(fname,self%nat,self%at,self%xyz) - end if - return - end subroutine writecoord - -!==================================================================! -! subroutine appendcoord -! is the write procedure for the "coord" class. -! coords will be written out in XYZ format! -!==================================================================! - subroutine appendcoord(self,io) - implicit none - class(coord) :: self - integer :: io - character(len=64) :: atmp - character(len=32) :: btmp - self%xyz = self%xyz*bohr !to Angström - write(btmp,'(f22.10)') self%energy - write (atmp,'(a,a)') ' energy= ',adjustl(btmp) - if (allocated(self%comment)) then - call wrxyz(io,self%nat,self%at,self%xyz, & - & trim(atmp)//' '//trim(self%comment)) - else - call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) - end if - self%xyz = self%xyz/bohr !back - return - end subroutine appendcoord - - subroutine appendlog(self,io,energy,gnorm) - implicit none - class(coord) :: self - integer :: io - real(wp),optional :: energy - real(wp),optional :: gnorm - character(len=64) :: atmp - self%xyz = self%xyz*bohr !to Angström - if (present(gnorm).and.present(energy)) then - write (atmp,'(a,f22.10,a,f16.8)') ' energy= ',energy,' grad.norm.= ',gnorm - else if (present(energy)) then - write (atmp,'(a,f22.10)') ' energy= ',energy - else - atmp = '' - end if - call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) - self%xyz = self%xyz/bohr !back - return - end subroutine appendlog - -!=========================================================================================! -!=========================================================================================! -! 4. GENERAL UTILITY ROUTINES -!=========================================================================================! -!=========================================================================================! - -!============================================================! -! read a line of coordinates and determine by itself -! if the format is x,y,z,at or at,x,y,z -!============================================================! - subroutine coordline(line,sym,xyz,io) - implicit none - character(len=*) :: line - character(len=*) :: sym - real(wp) :: xyz(3) - integer,intent(out) :: io - - io = 0 - read (line,*,iostat=io) xyz(1:3),sym - if (io .ne. 0) then - read (line,*,iostat=io) sym,xyz(1:3) - !if(io.ne.0)then - ! error stop 'error while reading coord line' - !endif - end if - - return - end subroutine coordline - -!============================================================! -! convert a string into uppercase -!============================================================! - function upperCase(s) - implicit none - character(len=*),intent(in) :: s - character(len=:),allocatable :: sout - character(len=:),allocatable :: upperCase - integer :: ic,i - character(26),Parameter :: high = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - character(26),Parameter :: low = 'abcdefghijklmnopqrstuvwxyz' - sout = s - do i = 1,LEN_TRIM(s) - ic = INDEX(low,s(i:i)) - if (ic > 0) sout(i:i) = high(ic:ic) - end do - call move_alloc(sout,upperCase) - end function upperCase - -!============================================================! -! convert a string into lowercase -!============================================================! - function lowerCase(s) - implicit none - character(len=*),intent(in) :: s - character(len=:),allocatable :: sout - character(len=:),allocatable :: lowerCase - integer :: ic,i - character(26),Parameter :: high = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - character(26),Parameter :: low = 'abcdefghijklmnopqrstuvwxyz' - sout = s - do i = 1,LEN_TRIM(s) - ic = INDEX(high,s(i:i)) - if (ic > 0) sout(i:i) = low(ic:ic) - end do - call move_alloc(sout,lowerCase) - end function lowerCase - -!============================================================! -! split element lable if some isotope indicator was given -! and convert to uppercase -!============================================================! - function convertlable(s) - implicit none - character(len=*),intent(in) :: s - character(len=:),allocatable :: sout - character(len=:),allocatable :: convertlable - integer :: ic,i - character(14),parameter :: lab = '0123456789*_+-' - character(26),parameter :: high = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - character(26),parameter :: low = 'abcdefghijklmnopqrstuvwxyz' - sout = s - do i = 1,len_trim(s) - ic = index(lab,s(i:i)) - if (ic > 0) sout(i:i) = ' ' - ic = index(low,s(i:i)) - if (ic > 0) sout(i:i) = high(ic:ic) - end do - sout = trim(adjustl(sout)) - if (len_trim(sout) .gt. 1) then - sout(2:2) = lowerCase(sout(2:2)) - else - sout = sout//' ' - end if - call move_alloc(sout,convertlable) - end function convertlable - -!=============================================================! - pure elemental integer function ncore(at) - integer,intent(in) :: at - if (at .le. 2) then - ncore = 0 - elseif (at .le. 10) then - ncore = 2 - elseif (at .le. 18) then - ncore = 10 - elseif (at .le. 29) then !zn - ncore = 18 - elseif (at .le. 36) then - ncore = 28 - elseif (at .le. 47) then - ncore = 36 - elseif (at .le. 54) then - ncore = 46 - elseif (at .le. 71) then - ncore = 54 - elseif (at .le. 79) then - ncore = 68 - elseif (at .le. 86) then - ncore = 78 - end if - end function ncore - -!============================================================! -! e2i is used to map the element (as a string) to integer -!============================================================! - integer function e2i(cin) - implicit none - character(len=*),intent(in) :: cin - character(len=:),allocatable :: c - integer :: iout - integer :: i,j,k,ich,io,Z - logical :: ex - c = trim(convertlable(cin)) - read (cin,*,iostat=io) j - if (io == 0) Z = j - if (any(PSE(:) .eq. c)) then - do i = 1,118 - if (trim(PSE(i)) .eq. c) then - iout = i - exit - end if - end do - else if (io == 0.and.Z <= 118) then - iout = Z - else !> special cases - select case (trim(c)) - case ('D'); iout = 1 - case ('T'); iout = 1 - case default; iout = 0 - end select - end if - e2i = iout - end function e2i - -!============================================================! -! i2e is used to map the element (as a integer) to a string -!============================================================! - character(len=2) function i2e(iin,oformat) - implicit none - integer,intent(in) :: iin - character(len=:),allocatable :: c - character(len=*),optional :: oformat - if (iin <= 118) then - c = uppercase(PSE(iin)) - else - c = 'XX' - end if - i2e = trim(c) - if (present(oformat)) then - select case (oformat) - case ('lc','lowercase') - i2e = lowerCase(trim(c)) - case ('nc','nicecase') - if (len_trim(c) .gt. 1) then - c(2:2) = lowerCase(c(2:2)) - i2e = trim(c) - end if - case default - continue - end select - end if - end function i2e - -!============================================================! -! get the file extension -!============================================================! - function fextension(s) - implicit none - character(len=*),intent(in) :: s !filename - character(len=:),allocatable :: sout - character(len=:),allocatable :: fextension !output - integer :: ic,i - sout = trim(adjustl(s)) - i = len_trim(sout) - ic = index(sout,'.',.true.) - if (ic .ne. 0) then - fextension = sout(ic:i) - else - fextension = 'none' - end if - return - end function fextension - -!============================================================! -! grep for a keyword within the file -!============================================================! - function sgrep(fname,key) - implicit none - character(len=*),intent(in) :: fname - character(len=*),intent(in) :: key - logical :: sgrep - character(len=256) :: atmp - integer :: ic,io - sgrep = .false. - open (newunit=ic,file=fname) - do - read (ic,'(a)',iostat=io) atmp - if (io < 0) exit !EOF - if (index(atmp,key) .ne. 0) then - sgrep = .true. - exit - end if - end do - close (ic) - return - end function sgrep - -!============================================================! -! grep the energy from a line of strings -!============================================================! - function grepenergy(line) - implicit none - real(wp) :: grepenergy - character(len=*),intent(in) :: line - real(wp) :: energy - character(len=:),allocatable :: atmp - integer :: i,io,k - atmp = trim(line) - energy = 0.0_wp - if (index(atmp,'energy=') .ne. 0) then - k = index(atmp,'energy=') - atmp = atmp(k+7:) - read (atmp,*,iostat=io) energy - if (io .ne. 0) energy = 0.0_wp - else if (index(atmp,'energy:') .ne. 0) then - k = index(atmp,'energy:') - atmp = atmp(k+7:) - read (atmp,*,iostat=io) energy - if (io .ne. 0) energy = 0.0_wp - else - !> assumes that the first float in the line is the energy - do i = 1,len_trim(atmp) - if (len_trim(atmp) .lt. 1) exit - read (atmp,*,iostat=io) energy - if (io > 0) then - atmp = atmp(2:) - atmp = adjustl(atmp) - cycle - else - exit - end if - end do - end if - grepenergy = energy - return - end function grepenergy - -!============================================================! -! count number of bonds from an wbo matrix -!============================================================! - function countbonds(nat,wbo) result(nbd) - implicit none - integer,intent(in) :: nat - real(wp),intent(in) :: wbo(nat,nat) - integer :: nbd - integer :: i,j,k - nbd = 0 - do i = 1,nat - do j = 1,i-1 - k = nint(wbo(i,j)) - if (k > 0) nbd = nbd+1 - end do - end do - return - end function countbonds - -!=========================================================================================! - - subroutine get_atlist(nat,atlist,line,at) -!****************************************************** -!* Analyze a string containing atom specifications. -!* "atlist" is a array of booleans for each atom, -!* which is set to .true. should the atom be contained -!* in atlist. -!****************************************************** - implicit none - integer,intent(in) :: nat - logical,intent(out),allocatable :: atlist(:) - character(len=*),intent(in) :: line - integer,intent(in),optional :: at(nat) - character(len=:),allocatable :: substr(:) - integer :: i,j,k,l,io,ns,ll,i1,i2,io1,io2,i3,i4 - character(len=:),allocatable :: atmp,btmp - - allocate (atlist(nat),source=.false.) -!>-- count stuff - ll = len_trim(line) - ns = 1 - do i = 1,ll - if (line(i:i) .eq. ',') ns = ns+1 - end do - allocate (substr(ns),source=repeat(' ',ll)) -!>-- cut stuff - if (ns > 1) then - j = 1 - k = 1 - do i = 1,ll - if (k == ns) then - substr(k) = lowercase(adjustl(line(j:))) - exit - end if - if (line(i:i) .eq. ',') then - substr(k) = lowercase(adjustl(line(j:i-1))) - k = k+1 - j = i+1 - end if - end do - else - substr(1) = trim(line) - end if -!>--- analyze stuff - do i = 1,ns - atmp = trim(substr(i)) - if (atmp .eq. 'all') then - atlist(:) = .true. - exit - end if - if (index(atmp,'.') .ne. 0) cycle !> exclude floats - l = index(atmp,'-') - if (l .eq. 0) then - read (atmp,*,iostat=io) i1 - !> check if it is an element symbol - if (io /= 0) then - if (len_trim(atmp) > 2) then - if (index(trim(atmp),'heavy') .ne. 0) then !> all heavy atoms - if (present(at)) then - do j = 1,nat - if (at(j) > 1) atlist(j) = .true. - end do - end if - end if - else !> element symbols - k = e2i(atmp) - if (present(at)) then - do j = 1,nat - if (at(j) == k) atlist(j) = .true. - end do - end if - end if - else - atlist(i1) = .true. - end if - else - btmp = atmp(:l-1) - read (btmp,*,iostat=io1) i1 - btmp = atmp(l+1:) - read (btmp,*,iostat=io2) i2 - if (io1 .eq. 0.and.io2 .eq. 0) then - i4 = max(i1,i2) - i3 = min(i1,i2) - do j = 1,nat - if (i3 <= j.and.j <= i4) atlist(j) = .true. - end do - end if - end if - end do - deallocate (substr) - end subroutine get_atlist - -!=========================================================================================! - - subroutine atswp(self,ati,atj) - !******************************** - !* swap atom ati with atj in mol - !******************************** - implicit none - class(coord),intent(inout) :: self - integer,intent(in) :: ati,atj - real(wp) :: xyztmp(3) - integer :: attmp - xyztmp(1:3) = self%xyz(1:3,ati) - attmp = self%at(ati) - self%xyz(1:3,ati) = self%xyz(1:3,atj) - self%at(ati) = self%at(atj) - self%xyz(1:3,atj) = xyztmp(1:3) - self%at(atj) = attmp - end subroutine atswp - -!=========================================================================================! - function sumform(nat,at) result(sumformula) -!************************************************ -!* get sumformula as a string from the AT array -!************************************************ - implicit none - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - character(len=:),allocatable :: sumformula - integer :: sumat(118) - integer :: i - character(len=6) :: str - sumformula = '' - sumat = 0 - do i = 1,nat - sumat(at(i)) = sumat(at(i))+1 - end do - !> carbon always first - if (sumat(6) > 0) then - if (sumat(6) > 1) then - write (str,'(a,i0)') trim(adjustl(i2e(6,'nc'))),sumat(6) - else - str = 'C' - end if - sumformula = trim(sumformula)//trim(str) - end if - do i = 2,118 - if (i == 6) cycle - if (sumat(i) .lt. 1) cycle - if (sumat(i) > 1) then - write (str,'(a,i0)') trim(adjustl(i2e(i,'nc'))),sumat(i) - else - str = trim(i2e(i,'nc')) - end if - sumformula = trim(sumformula)//trim(str) - end do - !> hydrogen always last - if (sumat(1) > 0) then - if (sumat(1) > 1) then - write (str,'(a,i0)') trim(adjustl(i2e(1,'nc'))),sumat(1) - else - str = 'H' - end if - sumformula = trim(sumformula)//trim(str) - end if - return - end function sumform - - function coord_sumform(self) result(sumformula) - implicit none - class(coord) :: self - character(len=:),allocatable :: sumformula - sumformula = sumform(self%nat,self%at) - end function coord_sumform -!=========================================================================================! -!=========================================================================================! -! end of the module -!=========================================================================================! -!=========================================================================================! -end module molecule_type +! ══════════════════════════════════════════════════════════════════════════════ +! ══════════════════════════════════════════════════════════════════════════════ +end module molecule_type_ensemble From ae3e34679cbf2e29ae909d1c2cac008f8f4c4435 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 23 Mar 2026 23:45:51 +0100 Subject: [PATCH 262/374] Re-export types --- src/molecule/strucreader.f90 | 2478 +--------------------------------- src/molecule/type.f90 | 5 +- 2 files changed, 13 insertions(+), 2470 deletions(-) diff --git a/src/molecule/strucreader.f90 b/src/molecule/strucreader.f90 index 48e1f21a..83a9898a 100644 --- a/src/molecule/strucreader.f90 +++ b/src/molecule/strucreader.f90 @@ -35,2505 +35,47 @@ ! !=========================================================================================! module strucrd - use iso_fortran_env,only:wp => real64 - use iso_c_binding -!> simple geomerty and vector operations - use geo -!> element symbols - use miscdata,only:PSE - use crest_cn_module,only:calculate_cn + use molecule_type + use molecule_type_components + use molecule_type_ensemble + use molecule_io implicit none - -!=========================================================================================! -!>--- private module variables and parameters private - -!>--- some constants and name mappings - real(wp),parameter :: bohr = 0.52917726_wp - real(wp),parameter :: aatoau = 1.0_wp/bohr - real(wp),parameter :: autokcal = 627.509541_wp -!>-- filetypes as integers - integer,parameter :: tmcoord = 1 - integer,parameter :: xmol = 2 - integer,parameter :: sdf = 3 !currently unused - integer,parameter :: sdfV2000 = 31 - integer,parameter :: sdfV3000 = 32 - integer,parameter :: pdbfile = 4 !currently unused - ! [...] - -!>--- private utility subroutines - private :: upperCase,lowerCase - private :: convertlable,fextension,sgrep + !> RE-EXPORTS FROM THE ABOVE MODULES +! ══════════════════════════════════════════════════════════════════════════════ + public :: coord !> coord type + public :: ensemble !> ensemble type (sparsely used) + public :: mollist !> list of coord objects !=========================================================================================! -!>--- public subroutines public :: i2e !> function to convert atomic number to element symbol public :: asym !> " - interface asym !> " - module procedure i2e !> " - end interface asym public :: e2i !> function to convert element symbol into atomic number + public :: grepenergy public :: checkcoordtype - public :: rdnat !-- procedure to read number of atoms Nat public :: rdcoord !-- read an input file, determine format automatically public :: rdxmol !-- read a file in the Xmol (.xyz) format specifically public :: rdxmolselec !-- read only a certain structure in Xmol file - !>--- write a TM coord file public :: wrc0 - interface wrc0 - module procedure wrc0_file - module procedure wrc0_channel - end interface wrc0 public :: wrcoord - interface wrcoord - module procedure wrc0_file - module procedure wrc0_channel - end interface wrcoord - - !>--- write a XYZ coord file public :: wrxyz - interface wrxyz - module procedure wrxyz_file - module procedure wrxyz_file_mask - module procedure wrxyz_channel_energy - module procedure wrxyz_channel - end interface wrxyz - - !>--- write a sdf molfile public :: wrsdf - interface wrsdf - module procedure wrsdf_channel - end interface wrsdf public :: xyz2coord public :: coord2xyz - public :: rdensembleparam !-- read Nat and Nall for a XYZ trajectory public :: rdensemble !-- read a XYZ trajectory - interface rdensemble - module procedure rdensemble_conf1 - module procedure rdensemble_conf2 - module procedure rdensemble_conf3 - - module procedure rdensemble_mixed2 - - module procedure rdensemble_coord_type - end interface rdensemble - public :: wrensemble - interface wrensemble - module procedure wrensemble_conf - module procedure wrensemble_conf_energy - module procedure wrensemble_conf_energy_comment - - module procedure wrensemble_coord_name - module procedure wrensemble_coord_channel - end interface wrensemble - public :: pdbdata - public :: coord - public :: ensemble - public :: mollist public :: coordline public :: get_atlist public :: sumform -!=========================================================================================! - !coord class. contains a single structure in the PDB format. - !coordinates by definition are in Angstroem. - type :: pdbdata - - !--- data - integer :: nat = 0 - integer :: frag = 0 - !--- arrays - integer,allocatable :: athet(:) !ATOM (1) or HETATM (2) - character(len=4),allocatable :: pdbat(:) !PDB atom specifier - character(len=3),allocatable :: pdbas(:) !PDB amino acid specifier - integer,allocatable :: pdbfrag(:) !PDB fragment specifier - character(len=1),allocatable :: pdbgrp(:) !PDB group specifier - real(wp),allocatable :: pdbocc(:) !PDB occupancy - real(wp),allocatable :: pdbtf(:) !PDB temperature factor - - contains - procedure :: deallocate => deallocate_pdb !clear memory space - procedure :: allocate => allocate_pdb - - end type pdbdata -!=========================================================================================! - !coord class. contains a single structure - !by convention coordinates are in atomic units (Bohr) for a single structure! - type :: coord - - !********************************************! - !> data that's typically used in coord type -- number of atoms - integer :: nat = 0 - !>-- atom types as integer, dimension will be at(nat) - integer,allocatable :: at(:) - !>-- atomic coordinates, by convention in Bohrs - real(wp),allocatable :: xyz(:,:) - - !**************************************! - !> (optional) data, often not present -- energy - real(wp) :: energy = 0.0_wp - !>-- a comment line - character(len=:),allocatable :: comment - !>-- molecular charge - integer :: chrg = 0 - !>-- multiplicity information - integer :: uhf = 0 - !>-- number of bonds - integer :: nbd = 0 - !>-- bond info - integer,allocatable :: bond(:,:) - !>-- lattice vectors - real(wp),allocatable :: lat(:,:) - - !>-- atomic charges - real(wp),allocatable :: qat(:) - - !>-- (optional) PDB data - type(pdbdata) :: pdb - - contains - procedure :: deallocate => deallocate_coord !> clear memory space - procedure :: open => opencoord !> read an coord file - procedure :: write => writecoord !> write - procedure :: append => appendcoord !> append - procedure :: get => getcoord !> allocate & fill with data - procedure :: appendlog !> append .log file with coordinates and energy - procedure :: dist => coord_getdistance !> calculate distance between two atoms - procedure :: angle => coord_getangle !> calculate angle between three atoms - procedure :: dihedral => coord_getdihedral !> calculate dihedral angle between four atoms - procedure :: cutout => coord_getcutout !> create a substructure - procedure :: get_CN => coord_get_CN !> calculate coordination number - procedure :: get_z => coord_get_z !> calculate nuclear charge - procedure :: cn_to_bond => coord_cn_to_bond !> generate neighbour matrix from CN - procedure :: swap => atswp !> swap two atoms coordinates and their at() entries - procedure :: sumform => coord_sumform !> generate a string with the sum formula - end type coord -!=========================================================================================! - !> ensemble class. contains all structures of an ensemble - !> by convention coordinates are in Angström for an ensemble! - type :: ensemble - - logical :: mixed = .false. !> if all molecules were the same == .false. - - !> data - integer :: nat = 0 !> (max) number of total atoms - integer :: nall = 0 !> number of structures - - !> if all structures were the same molecule these are filled - !> mixed==.false. - integer,allocatable :: at(:) !> atom types as integer, dimension will be at(nat) - real(wp),allocatable :: xyz(:,:,:) !> coordinates, dimension will be xyz(3,nat,nall) - real(wp),allocatable :: er(:) !> energy of each structure, dimension will be eread(nall) - - !> otherwise this is filled - !> mixed == .true. - type(coord),allocatable :: structures(:) - - real(wp) :: g !gibbs free energy - real(wp) :: s !entropy - real(wp),allocatable :: gt(:) !gibbs free energy of each member - real(wp),allocatable :: ht(:) !enthalpy of each member - real(wp),allocatable :: svib(:) !vibrational entropy of each member - real(wp),allocatable :: srot(:) !rotational entropy of each member - real(wp),allocatable :: stra(:) !translational entropy of each member - - contains - procedure :: deallocate => deallocate_ensembletype !clear memory space - procedure :: open => openensemble !read an ensemble file - procedure :: write => write_ensemble !write to file - procedure :: get_mol => ensemble_get_mol !extract the i-th mol from ensemble type - end type ensemble - -!==========================================================================================! - type :: mollist - integer :: nall = 0 - type(coord),allocatable :: structure(:) - end type mollist - !=========================================================================================! !=========================================================================================! contains !> MODULE PROCEDURES START HERE -!=========================================================================================! -!=========================================================================================! -! 1. ROUTINES FOR READING ENTIRE ENSEMBLES (OR TRAJECTORIES) -!=========================================================================================! -!=========================================================================================! - -!==================================================================! -! subroutine rdensembleparam -! read a ensemble file and get some information from -! it: -! On Input: fname - name of the file, should be in -! the Xmol (*.xyz) format. -! -! On Output: nat - number of atoms -! (if different sized structures are present, -! nat is the largest) -! nall - number of structures -! conform - (optional) do all structures -! have the same number of atoms? -!=================================================================! - subroutine rdensembleparam(fname,nat,nall,conform) - implicit none - character(len=*),intent(in) :: fname - integer,intent(out) :: nat - integer,intent(out) :: nall - logical,intent(out),optional :: conform - logical :: conformdum - integer :: dum,iosum - integer :: natref - real(wp) :: x,y,z - integer :: i,j,k,ich,io - logical :: ex - character(len=10) :: str - conformdum = .true. - nat = 0 - nall = 0 - natref = 0 - inquire (file=fname,exist=ex) - if (.not.ex) return - open (newunit=ich,file=fname) - do - read (ich,*,iostat=io) dum - if (io < 0) exit - if (io > 0) cycle - if (nat == 0) natref = dum - read (ich,*,iostat=io) - if (io < 0) exit - iosum = 0 - do i = 1,dum - read (ich,*,iostat=io) str,x,y,z - if (io < 0) exit - iosum = iosum+io - end do - if (iosum > 0) cycle - nat = max(dum,nat) - if (dum .ne. natref) conformdum = .false. - nall = nall+1 - end do - close (ich) - if (present(conform)) conform = conformdum - return - end subroutine rdensembleparam - -!==================================================================! -! subroutine rdensemble_conf1 -! read a conformer ensemble/a MD trajectory, i.e., -! all structures have the same number and order of atoms. -! version 1 also reads the energy -!=================================================================! - subroutine rdensemble_conf1(fname,nat,nall,at,xyz,eread) - implicit none - character(len=*),intent(in) :: fname - integer,intent(inout) :: nat - integer,intent(inout) :: nall - integer,intent(inout),allocatable :: at(:) - real(wp),intent(inout),allocatable :: xyz(:,:,:) - real(wp),intent(inout),allocatable :: eread(:) - integer :: i,j,k,ich,io - logical :: ex - integer :: dum - character(len=512) :: line - character(len=6) :: sym - if (.not.allocated(xyz).or..not.allocated(at)) then - call rdensembleparam(fname,nat,nall) - end if - if (.not.allocated(xyz)) allocate (xyz(3,nat,nall)) - if (.not.allocated(at)) allocate (at(nat)) - if (.not.allocated(eread)) allocate (eread(nall)) - - eread = 0.0_wp - xyz = 0.0_wp - open (newunit=ich,file=fname) - do i = 1,nall - read (ich,*,iostat=io) dum - if (io < 0) exit - if (io > 0) cycle - if (dum .ne. nat) then - call ensemble_strucskip(ich,nat,io) - if (io < 0) exit - end if - read (ich,'(a)',iostat=io) line - if (io < 0) exit - eread(i) = grepenergy(line) - do j = 1,dum - read (ich,'(a)',iostat=io) line - if (io < 0) exit - call coordline(line,sym,xyz(1:3,j,i),io) - if (io .ne. 0) then - backspace (ich) - exit - end if - at(j) = e2i(sym) - end do - end do - close (ich) - - if (io < 0) then - error stop 'error while reading ensemble file.' - end if - - return - end subroutine rdensemble_conf1 - -!==================================================================! -! subroutine rdensemble_conf2 -! read a conformer ensemble/a MD trajectory, i.e., -! all structures have the same number and order of atoms. -! version 2 does not read the energy -!=================================================================! - subroutine rdensemble_conf2(fname,nat,nall,at,xyz) - implicit none - character(len=*),intent(in) :: fname - integer,intent(inout) :: nat - integer,intent(inout) :: nall - integer,intent(inout),allocatable :: at(:) - real(wp),intent(inout),allocatable :: xyz(:,:,:) - integer :: i,j,k,ich,io - logical :: ex - integer :: dum,nallnew - character(len=512) :: line - character(len=6) :: sym - if (.not.allocated(xyz).or..not.allocated(at)) then - call rdensembleparam(fname,nat,nall) - end if - if (.not.allocated(xyz)) allocate (xyz(3,nat,nall)) - if (.not.allocated(at)) allocate (at(nat)) - io = 0 - xyz = 0.0_wp - open (newunit=ich,file=fname) - do i = 1,nall - read (ich,*,iostat=io) dum - if (io < 0) exit - if (io > 0) cycle - if (dum .ne. nat) then - call ensemble_strucskip(ich,nat,io) - if (io < 0) exit - end if - read (ich,'(a)',iostat=io) line - if (io < 0) exit - do j = 1,dum - read (ich,'(a)',iostat=io) line - if (io < 0) exit - call coordline(line,sym,xyz(1:3,j,i),io) - if (io .ne. 0) then - backspace (ich) - exit - end if - at(j) = e2i(sym) - end do - end do - close (ich) - - if (io < 0) then - error stop 'error while reading ensemble file.' - end if - - return - end subroutine rdensemble_conf2 - -!==================================================================! -! subroutine rdensemble_conf3 -! read a conformer ensemble/a MD trajectory, i.e., -! all structures have the same number and order of atoms. -! version 3 saves the comment line for each structure -!=================================================================! - subroutine rdensemble_conf3(fname,nat,nall,at,xyz,comments) - implicit none - character(len=*),intent(in) :: fname - integer,intent(inout) :: nat - integer,intent(inout) :: nall - integer :: at(nat) - integer,allocatable :: atdum(:) - real(wp) :: xyz(3,nat,nall) - character(len=*) :: comments(nall) - integer :: i,j,k,ich,io - logical :: ex - integer :: dum,nallnew - character(len=512) :: line - character(len=6) :: sym - io = 0 - xyz = 0.0_wp - k = 0 - open (newunit=ich,file=fname) - do i = 1,nall - read (ich,*,iostat=io) dum - if (io < 0) exit - if (io > 0) cycle - if (dum .ne. nat) then - call ensemble_strucskip(ich,nat,io) - if (io < 0) exit - end if - read (ich,'(a)',iostat=io) line - if (io < 0) exit - comments(i) = trim(line) - do j = 1,dum - k = k+1 - read (ich,'(a)',iostat=io) line - if (io < 0) exit - call coordline(line,sym,xyz(1:3,j,i),io) - if (io .ne. 0) then - backspace (ich) - exit - end if - at(j) = e2i(sym) - end do - end do - close (ich) - - if (io < 0) then - error stop 'error while reading ensemble file.' - end if - - return - end subroutine rdensemble_conf3 - - subroutine ensemble_strucskip(ich,nat,io) - implicit none - integer,intent(in) :: ich - integer,intent(in) :: nat - integer,intent(out) :: io - integer :: io2,dum,k - io = 0 - dum = 0 - k = 0 - do while (dum .ne. nat) - read (ich,*,iostat=io) dum - if (io < 0) exit - k = k+1 - if (io > 0) cycle - end do - end subroutine ensemble_strucskip - -!==================================================================! -! subroutine rdensemble_mixed2 -! read an ensemble of mixed strcutres, i.e., all stuctures -! can have a diferent number and order of atoms. -! version 2 does not read energies -!=================================================================! - subroutine rdensemble_mixed2(fname,natmax,nall,nats,ats,xyz,comments) - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: natmax - integer,intent(in) :: nall - integer :: nats(nall) - integer :: ats(natmax,nall) - real(wp) :: xyz(3,natmax,nall) - character(len=*) :: comments(nall) - integer :: i,j,k,ich,io - logical :: ex - integer :: dum - character(len=512) :: line - character(len=6) :: sym - open (newunit=ich,file=fname) - do i = 1,nall - read (ich,*,iostat=io) dum - if (io < 0) exit - if (io > 0) cycle - nats(i) = dum - read (ich,'(a)',iostat=io) line - if (io < 0) exit - comments(i) = trim(line) - do j = 1,dum - read (ich,'(a)',iostat=io) line - if (io < 0) exit - call coordline(line,sym,xyz(1:3,j,i),io) - if (io < 0) exit - ats(j,i) = e2i(sym) - end do - end do - close (ich) - - if (io < 0) then - error stop 'error while reading ensemble file.' - end if - - return - end subroutine rdensemble_mixed2 - -!========================================================================================! - subroutine rdensemble_coord_type(fname,nall,structures) -!********************************************************* -!* subroutine rdensemble_coord_type -!* A variant of the rdensemble routine that automatically -!* produces an array of coord containers -!********************************************************* - implicit none - character(len=*),intent(in) :: fname !> name of the ensemble file - integer,intent(out) :: nall !> number of structures in ensemble - type(coord),intent(out),allocatable :: structures(:) - - real(wp),allocatable :: xyz(:,:,:) - integer :: nat - integer,allocatable :: nats(:) - integer,allocatable :: at(:) - integer,allocatable :: ats(:,:) - real(wp),allocatable :: eread(:) - character(len=512),allocatable :: comments(:) - integer :: i,j,k,ich,io,nat_i - logical :: ex,multiple_sizes - - call rdensembleparam(fname,nat,nall,multiple_sizes) - !>--- multiple sizes - allocate (structures(nall)) - allocate (xyz(3,nat,nall),ats(nat,nall),nats(nall),eread(nall)) - allocate (comments(nall)) - call rdensemble_mixed2(fname,nat,nall,nats,ats,xyz,comments) - !>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<--- Important: coord types must be in Bohrs - xyz = xyz/bohr - !>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<< we check if all the structures in the file - !> are actually the same length (nat), if not we need to - !> take care of this and read into self%structures instead - call rdensembleparam(fname,nat,nall,conform) - self%mixed = .not.conform - - if (conform) then - if (nat > 0.and.nall > 0) then - call self%deallocate() - allocate (at(nat),xyz(3,nat,nall),eread(nall)) - call rdensemble(fname,nat,nall,at,xyz,eread) - - self%nat = nat - self%nall = nall - call move_alloc(at,self%at) - call move_alloc(xyz,self%xyz) - call move_alloc(eread,self%er) - else - error stop 'format error while reading ensemble file.' - end if - else - call rdensemble_coord_type(fname,self%nall,self%structures) - allocate (self%er(nall),source=0.0_wp) - self%er(:) = self%structures(:)%energy - end if - - return - end subroutine openensemble - - subroutine ensemble_get_mol(self,i,mol) - class(ensemble) :: self - integer,intent(in) :: i - class(coord),intent(inout) :: mol - integer :: n - logical :: reinitialize - if (i > self%nall) error stop 'can´t get molecule from ensemble. i>nall' - if (i < 1) error stop 'can´t get molecule from ensemble. i<1' - if (.not.self%mixed) then - n = self%nat - reinitialize = .not. (mol%nat == n) - if (reinitialize) then - mol%nat = n - if (allocated(mol%at)) deallocate (mol%at) - allocate (mol%at(n),source=0) - if (allocated(mol%xyz)) deallocate (mol%xyz) - allocate (mol%xyz(3,n),source=0.0_wp) - end if - mol%energy = self%er(i) - mol%at(:) = self%at(:) - !> Important, ens is in Angström, mol is in Bohrs - mol%xyz(1:3,1:n) = self%xyz(1:3,1:n,i)*aatoau - else !> self%mixed == .true. - n = self%structures(i)%nat - reinitialize = .not. (mol%nat == n) - if (reinitialize) then - if (allocated(mol%at)) deallocate (mol%at) - allocate (mol%at(n),source=0) - if (allocated(mol%xyz)) deallocate (mol%xyz) - allocate (mol%xyz(3,n),source=0.0_wp) - end if - mol%nat = self%structures(i)%nat - mol%at(:) = self%structures(i)%at(:) - mol%xyz(:,:) = self%structures(i)%xyz(:,:) - mol%energy = self%structures(i)%energy - end if - end subroutine ensemble_get_mol - -!=========================================================================================! -!=========================================================================================! -! 2. ROUTINES FOR READING SINGLE STRUCTURES (COORDS) -!=========================================================================================! -!=========================================================================================! - -!============================================================! -! subroutine checkcoordtype -! try to identify the filetype of the coord type. -! first based on file extension, if that fails by -! a keyword within the file. -!============================================================! - subroutine checkcoordtype(fname,typint) - implicit none - character(len=*) :: fname - integer,intent(out) :: typint - typint = 0 - !-- check file extension first - select case (fextension(fname)) - case ('.coord','.COORD') - typint = tmcoord - case ('.xyz','.XYZ','.trj','.TRJ','.sorted') - typint = xmol - case ('.sd','.sdf','.SDF','.mol','.MOL') - typint = sdf - if (sgrep(fname,'V2000')) then - typint = sdfV2000 - end if - if (sgrep(fname,'V3000')) then - typint = sdfV3000 - end if - case ('.pdb','.PDB') - typint = pdbfile - case default - typint = 0 - end select - if (typint .ne. 0) return !-- file extension was recognized - !-- grep for keywords otherwise - if (sgrep(fname,'$coord')) then - typint = tmcoord - else !--no match found - typint = 0 - end if - return - end subroutine checkcoordtype - -!============================================================! -! subroutine rdnat -! read number of atoms "nat" form file -! -! On Input: fname - name of the coord file -! ftype - (OPTIONAL) format of the input coord file -! if ftype is not present, it is determined -! On Output: nat - number of atoms -!============================================================! - subroutine rdnat(fname,nat,ftype) - implicit none - character(len=*),intent(in) :: fname - integer,intent(out) :: nat - integer,optional :: ftype - integer :: ftypedum - integer :: ich,i,j,io,k - logical :: ex - character(len=256) :: atmp - nat = 0 - inquire (file=fname,exist=ex) - if (.not.ex) then - error stop 'file does not exist.' - end if - if (present(ftype)) then - ftypedum = ftype - else - call checkcoordtype(fname,ftypedum) - end if - open (newunit=ich,file=fname) - select case (ftypedum) - !--- *.xyz files - case (xmol) - read (ich,*,iostat=io) nat - !--- TM coord file - case (tmcoord) - do - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - if (index(atmp,"$coord") .eq. 1) exit - end do - do - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - if (atmp(1:1) == '$') exit - nat = nat+1 - end do - !--- sdf V2000 (or *.mol) file - case (sdfV2000) - do i = 1,3 !-- first three comment lines - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - end do - read (ich,'(a)',iostat=io) atmp - if (index(atmp,'V2000') .ne. 0) then - read (atmp,'(i3)') nat !- first argument is nat - end if - !--- sdf V3000 file - case (sdfV3000) - do - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - if ((index(atmp,'V30') .ne. 0).and. & - & (index(atmp,'COUNTS') .ne. 0)) then - j = index(atmp,'COUNTS')+6 - k = len_trim(atmp) - atmp = atmp(j:k) - atmp = adjustl(atmp) - read (atmp,*) nat - end if - end do - !--- pdb file - case (pdbfile) - !write(*,*) 'PDB file format not supported yet.' - nat = 0 - do - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - if ((index(atmp,'ATOM') .eq. 1).or. & - & (index(atmp,'HETATM') .eq. 1)) then - nat = nat+1 - end if - end do - case default - continue - end select - close (ich) - return - end subroutine rdnat - -!============================================================! -! subroutine rdcoord -! read in a structure. The format is determined automatically -! -! On Input: fname - name of the coord file -! nat - number of atoms -! -! On Output: at - atom number as integer -! xyz - coordinates (always in Bohr) -! energy - (OPTIONAL) if present, try to get energy -! mainly from xyz files -!============================================================! - subroutine rdcoord(fname,nat,at,xyz,energy) - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: nat - integer,intent(inout) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) - real(wp),optional :: energy - character(len=256) :: atmp - integer :: ftype - type(pdbdata) :: pdbdummy - - !--- determine the file type - call checkcoordtype(fname,ftype) - - select case (ftype) - case (tmcoord) !-- TM coord file, always retruns coords in Bohr - call rdtmcoord(fname,nat,at,xyz) - case (xmol) !-- XYZ file, is Angström, needs conversion - if (present(energy)) then - call rdxmol(fname,nat,at,xyz,atmp) - energy = grepenergy(atmp) - else - call rdxmol(fname,nat,at,xyz) - end if - xyz = xyz/bohr - case (sdfV2000) !-- SDF/MOL V2000 file, also Angström - call rdsdf(fname,nat,at,xyz) - xyz = xyz/bohr - case (sdfV3000) !-- SDF V3000 file, Angström - call rdsdfV3000(fname,nat,at,xyz) - xyz = xyz/bohr - case (pdbfile) !-- PDB file, Angström - !error stop 'PDB file format not supported yet.' - call rdPDB(fname,nat,at,xyz,pdbdummy) - xyz = xyz/bohr - call pdbdummy%deallocate() - case default - continue - end select - - return - end subroutine rdcoord - -!============================================================! -! subroutine rdtmcoord -! read a struncture in the TM coord style. -! -! On Input: fname - name of the coord file -! nat - number of atoms -! -! On Output: at - atom number as integer -! xyz - coordinates (always in Bohr) -!============================================================! - subroutine rdtmcoord(fname,nat,at,xyz) - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: nat - integer,intent(inout) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) - character(len=6) :: sym - integer :: ich,io,i - real(wp) :: convert - character(len=256) :: atmp - open (newunit=ich,file=fname) - do - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - if (index(atmp,"$coord") .eq. 1) exit - end do - if(index(atmp,'ang').ne.0)then - !> coord files allow explicit specification in Angström - convert = aatoau - else - convert = 1.0_wp - endif - do i = 1,nat - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - if (atmp(1:1) == '$') exit - call coordline(atmp,sym,xyz(1:3,i),io) - if (io < 0) then - write (*,*) 'error while reading coord line. EOF' - exit - end if - at(i) = e2i(sym) - end do - close (ich) - xyz = xyz*convert - return - end subroutine rdtmcoord - -!============================================================! -! subroutine rdxmol -! read a struncture in the *.xyz (Xmol) style. -! The commentary (second) line is ignored -! -! On Input: fname - name of the coord file -! nat - number of atoms -! -! On Output: at - atom number as integer -! xyz - coordinates (in Angström) -! comment - (OPTIONAL) commentary line of the file -!============================================================! - subroutine rdxmol(fname,nat,at,xyz,comment) - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: nat - integer,intent(inout) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) - character(len=*),optional :: comment - character(len=6) :: sym - integer :: ich,io,i - integer :: dum - character(len=256) :: atmp - open (newunit=ich,file=fname) - read (ich,*,iostat=io) dum - if (nat .ne. dum) then - error stop 'error while reading input coordinates' - end if - read (ich,'(a)') atmp !--commentary line - if (present(comment)) comment = trim(adjustl(atmp)) - do i = 1,nat - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - call coordline(atmp,sym,xyz(1:3,i),io) - if (io < 0) then - write (*,*) 'error while reading coord line. EOF' - exit - end if - at(i) = e2i(sym) - end do - close (ich) - return - end subroutine rdxmol - -!============================================================! -! subroutine rdsdf -! read a struncture in the .sdf/.mol V2000 style. -! -! On Input: fname - name of the coord file -! nat - number of atoms -! -! On Output: at - atom number as integer -! xyz - coordinates (in Angström) -! comment - (OPTIONAL) commentary line of the file -!============================================================! - subroutine rdsdf(fname,nat,at,xyz,comment) - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: nat - integer,intent(inout) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) - character(len=*),optional :: comment - character(len=6) :: sym - integer :: ich,io,i - integer :: dum - character(len=256) :: atmp - open (newunit=ich,file=fname) - read (ich,'(a)',iostat=io) atmp - read (ich,'(a)',iostat=io) atmp - read (ich,'(a)',iostat=io) atmp - if (present(comment)) comment = trim(adjustl(atmp)) - read (ich,'(i3)',iostat=io) dum - if (nat .ne. dum) then - error stop 'error while reading input coordinates' - end if - do i = 1,nat - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - call coordline(atmp,sym,xyz(1:3,i),io) - if (io < 0) then - write (*,*) 'error while reading coord line. EOF' - exit - end if - at(i) = e2i(sym) - end do - close (ich) - return - end subroutine rdsdf - -!============================================================! -! subroutine rdsdfV3000 -! read a struncture in the .sdf/.mol V3000 style. -! -! On Input: fname - name of the coord file -! nat - number of atoms -! -! On Output: at - atom number as integer -! xyz - coordinates (in Angström) -! comment - (OPTIONAL) commentary line of the file -!============================================================! - subroutine rdsdfV3000(fname,nat,at,xyz,comment) - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: nat - integer,intent(inout) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) - character(len=*),optional :: comment - character(len=6) :: sym - integer :: ich,io,i,j,k,l - integer :: dum - character(len=256) :: atmp - character(len=32) :: btmp - open (newunit=ich,file=fname) - read (ich,'(a)',iostat=io) atmp - read (ich,'(a)',iostat=io) atmp - read (ich,'(a)',iostat=io) atmp - if (present(comment)) comment = trim(adjustl(atmp)) - do - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - if ((index(atmp,'V30') .ne. 0).and. & - & (index(atmp,'COUNTS') .ne. 0)) then - j = index(atmp,'COUNTS')+6 - k = len_trim(atmp) - atmp = atmp(j:k) - atmp = adjustl(atmp) - read (atmp,*) dum - end if - if ((index(atmp,'V30') .ne. 0).and. & - & (index(atmp,'ATOM') .ne. 0)) then - exit - end if - end do - if (nat .ne. dum) then - error stop 'error while reading input coordinates' - end if - do i = 1,nat - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - write (btmp,'(i0)') i - l = len_trim(btmp)+1 - j = index(atmp,'V30')+3 - k = len_trim(atmp) - atmp = atmp(j:k) - atmp = adjustl(atmp) - atmp = atmp(l:k) - call coordline(atmp,sym,xyz(1:3,i),io) - if (io < 0) then - write (*,*) 'error while reading coord line. EOF' - exit - end if - at(i) = e2i(sym) - end do - close (ich) - return - end subroutine rdsdfV3000 -!============================================================! -! subroutine rdPDB -! read a struncture in the .PDB style. -! -! On Input: fname - name of the coord file -! nat - number of atoms -! -! On Output: at - atom number as integer -! xyz - coordinates (in Angström) -! pdb - pdbdata object -!============================================================! - subroutine rdPDB(fname,nat,at,xyz,pdb) - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: nat - integer,intent(inout) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) - type(pdbdata) :: pdb - character(len=2) :: sym - integer :: ich,io,i,j,k - character(len=256) :: atmp - character(len=6) :: dum1 - character(len=1) :: dum2,dum3,pdbgp - character(len=3) :: pdbas - character(len=2) :: dum4 - character(len=4) :: pdbat - real(wp) :: r1,r2 - call pdb%allocate(nat) - open (newunit=ich,file=fname) - k = 0 - do - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - if ((index(atmp,'ATOM') .eq. 1).or. & - & (index(atmp,'HETATM') .eq. 1)) then - k = k+1 - read (atmp,'(A6,I5,1X,A4,A1,A3,1X,A1,I4,A1,3X,3F8.3,2F6.2,10X,A2,A2)') & - & dum1,i,pdbat,dum2,pdbas,pdbgp,j,dum3,xyz(1:3,k),r1,r2,sym,dum4 - at(k) = e2i(sym) - pdb%pdbat(k) = pdbat - pdb%pdbas(k) = pdbas - pdb%pdbgrp(k) = pdbgp - pdb%pdbfrag(k) = j - pdb%pdbocc(k) = r1 - pdb%pdbtf(k) = r2 - end if - end do - close (ich) - return - end subroutine rdPDB - -!============================================================! -! subroutine rdxmolselec -! Read a file with multiple structures in the *.xyz (Xmol) style. -! Picks one structure. -! The commentary (second) line is ignored -! -! On Input: fname - name of the coord file -! m - position of the desired structure -! nat - number of atoms -! -! On Output: at - atom number as integer -! xyz - coordinates (in Bohr) -!============================================================! - - subroutine rdxmolselec(fname,m,nat,at,xyz,comment) - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: nat,m - integer,intent(inout) :: at(nat) - real(wp),intent(inout) :: xyz(3,nat) - character(len=*),optional :: comment - character(len=6) :: sym - integer :: ich,io,i,j - integer :: dum - character(len=256) :: atmp - - open (newunit=ich,file=fname) - - do j = 1,m - read (ich,*,iostat=io) dum - if (nat .ne. dum) then - error stop 'error while reading input coordinates' - end if - read (ich,'(a)') atmp !--commentary line - if (present(comment)) comment = trim(adjustl(atmp)) - do i = 1,nat - read (ich,'(a)',iostat=io) atmp - if (io < 0) exit - atmp = adjustl(atmp) - call coordline(atmp,sym,xyz(1:3,i),io) - if (io < 0) then - write (*,*) 'error while reading coord line. EOF' - exit - end if - at(i) = e2i(sym) - end do - end do - close (ich) - xyz = xyz/bohr - return - end subroutine rdxmolselec - -!==================================================================! -! subroutine deallocate_coord -! is used to clear memory for the coord type -!==================================================================! - subroutine deallocate_coord(self) - implicit none - class(coord) :: self - self%nat = 0 - if (allocated(self%at)) deallocate (self%at) - if (allocated(self%xyz)) deallocate (self%xyz) - call self%pdb%deallocate() - return - end subroutine deallocate_coord - -!==================================================================! -! subroutine deallocate_pdb -! is used to clear memory for the pdbdata type -!==================================================================! - subroutine deallocate_pdb(self) - implicit none - class(pdbdata) :: self - self%nat = 0 - self%frag = 0 - if (allocated(self%athet)) deallocate (self%athet) - if (allocated(self%pdbat)) deallocate (self%pdbat) - if (allocated(self%pdbas)) deallocate (self%pdbas) - if (allocated(self%pdbfrag)) deallocate (self%pdbfrag) - if (allocated(self%pdbgrp)) deallocate (self%pdbgrp) - if (allocated(self%pdbocc)) deallocate (self%pdbocc) - if (allocated(self%pdbtf)) deallocate (self%pdbtf) - return - end subroutine deallocate_pdb - -!==================================================================! -! subroutine allocate_pdb -! is used to clear memory for the pdbdata type -!==================================================================! - subroutine allocate_pdb(self,nat) - implicit none - class(pdbdata) :: self - integer :: nat - call deallocate_pdb(self) - self%nat = nat - allocate (self%athet(nat)) - allocate (self%pdbat(nat)) - allocate (self%pdbas(nat)) - allocate (self%pdbfrag(nat)) - allocate (self%pdbgrp(nat)) - allocate (self%pdbocc(nat)) - allocate (self%pdbtf(nat)) - return - end subroutine allocate_pdb - -!==================================================================! -! subroutine opencoord -! is the open procedure for the "coord" class. -!==================================================================! - subroutine opencoord(self,fname) - implicit none - class(coord) :: self - character(len=*),intent(in) :: fname - integer :: nat - integer,allocatable :: at(:) - real(wp),allocatable :: xyz(:,:) - integer :: ftype - integer :: i,j,k,ich,io - logical :: ex - real(wp) :: en - - inquire (file=fname,exist=ex) - if (.not.ex) then - error stop 'coord file does not exist.' - end if - - call self%deallocate() - - call checkcoordtype(fname,ftype) - call rdnat(fname,nat) - - if (nat > 0) then - en = 0.0_wp - allocate (at(nat),xyz(3,nat)) - if (ftype == pdbfile) then - call rdPDB(fname,nat,at,xyz,self%pdb) - xyz = xyz/bohr - else - call rdcoord(fname,nat,at,xyz,energy=en) - end if - - self%nat = nat - self%energy = en - call move_alloc(at,self%at) - call move_alloc(xyz,self%xyz) - else - error stop 'format error while reading coord file.' - end if - - return - end subroutine opencoord -!==================================================================! -! subroutine getcoord -! allocate "coord" class and fill with data -!==================================================================! - subroutine getcoord(self,convfac,nat,at,xyz) - implicit none - class(coord) :: self - real(wp),intent(in) :: convfac - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - real(wp),intent(in) :: xyz(3,nat) - call self%deallocate() - allocate (self%at(nat)) - allocate (self%xyz(3,nat)) - self%nat = nat - self%at = at - self%xyz = xyz/convfac - return - end subroutine getcoord - -!==================================================================! -! function coord_getdistance -! calculate the distance for a given pair of atoms -!==================================================================! - function coord_getdistance(self,a1,a2) result(d) - implicit none - class(coord) :: self - integer,intent(in) :: a1,a2 - real(wp) :: d - d = 0.0_wp - if (allocated(self%xyz)) then - d = (self%xyz(1,a1)-self%xyz(1,a2))**2+ & - & (self%xyz(2,a1)-self%xyz(2,a2))**2+ & - & (self%xyz(3,a1)-self%xyz(3,a2))**2 - d = sqrt(d) - end if - return - end function coord_getdistance - -!==================================================================! -! function coord_getangle -! calculate the angle for a given trio of atoms in rad -! A1-A2-A3 -!==================================================================! - function coord_getangle(self,a1,a2,a3) result(angle) - implicit none - class(coord) :: self - integer,intent(in) :: a1,a2,a3 - real(wp) :: angle,u(3),v(3),o(3) - real(wp) :: d2ij,d2jk,d2ik,xy,temp - angle = 0.0_wp - if (allocated(self%xyz)) then - u(1:3) = self%xyz(1:3,a1)-self%xyz(1:3,a2) - v(1:3) = self%xyz(1:3,a3)-self%xyz(1:3,a2) - angle = tangle(u,v) - end if - return - end function coord_getangle - -!==================================================================! -! function coord_getdihedral -! calculate the dihedral angle for a given quartet of atoms in rad -! A1-A2-A3-A4 -!==================================================================! - function coord_getdihedral(self,a1,a2,a3,a4) result(dihed) - implicit none - class(coord) :: self - integer,intent(in) :: a1,a2,a3,a4 - real(wp) :: dihed - real(wp) :: u(3),v(3),w(3) - real(wp) :: n1(3),n2(3) - real(wp) :: u1(3),u2(3),u3(3) - - dihed = 0.0_wp - if (allocated(self%xyz)) then - - u(1:3) = self%xyz(1:3,a2)-self%xyz(1:3,a1) - v(1:3) = self%xyz(1:3,a3)-self%xyz(1:3,a2) - w(1:3) = self%xyz(1:3,a4)-self%xyz(1:3,a3) - dihed = dihedral(u,v,w) - end if - return - end function coord_getdihedral - -!==================================================================! -! function coord_getgutout -! create a cutout mol object -!==================================================================! - function coord_getcutout(self,atlist) result(molout) - implicit none - class(coord) :: self - logical,intent(in) :: atlist(self%nat) - type(coord) :: molout - integer :: newnat,i,j,k,l - - newnat = count(atlist,1) - if (newnat == self%nat) then - molout = self - else - molout%nat = newnat - allocate (molout%at(newnat),source=0) - allocate (molout%xyz(3,newnat),source=0.0_wp) - k = 0 - do i = 1,self%nat - if (atlist(i)) then - k = k+1 - molout%at(k) = self%at(i) - molout%xyz(1:3,k) = self%xyz(1:3,i) - end if - end do - end if - return - end function coord_getcutout - -!==================================================================! - - subroutine coord_get_CN(self,cn,cn_type,cn_thr,dcndr) - implicit none - class(coord) :: self - real(wp),intent(out),allocatable :: cn(:) - real(wp),intent(in),optional :: cn_thr - character(len=*),intent(in),optional :: cn_type - real(wp),intent(out),optional :: dcndr(3,self%nat,self%nat) - if (self%nat <= 0) return - if (.not.allocated(self%xyz).or..not.allocated(self%at)) return - allocate (cn(self%nat),source=0.0_wp) - call calculate_CN(self%nat,self%at,self%xyz,cn, & - & cntype=cn_type,cnthr=cn_thr,dcndr=dcndr) - end subroutine coord_get_CN - -!==================================================================! - - subroutine coord_get_z(self,z) - implicit none - class(coord) :: self - real(wp),intent(out),allocatable :: z(:) - integer :: i,j,k - if (self%nat <= 0) return - if (.not.allocated(self%xyz).or..not.allocated(self%at)) return - allocate (z(self%nat),source=0.0_wp) - do i = 1,self%nat - z(i) = real(self%at(i),wp)-real(ncore(self%at(i))) - if (self%at(i) > 57.and.self%at(i) < 72) z(i) = 3.0_wp - end do - end subroutine coord_get_z - -!==================================================================! - - subroutine coord_cn_to_bond(self,cn,bond,cn_type,cn_thr) - implicit none - class(coord) :: self - real(wp),intent(out),allocatable :: cn(:) - real(wp),intent(out),allocatable,optional :: bond(:,:) - real(wp),intent(in),optional :: cn_thr - character(len=*),intent(in),optional :: cn_type - if (self%nat <= 0) return - if (.not.allocated(self%xyz).or..not.allocated(self%at)) return - allocate (cn(self%nat),source=0.0_wp) - call calculate_CN(self%nat,self%at,self%xyz,cn, & - & cntype=cn_type,cnthr=cn_thr,bond=bond) - end subroutine coord_cn_to_bond - -!=========================================================================================! -!=========================================================================================! -! 3. ROUTINES FOR WRITING STRUCTURES AND CONVERTING THEM -!=========================================================================================! -!=========================================================================================! - -!============================================================! -! subroutine wrc0_file -! this is the typical quick write routine for TM coord files -! version for writing directly to a new file -! -! On Input: fname - name of the coord file -! nat - number of atoms -! at - atom number as integer -! xyz - coordinates (in Bohr) -! -! On Output: file written to "fname" -!============================================================! - subroutine wrc0_file(fname,nat,at,xyz) - implicit none - character(len=*) :: fname - integer :: nat - integer :: at(nat) - real(wp) :: xyz(3,nat) - integer :: i,j,k,ich,io - logical :: ex - open (newunit=ich,file=fname,status='replace') - write (ich,'(''$coord'')') - do j = 1,nat - write (ich,'(3F24.12,5x,a2)') xyz(1:3,j),i2e(at(j),'lc') - end do - write (ich,'(''$end'')') - close (ich) - return - end subroutine wrc0_file - -!============================================================! -! subroutine wrc0_channel -! this is the typical quick write routine for TM coord files -! version for writing to a output channel -! -! On Input: fname - name of the coord file -! nat - number of atoms -! at - atom number as integer -! xyz - coordinates (in Bohr) -! -! On Output: file written to "fname" -!============================================================! - subroutine wrc0_channel(ch,nat,at,xyz) - implicit none - integer :: ch - integer :: nat - integer :: at(nat) - real(wp) :: xyz(3,nat) - integer :: i,j,k,ich,io - logical :: ex - write (ch,'(''$coord'')') - do j = 1,nat - write (ch,'(3F24.12,5x,a2)') xyz(1:3,j),i2e(at(j),'lc') - end do - write (ch,'(''$end'')') - return - end subroutine wrc0_channel - -!============================================================! -! subroutine wrxyz_file -! this is the typical quick write routine for TM coord files -! version for writing directly to a new file -! -! On Input: fname - name of the coord file -! nat - number of atoms -! at - atom number as integer -! xyz - coordinates (in Angström) -! comment - (OPTIONAL) comment line -! -! On Output: file written to "fname" -!============================================================! - subroutine wrxyz_file(fname,nat,at,xyz,comment) - implicit none - character(len=*) :: fname - integer :: nat - integer :: at(nat) - real(wp) :: xyz(3,nat) - character(len=*),optional :: comment - integer :: i,j,k,ich,io - logical :: ex - open (newunit=ich,file=fname,status='replace') - write (ich,'(2x,i0)') nat - if (present(comment)) then - write (ich,'(a)') trim(comment) - else - write (ich,*) - end if - do j = 1,nat - write (ich,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) - end do - close (ich) - return - end subroutine wrxyz_file - -!============================================================! -! subroutine wrxyz_file_mask -! this is the typical quick write routine for TM coord files -! version for writing directly to a new file -! -! On Input: fname - name of the coord file -! nat - number of atoms -! at - atom number as integer -! xyz - coordinates (in Angström) -! mask - a mask to determine to write which atoms -! comment - (OPTIONAL) comment line -! -! On Output: file written to "fname" -!============================================================! - subroutine wrxyz_file_mask(fname,nat,at,xyz,mask,comment) - implicit none - character(len=*) :: fname - integer :: nat - integer :: at(nat) - real(wp) :: xyz(3,nat) - logical :: mask(nat) - integer :: maskednat - character(len=*),optional :: comment - integer :: i,j,k,ich,io - logical :: ex - open (newunit=ich,file=fname,status='replace') - maskednat = count(mask(:)) - write (ich,'(2x,i0)') maskednat - if (present(comment)) then - write (ich,'(a)') trim(comment) - else - write (ich,*) - end if - do j = 1,nat - if (mask(j)) then - write (ich,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) - end if - end do - close (ich) - return - end subroutine wrxyz_file_mask - -!============================================================! -! subroutine wrxyz_channel -! this is the typical quick write routine for xyz files -! version for writing to a output channel -! -! On Input: fname - name of the coord file -! nat - number of atoms -! at - atom number as integer -! xyz - coordinates (in Angström) -! comment - (OPTIONAL) the comment line -! -! On Output: file written to "fname" -!============================================================! - subroutine wrxyz_channel(ch,nat,at,xyz,comment) - implicit none - integer :: ch - integer :: nat - integer :: at(nat) - real(wp) :: xyz(3,nat) - character(len=*),optional :: comment - integer :: i,j,k,ich,io - logical :: ex - write (ch,'(2x,i0)') nat - if (present(comment)) then - write (ch,'(a)') trim(comment) - else - write (ch,*) - end if - do j = 1,nat - write (ch,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) - end do - return - end subroutine wrxyz_channel - -!============================================================! -! subroutine wrxyz_channel -! this is the typical quick write routine for xyz files -! version for writing to a output channel -! -! On Input: fname - name of the coord file -! nat - number of atoms -! at - atom number as integer -! xyz - coordinates (in Angström) -! er - energy -! -! On Output: file written to "fname" -!============================================================! - subroutine wrxyz_channel_energy(ch,nat,at,xyz,er) - implicit none - integer :: ch - integer :: nat - integer :: at(nat) - real(wp) :: xyz(3,nat) - real(wp) :: er - integer :: i,j,k,ich,io - logical :: ex - write (ch,'(2x,i0)') nat - write (ch,'(2x,a,f18.8)') "energy=",er - do j = 1,nat - write (ch,'(1x,a2,1x,3f20.10)') i2e(at(j),'nc'),xyz(1:3,j) - end do - return - end subroutine wrxyz_channel_energy - -!============================================================! -! subroutine wrsdf_channel -! this is the quick write routine for sdf files -! version for writing to a output channel -! -! On Input: fname - name of the coord file -! nat - number of atoms -! at - atom number as integer -! xyz - coordinates (in Angström) -! er - energy -! wbo - bond order matrix -! -! On Output: written to channel "ch" -!============================================================! - subroutine wrsdf_channel(ch,nat,at,xyz,er,chrg,wbo,comment,icharges) - implicit none - integer,intent(in) :: ch - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - real(wp),intent(in) :: xyz(3,nat) - real(wp),intent(in) :: er - integer,intent(in) :: chrg - real(wp),intent(in) :: wbo(nat,nat) - character(len=*),intent(in) :: comment - real(wp),intent(in),optional :: icharges(nat) - character(len=8) :: date - character(len=10) :: time - integer :: list12(12),nbd - integer,parameter :: list4(4) = 0 - integer,parameter :: list8(8) = 0 - character(len=*),parameter :: countsfmt = '(3i3, 8i3, 1x, a5)' - character(len=*),parameter :: atmfmt = '(3f10.4, 1x, a2, 12i3)' - character(len=*),parameter :: bndfmt = '(7i3)' - integer :: i,j,k,ich,io - logical :: ex - - !>--- generate data - call date_and_time(date,time) - nbd = countbonds(nat,wbo) - list12 = 0 - !>--- comment lines - call date_and_time(date,time) - write (ch,'(a)') trim(comment) - write (ch,'(1x,a, 3a2, a4, "3D",1x,a,f18.8,5x)') & - & 'crest',date(5:6),date(7:8),date(3:4),time(:4),'Energy =',er - write (ch,'(a)') - !>--- counts line - write (ch,countsfmt) nat,nbd,list8,999,'V2000' - !>--- atom block - do j = 1,nat - write (ch,atmfmt) xyz(1:3,j),i2e(at(j),'nc'),list12 - end do - !>--- bonds block - do i = 1,nat - do j = i+1,nat - k = nint(wbo(j,i)) - if (k > 0) then - write (ch,bndfmt) i,j,k,list4 - end if - end do - end do - !>--- other - if (present(icharges)) then - do i = 1,nat - if (abs(nint(icharges(i))) /= 0) then - write (ch,'(a, *(i3, 1x, i3, 1x, i3))') "M CHG",1,i,nint(icharges(i)) - end if - end do - else if (chrg .ne. 0) then - write (ch,'(a, *(i3, 1x, i3, 1x, i3))') "M CHG",1,1,chrg - end if - write (ch,'(a)') 'M END' - write (ch,'(a)') '$$$$' - return - end subroutine wrsdf_channel - -!============================================================! -! subroutine wrsdfV3000_channel -! this is the quick write routine for sdf files -! version for writing to a output channel -! -! On Input: fname - name of the coord file -! nat - number of atoms -! at - atom number as integer -! xyz - coordinates (in Angström) -! er - energy -! wbo - bond order matrix -! -! On Output: written to channel "ch" -!============================================================! - subroutine wrsdfV3000_channel(ch,nat,at,xyz,er,chrg,wbo,comment) - implicit none - integer,intent(in) :: ch - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - real(wp),intent(in) :: xyz(3,nat) - real(wp),intent(in) :: er - real(wp),intent(in) :: chrg - real(wp),intent(in) :: wbo(nat,nat) - character(len=*),intent(in),optional :: comment - character(len=8) :: date - character(len=10) :: time - integer :: list12(12),nbd,b - integer,parameter :: list4(4) = 0 - character(len=*),parameter :: countsfmt = '(3i3, 8i3, 1x, a5)' - character(len=*),parameter :: countsfmt2 = '(a,2i3, 3i3)' - character(len=*),parameter :: atmfmt = '(a,1x,i0,1x, a,3f10.4, i2, 11i3)' - character(len=*),parameter :: bndfmt = '(a,1x,i0,1x,7i3)' - integer :: i,j,k,ich,io - logical :: ex - - !>--- generate data - call date_and_time(date,time) - nbd = countbonds(nat,wbo) - !>--- comment lines - call date_and_time(date,time) - if (present(comment)) then - write (ch,'(1x,a)') comment - else - write (ch,'(1x,a)') 'structure written by crest' - end if - write (ch,'(1x,a,f18.8,5x, 3a2, a4, "3D")') & - & 'Energy =',er,date(5:6),date(7:8),date(3:4),time(:4) - write (ch,'(a)') - !>--- counts line - write (ch,countsfmt) nat,nbd,0,0,0,999,'V2000' - write (ch,'("M V30 BEGIN CTAB")') - write (ch,countsfmt2) "M V30 COUNTS",nat,nbd,0,0,0 - !>--- atom block - write (ch,'("M V30 BEGIN ATOM")') - do j = 1,nat - write (ch,atmfmt) 'M V30',j, & - & i2e(at(j),'nc'),xyz(1:3,j),list12 - end do - write (ch,'("M V30 END ATOM")') - !>--- bonds block - write (ch,'("M V30 BEGIN BOND")') - b = 0 - do i = 1,nat - do j = i+1,nat - k = nint(wbo(j,i)) - if (k > 0) then - b = b+1 - write (ch,bndfmt) "M V30",b,i,j,k,list4 - end if - end do - end do - write (ch,'("M V30 END BOND")') - !>--- other - if (chrg .ne. 0) then - write (ch,'(a, *(i3, 1x, i3, 1x, i3))') "M V30 CHG",1,1,chrg - end if - write (ch,'(a)') 'M V30 END CTAB' - write (ch,'(a)') 'M END' - write (ch,'(a)') '$$$$' - return - end subroutine wrsdfV3000_channel - -!============================================================! -! subroutine xyz2coord -! simple conversion of a xyz to a coord file. -! -! On Input: iname - name of the xyz file -! oname - name of the coord file -! -! On Output: file written to "oname" -!============================================================! - subroutine xyz2coord(iname,oname) - implicit none - character(len=*) :: iname - character(len=*) :: oname - type(coord) :: struc - call struc%open(iname) - call wrc0(oname,struc%nat,struc%at,struc%xyz) - call struc%deallocate() - return - end subroutine xyz2coord - -!============================================================! -! subroutine coord2xyz -! simple conversion of a coord to a xyz file. -! -! On Input: iname - name of the coord file -! oname - name of the xyz file -! -! On Output: file written to "oname" -!============================================================! - subroutine coord2xyz(iname,oname) - implicit none - character(len=*) :: iname - character(len=*) :: oname - type(coord) :: struc - call struc%open(trim(iname)) - struc%xyz = struc%xyz*bohr !to Angström - call wrxyz(oname,struc%nat,struc%at,struc%xyz) - call struc%deallocate() - return - end subroutine coord2xyz - -!==================================================================! -! subroutine writecoord -! is the write procedure for the "coord" class. -!==================================================================! - subroutine writecoord(self,fname) - implicit none - class(coord) :: self - character(len=*),intent(in) :: fname - character(len=80) :: comment - if (.not.allocated(self%xyz)) then - write (*,*) 'Cannot write ',trim(fname),'. not allocated' - end if - if (index(fname,'.xyz') .ne. 0) then - write (comment,'(a,G0.12)') ' energy= ',self%energy - self%xyz = self%xyz*bohr !to Angström - call wrxyz(fname,self%nat,self%at,self%xyz,comment) - self%xyz = self%xyz/bohr !back - else - call wrc0(fname,self%nat,self%at,self%xyz) - end if - return - end subroutine writecoord - -!==================================================================! -! subroutine appendcoord -! is the write procedure for the "coord" class. -! coords will be written out in XYZ format! -!==================================================================! - subroutine appendcoord(self,io) - implicit none - class(coord) :: self - integer :: io - character(len=64) :: atmp - character(len=32) :: btmp - self%xyz = self%xyz*bohr !to Angström - write(btmp,'(f22.10)') self%energy - write (atmp,'(a,a)') ' energy= ',adjustl(btmp) - if (allocated(self%comment)) then - call wrxyz(io,self%nat,self%at,self%xyz, & - & trim(atmp)//' '//trim(self%comment)) - else - call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) - end if - self%xyz = self%xyz/bohr !back - return - end subroutine appendcoord - - subroutine appendlog(self,io,energy,gnorm) - implicit none - class(coord) :: self - integer :: io - real(wp),optional :: energy - real(wp),optional :: gnorm - character(len=64) :: atmp - self%xyz = self%xyz*bohr !to Angström - if (present(gnorm).and.present(energy)) then - write (atmp,'(a,f22.10,a,f16.8)') ' energy= ',energy,' grad.norm.= ',gnorm - else if (present(energy)) then - write (atmp,'(a,f22.10)') ' energy= ',energy - else - atmp = '' - end if - call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) - self%xyz = self%xyz/bohr !back - return - end subroutine appendlog - -!=========================================================================================! -!=========================================================================================! -! 4. GENERAL UTILITY ROUTINES -!=========================================================================================! -!=========================================================================================! - -!============================================================! -! read a line of coordinates and determine by itself -! if the format is x,y,z,at or at,x,y,z -!============================================================! - subroutine coordline(line,sym,xyz,io) - implicit none - character(len=*) :: line - character(len=*) :: sym - real(wp) :: xyz(3) - integer,intent(out) :: io - - io = 0 - read (line,*,iostat=io) xyz(1:3),sym - if (io .ne. 0) then - read (line,*,iostat=io) sym,xyz(1:3) - !if(io.ne.0)then - ! error stop 'error while reading coord line' - !endif - end if - - return - end subroutine coordline - -!============================================================! -! convert a string into uppercase -!============================================================! - function upperCase(s) - implicit none - character(len=*),intent(in) :: s - character(len=:),allocatable :: sout - character(len=:),allocatable :: upperCase - integer :: ic,i - character(26),Parameter :: high = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - character(26),Parameter :: low = 'abcdefghijklmnopqrstuvwxyz' - sout = s - do i = 1,LEN_TRIM(s) - ic = INDEX(low,s(i:i)) - if (ic > 0) sout(i:i) = high(ic:ic) - end do - call move_alloc(sout,upperCase) - end function upperCase - -!============================================================! -! convert a string into lowercase -!============================================================! - function lowerCase(s) - implicit none - character(len=*),intent(in) :: s - character(len=:),allocatable :: sout - character(len=:),allocatable :: lowerCase - integer :: ic,i - character(26),Parameter :: high = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - character(26),Parameter :: low = 'abcdefghijklmnopqrstuvwxyz' - sout = s - do i = 1,LEN_TRIM(s) - ic = INDEX(high,s(i:i)) - if (ic > 0) sout(i:i) = low(ic:ic) - end do - call move_alloc(sout,lowerCase) - end function lowerCase - -!============================================================! -! split element lable if some isotope indicator was given -! and convert to uppercase -!============================================================! - function convertlable(s) - implicit none - character(len=*),intent(in) :: s - character(len=:),allocatable :: sout - character(len=:),allocatable :: convertlable - integer :: ic,i - character(14),parameter :: lab = '0123456789*_+-' - character(26),parameter :: high = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - character(26),parameter :: low = 'abcdefghijklmnopqrstuvwxyz' - sout = s - do i = 1,len_trim(s) - ic = index(lab,s(i:i)) - if (ic > 0) sout(i:i) = ' ' - ic = index(low,s(i:i)) - if (ic > 0) sout(i:i) = high(ic:ic) - end do - sout = trim(adjustl(sout)) - if (len_trim(sout) .gt. 1) then - sout(2:2) = lowerCase(sout(2:2)) - else - sout = sout//' ' - end if - call move_alloc(sout,convertlable) - end function convertlable - -!=============================================================! - pure elemental integer function ncore(at) - integer,intent(in) :: at - if (at .le. 2) then - ncore = 0 - elseif (at .le. 10) then - ncore = 2 - elseif (at .le. 18) then - ncore = 10 - elseif (at .le. 29) then !zn - ncore = 18 - elseif (at .le. 36) then - ncore = 28 - elseif (at .le. 47) then - ncore = 36 - elseif (at .le. 54) then - ncore = 46 - elseif (at .le. 71) then - ncore = 54 - elseif (at .le. 79) then - ncore = 68 - elseif (at .le. 86) then - ncore = 78 - end if - end function ncore - -!============================================================! -! e2i is used to map the element (as a string) to integer -!============================================================! - integer function e2i(cin) - implicit none - character(len=*),intent(in) :: cin - character(len=:),allocatable :: c - integer :: iout - integer :: i,j,k,ich,io,Z - logical :: ex - c = trim(convertlable(cin)) - read (cin,*,iostat=io) j - if (io == 0) Z = j - if (any(PSE(:) .eq. c)) then - do i = 1,118 - if (trim(PSE(i)) .eq. c) then - iout = i - exit - end if - end do - else if (io == 0.and.Z <= 118) then - iout = Z - else !> special cases - select case (trim(c)) - case ('D'); iout = 1 - case ('T'); iout = 1 - case default; iout = 0 - end select - end if - e2i = iout - end function e2i - -!============================================================! -! i2e is used to map the element (as a integer) to a string -!============================================================! - character(len=2) function i2e(iin,oformat) - implicit none - integer,intent(in) :: iin - character(len=:),allocatable :: c - character(len=*),optional :: oformat - if (iin <= 118) then - c = uppercase(PSE(iin)) - else - c = 'XX' - end if - i2e = trim(c) - if (present(oformat)) then - select case (oformat) - case ('lc','lowercase') - i2e = lowerCase(trim(c)) - case ('nc','nicecase') - if (len_trim(c) .gt. 1) then - c(2:2) = lowerCase(c(2:2)) - i2e = trim(c) - end if - case default - continue - end select - end if - end function i2e - -!============================================================! -! get the file extension -!============================================================! - function fextension(s) - implicit none - character(len=*),intent(in) :: s !filename - character(len=:),allocatable :: sout - character(len=:),allocatable :: fextension !output - integer :: ic,i - sout = trim(adjustl(s)) - i = len_trim(sout) - ic = index(sout,'.',.true.) - if (ic .ne. 0) then - fextension = sout(ic:i) - else - fextension = 'none' - end if - return - end function fextension - -!============================================================! -! grep for a keyword within the file -!============================================================! - function sgrep(fname,key) - implicit none - character(len=*),intent(in) :: fname - character(len=*),intent(in) :: key - logical :: sgrep - character(len=256) :: atmp - integer :: ic,io - sgrep = .false. - open (newunit=ic,file=fname) - do - read (ic,'(a)',iostat=io) atmp - if (io < 0) exit !EOF - if (index(atmp,key) .ne. 0) then - sgrep = .true. - exit - end if - end do - close (ic) - return - end function sgrep - -!============================================================! -! grep the energy from a line of strings -!============================================================! - function grepenergy(line) - implicit none - real(wp) :: grepenergy - character(len=*),intent(in) :: line - real(wp) :: energy - character(len=:),allocatable :: atmp - integer :: i,io,k - atmp = trim(line) - energy = 0.0_wp - if (index(atmp,'energy=') .ne. 0) then - k = index(atmp,'energy=') - atmp = atmp(k+7:) - read (atmp,*,iostat=io) energy - if (io .ne. 0) energy = 0.0_wp - else if (index(atmp,'energy:') .ne. 0) then - k = index(atmp,'energy:') - atmp = atmp(k+7:) - read (atmp,*,iostat=io) energy - if (io .ne. 0) energy = 0.0_wp - else - !> assumes that the first float in the line is the energy - do i = 1,len_trim(atmp) - if (len_trim(atmp) .lt. 1) exit - read (atmp,*,iostat=io) energy - if (io > 0) then - atmp = atmp(2:) - atmp = adjustl(atmp) - cycle - else - exit - end if - end do - end if - grepenergy = energy - return - end function grepenergy - -!============================================================! -! count number of bonds from an wbo matrix -!============================================================! - function countbonds(nat,wbo) result(nbd) - implicit none - integer,intent(in) :: nat - real(wp),intent(in) :: wbo(nat,nat) - integer :: nbd - integer :: i,j,k - nbd = 0 - do i = 1,nat - do j = 1,i-1 - k = nint(wbo(i,j)) - if (k > 0) nbd = nbd+1 - end do - end do - return - end function countbonds - -!=========================================================================================! - - subroutine get_atlist(nat,atlist,line,at) -!****************************************************** -!* Analyze a string containing atom specifications. -!* "atlist" is a array of booleans for each atom, -!* which is set to .true. should the atom be contained -!* in atlist. -!****************************************************** - implicit none - integer,intent(in) :: nat - logical,intent(out),allocatable :: atlist(:) - character(len=*),intent(in) :: line - integer,intent(in),optional :: at(nat) - character(len=:),allocatable :: substr(:) - integer :: i,j,k,l,io,ns,ll,i1,i2,io1,io2,i3,i4 - character(len=:),allocatable :: atmp,btmp - - allocate (atlist(nat),source=.false.) -!>-- count stuff - ll = len_trim(line) - ns = 1 - do i = 1,ll - if (line(i:i) .eq. ',') ns = ns+1 - end do - allocate (substr(ns),source=repeat(' ',ll)) -!>-- cut stuff - if (ns > 1) then - j = 1 - k = 1 - do i = 1,ll - if (k == ns) then - substr(k) = lowercase(adjustl(line(j:))) - exit - end if - if (line(i:i) .eq. ',') then - substr(k) = lowercase(adjustl(line(j:i-1))) - k = k+1 - j = i+1 - end if - end do - else - substr(1) = trim(line) - end if -!>--- analyze stuff - do i = 1,ns - atmp = trim(substr(i)) - if (atmp .eq. 'all') then - atlist(:) = .true. - exit - end if - if (index(atmp,'.') .ne. 0) cycle !> exclude floats - l = index(atmp,'-') - if (l .eq. 0) then - read (atmp,*,iostat=io) i1 - !> check if it is an element symbol - if (io /= 0) then - if (len_trim(atmp) > 2) then - if (index(trim(atmp),'heavy') .ne. 0) then !> all heavy atoms - if (present(at)) then - do j = 1,nat - if (at(j) > 1) atlist(j) = .true. - end do - end if - end if - else !> element symbols - k = e2i(atmp) - if (present(at)) then - do j = 1,nat - if (at(j) == k) atlist(j) = .true. - end do - end if - end if - else - atlist(i1) = .true. - end if - else - btmp = atmp(:l-1) - read (btmp,*,iostat=io1) i1 - btmp = atmp(l+1:) - read (btmp,*,iostat=io2) i2 - if (io1 .eq. 0.and.io2 .eq. 0) then - i4 = max(i1,i2) - i3 = min(i1,i2) - do j = 1,nat - if (i3 <= j.and.j <= i4) atlist(j) = .true. - end do - end if - end if - end do - deallocate (substr) - end subroutine get_atlist - -!=========================================================================================! - - subroutine atswp(self,ati,atj) - !******************************** - !* swap atom ati with atj in mol - !******************************** - implicit none - class(coord),intent(inout) :: self - integer,intent(in) :: ati,atj - real(wp) :: xyztmp(3) - integer :: attmp - xyztmp(1:3) = self%xyz(1:3,ati) - attmp = self%at(ati) - self%xyz(1:3,ati) = self%xyz(1:3,atj) - self%at(ati) = self%at(atj) - self%xyz(1:3,atj) = xyztmp(1:3) - self%at(atj) = attmp - end subroutine atswp - -!=========================================================================================! - function sumform(nat,at) result(sumformula) -!************************************************ -!* get sumformula as a string from the AT array -!************************************************ - implicit none - integer,intent(in) :: nat - integer,intent(in) :: at(nat) - character(len=:),allocatable :: sumformula - integer :: sumat(118) - integer :: i - character(len=6) :: str - sumformula = '' - sumat = 0 - do i = 1,nat - sumat(at(i)) = sumat(at(i))+1 - end do - !> carbon always first - if (sumat(6) > 0) then - if (sumat(6) > 1) then - write (str,'(a,i0)') trim(adjustl(i2e(6,'nc'))),sumat(6) - else - str = 'C' - end if - sumformula = trim(sumformula)//trim(str) - end if - do i = 2,118 - if (i == 6) cycle - if (sumat(i) .lt. 1) cycle - if (sumat(i) > 1) then - write (str,'(a,i0)') trim(adjustl(i2e(i,'nc'))),sumat(i) - else - str = trim(i2e(i,'nc')) - end if - sumformula = trim(sumformula)//trim(str) - end do - !> hydrogen always last - if (sumat(1) > 0) then - if (sumat(1) > 1) then - write (str,'(a,i0)') trim(adjustl(i2e(1,'nc'))),sumat(1) - else - str = 'H' - end if - sumformula = trim(sumformula)//trim(str) - end if - return - end function sumform - - function coord_sumform(self) result(sumformula) - implicit none - class(coord) :: self - character(len=:),allocatable :: sumformula - sumformula = sumform(self%nat,self%at) - end function coord_sumform - -!=========================================================================================! -!=========================================================================================! -! end of the module -!=========================================================================================! -!=========================================================================================! end module strucrd diff --git a/src/molecule/type.f90 b/src/molecule/type.f90 index edbd998c..c139ce13 100644 --- a/src/molecule/type.f90 +++ b/src/molecule/type.f90 @@ -28,9 +28,10 @@ module molecule_type use crest_cn_module,only:calculate_cn implicit none private - +! ══════════════════════════════════════════════════════════════════════════════ + !> EXPORTS public :: coord - + public :: coord2xyz,xyz2coord ! ══════════════════════════════════════════════════════════════════════════════ type :: coord From e204424305871c662b8f1dc9f6048511f78b92bb Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 24 Mar 2026 00:09:39 +0100 Subject: [PATCH 263/374] Some cleanup for molecule type refactor --- src/molecule/io.f90 | 30 +++++++++++++++++++++--------- src/molecule/parameters.f90 | 4 ++-- src/molecule/type.f90 | 17 ++++++++++------- 3 files changed, 33 insertions(+), 18 deletions(-) diff --git a/src/molecule/io.f90 b/src/molecule/io.f90 index 95646dc6..7f4985f2 100644 --- a/src/molecule/io.f90 +++ b/src/molecule/io.f90 @@ -50,6 +50,7 @@ module molecule_io public :: rdcoord !-- read an input file, determine format automatically public :: rdxmol !-- read a file in the Xmol (.xyz) format specifically public :: rdxmolselec !-- read only a certain structure in Xmol file + public :: rdPDB !>--- write a TM coord file public :: wrc0 @@ -153,7 +154,8 @@ subroutine rdnat(fname,nat,ftype) nat = 0 inquire (file=fname,exist=ex) if (.not.ex) then - error stop 'file does not exist.' + write (stdout,'(a)') '**ERROR** could not find coord file '//trim(fname) + call exit(1) end if if (present(ftype)) then ftypedum = ftype @@ -259,6 +261,7 @@ subroutine rdcoord(fname,nat,at,xyz,energy,ftype) select case (ftypedum) case (coordtype%turbomole) !-- TM coord file, always retruns coords in Bohr call rdtmcoord(fname,nat,at,xyz) + case (coordtype%xyz) !-- XYZ file, is Angström, needs conversion if (present(energy)) then call rdxmol(fname,nat,at,xyz,atmp) @@ -267,16 +270,20 @@ subroutine rdcoord(fname,nat,at,xyz,energy,ftype) call rdxmol(fname,nat,at,xyz) end if xyz = xyz/bohr + case (coordtype%sdfV2000) !-- SDF/MOL V2000 file, also Angström call rdsdf(fname,nat,at,xyz) xyz = xyz/bohr + case (coordtype%sdfV3000) !-- SDF V3000 file, Angström call rdsdfV3000(fname,nat,at,xyz) xyz = xyz/bohr + case (coordtype%PDB) !-- PDB file, Angström call rdPDB(fname,nat,at,xyz,pdbdummy) xyz = xyz/bohr call pdbdummy%deallocate() + case default continue end select @@ -364,7 +371,9 @@ subroutine rdxmol(fname,nat,at,xyz,comment) open (newunit=ich,file=fname) read (ich,*,iostat=io) dum if (nat .ne. dum) then - error stop 'error while reading input coordinates' + write (stdout,'(a)') '**ERROR** Mismatch in expected atom number for file '//trim(fname) + write (stdout,'(a,i0,a,i0)') ' Expected ',nat,' got ',dum + call exit(1) end if read (ich,'(a)') atmp !--commentary line if (present(comment)) comment = trim(adjustl(atmp)) @@ -374,7 +383,7 @@ subroutine rdxmol(fname,nat,at,xyz,comment) atmp = adjustl(atmp) call coordline(atmp,sym,xyz(1:3,i),io) if (io < 0) then - write (*,*) 'error while reading coord line. EOF' + write (stdout,'(a)') '**ERROR** Unexpected EOF while reading file '//trim(fname) exit end if at(i) = e2i(sym) @@ -414,7 +423,9 @@ subroutine rdsdf(fname,nat,at,xyz,comment) if (present(comment)) comment = trim(adjustl(atmp)) read (ich,'(i3)',iostat=io) dum if (nat .ne. dum) then - error stop 'error while reading input coordinates' + write (stdout,'(a)') '**ERROR** Mismatch in expected atom number for file '//trim(fname) + write (stdout,'(a,i0,a,i0)') ' Expected ',nat,' got ',dum + call exit(1) end if do i = 1,nat read (ich,'(a)',iostat=io) atmp @@ -478,7 +489,9 @@ subroutine rdsdfV3000(fname,nat,at,xyz,comment) end if end do if (nat .ne. dum) then - error stop 'error while reading input coordinates' + write (stdout,'(a)') '**ERROR** Mismatch in expected atom number for file '//trim(fname) + write (stdout,'(a,i0,a,i0)') ' Expected ',nat,' got ',dum + call exit(1) end if do i = 1,nat read (ich,'(a)',iostat=io) atmp @@ -586,7 +599,9 @@ subroutine rdxmolselec(fname,m,nat,at,xyz,comment) do j = 1,m read (ich,*,iostat=io) dum if (nat .ne. dum) then - error stop 'error while reading input coordinates' + write (stdout,'(a)') '**ERROR** Mismatch in expected atom number for file '//trim(fname) + write (stdout,'(a,i0,a,i0)') ' Expected ',nat,' got ',dum + call exit(1) end if read (ich,'(a)') atmp !--commentary line if (present(comment)) comment = trim(adjustl(atmp)) @@ -994,9 +1009,6 @@ subroutine coordline(line,sym,xyz,io) read (line,*,iostat=io) xyz(1:3),sym if (io .ne. 0) then read (line,*,iostat=io) sym,xyz(1:3) - !if(io.ne.0)then - ! error stop 'error while reading coord line' - !endif end if return diff --git a/src/molecule/parameters.f90 b/src/molecule/parameters.f90 index 7a35ebff..3c200dc0 100644 --- a/src/molecule/parameters.f90 +++ b/src/molecule/parameters.f90 @@ -18,11 +18,11 @@ !================================================================================! module molecule_parameters - use iso_fortran_env,only:wp => real64 + use iso_fortran_env,only:wp => real64,stdout=>output_unit use iso_c_binding implicit none - public :: wp !> RE-EXPORT + public :: wp,stdout !> RE-EXPORTS !&< !>--- some constants and name mappings real(wp),parameter :: bohr = 0.52917726_wp diff --git a/src/molecule/type.f90 b/src/molecule/type.f90 index c139ce13..bbb22428 100644 --- a/src/molecule/type.f90 +++ b/src/molecule/type.f90 @@ -139,7 +139,8 @@ subroutine opencoord(self,fname) inquire (file=fname,exist=ex) if (.not.ex) then - error stop 'coord file does not exist.' + write(stdout,'(a)') '**ERROR** could not find coord file '//trim(fname) + call exit(1) end if call self%deallocate() @@ -150,19 +151,21 @@ subroutine opencoord(self,fname) if (nat > 0) then en = 0.0_wp allocate (at(nat),xyz(3,nat)) - if (ftype == coordtype%PDB) then - call rdPDB(fname,nat,at,xyz,self%pdb) + select case (ftype) + case (coordtype%PDB) + call rdPDB(fname,nat,at,xyz,self%pdb) ! ← need to fill self%pdb xyz = xyz/bohr - else + case default call rdcoord(fname,nat,at,xyz,energy=en,ftype=ftype) - end if - + end select self%nat = nat self%energy = en call move_alloc(at,self%at) call move_alloc(xyz,self%xyz) else - error stop 'format error while reading coord file.' + write(stdout,'(a)') '**ERROR** Format issue while reading coord file '//trim(fname) + write(stdout,'(a)') ' Number of atoms detected as zero!' + call exit(1) end if return From b7c7a75190b46c52ef2da6b89b9171534adb96b0 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 24 Mar 2026 01:37:33 +0100 Subject: [PATCH 264/374] Modify the mol%write() function to adapt to file types --- src/molecule/io.f90 | 20 ++++-- src/molecule/parameters.f90 | 9 ++- src/molecule/type.f90 | 112 +++++++++++++++++++++++++++---- src/molecule/type_components.f90 | 32 ++++++++- 4 files changed, 152 insertions(+), 21 deletions(-) diff --git a/src/molecule/io.f90 b/src/molecule/io.f90 index 7f4985f2..bbf7ff29 100644 --- a/src/molecule/io.f90 +++ b/src/molecule/io.f90 @@ -78,6 +78,14 @@ module molecule_io interface wrsdf module procedure wrsdf_channel end interface wrsdf + public :: wrsdfV2000 + interface wrsdfV2000 + module procedure wrsdf_channel + end interface wrsdfV2000 + interface wrsdfV3000 + module procedure wrsdfV3000_channel + end interface wrsdfV3000 + public :: wrsdfV3000 public :: coordline public :: get_atlist @@ -105,9 +113,10 @@ subroutine checkcoordtype(fname,typint) case ('.coord','.COORD') typint = coordtype%turbomole case ('.xyz','.XYZ', & - & '.trj','.TRJ','.sorted', & - & '.extxyz') + & '.trj','.TRJ','.sorted') typint = coordtype%xyz + case ('.extxyz','.EXTXYZ') + typint = coordtype%extxyz case ('.sd','.sdf','.SDF','.mol','.MOL') typint = coordtype%sdf if (sgrep(fname,'V2000')) then @@ -119,8 +128,9 @@ subroutine checkcoordtype(fname,typint) case ('.pdb','.PDB') typint = coordtype%PDB case default - typint = 0 + typint = coordtype%unknown end select + if (typint .ne. coordtype%unknown) return !-- file extension was recognized !-- grep for keywords otherwise if (sgrep(fname,'$coord')) then @@ -1169,10 +1179,12 @@ function sgrep(fname,key) implicit none character(len=*),intent(in) :: fname character(len=*),intent(in) :: key - logical :: sgrep + logical :: sgrep,ex character(len=256) :: atmp integer :: ic,io sgrep = .false. + inquire (file=fname,exist=ex) + if (.not.ex) return open (newunit=ic,file=fname) do read (ic,'(a)',iostat=io) atmp diff --git a/src/molecule/parameters.f90 b/src/molecule/parameters.f90 index 3c200dc0..7386aa5f 100644 --- a/src/molecule/parameters.f90 +++ b/src/molecule/parameters.f90 @@ -25,9 +25,12 @@ module molecule_parameters public :: wp,stdout !> RE-EXPORTS !&< !>--- some constants and name mappings - real(wp),parameter :: bohr = 0.52917726_wp - real(wp),parameter :: aatoau = 1.0_wp/bohr - real(wp),parameter :: autokcal = 627.509541_wp + real(wp),parameter,public :: bohr = 0.52917726_wp + real(wp),parameter,public :: aatoau = 1.0_wp/bohr + real(wp),parameter,public :: autoaa = bohr + real(wp),parameter,public :: autokcal = 627.509541_wp + real(wp),parameter,public :: autoeV = 27.211324570273_wp + !>-- filetypes as integers type ,private:: enum_coordtype integer :: unknown = 0 diff --git a/src/molecule/type.f90 b/src/molecule/type.f90 index bbb22428..f38d55d0 100644 --- a/src/molecule/type.f90 +++ b/src/molecule/type.f90 @@ -79,12 +79,14 @@ module molecule_type type(pdbdata) :: pdb !>-- extxyz signature + logical :: wrextxyz = .false. type(extxyz_signatures),allocatable :: extxyz contains procedure :: deallocate => deallocate_coord !> clear memory space procedure :: open => opencoord !> read an coord file - procedure :: write => writecoord !> write + procedure :: write => writecoord !> write (detected from file extension) + procedure :: writeextxyz => write_extxyz !> write extxyz file to a given iunit procedure :: append => appendcoord !> append procedure :: get => getcoord !> allocate & fill with data procedure :: appendlog !> append .log file with coordinates and energy @@ -139,7 +141,7 @@ subroutine opencoord(self,fname) inquire (file=fname,exist=ex) if (.not.ex) then - write(stdout,'(a)') '**ERROR** could not find coord file '//trim(fname) + write (stdout,'(a)') '**ERROR** could not find coord file '//trim(fname) call exit(1) end if @@ -163,8 +165,8 @@ subroutine opencoord(self,fname) call move_alloc(at,self%at) call move_alloc(xyz,self%xyz) else - write(stdout,'(a)') '**ERROR** Format issue while reading coord file '//trim(fname) - write(stdout,'(a)') ' Number of atoms detected as zero!' + write (stdout,'(a)') '**ERROR** Format issue while reading coord file '//trim(fname) + write (stdout,'(a)') ' Number of atoms detected as zero!' call exit(1) end if @@ -333,6 +335,60 @@ end subroutine coord_cn_to_bond ! ROUTINES FOR WRITING STRUCTURES AND CONVERTING THEM ! ══════════════════════════════════════════════════════════════════════════════ + subroutine write_extxyz(self,iunit) +!************************************************************************ +!* Write an extended xyz file from the coord object. * +!* By convention energies will be in eV for extxyz! * +!* By convention (and if present), forces will be in eV/Ang for extxyz! * +!************************************************************************ + class(coord) :: self + integer,intent(in) :: iunit !> assue the unit is open for writing + + character(len=200) :: atmp + real(wp) :: eeV + integer :: ii + real(wp),parameter :: grad2force = -autoeV/autoaa + + !> print number of atoms + write (iunit,'(i10)') self%nat + + !> construct ext comment line bit by bit + eeV = self%energy*autoeV + write (atmp,'(f20.10)') eeV + write (iunit,'(a,a)',advance='no') trim('energy='//adjustl(atmp)),' ' + if (allocated(self%lat)) then + write (iunit,'(a)',advance='no') 'Lattice="' + write (iunit,'(9f15.8)',advance='no') reshape(self%lat, [9]) + write (iunit,'(a)',advance='no') '" ' + end if + if (allocated(self%extxyz)) then + call assemble_properties_tag(self%extxyz,atmp) + else if (allocated(self%gradient)) then + write (atmp,'("species:S:1:pos:R:3:forces:R:3")') + else + write (atmp,'("species:S:1:pos:R:3")') + end if + write (iunit,'(a,a,a)',advance='no') 'Properties=',trim(atmp),' ' + write (iunit,*) + + !> coord block + if (allocated(self%extxyz)) then + write (stdout,*) '**ERROR** This extxyz write function is TODO' + call exit(1) + else if (allocated(self%gradient)) then + do ii = 1,self%nat + write (iunit,'(1x,a2,1x,6f20.10)') & + & i2e(self%at(ii)),self%xyz(1:3,ii)*autoaa,self%gradient(1:3,ii)*grad2force + end do + else + do ii = 1,self%nat + write (iunit,'(1x,a2,1x,3f20.10)') i2e(self%at(ii)),self%xyz(1:3,ii)*autoaa + end do + end if + end subroutine write_extxyz + +! ────────────────────────────────────────────────────────────────────────────── + subroutine xyz2coord(iname,oname) !*********************************************** !* subroutine xyz2coord * @@ -383,17 +439,47 @@ subroutine writecoord(self,fname) class(coord) :: self character(len=*),intent(in) :: fname character(len=80) :: comment + integer :: ftype,iunit if (.not.allocated(self%xyz)) then - write (*,*) 'Cannot write ',trim(fname),'. not allocated' - end if - if (index(fname,'.xyz') .ne. 0) then - write (comment,'(a,G0.12)') ' energy= ',self%energy - self%xyz = self%xyz*bohr !to Angström - call wrxyz(fname,self%nat,self%at,self%xyz,comment) - self%xyz = self%xyz/bohr !back - else - call wrc0(fname,self%nat,self%at,self%xyz) + write (stdout,*) 'Cannot write ',trim(fname),'. No coordinates allocated' end if + call checkcoordtype(fname,ftype) + open (newunit=iunit,file=trim(fname)) + select case (ftype) + case (coordtype%xyz) + if (self%wrextxyz) then + call self%writeextxyz(iunit) + else + call wrxyz(iunit,self%nat,self%at,self%xyz*autoaa,self%energy) + end if + + case (coordtype%extxyz) + call self%writeextxyz(iunit) + + case (coordtype%sdf,coordtype%sdfV3000) + call wrsdfV3000(iunit,self%nat,self%at,self%xyz*autoaa, & + & self%energy,real(self%chrg,wp),real(self%bond,wp),' written by CREST') + + case (coordtype%sdfV2000) + call wrsdfV2000(iunit,self%nat,self%at,self%xyz*autoaa, & + & self%energy,self%chrg,real(self%bond,wp),' written by CREST') + + case (coordtype%PDB) + write (stdout,'(a)') '**ERROR** PDB file writer not implemented, TODO' + call exit(1) + case default + !> defaults to Turbomole coord type + call wrc0(iunit,self%nat,self%at,self%xyz) + end select + close (iunit) + !if (index(fname,'.xyz') .ne. 0) then + ! write (comment,'(a,G0.12)') ' energy= ',self%energy + ! self%xyz = self%xyz*bohr !to Angström + ! call wrxyz(fname,self%nat,self%at,self%xyz,comment) + ! self%xyz = self%xyz/bohr !back + !else + ! call wrc0(fname,self%nat,self%at,self%xyz) + !end if return end subroutine writecoord diff --git a/src/molecule/type_components.f90 b/src/molecule/type_components.f90 index e6e7b33b..f9648151 100644 --- a/src/molecule/type_components.f90 +++ b/src/molecule/type_components.f90 @@ -46,7 +46,8 @@ module molecule_type_components ! ────────────────────────────────────────────────────────────────────────────── - public :: signature,extxyz_signatures,parse_properties_tag + public :: signature,extxyz_signatures + public :: parse_properties_tag,assemble_properties_tag ! Type representing a single property entry (e.g., pos:R:3) type :: signature @@ -173,6 +174,35 @@ subroutine parse_properties_tag(prop_str,ext_props) end do end subroutine parse_properties_tag + subroutine assemble_properties_tag(ext_props,prop_str) + implicit none + type(extxyz_signatures),intent(in) :: ext_props + character(len=*),intent(out) :: prop_str + + integer :: i + character(len=16) :: col_buffer ! Temporary buffer for integer conversion + + ! Initialize the string as empty + prop_str = "" + + do i = 1,ext_props%n_props + ! 1. Append the Name + prop_str = trim(prop_str)//trim(ext_props%props(i)%name)//":" + + ! 2. Append the Type (R/S/I) + prop_str = trim(prop_str)//ext_props%props(i)%p_type//":" + + ! 3. Append the Number of Columns + write (col_buffer,'(I0)') ext_props%props(i)%n_fields + prop_str = trim(prop_str)//trim(col_buffer) + + ! 4. Add a colon separator UNLESS this is the last property + if (i < ext_props%n_props) then + prop_str = trim(prop_str)//":" + end if + end do + end subroutine assemble_properties_tag + ! ══════════════════════════════════════════════════════════════════════════════ ! ══════════════════════════════════════════════════════════════════════════════ end module molecule_type_components From a5bf112452be5a11e308eaf6ca2509275927856b Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 24 Mar 2026 12:27:41 +0100 Subject: [PATCH 265/374] working on extxyz reader --- src/molecule/io.f90 | 105 ++++++++++++++++++++++++++++++- src/molecule/strucreader.f90 | 58 +++++++---------- src/molecule/type_components.f90 | 57 ++++++++++------- 3 files changed, 161 insertions(+), 59 deletions(-) diff --git a/src/molecule/io.f90 b/src/molecule/io.f90 index bbf7ff29..7ecb9c6b 100644 --- a/src/molecule/io.f90 +++ b/src/molecule/io.f90 @@ -115,6 +115,9 @@ subroutine checkcoordtype(fname,typint) case ('.xyz','.XYZ', & & '.trj','.TRJ','.sorted') typint = coordtype%xyz + if (sgrep(fname,'Properties=',casesensitive=.false.)) then + typint = coordtype%extxyz + end if case ('.extxyz','.EXTXYZ') typint = coordtype%extxyz case ('.sd','.sdf','.SDF','.mol','.MOL') @@ -998,6 +1001,97 @@ subroutine wrsdfV3000_channel(ch,nat,at,xyz,er,chrg,wbo,comment) return end subroutine wrsdfV3000_channel +! ────────────────────────────────────────────────────────────────────────────── + + subroutine read_extxyz_frame(iunit,ext_sigs,ext_props,success) + implicit none + + ! Formal Arguments + integer,intent(in) :: iunit + type(extxyz_signatures),intent(inout) :: ext_sigs + type(extxyz_properties),intent(inout) :: ext_props + logical,intent(out) :: success + + ! Internal variables + integer :: nat,i,ierr,total_fields + character(len=5000) :: comment_line + character(len=2000) :: val_str + logical :: found + real(wp) :: energy + real(wp) :: lattice(3,3) + real(wp) :: lat_raw(9) + character(len=128),allocatable :: line_fields(:) + character(len=2000) :: current_line + + success = .true. + + ! 1. Read Number of Atoms (nat) + read (iunit,*,iostat=ierr) nat + if (ierr /= 0) then + success = .false. + return + end if + + ! 2. Read the long comment line + read (iunit,'(A)',iostat=ierr) comment_line + if (ierr /= 0) then + success = .false. + return + end if + + ! 3. Extract Key-Value Pairs + ! Extract Energy + call get_extxyz_value(comment_line,"energy",val_str,found) + if (found) read (val_str,*) energy + + ! Extract Lattice + call get_extxyz_value(comment_line,"lattice",val_str,found) + if (found) then + read (val_str,*) lat_raw + lattice = reshape(lat_raw, (/3,3/)) + end if + + ! Extract and Parse Properties Signature + call get_extxyz_value(comment_line,"properties",val_str,found) + if (found) then + call parse_properties_tag(val_str,ext_sigs) + else + success = .false. + return + end if + + ! 4. Placeholder: Allocate extxyz_properties based on signatures + ! CALL allocate_extxyz_properties_from_sigs(nat, ext_sigs, ext_props) + + ! 5. Read Atom Data Lines + total_fields = ext_sigs%total_fields + allocate (line_fields(total_fields)) + + do i = 1,nat + read (iunit,'(A)',iostat=ierr) current_line + if (ierr /= 0) then + success = .false. + exit + end if + + ! Split line into fields based on whitespace + ! Note: Implementing a basic list-directed read or custom splitter here + read (current_line,*,iostat=ierr) line_fields + + if (ierr /= 0) then + print*,"Error: Mismatch between signature fields and data at atom",i + success = .false. + exit + end if + + ! 6. Placeholder: Fill entries in extxyz_properties + ! CALL fill_atom_properties(line_fields, ext_sigs, ext_props, i) + end do + + deallocate (line_fields) + + end subroutine read_extxyz_frame + !=========================================================================================! !=========================================================================================! ! 4. GENERAL UTILITY ROUTINES @@ -1175,21 +1269,27 @@ end function fextension !============================================================! ! grep for a keyword within the file !============================================================! - function sgrep(fname,key) + function sgrep(fname,key,casesensitive) implicit none character(len=*),intent(in) :: fname character(len=*),intent(in) :: key + logical,intent(in),optional :: casesensitive logical :: sgrep,ex character(len=256) :: atmp + character(len=:),allocatable :: kkey integer :: ic,io sgrep = .false. inquire (file=fname,exist=ex) if (.not.ex) return + kkey = trim(key) + if (present(casesensitive)) then + if (.not.casesensitive) kkey = lowercase(key) + end if open (newunit=ic,file=fname) do read (ic,'(a)',iostat=io) atmp if (io < 0) exit !EOF - if (index(atmp,key) .ne. 0) then + if (index(atmp,kkey) .ne. 0) then sgrep = .true. exit end if @@ -1237,7 +1337,6 @@ function grepenergy(line) grepenergy = energy return end function grepenergy - ! ────────────────────────────────────────────────────────────────────────────── subroutine get_extxyz_value(comment_line,key,value,found) diff --git a/src/molecule/strucreader.f90 b/src/molecule/strucreader.f90 index 83a9898a..50a2838e 100644 --- a/src/molecule/strucreader.f90 +++ b/src/molecule/strucreader.f90 @@ -17,65 +17,55 @@ ! along with crest. If not, see . !================================================================================! -!=========================================================================================! -! STRUCRD is a module for reading and writing molecular structures. -! -! The source is organized as follows: -! 0. Variable declarations -! 1. Routines for reading and writing ensemble files/trajectories in the XYZ format -! 2. Routines for reading single structures in various formats -! 3. Routines for writing structures in various formats -! 4. Utility routines mainly used only within the module -! -! Currently supported formats: -! .xyz (Xmol) files and trajectories (read and write) -! coord (turbomole) files (read and write) -! .sdf/.mol files (V2000, read only) -! .pdb files (in development) -! -!=========================================================================================! +!> Exports the "coord" type and I/O module strucrd use molecule_type use molecule_type_components use molecule_type_ensemble + use molecule_parameters, only: coordtype use molecule_io implicit none private + !> RE-EXPORTS FROM THE ABOVE MODULES ! ══════════════════════════════════════════════════════════════════════════════ public :: coord !> coord type - public :: ensemble !> ensemble type (sparsely used) + public :: ensemble !> ensemble type (sparsely used, better use a list of coord objects) public :: mollist !> list of coord objects -!=========================================================================================! +! ══════════════════════════════════════════════════════════════════════════════ public :: i2e !> function to convert atomic number to element symbol - public :: asym !> " + public :: asym !> alterinative signature for i2e public :: e2i !> function to convert element symbol into atomic number - public :: grepenergy - public :: checkcoordtype - public :: rdnat !-- procedure to read number of atoms Nat - public :: rdcoord !-- read an input file, determine format automatically - public :: rdxmol !-- read a file in the Xmol (.xyz) format specifically - public :: rdxmolselec !-- read only a certain structure in Xmol file + public :: checkcoordtype !> determine input coordinate file type (mostly via extension) + public :: coordtype !> Possible return types from checkcoordtype → e.g. coordtype%turbomole - public :: wrc0 - public :: wrcoord - public :: wrxyz - public :: wrsdf + public :: rdnat !> procedure to read number of atoms Nat + public :: rdcoord !> read an input file, determine format automatically + public :: rdxmol !> read a file in the Xmol (.xyz) format specifically + public :: rdxmolselec !> read only a certain structure in Xmol file + + !> NOTE, using coord%write() is safer than the ones below + public :: wrc0 !> write file in turbomole format + public :: wrcoord !> write file by name, type via extension + public :: wrxyz !> write file in xyz format + public :: wrsdf !> write file in sdf format public :: xyz2coord public :: coord2xyz - public :: rdensembleparam !-- read Nat and Nall for a XYZ trajectory - public :: rdensemble !-- read a XYZ trajectory + public :: rdensembleparam !> read Nat and Nall for a XYZ trajectory + public :: rdensemble !> read a XYZ trajectory public :: wrensemble public :: coordline + public :: grepenergy public :: get_atlist public :: sumform -!=========================================================================================! -!=========================================================================================! +! ══════════════════════════════════════════════════════════════════════════════ contains !> MODULE PROCEDURES START HERE +! ══════════════════════════════════════════════════════════════════════════════ +! ══════════════════════════════════════════════════════════════════════════════ end module strucrd diff --git a/src/molecule/type_components.f90 b/src/molecule/type_components.f90 index f9648151..d24b68c4 100644 --- a/src/molecule/type_components.f90 +++ b/src/molecule/type_components.f90 @@ -46,7 +46,7 @@ module molecule_type_components ! ────────────────────────────────────────────────────────────────────────────── - public :: signature,extxyz_signatures + public :: signature,extxyz_signatures,extxyz_properties public :: parse_properties_tag,assemble_properties_tag ! Type representing a single property entry (e.g., pos:R:3) @@ -58,11 +58,24 @@ module molecule_type_components ! Type representing the collection of all properties in the file type :: extxyz_signatures - type(signature),allocatable :: props(:) - integer :: n_props ! Number of unique property keys - integer :: total_fields ! Total sum of all n_fields (total columns) + type(signature),allocatable :: signat(:) + integer :: n_props = 0 ! Number of unique property keys + integer :: total_fields = 0 ! Total sum of all n_fields (total columns) end type extxyz_signatures + type :: extxyz_property + integer :: natoms = 0 + type(signature) :: signat + character(len=32),allocatable :: S(:,:) + integer,allocatable :: I(:,:) + real(wp),allocatable :: R(:,:) + end type extxyz_property + + type :: extxyz_properties + integer :: n_props = 0 + type(extxyz_property),allocatable :: props(:) + end type extxyz_properties + ! ══════════════════════════════════════════════════════════════════════════════ contains !> MODULE PROCEDURES START HERE ! ══════════════════════════════════════════════════════════════════════════════ @@ -108,7 +121,7 @@ end subroutine allocate_pdb ! ────────────────────────────────────────────────────────────────────────────── - subroutine parse_properties_tag(prop_str,ext_props) + subroutine parse_properties_tag(prop_str,ext_sigs) !************************************************************************************* !* Parses the "Properties" value string from an extXYZ comment line. * !* Following the ASE (Atomic Simulation Environment) standard, it decomposes * @@ -118,7 +131,7 @@ subroutine parse_properties_tag(prop_str,ext_props) !* ARGUMENTS: * !* prop_str [IN] : The raw string value of the Properties tag. * !* Example: "species:S:1:pos:R:3:forces:R:3" * -!* ext_props [OUT] : An instance of extxyz_signatures. * +!* ext_sigs [OUT] : An instance of extxyz_signatures. * !* - Allocates the 'props' array based on the number of triplets.* !* - Calculates 'total_fields' for buffer allocation. * !* * @@ -132,7 +145,7 @@ subroutine parse_properties_tag(prop_str,ext_props) !* - It handles both trailing colons and clean endings. * !************************************************************************************* character(len=*),intent(in) :: prop_str - type(extxyz_signatures),intent(out) :: ext_props + type(extxyz_signatures),intent(out) :: ext_sigs integer :: i,start_pos,end_pos,part_count,i_prop character(len=len_trim(prop_str)) :: buffer @@ -144,39 +157,39 @@ subroutine parse_properties_tag(prop_str,ext_props) if (prop_str(i:i) == ':') part_count = part_count+1 end do - ext_props%n_props = (part_count+1)/3 - allocate (ext_props%props(ext_props%n_props)) - ext_props%total_fields = 0 + ext_sigs%n_props = (part_count+1)/3 + allocate (ext_sigs%signat(ext_sigs%n_props)) + ext_sigs%total_fields = 0 ! 2. Parse the triplets buffer = trim(prop_str) start_pos = 1 - do i_prop = 1,ext_props%n_props + do i_prop = 1,ext_sigs%n_props ! Extract Name end_pos = index(buffer(start_pos:),':')+start_pos-2 - ext_props%props(i_prop)%name = buffer(start_pos:end_pos) + ext_sigs%signat(i_prop)%name = buffer(start_pos:end_pos) start_pos = end_pos+2 ! Extract Type (R/S/I) - ext_props%props(i_prop)%p_type = buffer(start_pos:start_pos) + ext_sigs%signat(i_prop)%p_type = buffer(start_pos:start_pos) start_pos = start_pos+2 ! Skip char and following colon ! Extract Number of Fields end_pos = index(buffer(start_pos:),':')+start_pos-2 if (end_pos < start_pos) end_pos = len_trim(buffer) ! Handle last element - read (buffer(start_pos:end_pos),*) ext_props%props(i_prop)%n_fields + read (buffer(start_pos:end_pos),*) ext_sigs%signat(i_prop)%n_fields start_pos = end_pos+2 ! Update global counter - ext_props%total_fields = ext_props%total_fields+ext_props%props(i_prop)%n_fields + ext_sigs%total_fields = ext_sigs%total_fields+ext_sigs%signat(i_prop)%n_fields end do end subroutine parse_properties_tag - subroutine assemble_properties_tag(ext_props,prop_str) + subroutine assemble_properties_tag(ext_sigs,prop_str) implicit none - type(extxyz_signatures),intent(in) :: ext_props + type(extxyz_signatures),intent(in) :: ext_sigs character(len=*),intent(out) :: prop_str integer :: i @@ -185,19 +198,19 @@ subroutine assemble_properties_tag(ext_props,prop_str) ! Initialize the string as empty prop_str = "" - do i = 1,ext_props%n_props + do i = 1,ext_sigs%n_props ! 1. Append the Name - prop_str = trim(prop_str)//trim(ext_props%props(i)%name)//":" + prop_str = trim(prop_str)//trim(ext_sigs%signat(i)%name)//":" ! 2. Append the Type (R/S/I) - prop_str = trim(prop_str)//ext_props%props(i)%p_type//":" + prop_str = trim(prop_str)//ext_sigs%signat(i)%p_type//":" ! 3. Append the Number of Columns - write (col_buffer,'(I0)') ext_props%props(i)%n_fields + write (col_buffer,'(I0)') ext_sigs%signat(i)%n_fields prop_str = trim(prop_str)//trim(col_buffer) ! 4. Add a colon separator UNLESS this is the last property - if (i < ext_props%n_props) then + if (i < ext_sigs%n_props) then prop_str = trim(prop_str)//":" end if end do From 4cea29a5efa836d7148112e2a95f886b73381263 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 24 Mar 2026 12:42:53 +0100 Subject: [PATCH 266/374] extxyz parsing ... --- src/molecule/type_components.f90 | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/src/molecule/type_components.f90 b/src/molecule/type_components.f90 index d24b68c4..c738cc1c 100644 --- a/src/molecule/type_components.f90 +++ b/src/molecule/type_components.f90 @@ -48,6 +48,7 @@ module molecule_type_components public :: signature,extxyz_signatures,extxyz_properties public :: parse_properties_tag,assemble_properties_tag + public :: allocate_extxyz_properties_from_sigs ! Type representing a single property entry (e.g., pos:R:3) type :: signature @@ -216,6 +217,36 @@ subroutine assemble_properties_tag(ext_sigs,prop_str) end do end subroutine assemble_properties_tag +! ────────────────────────────────────────────────────────────────────────────── + subroutine allocate_extxyz_properties_from_sigs(nat,ext_sigs,ext_props) + implicit none + integer,intent(in) :: nat + type(extxyz_signatures),intent(in) :: ext_sigs + type(extxyz_properties),intent(out) :: ext_props + + integer :: ii,n_props,n_fields + + n_props = ext_sigs%n_props + ext_props%n_props = n_props + allocate (ext_props%props(n_props)) + do ii = 1,n_props + associate (prop => ext_props%props(ii)) + prop%signat = ext_sigs%signat(ii) + prop%natoms = nat + n_fields = prop%signat%n_fields + select case(prop%signat%p_type) + case ('I') + allocate(prop%I(n_fields,nat), source=0) + case ('R') + allocate(prop%R(n_fields,nat), source=0.0_wp) + case ('S') + allocate(prop%S(n_fields,nat), source=repeat(' ',32)) + end select + end associate + end do + + end subroutine allocate_extxyz_properties_from_sigs + ! ══════════════════════════════════════════════════════════════════════════════ ! ══════════════════════════════════════════════════════════════════════════════ end module molecule_type_components From 2b20668823950a7053bb399d70cce1de8236813a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 24 Mar 2026 14:19:30 +0100 Subject: [PATCH 267/374] continue on extxyz parsing --- src/molecule/io.f90 | 56 ++++++++++++++++++++++++-------- src/molecule/type.f90 | 15 +++++++-- src/molecule/type_components.f90 | 12 ++++--- 3 files changed, 63 insertions(+), 20 deletions(-) diff --git a/src/molecule/io.f90 b/src/molecule/io.f90 index 7ecb9c6b..47011062 100644 --- a/src/molecule/io.f90 +++ b/src/molecule/io.f90 @@ -51,6 +51,7 @@ module molecule_io public :: rdxmol !-- read a file in the Xmol (.xyz) format specifically public :: rdxmolselec !-- read only a certain structure in Xmol file public :: rdPDB + public :: read_extxyz_frame !>--- write a TM coord file public :: wrc0 @@ -1060,8 +1061,8 @@ subroutine read_extxyz_frame(iunit,ext_sigs,ext_props,success) return end if - ! 4. Placeholder: Allocate extxyz_properties based on signatures - ! CALL allocate_extxyz_properties_from_sigs(nat, ext_sigs, ext_props) + ! 4. Allocate extxyz_properties based on signatures + call allocate_extxyz_properties_from_sigs(nat, ext_sigs, ext_props) ! 5. Read Atom Data Lines total_fields = ext_sigs%total_fields @@ -1074,24 +1075,53 @@ subroutine read_extxyz_frame(iunit,ext_sigs,ext_props,success) exit end if - ! Split line into fields based on whitespace - ! Note: Implementing a basic list-directed read or custom splitter here - read (current_line,*,iostat=ierr) line_fields - - if (ierr /= 0) then - print*,"Error: Mismatch between signature fields and data at atom",i - success = .false. - exit - end if - ! 6. Placeholder: Fill entries in extxyz_properties - ! CALL fill_atom_properties(line_fields, ext_sigs, ext_props, i) + ! CALL fill_atom_properties(current_line, ext_sigs, ext_props, i) end do deallocate (line_fields) end subroutine read_extxyz_frame +! ────────────────────────────────────────────────────────────────────────────── + + subroutine fill_atom_properties(current_line,ext_sigs,ext_props,i) + implicit none + character(len=*),intent(in) :: current_line + type(extxyz_signatures),intent(in) :: ext_sigs + type(extxyz_properties),intent(inout) :: ext_props + integer,intent(in) :: i + integer :: ii,jj,kk + + + + + end subroutine fill_atom_properties + +! ────────────────────────────────────────────────────────────────────────────── + + subroutine get_at_from_ext(ext_props,at) + implicit none + type(extxyz_properties) :: ext_props + integer,intent(out),allocatable :: at(:) + + integer :: ii,jj,nat + + do ii = 1,ext_props%n_props + associate (prop => ext_props%props(ii)) + select case (trim(prop%signat%name)) + case ('species') + nat = prop%natoms + allocate (at(nat),source=0) + do jj = 1,nat + at(jj) = e2i(prop%S(1,jj)) + end do + end select + end associate + end do + + end subroutine get_at_from_ext + !=========================================================================================! !=========================================================================================! ! 4. GENERAL UTILITY ROUTINES diff --git a/src/molecule/type.f90 b/src/molecule/type.f90 index f38d55d0..c42d88d4 100644 --- a/src/molecule/type.f90 +++ b/src/molecule/type.f90 @@ -135,9 +135,11 @@ subroutine opencoord(self,fname) integer,allocatable :: at(:) real(wp),allocatable :: xyz(:,:) integer :: ftype - integer :: i,j,k,ich,io - logical :: ex + integer :: i,j,k,ich,io,iunit + logical :: ex,success real(wp) :: en + type(extxyz_signatures) :: ext_sigs + type(extxyz_properties) :: ext_props inquire (file=fname,exist=ex) if (.not.ex) then @@ -157,6 +159,15 @@ subroutine opencoord(self,fname) case (coordtype%PDB) call rdPDB(fname,nat,at,xyz,self%pdb) ! ← need to fill self%pdb xyz = xyz/bohr + + case (coordtype%extxyz) + open(newunit=iunit,file=fname) + call read_extxyz_frame(iunit,ext_sigs,ext_props,success) + close(iunit) + if(success)then + + endif + case default call rdcoord(fname,nat,at,xyz,energy=en,ftype=ftype) end select diff --git a/src/molecule/type_components.f90 b/src/molecule/type_components.f90 index c738cc1c..c94a8b93 100644 --- a/src/molecule/type_components.f90 +++ b/src/molecule/type_components.f90 @@ -74,6 +74,7 @@ module molecule_type_components type :: extxyz_properties integer :: n_props = 0 + integer :: total_fields = 0 type(extxyz_property),allocatable :: props(:) end type extxyz_properties @@ -228,19 +229,20 @@ subroutine allocate_extxyz_properties_from_sigs(nat,ext_sigs,ext_props) n_props = ext_sigs%n_props ext_props%n_props = n_props + ext_props%total_fields = ext_sigs%total_fields allocate (ext_props%props(n_props)) do ii = 1,n_props associate (prop => ext_props%props(ii)) prop%signat = ext_sigs%signat(ii) - prop%natoms = nat + prop%natoms = nat n_fields = prop%signat%n_fields - select case(prop%signat%p_type) + select case (prop%signat%p_type) case ('I') - allocate(prop%I(n_fields,nat), source=0) + allocate (prop%I(n_fields,nat),source=0) case ('R') - allocate(prop%R(n_fields,nat), source=0.0_wp) + allocate (prop%R(n_fields,nat),source=0.0_wp) case ('S') - allocate(prop%S(n_fields,nat), source=repeat(' ',32)) + allocate (prop%S(n_fields,nat),source=repeat(' ',32)) end select end associate end do From 07778c7c7c40167704a943ce21434fe68afaab05 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 24 Mar 2026 14:34:07 +0100 Subject: [PATCH 268/374] continue work on extxyz parser --- src/molecule/io.f90 | 84 +++++++++++++++++++++++++++++++++++++++------ 1 file changed, 74 insertions(+), 10 deletions(-) diff --git a/src/molecule/io.f90 b/src/molecule/io.f90 index 47011062..de13d3a3 100644 --- a/src/molecule/io.f90 +++ b/src/molecule/io.f90 @@ -1062,7 +1062,7 @@ subroutine read_extxyz_frame(iunit,ext_sigs,ext_props,success) end if ! 4. Allocate extxyz_properties based on signatures - call allocate_extxyz_properties_from_sigs(nat, ext_sigs, ext_props) + call allocate_extxyz_properties_from_sigs(nat,ext_sigs,ext_props) ! 5. Read Atom Data Lines total_fields = ext_sigs%total_fields @@ -1075,26 +1075,48 @@ subroutine read_extxyz_frame(iunit,ext_sigs,ext_props,success) exit end if - ! 6. Placeholder: Fill entries in extxyz_properties - ! CALL fill_atom_properties(current_line, ext_sigs, ext_props, i) + ! 6. Fill entries in extxyz_properties + call fill_atom_properties(current_line,ext_props,i) end do - - deallocate (line_fields) - end subroutine read_extxyz_frame ! ────────────────────────────────────────────────────────────────────────────── - subroutine fill_atom_properties(current_line,ext_sigs,ext_props,i) + subroutine fill_atom_properties(current_line,ext_props,i) implicit none character(len=*),intent(in) :: current_line - type(extxyz_signatures),intent(in) :: ext_sigs type(extxyz_properties),intent(inout) :: ext_props integer,intent(in) :: i - integer :: ii,jj,kk + integer :: ii,jj,kk,ierr + character(len=32),allocatable :: line_fields(:) + + allocate (line_fields(ext_props%total_fields),source=repeat(' ',32)) - + read (current_line,*,iostat=ierr) line_fields + if (ierr /= 0) then + write (stdout,*) '**ERROR** unexpected line fromat in extxyz parsing for atom',i + end if + do ii = 1,ext_props%n_props + associate (prop => ext_props%props(ii)) + kk = 0 + do jj = 1,prop%signat%n_fields + kk = kk+1 + select case (prop%signat%p_type) + case ('S') + prop%S(jj,i) = trim(line_fields(kk)) + case ('I') + read (line_fields(kk),*,iostat=ierr) prop%I(jj,i) + case ('R') + read (line_fields(kk),*,iostat=ierr) prop%S(jj,i) + end select + if (ierr /= 0) then + write (stdout,*) '**ERROR** unexpected line fromat in extxyz parsing for element',jj,'of atom',i + return + end if + end do + end associate + end do end subroutine fill_atom_properties @@ -1122,6 +1144,48 @@ subroutine get_at_from_ext(ext_props,at) end subroutine get_at_from_ext + subroutine get_xyz_from_ext(ext_props,xyz) + implicit none + type(extxyz_properties) :: ext_props + real(wp),intent(out),allocatable :: xyz(:,:) + + integer :: ii,jj,nat + + do ii = 1,ext_props%n_props + associate (prop => ext_props%props(ii)) + select case (trim(prop%signat%name)) + case ('pos') + nat = prop%natoms + allocate (xyz(3,nat),source=0.0_wp) + do jj = 1,nat + xyz(:,jj) = prop%R(:,jj) + end do + end select + end associate + end do + end subroutine get_xyz_from_ext + + subroutine get_grad_from_ext(ext_props,grad) + implicit none + type(extxyz_properties) :: ext_props + real(wp),intent(out),allocatable :: grad(:,:) + + integer :: ii,jj,nat + + do ii = 1,ext_props%n_props + associate (prop => ext_props%props(ii)) + select case (trim(prop%signat%name)) + case ('forces') + nat = prop%natoms + allocate (grad(3,nat),source=0.0_wp) + do jj = 1,nat + grad(:,jj) = prop%R(:,jj)*(-autoaa/autoeV) + end do + end select + end associate + end do + end subroutine get_grad_from_ext + !=========================================================================================! !=========================================================================================! ! 4. GENERAL UTILITY ROUTINES From 2f2923eb26f6ca10455197b80b3f6356df3ababe Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 24 Mar 2026 16:06:30 +0100 Subject: [PATCH 269/374] Debugging extxyz reader --- src/algos/playground.f90 | 5 +++ src/molecule/io.f90 | 95 +++++++++++++++++++++++++++++++++++----- src/molecule/type.f90 | 27 ++++++++---- 3 files changed, 109 insertions(+), 18 deletions(-) diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index 98df41a5..f9777bba 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -77,7 +77,12 @@ subroutine crest_playground(env,tim) ! call calculation_summary(calc,mol,energy,grad) !========================================================================================! + allocate(mol%gradient(3,mol%nat), source=1.0_wp) + call mol%write('dummy.extxyz') + + call molnew%open("dummy.extxyz") + !call molnew%write("dummy2.extxyz") !========================================================================================! call tim%stop(14) return diff --git a/src/molecule/io.f90 b/src/molecule/io.f90 index de13d3a3..4ad6ad03 100644 --- a/src/molecule/io.f90 +++ b/src/molecule/io.f90 @@ -52,6 +52,7 @@ module molecule_io public :: rdxmolselec !-- read only a certain structure in Xmol file public :: rdPDB public :: read_extxyz_frame + public :: get_at_from_ext,get_xyz_from_ext,get_grad_from_ext !>--- write a TM coord file public :: wrc0 @@ -179,7 +180,7 @@ subroutine rdnat(fname,nat,ftype) open (newunit=ich,file=fname) select case (ftypedum) - case (coordtype%xyz) !--- *.xyz files + case (coordtype%xyz,coordtype%extxyz) !--- *.xyz files read (ich,*,iostat=io) nat case (coordtype%turbomole) !--- TM coord file @@ -1004,13 +1005,15 @@ end subroutine wrsdfV3000_channel ! ────────────────────────────────────────────────────────────────────────────── - subroutine read_extxyz_frame(iunit,ext_sigs,ext_props,success) + subroutine read_extxyz_frame(iunit,ext_sigs,ext_props,energy,lat,success) implicit none ! Formal Arguments integer,intent(in) :: iunit type(extxyz_signatures),intent(inout) :: ext_sigs type(extxyz_properties),intent(inout) :: ext_props + real(wp),intent(out) :: energy + real(wp),intent(out),allocatable :: lat(:,:) logical,intent(out) :: success ! Internal variables @@ -1018,7 +1021,6 @@ subroutine read_extxyz_frame(iunit,ext_sigs,ext_props,success) character(len=5000) :: comment_line character(len=2000) :: val_str logical :: found - real(wp) :: energy real(wp) :: lattice(3,3) real(wp) :: lat_raw(9) character(len=128),allocatable :: line_fields(:) @@ -1042,18 +1044,21 @@ subroutine read_extxyz_frame(iunit,ext_sigs,ext_props,success) ! 3. Extract Key-Value Pairs ! Extract Energy - call get_extxyz_value(comment_line,"energy",val_str,found) + call get_key_value(comment_line,"energy",val_str,found,case_sensitive=.false.) if (found) read (val_str,*) energy ! Extract Lattice - call get_extxyz_value(comment_line,"lattice",val_str,found) + call get_key_value(comment_line,"lattice",val_str,found,case_sensitive=.false.) if (found) then read (val_str,*) lat_raw lattice = reshape(lat_raw, (/3,3/)) + allocate (lat(3,3)) + lat = lattice end if ! Extract and Parse Properties Signature - call get_extxyz_value(comment_line,"properties",val_str,found) + call get_extxyz_value(comment_line,"Properties",val_str,found) + call get_key_value(comment_line,'Properties',val_str,found,case_sensitive=.false.) if (found) then call parse_properties_tag(val_str,ext_sigs) else @@ -1097,9 +1102,9 @@ subroutine fill_atom_properties(current_line,ext_props,i) write (stdout,*) '**ERROR** unexpected line fromat in extxyz parsing for atom',i end if + kk = 0 do ii = 1,ext_props%n_props associate (prop => ext_props%props(ii)) - kk = 0 do jj = 1,prop%signat%n_fields kk = kk+1 select case (prop%signat%p_type) @@ -1108,7 +1113,7 @@ subroutine fill_atom_properties(current_line,ext_props,i) case ('I') read (line_fields(kk),*,iostat=ierr) prop%I(jj,i) case ('R') - read (line_fields(kk),*,iostat=ierr) prop%S(jj,i) + read (line_fields(kk),*,iostat=ierr) prop%R(jj,i) end select if (ierr /= 0) then write (stdout,*) '**ERROR** unexpected line fromat in extxyz parsing for element',jj,'of atom',i @@ -1136,7 +1141,7 @@ subroutine get_at_from_ext(ext_props,at) nat = prop%natoms allocate (at(nat),source=0) do jj = 1,nat - at(jj) = e2i(prop%S(1,jj)) + at(jj) = e2i(trim(prop%S(1,jj))) end do end select end associate @@ -1158,7 +1163,7 @@ subroutine get_xyz_from_ext(ext_props,xyz) nat = prop%natoms allocate (xyz(3,nat),source=0.0_wp) do jj = 1,nat - xyz(:,jj) = prop%R(:,jj) + xyz(:,jj) = prop%R(:,jj)*aatoau end do end select end associate @@ -1489,6 +1494,76 @@ subroutine get_extxyz_value(comment_line,key,value,found) end if end subroutine get_extxyz_value + subroutine get_key_value(input_str,key,value,success,case_sensitive) + implicit none + + ! Arguments + character(len=*),intent(in) :: input_str ! The full string to search + character(len=*),intent(in) :: key ! The key to look for + character(len=*),intent(out) :: value ! The extracted value + logical,intent(out) :: success ! True if found and parsed + logical,intent(in),optional :: case_sensitive ! Toggle case sensitivity + + ! Internal variables + integer :: key_len,str_len,start_pos,val_start,val_end + character(len=len(input_str)) :: search_str,search_key + character(len=1) :: quote_char + logical :: sensitive + + ! Initialize + success = .false. + value = "" + sensitive = .true. + if (present(case_sensitive)) sensitive = case_sensitive + + key_len = len_trim(key) + str_len = len_trim(input_str) + + ! Prepare strings for case-insensitive search if requested + if (.not.sensitive) then + search_str = lowercase(input_str) + search_key = lowercase(key) + else + search_str = input_str + search_key = key + end if + + ! Find key followed immediately by '=' + ! Note: Searching for 'key=' to satisfy the "no whitespace" requirement + start_pos = index(search_str,trim(search_key)//'=') + + if (start_pos > 0) then + ! Value starts right after 'key=' + val_start = start_pos+key_len+1 + + ! Check for quotes + quote_char = input_str(val_start:val_start) + + if (quote_char == '"'.or.quote_char == "'") then + ! Handle quoted value + val_start = val_start+1 + ! Find the closing quote starting from the next character + val_end = index(input_str(val_start:),quote_char) + + if (val_end > 0) then + val_end = val_start+val_end-2 + value = input_str(val_start:val_end) + success = .true. + end if + else + ! Handle unquoted value (extract until next space or end of string) + val_end = index(input_str(val_start:)," ") + if (val_end == 0) then + val_end = str_len + else + val_end = val_start+val_end-2 + end if + value = input_str(val_start:val_end) + success = .true. + end if + end if + end subroutine get_key_value + ! ────────────────────────────────────────────────────────────────────────────── function count_extxyz_pairs(comment_line) result(num_pairs) diff --git a/src/molecule/type.f90 b/src/molecule/type.f90 index c42d88d4..2088a43e 100644 --- a/src/molecule/type.f90 +++ b/src/molecule/type.f90 @@ -64,7 +64,7 @@ module molecule_type !>-- multiplicity information integer :: uhf = 0 !>--- gradient - real(wp),allocatable :: grad(:,:) + !real(wp),allocatable :: grad(:,:) !>-- number of bonds integer :: nbd = 0 !>-- bond info @@ -134,6 +134,8 @@ subroutine opencoord(self,fname) integer :: nat integer,allocatable :: at(:) real(wp),allocatable :: xyz(:,:) + real(wp),allocatable :: grad(:,:) + real(wp),allocatable :: lat(:,:) integer :: ftype integer :: i,j,k,ich,io,iunit logical :: ex,success @@ -161,15 +163,24 @@ subroutine opencoord(self,fname) xyz = xyz/bohr case (coordtype%extxyz) - open(newunit=iunit,file=fname) - call read_extxyz_frame(iunit,ext_sigs,ext_props,success) - close(iunit) - if(success)then - - endif + open (newunit=iunit,file=fname) + call read_extxyz_frame(iunit,ext_sigs,ext_props,en,lat,success) + close (iunit) + if (success) then + call get_at_from_ext(ext_props,at) + call get_xyz_from_ext(ext_props,xyz) + call get_grad_from_ext(ext_props,grad) + self%nat = nat + self%energy = en + call move_alloc(at,self%at) + call move_alloc(xyz,self%xyz) + if(allocated(lat)) call move_alloc(lat,self%lat) + if(allocated(grad)) call move_alloc(grad,self%gradient) + end if case default call rdcoord(fname,nat,at,xyz,energy=en,ftype=ftype) + end select self%nat = nat self%energy = en @@ -379,7 +390,7 @@ subroutine write_extxyz(self,iunit) else write (atmp,'("species:S:1:pos:R:3")') end if - write (iunit,'(a,a,a)',advance='no') 'Properties=',trim(atmp),' ' + write (iunit,'(a,a,a)',advance='no') 'Properties=',trim(atmp),' ' write (iunit,*) !> coord block From 44453d6d0abf9bff90f19b3fdbe1454c814d77d9 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 24 Mar 2026 17:30:45 +0100 Subject: [PATCH 270/374] extxyz printout for crestopt.log.xyz files --- src/algos/playground.f90 | 2 +- src/calculator/calc_type.f90 | 1 + src/calculator/calculator.F90 | 10 ++++++ src/molecule/io.f90 | 7 ----- src/molecule/type.f90 | 53 +++++++++++++++++++------------- src/optimize/ancopt.f90 | 27 +++++----------- src/optimize/gd.f90 | 1 + src/optimize/lbfgs.f90 | 4 +++ src/optimize/newton_raphson.f90 | 5 +-- src/optimize/optimize_module.f90 | 1 + src/optimize/rfo.f90 | 1 + 11 files changed, 61 insertions(+), 51 deletions(-) diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index f9777bba..dfa8bda5 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -82,7 +82,7 @@ subroutine crest_playground(env,tim) call molnew%open("dummy.extxyz") - !call molnew%write("dummy2.extxyz") + call molnew%write("dummy2.extxyz") !========================================================================================! call tim%stop(14) return diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 76aa0073..f8708236 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -275,6 +275,7 @@ module calc_type integer :: opt_engine = 0 !> default: ANCOPT integer :: lbfgs_histsize = 20 !> L-BFGS history size integer :: hess_init = 5 !> Initialization of the hessian, standard modhess lindh95 + logical :: logextxyz = .true. !> write extended xyz files from optimization trajectories !>--- GFN0* data, needed for special MECP application type(gfn0_data),allocatable :: g0calc diff --git a/src/calculator/calculator.F90 b/src/calculator/calculator.F90 index 498f8293..6aebaa71 100644 --- a/src/calculator/calculator.F90 +++ b/src/calculator/calculator.F90 @@ -308,6 +308,16 @@ subroutine engrad_mol(mol,calc,energy,gradient,iostatus) end if end if +!********************************************* +!>--- store some outptut data to mol itself? +!********************************************* + mol%energy = energy + if (allocated(mol%gradient).or.mol%wrextxyz) then + !$omp critical + mol%gradient = gradient + !$omp end critical + end if + return end subroutine engrad_mol diff --git a/src/molecule/io.f90 b/src/molecule/io.f90 index 4ad6ad03..e4d5f7ac 100644 --- a/src/molecule/io.f90 +++ b/src/molecule/io.f90 @@ -1131,9 +1131,7 @@ subroutine get_at_from_ext(ext_props,at) implicit none type(extxyz_properties) :: ext_props integer,intent(out),allocatable :: at(:) - integer :: ii,jj,nat - do ii = 1,ext_props%n_props associate (prop => ext_props%props(ii)) select case (trim(prop%signat%name)) @@ -1146,16 +1144,13 @@ subroutine get_at_from_ext(ext_props,at) end select end associate end do - end subroutine get_at_from_ext subroutine get_xyz_from_ext(ext_props,xyz) implicit none type(extxyz_properties) :: ext_props real(wp),intent(out),allocatable :: xyz(:,:) - integer :: ii,jj,nat - do ii = 1,ext_props%n_props associate (prop => ext_props%props(ii)) select case (trim(prop%signat%name)) @@ -1174,9 +1169,7 @@ subroutine get_grad_from_ext(ext_props,grad) implicit none type(extxyz_properties) :: ext_props real(wp),intent(out),allocatable :: grad(:,:) - integer :: ii,jj,nat - do ii = 1,ext_props%n_props associate (prop => ext_props%props(ii)) select case (trim(prop%signat%name)) diff --git a/src/molecule/type.f90 b/src/molecule/type.f90 index 2088a43e..49c85bd0 100644 --- a/src/molecule/type.f90 +++ b/src/molecule/type.f90 @@ -170,12 +170,8 @@ subroutine opencoord(self,fname) call get_at_from_ext(ext_props,at) call get_xyz_from_ext(ext_props,xyz) call get_grad_from_ext(ext_props,grad) - self%nat = nat - self%energy = en - call move_alloc(at,self%at) - call move_alloc(xyz,self%xyz) - if(allocated(lat)) call move_alloc(lat,self%lat) - if(allocated(grad)) call move_alloc(grad,self%gradient) + if (allocated(lat)) call move_alloc(lat,self%lat) + if (allocated(grad)) call move_alloc(grad,self%gradient) end if case default @@ -515,16 +511,21 @@ subroutine appendcoord(self,io) integer :: io character(len=64) :: atmp character(len=32) :: btmp - self%xyz = self%xyz*bohr !to Angström - write (btmp,'(f22.10)') self%energy - write (atmp,'(a,a)') ' energy= ',adjustl(btmp) - if (allocated(self%comment)) then - call wrxyz(io,self%nat,self%at,self%xyz, & - & trim(atmp)//' '//trim(self%comment)) + if (.not.self%wrextxyz) then !> regular xyz append + self%xyz = self%xyz*bohr !to Angström + write (btmp,'(f22.10)') self%energy + write (atmp,'(a,a)') ' energy= ',adjustl(btmp) + if (allocated(self%comment)) then + call wrxyz(io,self%nat,self%at,self%xyz, & + & trim(atmp)//' '//trim(self%comment)) + else + call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) + end if + self%xyz = self%xyz/bohr !back else - call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) + !> extxyz append + call self%writeextxyz(io) end if - self%xyz = self%xyz/bohr !back return end subroutine appendcoord @@ -536,16 +537,24 @@ subroutine appendlog(self,io,energy,gnorm) real(wp),optional :: energy real(wp),optional :: gnorm character(len=64) :: atmp - self%xyz = self%xyz*bohr !to Angström - if (present(gnorm).and.present(energy)) then - write (atmp,'(a,f22.10,a,f16.8)') ' energy= ',energy,' grad.norm.= ',gnorm - else if (present(energy)) then - write (atmp,'(a,f22.10)') ' energy= ',energy + real(wp) :: etmp,gtmp + if (.not.self%wrextxyz) then + self%xyz = self%xyz*bohr !to Angström + if (present(gnorm).and.present(energy)) then + write (atmp,'(a,f22.10,a,f16.8)') ' energy= ',energy,' grad.norm.= ',gnorm + else if (present(energy)) then + write (atmp,'(a,f22.10)') ' energy= ',energy + else + atmp = '' + end if + call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) + self%xyz = self%xyz/bohr !back else - atmp = '' + etmp = self%energy + if(present(energy)) self%energy = energy + call self%writeextxyz(io) + self%energy = etmp end if - call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) - self%xyz = self%xyz/bohr !back return end subroutine appendlog diff --git a/src/optimize/ancopt.f90 b/src/optimize/ancopt.f90 index 36e7a23f..2fbfee9f 100644 --- a/src/optimize/ancopt.f90 +++ b/src/optimize/ancopt.f90 @@ -1,7 +1,7 @@ !================================================================================! ! This file is part of crest. ! -! Copyright (C) 2021 - 2022 Philipp Pracht +! Copyright (C) 2021 - 2026 Philipp Pracht ! ! crest is free software: you can redistribute it and/or modify it under ! the terms of the GNU Lesser General Public License as published by @@ -122,7 +122,7 @@ subroutine ancopt(mol,calc,etot,grd,pr,wr,iostatus) hmax = calc%hmax_opt maxdispl = calc%maxdispl_opt s6 = mhset%s6 !> slightly better than 30 for various proteins - mhset%model=calc%mh_type + mhset%model = calc%mh_type !> initial number of steps in relax() routine before !> new ANC are made by model Hessian @@ -167,6 +167,7 @@ subroutine ancopt(mol,calc,etot,grd,pr,wr,iostatus) molopt%nat = mol%nat molopt%at = mol%at molopt%xyz = mol%xyz + molopt%wrextxyz = calc%logextxyz estart = etot !>--- initialize .log file, if desired @@ -428,18 +429,6 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & exit main_loop end if - !if (present(avconv)) then - ! call avconv%set_eg_log(energy,gnorm) - ! energy = avconv%get_averaged_energy() - ! gnorm = avconv%get_averaged_gradient() - ! if (pr) then - ! write (*,'("av. E:",1x,f14.7,1x,"->",1x,f14.7)') & - ! avconv%elog(avconv%nlog),energy - ! write (*,'("av. G:",1x,f14.7,1x,"->",1x,f14.7)') & - ! avconv%glog(avconv%nlog),gnorm - ! end if - !end if - !>--- check for convergence gchng = gnorm-gnold echng = energy-eold @@ -644,12 +633,12 @@ function alp_generate(gnorm) result(alp) !**************************************************** !* Computes stepsize scaling factor !**************************************************** - real(wp), intent(in) :: gnorm - real(wp) :: alp, shift, l, k + real(wp),intent(in) :: gnorm + real(wp) :: alp,shift,l,k - l=2.0_wp - k=2000.0 - shift=0.0005 + l = 2.0_wp + k = 2000.0 + shift = 0.0005 alp = L/(1+euler**(k*(gnorm-shift)))+1 diff --git a/src/optimize/gd.f90 b/src/optimize/gd.f90 index 7de349f5..17f5a653 100644 --- a/src/optimize/gd.f90 +++ b/src/optimize/gd.f90 @@ -153,6 +153,7 @@ subroutine gradientdescent(mol,calc,etot,grd,pr,wr,iostatus) molopt%nat = mol%nat molopt%at = mol%at molopt%xyz = mol%xyz + molopt%wrextxyz = calc%logextxyz estart = etot gnorm = 0.0_wp depred = 0.0_wp diff --git a/src/optimize/lbfgs.f90 b/src/optimize/lbfgs.f90 index 2fea6756..5fe2ee86 100644 --- a/src/optimize/lbfgs.f90 +++ b/src/optimize/lbfgs.f90 @@ -168,8 +168,12 @@ subroutine lbfgs_optimize(mol,calc,etot,grd,pr,io) econverged = .false. gconverged = .false. converged = .false. + mol%wrextxyz = calc%logextxyz open (newunit=ilog,file='crestopt.log.xyz') + if(calc%logextxyz)then + mol%gradient = grd + endif call mol%appendlog(ilog,etot) !$omp critical diff --git a/src/optimize/newton_raphson.f90 b/src/optimize/newton_raphson.f90 index 1ea8f511..35390a9e 100644 --- a/src/optimize/newton_raphson.f90 +++ b/src/optimize/newton_raphson.f90 @@ -1,7 +1,7 @@ !================================================================================! ! This file is part of crest. ! -! Copyright (C) 2021 - 2022 Philipp Pracht +! Copyright (C) 2026 Lukas Rindt ! ! crest is free software: you can redistribute it and/or modify it under ! the terms of the GNU Lesser General Public License as published by @@ -209,6 +209,7 @@ subroutine newton_raphson(mol,calc,etot,grd,pr,wr,iostatus) molopt%nat = mol%nat molopt%at = mol%at molopt%xyz = mol%xyz + molopt%wrextxyz = calc%logextxyz estart = etot !>--- initialize .log file, if desired @@ -463,4 +464,4 @@ end subroutine newton_raphson !========================================================================================! !========================================================================================! -end module newton_raphson_module \ No newline at end of file +end module newton_raphson_module diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index 89f3b310..eaffa170 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -75,6 +75,7 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) molnew%at = mol%at molnew%xyz = mol%xyz molnew%nat = mol%nat + molnew%wrextxyz = .true. !$omp end critical nat3 = 3*mol%nat diff --git a/src/optimize/rfo.f90 b/src/optimize/rfo.f90 index a5ca3e11..6da0be89 100644 --- a/src/optimize/rfo.f90 +++ b/src/optimize/rfo.f90 @@ -217,6 +217,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) molopt%nat = mol%nat molopt%at = mol%at molopt%xyz = mol%xyz + molopt%wrextxyz = calc%logextxyz estart = etot !energy = etot From 3bbff957622a6673e2dc7c4120e80e63c5181af2 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 24 Mar 2026 21:56:34 +0100 Subject: [PATCH 271/374] extended xyz refactor --- src/dynamics/dynamics_module.f90 | 6 +-- src/molecule/type.f90 | 76 +++++++++++--------------------- 2 files changed, 29 insertions(+), 53 deletions(-) diff --git a/src/dynamics/dynamics_module.f90 b/src/dynamics/dynamics_module.f90 index e3856ebf..e1524d7f 100644 --- a/src/dynamics/dynamics_module.f90 +++ b/src/dynamics/dynamics_module.f90 @@ -330,6 +330,7 @@ subroutine dynamics(mol,dat,calc,pr,term) end if !$omp critical if (dat%wrtrj) open (newunit=trj,file=trajectory) + mol%wrextxyz = calc%logextxyz !$omp end critical !>--- begin printout @@ -449,7 +450,7 @@ subroutine dynamics(mol,dat,calc,pr,term) temp = 2.0_wp*ekin/float(nfreedom)/kB !>--- THERMOSTATING and velocity update - if (dat%thermotype_i == 3)then !'langevin') then + if (dat%thermotype_i == 3) then !'langevin') then if (dat%thermostat) then call langevin_step(mol%nat,dat,mass,velo,acc,tstep_au,vel) else @@ -464,7 +465,7 @@ subroutine dynamics(mol,dat,calc,pr,term) !>--- Using the half-step estimate veln would give Ekin(vel_scaled)=K_new*(Efull/Ehalf) !>--- and systematically overshoot the target temperature by ~Efull/Ehalf. if (dat%thermostat.and. & - & dat%thermotype_i == 4 ) then + & dat%thermotype_i == 4) then !& (trim(dat%thermotype) == 'bussi'.or.trim(dat%thermotype) == 'csvr')) then call ekinet(mol%nat,vel,mass,ekin) temp = 2.0_wp*ekin/float(nfreedom)/kB @@ -1448,7 +1449,6 @@ subroutine md_defaults_fallback(self) end if self%maxblock = nint(self%length_steps/float(self%blockl)) - call thermostat2int(self) end subroutine md_defaults_fallback diff --git a/src/molecule/type.f90 b/src/molecule/type.f90 index 49c85bd0..419a3b42 100644 --- a/src/molecule/type.f90 +++ b/src/molecule/type.f90 @@ -63,8 +63,6 @@ module molecule_type integer :: chrg = 0 !>-- multiplicity information integer :: uhf = 0 - !>--- gradient - !real(wp),allocatable :: grad(:,:) !>-- number of bonds integer :: nbd = 0 !>-- bond info @@ -89,7 +87,7 @@ module molecule_type procedure :: writeextxyz => write_extxyz !> write extxyz file to a given iunit procedure :: append => appendcoord !> append procedure :: get => getcoord !> allocate & fill with data - procedure :: appendlog !> append .log file with coordinates and energy + procedure :: appendlog => appendcoord !> append .log file with coordinates and energy procedure :: dist => coord_getdistance !> calculate distance between two atoms procedure :: angle => coord_getangle !> calculate angle between three atoms procedure :: dihedral => coord_getdihedral !> calculate dihedral angle between four atoms @@ -450,9 +448,12 @@ subroutine coord2xyz(iname,oname) end subroutine coord2xyz ! ────────────────────────────────────────────────────────────────────────────── -! subroutine writecoord -! is the write procedure for the "coord" class. + subroutine writecoord(self,fname) +!************************************************* +!* subroutine writecoord * +!* is the write procedure for the "coord" class. * +!************************************************* implicit none class(coord) :: self character(len=*),intent(in) :: fname @@ -490,73 +491,48 @@ subroutine writecoord(self,fname) call wrc0(iunit,self%nat,self%at,self%xyz) end select close (iunit) - !if (index(fname,'.xyz') .ne. 0) then - ! write (comment,'(a,G0.12)') ' energy= ',self%energy - ! self%xyz = self%xyz*bohr !to Angström - ! call wrxyz(fname,self%nat,self%at,self%xyz,comment) - ! self%xyz = self%xyz/bohr !back - !else - ! call wrc0(fname,self%nat,self%at,self%xyz) - !end if return end subroutine writecoord ! ────────────────────────────────────────────────────────────────────────────── -! subroutine appendcoord -! is the write procedure for the "coord" class. -! coords will be written out in XYZ format! - subroutine appendcoord(self,io) + + subroutine appendcoord(self,iunit,energy) +!************************************************* +!* subroutine appendcoord * +!* is the write procedure for the "coord" class. * +!* coords will be written out in XYZ format! * +!************************************************* implicit none class(coord) :: self - integer :: io + integer,intent(in) :: iunit + real(wp),intent(in),optional :: energy character(len=64) :: atmp character(len=32) :: btmp + real(wp) :: etmp if (.not.self%wrextxyz) then !> regular xyz append self%xyz = self%xyz*bohr !to Angström - write (btmp,'(f22.10)') self%energy + if (present(energy)) then + write (btmp,'(f22.10)') energy + else + write (btmp,'(f22.10)') self%energy + end if write (atmp,'(a,a)') ' energy= ',adjustl(btmp) if (allocated(self%comment)) then - call wrxyz(io,self%nat,self%at,self%xyz, & + call wrxyz(iunit,self%nat,self%at,self%xyz, & & trim(atmp)//' '//trim(self%comment)) else - call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) + call wrxyz(iunit,self%nat,self%at,self%xyz,trim(atmp)) end if self%xyz = self%xyz/bohr !back else !> extxyz append - call self%writeextxyz(io) - end if - return - end subroutine appendcoord - -! ────────────────────────────────────────────────────────────────────────────── - subroutine appendlog(self,io,energy,gnorm) - implicit none - class(coord) :: self - integer :: io - real(wp),optional :: energy - real(wp),optional :: gnorm - character(len=64) :: atmp - real(wp) :: etmp,gtmp - if (.not.self%wrextxyz) then - self%xyz = self%xyz*bohr !to Angström - if (present(gnorm).and.present(energy)) then - write (atmp,'(a,f22.10,a,f16.8)') ' energy= ',energy,' grad.norm.= ',gnorm - else if (present(energy)) then - write (atmp,'(a,f22.10)') ' energy= ',energy - else - atmp = '' - end if - call wrxyz(io,self%nat,self%at,self%xyz,trim(atmp)) - self%xyz = self%xyz/bohr !back - else etmp = self%energy - if(present(energy)) self%energy = energy - call self%writeextxyz(io) + if (present(energy)) self%energy = energy + call self%writeextxyz(iunit) self%energy = etmp end if return - end subroutine appendlog + end subroutine appendcoord ! ══════════════════════════════════════════════════════════════════════════════ ! GENERAL UTILITY ROUTINES From fc080e27ea6e069627a24782630ba3b18a85bbbf Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 24 Mar 2026 23:03:05 +0100 Subject: [PATCH 272/374] ensemble reader function extended xyz --- src/algos/playground.f90 | 9 +++ src/molecule/io.f90 | 33 +++++++---- src/molecule/type.f90 | 2 +- src/molecule/type_ensemble.f90 | 104 +++++++++++++++++++++++---------- 4 files changed, 106 insertions(+), 42 deletions(-) diff --git a/src/algos/playground.f90 b/src/algos/playground.f90 index dfa8bda5..82abf58d 100644 --- a/src/algos/playground.f90 +++ b/src/algos/playground.f90 @@ -83,6 +83,15 @@ subroutine crest_playground(env,tim) call molnew%open("dummy.extxyz") call molnew%write("dummy2.extxyz") + + + block + type(coord),allocatable :: structures(:) + integer :: nall + call rdensemble(env%inputcoords,nall,structures) + write(*,*) nall,'structures read from ',env%inputcoords + call wrensemble('dummyensemble.xyz',nall,structures) + end block !========================================================================================! call tim%stop(14) return diff --git a/src/molecule/io.f90 b/src/molecule/io.f90 index e4d5f7ac..ea93ddcb 100644 --- a/src/molecule/io.f90 +++ b/src/molecule/io.f90 @@ -33,7 +33,7 @@ module molecule_io !>--- private utility subroutines private :: upperCase,lowerCase - private :: convertlable,fextension,sgrep + private :: convertlable,fextension ! ────────────────────────────────────────────────────────────────────────────── !>--- public subroutines @@ -90,6 +90,7 @@ module molecule_io public :: wrsdfV3000 public :: coordline + public :: sgrep public :: get_atlist public :: sumform @@ -1005,19 +1006,20 @@ end subroutine wrsdfV3000_channel ! ────────────────────────────────────────────────────────────────────────────── - subroutine read_extxyz_frame(iunit,ext_sigs,ext_props,energy,lat,success) + subroutine read_extxyz_frame(iunit,ext_sigs,ext_props,nat,energy,lat,success) implicit none ! Formal Arguments integer,intent(in) :: iunit - type(extxyz_signatures),intent(inout) :: ext_sigs - type(extxyz_properties),intent(inout) :: ext_props + type(extxyz_signatures),intent(out) :: ext_sigs + type(extxyz_properties),intent(out) :: ext_props + integer,intent(out) :: nat real(wp),intent(out) :: energy real(wp),intent(out),allocatable :: lat(:,:) logical,intent(out) :: success ! Internal variables - integer :: nat,i,ierr,total_fields + integer :: i,ierr,total_fields character(len=5000) :: comment_line character(len=2000) :: val_str logical :: found @@ -1367,7 +1369,8 @@ function sgrep(fname,key,casesensitive) character(len=*),intent(in) :: key logical,intent(in),optional :: casesensitive logical :: sgrep,ex - character(len=256) :: atmp + logical :: convert = .false. + character(len=5000) :: atmp character(len=:),allocatable :: kkey integer :: ic,io sgrep = .false. @@ -1375,15 +1378,25 @@ function sgrep(fname,key,casesensitive) if (.not.ex) return kkey = trim(key) if (present(casesensitive)) then - if (.not.casesensitive) kkey = lowercase(key) + if (.not.casesensitive)then + kkey = lowercase(key) + convert = .true. + endif end if open (newunit=ic,file=fname) do read (ic,'(a)',iostat=io) atmp if (io < 0) exit !EOF - if (index(atmp,kkey) .ne. 0) then - sgrep = .true. - exit + if (convert) then + if (index(lowercase(atmp),kkey) .ne. 0) then + sgrep = .true. + exit + end if + else + if (index(atmp,kkey) .ne. 0) then + sgrep = .true. + exit + end if end if end do close (ic) diff --git a/src/molecule/type.f90 b/src/molecule/type.f90 index 419a3b42..dd31d269 100644 --- a/src/molecule/type.f90 +++ b/src/molecule/type.f90 @@ -162,7 +162,7 @@ subroutine opencoord(self,fname) case (coordtype%extxyz) open (newunit=iunit,file=fname) - call read_extxyz_frame(iunit,ext_sigs,ext_props,en,lat,success) + call read_extxyz_frame(iunit,ext_sigs,ext_props,nat,en,lat,success) close (iunit) if (success) then call get_at_from_ext(ext_props,at) diff --git a/src/molecule/type_ensemble.f90 b/src/molecule/type_ensemble.f90 index eea37f1b..c47ad838 100644 --- a/src/molecule/type_ensemble.f90 +++ b/src/molecule/type_ensemble.f90 @@ -17,11 +17,23 @@ ! along with crest. If not, see . !================================================================================! + + +! ══════════════════════════════════════════════════════════════════════════════ +! +! NOTE: While there are the two types "ensemble" and "mollist", the best way +! to handle a list of structures is as "type(coord),allocatable :: structures(:)" +! which is mapped in the rdensemble_coord_type routine to rdensemble. +! Both of the other types wrap that, but it would be better to not use them. +! +! ────────────────────────────────────────────────────────────────────────────── + module molecule_type_ensemble use iso_c_binding use molecule_parameters use molecule_io use molecule_type + use molecule_type_components implicit none ! ══════════════════════════════════════════════════════════════════════════════ @@ -393,13 +405,15 @@ subroutine rdensemble_mixed2(fname,natmax,nall,nats,ats,xyz,comments) return end subroutine rdensemble_mixed2 -!========================================================================================! +! ══════════════════════════════════════════════════════════════════════════════ +!> most important routine in this module: read into a list of coord objects! +! ══════════════════════════════════════════════════════════════════════════════ subroutine rdensemble_coord_type(fname,nall,structures) -!********************************************************* -!* subroutine rdensemble_coord_type -!* A variant of the rdensemble routine that automatically -!* produces an array of coord containers -!********************************************************* +!********************************************************** +!* subroutine rdensemble_coord_type * +!* A variant of the rdensemble routine that automatically * +!* produces an array of coord containers * +!********************************************************** implicit none character(len=*),intent(in) :: fname !> name of the ensemble file integer,intent(out) :: nall !> number of structures in ensemble @@ -412,32 +426,63 @@ subroutine rdensemble_coord_type(fname,nall,structures) integer,allocatable :: ats(:,:) real(wp),allocatable :: eread(:) character(len=512),allocatable :: comments(:) - integer :: i,j,k,ich,io,nat_i - logical :: ex,multiple_sizes + integer :: i,j,k,ich,io,nat_i,iunit,ii + logical :: ex,multiple_sizes,is_extxyz,success + + type(extxyz_signatures) :: ext_sigs + type(extxyz_properties) :: ext_props + real(wp),allocatable :: exyz(:,:),egrd(:,:),lat(:,:) + integer,allocatable :: eat(:) + reaL(wp) :: energy + + is_extxyz = sgrep(fname,'Properties=',casesensitive=.false.) call rdensembleparam(fname,nat,nall,multiple_sizes) - !>--- multiple sizes + + !>--- multiple sizes possible allocate (structures(nall)) - allocate (xyz(3,nat,nall),ats(nat,nall),nats(nall),eread(nall)) - allocate (comments(nall)) - call rdensemble_mixed2(fname,nat,nall,nats,ats,xyz,comments) - !>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<--- Important: coord types must be in Bohrs - xyz = xyz/bohr - !>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<-- extended xyz case + open (newunit=iunit,file=trim(fname)) + do ii = 1,nall + call read_extxyz_frame(iunit,ext_sigs,ext_props,nat,energy,lat,success) + if (success) then + call get_at_from_ext(ext_props,eat) + call get_xyz_from_ext(ext_props,exyz) + call get_grad_from_ext(ext_props,egrd) + if (allocated(eat)) call move_alloc(eat,structures(ii)%at) + if(allocated(exyz)) call move_alloc(exyz,structures(ii)%xyz) + if (allocated(lat)) call move_alloc(lat,structures(ii)%lat) + if (allocated(egrd)) call move_alloc(egrd,structures(ii)%gradient) + structures(ii)%energy = energy + structures(ii)%wrextxyz = .true. + structures(ii)%nat = nat + end if + end do + close (iunit) + else + !>-- regular xyz case + allocate (xyz(3,nat,nall),ats(nat,nall),nats(nall),eread(nall)) + allocate (comments(nall)) + call rdensemble_mixed2(fname,nat,nall,nats,ats,xyz,comments) + !>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<--- Important: coord types must be in Bohrs + xyz = xyz/bohr + !>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<< Date: Wed, 25 Mar 2026 18:37:40 +0100 Subject: [PATCH 273/374] update dftd4 subproject across builds --- .gitmodules | 1 + config/modules/Finddftd4.cmake | 2 +- subprojects/dftd4 | 2 +- subprojects/dftd4.wrap | 2 +- 4 files changed, 4 insertions(+), 3 deletions(-) diff --git a/.gitmodules b/.gitmodules index 2d9e347a..36ee875d 100644 --- a/.gitmodules +++ b/.gitmodules @@ -31,6 +31,7 @@ [submodule "subprojects/dftd4"] path = subprojects/dftd4 url = https://github.com/dftd4/dftd4 + branch = main [submodule "subprojects/mctc-lib"] path = subprojects/mctc-lib url = https://github.com/grimme-lab/mctc-lib.git diff --git a/config/modules/Finddftd4.cmake b/config/modules/Finddftd4.cmake index 5d5edc91..c66d1ad2 100644 --- a/config/modules/Finddftd4.cmake +++ b/config/modules/Finddftd4.cmake @@ -17,7 +17,7 @@ set(_lib "dftd4") set(_pkg "DFTD4") set(_url "https://github.com/dftd4/dftd4") -set(_branch "v3.7.0") +set(_branch "v4.0.0") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") diff --git a/subprojects/dftd4 b/subprojects/dftd4 index 7b2ff85a..f02a65f7 160000 --- a/subprojects/dftd4 +++ b/subprojects/dftd4 @@ -1 +1 @@ -Subproject commit 7b2ff85a71a3630808fd8a2d972933f75b743f3c +Subproject commit f02a65f71d82a8cd814c7f6878f51044a889bae3 diff --git a/subprojects/dftd4.wrap b/subprojects/dftd4.wrap index 5b935577..6b08287a 100644 --- a/subprojects/dftd4.wrap +++ b/subprojects/dftd4.wrap @@ -1,6 +1,6 @@ [wrap-git] url = https://github.com/dftd4/dftd4 -revision = head +revision = v4.0.0 clone-recursive = true [provide] From d459b1ebadd006237415a942142316cd54fba367 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 25 Mar 2026 18:50:24 +0100 Subject: [PATCH 274/374] Update multicharge subproject to v0.5.0 --- config/modules/Findmulticharge.cmake | 2 +- subprojects/multicharge | 2 +- subprojects/multicharge.wrap | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/config/modules/Findmulticharge.cmake b/config/modules/Findmulticharge.cmake index 5f23d6a9..fd7d54bd 100644 --- a/config/modules/Findmulticharge.cmake +++ b/config/modules/Findmulticharge.cmake @@ -1,7 +1,7 @@ set(_lib "multicharge") set(_pkg "MULTICHARGE") set(_url "https://github.com/grimme-lab/multicharge") -set(_branch "v0.3.0") +set(_branch "v0.5.0") # Discovery method order can be overridden by the parent project, e.g.: # set(multicharge_FIND_METHOD "subproject" "cmake") diff --git a/subprojects/multicharge b/subprojects/multicharge index 282626e6..6a5d63f9 160000 --- a/subprojects/multicharge +++ b/subprojects/multicharge @@ -1 +1 @@ -Subproject commit 282626e690aa7db2aec448d9032636a5cd75f25c +Subproject commit 6a5d63f9e9e29dcf13cc47cc27f33bf9015681bf diff --git a/subprojects/multicharge.wrap b/subprojects/multicharge.wrap index da33639c..a77f7290 100644 --- a/subprojects/multicharge.wrap +++ b/subprojects/multicharge.wrap @@ -1,6 +1,6 @@ [wrap-git] url = https://github.com/grimme-lab/multicharge -revision = head +revision = v0.5.0 clone-recursive = true [provide] From 8ec292054b6c977f7bf9ba6cabe3d21d38cbc086 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 25 Mar 2026 19:03:52 +0100 Subject: [PATCH 275/374] Update toml-f subproject --- subprojects/toml-f | 2 +- subprojects/toml-f.wrap | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/subprojects/toml-f b/subprojects/toml-f index 056d3620..d37d83f5 160000 --- a/subprojects/toml-f +++ b/subprojects/toml-f @@ -1 +1 @@ -Subproject commit 056d3620dcc925d2f94d09b80f6b6c29b99eaab6 +Subproject commit d37d83f5a8d65100f8548a64d9f97c7e1c57ca2f diff --git a/subprojects/toml-f.wrap b/subprojects/toml-f.wrap index 2045c395..0193de1c 100644 --- a/subprojects/toml-f.wrap +++ b/subprojects/toml-f.wrap @@ -1,6 +1,6 @@ [wrap-git] url = https://github.com/toml-f/toml-f -revision = head +revision = v0.4.3 clone-recursive = true [provide] From 3610d80ce2e3be1e52c6ffc1adcd30e9cc657af8 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 25 Mar 2026 19:17:05 +0100 Subject: [PATCH 276/374] Add tblite fixes because of newer version --- src/calculator/tblite_api.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/calculator/tblite_api.F90 b/src/calculator/tblite_api.F90 index a3a35697..70bf62ef 100644 --- a/src/calculator/tblite_api.F90 +++ b/src/calculator/tblite_api.F90 @@ -384,7 +384,7 @@ subroutine tblite_singlepoint(mol,chrg,uhf,tblite,energy,gradient,iostatus) call ceh_singlepoint(tblite%ctx,tblite%calc,mctcmol,tblite%wfn, & & tblite%accuracy,verbosity) case (xtblvl%eeq) - call eeq_guess(mctcmol,tblite%calc,tblite%wfn) + call eeq_guess(mctcmol,tblite%calc,tblite%wfn,error) end select if (tblite%ctx%failed()) then @@ -446,7 +446,7 @@ subroutine tblite_addsettings(tblite,maxscc,rdwbo,saveint,accuracy) logical,intent(in) :: saveint real(wp),intent(in) :: accuracy #ifdef WITH_TBLITE - tblite%calc%max_iter = maxscc + tblite%calc%iterator%max_iter = maxscc tblite%calc%save_integrals = (rdwbo.or.saveint) tblite%accuracy = accuracy #endif From 96df0f904532b54d5ba4e62e5fa81d9a79dbd85f Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 25 Mar 2026 20:11:18 +0100 Subject: [PATCH 277/374] gxtb-tblite calculator setup... still some energy difference compared to the tblite app --- CMakeLists.txt | 10 +++++++++- config/CMakeLists.txt | 1 + meson.build | 8 ++++++++ meson_options.txt | 5 +++++ src/calculator/calc_type.f90 | 22 +++++++++++++--------- src/calculator/tblite_api.F90 | 14 ++++++++++++++ src/confparse.f90 | 4 +++- src/parsing/parse_calcdata.f90 | 23 +++++++++++++++-------- src/printouts.f90 | 28 ++++++++++++++++------------ 9 files changed, 84 insertions(+), 31 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 19f1d780..4749868e 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -93,13 +93,21 @@ endif() if(NOT TARGET "tblite::tblite" AND WITH_TBLITE) find_package("mctc-lib" REQUIRED) find_package("mstore" REQUIRED) - find_package("multicharge" REQUIRED) + find_package("multicharge" REQUIRED) find_package("dftd4" REQUIRED) find_package("s-dftd3" REQUIRED) find_package("tblite" REQUIRED) add_compile_definitions(WITH_TBLITE) endif() +# g-xTB via tblite +if(WITH_GXTB) + if(NOT WITH_TBLITE) + message(FATAL_ERROR "WITH_GXTB requires WITH_TBLITE to be enabled") + endif() + add_compile_definitions(WITH_GXTB) +endif() + # GFN-FF if(NOT TARGET "gfnff::gfnff" AND WITH_GFNFF) find_package("gfnff" REQUIRED) diff --git a/config/CMakeLists.txt b/config/CMakeLists.txt index 3c1579e7..d694af6a 100644 --- a/config/CMakeLists.txt +++ b/config/CMakeLists.txt @@ -31,6 +31,7 @@ install( # Options for enabling or disabling features option(WITH_OpenMP "Enable OpenMP support" TRUE) option(WITH_TBLITE "Enable support for tblite" TRUE) +option(WITH_GXTB "Enable g-xTB via tblite (requires WITH_TBLITE)" TRUE) option(WITH_TOMLF "Enable support for toml-f" TRUE) option(WITH_GFN0 "Enable support for GFN0-xTB" TRUE) option(WITH_GFNFF "Enable support for GFN-FF" TRUE) diff --git a/meson.build b/meson.build index 4b6d5a75..b80259af 100644 --- a/meson.build +++ b/meson.build @@ -233,6 +233,14 @@ if with_tblite add_project_arguments('-DWITH_TBLITE', language : ['c', 'fortran']) endif +with_gxtb = get_option('gxtb') +if with_gxtb + if not with_tblite + error('gxtb requires tblite to be enabled') + endif + add_project_arguments('-DWITH_GXTB', language : ['c', 'fortran']) +endif + gfnff_dep = dependency('gfnff', fallback : ['gfnff', 'gfnff_dep'], required : get_option('gfnff'), diff --git a/meson_options.txt b/meson_options.txt index 6274b9f0..25ed2cc7 100644 --- a/meson_options.txt +++ b/meson_options.txt @@ -47,6 +47,11 @@ option('tblite', value : 'auto', description : 'Enable tblite semiempirical library', ) +option('gxtb', + type : 'boolean', + value : true, + description : 'Enable g-xTB via tblite (requires tblite)', +) option('toml-f', type : 'feature', value : 'auto', diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index f8708236..f9ab3819 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -1413,15 +1413,19 @@ subroutine create_calclevel_shortcut(self,levelstring, & self%id = jobtype%turbomole self%rdgrad = .false. self%binary = 'gp3' - case ('gxtb','gxtb_dev') - self%id = jobtype%turbomole - self%rdgrad = .false. - self%binary = 'gxtb' - self%rdwbo = .false. - if (index(levelstring,'_dev') .ne. 0) then - self%other = '-grad' - self%rdgrad = .true. - end if + case ('gxtb','--gxtb') + self%id = jobtype%tblite + self%tblitelvl = xtblvl%gxtb +! case ('gxtb','--gxtb','gxtb_dev') +! !> fallback: system call (requires gxtb binary in PATH) +! self%id = jobtype%turbomole +! self%rdgrad = .false. +! self%binary = 'gxtb' +! self%rdwbo = .false. +! if (index(levelstring,'_dev') .ne. 0) then +! self%other = '-grad' +! self%rdgrad = .true. +! end if case ('orca') self%id = jobtype%orca diff --git a/src/calculator/tblite_api.F90 b/src/calculator/tblite_api.F90 index 70bf62ef..bed27285 100644 --- a/src/calculator/tblite_api.F90 +++ b/src/calculator/tblite_api.F90 @@ -34,6 +34,9 @@ module tblite_api use tblite_wavefunction,only:sad_guess,eeq_guess,shell_partition use tblite_xtb,xtb_calculator => xtb_calculator use tblite_xtb_calculator,only:new_xtb_calculator +#ifdef WITH_GXTB + use tblite_xtb,only:new_gxtb_calculator +#endif use tblite_param,only:param_record use tblite_results,only:tblite_resultstype => results_type use tblite_wavefunction_mulliken,only:get_molecular_dipole_moment @@ -86,6 +89,7 @@ module tblite_api integer :: eeq = 4 integer :: ceh = 5 integer :: param = 6 + integer :: gxtb = 7 end type enum_tblite_method type(enum_tblite_method),parameter,public :: xtblvl = enum_tblite_method() @@ -167,6 +171,16 @@ subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite,ceh_guess) if (pr) call tblite%ctx%message("tblite> parameter file does not exist, defaulting to GFN2-xTB") call new_gfn2_calculator(tblite%calc,mctcmol,error) end if +#ifdef WITH_GXTB + case (xtblvl%gxtb) + if (pr) call tblite%ctx%message("tblite> Setting up g-xTB calculation") + call new_gxtb_calculator(tblite%calc,mctcmol,error) +#else + case (xtblvl%gxtb) + write (stdout,*) 'Error: Compiled without g-xTB support!' + write (stdout,*) 'Recompile with -DWITH_GXTB to enable g-xTB via tblite' + error stop +#endif case default call tblite%ctx%message("Error: Unknown method in tblite!") error stop diff --git a/src/confparse.f90 b/src/confparse.f90 index c0323838..73f9c8ef 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -1412,11 +1412,13 @@ subroutine parseflags(env,arg,nra) case ('-gxtb') processedarg(i) = .true. - call gxtb_dev_warning() + env%gfnver = '--gxtb' + write (stdout,'(2x,a,'' : Use of g-xTB requested.'')') env%gfnver case ('-gxtb_dev') processedarg(i+1) = .true. env%gfnver = 'gxtb_dev' + call gxtb_dev_warning() case ('-gfn2@gfn0','-gfn2@gfn1','-gfn2@gff','-gfn2@ff','-gfn2@gfnff') processedarg(i) = .true. diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 23a24c08..a0c4387e 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -253,11 +253,16 @@ subroutine parse_setting_auto(env,job,kv,rd) job%id = jobtype%gfnff case ('pvol','libpvol','pv') job%id = jobtype%libpvol + case ('gxtb','g-xtb','gxtb-xtb') + job%id = jobtype%tblite + job%tblitelvl = xtblvl%gxtb case ('gxtb_dev') - job%id = jobtype%turbomole - job%rdgrad = .true. - job%binary = 'gxtb' - job%other = '-grad' + ! !> fallback: system call (requires gxtb binary in PATH) + ! job%id = jobtype%turbomole + ! job%rdgrad = .false. + ! job%binary = 'gxtb' + ! job%rdwbo = .false. + call gxtb_dev_warning() case ('none') job%id = jobtype%unknown case ('lj','lennard-jones') @@ -336,6 +341,8 @@ subroutine parse_setting_auto(env,job,kv,rd) case ('eeq','d4eeq') job%tblitelvl = xtblvl%eeq job%rdgrad = .false. + case ('gxtb','g-xtb') + job%tblitelvl = xtblvl%gxtb case default job%tblitelvl = xtblvl%unknown !>--- keyword was recognized, but invalid argument supplied @@ -1233,19 +1240,19 @@ subroutine parse_md_auto(env,mddat,kv,rd) mddat%tsoll = kv%value_f mddat%thermostat = .true. - case ('thermostat') - select case(kv%value_c) + case ('thermostat') + select case (kv%value_c) case ('off','nve') mddat%thermotype = 'none' case ('berendsen','langevin','bbk') mddat%thermotype = trim(kv%value_c) - case ('bussi','bussi-donaido-parinello','bussi-parinello','csvr') + case ('bussi','bussi-donaido-parinello','bussi-parinello','csvr') mddat%thermotype = 'bussi' case default write (stdout,fmtura) kv%value_c call creststop(status_config) end select - mddat%thermostat=.true. + mddat%thermostat = .true. case ('shake') select case (kv%id) diff --git a/src/printouts.f90 b/src/printouts.f90 index 6463436c..09af582e 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -922,17 +922,21 @@ subroutine gxtb_dev_warning use crest_parameters use crest_data,only:status_ioerr write (stdout,*) - write (stdout,'(a)') "!!! WARNING !!!" - write (stdout,'(a)') "You have selected g-xTB for your calculations, but currently only the" - write (stdout,'(a)') "preliminary binary version is available." - write (stdout,'(a)') "This version does NOT HAVE ANALYTICAL GRADIENTS available and uses" - write (stdout,'(a)') "NUMERICAL gradients which are SLOW and NOISY." + write (stdout,'(a)') "Note: g-xTB via tblite is available. Use '--gxtb'." write (stdout,*) - write (stdout,'(a)') 'The cmd argument "--gxtb" will be disabled until an implementation' - write (stdout,'(a)') 'with analytical gradients is available' - write (stdout,*) - write (stdout,'(a)') 'Please use "--gxtb_dev" in the mean time.' - write (stdout,'(a)') "Make sure you have the dev version gxtb installed (https://github.com/grimme-lab/g-xtb)" - write (stdout,*) - call creststop(status_ioerr) + call creststop(status_safety) +! write (stdout,*) +! write (stdout,'(a)') "!!! WARNING !!!" +! write (stdout,'(a)') "You have selected g-xTB for your calculations, but currently only the" +! write (stdout,'(a)') "preliminary binary version is available." +! write (stdout,'(a)') "This version does NOT HAVE ANALYTICAL GRADIENTS available and uses" +! write (stdout,'(a)') "NUMERICAL gradients which are SLOW and NOISY." +! write (stdout,*) +! write (stdout,'(a)') 'The cmd argument "--gxtb" will be disabled until an implementation' +! write (stdout,'(a)') 'with analytical gradients is available' +! write (stdout,*) +! write (stdout,'(a)') 'Please use "--gxtb_dev" in the mean time.' +! write (stdout,'(a)') "Make sure you have the dev version gxtb installed (https://github.com/grimme-lab/g-xtb)" +! write (stdout,*) +! call creststop(status_ioerr) end subroutine gxtb_dev_warning From 03527f0978c4796f8c1701e71dbfe3fbafe54cfe Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 25 Mar 2026 21:39:21 +0100 Subject: [PATCH 278/374] Taking care of EEQ-BC aux charges --- src/calculator/tblite_api.F90 | 43 +++++++++++++++++++++++++++++++---- 1 file changed, 39 insertions(+), 4 deletions(-) diff --git a/src/calculator/tblite_api.F90 b/src/calculator/tblite_api.F90 index bed27285..7f71e343 100644 --- a/src/calculator/tblite_api.F90 +++ b/src/calculator/tblite_api.F90 @@ -72,7 +72,8 @@ module tblite_api integer :: lvl = 0 real(wp) :: accuracy = 1.0_wp character(len=:),allocatable :: paramfile - type(wavefunction_type) :: wfn + type(wavefunction_type) :: wfn + type(wavefunction_type),allocatable :: wfn_aux type(xtb_calculator) :: calc type(tblite_ctx) :: ctx type(tblite_resultstype) :: res @@ -117,6 +118,9 @@ subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite,ceh_guess) !* subroutine tblite_setup initializes the tblite object which is !* passed between the CREST calculators and this module !***************************************************************** +#ifdef WITH_TBLITE + use multicharge,only:get_charges +#endif implicit none type(coord),intent(in) :: mol integer,intent(in) :: chrg @@ -191,10 +195,23 @@ subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite,ceh_guess) etemp_au = etemp*ktoau call new_wavefunction(tblite%wfn,mol%nat,tblite%calc%bas%nsh, & & tblite%calc%bas%nao,1,etemp_au) +#ifdef WITH_GXTB + if (tblite%lvl == xtblvl%gxtb) then + call sad_guess(mctcmol,tblite%calc,tblite%wfn) + end if +#endif if (ceh_guess) then call tblite_internal_ceh_guess(mctcmol,tblite) end if +!>--- for methods with an auxiliary charge model (e.g., gxTB), pre-allocate wfn_aux. +!>--- Charges are updated at each singlepoint call (geometry-dependent). + if (allocated(tblite%calc%charge_model)) then + if (allocated(tblite%wfn_aux)) deallocate(tblite%wfn_aux) + allocate(tblite%wfn_aux) + call new_wavefunction(tblite%wfn_aux,mctcmol%nat,tblite%calc%bas%nsh,0,1,0.0_wp,.true.) + end if + #else /* WITH_TBLITE */ write (stdout,*) 'Error: Compiled without tblite support!' write (stdout,*) 'Use -DWITH_TBLITE=true in the setup to enable this function' @@ -360,6 +377,9 @@ subroutine tblite_singlepoint(mol,chrg,uhf,tblite,energy,gradient,iostatus) !* The actual calculator call. !* The tblite object must be set up at this point !************************************************** +#ifdef WITH_TBLITE + use multicharge,only:get_charges +#endif implicit none type(coord),intent(in) :: mol integer,intent(in) :: chrg @@ -388,12 +408,27 @@ subroutine tblite_singlepoint(mol,chrg,uhf,tblite,energy,gradient,iostatus) !>--- make an mctcmol object from mol call tblite_mol2mol(mol,chrg,uhf,mctcmol) +!>--- update geometry-dependent EEQ-BC charges in wfn_aux (allocated once in tblite_setup) + if (allocated(tblite%wfn_aux)) then + call get_charges(tblite%calc%charge_model,mctcmol,error,tblite%wfn_aux%qat(:,1), & + & dqdr=tblite%wfn_aux%dqatdr(:,:,:,1),dqdL=tblite%wfn_aux%dqatdL(:,:,:,1)) + if (allocated(error)) then + if (pr) call tblite%ctx%message("tblite> auxiliary charge model failed: "//error%message) + iostatus = 1 + return + end if + end if + !>--- call the singlepoint routine select case (tblite%lvl) case default - call xtb_singlepoint(tblite%ctx,mctcmol,tblite%calc,tblite%wfn,tblite%accuracy, & - & energy,gradient, & - & sigma,verbosity,results=tblite%res) + if (allocated(tblite%wfn_aux)) then + call xtb_singlepoint(tblite%ctx,mctcmol,tblite%calc,tblite%wfn,tblite%accuracy, & + & energy,gradient,sigma,verbosity,results=tblite%res,wfn_aux=tblite%wfn_aux) + else + call xtb_singlepoint(tblite%ctx,mctcmol,tblite%calc,tblite%wfn,tblite%accuracy, & + & energy,gradient,sigma,verbosity,results=tblite%res) + end if case (xtblvl%ceh) call ceh_singlepoint(tblite%ctx,tblite%calc,mctcmol,tblite%wfn, & & tblite%accuracy,verbosity) From d83e01b3b1a1c3c46118c636bc2a531cf6008629 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 30 Mar 2026 15:13:51 +0200 Subject: [PATCH 279/374] fix energy conversion for extxyz ensembles --- src/molecule/type.f90 | 5 +++-- src/molecule/type_ensemble.f90 | 5 +++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/molecule/type.f90 b/src/molecule/type.f90 index dd31d269..3485e41b 100644 --- a/src/molecule/type.f90 +++ b/src/molecule/type.f90 @@ -165,9 +165,10 @@ subroutine opencoord(self,fname) call read_extxyz_frame(iunit,ext_sigs,ext_props,nat,en,lat,success) close (iunit) if (success) then + en = en / autoeV call get_at_from_ext(ext_props,at) - call get_xyz_from_ext(ext_props,xyz) - call get_grad_from_ext(ext_props,grad) + call get_xyz_from_ext(ext_props,xyz) !> converts AA to Bohr + call get_grad_from_ext(ext_props,grad) !> converts eV/AA to Ha/Bohr if (allocated(lat)) call move_alloc(lat,self%lat) if (allocated(grad)) call move_alloc(grad,self%gradient) end if diff --git a/src/molecule/type_ensemble.f90 b/src/molecule/type_ensemble.f90 index c47ad838..fd9a8abf 100644 --- a/src/molecule/type_ensemble.f90 +++ b/src/molecule/type_ensemble.f90 @@ -448,9 +448,10 @@ subroutine rdensemble_coord_type(fname,nall,structures) do ii = 1,nall call read_extxyz_frame(iunit,ext_sigs,ext_props,nat,energy,lat,success) if (success) then + energy = energy / autoeV call get_at_from_ext(ext_props,eat) - call get_xyz_from_ext(ext_props,exyz) - call get_grad_from_ext(ext_props,egrd) + call get_xyz_from_ext(ext_props,exyz) !> converts AA to Bohr + call get_grad_from_ext(ext_props,egrd) !> converts eV/AA to Ha/Bohr if (allocated(eat)) call move_alloc(eat,structures(ii)%at) if(allocated(exyz)) call move_alloc(exyz,structures(ii)%xyz) if (allocated(lat)) call move_alloc(lat,structures(ii)%lat) From b5ac89188c1a598aa537ef9c609d45976ed96852 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 30 Mar 2026 16:40:59 +0200 Subject: [PATCH 280/374] Fix extxyz energy conversion within sampling workflows --- src/algos/refine.f90 | 27 ++++++++++++++++----- src/algos/search_conformers.f90 | 42 +++++++++++++++++++++++---------- src/molecule/type.f90 | 2 +- 3 files changed, 51 insertions(+), 20 deletions(-) diff --git a/src/algos/refine.f90 b/src/algos/refine.f90 index f6f5f060..83ebc9e7 100644 --- a/src/algos/refine.f90 +++ b/src/algos/refine.f90 @@ -49,6 +49,7 @@ subroutine crest_refine(env,input,output) real(wp),allocatable :: xyz(:,:,:) integer,allocatable :: at(:) integer :: nrefine,refine_stage + type(coord),allocatable :: structures(:) !===========================================================! !>--- setup if (present(output)) then @@ -57,6 +58,11 @@ subroutine crest_refine(env,input,output) outname = input !> overwrite end if + if(.not.allocated(env%refine_queue))then + call rename(trim(input),trim(output)) + return + endif + !>--- presorting step, if necessary if (env%refine_presort) then call newcregen(env,0,input) @@ -64,12 +70,21 @@ subroutine crest_refine(env,input,output) end if !>--- read in - call rdensemble(input,nat,nall,at,xyz,eread) - allocate (etmp(nall),source=0.0_wp) -!>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: crest_sploop requires coordinates in Bohrs - xyz = xyz/bohr -!>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: crest_sploop requires coordinates in Bohrs +! xyz = xyz/bohr +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- track ensemble for restart - call trackensemble(ensnam,nat,nall,at,xyz,eread) -!>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: crest_oloop requires coordinates in Bohrs - xyz = xyz/bohr -!>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- track ensemble for restart +! !call trackensemble(ensnam,nat,nall,at,xyz,eread) +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: crest_oloop requires coordinates in Bohrs +! xyz = xyz/bohr +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- read new ensemble for next iteration allocate (xyz(3,nat,nall),at(nat),eread(nall)) - call rdensemble(trim(inpnam),nat,nall,at,xyz,eread) - !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: crest_oloop requires coordinates in Bohrs - xyz = xyz/bohr - !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: crest_oloop requires coordinates in Bohrs + !xyz = xyz/bohr + !!>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- restore default sorting thresholds env%ewin = ewinbackup env%rthr = rthrbackup diff --git a/src/molecule/type.f90 b/src/molecule/type.f90 index 3485e41b..ca5eb395 100644 --- a/src/molecule/type.f90 +++ b/src/molecule/type.f90 @@ -376,7 +376,7 @@ subroutine write_extxyz(self,iunit) if (allocated(self%lat)) then write (iunit,'(a)',advance='no') 'Lattice="' write (iunit,'(9f15.8)',advance='no') reshape(self%lat, [9]) - write (iunit,'(a)',advance='no') '" ' + write (iunit,'(a)',advance='no') '" pbc="T T T"' end if if (allocated(self%extxyz)) then call assemble_properties_tag(self%extxyz,atmp) From 78160208e6fbfda8f7114d20380d1c516bf058f8 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 7 Apr 2026 20:20:19 +0200 Subject: [PATCH 281/374] Add a deep-copy function for coord types --- src/molecule/type.f90 | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/src/molecule/type.f90 b/src/molecule/type.f90 index ca5eb395..d60fbd58 100644 --- a/src/molecule/type.f90 +++ b/src/molecule/type.f90 @@ -97,6 +97,7 @@ module molecule_type procedure :: cn_to_bond => coord_cn_to_bond !> generate neighbour matrix from CN procedure :: swap => atswp !> swap two atoms coordinates and their at() entries procedure :: sumform => coord_sumform !> generate a string with the sum formula + procedure :: copy => coord_copy !> deep copy from another coord object end type coord ! ══════════════════════════════════════════════════════════════════════════════ @@ -119,6 +120,48 @@ subroutine deallocate_coord(self) return end subroutine deallocate_coord +! ────────────────────────────────────────────────────────────────────────────── + + subroutine coord_copy(self,src) +!************************************************************* +!* Deep copy of a coord object from src to self. * +!* * +!* On Input: src - source coord object * +!* On Output: self - destination, populated with src data * +!************************************************************* + implicit none + class(coord),intent(out) :: self + type(coord),intent(in) :: src + + ! ── scalar fields ──────────────────────────────────────────────────────── + self%nat = src%nat + self%energy = src%energy + self%chrg = src%chrg + self%uhf = src%uhf + self%nbd = src%nbd + self%wrextxyz = src%wrextxyz + + ! ── mandatory allocatable arrays ───────────────────────────────────────── + if (allocated(src%at)) self%at = src%at + if (allocated(src%xyz)) self%xyz = src%xyz + + ! ── optional allocatable arrays ────────────────────────────────────────── + if (allocated(src%gradient)) self%gradient = src%gradient + if (allocated(src%bond)) self%bond = src%bond + if (allocated(src%lat)) self%lat = src%lat + if (allocated(src%qat)) self%qat = src%qat + + ! ── optional character fields ───────────────────────────────────────────── + if (allocated(src%comment)) self%comment = src%comment + if (allocated(src%origin)) self%origin = src%origin + + ! ── derived-type components ─────────────────────────────────────────────── + self%pdb = src%pdb + if (allocated(src%extxyz)) self%extxyz = src%extxyz + + return + end subroutine coord_copy + ! ────────────────────────────────────────────────────────────────────────────── subroutine opencoord(self,fname) From ce57b07ea7b248f85f8aefb863daa3bb7d3179ba Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 7 Apr 2026 21:33:34 +0200 Subject: [PATCH 282/374] Fix deep copy routines for calcdata and calculation_settings --- src/calculator/calc_type.f90 | 236 +++++++++++++++++++++++++---------- src/molecule/io.f90 | 3 +- 2 files changed, 175 insertions(+), 64 deletions(-) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index f8708236..51cc28c9 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -596,59 +596,117 @@ subroutine calculation_copy(self,src,ignore_constraints) call self%reset() - self%id = src%id +! ── identity ───────────────────────────────────────────────────────────────── + self%id = src%id + self%refine_stage = src%refine_stage - if (allocated(self%calcs)) deallocate (self%calcs) +! ── calculation levels ─────────────────────────────────────────────────────── + if (allocated(self%calcs)) deallocate(self%calcs) self%ncalculations = 0 do i = 1,src%ncalculations call newset%copy(src%calcs(i)) call self%add(newset) end do +! ── constraints ────────────────────────────────────────────────────────────── igno = .false. - if(present(ignore_constraints)) igno = ignore_constraints - if (allocated(self%cons)) deallocate (self%cons) + if (present(ignore_constraints)) igno = ignore_constraints + if (allocated(self%cons)) deallocate(self%cons) self%nconstraints = 0 - if(.not.igno)then - do i = 1,src%nconstraints - call newcons%copy(src%cons(i)) - call self%add(newcons) - end do - endif + if (.not.igno) then + do i = 1,src%nconstraints + call newcons%copy(src%cons(i)) + call self%add(newcons) + end do + end if -!&> +! ── scans ──────────────────────────────────────────────────────────────────── + self%nscans = src%nscans + self%relaxscan = src%relaxscan + self%scansforce = src%scansforce + if (allocated(src%scans)) then + allocate(self%scans(src%nscans)) + do i = 1,src%nscans + self%scans(i)%type = src%scans(i)%type + self%scans(i)%n = src%scans(i)%n + self%scans(i)%steps = src%scans(i)%steps + self%scans(i)%minval = src%scans(i)%minval + self%scans(i)%maxval = src%scans(i)%maxval + self%scans(i)%constrnmbr = src%scans(i)%constrnmbr + self%scans(i)%restore = src%scans(i)%restore + self%scans(i)%currentstep = src%scans(i)%currentstep + if (allocated(src%scans(i)%atms)) self%scans(i)%atms = src%scans(i)%atms + if (allocated(src%scans(i)%points)) self%scans(i)%points = src%scans(i)%points + end do + end if + +! ── frozen atoms ───────────────────────────────────────────────────────────── + self%nfreeze = src%nfreeze + if (allocated(src%freezelist)) self%freezelist = src%freezelist + +! ── optimization settings ──────────────────────────────────────────────────── self%optnewinit = src%optnewinit self%anopt = src%anopt - self%optlev = src%optlev + self%optlev = src%optlev self%micro_opt = src%micro_opt - self%maxcycle = src%maxcycle + self%maxcycle = src%maxcycle self%maxdispl_opt = src%maxdispl_opt - self%ethr_opt = src%ethr_opt - self%gthr_opt = src%gthr_opt - self%hlow_opt = src%hlow_opt - self%hmax_opt = src%hmax_opt - self%acc_opt = src%acc_opt - self%maxerise = src%maxerise - self%hguess = src%hguess - self%exact_rf = src%exact_rf - self%average_conv = src%average_conv - self%tsopt = src%tsopt - self%iupdat = src%iupdat - self%opt_engine = src%opt_engine + self%ethr_opt = src%ethr_opt + self%gthr_opt = src%gthr_opt + self%hlow_opt = src%hlow_opt + self%hmax_opt = src%hmax_opt + self%acc_opt = src%acc_opt + self%maxerise = src%maxerise + self%hguess = src%hguess + self%exact_rf = src%exact_rf + self%average_conv = src%average_conv + self%tsopt = src%tsopt + self%iupdat = src%iupdat + self%opt_engine = src%opt_engine self%lbfgs_histsize = src%lbfgs_histsize - - self%pr_energies = src%pr_energies - self%eout_unit = src%eout_unit - self%elog = src%elog - self%g_sampling = src%g_sampling - self%gs_hess_type = src%gs_hess_type - self%nt = src%nt - self%temperatures = src%temperatures - self%ithr = src%ithr - self%fscal = src%fscal - self%sthr = src%sthr - self%emodel = src%emodel -!&< + self%hess_init = src%hess_init + self%logextxyz = src%logextxyz + +! ── smooth-function parameters ─────────────────────────────────────────────── + self%L = src%L + self%k = src%k + self%shift = src%shift + self%scaling = src%scaling + +! ── printout and I/O ───────────────────────────────────────────────────────── + self%pr_energies = src%pr_energies + self%eout_unit = src%eout_unit + if (allocated(src%elog)) self%elog = src%elog + +! ── ONIOM integer maps ─────────────────────────────────────────────────────── + if (allocated(src%ONIOMmap)) self%ONIOMmap = src%ONIOMmap + if (allocated(src%ONIOMrevmap)) self%ONIOMrevmap = src%ONIOMrevmap + +! ── thermochemistry ────────────────────────────────────────────────────────── + self%do_HR = src%do_HR + self%full_HR = src%full_HR + self%hu_steps = src%hu_steps + self%nt = src%nt + self%ithr = src%ithr + self%fscal = src%fscal + self%sthr = src%sthr + self%initialize_hr_type = src%initialize_hr_type + self%mh_type = src%mh_type + self%hr_hu_type = src%hr_hu_type + self%deform_opt_hess = src%deform_opt_hess + self%doh_stepsize = src%doh_stepsize + self%chess_id_guess = src%chess_id_guess + self%g_sampling = src%g_sampling + self%gs_hess_type = src%gs_hess_type + if (allocated(src%emodel)) self%emodel = src%emodel + if (allocated(src%temperatures)) self%temperatures = src%temperatures + if (allocated(src%et)) self%et = src%et + if (allocated(src%ht)) self%ht = src%ht + if (allocated(src%gt)) self%gt = src%gt + if (allocated(src%stot)) self%stot = src%stot + +!> NOTE: API handle objects (g0calc, ONIOM, ONIOMmols, chess) are NOT copied; +!> they hold C-level or heavy reconstructed state and are re-initialized. return end subroutine calculation_copy @@ -1086,52 +1144,104 @@ subroutine calculation_settings_copy(self,src) class(calculation_settings),intent(out) :: self type(calculation_settings) :: src -!&> - if (allocated(src%calcspace)) self%calcspace = src%calcspace - if (allocated(src%calcfile)) self%calcfile = src%calcfile - if (allocated(src%gradfile)) self%gradfile = src%gradfile - if (allocated(src%path)) self%path = src%path - if (allocated(src%other)) self%other = src%other - if (allocated(src%binary)) self%binary = src%binary - if (allocated(src%systemcall)) self%systemcall = src%systemcall - if (allocated(src%description)) self%description = src%description - if (allocated(src%gradkey)) self%gradkey = src%gradkey - if (allocated(src%efile)) self%efile = src%efile - if (allocated(src%solvmodel)) self%solvmodel = src%solvmodel - if (allocated(src%solvent)) self%solvent = src%solvent - +! ── identity and printout ──────────────────────────────────────────────────── self%id = src%id self%prch = src%prch + self%pr = src%pr + self%prappend = src%prappend + self%prstdout = src%prstdout + self%refine_lvl = src%refine_lvl + +! ── system ─────────────────────────────────────────────────────────────────── self%chrg = src%chrg self%uhf = src%uhf - self%refine_lvl = src%refine_lvl + self%active = src%active + self%weight = src%weight + +! ── allocatable strings ────────────────────────────────────────────────────── + if (allocated(src%calcspace)) self%calcspace = src%calcspace + if (allocated(src%calcfile)) self%calcfile = src%calcfile + if (allocated(src%gradfile)) self%gradfile = src%gradfile + if (allocated(src%path)) self%path = src%path + if (allocated(src%other)) self%other = src%other + if (allocated(src%binary)) self%binary = src%binary + if (allocated(src%systemcall)) self%systemcall = src%systemcall + if (allocated(src%description)) self%description = src%description + if (allocated(src%shortflag)) self%shortflag = src%shortflag + if (allocated(src%gradkey)) self%gradkey = src%gradkey + if (allocated(src%efile)) self%efile = src%efile + if (allocated(src%solvmodel)) self%solvmodel = src%solvmodel + if (allocated(src%solvent)) self%solvent = src%solvent + if (allocated(src%parametrisation))self%parametrisation= src%parametrisation + if (allocated(src%restartfile)) self%restartfile = src%restartfile + if (allocated(src%refgeo)) self%refgeo = src%refgeo + if (allocated(src%refcharges)) self%refcharges = src%refcharges + if (allocated(src%tbliteparam)) self%tbliteparam = src%tbliteparam + +! ── gradient settings ──────────────────────────────────────────────────────── + self%numgrad = src%numgrad + self%gradstep = src%gradstep + self%rdgrad = src%rdgrad + self%gradtype = src%gradtype + self%gradfmt = src%gradfmt +! ── property requests ──────────────────────────────────────────────────────── self%rdwbo = src%rdwbo + self%rdqat = src%rdqat + self%dumpq = src%dumpq self%rddip = src%rddip + self%dipole = src%dipole self%rddipgrad = src%rddipgrad - self%gradtype = src%gradtype - self%gradfmt = src%gradfmt - + self%getlmocent = src%getlmocent + self%nprot = src%nprot + if (allocated(src%getsasa)) self%getsasa = src%getsasa + if (allocated(src%efield)) self%efield = src%efield + if (allocated(src%wbo)) self%wbo = src%wbo + if (allocated(src%qat)) self%qat = src%qat + if (allocated(src%dipgrad)) self%dipgrad = src%dipgrad + if (allocated(src%protxyz)) self%protxyz = src%protxyz + +! ── API / backend settings ─────────────────────────────────────────────────── self%tblitelvl = src%tblitelvl self%etemp = src%etemp self%accuracy = src%accuracy self%apiclean = src%apiclean self%maxscc = src%maxscc self%saveint = src%saveint + self%ceh_guess = src%ceh_guess + self%restart = src%restart - self%ngrid = src%ngrid + self%ngrid = src%ngrid self%extpressure = src%extpressure - self%proberad = src%proberad + self%proberad = src%proberad + self%pvmodel = src%pvmodel + self%vdwset = src%vdwset + self%pvradscal = src%pvradscal + + self%nconfig = src%nconfig + if (allocated(src%config)) self%config = src%config + if (allocated(src%occ)) self%occ = src%occ +! ── ONIOM identifiers ──────────────────────────────────────────────────────── self%ONIOM_highlowroot = src%ONIOM_highlowroot - self%ONIOM_id = src%ONIOM_id + self%ONIOM_id = src%ONIOM_id - self%ag = src%ag +! ── ORCA input block ───────────────────────────────────────────────────────── + self%ORCA%mpi = src%ORCA%mpi + self%ORCA%nlines = src%ORCA%nlines + if (allocated(src%ORCA%cmd)) self%ORCA%cmd = src%ORCA%cmd + if (allocated(src%ORCA%input)) self%ORCA%input = src%ORCA%input + +! ── inline potentials ──────────────────────────────────────────────────────── + self%ag = src%ag self%penalty = src%penalty - self%MPAR = src%MPAR - self%MPAR%iid = 0 !> important for parallelization -!&< +! ── MLIP settings ──────────────────────────────────────────────────────────── + self%MPAR = src%MPAR + self%MPAR%iid = 0 !> reset instance ID for parallelization + +!> NOTE: API handle objects (tblite, g0calc, ff_dat, libpvol) are NOT copied; +!> they hold C-level state and are re-initialized on first use. return end subroutine calculation_settings_copy diff --git a/src/molecule/io.f90 b/src/molecule/io.f90 index ea93ddcb..87ea7e52 100644 --- a/src/molecule/io.f90 +++ b/src/molecule/io.f90 @@ -1369,11 +1369,12 @@ function sgrep(fname,key,casesensitive) character(len=*),intent(in) :: key logical,intent(in),optional :: casesensitive logical :: sgrep,ex - logical :: convert = .false. + logical :: convert character(len=5000) :: atmp character(len=:),allocatable :: kkey integer :: ic,io sgrep = .false. + convert = .false. inquire (file=fname,exist=ex) if (.not.ex) return kkey = trim(key) From 3c244ea745942c79391c0c0a58aa32a61fb03100 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 7 Apr 2026 21:42:52 +0200 Subject: [PATCH 283/374] Create deep copy routine for env --- src/classes.f90 | 346 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 346 insertions(+) diff --git a/src/classes.f90 b/src/classes.f90 index a52cd6de..1ea43440 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -664,6 +664,7 @@ module crest_data procedure :: addrefine => add_to_refinequeue procedure :: wrtCHRG => wrtCHRG procedure :: addsplitqueue => env_addsplitqueue + procedure :: copy => systemdata_copy end type systemdata !========================================================================================! @@ -1125,5 +1126,350 @@ function thermo_get_close_rt(self,nrt) result(temp) temp = self%temps(nrt) end function thermo_get_close_rt !========================================================================================! +!========================================================================================! + + subroutine systemdata_copy(self,src) +!************************************************************* +!* Deep copy of a systemdata object from src to self. * +!* * +!* On Input: src - source systemdata object * +!* On Output: self - destination, populated with src data * +!* * +!* NOTE: Some embedded derived types (mddat, splitqueue, * +!* splitheap, bh_ref, ONIOM_input) are assigned via * +!* Fortran intrinsic assignment, which may only be a * +!* shallow copy if those types contain pointer * +!* components. See individual placeholder comments. * +!************************************************************* + implicit none + class(systemdata),intent(out) :: self + type(systemdata),intent(in) :: src + +! ── run-control integers ────────────────────────────────────────────────────── + self%iostatus_meta = src%iostatus_meta + self%crestver = src%crestver + self%runver = src%runver + self%properties = src%properties + self%properties2 = src%properties2 + self%npq = src%npq + if (allocated(src%pqueue)) self%pqueue = src%pqueue + +! ── CREGEN thresholds ───────────────────────────────────────────────────────── + self%level = src%level + self%thresholds = src%thresholds + self%ewin = src%ewin + self%ethr = src%ethr + self%ethrpurge = src%ethrpurge + self%couthr = src%couthr + self%rthr = src%rthr + self%bthr = src%bthr + self%bthr2 = src%bthr2 + self%bthrmax = src%bthrmax + self%bthrshift = src%bthrshift + self%athr = src%athr + self%pthr = src%pthr + self%pthrsum = src%pthrsum + self%tboltz = src%tboltz + self%cgf = src%cgf + self%iinversion = src%iinversion + +! ── MD / algo control ───────────────────────────────────────────────────────── + self%mdtemps = src%mdtemps + self%mdtime = src%mdtime + self%elowest = src%elowest + self%eprivious = src%eprivious + self%gcmax = src%gcmax + self%gcmaxparent = src%gcmaxparent + self%icount = src%icount + self%mdmode = src%mdmode + self%nmodes = src%nmodes + self%temps = src%temps + self%snapshots = src%snapshots + self%Maxrestart = src%Maxrestart + self%nreset = src%nreset + self%nrotammds = src%nrotammds + self%maxcompare = src%maxcompare + self%tsplit = src%tsplit + +! ── molecular data ──────────────────────────────────────────────────────────── + self%nat = src%nat + self%chrg = src%chrg + self%uhf = src%uhf + self%rednat = src%rednat + self%optlev = src%optlev + self%forceconst = src%forceconst + self%dummypercent = src%dummypercent + +! ── parallelization ─────────────────────────────────────────────────────────── + self%MAXRUN = src%MAXRUN + self%omp = src%omp + self%Threads = src%Threads + self%omp_allow_nested = src%omp_allow_nested + +! ── fixed-length names and flags ────────────────────────────────────────────── + self%ensemblename = src%ensemblename + self%ensemblename2 = src%ensemblename2 + self%fixfile = src%fixfile + self%constraints = src%constraints + self%solvent = src%solvent + self%gfnver = src%gfnver + self%gfnver2 = src%gfnver2 + self%lmover = src%lmover + self%ProgName = src%ProgName + self%ProgIFF = src%ProgIFF + self%homedir = src%homedir + self%scratchdir = src%scratchdir + +! ── allocatable character fields ────────────────────────────────────────────── + if (allocated(src%solv)) self%solv = src%solv + if (allocated(src%cmd)) self%cmd = src%cmd + if (allocated(src%inputcoords)) self%inputcoords = src%inputcoords + if (allocated(src%wbofile)) self%wbofile = src%wbofile + if (allocated(src%atlist)) self%atlist = src%atlist + if (allocated(src%chargesfilename)) self%chargesfilename = src%chargesfilename + if (allocated(src%sortmode)) self%sortmode = src%sortmode + +! ── METADYN scalar settings ─────────────────────────────────────────────────── + self%hmass = src%hmass + self%mdtemp = src%mdtemp + self%nmdtemp = src%nmdtemp + self%mdstep = src%mdstep + self%mdlenfac = src%mdlenfac + self%tmtd = src%tmtd + self%flexi = src%flexi + self%shake = src%shake + self%mddumpxyz = src%mddumpxyz + self%mdskip = src%mdskip + self%mddump = src%mddump + self%maxopt = src%maxopt + self%hlowopt = src%hlowopt + self%microopt = src%microopt + self%s6opt = src%s6opt + self%mtd_kscal = src%mtd_kscal + self%nstatic = src%nstatic + +! ── METADYN allocatable arrays ──────────────────────────────────────────────── + self%nmetadyn = src%nmetadyn + if (allocated(src%metadfac)) self%metadfac = src%metadfac + if (allocated(src%metadexp)) self%metadexp = src%metadexp + if (allocated(src%metadlist)) self%metadlist = src%metadlist + if (allocated(src%mtdstaticfile)) self%mtdstaticfile = src%mtdstaticfile + if (allocated(src%includeRMSD)) self%includeRMSD = src%includeRMSD + if (allocated(src%excludeTOPO)) self%excludeTOPO = src%excludeTOPO + +! ── NCI / reactor settings ──────────────────────────────────────────────────── + self%potscal = src%potscal + self%potpad = src%potpad + self%rdens = src%rdens + self%tempfermi = src%tempfermi + self%XH3 = src%XH3 + self%kappa = src%kappa + if (allocated(src%potatlist)) self%potatlist = src%potatlist + +! ── embedded derived types (allocatable-only internals; intrinsic =) ────────── + self%protb = src%protb !> protobj: allocatables only, intrinsic = is deep + self%cts = src%cts !> legacy_constraints: allocatables only, intrinsic = is deep + self%eMTD = src%eMTD !> entropyMTD: allocatables only, intrinsic = is deep + self%thermo = src%thermo !> thermodata: allocatables only, intrinsic = is deep + self%ref = src%ref !> refdata: allocatables only, intrinsic = is deep + +! ── calc pointer: allocate new target and deep-copy ─────────────────────────── + if (associated(src%calc)) then + if (.not. associated(self%calc)) allocate (self%calc) + call self%calc%copy(src%calc) + end if + +! ── placeholder: mddat (mddata) ─────────────────────────────────────────────── +! mddata may contain pointer components; use intrinsic = as placeholder. + self%mddat = src%mddat + +! ── placeholder: bh_ref (bh_class) ─────────────────────────────────────────── +! bh_class may contain pointer components; use intrinsic = as placeholder. + if (allocated(src%bh_ref)) then + if (.not. allocated(self%bh_ref)) allocate (self%bh_ref,source=src%bh_ref) + end if + +! ── rigidconf settings ──────────────────────────────────────────────────────── + self%rigidconf_algo = src%rigidconf_algo + self%rigidconf_toposource = src%rigidconf_toposource + if (allocated(src%rigidconf_userfile)) self%rigidconf_userfile = src%rigidconf_userfile + if (allocated(src%refine_queue)) self%refine_queue = src%refine_queue + if (allocated(src%ONIOM_toml)) self%ONIOM_toml = src%ONIOM_toml + +! ── placeholder: ONIOM_input (lwoniom_input) ────────────────────────────────── +! lwoniom_input may contain pointer components; use intrinsic = as placeholder. + if (allocated(src%ONIOM_input)) then + if (.not. allocated(self%ONIOM_input)) allocate (self%ONIOM_input,source=src%ONIOM_input) + end if + +! ── substructure queue ──────────────────────────────────────────────────────── + self%substructure_queue = src%substructure_queue + self%queue_iter = src%queue_iter + self%queue_maxreconstruct = src%queue_maxreconstruct +! splitqueue (split_atms) and splitheap (construct_heap): placeholder + if (allocated(src%splitqueue)) self%splitqueue = src%splitqueue + self%splitheap = src%splitheap + +! ── QCG settings ───────────────────────────────────────────────────────────── + self%qcg_runtype = src%qcg_runtype + self%nsolv = src%nsolv + self%nqcgclust = src%nqcgclust + self%max_solv = src%max_solv + self%ensemble_method = src%ensemble_method + self%ensemble_opt = src%ensemble_opt + self%freqver = src%freqver + self%freq_scal = src%freq_scal + self%docking_qcg_flag = src%docking_qcg_flag + if (allocated(src%directed_file)) self%directed_file = src%directed_file + if (allocated(src%directed_list)) self%directed_list = src%directed_list + if (allocated(src%directed_number)) self%directed_number = src%directed_number + if (allocated(src%solu_file)) self%solu_file = src%solu_file + if (allocated(src%solv_file)) self%solv_file = src%solv_file + +! ── clustering settings ─────────────────────────────────────────────────────── + self%maxcluster = src%maxcluster + self%nclust = src%nclust + self%pccap = src%pccap + self%pcthr = src%pcthr + self%pcmin = src%pcmin + self%csthr = src%csthr + self%clustlev = src%clustlev + if (allocated(src%pcmeasure)) self%pcmeasure = src%pcmeasure + +! ── structure generation / bias settings ────────────────────────────────────── + self%doOHflip = src%doOHflip + self%maxflip = src%maxflip + self%rthr2 = src%rthr2 + self%kshift = src%kshift + self%kshiftnum = src%kshiftnum + self%gescoptlev = src%gescoptlev + if (allocated(src%biasfile)) self%biasfile = src%biasfile + +! ── DFT driver (deprecated) ─────────────────────────────────────────────────── + self%hardcutDFT = src%hardcutDFT + self%harcutpthr = src%harcutpthr + self%hardcutnst = src%hardcutnst + if (allocated(src%dftrcfile)) self%dftrcfile = src%dftrcfile + +! ── msreact settings ────────────────────────────────────────────────────────── + self%msei = src%msei + self%mscid = src%mscid + self%msnoiso = src%msnoiso + self%msiso = src%msiso + self%msmolbar = src%msmolbar + self%msinchi = src%msinchi + self%mslargeprint = src%mslargeprint + self%msattrh = src%msattrh + self%msnbonds = src%msnbonds + self%msnshifts = src%msnshifts + self%msnshifts2 = src%msnshifts2 + self%msnfrag = src%msnfrag + self%msinput = src%msinput + +! ── general logical flags ───────────────────────────────────────────────────── + self%allrot = src%allrot + self%alkylize = src%alkylize + self%alkylizeskip = src%alkylizeskip + self%altopt = src%altopt + self%autothreads = src%autothreads + self%autozsort = src%autozsort + self%allowrestart = src%allowrestart + self%better = src%better + self%ceh_guess = src%ceh_guess + self%cff = src%cff + self%cluster = src%cluster + self%checktopo = src%checktopo + self%checkiso = src%checkiso + self%chargesfile = src%chargesfile + self%compareens = src%compareens + self%confgo = src%confgo + self%constrain_solu = src%constrain_solu + self%crest_ohess = src%crest_ohess + self%doNMR = src%doNMR + self%dryrun = src%dryrun + self%ENSO = src%ENSO + self%ens_const = src%ens_const + self%entropic = src%entropic + self%entropymd = src%entropymd + self%esort = src%esort + self%ext = src%ext + self%extLFER = src%extLFER + self%FINAL_GFN2_OPT = src%FINAL_GFN2_OPT + self%fullcre = src%fullcre + self%gbsa = src%gbsa + self%gcmultiopt = src%gcmultiopt + self%gradsp = src%gradsp + self%heavyrmsd = src%heavyrmsd + self%inplaceMode = src%inplaceMode + self%iterativeV2 = src%iterativeV2 + self%iru = src%iru + self%keepModef = src%keepModef + self%keepScratch = src%keepScratch + self%legacy = src%legacy + self%metadynset = src%metadynset + self%methautocorr = src%methautocorr + self%multilevelopt = src%multilevelopt + self%newcregen = src%newcregen + self%NCI = src%NCI + self%niceprint = src%niceprint + self%noconst = src%noconst + self%onlyZsort = src%onlyZsort + self%optpurge = src%optpurge + self%outputsdf = src%outputsdf + self%pcaexclude = src%pcaexclude + self%pclean = src%pclean + self%performCross = src%performCross + self%performMD = src%performMD + self%performModef = src%performModef + self%performMTD = src%performMTD + self%preactormtd = src%preactormtd + self%preactorpot = src%preactorpot + self%preopt = src%preopt + self%presp = src%presp + self%printscoords = src%printscoords + self%QCG = src%QCG + self%qcg_flag = src%qcg_flag + self%qcg_restart = src%qcg_restart + self%nopreopt = src%nopreopt + self%quick = src%quick + self%readbias = src%readbias + self%reftopo = src%reftopo + self%relax = src%relax + self%restartopt = src%restartopt + self%reweight = src%reweight + self%riso = src%riso + self%rotamermds = src%rotamermds + self%refine_presort = src%refine_presort + self%refine_esort = src%refine_esort + self%sameRandomNumber = src%sameRandomNumber + self%scallen = src%scallen + self%scratch = src%scratch + self%setgcmax = src%setgcmax + self%sdfformat = src%sdfformat + self%slow = src%slow + self%solv_md = src%solv_md + self%staticmtd = src%staticmtd + self%subRMSD = src%subRMSD + self%superquick = src%superquick + self%threadssetmanual = src%threadssetmanual + self%trackorigin = src%trackorigin + self%testnumgrad = src%testnumgrad + self%use_xtbiff = src%use_xtbiff + self%user_enslvl = src%user_enslvl + self%user_temp = src%user_temp + self%user_mdtime = src%user_mdtime + self%user_mdstep = src%user_mdstep + self%user_nclust = src%user_nclust + self%user_dumxyz = src%user_dumxyz + self%user_wscal = src%user_wscal + self%useqmdff = src%useqmdff + self%water = src%water + self%wallsetup = src%wallsetup + self%wbotopo = src%wbotopo + + return + end subroutine systemdata_copy + +!========================================================================================! !========================================================================================! end module crest_data From ab19738c17b9c82eca9eae0278b62feaad2a9617 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 7 Apr 2026 22:22:02 +0200 Subject: [PATCH 284/374] Update to gfnff v0.1.1 subproject --- CMakeLists.txt | 2 +- src/calculator/gfnff_api.F90 | 108 +++++++++++++++++++++++++++-------- subprojects/gfnff | 2 +- subprojects/gfnff.wrap | 4 +- test/test_gfnff.F90 | 53 +++++++++-------- 5 files changed, 115 insertions(+), 54 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 19f1d780..54720c05 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -26,7 +26,7 @@ endif() # Setup the crest Project project( crest - LANGUAGES "C" "Fortran" + LANGUAGES "C" "CXX" "Fortran" VERSION 3.0.3 DESCRIPTION "A tool for the exploration of low-energy chemical space" ) diff --git a/src/calculator/gfnff_api.F90 b/src/calculator/gfnff_api.F90 index c9ec8ec4..d5ce3c0e 100644 --- a/src/calculator/gfnff_api.F90 +++ b/src/calculator/gfnff_api.F90 @@ -1,7 +1,7 @@ !================================================================================! ! This file is part of crest. ! -! Copyright (C) 2023 Philipp Pracht +! Copyright (C) 2023-2026 Philipp Pracht ! ! crest is free software: you can redistribute it and/or modify it under ! the terms of the GNU Lesser General Public License as published by @@ -58,6 +58,20 @@ module gfnff_api !========================================================================================! subroutine gfnff_api_setup(mol,chrg,ff_dat,io,pr,iunit) +!************************************************************* +!* Set up (initialize) a GFN-FF calculator from a coord mol. * +!* Lattice vectors are read from mol%lat when present, so * +!* PBC calculations are automatically activated. * +!* * +!* INPUT: * +!* mol - molecule (coords + optional lattice) * +!* chrg - total molecular charge * +!* pr - optional verbosity flag (logical) * +!* iunit - optional output unit * +!* OUTPUT: * +!* ff_dat - initialized GFN-FF data object * +!* io - error status (0 = success) * +!************************************************************* implicit none type(coord),intent(in) :: mol integer,intent(in) :: chrg @@ -66,18 +80,44 @@ subroutine gfnff_api_setup(mol,chrg,ff_dat,io,pr,iunit) integer,intent(in),optional :: iunit type(gfnff_data),allocatable,intent(inout) :: ff_dat type(coord) :: refmol + !> LOCAL + integer :: mylevel,myunit io = 0 + + ! ── map legacy pr/iunit to integer printlevel/printunit ────────────────── + mylevel = 0 + if (present(pr)) then + if (pr) mylevel = 2 + end if + if (present(iunit)) then + myunit = iunit + else + myunit = stdout + end if + #ifdef WITH_GFNFF if (allocated(ff_dat%refgeo)) then - !> initialize GFN-FF from a separate reference structure + ! ── initialize from a separate reference structure ────────────────────── call refmol%open(ff_dat%refgeo) - call gfnff_initialize(refmol%nat,refmol%at,refmol%xyz,ff_dat, & - & ichrg=chrg,print=pr,iostat=io,iunit=iunit) + if (allocated(refmol%lat)) then + call gfnff_initialize(refmol%nat,refmol%at,refmol%xyz,ff_dat, & + & ichrg=chrg,printlevel=mylevel,printunit=myunit,iostat=io, & + & lattice=refmol%lat,npbc=3) + else + call gfnff_initialize(refmol%nat,refmol%at,refmol%xyz,ff_dat, & + & ichrg=chrg,printlevel=mylevel,printunit=myunit,iostat=io) + end if call refmol%deallocate() else - !> initialize parametrization and topology of GFN-FF - call gfnff_initialize(mol%nat,mol%at,mol%xyz,ff_dat, & - & ichrg=chrg,print=pr,iostat=io,iunit=iunit) + ! ── initialize from mol directly ──────────────────────────────────────── + if (allocated(mol%lat)) then + call gfnff_initialize(mol%nat,mol%at,mol%xyz,ff_dat, & + & ichrg=chrg,printlevel=mylevel,printunit=myunit,iostat=io, & + & lattice=mol%lat,npbc=3) + else + call gfnff_initialize(mol%nat,mol%at,mol%xyz,ff_dat, & + & ichrg=chrg,printlevel=mylevel,printunit=myunit,iostat=io) + end if end if #else /* WITH_GFNFF */ @@ -89,7 +129,21 @@ end subroutine gfnff_api_setup !========================================================================================! - subroutine gfnff_sp(mol,ff_dat,energy,gradient,iostatus) + subroutine gfnff_sp(mol,ff_dat,energy,gradient,iostatus,sigma) +!************************************************************* +!* GFN-FF single-point energy + gradient for mol. * +!* When mol%lat is allocated the periodic singlepoint call * +!* is used automatically (lattice passed to gfnff). * +!* * +!* INPUT: * +!* mol - molecule (coords + optional lattice) * +!* ff_dat - initialized GFN-FF data object * +!* OUTPUT: * +!* energy - total energy (Hartree) * +!* gradient - gradient (Eh/Bohr) * +!* iostatus - error status (0 = success) * +!* sigma - optional stress tensor (Eh); zero non-PBC * +!************************************************************* implicit none !> INPUT type(coord),intent(in) :: mol @@ -97,16 +151,23 @@ subroutine gfnff_sp(mol,ff_dat,energy,gradient,iostatus) !> OUTPUT real(wp),intent(out) :: energy real(wp),intent(out) :: gradient(3,mol%nat) - integer,intent(out) :: iostatus + integer,intent(out) :: iostatus + real(wp),intent(out),optional :: sigma(3,3) !> LOCAL - logical :: fail + real(wp) :: sigma_loc(3,3) energy = 0.0_wp gradient = 0.0_wp iostatus = 0 - fail = .false. + sigma_loc = 0.0_wp #ifdef WITH_GFNFF - call gfnff_singlepoint(mol%nat,mol%at,mol%xyz,ff_dat, & - & energy,gradient,iostat=iostatus) + if (allocated(mol%lat)) then + call gfnff_singlepoint(mol%nat,mol%at,mol%xyz,ff_dat, & + & energy,gradient,lattice=mol%lat,sigma=sigma_loc,iostat=iostatus) + else + call gfnff_singlepoint(mol%nat,mol%at,mol%xyz,ff_dat, & + & energy,gradient,iostat=iostatus) + end if + if (present(sigma)) sigma = sigma_loc #else write (stdout,*) 'Error: Compiled without GFN-FF support!' write (stdout,*) 'Use -DWITH_GFNFF=true in the setup to enable this function' @@ -121,10 +182,8 @@ subroutine gfnff_printout(iunit,ff_dat) !> INPUT integer,intent(in) :: iunit type(gfnff_data),allocatable,intent(inout) :: ff_dat - !> LOCAL - logical :: fail #ifdef WITH_GFNFF - call print_gfnff_results(iunit,ff_dat%res,allocated(ff_dat%solvation)) + call ff_dat%resultprint(printunit=iunit) #else write (stdout,*) 'Error: Compiled without GFN-FF support!' write (stdout,*) 'Use -DWITH_GFNFF=true in the setup to enable this function' @@ -162,17 +221,16 @@ subroutine gfnff_dump_sasa(ff_dat,nat,atlist) integer,intent(in) :: nat integer :: i real(wp) :: sumsasa - if(allocated(ff_dat%solvation))then - if(allocated(ff_dat%solvation%sasa))then + if (allocated(ff_dat%solvation)) then + if (allocated(ff_dat%solvation%sasa)) then sumsasa = 0.0_wp - do i=1,nat - if(atlist(i)) sumsasa = sumsasa + ff_dat%solvation%sasa(i) - enddo - write(5454,*) sumsasa - endif - endif + do i = 1,nat + if (atlist(i)) sumsasa = sumsasa+ff_dat%solvation%sasa(i) + end do + write (5454,*) sumsasa + end if + end if end subroutine gfnff_dump_sasa !========================================================================================! !========================================================================================! end module gfnff_api - diff --git a/subprojects/gfnff b/subprojects/gfnff index 0e0280f0..e0d6e398 160000 --- a/subprojects/gfnff +++ b/subprojects/gfnff @@ -1 +1 @@ -Subproject commit 0e0280f05c8ffd83f82a035636ffc64c37489120 +Subproject commit e0d6e39863eaa09531b126dc4a1a58945abc25fb diff --git a/subprojects/gfnff.wrap b/subprojects/gfnff.wrap index cafebc59..9fff9917 100644 --- a/subprojects/gfnff.wrap +++ b/subprojects/gfnff.wrap @@ -1,6 +1,6 @@ [wrap-git] -url = https://github.com/grimme-lab/gfnff -revision = head +url = https://github.com/pprcht/gfnff +revision = v0.1.1 clone-recursive = true [provide] diff --git a/test/test_gfnff.F90 b/test/test_gfnff.F90 index 6e5c9d46..4b03cfcf 100644 --- a/test/test_gfnff.F90 +++ b/test/test_gfnff.F90 @@ -192,32 +192,35 @@ subroutine test_gfnff_sp_anion(error) real(wp),allocatable :: grad(:,:) integer :: io !&< - real(wp),parameter :: e_ref = -5.722199796041350_wp + !> Reference values updated for gfnff v0.1.1: the neighbour-list and + !> Wigner-Seitz cell (WSC) rework changed energetics for charged systems. + !> Both energy and gradient references were regenerated from the v0.1.1 run. + real(wp),parameter :: e_ref = -5.828532820056295_wp real(wp),parameter :: g_ref(3,24) = reshape([& - & 0.004468921480142_wp, -0.000083123134016_wp, 0.000001151477114_wp, & - & 0.026784240021401_wp, -0.003317301163864_wp, 0.000007330730819_wp, & - & -0.004004820272010_wp, -0.030509909771367_wp, 0.000021392716860_wp, & - & -0.000751769525558_wp, 0.005889324801531_wp, -0.000022156837684_wp, & - & -0.027788611671027_wp, -0.033864525810969_wp, -0.000006636279691_wp, & - & 0.026412943164910_wp, 0.030830470039288_wp, 0.000033495772036_wp, & - & -0.017689873797001_wp, -0.023514680185829_wp, -0.000029972119517_wp, & - & 0.025299322245125_wp, 0.011384898053826_wp, 0.000001507574957_wp, & - & -0.009184660893020_wp, 0.023372121393537_wp, -0.000006131704134_wp, & - & -0.001241048489363_wp, 0.005561107788044_wp, -0.000016875281359_wp, & - & 0.002544027763531_wp, -0.004003045629465_wp, -0.000031756330103_wp, & - & -0.029084734620249_wp, 0.020333106964323_wp, 0.000017800756382_wp, & - & -0.000069352904917_wp, -0.003305508039344_wp, -0.000014616855913_wp, & - & -0.003685271682472_wp, 0.001732297413329_wp, -0.000073775627784_wp, & - & 0.001715180720526_wp, 0.002427255238024_wp, 0.000002864449221_wp, & - & 0.001895835509322_wp, -0.000518306207627_wp, 0.003050902872775_wp, & - & 0.001898766998976_wp, -0.000518624553391_wp, -0.003057577541061_wp, & - & -0.002685446613991_wp, 0.000991558499999_wp, 0.000012103424716_wp, & - & 0.003434143710645_wp, -0.000161577974365_wp, 0.000003107935122_wp, & - & -0.000493795408284_wp, 0.000908332349694_wp, 0.003287812553032_wp, & - & -0.000484391594052_wp, 0.000916710811928_wp, -0.003278674680856_wp, & - & -0.001252234734786_wp, -0.003284602467482_wp, 0.000045301985594_wp, & - & 0.001987099764679_wp, -0.000604716538950_wp, 0.002853130443235_wp, & - & 0.001975530827471_wp, -0.000661261876856_wp, -0.002799729433761_wp & + & 3.94230543214767e-03_wp, 3.52030063768979e-04_wp, 1.81683057095039e-06_wp, & + & 1.51705975544829e-02_wp, -8.59644901931333e-03_wp, -1.30289855263585e-05_wp, & + & -3.32620665073756e-03_wp, -1.27838095920201e-02_wp, 3.07797052876764e-05_wp, & + & 4.93740063275844e-03_wp, 4.06512386391377e-03_wp, -2.14659925847723e-05_wp, & + & -2.31495929321227e-02_wp, -2.87916805922025e-02_wp, -3.22455640084147e-06_wp, & + & 2.05728120146893e-02_wp, 1.07842246816042e-02_wp, 5.58592835861545e-05_wp, & + & -3.57568867600167e-03_wp, -1.87642796677282e-03_wp, -2.53540979489806e-05_wp, & + & 5.05671257009310e-03_wp, 4.08216306711967e-03_wp, -5.09893176526027e-05_wp, & + & -2.48954902302761e-03_wp, 1.56793979443191e-02_wp, 3.18591292280463e-05_wp, & + & -4.61712459034876e-03_wp, 7.38892241260220e-03_wp, -2.69984802863847e-05_wp, & + & 6.67104429871043e-03_wp, -7.53862115125029e-03_wp, -3.64266870952139e-05_wp, & + & -2.31759261766794e-02_wp, 1.91389704080971e-02_wp, 6.34113639207092e-06_wp, & + & 6.05908705535911e-06_wp, -3.03220605329460e-03_wp, -1.40325040899702e-05_wp, & + & -3.98348638058101e-03_wp, 1.54809264373304e-03_wp, -5.64650422844910e-05_wp, & + & 1.71517910778865e-03_wp, 2.42726129127660e-03_wp, 2.86445331615998e-06_wp, & + & 1.89583331406671e-03_wp, -5.18309297446946e-04_wp, 3.05090837898127e-03_wp, & + & 1.89876480153798e-03_wp, -5.18627636530015e-04_wp, -3.05758305240559e-03_wp, & + & -2.71548970167826e-03_wp, 1.07706281565603e-03_wp, 1.41909698337930e-05_wp, & + & 3.43414680170101e-03_wp, -1.61582876165697e-04_wp, 3.10793153391831e-06_wp, & + & -4.93795501029164e-04_wp, 9.08335390055891e-04_wp, 3.28781757277625e-03_wp, & + & -4.84391692211688e-04_wp, 9.16713856580635e-04_wp, -3.27867969575159e-03_wp, & + & -1.25224049764651e-03_wp, -3.28460279557860e-03_wp, 4.53019960043941e-05_wp, & + & 1.98710257887371e-03_wp, -6.04718036417461e-04_wp, 2.85313550792252e-03_wp, & + & 1.97553362815908e-03_wp, -6.61263421734836e-04_wp, -2.79973448340641e-03_wp & & ], shape(g_ref)) !&> From f9d1b0f74800799b5f4295bfb6b019b98ffb5d79 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 13 Apr 2026 10:48:47 +0200 Subject: [PATCH 285/374] Remove omp critical statement in orca hessian processor --- src/entropy/thermocalc.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/entropy/thermocalc.f90 b/src/entropy/thermocalc.f90 index dabb67b0..cca2f51c 100644 --- a/src/entropy/thermocalc.f90 +++ b/src/entropy/thermocalc.f90 @@ -362,12 +362,12 @@ subroutine rdfreq_orca_hess(mol,fname,nmodes,freq) write(stdout,'(a)',advance='no') ' Processing (raw) Hessian read from ORCA '//trim(fname)//' ... ' flush(stdout) - !$omp critical + !!$omp critical !>-- Projects and mass-weights the Hessian call prj_mw_hess(mol%nat,mol%at,nmodes,mol%xyz,hess) !>-- Computes the Frequencies call frequencies(mol%nat,mol%at,mol%xyz,nmodes,hess,freq,io) - !$omp end critical + !!$omp end critical write(stdout,'(a)') 'done.' deallocate (hess) From d3e5e68961468be9c0e966a6364f499072930110 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 24 Apr 2026 12:37:35 +0200 Subject: [PATCH 286/374] new logic for g-xTB usage: WITH_GXTB --> tblite implementation (still confidential), else: xtb syscall with --gxtb --- src/calculator/calc_type.f90 | 19 +++++++------------ src/calculator/tblite_api.F90 | 10 ++++++++-- src/confparse.f90 | 6 +++--- src/parsing/parse_calcdata.f90 | 23 ++++++++++++++--------- src/printouts.f90 | 19 +++---------------- 5 files changed, 35 insertions(+), 42 deletions(-) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index f9ab3819..49ee8740 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -1414,18 +1414,13 @@ subroutine create_calclevel_shortcut(self,levelstring, & self%rdgrad = .false. self%binary = 'gp3' case ('gxtb','--gxtb') - self%id = jobtype%tblite - self%tblitelvl = xtblvl%gxtb -! case ('gxtb','--gxtb','gxtb_dev') -! !> fallback: system call (requires gxtb binary in PATH) -! self%id = jobtype%turbomole -! self%rdgrad = .false. -! self%binary = 'gxtb' -! self%rdwbo = .false. -! if (index(levelstring,'_dev') .ne. 0) then -! self%other = '-grad' -! self%rdgrad = .true. -! end if + if (have_gxtb) then + self%id = jobtype%tblite + self%tblitelvl = xtblvl%gxtb + else + self%id = jobtype%xtbsys + self%other = '--gxtb' + end if case ('orca') self%id = jobtype%orca diff --git a/src/calculator/tblite_api.F90 b/src/calculator/tblite_api.F90 index 7f71e343..d3d57d26 100644 --- a/src/calculator/tblite_api.F90 +++ b/src/calculator/tblite_api.F90 @@ -94,6 +94,12 @@ module tblite_api end type enum_tblite_method type(enum_tblite_method),parameter,public :: xtblvl = enum_tblite_method() +#ifdef WITH_GXTB + logical,parameter,public :: have_gxtb = .true. +#else + logical,parameter,public :: have_gxtb = .false. +#endif + !> Conversion factor from Kelvin to Hartree real(wp),parameter :: ktoau = 3.166808578545117e-06_wp @@ -181,8 +187,8 @@ subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite,ceh_guess) call new_gxtb_calculator(tblite%calc,mctcmol,error) #else case (xtblvl%gxtb) - write (stdout,*) 'Error: Compiled without g-xTB support!' - write (stdout,*) 'Recompile with -DWITH_GXTB to enable g-xTB via tblite' + write (stdout,'(a)') 'Error: g-xTB via tblite not available (compiled without WITH_GXTB).' + write (stdout,'(a)') 'This code path should not be reached — use the xtb binary fallback.' error stop #endif case default diff --git a/src/confparse.f90 b/src/confparse.f90 index 73f9c8ef..73f78974 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -1416,9 +1416,9 @@ subroutine parseflags(env,arg,nra) write (stdout,'(2x,a,'' : Use of g-xTB requested.'')') env%gfnver case ('-gxtb_dev') - processedarg(i+1) = .true. - env%gfnver = 'gxtb_dev' - call gxtb_dev_warning() + processedarg(i) = .true. + env%gfnver = '--gxtb' + write (stdout,'(2x,a)') 'Note: --gxtb_dev is deprecated, redirecting to --gxtb.' case ('-gfn2@gfn0','-gfn2@gfn1','-gfn2@gff','-gfn2@ff','-gfn2@gfnff') processedarg(i) = .true. diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index a0c4387e..9dced63d 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -30,7 +30,7 @@ module parse_calcdata use dynamics_module use bh_module use gradreader_module,only:gradtype,conv2gradfmt - use tblite_api,only:xtblvl + use tblite_api,only:xtblvl,have_gxtb use strucrd,only:get_atlist,coord use axis_module @@ -254,15 +254,20 @@ subroutine parse_setting_auto(env,job,kv,rd) case ('pvol','libpvol','pv') job%id = jobtype%libpvol case ('gxtb','g-xtb','gxtb-xtb') - job%id = jobtype%tblite - job%tblitelvl = xtblvl%gxtb + if (have_gxtb) then + job%id = jobtype%tblite + job%tblitelvl = xtblvl%gxtb + else + job%id = jobtype%xtbsys + job%other = '--gxtb' + end if case ('gxtb_dev') - ! !> fallback: system call (requires gxtb binary in PATH) - ! job%id = jobtype%turbomole - ! job%rdgrad = .false. - ! job%binary = 'gxtb' - ! job%rdwbo = .false. - call gxtb_dev_warning() + if (have_gxtb) then + call gxtb_dev_warning() + else + job%id = jobtype%xtbsys + job%other = '--gxtb' + end if case ('none') job%id = jobtype%unknown case ('lj','lennard-jones') diff --git a/src/printouts.f90 b/src/printouts.f90 index 09af582e..f49e218d 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -920,23 +920,10 @@ end subroutine printprogbar subroutine gxtb_dev_warning use crest_parameters - use crest_data,only:status_ioerr + use crest_data,only:status_safety write (stdout,*) - write (stdout,'(a)') "Note: g-xTB via tblite is available. Use '--gxtb'." + write (stdout,'(a)') "Note: '--gxtb_dev' is deprecated. Use '--gxtb'." + write (stdout,'(a)') "g-xTB via the tblite API is available with this build." write (stdout,*) call creststop(status_safety) -! write (stdout,*) -! write (stdout,'(a)') "!!! WARNING !!!" -! write (stdout,'(a)') "You have selected g-xTB for your calculations, but currently only the" -! write (stdout,'(a)') "preliminary binary version is available." -! write (stdout,'(a)') "This version does NOT HAVE ANALYTICAL GRADIENTS available and uses" -! write (stdout,'(a)') "NUMERICAL gradients which are SLOW and NOISY." -! write (stdout,*) -! write (stdout,'(a)') 'The cmd argument "--gxtb" will be disabled until an implementation' -! write (stdout,'(a)') 'with analytical gradients is available' -! write (stdout,*) -! write (stdout,'(a)') 'Please use "--gxtb_dev" in the mean time.' -! write (stdout,'(a)') "Make sure you have the dev version gxtb installed (https://github.com/grimme-lab/g-xtb)" -! write (stdout,*) -! call creststop(status_ioerr) end subroutine gxtb_dev_warning From 32c663bd58f5d7e42c5706ee8d91e91f2dac4c27 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 24 Apr 2026 13:02:34 +0200 Subject: [PATCH 287/374] Deactivate g-xTB tblite build (still confidential, in preparation) --- config/CMakeLists.txt | 2 +- meson_options.txt | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/config/CMakeLists.txt b/config/CMakeLists.txt index d694af6a..1935ba89 100644 --- a/config/CMakeLists.txt +++ b/config/CMakeLists.txt @@ -31,7 +31,7 @@ install( # Options for enabling or disabling features option(WITH_OpenMP "Enable OpenMP support" TRUE) option(WITH_TBLITE "Enable support for tblite" TRUE) -option(WITH_GXTB "Enable g-xTB via tblite (requires WITH_TBLITE)" TRUE) +option(WITH_GXTB "Enable g-xTB via tblite (requires WITH_TBLITE)" FALSE) option(WITH_TOMLF "Enable support for toml-f" TRUE) option(WITH_GFN0 "Enable support for GFN0-xTB" TRUE) option(WITH_GFNFF "Enable support for GFN-FF" TRUE) diff --git a/meson_options.txt b/meson_options.txt index 25ed2cc7..d34d5c81 100644 --- a/meson_options.txt +++ b/meson_options.txt @@ -49,7 +49,7 @@ option('tblite', ) option('gxtb', type : 'boolean', - value : true, + value : false, description : 'Enable g-xTB via tblite (requires tblite)', ) option('toml-f', From ae8f66979df9fca1c35bea024f9bfb69f686c5ea Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 24 Apr 2026 13:41:17 +0200 Subject: [PATCH 288/374] Update in preparation for tblite gxtb build --- src/calculator/tblite_api.F90 | 15 ++++++++++++++- subprojects/dftd4 | 2 +- subprojects/tblite | 2 +- subprojects/toml-f | 2 +- 4 files changed, 17 insertions(+), 4 deletions(-) diff --git a/src/calculator/tblite_api.F90 b/src/calculator/tblite_api.F90 index d3d57d26..bf2bdfe4 100644 --- a/src/calculator/tblite_api.F90 +++ b/src/calculator/tblite_api.F90 @@ -125,7 +125,9 @@ subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite,ceh_guess) !* passed between the CREST calculators and this module !***************************************************************** #ifdef WITH_TBLITE +#ifdef WITH_GXTB use multicharge,only:get_charges +#endif #endif implicit none type(coord),intent(in) :: mol @@ -212,11 +214,13 @@ subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite,ceh_guess) !>--- for methods with an auxiliary charge model (e.g., gxTB), pre-allocate wfn_aux. !>--- Charges are updated at each singlepoint call (geometry-dependent). +#ifdef WITH_GXTB if (allocated(tblite%calc%charge_model)) then if (allocated(tblite%wfn_aux)) deallocate(tblite%wfn_aux) allocate(tblite%wfn_aux) call new_wavefunction(tblite%wfn_aux,mctcmol%nat,tblite%calc%bas%nsh,0,1,0.0_wp,.true.) end if +#endif #else /* WITH_TBLITE */ write (stdout,*) 'Error: Compiled without tblite support!' @@ -384,7 +388,9 @@ subroutine tblite_singlepoint(mol,chrg,uhf,tblite,energy,gradient,iostatus) !* The tblite object must be set up at this point !************************************************** #ifdef WITH_TBLITE +#ifdef WITH_GXTB use multicharge,only:get_charges +#endif #endif implicit none type(coord),intent(in) :: mol @@ -415,6 +421,7 @@ subroutine tblite_singlepoint(mol,chrg,uhf,tblite,energy,gradient,iostatus) call tblite_mol2mol(mol,chrg,uhf,mctcmol) !>--- update geometry-dependent EEQ-BC charges in wfn_aux (allocated once in tblite_setup) +#ifdef WITH_GXTB if (allocated(tblite%wfn_aux)) then call get_charges(tblite%calc%charge_model,mctcmol,error,tblite%wfn_aux%qat(:,1), & & dqdr=tblite%wfn_aux%dqatdr(:,:,:,1),dqdL=tblite%wfn_aux%dqatdL(:,:,:,1)) @@ -424,10 +431,12 @@ subroutine tblite_singlepoint(mol,chrg,uhf,tblite,energy,gradient,iostatus) return end if end if +#endif !>--- call the singlepoint routine select case (tblite%lvl) case default +#ifdef WITH_GXTB if (allocated(tblite%wfn_aux)) then call xtb_singlepoint(tblite%ctx,mctcmol,tblite%calc,tblite%wfn,tblite%accuracy, & & energy,gradient,sigma,verbosity,results=tblite%res,wfn_aux=tblite%wfn_aux) @@ -435,6 +444,10 @@ subroutine tblite_singlepoint(mol,chrg,uhf,tblite,energy,gradient,iostatus) call xtb_singlepoint(tblite%ctx,mctcmol,tblite%calc,tblite%wfn,tblite%accuracy, & & energy,gradient,sigma,verbosity,results=tblite%res) end if +#else + call xtb_singlepoint(tblite%ctx,mctcmol,tblite%calc,tblite%wfn,tblite%accuracy, & + & energy,gradient,sigma,verbosity,results=tblite%res) +#endif case (xtblvl%ceh) call ceh_singlepoint(tblite%ctx,tblite%calc,mctcmol,tblite%wfn, & & tblite%accuracy,verbosity) @@ -501,7 +514,7 @@ subroutine tblite_addsettings(tblite,maxscc,rdwbo,saveint,accuracy) logical,intent(in) :: saveint real(wp),intent(in) :: accuracy #ifdef WITH_TBLITE - tblite%calc%iterator%max_iter = maxscc + tblite%calc%max_iter = maxscc tblite%calc%save_integrals = (rdwbo.or.saveint) tblite%accuracy = accuracy #endif diff --git a/subprojects/dftd4 b/subprojects/dftd4 index f02a65f7..53cb1754 160000 --- a/subprojects/dftd4 +++ b/subprojects/dftd4 @@ -1 +1 @@ -Subproject commit f02a65f71d82a8cd814c7f6878f51044a889bae3 +Subproject commit 53cb17549a937e893c411e5679d741036dd4fbe6 diff --git a/subprojects/tblite b/subprojects/tblite index 660d1678..526baa60 160000 --- a/subprojects/tblite +++ b/subprojects/tblite @@ -1 +1 @@ -Subproject commit 660d1678d6f36999d7ffda6e710d5ff00ff2f8ff +Subproject commit 526baa60d331605af3aa5593000d164a93ea905e diff --git a/subprojects/toml-f b/subprojects/toml-f index d37d83f5..d5e92701 160000 --- a/subprojects/toml-f +++ b/subprojects/toml-f @@ -1 +1 @@ -Subproject commit d37d83f5a8d65100f8548a64d9f97c7e1c57ca2f +Subproject commit d5e92701d28b647323ce05ecbcbf302dd19792f7 From aa1691e14eef0232a6a61b13e79bf515892dad5b Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 24 Apr 2026 15:20:15 +0200 Subject: [PATCH 289/374] Use the same commits in all of git submodules, Cmake Find* files, and meson wrap files --- config/modules/Finddftd4.cmake | 2 +- config/modules/Findfmlip_relay.cmake | 3 ++- config/modules/Findgfn0.cmake | 3 ++- config/modules/Findgfnff.cmake | 3 ++- config/modules/Findlibpvol.cmake | 2 +- config/modules/Findlwoniom.cmake | 3 ++- config/modules/Findmctc-lib.cmake | 3 ++- config/modules/Findmstore.cmake | 3 ++- config/modules/Findmulticharge.cmake | 2 +- config/modules/Finds-dftd3.cmake | 2 +- config/modules/Findtblite.cmake | 2 +- config/modules/Findtest-drive.cmake | 3 ++- config/modules/Findtoml-f.cmake | 3 ++- subprojects/dftd4.wrap | 2 +- subprojects/fmlip_relay.wrap | 2 +- subprojects/gfn0.wrap | 4 ++-- subprojects/gfnff.wrap | 2 +- subprojects/lwoniom.wrap | 4 ++-- subprojects/mctc-lib.wrap | 2 +- subprojects/mstore.wrap | 2 +- subprojects/multicharge.wrap | 2 +- subprojects/pvol.wrap | 2 +- subprojects/s-dftd3.wrap | 4 ++-- subprojects/tblite.wrap | 2 +- subprojects/test-drive.wrap | 2 +- subprojects/toml-f.wrap | 2 +- 26 files changed, 37 insertions(+), 29 deletions(-) diff --git a/config/modules/Finddftd4.cmake b/config/modules/Finddftd4.cmake index c66d1ad2..ff35df1f 100644 --- a/config/modules/Finddftd4.cmake +++ b/config/modules/Finddftd4.cmake @@ -17,7 +17,7 @@ set(_lib "dftd4") set(_pkg "DFTD4") set(_url "https://github.com/dftd4/dftd4") -set(_branch "v4.0.0") +set(_branch "53cb17549a937e893c411e5679d741036dd4fbe6") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") diff --git a/config/modules/Findfmlip_relay.cmake b/config/modules/Findfmlip_relay.cmake index 7a223640..b5e95dcd 100644 --- a/config/modules/Findfmlip_relay.cmake +++ b/config/modules/Findfmlip_relay.cmake @@ -1,6 +1,7 @@ set(_lib "fmlip_relay") set(_pkg "FMLIP_RELAY") set(_url "https://github.com/pprcht/fmlip-relay") +set(_branch "22a788a48031af3a1ae9f687af09595568dd9fb4") # Discovery method order can be overridden by the parent project, e.g.: # set(FMLIP_RELAY_FIND_METHOD "subproject" "cmake") @@ -12,7 +13,7 @@ endif() # Replace "crest-utils" with the actual name if yours differs. include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") -crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}") +crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}" "${_branch}") set(found FALSE) if(TARGET "fmlip_relay::fmlip_relay") diff --git a/config/modules/Findgfn0.cmake b/config/modules/Findgfn0.cmake index a44f8c8d..8327754f 100644 --- a/config/modules/Findgfn0.cmake +++ b/config/modules/Findgfn0.cmake @@ -17,6 +17,7 @@ set(_lib "gfn0") set(_pkg "GFN0") set(_url "https://github.com/pprcht/gfn0") +set(_branch "717cce283ede4fa88d949292291b1f0f6984440a") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") @@ -24,7 +25,7 @@ endif() include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") -crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}") +crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}" "${_branch}") set (found FALSE) if(TARGET "gfn0::gfn0") diff --git a/config/modules/Findgfnff.cmake b/config/modules/Findgfnff.cmake index faf16024..090aeaf3 100644 --- a/config/modules/Findgfnff.cmake +++ b/config/modules/Findgfnff.cmake @@ -17,6 +17,7 @@ set(_lib "gfnff") set(_pkg "GFNFF") set(_url "https://github.com/pprcht/gfnff") +set(_branch "e0d6e39863eaa09531b126dc4a1a58945abc25fb") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") @@ -24,7 +25,7 @@ endif() include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") -crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}") +crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}" "${_branch}") set(found FALSE) if(TARGET "gfnff::gfnff") diff --git a/config/modules/Findlibpvol.cmake b/config/modules/Findlibpvol.cmake index e62c52c2..13c880c9 100644 --- a/config/modules/Findlibpvol.cmake +++ b/config/modules/Findlibpvol.cmake @@ -17,7 +17,7 @@ set(_lib "pvol") set(_pkg "PVOL") set(_url "https://github.com/pprcht/libpvol.git") -set(_branch "build-update") +set(_branch "c975ad4e062a00e6b228505bec0f1d722aea9f46") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf" ) diff --git a/config/modules/Findlwoniom.cmake b/config/modules/Findlwoniom.cmake index 1f825b13..de073c21 100644 --- a/config/modules/Findlwoniom.cmake +++ b/config/modules/Findlwoniom.cmake @@ -17,6 +17,7 @@ set(_lib "lwoniom") set(_pkg "LWONIOM") set(_url "https://github.com/crest-lab/lwoniom") +set(_branch "ab66c7ebc3066328a8fc313dc783aec9b773cad2") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") @@ -24,7 +25,7 @@ endif() include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") -crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}") +crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}" "${_branch}") set(found FALSE) if(TARGET "lwoniom::lwoniom") diff --git a/config/modules/Findmctc-lib.cmake b/config/modules/Findmctc-lib.cmake index 5e9b3d1a..4d704175 100644 --- a/config/modules/Findmctc-lib.cmake +++ b/config/modules/Findmctc-lib.cmake @@ -1,6 +1,7 @@ set(_lib "mctc-lib") set(_pkg "MCTCLIB") set(_url "https://github.com/grimme-lab/mctc-lib") +set(_branch "8cd0cb4489537fd28bfb2e8094f1647f3e0da284") # Discovery method order can be overridden by the parent project, e.g.: # set(mctc-lib_FIND_METHOD "subproject" "cmake") @@ -12,7 +13,7 @@ endif() # Replace "crest-utils" with the actual name if yours differs. include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") -crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}") +crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}" "${_branch}") set(found FALSE) if(TARGET "mctc-lib::mctc-lib") diff --git a/config/modules/Findmstore.cmake b/config/modules/Findmstore.cmake index 104e3ff8..e857fe9e 100644 --- a/config/modules/Findmstore.cmake +++ b/config/modules/Findmstore.cmake @@ -1,6 +1,7 @@ set(_lib "mstore") set(_pkg "MSTORE") set(_url "https://github.com/grimme-lab/mstore") +set(_branch "10a3437b3634dd4464557580ae36c1ed72535f6c") # Discovery method order can be overridden by the parent project, e.g.: # set(mstore_FIND_METHOD "subproject" "cmake") @@ -12,7 +13,7 @@ endif() # Replace "crest-utils" with the actual name if yours differs. include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") -crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}") +crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}" "${_branch}") set(found FALSE) if(TARGET "mstore::mstore") diff --git a/config/modules/Findmulticharge.cmake b/config/modules/Findmulticharge.cmake index fd7d54bd..45b4348c 100644 --- a/config/modules/Findmulticharge.cmake +++ b/config/modules/Findmulticharge.cmake @@ -1,7 +1,7 @@ set(_lib "multicharge") set(_pkg "MULTICHARGE") set(_url "https://github.com/grimme-lab/multicharge") -set(_branch "v0.5.0") +set(_branch "6a5d63f9e9e29dcf13cc47cc27f33bf9015681bf") # Discovery method order can be overridden by the parent project, e.g.: # set(multicharge_FIND_METHOD "subproject" "cmake") diff --git a/config/modules/Finds-dftd3.cmake b/config/modules/Finds-dftd3.cmake index 2ea1fff5..82ceb350 100644 --- a/config/modules/Finds-dftd3.cmake +++ b/config/modules/Finds-dftd3.cmake @@ -17,7 +17,7 @@ set(_lib "s-dftd3") set(_pkg "SDFTD3") set(_url "https://github.com/dftd3/simple-dftd3") -set(_branch "v1.2.1") +set(_branch "87efc010cd74f84d273909ce1470eb63ddb07305") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") diff --git a/config/modules/Findtblite.cmake b/config/modules/Findtblite.cmake index 782e266f..6fa61363 100644 --- a/config/modules/Findtblite.cmake +++ b/config/modules/Findtblite.cmake @@ -17,7 +17,7 @@ set(_lib "tblite") set(_pkg "TBLITE") set(_url "https://github.com/tblite/tblite") -set(_branch "HEAD") +set(_branch "526baa60d331605af3aa5593000d164a93ea905e") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") diff --git a/config/modules/Findtest-drive.cmake b/config/modules/Findtest-drive.cmake index ed96bae6..b2784d87 100644 --- a/config/modules/Findtest-drive.cmake +++ b/config/modules/Findtest-drive.cmake @@ -17,6 +17,7 @@ set(_lib "test-drive") set(_pkg "TEST-DRIVE") set(_url "https://github.com/fortran-lang/test-drive") +set(_branch "e8b7ca492c647ed384c9845d2caed04192af7d02") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") @@ -24,7 +25,7 @@ endif() include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") -crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}") +crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}" "${_branch}") if(TARGET "${_lib}::${_lib}") set (found TRUE) diff --git a/config/modules/Findtoml-f.cmake b/config/modules/Findtoml-f.cmake index ca1da4cb..cc4cb55c 100644 --- a/config/modules/Findtoml-f.cmake +++ b/config/modules/Findtoml-f.cmake @@ -17,6 +17,7 @@ set(_lib "toml-f") set(_pkg "TOML-F") set(_url "https://github.com/toml-f/toml-f") +set(_branch "d5e92701d28b647323ce05ecbcbf302dd19792f7") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") @@ -24,7 +25,7 @@ endif() include("${CMAKE_CURRENT_LIST_DIR}/crest-utils.cmake") -crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}") +crest_find_package("${_lib}" "${${_pkg}_FIND_METHOD}" "${_url}" "${_branch}") if(TARGET "toml-f::toml-f") set (found TRUE) diff --git a/subprojects/dftd4.wrap b/subprojects/dftd4.wrap index 6b08287a..2ea27f49 100644 --- a/subprojects/dftd4.wrap +++ b/subprojects/dftd4.wrap @@ -1,6 +1,6 @@ [wrap-git] url = https://github.com/dftd4/dftd4 -revision = v4.0.0 +revision = 53cb17549a937e893c411e5679d741036dd4fbe6 clone-recursive = true [provide] diff --git a/subprojects/fmlip_relay.wrap b/subprojects/fmlip_relay.wrap index 956eae75..e773b3e9 100644 --- a/subprojects/fmlip_relay.wrap +++ b/subprojects/fmlip_relay.wrap @@ -3,7 +3,7 @@ # the submodule is checked out under subprojects/fmlip_relay/. [wrap-git] url = https://github.com/pprcht/fmlip-relay -revision = head +revision = 22a788a48031af3a1ae9f687af09595568dd9fb4 clone-recursive = true [provide] diff --git a/subprojects/gfn0.wrap b/subprojects/gfn0.wrap index 0fdd7261..eea8d469 100644 --- a/subprojects/gfn0.wrap +++ b/subprojects/gfn0.wrap @@ -1,6 +1,6 @@ [wrap-git] -url = https://github.com/grimme-lab/gfn0 -revision = head +url = https://github.com/pprcht/gfn0 +revision = 717cce283ede4fa88d949292291b1f0f6984440a clone-recursive = true [provide] diff --git a/subprojects/gfnff.wrap b/subprojects/gfnff.wrap index 9fff9917..2da13069 100644 --- a/subprojects/gfnff.wrap +++ b/subprojects/gfnff.wrap @@ -1,6 +1,6 @@ [wrap-git] url = https://github.com/pprcht/gfnff -revision = v0.1.1 +revision = e0d6e39863eaa09531b126dc4a1a58945abc25fb clone-recursive = true [provide] diff --git a/subprojects/lwoniom.wrap b/subprojects/lwoniom.wrap index e1afd4a1..ad578b0b 100644 --- a/subprojects/lwoniom.wrap +++ b/subprojects/lwoniom.wrap @@ -1,6 +1,6 @@ [wrap-git] -url = https://github.com/grimme-lab/lwoniom -revision = head +url = https://github.com/crest-lab/lwoniom +revision = ab66c7ebc3066328a8fc313dc783aec9b773cad2 clone-recursive = true [provide] diff --git a/subprojects/mctc-lib.wrap b/subprojects/mctc-lib.wrap index 59b0b394..cde3ba9b 100644 --- a/subprojects/mctc-lib.wrap +++ b/subprojects/mctc-lib.wrap @@ -1,6 +1,6 @@ [wrap-git] url = https://github.com/grimme-lab/mctc-lib -revision = head +revision = 8cd0cb4489537fd28bfb2e8094f1647f3e0da284 clone-recursive = true [provide] diff --git a/subprojects/mstore.wrap b/subprojects/mstore.wrap index 3aa6eea3..0dc55b08 100644 --- a/subprojects/mstore.wrap +++ b/subprojects/mstore.wrap @@ -1,6 +1,6 @@ [wrap-git] url = https://github.com/grimme-lab/mstore -revision = head +revision = 10a3437b3634dd4464557580ae36c1ed72535f6c clone-recursive = true [provide] diff --git a/subprojects/multicharge.wrap b/subprojects/multicharge.wrap index a77f7290..a201a243 100644 --- a/subprojects/multicharge.wrap +++ b/subprojects/multicharge.wrap @@ -1,6 +1,6 @@ [wrap-git] url = https://github.com/grimme-lab/multicharge -revision = v0.5.0 +revision = 6a5d63f9e9e29dcf13cc47cc27f33bf9015681bf clone-recursive = true [provide] diff --git a/subprojects/pvol.wrap b/subprojects/pvol.wrap index 958ae0b3..f8f6c02b 100644 --- a/subprojects/pvol.wrap +++ b/subprojects/pvol.wrap @@ -1,6 +1,6 @@ [wrap-git] url = https://github.com/pprcht/libpvol.git -revision = build-update +revision = c975ad4e062a00e6b228505bec0f1d722aea9f46 clone-recursive = true [provide] diff --git a/subprojects/s-dftd3.wrap b/subprojects/s-dftd3.wrap index 1f4669d1..d7e1399c 100644 --- a/subprojects/s-dftd3.wrap +++ b/subprojects/s-dftd3.wrap @@ -1,6 +1,6 @@ [wrap-git] -url = https://github.com/awvwgk/simple-dftd3 -revision = head +url = https://github.com/dftd3/simple-dftd3 +revision = 87efc010cd74f84d273909ce1470eb63ddb07305 clone-recursive = true [provide] diff --git a/subprojects/tblite.wrap b/subprojects/tblite.wrap index 4041e713..1725531d 100644 --- a/subprojects/tblite.wrap +++ b/subprojects/tblite.wrap @@ -1,6 +1,6 @@ [wrap-git] url = https://github.com/tblite/tblite -revision = head +revision = 526baa60d331605af3aa5593000d164a93ea905e clone-recursive = true [provide] diff --git a/subprojects/test-drive.wrap b/subprojects/test-drive.wrap index eb380856..1cb3242a 100644 --- a/subprojects/test-drive.wrap +++ b/subprojects/test-drive.wrap @@ -1,6 +1,6 @@ [wrap-git] url = https://github.com/fortran-lang/test-drive -revision = head +revision = e8b7ca492c647ed384c9845d2caed04192af7d02 clone-recursive = true [provide] diff --git a/subprojects/toml-f.wrap b/subprojects/toml-f.wrap index 0193de1c..ddb7a97c 100644 --- a/subprojects/toml-f.wrap +++ b/subprojects/toml-f.wrap @@ -1,6 +1,6 @@ [wrap-git] url = https://github.com/toml-f/toml-f -revision = v0.4.3 +revision = d5e92701d28b647323ce05ecbcbf302dd19792f7 clone-recursive = true [provide] From 740765dee1de1f10e8d8df00612d0a88fdd75d7c Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 24 Apr 2026 18:55:05 +0200 Subject: [PATCH 290/374] let refine write in extxyz format --- src/algos/refine.f90 | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/algos/refine.f90 b/src/algos/refine.f90 index 83ebc9e7..18bc9eb1 100644 --- a/src/algos/refine.f90 +++ b/src/algos/refine.f90 @@ -84,7 +84,6 @@ subroutine crest_refine(env,input,output) eread(j) = structures(j)%energy xyz(1:3,1:nat,j) = structures(j)%xyz(1:3,1:nat) end do - deallocate (structures) !===========================================================! DO_REFINE: if (allocated(env%refine_queue)) then @@ -136,15 +135,17 @@ subroutine crest_refine(env,input,output) end if DO_REFINE !===========================================================! -!>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: ensemble file must be written in AA - xyz = xyz/angstrom -!>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- write output ensemble - call wrensemble(outname,nat,nall,at,xyz,eread) +!>--- sync refined energies and coordinates back into coord structures + do j = 1,nall + structures(j)%energy = eread(j) + structures(j)%xyz(1:3,1:nat) = xyz(1:3,1:nat,j) + structures(j)%wrextxyz = .true. + end do +!>--- write output ensemble in extxyz format + call wrensemble(outname,nall,structures) !===========================================================! - deallocate (etmp,eread,xyz,at) + deallocate (etmp,eread,xyz,at,structures) return end subroutine crest_refine !========================================================================================! From d04cf0405cfc8d764a05d8b5c1d9b38029519676 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 24 Apr 2026 19:36:56 +0200 Subject: [PATCH 291/374] printout formatting --- src/sorting/cregen.f90 | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 7fef4656..7ea8fe1d 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -1198,8 +1198,8 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & if (groups(ii) .ne. gg) cycle do jj = ii+1,nall kk = groups(jj) - if (kk .ne. gg .or. kk < 0) cycle - + if (kk .ne. gg.or.kk < 0) cycle + workmols(cc)%nat = structures(jj)%nat workmols(cc)%at(:) = structures(jj)%at(:) workmols(cc)%xyz(:,:) = structures(jj)%xyz(:,:) @@ -1655,7 +1655,7 @@ subroutine cregen_irmsd_sort(env,nall,structures,groups,allcanon,printlvl) cc = omp_get_thread_num()+1 if (groups(jj) .ne. 0) cycle ediff = abs(structures(ii)%energy-structures(jj)%energy) - if(ediff > ETHR) cycle + if (ediff > ETHR) cycle if (individual_IDs) then rcaches(cc)%rank(1:nat,1) = sorters(ii)%rank(1:nat) rcaches(cc)%rank(1:nat,2) = sorters(jj)%rank(1:nat) @@ -2460,19 +2460,19 @@ subroutine cregen_pr2(ch,env,nall,ng,degen,er) !>-- really long energy list write (och,'(80("*"))') - write (och,'(1x,a8,1x,a8,3(1x,a12),1x,a9,1x,a5)') & + write (och,'(1x,a8,1x,a8,(1x,a16),(1x,a8),(1x,a12),1x,a9,1x,a5)') & & ' ','ΔE','Etot','weight','conf.weight','conformer','' - write (och,'(a8,1x,a8,3(1x,a12),1x,a9,1x,a5,1x,a6)') & + write (och,'(a8,1x,a8,(1x,a16),(1x,a8),(1x,a12),1x,a9,1x,a5,1x,a6)') & & 'id ','kcal/mol','hartree','p(i)','p(group)','group','degen','origin' - write (och,'(4x,4("-"),1x,8("-"),3(1x,12("-")),1x,9("-"),1x,5("-"),1x,6("-"))') + write (och,'(4x,4("-"),1x,8("-"),(1x,16("-")),(1x,8("-")),(1x,12("-")),1x,9("-"),1x,5("-"),1x,6("-"))') if (abbrev) then call remove('cregen.full') open (newunit=och2,file='cregen.full',status='replace') - write (och2,'(1x,a8,1x,a8,3(1x,a12),1x,a9,1x,a5)') & + write (och2,'(1x,a8,1x,a8,(1x,a16),(1x,a8),(1x,a12),1x,a9,1x,a5)') & & ' ','ΔE','Etot','weight','conf.weight','conformer','' - write (och2,'(a8,1x,a8,3(1x,a12),1x,a9,1x,a5,1x,a6)') & + write (och2,'(a8,1x,a8,(1x,a16),(1x,a8),(1x,a12),1x,a9,1x,a5,1x,a6)') & & 'id ','kcal/mol','hartree','p(i)','p(group)','group','degen','origin' - write (och2,'(4x,4("-"),1x,8("-"),3(1x,12("-")),1x,9("-"),1x,5("-"),1x,6("-"))') + write (och2,'(4x,4("-"),1x,8("-"),(1x,16("-")),(1x,8("-")),(1x,12("-")),1x,9("-"),1x,5("-"),1x,6("-"))') else call remove('cregen.full') end if @@ -2484,33 +2484,33 @@ subroutine cregen_pr2(ch,env,nall,ng,degen,er) a = degen(2,i) b = degen(3,i) if (k <= printlimit.or.k > nall-10) then - write (och,'(i8,1x,f8.4,1x,f12.6,2(1x,f12.5),1x,i9,1x,i5,a)') & + write (och,'(i8,1x,f8.4,1x,f16.6,(1x,f8.5),(1x,f12.5),1x,i9,1x,i5,a)') & & a,erel(a),er(a),p(a),pg(i),i,degen(1,i),trim(origin(a)) else if (print_placeholder) then print_placeholder = .false. write (och,'(5x,"...",1x," ...")') end if if (abbrev) then - write (och2,'(i8,1x,f8.4,1x,f12.6,2(1x,f12.5),1x,i9,1x,i5,a)') & + write (och2,'(i8,1x,f8.4,1x,f16.6,(1x,f8.5),(1x,f12.5),1x,i9,1x,i5,a)') & & a,erel(a),er(a),p(a),pg(i),i,degen(1,i),trim(origin(a)) end if do j = a+1,b k = k+1 if (k <= printlimit.or.k > nall-10) then - write (och,'(i8,1x,f8.4,1x,f12.6,1x,f12.5,1x,a12,1x,a9,1x,a5,1x,a)') & + write (och,'(i8,1x,f8.4,1x,f16.6,1x,f8.5,1x,a12,1x,a9,1x,a5,1x,a)') & & k,erel(j),er(j),p(j),'.','.','.',trim(origin(j)) else if (print_placeholder) then print_placeholder = .false. write (och,'(5x,"...",1x," ...")') end if if (abbrev) then - write (och2,'(i8,1x,f8.4,1x,f12.6,1x,f12.5,1x,a12,1x,a9,1x,a5,1x,a)') & + write (och2,'(i8,1x,f8.4,1x,f16.6,1x,f8.5,1x,a12,1x,a9,1x,a5,1x,a)') & & k,erel(j),er(j),p(j),'.','.','.',trim(origin(j)) end if end do end do - if(abbrev) close(och2) + if (abbrev) close (och2) !>-- file for the '-compare' mode if (env%compareens) then From 244b4369094ec90c32f0525933f56f879db59476 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 24 Apr 2026 20:11:59 +0200 Subject: [PATCH 292/374] Avoid starting calculations by itself. require explicit runtype specification now --- src/confparse.f90 | 2 +- src/crest_main.f90 | 13 +++++++++---- src/printouts.f90 | 40 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 50 insertions(+), 5 deletions(-) diff --git a/src/confparse.f90 b/src/confparse.f90 index 73f78974..8e279f84 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -333,7 +333,7 @@ subroutine parseflags(env,arg,nra) !=========================================================================================! !=========================================================================================! !>--- get the CREST version/runtype - env%crestver = crest_imtd !> confscript version (v.1 = MF-MD-GC, v.2 = MTD) + env%crestver = crest_none !> no runtype selected — must be set explicitly env%runver = 1 !> default env%properties = p_none !> additional calculations/options before or after confsearch env%properties2 = p_none !> backup for env%properties diff --git a/src/crest_main.f90 b/src/crest_main.f90 index 416040f1..89acaa59 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -223,10 +223,12 @@ program CREST !=========================================================================================! !> PRE-OPTIMIZATION OF THE GEOMETRY !=========================================================================================! - if (env%preopt) then - call trialOPT(env) - else if (env%presp) then - call xtbsp(env) + if (env%crestver /= crest_none) then + if (env%preopt) then + call trialOPT(env) + else if (env%presp) then + call xtbsp(env) + end if end if !=========================================================================================! !> SET UP QUEUES, IF REQUIRED @@ -316,6 +318,9 @@ program CREST case (crest_test) call crest_playground(env,tim) + case (crest_none) + call crest_no_runtype_selected() + case default continue end select diff --git a/src/printouts.f90 b/src/printouts.f90 index f49e218d..20a60552 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -927,3 +927,43 @@ subroutine gxtb_dev_warning write (stdout,*) call creststop(status_safety) end subroutine gxtb_dev_warning + +!========================================================================================! +!========================================================================================! + +subroutine crest_no_runtype_selected() + !***************************************************** + !* Print an error when no runtype has been selected, * + !* list the available main runtypes, and stop. * + !***************************************************** + use crest_parameters,only:stdout + use crest_data,only:status_safety + implicit none + write (stdout,*) + write (stdout,'(1x,a)') repeat('=',60) + write (stdout,'(1x,a)') 'No runtype was selected.' + write (stdout,'(1x,a)') 'Please choose one of the main runtypes listed below.' + write (stdout,'(1x,a)') repeat('=',60) + write (stdout,*) + write (stdout,'(3x,a)') 'Main runtypes:' + write (stdout,*) + write (stdout,'(5x,a,t30,a)') '--sp','Single-point energy calculation' + write (stdout,'(5x,a,t30,a)') '--opt','Structure optimization' + write (stdout,'(5x,a,t30,a)') '--md','Molecular dynamics simulation' + write (stdout,'(5x,a,t30,a)') '--v3','iMTD-GC conformational search' + write (stdout,'(5x,a,t30,a)') '--entropy','Entropy/free-energy sampling' + write (stdout,'(5x,a,t30,a)') '--mdopt','Ensemble optimization (no sorting)' + write (stdout,'(5x,a,t30,a)') '--screen','Ensemble screening' + write (stdout,'(5x,a,t30,a)') '--protonate','Protonation site search' + write (stdout,'(5x,a,t30,a)') '--deprotonate','Deprotonation site search' + write (stdout,'(5x,a,t30,a)') '--tautomerize','Tautomer generation' + write (stdout,'(5x,a,t30,a)') '--qcg','QCG workflows' + write (stdout,'(5x,a,t30,a)') '--msreact','MSREACT workflows' + write (stdout,'(5x,a,t30,a)') '--bh','Basin-hopping global optimization' + write (stdout,'(5x,a,t30,a)') '--sort','Ensemble sorting (CREGEN)' + write (stdout,*) + write (stdout,'(3x,a)') 'For TOML input files use: crest --input ' + write (stdout,'(3x,a)') 'For the full option list: crest --help' + write (stdout,*) + call creststop(status_safety) +end subroutine crest_no_runtype_selected From 919ced4d599f00e7cc09c8ab741d4d6d06b2ffef Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 24 Apr 2026 20:49:01 +0200 Subject: [PATCH 293/374] rewire --cregen/--sort logic for easier use --- src/algos/sorting.f90 | 2 +- src/confparse.f90 | 49 ++++++++++++------------------------------- src/crest_main.f90 | 28 ------------------------- 3 files changed, 14 insertions(+), 65 deletions(-) diff --git a/src/algos/sorting.f90 b/src/algos/sorting.f90 index b1592793..74de919c 100644 --- a/src/algos/sorting.f90 +++ b/src/algos/sorting.f90 @@ -93,7 +93,7 @@ subroutine crest_sort(env,tim) call cregen_irmsd_all(nall,structures,printlvl=2,iinversion=env%iinversion) case ('cregen') -!>--- the original CREGEN procedure (fallback, needs nicer implementations) +!>--- the original CREGEN procedure call newcregen(env,structurelist=structures) call catdel('cregen.out.tmp') diff --git a/src/confparse.f90 b/src/confparse.f90 index 8e279f84..403d14aa 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -891,10 +891,15 @@ subroutine parseflags(env,arg,nra) write (stdout,'(2x,a,t15,a)') argument//':','Molecular dynamics simulation' exit - case ('-sort') + case ('-sort','-cregen') processedarg(i) = .true. env%preopt = .false. env%crestver = crest_sorting + env%autozsort = .false. + if (argument == '-cregen') then + env%sortmode = 'cregen' + env%confgo = .true. + end if ctmp = arg1 inquire (file=ctmp,exist=ex) if (ex) then @@ -902,7 +907,7 @@ subroutine parseflags(env,arg,nra) env%inputcoords = ctmp env%ensemblename = ctmp end if - if (nra >= i+2) then + if (argument == '-sort' .and. nra >= i+2) then ctmp = arg2 if (ctmp(1:1) .ne. '-') then processedarg(i+2) = .true. @@ -973,6 +978,10 @@ subroutine parseflags(env,arg,nra) call inputcoords(env,trim(arg(1))) processedarg(1) = .true. end if +!> For sorting runtypes, fall back to the input file if no ensemble was set explicitly + if (env%crestver == crest_sorting .and. len_trim(env%ensemblename) == 0) then + env%ensemblename = env%inputcoords + end if !========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>! @@ -2081,38 +2090,6 @@ subroutine parseflags(env,arg,nra) case ('-inplace') !> activate "in-place" mode for optimizations (ON by default) processedarg(i) = .true. env%inplaceMode = .true. -!========================================================================================! -!------- CREGEN related flags -!========================================================================================! - case ('-cregen','-oldcregen') !> CREGEN standalone use - processedarg(i) = .true. - env%confgo = .true. - env%properties = p_cregen - env%autozsort = .false. - atmp = '' - env%ensemblename = 'none selected' - if (nra .ge. (i+1)) atmp = adjustl(arg(i+1)) - if ((atmp(1:1) /= '-').and.(len_trim(atmp) .ge. 1)) then - env%ensemblename = trim(atmp) - processedarg(i+1) = .true. - end if - if (index(env%ensemblename,'none selected') .ne. 0) then - write (stdout,'(2x,a,1x,a)') trim(arg(i)),': CREGEN standalone usage.' - else - write (stdout,'(2x,a,1x,a,a,a)') trim(arg(i)),': CREGEN standalone usage. Sorting file <', & - & trim(env%ensemblename),'>' - end if - if (trim(arg(i)) .eq. '-oldcregen') then - write (stdout,'(3x,a)') 'Using the old version of the CREGEN subroutine.' - env%newcregen = .false. - end if - - case ('-oldcr') - processedarg(i) = .true. - write (stdout,'(3x,a)') 'Using the old version of the CREGEN subroutine.' - env%newcregen = .false. - env%ethr = 0.1d0 !> ETHR old value - case ('-enso') !> compare two given ensembles processedarg(i) = .true. env%ENSO = .true. @@ -2795,8 +2772,8 @@ subroutine parseflags(env,arg,nra) if (env%properties == p_propcalc) then !>--- for standalone use env%properties = p_cluster - elseif (env%confgo.and.env%properties == p_cregen) then - !>--- as extension for CREGEN + elseif (env%crestver == crest_sorting) then + !>--- as extension for CREGEN/sorting env%cluster = .true. else if (any((/crest_imtd,crest_imtd2/) == env%crestver)) then !>--- works as an extensiton to the conformational search diff --git a/src/crest_main.f90 b/src/crest_main.f90 index 89acaa59..41aca294 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -102,34 +102,6 @@ program CREST !> PRE-CONFSEARCH PROPERTY CALCS !=========================================================================================! select case (env%properties) -!>--- only CREGEN routine - case (p_cregen) - call tim%start(1,'CREGEN') - write (*,*) 'Using only the CREGEN sorting routine.' - env%cgf(6) = .true. !write confg output to file - if (env%doNMR) then - env%cgf(3) = .true. - if (.not.env%fullcre) then - env%cgf(2) = .false. - end if - end if - if (env%newcregen) then - block - use cregen_interface - call newcregen(env,0) - end block - else - call cregen2(env) - end if - if (env%doNMR.and.env%fullcre) then - call entropic(env,.true.,.false.,.false.,env%ensemblename, & - & env%tboltz,dumfloat,dumfloat2) - end if - if (env%cluster) then - call ccegen(env,.true.,ensemblefile) - end if - call tim%stop(1) - call propquit(tim) !>--- zsort routine case (p_zsort) call zsort From 9a8afe7fac7515caf8563a83f31578995279be2b Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 24 Apr 2026 23:29:39 +0200 Subject: [PATCH 294/374] Nicer --help menu print, plus some man page cleanup --- docs/man/crest.adoc | 656 ++++++++++++++++++++++++++++++-------------- src/printouts.f90 | 606 +++++++++++++++++++++++----------------- 2 files changed, 802 insertions(+), 460 deletions(-) diff --git a/docs/man/crest.adoc b/docs/man/crest.adoc index b59a4d1b..75b41ce2 100644 --- a/docs/man/crest.adoc +++ b/docs/man/crest.adoc @@ -14,10 +14,10 @@ // You should have received a copy of the GNU Lesser General Public License // along with crest. If not, see . = crest(1) -P.Pracht; S.Grimme; Universitaet Bonn, MCTC +P.Pracht; S.Grimme; C.Bannwarth; F.Bohle; S.Ehlert; G.Feldmann; J.Gorges; C.Plett; S.Spicher; P.Steinbach; P.Wesolowski; F.Zeller :doctype: manpage // This attribute should be set from the build system: -:release-version: +:release-version: :man manual: User Commands :man source: Crest {release-version} :page-layout: base @@ -28,352 +28,584 @@ crest - Conformer-Rotamer Ensemble Sampling Tool based on the GFN methods == SYNOPSIS -*crest* [_INPUT_] [_OPTION_]... +*crest* [_INPUT_] [_OPTIONS_]... + +*crest* *--input* _file.toml_ == DESCRIPTION -Conformer-Rotamer Ensemble Sampling Tool based on the GFN methods. +CREST is a conformer/rotamer ensemble sampling tool that interfaces with +various quantum chemistry backends to explore molecular potential energy +surfaces. +It supports conformational searches, protonation/tautomer workflows, solvation +cluster growth, mass-spectral fragmentation, and various standalone utility +tasks. -Using the xTB program. Compatible with xTB version 6.4.0. +The _INPUT_ argument can be a coordinate file in TM (*coord*, Bohr) or +Xmol (*\*.xyz*, Angstrom) format. +If omitted, CREST searches the working directory for a file named *coord*. +Versions 3.0 and later also accept a TOML input file either as the first +positional argument or via *--input*. .Cite work conducted with this code as [quote] ---- P. Pracht, F. Bohle, S. Grimme, PCCP, 2020, 22, 7169-7192. - - and S. Grimme, JCTC, 2019, 15, 2847-2862. - - with help from: - F.Bohle, S.Ehlert, S.Grimme, P.Pracht + S. Grimme, JCTC, 2019, 15, 2847-2862. + P. Pracht et al., J. Chem. Phys., 2024, 160, 114110. ---- -This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +For QCG calculations additionally cite: + +[quote] +---- + S. Spicher, C. Plett, P. Pracht, A. Hansen, S. Grimme, + JCTC, 2022, 18 (5), 3174-3189. + C. Plett, S. Grimme, + Angew. Chem. Int. Ed. 2023, 62, e202214477. +---- == OPTIONS -The FIRST argument CAN be a coordinate file in the TM **(coord, Bohr)** or Xmol **(*.xyz, Ang.)** format. -If no such file is present as the first argument **crest** will automatically search for a file called "`**coord**`" in the TM format. +=== Run modes -=== General and technical options +*--sp*:: + Single-point energy calculation. -*-v1*:: - Use the MF-MD-GC workflow. - (_OUTDATED_) +*--opt*, *--optimize*:: + Geometry optimization. -*-v2*:: - Use the MTD-GC workflow. - (_OUTDATED_) +*--hess*, *--numhess*:: + Numerical Hessian / vibrational frequencies. -*-v3* (or *-v2i*):: - Use the iMTD-GC workflow. - [_default_] +*--md*, *--dynamics*:: + Stand-alone molecular dynamics simulation. -*-v4*:: - Use the iMTD-sMTD workflow. +*--v3*, *--v2i*:: + iMTD-GC iterative conformational search. + [_default_ conformer search] -*-entropy*:: - The same workflow as with "`**-v4**`", specialized for the calculation of conformational entropy. +*--v4*, *--entropy*:: + iMTD-sMTD entropy-focused conformational search. -*-xnam* _bin_:: - Specify name of the **xtb**(1) binary that should be used. +*--mdopt* [_file_]:: + Optimize every structure in an ensemble file. -*-niceprint*:: - Progress bar printout for optimizations. +*--screen* [_file_]:: + Multi-level energy screening of an ensemble. -*-dry*:: - Perform a "`dry run`". - Only prints the settings that would be applied with the CMD input and stops the run before any calculations +*--protonate*:: + Automated protonation site search. -*-T* _int_:: - Set total number of CPUs (threads) to be used. - Parallel settings are then determined automatically for each step. - If not set by "`**-T**`", this number is read from the **OMP_NUM_THREADS** global variable. +*--deprotonate*:: + Automated deprotonation site search. -=== Calculation options +*--tautomerize*:: + Automated tautomer search. -*-g* _string_:: - Use GBSA implicit solvent for solvent _string_. +*--qcg* [_solvent_]:: + Quantum Cluster Growth solvation workflows. -*-alpb* _string_:: - Use ALPB implicit solvent for solvent _string_. +*--msreact*:: + Mass-spectral fragment generator. -*-chrg* _int_:: - Set the molecules`' charge. +*--bh*, *--GMIN*:: + Basin-hopping global optimization. -*-uhf* _int_:: - Set _int_=**N alpha - N beta** electrons - -*-nozs*:: - Do not perform z-mat sorting. - [_default_] +*--sort*:: + Ensemble sorting via CREGEN. -*-opt* _lev_:: - Set optimization level for **ALL** GFN-xTB optimizations. - [_default_: **vtight**] +=== Method selection - * _lev_ = **vloose**, **loose**, **normal**, **tight**, **vtight** +*-gfn2*:: + Use GFN2-xTB. + [_default_] *-gfn1*:: Use GFN1-xTB. -*-gfn2*:: - Use GFN2-xTB. - [_default_] +*-gfn0*:: + Use GFN0-xTB. *-gff*, *-gfnff*:: - Use GFN-FF (requires **xtb**(1) 6.3 or newer). - (For GFN-FF searches bond constraints are applied automatically.) + Use GFN-FF. + Bond constraints are applied automatically for GFN-FF searches. + +*-gxtb*:: + Use g-xTB (requires a special build). *-gfn2//gfnff*:: - GFN2-xTB//GFN-FF composite mode. + GFN-FF trajectories with GFN2-xTB energy reweighting. + +*-refine* _method_:: + Post-process conformers at a higher level of theory. + +*-optlev* _level_:: + Optimization convergence level for all semiempirical calculations. + _level_ = *crude*, *vloose*, *loose*, *normal*, *tight*, *vtight*, *extreme*. + +*-dscal* [_factor_]:: + Scale the dispersion energy in MD/MTD simulations. + +=== Molecular system + +*-T* _int_:: + Number of CPU threads. + If not set, read from *OMP_NUM_THREADS*. + +*-chrg* _int_:: + Molecular charge. -*Adding additional constraints to the calculations:* +*-uhf* _int_:: + Number of unpaired electrons (N_alpha - N_beta). + +*-g* _solvent_, *-gbsa* _solvent_:: + GBSA implicit solvation. + +*-alpb* _solvent_:: + ALPB implicit solvation. + +*-efield* _Ex_ _Ey_ _Ez_:: + Apply a homogeneous external electric field in V/Ang along x, y, z. + +*-charges* [_file_]:: + Read atomic partial charges from _file_ (default: *charges*). + +=== Technical options + +*--input* _file_:: + Specify a TOML input file with detailed settings. + +*-xnam* _bin_:: + Path to the xtb executable (when using xtb as the backend). + +*-noopt*:: + Skip pre-optimization of the input structure. + +*-niceprint*:: + Show an animated progress bar during long runs. + +*-dry*:: + Parse all arguments, print the resolved settings, then exit without + running any calculation. + +*-legacy*:: + Force CREST < 3.0 behaviour. -The user is able to include additional constraints to **ALL** xtb**(1)** calculations that are conducted by CREST. +=== Constraints + +The following flags apply constraints to *all* calculations made by CREST. *-cinp* _file_:: - Read in a file containing the constraints. - Constraints have to be in the same format as in xtb**(1)**. - (This was done previously via the "`**.constrains**`" file.) + Read constraints from _file_ (same format as in *xtb*(1); + formerly passed via *.constrains*). + +*-cbonds* [_fc_]:: + Constrain all bonds globally (derived from topology). + Optional force constant _fc_ in Eh. -*-cbonds*:: - Define automatic bond constraints (set up from topology). +*-cbonds_md* [_fc_]:: + Constrain all bonds during MDs/MTDs only, not optimizations. *-nocbonds*:: - Turn off **-cbonds**. (For GFN-FF, mainly. See above.) + Disable automatic bond constraints. *-fc* _float_:: - Define force constant for defined constraints (**-cbonds**). + Global force constant for bond constraints. -=== Options for ensemble comparisons +=== Ensemble comparison and sorting (CREGEN) -*-cregen* _file_:: - Use **ONLY** the CREGEN subroutine to sort a given ensemble file. +*-cregen* [_file_]:: + Run CREGEN standalone to sort and deduplicate an ensemble file. *-ewin* _real_:: - Set energy window in kcal/mol. - [_default_: **6.0** kcal/mol] + Energy window in kcal/mol. + [_default_: *6.0* kcal/mol] *-rthr* _real_:: - Set RMSD threshold in Ang. - [_default_: **0.125** Ang] + RMSD threshold in Ang. + [_default_: *0.125* Ang] *-ethr* _real_:: - Set E threshold in kcal/mol. - [_default_: **0.05** kcal/mol] + Energy threshold in kcal/mol. + [_default_: *0.05* kcal/mol] *-bthr* _real_:: - Set Rot. const. threshold. - [_default_: **0.01** (= 1%)] + Rotational constant threshold. + [_default_: *0.01* (= 1%)] *-pthr* _real_:: - Boltzmann population threshold. - [_default_: **0.05** (= 5%)] + Boltzmann population threshold (0-1). + [_default_: *0.05*] *-temp* _real_:: - Set temperature in **CREGEN**. - [_default_: **298.15** K] + Temperature for Boltzmann weighting in K. + [_default_: *298.15* K] -*-prsc*:: - Create a **scoord.*** file for each conformer. +*-topo*, *-notopo*:: + Enable or disable the topology change check. -*-nowr*:: - Don't write new ensemble files. +*-ezcheck*:: + Enable E/Z double-bond isomer check. -*-eqv*,*-nmr*,*-entropy*:: - Compare nuclear equivalences (requires rotamers). +*-heavy*:: + Use heavy-atom-only RMSD. + +*-allrot*:: + Use all three rotational constants (A, B, C) for duplicate detection. + +*-eqv*, *-nmr*:: + NMR nuclear equivalence analysis (requires rotamers). *-cluster* _int_:: - PCA and k-Means clustering of sorted ensemble. - Works as extenstion to the **CREGEN** sorting. - _int_ is the number of clusters to be formed. + PCA + k-Means clustering of the sorted ensemble. + _int_ is the number of clusters. -*-notopo*:: - Turn off any topology checks in **CREGEN**. +*-prsc*:: + Write *scoord.** files for each conformer. -=== Options for the iMTD-GC workflows +*-nowr*:: + Skip writing the sorted ensemble file. -*-cross*:: - Do the GC part. +*-osdf*:: + Write the output ensemble in SDF format in addition to XYZ. + +=== Conformer search / sampling + +*-v3*, *-v2i*:: + iMTD-GC (iterative MTD-GC). [_default_] -*-nocross*:: - Don't do the GC part. +*-v4*, *-entropy*:: + iMTD-sMTD, specialized for entropy/free-energy sampling. + +*-len* _t_[*x*], *-mdlen* _t_[*x*]:: + MD/MTD simulation length in ps. + Append *x* to scale the default length by a factor instead. + +*-tstep* _float_:: + MD integration timestep in fs. + [_default_: *5* fs] *-shake* _int_:: - Set SHAKE mode for MD. - (**0**=off, **1**=H-only, **2**=all bonds) - [_default_: **2**] + SHAKE constraint mode: *0* = off, *1* = X-H bonds only, *2* = all bonds. + [_default_: *1*] -*-tstep* _int_:: - Set MD time step in fs. - [_default_: **5** fs] +*-mdtemp* _float_:: + Temperature for MTD simulations in K. -*-mdlen/-len* _real_:: - Set MD length (all MTDs) in ps. - Also possible are multiplicative factors for the default MD length with "`**x**_real_`". +*-tnmd* _float_:: + Temperature for additional normal (unbiased) MDs in K. *-mddump* _int_:: - xyz dumpstep to Trajectory in fs. - [_default_: **100** fs] + Trajectory structure dump interval in fs. + [_default_: *100* fs] *-vbdump* _real_:: - Set Vbias dump frequency in ps. - [_default_: 1.0 ps] + Vbias (MTD bias) dump frequency in ps. + [_default_: *1.0* ps] -*-tnmd* _real_:: - Set temperature for additional normal MDs. - [_default_: 400 K] +*-nmtd* _int_:: + Number of MTD simulations per search cycle. -*-norotmd*:: - Don't do the regular MDs after the second multilevel optimization step. +*-cross*, *-nocross*:: + Enable or disable the genetic structure crossing step. + [_default_: *-cross*] -*-quick*:: - Perform a search with reduced settings for a crude ensemble. +*-gcmax* _int_:: + Maximum number of structures fed into the genetic crossing. -*-squick*:: - Perform a even further reduced search. +*-nozs*:: + Disable z-matrix sorting. + +*-normmd* [_n_ [_T_]]:: + Run additional unbiased MDs on the lowest-energy conformers. -*-mquick*:: - Perform a search with maximum reduced settings. - (Do not reduce the settings more than that.) +*-quick*, *-squick*, *-mquick*:: + Progressively reduced search settings for fast, approximate ensembles. *-origin*:: - Track the step of generation for each conformer/rotamer. + Track the MTD step of origin for each conformer. [_default_] *-keepdir*:: - Keep sub-directories of the conformer generation step. + Keep temporary working directories after the run. + +*-NCI*:: + NCI cluster mode: flat-bottom wall potential and specialised MTD settings + suited for weakly-bound complexes. -*-nci*:: - Generate an ellipsoide potential around the input structure and add it to the MTD simulation. - This can be used to find aggregates of NCI complexes. +*-wscal* _float_:: + Scale the wall potential sphere radius. -*-wscal* _real_:: - Scale the ellipsoide potential axes by factor _real_. +*-hflip*, *-noflip*:: + Enable or disable OH proton flipping after MTD. + [_default_: *-noflip*] -=== Thermostatistical options (used in entropy mode) +*-maxflip* _int_:: + Maximum number of OH flip attempts. + [_default_: *1000*] -*-trange* _lower_ _upper_ _step_:: - Entropies are calculated for different temperatures. - These are calculated in a temperature range from _lower_ to _upper_ with _step_ in between. - [_default_: **280**K-**380**K in **10**K steps] +=== Thermostatistical options + +*-trange* _Tmin_ _Tmax_ _Tstep_:: + Compute entropies over a temperature range. + [_default_: *280*-*380* K in *10* K steps] + +*-tread* _file_:: + Read a list of temperatures (one per line) from _file_. *-fscal* _float_:: - Frequency scaling factor. - [_default_: 1.0] + Vibrational frequency scaling factor. + [_default_: *1.0*] -*-sthr* _float_:: - Vibrational/rotational entropy interpolation threshold (tau). - [_default_: **25.0** cm^-1] +*-sthr* _float_, *-rotorcut* _float_:: + Rotor cutoff in cm^-1: modes below this are treated as free rotors. + [_default_: *25.0* cm^-1] *-ithr* _float_:: Imaginary mode inversion cutoff. - [_default_: **-50.0** cm^-1] + [_default_: *-50.0* cm^-1] *-ptot* _float_:: - Sum of population for structures considered in msRRHO average. - [_default_: **0.9** (= 90%)] + Cumulative Boltzmann population threshold for msRRHO averaging. + [_default_: *0.9*] -=== options for MSREACT automated mass spectra fragment generator +*-pcap* _int_:: + Maximum number of structures used in property (Hessian) calculations. - *-msreact*:: - start the msreact mode +*-printpop*:: + Print Boltzmann populations at every temperature in the range. - *-msnoattrh*:: - deactivate attractive potential between hydrogen and LMO centers +*-avbhess*:: + Use a Boltzmann-averaged Hessian in the rrhoav property calculation. - *-msnshifts* _int_:: - perform n optimizations with randomly shifted atom postions (default 0) +=== Quantum Cluster Growth (QCG) - *-msnshifts* _int_:: - perform n optimizations with randomly shifted atom postions and repulsive potential applied to bonds (default 0) +General usage: *crest* _solute_ *-qcg* _solvent_ [_options_] - *-msnbonds* _int_:: - maximum number of bonds between atoms pairs for applying repulsive potential (default 3) +*-grow*:: + Cluster generation run type. - *-msmolbar*:: - sort out topological duplicates by molbar codes (requires sourced "molbar") +*-nsolv* _int_:: + Number of solvent molecules to add. - *-msinchi*:: - sort out topological duplicates by inchi codes (requires sourced "obabel") +*-fixsolute*:: + Fix the solute during cluster growth (recommended for rigid molecules; + applied automatically for water). - *-msnfrag* _int_:: - number of fragments that are printed by msreact (random selection) - - *-msiso*:: - print only non-dissociated structures (isomers) +*-nofix*:: + Do not fix the solute during growth (override for water). - *-msnoiso*:: - print only dissociated structures +*-nopreopt*:: + Skip pre-optimization. - *-mslargeprint*:: - do not remove temporary files and MSDIR with constrained optimizations +*-xtbiff*:: + Use the xTB-IFF standalone program for solvent docking. - *-chrg* _int_:: - set the molecules´ charge - - *-ewin* _float_:: - set energy window in for sorting out fragments kcal/mol, [default: 200.0 kcal/mol] - -=== Other tools for standalone use +*-normdock*:: + Perform a more extensive docking step during growth. -*-zsort*:: - Use only the **zsort** subroutine to sort the z-matrix of the input coordinate file. +*-maxsolv*:: + Set the convergence limit when *-nsolv* is not given. + [_default_: *150*] + +*-wscal* _float_:: + Scaling factor for the outer wall potential. + +*-samerand*:: + Use the same random seed for every xTB-IFF run. + +*-directed* _file_:: + Directed solvation: place solvent at positions defined in _file_. + +*-fin_opt_gfn2*:: + Perform final GFN2-xTB optimization of grow and ensemble structures. + +*-ensemble*:: + Ensemble generation run type. + +*-qcgmtd*, *-ncimtd*:: + NCI-MTD CREST ensemble generation. + [_default_] + +*-mtd*:: + MTD for QCG ensemble generation. + +*-md*:: + Normal MD for QCG ensemble search. + +*-enslvl* [_method_]:: + Method for ensemble search (all GFN methods supported). + +*-clustering*:: + Enable clustering for ensemble search (qcgmtd/ncimtd only). + +*-esolv*:: + Reference cluster generation and solvation energy calculation. + +*-gsolv*:: + Reference cluster generation and solvation free energy calculation. + +*-nclus*:: + Number of clusters for reference generation. + [_default_: *4*] + +*-nocff*:: + Disable the CFF algorithm. + +*-freqscal*:: + Frequency scale factor (output only). + +*-freqlvl* [_method_]:: + Method for frequency computation. + +=== Mass spectral fragment generator (MSReact) + +General usage: *crest* _input_ *-msreact* [_options_] + +*-msnoattrh*:: + Deactivate attractive potential between H atoms and LMO centers. + +*-msnshifts* _int_:: + Number of optimizations with randomly shifted atom positions. + [_default_: *0*] + +*-msnshifts2* _int_:: + Same as *-msnshifts* but with bond-repulsive potential applied. + [_default_: *0*] + +*-msnbonds* _int_:: + Maximum bond distance for the repulsive potential. + [_default_: *3*] + +*-msmolbar*:: + Deduplicate fragments by molbar codes (requires *molbar* in PATH). + +*-msinchi*:: + Deduplicate fragments by InChI codes (requires *obabel*(1) in PATH). + +*-msnfrag* _int_:: + Number of fragments to print (random selection). + +*-msiso*:: + Print only non-dissociated structures (isomers). -*-mdopt* _file_:: - Optimize along trajectory or ensemble file in the XYZ format. - Each point on the file is optimized. +*-msnoiso*:: + Print only dissociated structures. -*-screen* _file_:: - Optimize along ensemble file in the XYZ format. - A multilevel optimization is performed with continiously increasing thresholds. - After each step the ensemble file is sorted. +*-mslargeprint*:: + Keep all temporary files and the MSDIR directory. + +*-ewin* _real_:: + Energy window for fragment sorting in kcal/mol. + [_default_: *200.0* kcal/mol] + +*-msinput* _file_:: + Read special MSReact settings from _file_. + +=== Other standalone tools + +*-thermo* _file_:: + Compute thermochemistry from existing Hessian data. + Requires a *vibspectrum* file in TM format in the working directory. + +*-entropy* [_T_]:: + Compute conformational entropy from an ensemble. + Optional temperature _T_ in K. + +*-sort*:: + Sort ensemble structures by energy (CREGEN). + +*-symmetries*:: + Symmetry analysis of all structures in an ensemble. + +*-printboltz*:: + Print Boltzmann population weights for each structure. + +*-compare* _f1_ _f2_:: + Compare two ensembles _f1_ and _f2_ for structural overlap. + Both files must share the same atom ordering. + + *-maxcomp* _int_::: + Maximum number of conformers taken from each ensemble for comparison. + [_default_: *10*] + +*-splitfile* _file_ [_i_] [_j_]:: + Split an ensemble into per-structure directories under *SPLIT/*. + _i_ and _j_ optionally select a range of structures. + +*-rmsd* _f1_ _f2_:: + RMSD between two structures (coordinates auto-converted to Angstrom). + +*-rmsdheavy* _f1_ _f2_:: + Heavy-atom RMSD between two structures. *-protonate*:: - Find a molecule's protomes by using a LMO pi- or LP-center approach. + Automated protonation site search via LMO pi/LP-center approach. *-deprotonate*:: - Find a molecule's deprotomers. + Automated deprotonation site search. *-tautomerize*:: - Combine the protonation and deprotonation to find prototropic tautomers. + Find prototropic tautomers (protonation + deprotonation). *-trev*::: - Do first the deprotonation and then the protonation in the *-tautomerize* mode, i.e., reverse of the default procedure. + Deprotonate first, then protonate (reverse order). *-iter* _int_::: - Set number of protonation/deprotonation cycles in the tautomerization script. - [_default_: 2] + Number of protonation/deprotonation cycles. + [_default_: *2*] -*-compare* _f1_ _f2_:: - Compare two ensembles _f1_ and _f2_. - Both ensembles must have the same order of atoms of the molecule and should contain rotamers. +*-cregen* [_file_]:: + CREGEN ensemble sorting (see also _Ensemble comparison_ above). - *-maxcomp* _int_::: - Select the lowest _int_ conformers out of each ensemble to be compared with "`*-compare*`". - [_default_: 10] +*-zsort*:: + Z-matrix sorting of the input coordinate file. *-testtopo* _file_:: - Analyze some stuctural info (topology) for a given file. + Topology / bond connectivity analysis for a given file. *-constrain* _atoms_:: - Write example file "`*.xcontrol.sample*`" for constraints in crest. - (See *-cinp* option above.) + Write an example constraint file *.xcontrol.sample*. -*-thermo* _file_:: - Calculate thermo data for given structure. - Also requires vibrational frequencies in the TM format, saved as file called "`*vibspectrum*`". +=== TOML input files -*-rmsd*,*-rmsdheavy* _file1_ _file2_:: - Calculate RMSD or heavy atom RMSD between two structures. - Input coords are automatically transformed to Angstroem. +CREST 3.0+ accepts a TOML file as a flexible alternative to CLI flags. -*-splitfile* _file_ [*from*] [*to*]:: - Split an ensemble from _file_ into seperate directories for each structure. - *from* and *to* can be used to select specific structures from the file. - The new directories are collected in the *SPLIT* directory. + crest structure.xyz --input settings.toml + crest settings.toml # structure path given inside the file + +A minimal TOML input file: + +---- +input = "struc.xyz" +runtype = "iMTD-GC" +threads = 4 + +[calculation] + [[calculation.level]] + method = "gfn2" + chrg = 0 + gbsa = "h2o" +---- + +Key root-level settings: *input*/*structure* (coordinate file), +*runtype* (workflow), *threads* (CPU count), *preopt* (bool), +*constraints* (constraint file path). + +Main blocks: *[calculation]* / *[[calculation.level]]* / +*[[calculation.constraint]]* — method, charge, solvent, geometric +constraints; *[dynamics]* / *[[dynamics.meta]]* — MD and metadynamics +settings; *[cregen]* — sorting thresholds; *[thermo]* — thermochemistry. == NOTES -View literature references with **--cite**. +View full literature references with *--cite*. + +For the full option reference and TOML keyword documentation see: +https://crest-lab.github.io/crest-docs/ + +== SEE ALSO + +https://crest-lab.github.io/crest-docs/ diff --git a/src/printouts.f90 b/src/printouts.f90 index 20a60552..d3a6cab4 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -132,266 +132,368 @@ end subroutine disclaimer !=========================================================================================! +subroutine help_section(title) + !************************************* + !* Print a colored section header. * + !************************************* + use iomod,only:colorify + use crest_parameters,only:stdout + implicit none + character(len=*),intent(in) :: title + integer :: n + n = len_trim(title) + write(stdout,'(/,1x,a)') colorify(trim(title),'yellow') + write(stdout,'(1x,a)') colorify(repeat('─',n),'yellow') +end subroutine help_section + + +subroutine help_opt(flag,fw,desc) + !********************************************************************* + !* Print one colored flag + description, padding the flag column to * + !* fw characters wide so descriptions align. * + !********************************************************************* + use iomod,only:colorify + use crest_parameters,only:stdout + implicit none + character(len=*),intent(in) :: flag,desc + integer,intent(in) :: fw + integer :: fl,pad + fl = len_trim(flag) + pad = max(fw-fl,1) + write(stdout,'(a,a,a,a,a)') ' ',colorify(trim(flag),'green'), & + & repeat(' ',pad),' : ',trim(desc) +end subroutine help_opt + +!=========================================================================================! + subroutine confscript_help() - use crest_data + use iomod,only:colorify + use crest_parameters,only:stdout implicit none - write (*,'(80("-"))') - write (*,*) - write (*,'(1x, ''Usage :'')') - write (*,'(1x, '' crest [input] [options]'')') - write (*,*) - write (*,'(1x, ''The [input] argument CAN be a coordinate file in the'')') - write (*,'(1x, ''TM (coord, Bohr) or Xmol (*.xyz, Ang.) format.'')') - write (*,'(1x, ''If no such file is present as the first argument crest will'')') - write (*,'(1x, ''automatically search for a file called "coord" in the TM format.'')') - write (*,*) - write (*,'(1x, ''Versions >3.0 allow specifying detailed input instructions via'')') - write (*,'(1x, ''input files in the TOML format.'')') - write (*,'(1x, ''*.toml files can be [input] or specified via "--input "'')') - write (*,*) + write(stdout,'(/,1x,a)') colorify(repeat('─',76),'gold') + write(stdout,'(1x,a,a)') colorify('Usage:','yellow'),' crest [INPUT] [OPTIONS]' + write(stdout,'(1x,a)') colorify(repeat('─',76),'gold') + write(stdout,*) + write(stdout,'(1x,a)') 'The '//colorify('[INPUT]','blue')//' argument CAN be a coordinate file in the' + write(stdout,'(1x,a)') 'TM (coord, Bohr) or Xmol (*.xyz, Ang.) format.' + write(stdout,'(1x,a)') 'If no such file is present as the first argument, crest will' + write(stdout,'(1x,a)') 'automatically search for a file called "coord" in the TM format.' + write(stdout,*) + write(stdout,'(1x,a)') colorify('Versions >3.0 allow specifying detailed input instructions via','green') + write(stdout,'(1x,a)') colorify('input files in the TOML format.','green') + write(stdout,'(1x,a)') colorify('*.toml files can be ','green')//colorify(' [INPUT]','blue')// & + colorify(' or specified via "--input "','green') + write(stdout,*) call confscript_morehelp2() stop ' [-h] displayed. exit.' end subroutine confscript_help subroutine confscript_morehelp(flag) - use crest_data + use iomod,only:colorify + use crest_parameters,only:stdout implicit none character(len=*),intent(in) :: flag + integer :: fw - write (*,'(80("-"))') - write (*,*) + write(stdout,'(/,1x,a)') colorify(repeat('─',76),'gold') + write(stdout,*) select case (flag) - case default - write (*,'(/,1x,''General, technical, and calculation options:'')') - write (*,'(5x,''--input : Specify TOML file with detailed input instructions'')') - write (*,'(5x,''-T : Set total number of CPUs(threads)'')') - write (*,'(5x,'' to be used. Parallel settings are then'')') - write (*,'(5x,'' determined automatically for each step.'')') - write (*,'(5x,'' If not set by "-T", this number is read'')') - write (*,'(5x,'' from the OMP_NUM_THREADS global variable.'')') - write (*,'(5x,''-g : use GBSA implicit solvent'')') - write (*,'(5x,'' for solvent '')') - write (*,'(5x,''-alpb : use ALPB implicit solvent'')') - write (*,'(5x,'' for solvent '')') - write (*,'(5x,''-chrg : set the molecules´ charge'')') - write (*,'(5x,''-uhf : set =Nα-Nβ electrons'')') - write (*,'(5x,''-charges : copy a existing atomic charges file for'')') - write (*,'(5x,'' all optimizations (can be used by GFN-FF)'')') - write (*,'(5x,''-opt <"lev"> : set opt. level for ALL GFN-xTB'')') - write (*,'(5x,'' optimizations.'')') - write (*,'(5x,'' =vloose,loose,normal,tight,vtight'')') - write (*,'(5x,'' [default: vtight]'')') - write (*,'(5x,''-gfn1 : use GFN1-xTB'')') - write (*,'(5x,''-gfn2 : use GFN2-xTB [default]'')') - write (*,'(5x,''-gfn0 : use GFN0-xTB'')') - write (*,'(5x,''-gff, -gfnff : use GFN-FF (requires xtb 6.3 or newer)'')') - write (*,'(5x,'' (for GFN-FF searches bond constraints are applied automatically)'')') - write (*,'(5x,''-gfn2//gfnff : GFN2-xTB//GFN-FF composite mode)'')') - write (*,'(3x,''Adding additional constraints to the calculations:'')') - write (*,'(3x,''The user is able to include additional constraints to ALL'')') - write (*,'(3x,''xtb calculations that are conducted by CREST.'')') - write (*,'(5x,''-cinp : read in a file containing the constraints.'')') - write (*,'(5x,'' constraints have to be in the same format as in xtb.'')') - write (*,'(5x,'' (this was done previously via the ".constrains" file)'')') - write (*,'(5x,''-cbonds : define automatic bond constraints (set up from topology)'')') - write (*,'(5x,''-nocbonds : turn off -cbonds (for GFN-FF, mainly. see above)'')') - write (*,'(5x,''-fc : define force constant for defined constraints (-cbonds)'')') - write (*,'(5x,''-xnam <"bin"> : specify name of the xtb binary'')') - write (*,'(5x,'' that should be used.'')') - write (*,'(5x,''-niceprint : progress bar printout for optimizations'')') - write (*,'(5x,''-dry : perform a "dry run". Only prints the settings'')') - write (*,'(5x,'' that would be applied with the CMD input'')') - write (*,'(5x,'' and stops the run before any calculations'')') - write (*,*) + ! ── General / technical ────────────────────────────────────────────── + case default + fw = 16 + call help_section('Run modes:') + call help_opt('-sp',fw,'Single-point energy calculation') + call help_opt('-opt/-optimize',fw,'Geometry optimization') + call help_opt('-hess/-numhess',fw,'Numerical Hessian / vibrational frequencies') + call help_opt('-md/-dynamics',fw,'Molecular dynamics simulation') + call help_opt('-v3',fw,'iMTD-GC conformational search (see --help conf)') + call help_opt('-v4/-entropy',fw,'Entropy/free-energy sampling (see --help conf)') + call help_opt('-mdopt',fw,'Ensemble optimization (no sorting)') + call help_opt('-screen',fw,'Ensemble screening') + call help_opt('-protonate',fw,'Protonation site search') + call help_opt('-deprotonate',fw,'Deprotonation site search') + call help_opt('-tautomerize',fw,'Tautomer generation') + call help_opt('-qcg',fw,'Quantum Cluster Growth workflows (see --help qcg)') + call help_opt('-msreact',fw,'MS fragment generator (see --help msreact)') + call help_opt('-bh/-GMIN',fw,'Basin-hopping global optimization') + call help_opt('-sort',fw,'Ensemble sorting via CREGEN (see --help compare)') + write(stdout,*) + fw = 22 + call help_section('Method selection:') + call help_opt('-gfn2',fw,'Use GFN2-xTB [default]') + call help_opt('-gfn1',fw,'Use GFN1-xTB') + call help_opt('-gfn0',fw,'Use GFN0-xTB') + call help_opt('-gff/-gfnff',fw,'Use GFN-FF (bond constraints applied automatically)') + call help_opt('-gxtb',fw,'Use g-xTB (requires special build)') + call help_opt('-gfn2//gfnff',fw,'GFN-FF trajectories with GFN2-xTB energy reweighting') + call help_opt('-refine ',fw,'Post-process conformers at a higher level') + call help_opt('-optlev ',fw,'Optimization convergence level for ALL semiempirical calculations') + write(stdout,'(9x,a)') ' = crude, vloose, loose, normal, tight, vtight, extreme' + call help_opt('-dscal []',fw,'Scale dispersion energy in MD/MTD simulations') + write(stdout,*) + fw = 22 + call help_section('Molecular system:') + call help_opt('-T ',fw,'Number of CPU threads (or read from OMP_NUM_THREADS)') + call help_opt('-chrg ',fw,"Molecular charge") + call help_opt('-uhf ',fw,'Unpaired electrons (N_alpha - N_beta)') + call help_opt('-g/-gbsa ',fw,'GBSA implicit solvation') + call help_opt('-alpb ',fw,'ALPB implicit solvation') + call help_opt('-efield ',fw,'External electric field in V/Ang along x, y, z') + call help_opt('-charges []',fw,'Read atomic partial charges from file [default: "charges"]') + write(stdout,*) + fw = 22 + call help_section('Technical:') + call help_opt('--input ',fw,'Specify TOML input file with detailed settings') + call help_opt('-xnam ',fw,'Path to the xtb executable (when using xtb as backend)') + call help_opt('-noopt',fw,'Skip pre-optimization of the input structure') + call help_opt('-niceprint',fw,'Show progress bar during optimizations') + call help_opt('-dry',fw,'Parse args, print resolved settings, then exit') + call help_opt('-legacy',fw,'Force CREST < 3.0 behavior') + write(stdout,*) + fw = 22 + call help_section('Constraints (applied to ALL calculations):') + call help_opt('-cinp ',fw,'Read constraints file (xtb format; formerly ".constrains")') + call help_opt('-cbonds []',fw,'Constrain all bonds globally (set up from topology)') + call help_opt('-cbonds_md []',fw,'Constrain all bonds during MDs/MTDs only') + call help_opt('-nocbonds',fw,'Disable automatic bond constraints') + call help_opt('-fc ',fw,'Global force constant for bond constraints') + write(stdout,*) + + ! ── Ensemble comparison / CREGEN ───────────────────────────────────── case ('compare','cregen') - write (*,'(1x,''Options for ensemble comparisons:'')') - write (*,'(5x,''-cregen [file] : use ONLY the CREGEN subroutine'')') - write (*,'(5x,'' to sort a given ensemble file.'')') - write (*,'(5x,''-ewin : set energy window in kcal/mol,'')') - write (*,'(5x,'' [default: 6.0 kcal/mol]'')') - write (*,'(5x,''-rthr : set RMSD threshold in Ang,'')') - write (*,'(5x,'' [default: 0.125 Ang]'')') - write (*,'(5x,''-ethr : set E threshold in kcal/mol,'')') - write (*,'(5x,'' [default: 0.05 kcal/mol]'')') - write (*,'(5x,''-bthr : set Rot. const. threshold ,'')') - write (*,'(5x,'' [default: 0.01 (= 1%)]'')') - write (*,'(5x,''-pthr : Boltzmann population threshold'')') - write (*,'(5x,'' [default: 0.05 (= 5%)]'')') - write (*,'(5x,''-temp : set temperature in cregen, [default: 298.15 K]'')') - write (*,'(5x,''-prsc : create a scoord.* file for each conformer'')') - write (*,'(5x,''-nowr : don´t write new ensemble files'')') - write (*,'(5x,''-eqv,-nmr,-entropy : compare nuclear equivalences (requires rotamers)'')') - write (*,'(5x,''-cluster : PCA and k-Means clustering of sorted ensemble.'')') - write (*,'(5x,'' Works as extenstion to the CREGEN sorting.'')') - write (*,'(5x,'' is the number of clusters to be formed.'')') - write (*,'(5x,''-notopo : turn off any topology checks in CREGEN.'')') - write (*,*) - + fw = 20 + call help_section('Options for ensemble comparisons:') + call help_opt('-cregen [file]',fw,'Run CREGEN standalone to sort an ensemble file.') + write(stdout,*) + call help_section('Thresholds:') + call help_opt('-ewin ',fw,'Energy window in kcal/mol [default: 6.0]') + call help_opt('-rthr ',fw,'RMSD threshold in Ang [default: 0.125]') + call help_opt('-ethr ',fw,'Energy threshold in kcal/mol [default: 0.05]') + call help_opt('-bthr ',fw,'Rotational constant threshold [default: 0.01 = 1%]') + call help_opt('-pthr ',fw,'Boltzmann population threshold (0-1) [default: 0.05]') + call help_opt('-temp ',fw,'Boltzmann temperature in K [default: 298.15]') + write(stdout,*) + call help_section('Algorithm options:') + call help_opt('-topo/-notopo',fw,'Enable/disable topology change check') + call help_opt('-ezcheck',fw,'Enable E/Z double-bond isomer check') + call help_opt('-heavy',fw,'Use heavy-atom-only RMSD') + call help_opt('-allrot',fw,'Use all three rotational constants (A, B, C)') + call help_opt('-eqv/-nmr',fw,'NMR nuclear equivalence analysis (requires rotamers)') + call help_opt('-cluster ',fw,'PCA + k-Means clustering ( = number of clusters)') + write(stdout,*) + call help_section('Output:') + call help_opt('-prsc',fw,'Write scoord.* file for each conformer') + call help_opt('-nowr',fw,"Skip writing the sorted ensemble file") + call help_opt('-osdf',fw,'Also write output ensemble in SDF format') + write(stdout,*) + + ! ── Conformer search / sampling ────────────────────────────────────── case ('conf','sampling') - write (*,'(1x,''Options for sampling workflows:'')') - write (*,'(5x,''-v1 : use the MF-MD-GC workflow. (OUTDATED)'')') - write (*,'(5x,''-v2 : use the MTD-GC workflow. (OUTDATED)'')') - write (*,'(5x,''-v3 (or -v2i) : use the iMTD-GC workflow. [default]'')') - write (*,'(5x,''-v4 : use the iMTD-sMTD workflow.'')') - write (*,'(5x,''-entropy : the same workflow as with "-v4", specialized'')') - write (*,'(5x,'' for the calculation of conformational entropy.'')') - write (*,'(5x,''-nozs : do not perform z-mat sorting [default]'')') - write (*,'(5x,''-cross : do the GC part [default]'')') - write (*,'(5x,''-nocross : don´t do the GC part'')') - write (*,'(5x,''-shake : set SHAKE mode for MD'')') - write (*,'(5x,'' (0=off,1=H-only,2=all bonds) [default: 2]'')') - write (*,'(5x,''-tstep : set MD time step in fs'')') - write (*,'(5x,'' [default: 5 fs]'')') - write (*,'(5x,''-mdlen/-len : set MD length (all MTDs) in ps.'')') - write (*,'(5x,'' Also possible are multiplicative factors'')') - write (*,'(5x,'' for the default MD length with "x"'')') - write (*,'(5x,''-mddump : xyz dumpstep to Trajectory in fs'')') - write (*,'(5x,'' [default: 100 fs]'')') - write (*,'(5x,''-vbdump : set Vbias dump frequency in ps'')') - write (*,'(5x,'' [default: 1.0 ps]'')') - write (*,'(5x,''-tnmd : set temperature for additional normal MDs'')') - write (*,'(5x,'' [default: 400 K]'')') - write (*,'(5x,''-norotmd : don´t do the regular MDs after the '')') - write (*,'(5x,'' second multilevel optimization step'')') - write (*,'(5x,''-hflip/-noflip : turn on/off a small enhancement routine to'')') - write (*,'(5x,'' rotate OH groups after MTD. [default: OFF]'')') - write (*,'(5x,''-maxflip : max. number of new structures by the above'')') - write (*,'(5x,'' enhancement routine. [default: 1000]'')') - write (*,'(5x,''-quick : perform a search with reduced settings'')') - write (*,'(5x,'' for a crude ensemble.'')') - write (*,'(5x,''-squick : perform a even further reduced search'')') - write (*,'(5x,''-mquick : perform a search with maximum reduced settings'')') - write (*,'(5x,'' (do not reduce the settings more than that)'')') - write (*,'(5x,''-origin : track the step of generation for'')') - write (*,'(5x,'' each conformer/rotamer. [default]'')') - write (*,'(5x,''-keepdir : keep sub-directories of the conformer'')') - write (*,'(5x,'' generation step.'')') - write (*,'(5x,''-nci : generate an ellipsoide potential around the'')') - write (*,'(5x,'' input structure and add it to the MTD simulation.'')') - write (*,'(5x,'' This can be used to find aggregates of NCI complexes.'')') - write (*,'(5x,''-wscal : scale the ellipsoide potential axes by factor .'')') - write (*,*) - + fw = 20 + call help_section('Conformer search algorithms:') + call help_opt('-v3/-v2i',fw,'iMTD-GC (iterative MTD-GC) [default]') + call help_opt('-v4',fw,'iMTD-sMTD (entropy-focused search)') + call help_opt('-entropy',fw,'Same as -v4, specialized for conformational entropy') + + write(stdout,*) + call help_section('MD / MTD parameters:') + call help_opt('-len/-mdlen [x]',fw,'MD/MTD length in ps; append "x" for a scaling factor') + call help_opt('-tstep ',fw,'MD timestep in fs [default: 5 fs]') + call help_opt('-shake ',fw,'SHAKE mode: 0=off, 1=X-H only, 2=all bonds [default: 1]') + call help_opt('-mdtemp ',fw,'Temperature for MTD runs in K') + call help_opt('-tnmd ',fw,'Temperature for extra normal MDs in K') + call help_opt('-mddump ',fw,'Trajectory dump interval in fs [default: 100]') + call help_opt('-vbdump ',fw,'Vbias dump frequency in ps [default: 1.0]') + call help_opt('-nmtd ',fw,'Number of MTD simulations per cycle') + write(stdout,*) + call help_section('Search control:') + call help_opt('-cross/-nocross',fw,'Enable/disable genetic structure crossing [cross=default]') + call help_opt('-gcmax ',fw,'Max structures fed into genetic crossing') + call help_opt('-nozs',fw,'Disable z-matrix sorting') + call help_opt('-normmd [ []]',fw,'Run additional unbiased MDs on lowest conformers') + call help_opt('-quick/-squick/-mquick',fw,'Progressively reduced search settings') + call help_opt('-origin',fw,'Track conformer origin step [default]') + call help_opt('-keepdir',fw,'Keep temporary working directories') + call help_opt('-NCI',fw,'NCI cluster mode (flat-bottom wall + specialised MTD settings)') + call help_opt('-wscal ',fw,'Scale wall potential sphere radius') + call help_opt('-hflip/-noflip',fw,'OH proton flip after MTD [default: OFF]') + call help_opt('-maxflip ',fw,'Max OH flip attempts [default: 1000]') + write(stdout,*) + + ! ── Thermochemistry / entropy ───────────────────────────────────────── case ('thermo','entropy') - write (*,'(1x,''Thermostatistical options (used in entropy mode):'')') - write (*,'(5x,''-trange : entropies are calculated for different temperatures.'')') - write (*,'(5x,'' these are calculated in a temperature range from'')') - write (*,'(5x,'' to with in between.'')') - write (*,'(5x,'' [default: 280K-380K in 10K steps]'')') - write (*,'(5x,''-fscal : frequency scaling factor. [default: 1.0]'')') - write (*,'(5x,''-sthr : vibrational/rotational entropy interpolation threshold (τ)'')') - write (*,'(5x,'' [default: 25.0 cm^-1]'')') - write (*,'(5x,''-ithr : imaginary mode inversion cutoff [default: -50.0 cm^-1]'')') - write (*,'(5x,''-ptot : sum of population for structures considered in msRRHO average.'')') - write (*,'(5x,'' [default: 0.9 (=90%)]'')') - write (*,*) - + fw = 28 + call help_section('Thermostatistical options:') + call help_opt('-trange ',fw,'Temperature range in K for entropy output') + write(stdout,'(9x,a)') '[default: 280-380 K in 10 K steps]' + call help_opt('-tread ',fw,'Read temperatures (one per line) from file') + call help_opt('-fscal ',fw,'Frequency scaling factor [default: 1.0]') + call help_opt('-sthr/-rotorcut ',fw,'Rotor cutoff in cm^-1 (free-rotor interpolation) [default: 25.0]') + call help_opt('-ithr ',fw,'Imaginary mode inversion cutoff [default: -50.0 cm^-1]') + call help_opt('-ptot ',fw,'Cumulative population threshold for msRRHO [default: 0.9]') + call help_opt('-pcap ',fw,'Max structures used in property calculations') + call help_opt('-printpop',fw,'Print Boltzmann populations at every temperature') + call help_opt('-avbhess',fw,'Use Boltzmann-averaged Hessian in rrhoav') + write(stdout,*) + + ! ── QCG ────────────────────────────────────────────────────────────── case ('qcg') - write (*,'(1x,''Quantum Cluster Growth (QCG)'')') - write (*,'(1x,''General usage :'')') - write (*,'(5x,'' -qcg [options]'')') - write (*,'(1x,''options (additionally to the iMTD-GC options above):'')') - write (*,'(5x,''-keepdir : keep the tmp folder'')') - write (*,'(5x,''-nopreopt : do not perform preoptimization (only for qcg).'')') - write (*,'(5x,''-xtbiff : use the xTB-IFF standalone for docking of solvent'')') - write (*,'(5x,''-grow : cluster generation'')') - write (*,'(5x,''-fixsolute : fix the solute during the growth (recommended for rigid ones)'')') - write (*,'(5x,'' : done automatically for water'')') - write (*,'(5x,''-nofix : fix the solute not during the growth (needed only for water)'')') - write (*,'(5x,''-nsolv : number of solvent molecules to add'')') - write (*,'(5x,''-normdock : Perform a more extensive docking during grow'')') - write (*,'(5x,''-maxsolv : set limit of convergence, if no number of solutes was given. Default 150 '')') - write (*,'(5x,''-wscal : Scaling factor for outer wall potential'')') - write (*,'(5x,''-samerand : use same random number for every xtbiff run'')') - write (*,'(5x,''-fin_opt_gfn2 : perform GFN2-xTB optimizations for final grow and ensemble structures'')') - write (*,'(5x,''-directed : Perform directed solvation at positions defined in '')') - write (*,'(5x,''-ensemble : ensemble generation'')') - write (*,'(5x,''-qcgmtd : NCI-MTD CREST ensemble generation (Default)'')') - write (*,'(5x,''-ncimtd : NCI-MTD CREST ensemble generation'')') - write (*,'(5x,''-mtd : MTD for QCG ensemble generation'')') - write (*,'(5x,''-md : normal MD for QCG ensemble search'')') - write (*,'(5x,''-enslvl [method] : define a method for ensemble search. All gfn methods are supported'')') - write (*,'(5x,''-clustering : Turn on clustering for the ensemble search (only for qcgmtd and ncimtd'')') - write (*,'(5x,''-esolv : reference cluster generation and comp. of solvation energy'')') - write (*,'(5x,''-gsolv : reference cluster generation and comp. of solvation free energy'')') - write (*,'(5x,''-nclus : defines how many clusters are taken for reference cluster generation'')') - write (*,'(5x,'' : default 4'')') - write (*,'(5x,''-nocff : switches off the CFF algorithm'')') - write (*,'(5x,''-freqscal : defines frequency scale factor. Only for outprint'')') - write (*,'(5x,''-freqlvl [method] : define a method for frequency computation. All gfn versions are supported'')') - write (*,*) - + fw = 20 + call help_section('Quantum Cluster Growth (QCG)') + write(stdout,'(1x,a)') 'General usage: crest -qcg [options]' + write(stdout,'(1x,a)') 'Options (in addition to general / iMTD-GC options):' + write(stdout,*) + call help_section('Cluster growth:') + call help_opt('-grow',fw,'Cluster generation run type') + call help_opt('-nsolv ',fw,'Number of solvent molecules to add') + call help_opt('-fixsolute',fw,'Fix the solute during growth (auto for water)') + call help_opt('-nofix',fw,'Do not fix the solute (override for water)') + call help_opt('-nopreopt',fw,'Skip pre-optimization') + call help_opt('-xtbiff',fw,'Use xTB-IFF standalone for solvent docking') + call help_opt('-normdock',fw,'More extensive docking during growth') + call help_opt('-maxsolv',fw,'Convergence limit if -nsolv not given [default: 150]') + call help_opt('-wscal ',fw,'Scaling factor for outer wall potential') + call help_opt('-samerand',fw,'Use same random seed for every xtbiff run') + call help_opt('-directed ',fw,'Directed solvation at positions in ') + call help_opt('-fin_opt_gfn2',fw,'Final GFN2-xTB optimization for grow and ensemble') + write(stdout,*) + call help_section('Ensemble generation:') + call help_opt('-ensemble',fw,'Ensemble generation run type') + call help_opt('-qcgmtd',fw,'NCI-MTD CREST ensemble generation [default]') + call help_opt('-ncimtd',fw,'NCI-MTD CREST ensemble generation (alias)') + call help_opt('-mtd',fw,'MTD for QCG ensemble generation') + call help_opt('-md',fw,'Normal MD for QCG ensemble search') + call help_opt('-enslvl [method]',fw,'Method for ensemble search (all GFN methods supported)') + call help_opt('-clustering',fw,'Clustering for ensemble search (qcgmtd/ncimtd only)') + write(stdout,*) + call help_section('Solvation free energy:') + call help_opt('-esolv',fw,'Solvation energy (reference cluster generation)') + call help_opt('-gsolv',fw,'Solvation free energy (reference cluster generation)') + call help_opt('-nclus',fw,'Clusters for reference generation [default: 4]') + call help_opt('-nocff',fw,'Switch off the CFF algorithm') + call help_opt('-freqscal',fw,'Frequency scale factor (output only)') + call help_opt('-freqlvl [method]',fw,'Method for frequency computation') + call help_opt('-keepdir',fw,'Keep temporary directories') + write(stdout,*) + + ! ── MSReact ────────────────────────────────────────────────────────── case ('msreact') - write (*,'(1x,'' mass spectral fragment generator (msreact)'')') - write (*,'(1x,''General usage :'')') - write (*,'(5x,'' -msreact [options]'')') - write (*,'(1x,''options:'')') - write (*,'(5x,''-msnoattrh : deactivate attractive potential between hydrogen and LMO centers)'')') - write (*,'(5x,''-msnshifts [int] : perform n optimizations with randomly shifted atom postions (default 0) '')') - write (*,'(5x,''-msnshifts2 [int] : perform n optimizations with randomly shifted atom postions and repulsive potential applied to bonds (default 0) '')') - write (*,'(5x ''-msnbonds [int] : maximum number of bonds between atoms pairs for applying repulsive potential (default 3)'')') - write (*,'(5x,''-msmolbar : sort out topological duplicates by molbar codes (requires sourced "molbar")'')') - write (*,'(5x,''-msinchi : sort out topological duplicates by inchi codes (requires sourced "obabel")'')') - write (*,'(5x ''-msnfrag [int] : number of fragments that are printed by msreact (random selection)'')') - write (*,'(5x,''-msiso : print only non-dissociated structures (isomers)'')') - write (*,'(5x,''-msnoiso : print only dissociated structures'')') - write (*,'(5x,''-mslargeprint : do not remove temporary files and MSDIR do not remove temporary files and MSDIR with constrained optimizations'')') - write (*,'(5x,''-chrg : set the molecules´ charge'')') - write (*,'(5x,''-ewin : set energy window in for sorting out fragments kcal/mol,'')') - write (*,'(5x,'' [default: 200.0 kcal/mol] '')') - write (*,'(5x,''-msinput : read in an input file with special settings for msreact'')') - write (*,'(5x,''keywords for inputfile:'')') - write (*,'(5x,'' fragdist : increase distance between fragments xyz structures (default 0 Angstrom) '')') - write (*,'(5x,'' atomshift : shift of atoms in random atom displacement (default 0.75 Angstrom)'')') - write (*,'(5x,'' distthr_attr : distance threshold in Angstrom for H-LMO attraction (default 4.0 Angstrom) '')') - write (*,'(5x,'' fc_rep : force constant for repulsive potential between atom pairs (default 0.5) '')') - write (*,'(5x,'' fc_attr : force constant for attractive potential between hydrogen and LMO centers (default -0.5) '')') - write (*,'(5x,'' etemp : electronic temperature in xTB optimizations'')') - + fw = 22 + call help_section('Mass spectral fragment generator (msreact)') + write(stdout,'(1x,a)') 'General usage: crest -msreact [options]' + write(stdout,*) + call help_opt('-msnoattrh',fw,'Deactivate H–LMO attractive potential') + call help_opt('-msnshifts ',fw,'n optimizations with randomly shifted atoms [default: 0]') + call help_opt('-msnshifts2 ',fw,'Same but with bond-repulsive potential [default: 0]') + call help_opt('-msnbonds ',fw,'Max bond distance for repulsive potential [default: 3]') + call help_opt('-msmolbar',fw,'Deduplicate by molbar codes (requires "molbar")') + call help_opt('-msinchi',fw,'Deduplicate by InChI codes (requires "obabel")') + call help_opt('-msnfrag ',fw,'Number of fragments to print (random selection)') + call help_opt('-msiso',fw,'Print only non-dissociated structures (isomers)') + call help_opt('-msnoiso',fw,'Print only dissociated structures') + call help_opt('-mslargeprint',fw,'Keep all temporary files and MSDIR') + call help_opt('-chrg ',fw,"Molecular charge") + call help_opt('-ewin ',fw,'Energy window for fragment sorting in kcal/mol [default: 200.0]') + call help_opt('-msinput ',fw,'Read special settings from input file') + write(stdout,*) + fw = 22 + call help_section('msreact input file keywords:') + call help_opt('fragdist ',fw,'Inter-fragment distance increase [default: 0.0 Ang]') + call help_opt('atomshift ',fw,'Random atom displacement [default: 0.75 Ang]') + call help_opt('distthr_attr ',fw,'H–LMO attraction distance cutoff [default: 4.0 Ang]') + call help_opt('fc_rep ',fw,'Repulsive potential force constant [default: 0.5]') + call help_opt('fc_attr ',fw,'H–LMO attractive force constant [default: -0.5]') + call help_opt('etemp ',fw,'Electronic temperature in xTB optimizations') + write(stdout,*) + + ! ── Standalone tools ───────────────────────────────────────────────── case ('other') - write (*,'(1x,''Other tools for standalone use:'')') - write (*,'(5x,''-zsort : use only the zsort subroutine'')') - write (*,'(5x,'' to sort the z-matrix of the input'')') - write (*,'(5x,'' coord file.'')') - write (*,'(5x,''-mdopt : optimize along trajectory or'')') - write (*,'(5x,'' ensemble file in the XYZ format.'')') - write (*,'(5x,'' Each point on the file is optimized.'')') - write (*,'(5x,''-screen : optimize along ensemble file'')') - write (*,'(5x,'' in the XYZ format. A multilevel'')') - write (*,'(5x,'' optimization is performed with continiously'')') - write (*,'(5x,'' increasing thresholds. After each step'')') - write (*,'(5x,'' the ensemble file is sorted.'')') - write (*,'(5x,''-protonate : find a molecules protomes by using a'')') - write (*,'(5x,'' LMO π- or LP-center approach.'')') - write (*,'(5x,''-deprotonate : find a molecules deprotomers.'')') - write (*,'(5x,''-tautomerize : combine the protonation and deprotonation'')') - write (*,'(5x,'' to find prototropic tautomers.'')') - write (*,'(6x,''↳ -trev : do first the deprotonation and then the'')') - write (*,'(8x,'' protonation in the -tautomerize mode, i.e.,'')') - write (*,'(8x,'' reverse of the default procedure.'')') - write (*,'(6x,''↳ -iter : set number of protonation/deprotonation cycles'')') - write (*,'(8x,'' in the tautomerization script. [default: 2]'')') - write (*,'(5x,''-compare : compare two ensembles and .'')') - write (*,'(5x,'' Both ensembles must have the same'')') - write (*,'(5x,'' order of atoms of the molecule and'')') - write (*,'(5x,'' should contain rotamers.'')') - write (*,'(6x,''↳ -maxcomp : Selcect the lowest conformers'')') - write (*,'(8x,'' out of each ensemble to be compared'')') - write (*,'(8x,'' with "-compare". [default: 10]'')') - write (*,'(5x,''-testtopo : Analyze some stuctural info (topology) for a given file.'')') - write (*,'(5x,''-constrain : write example file ".xcontrol.sample" for constraints'')') - write (*,'(5x,'' in crest. (see -cinp option above)'')') - write (*,'(5x,''-thermo : Calculate thermo data for given structure. Also requires vibrational'')') - write (*,'(5x,'' frequencies in the TM format, saved as file called "vibspectrum"'')') - write (*,'(5x,''-rmsd,-rmsdheavy : Calculate RMSD or heavy atom RMSD between two structures.'')') - write (*,'(5x,'' Input coords are automatically transformed to Angstroem.'')') - write (*,'(5x,''-splitfile [from] [to] : Split an ensemble from into seperate directories'')') - write (*,'(5x,'' for each structure. [from] and [to] can be used to select'')') - write (*,'(5x,'' specific structures from the file.'')') - write (*,'(5x,'' The new directories are collected in the SPLIT directory.'')') - write (*,*) + fw = 26 + call help_section('Single-structure calculations:') + call help_opt('-sp',fw,'Single-point energy') + call help_opt('-opt/-optimize',fw,'Geometry optimization') + call help_opt('-hess/-numhess',fw,'Numerical Hessian / vibrational frequencies') + call help_opt('-dynamics/-dyn',fw,'Stand-alone MD run') + call help_opt('-thermo ',fw,'Thermochemistry from existing Hessian data') + write(stdout,'(9x,a)') '(also requires "vibspectrum" in TM format)' + write(stdout,*) + call help_section('Ensemble tools:') + call help_opt('-mdopt ',fw,'Optimize every structure in an ensemble (XYZ)') + call help_opt('-screen ',fw,'Multi-level energy screening of an ensemble') + call help_opt('-entropy []',fw,'Conformational entropy from ensemble') + call help_opt('-sort',fw,'Sort ensemble structures by energy') + call help_opt('-symmetries',fw,'Symmetry analysis of all structures in an ensemble') + call help_opt('-printboltz',fw,'Print Boltzmann population weights') + call help_opt('-compare ',fw,'Compare two ensembles for structural overlap') + write(stdout,'(9x,a)') colorify('-maxcomp ','green')//' : max conformers per ensemble [default: 10]' + call help_opt('-splitfile [i] [j]',fw,'Split ensemble into per-structure directories (SPLIT/)') + call help_opt('-rmsd ',fw,'RMSD between two structures (auto-converted to Ang)') + call help_opt('-rmsdheavy ',fw,'Heavy-atom RMSD between two structures') + write(stdout,*) + call help_section('Protonation / tautomerization:') + call help_opt('-protonate',fw,"Find a molecule's protomers (LMO π/LP-center approach)") + call help_opt('-deprotonate',fw,"Find a molecule's deprotomers") + call help_opt('-tautomerize',fw,'Find prototropic tautomers (protonation + deprotonation)') + write(stdout,'(9x,a)') colorify('-trev','green')//' : deprotonate first, then protonate (reverse order)' + write(stdout,'(9x,a)') colorify('-iter ','green')//' : number of prot/deprot cycles [default: 2]' + write(stdout,*) + call help_section('Miscellaneous:') + call help_opt('-cregen [file]',fw,'CREGEN ensemble sorting (see also --help compare)') + call help_opt('-zsort',fw,'Z-matrix sorting of the input coord file') + call help_opt('-testtopo ',fw,'Topology / bond connectivity analysis') + call help_opt('-constrain ',fw,'Write example constraint file ".xcontrol.sample"') + write(stdout,*) + + ! ── TOML input files ───────────────────────────────────────────────── + case ('toml') + call help_section('TOML input files') + write(stdout,'(1x,a)') 'CREST (v3+) accepts a TOML file as a flexible alternative to CLI flags.' + write(stdout,'(1x,a)') 'Pass it as the first argument or explicitly with --input:' + write(stdout,*) + write(stdout,'(3x,a)') colorify('crest structure.xyz --input settings.toml','green') + write(stdout,'(3x,a)') colorify('crest settings.toml','green')//' (structure path given inside the file)' + write(stdout,*) + call help_section('Minimal example:') + write(stdout,'(3x,a)') colorify('input','yellow')//' = "struc.xyz"' + write(stdout,'(3x,a)') colorify('runtype','yellow')//' = "iMTD-GC"' + write(stdout,'(3x,a)') colorify('threads','yellow')//' = 4' + write(stdout,*) + write(stdout,'(3x,a)') colorify('[calculation]','yellow') + write(stdout,'(5x,a)') colorify('[[calculation.level]]','yellow') + write(stdout,'(7x,a)') 'method = "gfn2"' + write(stdout,'(7x,a)') 'chrg = 0' + write(stdout,'(7x,a)') 'gbsa = "h2o"' + write(stdout,*) + call help_section('Key root-level settings:') + fw = 20 + call help_opt('input / structure',fw,'Input coordinate file') + call help_opt('runtype',fw,'Workflow to run (e.g. "iMTD-GC", "optimize", "md", "singlepoint")') + call help_opt('threads',fw,'Number of CPU threads') + call help_opt('preopt',fw,'Pre-optimize input structure (true/false)') + call help_opt('constraints',fw,'Path to an xtb-format constraint file') + write(stdout,*) + call help_section('Main blocks:') + ! ── padding = 30 - visible_len, so ' — ' aligns at column 30 ── + write(stdout,'(3x,a,a)') colorify('[calculation]','yellow'), & + & repeat(' ',17)//' — method, charge, solvent, …' + write(stdout,'(3x,a,a)') colorify(' [[calculation.level]]','yellow'), & + & repeat(' ',7)//' — one or more calculation levels' + write(stdout,'(3x,a,a)') colorify(' [[calculation.constraint]]','yellow'), & + & repeat(' ',2)//' — geometric constraints' + write(stdout,'(3x,a,a)') colorify('[dynamics]','yellow'), & + & repeat(' ',20)//' — MD length, timestep, temperature, …' + write(stdout,'(3x,a,a)') colorify(' [[dynamics.meta]]','yellow'), & + & repeat(' ',11)//' — metadynamics bias settings' + write(stdout,'(3x,a,a)') colorify('[cregen]','yellow'), & + & repeat(' ',22)//' — ensemble sorting thresholds' + write(stdout,'(3x,a,a)') colorify('[thermo]','yellow'), & + & repeat(' ',22)//' — thermochemistry settings' + write(stdout,*) + write(stdout,'(1x,a)') 'Full TOML keyword reference:' + write(stdout,'(3x,a)') colorify('https://crest-lab.github.io/crest-docs/','blue') + write(stdout,*) end select call confscript_morehelp2() @@ -399,13 +501,21 @@ subroutine confscript_morehelp(flag) end subroutine confscript_morehelp subroutine confscript_morehelp2 - write (*,'(1x, ''Some [options] command line flags can be shown with this help menu via:'')') - write (*,'(1x, '' --help [general/compare/conf/thermo/qcg/other]'')') - write (*,*) - write (*,*) 'View literature references with [--cite]' - write (*,*) 'For detailed documentation refer to:' - write (*,*) ' https://crest-lab.github.io/crest-docs/' - write (*,*) + use iomod,only:colorify + use crest_parameters,only:stdout + implicit none + write(stdout,'(/,1x,a)') 'For detailed help on option groups, use:' + write(stdout,'(3x,a)') colorify('--help general','gold')//' '// & + & colorify('--help compare','gold')//' '//colorify('--help conf','gold') + write(stdout,'(3x,a)') colorify('--help thermo','gold')//' '// & + & colorify('--help qcg','gold')//' '//colorify('--help msreact','gold') + write(stdout,'(3x,a)') colorify('--help other','gold')//' '// & + & colorify('--help toml','gold') + write(stdout,*) + write(stdout,'(1x,a,a)') 'View literature references with ',colorify('--cite','green') + write(stdout,'(1x,a)') 'For detailed documentation refer to:' + write(stdout,'(3x,a)') colorify('https://crest-lab.github.io/crest-docs/','blue') + write(stdout,*) end subroutine confscript_morehelp2 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC From 526cad7e715bb967d3e54e3ce37437c0b7d7a935 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 25 Apr 2026 00:14:12 +0200 Subject: [PATCH 295/374] irmsd test --- test/CMakeLists.txt | 1 + test/main.f90 | 4 +- test/meson.build | 1 + test/test_irmsd.F90 | 258 ++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 263 insertions(+), 1 deletion(-) create mode 100644 test/test_irmsd.F90 diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 1a334154..45f3e669 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -9,6 +9,7 @@ set( "optimization" "molecular_dynamics" "getsym" + "irmsd" ) set( test-srcs diff --git a/test/main.f90 b/test/main.f90 index ac53955e..65cbe41f 100644 --- a/test/main.f90 +++ b/test/main.f90 @@ -11,6 +11,7 @@ program tester use test_optimization, only: collect_optimization use test_molecular_dynamics, only: collect_mol_dynamics use test_getsym, only: collect_getsym + use test_irmsd, only: collect_irmsd implicit none integer :: stat, is character(len=:), allocatable :: suite_name, test_name @@ -34,7 +35,8 @@ program tester new_testsuite("CN",collect_CN), & new_testsuite("getsym", collect_getsym), & new_testsuite("optimization", collect_optimization), & - new_testsuite("molecular_dynamics", collect_mol_dynamics) & + new_testsuite("molecular_dynamics", collect_mol_dynamics), & + new_testsuite("irmsd", collect_irmsd) & ] !&> diff --git a/test/meson.build b/test/meson.build index 012f05da..d31dee47 100644 --- a/test/meson.build +++ b/test/meson.build @@ -10,6 +10,7 @@ tests = [ 'optimization', 'molecular_dynamics', 'getsym', + 'irmsd', ] test_srcs = files( diff --git a/test/test_irmsd.F90 b/test/test_irmsd.F90 new file mode 100644 index 00000000..7964ad4a --- /dev/null +++ b/test/test_irmsd.F90 @@ -0,0 +1,258 @@ +module test_irmsd + use testdrive,only:new_unittest,unittest_type,error_type,test_failed + use crest_parameters,only:wp,aatoau + use crest_testmol,only:get_testmol + use strucrd,only:coord + use irmsd_module,only:rmsd,irmsd + implicit none + private + + public :: collect_irmsd + + real(wp),parameter :: thr = 1.0e-10_wp + real(wp),parameter :: thr_loose = 1.0e-3_wp + +!========================================================================================! +!> H2 diatomic geometries in Bohr (centered at origin) +!========================================================================================! + + integer,parameter :: nat_h2 = 2 + integer,parameter :: at_h2(nat_h2) = [1,1] + !> bond = 1.0 Bohr + real(wp),parameter :: xyz_h2_ref(3,nat_h2) = reshape([ & + & 0.5_wp, 0.0_wp, 0.0_wp, & + &-0.5_wp, 0.0_wp, 0.0_wp], & + & [3,nat_h2]) + !> bond = 2.0 Bohr → analytical RMSD vs ref = 0.5 Bohr + real(wp),parameter :: xyz_h2_mol(3,nat_h2) = reshape([ & + & 1.0_wp, 0.0_wp, 0.0_wp, & + &-1.0_wp, 0.0_wp, 0.0_wp], & + & [3,nat_h2]) + +!========================================================================================! +!> Fluoxetine (40 atoms, Angstrom) — struc1 and struc2 from the iRMSD paper example. +!> Both represent the same conformer; struc2 has completely scrambled atom order +!> and a random rotation applied. iRMSD must return ≈ 0. +!========================================================================================! + + integer,parameter :: nat_fluo = 40 + + !> struc1 atom types (Z) + integer,parameter :: at_fluo1(nat_fluo) = [ & + & 6,9,1,1,6,1,6,9,9,7, & + & 6,1,8,6,6,6,6,6,1,6, & + & 1,6,1,1,1,1,1,1,1,6, & + & 1,1,1,1,6,6,1,6,6,6] + + !> struc1 coordinates, Angstrom + real(wp),parameter :: xyz_fluo1_ang(3,nat_fluo) = reshape([ & + &-0.0198_wp, 0.2158_wp, 0.5308_wp, & + &-5.0246_wp,-0.2464_wp, 0.5593_wp, & + &-2.0207_wp, 0.0761_wp, 3.2888_wp, & + & 2.0221_wp, 5.0303_wp, 0.4892_wp, & + &-0.4032_wp, 0.2003_wp, 1.8748_wp, & + & 1.4542_wp, 5.1890_wp,-1.1937_wp, & + & 2.1773_wp, 2.6686_wp,-0.7626_wp, & + &-4.6775_wp, 0.8294_wp, 2.4172_wp, & + &-4.3667_wp,-1.3218_wp, 2.3289_wp, & + & 3.0555_wp, 3.8290_wp,-0.9233_wp, & + & 2.3371_wp, 5.0467_wp,-0.5601_wp, & + & 3.7051_wp, 1.1947_wp,-0.3434_wp, & + & 1.3305_wp, 0.2076_wp, 0.3364_wp, & + &-2.3576_wp, 0.1386_wp,-0.0950_wp, & + & 3.3367_wp,-3.7475_wp,-2.0944_wp, & + &-2.7426_wp, 0.0481_wp, 1.2484_wp, & + &-4.1855_wp,-0.1659_wp, 1.6292_wp, & + & 2.4651_wp,-1.1750_wp,-1.3319_wp, & + & 1.7906_wp, 2.6512_wp, 0.2660_wp, & + & 2.8963_wp, 1.3473_wp,-1.0679_wp, & + & 1.3203_wp, 2.7752_wp,-1.4405_wp, & + & 1.8806_wp, 0.1908_wp,-0.9905_wp, & + &-0.7865_wp, 0.2662_wp,-1.5101_wp, & + & 3.3527_wp, 1.3925_wp,-2.0651_wp, & + & 1.1282_wp, 0.3962_wp,-1.7541_wp, & + & 2.8529_wp,-0.6554_wp,-3.3999_wp, & + & 2.9547_wp,-4.3108_wp,-0.0530_wp, & + & 3.8626_wp, 3.7250_wp,-0.3037_wp, & + & 0.3581_wp, 0.2294_wp, 2.6522_wp, & + &-1.7511_wp, 0.1165_wp, 2.2345_wp, & + & 2.9886_wp, 5.9146_wp,-0.7002_wp, & + & 2.1980_wp,-2.0723_wp, 0.6278_wp, & + & 3.6193_wp,-2.9009_wp,-4.0530_wp, & + &-3.1084_wp, 0.1174_wp,-0.8845_wp, & + & 2.5162_wp,-2.2260_wp,-0.4015_wp, & + &-1.0075_wp, 0.2216_wp,-0.4508_wp, & + & 3.6502_wp,-4.7430_wp,-2.3936_wp, & + & 2.9433_wp,-3.5025_wp,-0.7811_wp, & + & 2.8862_wp,-1.4373_wp,-2.6475_wp, & + & 3.3158_wp,-2.7117_wp,-3.0256_wp], & + & [3,nat_fluo]) + + !> struc2 atom types (Z) — scrambled order + integer,parameter :: at_fluo2(nat_fluo) = [ & + & 6,1,6,6,6,6,1,1,1,1, & + & 1,1,6,1,6,6,6,1,9,6, & + & 1,6,6,9,1,1,1,1,1,1, & + & 6,9,1,1,6,6,7,8,6,6] + + !> struc2 coordinates, Angstrom — scrambled + rotated + real(wp),parameter :: xyz_fluo2_ang(3,nat_fluo) = reshape([ & + &-0.2470_wp,-1.0143_wp,-0.4213_wp, & + & 0.0828_wp, 4.2564_wp,-4.4517_wp, & + &-2.1193_wp, 2.6178_wp, 0.0144_wp, & + & 1.2089_wp,-1.8204_wp, 1.8160_wp, & + & 0.0619_wp,-0.0804_wp, 0.5643_wp, & + & 0.9632_wp,-2.7436_wp, 0.7925_wp, & + &-5.9431_wp, 1.8117_wp, 2.4085_wp, & + &-3.2933_wp, 0.8099_wp, 0.1366_wp, & + & 2.4555_wp, 4.5828_wp,-3.8102_wp, & + &-0.0328_wp,-3.0384_wp,-1.1072_wp, & + &-3.9856_wp, 3.0777_wp, 1.8789_wp, & + &-2.4640_wp, 1.2332_wp, 1.6473_wp, & + &-0.4255_wp, 3.2037_wp,-2.6383_wp, & + & 1.7581_wp, 2.5331_wp,-0.1112_wp, & + & 1.3640_wp, 2.9121_wp,-1.0521_wp, & + & 1.5502_wp,-4.1306_wp, 0.8575_wp, & + &-5.0208_wp, 1.3357_wp, 2.0622_wp, & + &-4.4695_wp, 0.9920_wp, 2.9447_wp, & + & 1.1253_wp,-4.8340_wp, 1.9430_wp, & + & 2.2338_wp, 3.5914_wp,-1.9111_wp, & + &-1.7744_wp, 3.4140_wp, 0.6847_wp, & + & 0.4427_wp, 3.8850_wp,-3.4947_wp, & + & 0.7599_wp,-0.5019_wp, 1.6995_wp, & + & 1.2525_wp,-4.8990_wp,-0.2270_wp, & + &-1.3360_wp, 1.0931_wp,-1.2358_wp, & + & 1.7763_wp,-2.1151_wp, 2.6974_wp, & + & 0.9785_wp, 0.2106_wp, 2.4926_wp, & + &-5.3029_wp, 0.4654_wp, 1.4587_wp, & + &-0.8129_wp,-0.7679_wp,-1.3112_wp, & + &-2.6932_wp, 3.0927_wp,-0.7916_wp, & + &-0.9181_wp, 1.8428_wp,-0.5615_wp, & + & 2.9112_wp,-4.1100_wp, 0.9336_wp, & + &-1.4519_wp, 3.0470_wp,-2.9556_wp, & + & 3.2752_wp, 3.7325_wp,-1.6299_wp, & + & 1.7755_wp, 4.0721_wp,-3.1352_wp, & + & 0.0230_wp, 2.6924_wp,-1.4078_wp, & + &-4.2396_wp, 2.2887_wp, 1.2797_wp, & + &-0.2303_wp, 1.2522_wp, 0.5528_wp, & + &-3.0176_wp, 1.6462_wp, 0.7923_wp, & + & 0.1996_wp,-2.3349_wp,-0.3081_wp], & + & [3,nat_fluo]) + +!========================================================================================! +!========================================================================================! +contains !> Unit tests for rmsd and irmsd +!========================================================================================! +!========================================================================================! + + subroutine collect_irmsd(testsuite) + !*********************************** + !* Register all irmsd test cases. * + !*********************************** + type(unittest_type),allocatable,intent(out) :: testsuite(:) +!&< + testsuite = [ & + new_unittest("RMSD self comparison ",test_rmsd_self), & + new_unittest("RMSD H2 bond-stretch (known val)",test_rmsd_h2_bondstretch), & + new_unittest("iRMSD self comparison ",test_irmsd_self), & + new_unittest("iRMSD scrambled atom order ",test_irmsd_scrambled) & + ] +!&> + end subroutine collect_irmsd + +!========================================================================================! + + subroutine test_rmsd_self(error) + !***************************************************** + !* RMSD of a structure compared to itself must be 0. * + !***************************************************** + type(error_type),allocatable,intent(out) :: error + type(coord) :: mol + real(wp) :: rmsdval + call get_testmol('caffeine',mol) + rmsdval = rmsd(mol,mol) + if (abs(rmsdval) > thr) & + call test_failed(error,'RMSD(mol,mol) should be 0, got: '//to_str(rmsdval)) + end subroutine test_rmsd_self + +!========================================================================================! + + subroutine test_rmsd_h2_bondstretch(error) + !************************************************************* + !* Two H2 molecules with different bond lengths (1 and 2 Bohr). + !* Both centered at origin; no rotation needed for alignment. + !* Analytical RMSD = sqrt((0.5^2 + 0.5^2)/2) = 0.5 Bohr. + !************************************************************* + type(error_type),allocatable,intent(out) :: error + type(coord) :: ref,mol + real(wp) :: rmsdval + real(wp),parameter :: expected = 0.5_wp + + ref%nat = nat_h2 + allocate(ref%at(nat_h2),ref%xyz(3,nat_h2)) + ref%at = at_h2 + ref%xyz = xyz_h2_ref + + mol%nat = nat_h2 + allocate(mol%at(nat_h2),mol%xyz(3,nat_h2)) + mol%at = at_h2 + mol%xyz = xyz_h2_mol + + rmsdval = rmsd(ref,mol) + if (abs(rmsdval - expected) > thr) & + call test_failed(error,'Expected RMSD = 0.5 Bohr, got: '//to_str(rmsdval)) + end subroutine test_rmsd_h2_bondstretch + +!========================================================================================! + + subroutine test_irmsd_self(error) + !******************************************************* + !* iRMSD of a structure compared to itself must be 0. * + !******************************************************* + type(error_type),allocatable,intent(out) :: error + type(coord) :: mol + real(wp) :: rmsdval + call get_testmol('caffeine',mol) + rmsdval = irmsd(mol,mol,topocheck=.false.) + if (rmsdval > thr_loose) & + call test_failed(error,'iRMSD(mol,mol) should be ~0, got: '//to_str(rmsdval)) + end subroutine test_irmsd_self + +!========================================================================================! + + subroutine test_irmsd_scrambled(error) + !*********************************************************************** + !* Two copies of the same fluoxetine conformer (40 atoms). * + !* struc2 has fully randomised atom order and a random rotation. * + !* iRMSD must find the correct permutation and return ≈ 0 Å. * + !*********************************************************************** + type(error_type),allocatable,intent(out) :: error + type(coord) :: mol1,mol2 + real(wp) :: rmsdval + + mol1%nat = nat_fluo + allocate(mol1%at(nat_fluo),mol1%xyz(3,nat_fluo)) + mol1%at = at_fluo1 + mol1%xyz = xyz_fluo1_ang * aatoau + + mol2%nat = nat_fluo + allocate(mol2%at(nat_fluo),mol2%xyz(3,nat_fluo)) + mol2%at = at_fluo2 + mol2%xyz = xyz_fluo2_ang * aatoau + + rmsdval = irmsd(mol1,mol2,topocheck=.false.) + if (rmsdval > thr_loose) & + call test_failed(error,'iRMSD of identical fluoxetine (scrambled) should be ~0, got: '//to_str(rmsdval)) + end subroutine test_irmsd_scrambled + +!========================================================================================! + + pure function to_str(x) result(s) + !> Minimal real→string helper for error messages. + real(wp),intent(in) :: x + character(len=32) :: s + write(s,'(es16.8)') x + s = adjustl(s) + end function to_str + +end module test_irmsd From 453a85598ecda9e2a3f5eb525a3b8395b80214ad Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 25 Apr 2026 19:53:14 +0200 Subject: [PATCH 296/374] Build updates and tested static builds --- CMakeLists.txt | 9 +++++--- README.md | 48 ++++++++++++++++++++++++----------------- config/meson.build | 22 +++++++++++++------ meson.build | 48 +++++++++++++++++++++++++++++++++++++++-- subprojects/fmlip_relay | 2 +- subprojects/gfn0 | 2 +- subprojects/gfnff | 2 +- subprojects/pvol | 2 +- 8 files changed, 99 insertions(+), 36 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 6482ed80..5579ca3e 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -69,11 +69,14 @@ if(NOT TARGET "OpenMP::OpenMP_Fortran" AND WITH_OpenMP) endif() # Check if we are using OpenBLAS (need a precompiler definition if yes) -if(LAPACK_LIBRARIES) - string(FIND "${LAPACK_LIBRARIES}" "openblas" _openblas_in_lapack) +# Match "libopenblas" specifically to avoid false positives from conda env +# path names that contain "openblas" (e.g. crest-gnu-openblas/lib/libgomp.so). +if(LAPACK_LIBRARIES OR BLAS_LIBRARIES) + set(_all_blas_libs "${LAPACK_LIBRARIES};${BLAS_LIBRARIES}") + string(FIND "${_all_blas_libs}" "libopenblas" _openblas_in_lapack) if(NOT _openblas_in_lapack EQUAL -1) - message(STATUS "libopenblas was found as part of LAPACK") + message(STATUS "libopenblas was found as part of LAPACK/BLAS") add_compile_definitions(WITH_OPENBLAS) endif() endif() diff --git a/README.md b/README.md index 86b2065c..a42484e5 100644 --- a/README.md +++ b/README.md @@ -88,14 +88,17 @@ The conda-forge distribution is based on a *dynamically linked* CMake/GNU build. ![CI workflow](https://github.com/crest-lab/crest/actions/workflows/build.yml/badge.svg) -Working and tested builds of CREST (mostly on Ubuntu 20.04 LTS): +Working and tested builds of CREST: -| Build System | Compiler | Linear Algebra Backend | Build type | Status | Note | -|--------------|----------|------------------------|:--------------:|:----------:|:----:| -| CMake 3.30.2 | GNU (gcc 14.1.0) | [libopenblas 0.3.27](https://anaconda.org/conda-forge/libopenblas) | dynamic | ✅ || -| CMake 3.30.2 | GNU (gcc 12.3.0) | [libopenblas-dev](https://packages.debian.org/stable/libdevel/libopenblas-dev) | static | ✅ | [![Download (GNU)](https://img.shields.io/badge/download-GNU_build_binary-green)](https://github.com/crest-lab/crest/releases/download/latest/crest-gnu-12-ubuntu-latest.tar.xz)| -| CMake 3.28.3 | [Intel (`ifort`/`icc` 2021.9.0)](https://www.intel.com/content/www/us/en/developer/tools/oneapi/toolkits.html) | [MKL static (oneAPI 2023.1)](https://www.intel.com/content/www/us/en/developer/tools/oneapi/onemkl.html) | dynamic | ⚠️ | OpenMP/MKL problem ([#285](https://github.com/crest-lab/crest/issues/285)) | -| Meson 1.2.0 | [Intel (`ifort`/`icx` 2023.1.0)](https://www.intel.com/content/www/us/en/developer/tools/oneapi/toolkits.html) | [MKL static (oneAPI 2023.1)](https://www.intel.com/content/www/us/en/developer/tools/oneapi/onemkl.html) | static | ✅ | [![Download (ifort)](https://img.shields.io/badge/download-ifort_build_binary-blue.svg)](https://github.com/crest-lab/crest/releases/download/latest/crest-intel-2023.1.0-ubuntu-latest.tar.xz) | +| Build System | Compiler | Linear Algebra Backend | Build type | Note | +|--------------|----------|------------------------|:----------:|:----:| +| CMake 3.31.6 | GNU (gcc 14.3.0, conda-forge) | [libopenblas 0.3.31](https://anaconda.org/conda-forge/libopenblas) (conda-forge) | dynamic | [![Download (GNU)](https://img.shields.io/badge/download-GNU_build_binary-green)](https://github.com/crest-lab/crest/releases/download/latest/crest-gnu-12-ubuntu-latest.tar.xz) | +| CMake 3.31.6 | GNU (gcc 14.3.0, conda-forge) | [libopenblas 0.3.31](https://anaconda.org/conda-forge/libopenblas) (conda-forge) | static | | +| CMake 3.31.6 | [Intel (`ifx`/`icx` 2025.3)](https://www.intel.com/content/www/us/en/developer/tools/oneapi/toolkits.html) | [MKL (oneAPI 2025.3)](https://www.intel.com/content/www/us/en/developer/tools/oneapi/onemkl.html) | static | | +| Meson 1.10.1 | GNU (gcc 14.3.0, conda-forge) | [libopenblas 0.3.31](https://anaconda.org/conda-forge/libopenblas) (conda-forge) | dynamic | | +| Meson 1.10.1 | GNU (gcc 14.3.0, conda-forge) | [libopenblas 0.3.31](https://anaconda.org/conda-forge/libopenblas) (conda-forge) | static | | +| Meson 1.10.1 | [Intel (`ifx`/`icx` 2025.3)](https://www.intel.com/content/www/us/en/developer/tools/oneapi/toolkits.html) | [MKL (oneAPI 2025.3)](https://www.intel.com/content/www/us/en/developer/tools/oneapi/onemkl.html) | dynamic | | +| Meson 1.10.1 | [Intel (`ifx`/`icx` 2025.3)](https://www.intel.com/content/www/us/en/developer/tools/oneapi/toolkits.html) | [MKL (oneAPI 2025.3)](https://www.intel.com/content/www/us/en/developer/tools/oneapi/onemkl.html) | static | [![Download (ifx)](https://img.shields.io/badge/download-ifort_build_binary-blue.svg)](https://github.com/crest-lab/crest/releases/download/latest/crest-intel-2023.1.0-ubuntu-latest.tar.xz) | Generally, subprojects should be initialized for the *default* build options, which can be done by @@ -107,8 +110,8 @@ For more information about builds including subprojects see [here](./subprojects Some basic build instructions can be found in the following dropdown tabs: - - + + + +

CMake build

 @@ -126,29 +129,34 @@ make -C _build ```bash make test -C _build ``` -The `CMake` build typically requires access to shared libraries of LAPACK and OpenMP. They must be present in the library paths at compile and runtime. -Alternatively, a static build can be selected by using `-DSTATICBUILD=true` in the CMake setup step. The current static build with GNU compilers is available from the [**continous release page**](https://github.com/crest-lab/crest/releases/tag/latest). +The `CMake` build requires shared libraries of LAPACK/BLAS (e.g. OpenBLAS) and OpenMP at compile and runtime. +Alternatively, a static build can be selected by using `-DSTATICBUILD=true` in the CMake setup step. The current static build with GNU compilers is available from the [**continous release page**](https://github.com/crest-lab/crest/releases/tag/latest).
- +

meson build

 -For the setup an configuration of meson see also the [meson setup](https://github.com/grimme-lab/xtb/blob/master/meson/README.adoc) page hosted at the `xtb` repository. -The chain of commands to build CREST with meson is: +For the setup and configuration of meson see also the [meson setup](https://github.com/grimme-lab/xtb/blob/master/meson/README.adoc) page hosted at the `xtb` repository. +**Intel (`ifx`/`icx`) + MKL** (recommended for static release binaries): ```bash -export FC=ifort CC=icc -meson setup _build --prefix=$PWD/_dist +source /opt/intel/oneapi/setvars.sh +meson setup _build -Dlapack=mkl --prefix=$PWD/_dist meson install -C _build ``` -The `meson` build of CREST is mainly focused on and tested with the Intel `ifort`/`icc` compilers. -When using newer versions of Intel's oneAPI, replacing `icc` with `icx` should work. Please refrain from using `ifx` instead of `ifort`, however. -When attempting to build with `gfortran` and `gcc`, add `-Dla_backend=mkl` to the meson setup command. Compatibility with the GNU compilers might be limited. We recommend the CMake build (see the corresponding section) in this instance. +**GNU (`gfortran`/`gcc`) + OpenBLAS**: +```bash +export FC=gfortran CC=gcc +meson setup _build -Dlapack=openblas --prefix=$PWD/_dist +meson install -C _build +``` -By default the `meson` build will create a **statically** linked binary.
+
--- diff --git a/config/meson.build b/config/meson.build index 5a5ec726..169ad3eb 100644 --- a/config/meson.build +++ b/config/meson.build @@ -123,8 +123,12 @@ if fc_id == 'intel-llvm' warning('intel-llvm: libgcc_s.so not found — _Unwind_* symbols will be NULL, ' + 'Intel Fortran runtime will SIGSEGV at startup.') endif + # For static builds libgcc_s.so is not needed (signal handler uses ISO_C_BINDING + # and no longer goes through libifcore's _Unwind_* path), and adding an explicit + # .so path would defeat -static. Only add it for dynamic builds. _lifport_arg = static_build ? [] : ['-lifport'] - add_project_link_arguments(_lifport_arg + _gcc_s_link, language : 'fortran') + _gcc_s_arg = static_build ? [] : _gcc_s_link + add_project_link_arguments(_lifport_arg + _gcc_s_arg, language : 'fortran') endif # ═══════════════════════════════════════════════════════════════════════════════ @@ -143,20 +147,24 @@ if static_build elif fc_id == 'intel' # -static-intel : statically links Intel runtime (ifcore, imf, svml) # -qopenmp-link=static : statically links Intel OpenMP (libiomp5) - # Add -static on top if a fully self-contained binary is needed and - # glibc-static is available on the build host. + # -static : forces all -l flags (including MKL) to resolve to .a add_project_link_arguments( '-static-intel', '-qopenmp-link=static', + '-static', language : 'fortran', ) elif fc_id == 'intel-llvm' - # -static-intel : statically links Intel runtime (ifcore, ifport, imf, svml) - # -qopenmp-link=static : statically links Intel OpenMP (libomp / libiomp5) + # -static only: with LIBRARY_PATH including the Intel compiler lib dir, + # the linker finds libifcore.a/libimf.a/libiomp5.a directly. + # -static-intel + -qopenmp-link=static are NOT used because combined with + # -fopenmp link args from non-Intel subprojects they cause libifcore.a vs + # libifcoremt.a duplicate-symbol errors (ifx 2025.3). Allow-multiple- + # definition suppresses the remaining conflict (same pattern as ifort above). add_project_link_arguments( - '-static-intel', - '-qopenmp-link=static', + '-static', + '-Wl,--allow-multiple-definition', language : 'fortran', ) endif diff --git a/meson.build b/meson.build index b80259af..5e865741 100644 --- a/meson.build +++ b/meson.build @@ -64,7 +64,7 @@ if omp_dep.found() add_project_arguments('-DWITH_OMP', language : ['c', 'fortran']) endif -_omp_link_dep = (omp_dep.found() and not static_build) ? [omp_dep] : [] +_omp_link_dep = omp_dep.found() ? [omp_dep] : [] # ═══════════════════════════════════════════════════════════════════════════════ # LAPACK / BLAS @@ -91,7 +91,45 @@ _prefer_mkl = (fc_id in ['intel', 'intel-llvm']) and (lapack_opt == 'auto') # ── MKL ─────────────────────────────────────────────────────────────────────── if lapack_opt == 'mkl' or _prefer_mkl - _mkl = dependency('mkl-sdl', required : false, static : static_build) + _mkl = dependency('', required : false) # not-found sentinel + + # For static builds, mkl-sdl only offers libmkl_rt.so (no .a equivalent). + # Use run_command to get the lib dir from pkg-config WITHOUT resolving the + # dependency (so we can override it for subprojects below). Then look up + # the real .a archives with explicit dirs:. + # iomp5/gomp are provided by -static-intel/-qopenmp-link=static, so we do + # not add them explicitly here. + if static_build + _pc = find_program('pkg-config', required : false) + _mkl_libdir = '' + if _pc.found() + _r = run_command(_pc, '--variable=libdir', 'mkl-sdl', check : false) + if _r.returncode() == 0 + _mkl_libdir = _r.stdout().strip() + endif + endif + if _mkl_libdir != '' + _thread_lib = (fc_id == 'gcc') ? 'mkl_gnu_thread' : 'mkl_intel_thread' + _mkl_sa_parts = [] + foreach lib : ['mkl_intel_lp64', _thread_lib, 'mkl_core'] + _l = fc.find_library(lib, dirs : [_mkl_libdir], required : false, static : true) + if _l.found() + _mkl_sa_parts += [_l] + endif + endforeach + if _mkl_sa_parts.length() == 3 + _mkl = declare_dependency( + dependencies : _mkl_sa_parts, + link_args : ['-lpthread', '-lm', '-ldl'], + ) + endif + endif + endif + + if not _mkl.found() + # Dynamic build (or static path failed): use mkl-sdl single dynamic library. + _mkl = dependency('mkl-sdl', required : false, static : static_build) + endif if not _mkl.found() _thread_lib = (fc_id == 'gcc') ? 'mkl_gnu_thread' : 'mkl_intel_thread' @@ -194,6 +232,12 @@ if static_build if with_openblas meson.override_dependency('openblas', blas_dep) endif + if with_mkl + # Override mkl-sdl so subprojects (gfnff, gfn0, …) don't reintroduce -lmkl_rt + # when we resolved MKL statically (dependency() was never called for mkl-sdl + # in the static path above, so the override is still allowed here). + meson.override_dependency('mkl-sdl', lapack_dep) + endif endif # libgfortran.a (Fortran runtime) references quadmath_* symbols; the GFortran diff --git a/subprojects/fmlip_relay b/subprojects/fmlip_relay index 22a788a4..fa44cc39 160000 --- a/subprojects/fmlip_relay +++ b/subprojects/fmlip_relay @@ -1 +1 @@ -Subproject commit 22a788a48031af3a1ae9f687af09595568dd9fb4 +Subproject commit fa44cc393ef51b1c4f38a0e4c1303994268b13c4 diff --git a/subprojects/gfn0 b/subprojects/gfn0 index 717cce28..255d47bb 160000 --- a/subprojects/gfn0 +++ b/subprojects/gfn0 @@ -1 +1 @@ -Subproject commit 717cce283ede4fa88d949292291b1f0f6984440a +Subproject commit 255d47bb2c2b443d8bc70b1ce45c0f4deac42f02 diff --git a/subprojects/gfnff b/subprojects/gfnff index e0d6e398..112a7a1b 160000 --- a/subprojects/gfnff +++ b/subprojects/gfnff @@ -1 +1 @@ -Subproject commit e0d6e39863eaa09531b126dc4a1a58945abc25fb +Subproject commit 112a7a1bb5707f0e1ab1e86327c669b88cabafe0 diff --git a/subprojects/pvol b/subprojects/pvol index c975ad4e..010bddaa 160000 --- a/subprojects/pvol +++ b/subprojects/pvol @@ -1 +1 @@ -Subproject commit c975ad4e062a00e6b228505bec0f1d722aea9f46 +Subproject commit 010bddaa8766a03e023a977aeebaa6454629c947 From 6124536ed0b0a07dc419a5b9fd27e8de872b3621 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 25 Apr 2026 19:56:01 +0200 Subject: [PATCH 297/374] Update commit on meson wrap and cmake find files --- config/modules/Findfmlip_relay.cmake | 2 +- config/modules/Findgfn0.cmake | 2 +- config/modules/Findgfnff.cmake | 2 +- config/modules/Findlibpvol.cmake | 2 +- subprojects/fmlip_relay.wrap | 2 +- subprojects/gfn0.wrap | 2 +- subprojects/gfnff.wrap | 2 +- subprojects/pvol.wrap | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) diff --git a/config/modules/Findfmlip_relay.cmake b/config/modules/Findfmlip_relay.cmake index b5e95dcd..f0816f7a 100644 --- a/config/modules/Findfmlip_relay.cmake +++ b/config/modules/Findfmlip_relay.cmake @@ -1,7 +1,7 @@ set(_lib "fmlip_relay") set(_pkg "FMLIP_RELAY") set(_url "https://github.com/pprcht/fmlip-relay") -set(_branch "22a788a48031af3a1ae9f687af09595568dd9fb4") +set(_branch "fa44cc393ef51b1c4f38a0e4c1303994268b13c4") # Discovery method order can be overridden by the parent project, e.g.: # set(FMLIP_RELAY_FIND_METHOD "subproject" "cmake") diff --git a/config/modules/Findgfn0.cmake b/config/modules/Findgfn0.cmake index 8327754f..e5031dae 100644 --- a/config/modules/Findgfn0.cmake +++ b/config/modules/Findgfn0.cmake @@ -17,7 +17,7 @@ set(_lib "gfn0") set(_pkg "GFN0") set(_url "https://github.com/pprcht/gfn0") -set(_branch "717cce283ede4fa88d949292291b1f0f6984440a") +set(_branch "255d47bb2c2b443d8bc70b1ce45c0f4deac42f02") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") diff --git a/config/modules/Findgfnff.cmake b/config/modules/Findgfnff.cmake index 090aeaf3..cbd8c028 100644 --- a/config/modules/Findgfnff.cmake +++ b/config/modules/Findgfnff.cmake @@ -17,7 +17,7 @@ set(_lib "gfnff") set(_pkg "GFNFF") set(_url "https://github.com/pprcht/gfnff") -set(_branch "e0d6e39863eaa09531b126dc4a1a58945abc25fb") +set(_branch "112a7a1bb5707f0e1ab1e86327c669b88cabafe0") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") diff --git a/config/modules/Findlibpvol.cmake b/config/modules/Findlibpvol.cmake index 13c880c9..407a55f9 100644 --- a/config/modules/Findlibpvol.cmake +++ b/config/modules/Findlibpvol.cmake @@ -17,7 +17,7 @@ set(_lib "pvol") set(_pkg "PVOL") set(_url "https://github.com/pprcht/libpvol.git") -set(_branch "c975ad4e062a00e6b228505bec0f1d722aea9f46") +set(_branch "010bddaa8766a03e023a977aeebaa6454629c947") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf" ) diff --git a/subprojects/fmlip_relay.wrap b/subprojects/fmlip_relay.wrap index e773b3e9..34f5d002 100644 --- a/subprojects/fmlip_relay.wrap +++ b/subprojects/fmlip_relay.wrap @@ -3,7 +3,7 @@ # the submodule is checked out under subprojects/fmlip_relay/. [wrap-git] url = https://github.com/pprcht/fmlip-relay -revision = 22a788a48031af3a1ae9f687af09595568dd9fb4 +revision = fa44cc393ef51b1c4f38a0e4c1303994268b13c4 clone-recursive = true [provide] diff --git a/subprojects/gfn0.wrap b/subprojects/gfn0.wrap index eea8d469..182fac86 100644 --- a/subprojects/gfn0.wrap +++ b/subprojects/gfn0.wrap @@ -1,6 +1,6 @@ [wrap-git] url = https://github.com/pprcht/gfn0 -revision = 717cce283ede4fa88d949292291b1f0f6984440a +revision = 255d47bb2c2b443d8bc70b1ce45c0f4deac42f02 clone-recursive = true [provide] diff --git a/subprojects/gfnff.wrap b/subprojects/gfnff.wrap index 2da13069..ae3c5bbc 100644 --- a/subprojects/gfnff.wrap +++ b/subprojects/gfnff.wrap @@ -1,6 +1,6 @@ [wrap-git] url = https://github.com/pprcht/gfnff -revision = e0d6e39863eaa09531b126dc4a1a58945abc25fb +revision = 112a7a1bb5707f0e1ab1e86327c669b88cabafe0 clone-recursive = true [provide] diff --git a/subprojects/pvol.wrap b/subprojects/pvol.wrap index f8f6c02b..ef60af93 100644 --- a/subprojects/pvol.wrap +++ b/subprojects/pvol.wrap @@ -1,6 +1,6 @@ [wrap-git] url = https://github.com/pprcht/libpvol.git -revision = c975ad4e062a00e6b228505bec0f1d722aea9f46 +revision = 010bddaa8766a03e023a977aeebaa6454629c947 clone-recursive = true [provide] From 2a4d0377f051d260aa2abafdf00a4044f4aa4659 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 25 Apr 2026 19:59:22 +0200 Subject: [PATCH 298/374] alternative flag '-itmdgc' --- src/confparse.f90 | 2 +- src/printouts.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/confparse.f90 b/src/confparse.f90 index 403d14aa..7d3b0409 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -383,7 +383,7 @@ subroutine parseflags(env,arg,nra) env%Maxrestart = 1 !> for non-iterative MTD-GC only exit - case ('-v3','-v2i') !> confscript version 2 but iterativ (iMTD-GC) + case ('-v3','-v2i','-imtdgc') !> confscript version 2 but iterativ (iMTD-GC) processedarg(i) = .true. env%crestver = crest_imtd env%iterativeV2 = .true. diff --git a/src/printouts.f90 b/src/printouts.f90 index d3a6cab4..05dfaa7c 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -208,7 +208,7 @@ subroutine confscript_morehelp(flag) call help_opt('-opt/-optimize',fw,'Geometry optimization') call help_opt('-hess/-numhess',fw,'Numerical Hessian / vibrational frequencies') call help_opt('-md/-dynamics',fw,'Molecular dynamics simulation') - call help_opt('-v3',fw,'iMTD-GC conformational search (see --help conf)') + call help_opt('-v3/-imtdgc',fw,'iMTD-GC conformational search (see --help conf)') call help_opt('-v4/-entropy',fw,'Entropy/free-energy sampling (see --help conf)') call help_opt('-mdopt',fw,'Ensemble optimization (no sorting)') call help_opt('-screen',fw,'Ensemble screening') From 115d93d62af7e82cb92064e485c556aeae223e32 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 25 Apr 2026 20:52:54 +0200 Subject: [PATCH 299/374] workflow rework, part 1 --- .github/workflows/build-CI.yml | 145 ++++++++++++++--------------- .github/workflows/build-upload.yml | 132 ++++++++++++++------------ CMakeLists.txt | 10 +- 3 files changed, 154 insertions(+), 133 deletions(-) diff --git a/.github/workflows/build-CI.yml b/.github/workflows/build-CI.yml index 4ce283a1..2b1bd33b 100644 --- a/.github/workflows/build-CI.yml +++ b/.github/workflows/build-CI.yml @@ -4,12 +4,13 @@ on: push: branches: - master + - experimental - '*-maintenance' pull_request: branches: - master - '*-maintenance' - workflow_dispatch: + workflow_dispatch: env: BUILD_DIR: _build @@ -22,11 +23,6 @@ env: numpy ase matplotlib - LINUX_INTEL_COMPONENTS: >- - intel-oneapi-compiler-fortran-2023.1.0 - intel-oneapi-compiler-dpcpp-cpp-and-cpp-classic-2023.1.0 - intel-oneapi-mkl-2023.1.0 - intel-oneapi-mkl-devel-2023.1.0 jobs: build: @@ -35,26 +31,28 @@ jobs: strategy: fail-fast: false matrix: - os: [ubuntu-latest] - build-type: [debug] - toolchain: - - { compiler: gcc, version: '11', build: cmake } - - { compiler: gcc, version: '12', build: cmake } - - { compiler: gcc, version: '14', build: cmake } - #- { compiler: intel, version: '2023.1.0', build: cmake } - include: - # ---- Linux GCC CMake debugoptimized build ------------------------ - - { os: ubuntu-latest, build-type: debugoptimized, + # ---- Linux GCC + OpenBLAS — CMake debug -------------------------- + - { os: ubuntu-latest, build-type: debug, + toolchain: { compiler: gcc, version: '12', build: cmake } } + - { os: ubuntu-latest, build-type: debug, toolchain: { compiler: gcc, version: '14', build: cmake } } - - # ---- Linux static builds ----------------------------------------- - - { os: ubuntu-latest, build-type: static, - toolchain: { compiler: gcc, version: '12', build: cmake } } - #- { os: ubuntu-latest, build-type: static, - # toolchain: { compiler: intel, version: '2023.1.0', build: meson } } - - # ---- macOS GCC CMake debug builds -------------------------------- + + # ---- Linux GCC + OpenBLAS — Meson debugoptimized ----------------- + - { os: ubuntu-latest, build-type: debugoptimized, + toolchain: { compiler: gcc, version: '12', build: meson } } + - { os: ubuntu-latest, build-type: debugoptimized, + toolchain: { compiler: gcc, version: '14', build: meson } } + + # ---- Linux Intel (ifx/icx) + MKL — CMake debug ------------------ + - { os: ubuntu-latest, build-type: debug, + toolchain: { compiler: intel, version: '2025.1', mkl_version: '2025.1', build: cmake } } + + # ---- Linux Intel (ifx/icx) + MKL — Meson debugoptimized --------- + - { os: ubuntu-latest, build-type: debugoptimized, + toolchain: { compiler: intel, version: '2025.1', mkl_version: '2025.1', build: meson } } + + # ---- macOS GCC + OpenBLAS — CMake debug (GNU only) --------------- - { os: macos-latest, build-type: debug, toolchain: { compiler: gcc, version: '12', build: cmake } } - { os: macos-latest, build-type: debug, @@ -77,17 +75,17 @@ jobs: python-version: "3.10" # ---------------------------------------------------------------------- - # Compiler setup (GCC via setup-fortran, Intel via oneAPI on Linux) + # Compiler setup # ---------------------------------------------------------------------- - name: Install GCC using setup-fortran if: ${{ contains(matrix.toolchain.compiler, 'gcc') }} uses: fortran-lang/setup-fortran@v1 with: - compiler: ${{ matrix.toolchain.compiler }} # "gcc" - version: ${{ matrix.toolchain.version }} # e.g. "12" + compiler: ${{ matrix.toolchain.compiler }} + version: ${{ matrix.toolchain.version }} - - name: Install libopenblas (Linux GNU builds only) + - name: Install libopenblas (Linux GCC builds) if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.toolchain.compiler, 'gcc') }} run: | sudo apt-get update @@ -103,48 +101,49 @@ jobs: echo "CPPFLAGS=-I/usr/local/opt/openblas/include -I/opt/homebrew/opt/openblas/include" >> $GITHUB_ENV - name: Prepare for Intel cache restore - if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.toolchain.compiler, 'intel') }} + if: ${{ contains(matrix.toolchain.compiler, 'intel') }} run: | sudo mkdir -p /opt/intel - sudo chown "$USER" /opt/intel + sudo chown $USER /opt/intel - - name: Cache Intel oneAPI install - if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.toolchain.compiler, 'intel') }} + - name: Cache Intel installation + if: ${{ contains(matrix.toolchain.compiler, 'intel') }} id: cache-install uses: actions/cache@v4 with: path: /opt/intel/oneapi - key: install-${{ matrix.toolchain.compiler }}-${{ matrix.toolchain.version }}-${{ matrix.os }} + key: install-${{ matrix.toolchain.compiler }}-${{ matrix.toolchain.version }}-${{ matrix.toolchain.mkl_version }}-${{ matrix.os }} - - name: Install Intel oneAPI (compiler + MKL) - if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.toolchain.compiler, 'intel') && steps.cache-install.outputs.cache-hit != 'true' }} - run: | - KEY=GPG-PUB-KEY-INTEL-SW-PRODUCTS-2023.PUB - wget https://apt.repos.intel.com/intel-gpg-keys/$KEY - sudo apt-key add $KEY - rm $KEY + - name: Install Intel Compiler + if: ${{ contains(matrix.toolchain.compiler, 'intel') && steps.cache-install.outputs.cache-hit != 'true' }} + uses: fortran-lang/setup-fortran@v1 + with: + compiler: ${{ matrix.toolchain.compiler }} + version: ${{ matrix.toolchain.version }} - echo "deb https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list - sudo apt-get update - sudo apt-get install -y $PKG - env: - PKG: ${{ env.LINUX_INTEL_COMPONENTS }} + - name: Install Intel MKL + if: ${{ contains(matrix.toolchain.compiler, 'intel') && steps.cache-install.outputs.cache-hit != 'true' }} + run: | + sudo apt-get install -y \ + intel-oneapi-mkl-${{ matrix.toolchain.mkl_version }} \ + intel-oneapi-mkl-devel-${{ matrix.toolchain.mkl_version }} - name: Setup Intel oneAPI environment - if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.toolchain.compiler, 'intel') }} + if: ${{ contains(matrix.toolchain.compiler, 'intel') }} run: | - source /opt/intel/oneapi/setvars.sh + source /opt/intel/oneapi/setvars.sh --force printenv >> $GITHUB_ENV - name: Set compiler environment variables run: | - if [ "${{ matrix.toolchain.compiler }}" = "gcc" ]; then - echo "FC=gfortran" >> $GITHUB_ENV - echo "CC=gcc" >> $GITHUB_ENV - elif [ "${{ matrix.toolchain.compiler }}" = "intel" ]; then - # adjust to ifx/ifort if we want to change it in the future - echo "FC=ifort" >> $GITHUB_ENV - echo "CC=icx" >> $GITHUB_ENV + if [ ! -n "$FC" ]; then + if [ "${{ matrix.toolchain.compiler }}" = "gcc" ]; then + echo "FC=gfortran" >> $GITHUB_ENV + echo "CC=gcc" >> $GITHUB_ENV + elif [ "${{ matrix.toolchain.compiler }}" = "intel" ]; then + echo "FC=ifx" >> $GITHUB_ENV + echo "CC=icx" >> $GITHUB_ENV + fi fi echo "COMPILER_VERSION=${{ matrix.toolchain.version }}" >> $GITHUB_ENV @@ -163,15 +162,6 @@ jobs: # Configure # ---------------------------------------------------------------------- - - name: Configure build (Meson) - if: ${{ matrix.toolchain.build == 'meson' }} - run: > - meson setup ${{ env.BUILD_DIR }} - --buildtype=debugoptimized - --prefix=$PWD/_dist - --libdir=lib - --warnlevel=0 - - name: Configure build (CMake, debug) if: ${{ matrix.toolchain.build == 'cmake' && matrix.build-type == 'debug' }} run: > @@ -190,16 +180,26 @@ jobs: -DCMAKE_INSTALL_PREFIX=$PWD/_dist -DCMAKE_INSTALL_LIBDIR=lib - - name: Configure build (CMake, static) - if: ${{ matrix.toolchain.build == 'cmake' && matrix.build-type == 'static' }} + - name: Configure build (Meson, GNU) + if: ${{ matrix.toolchain.build == 'meson' && matrix.toolchain.compiler == 'gcc' }} run: > - cmake -B${{ env.BUILD_DIR }} - -GNinja - -DCMAKE_BUILD_TYPE=RelWithDebInfo - -DCMAKE_INSTALL_PREFIX=$PWD/_dist - -DCMAKE_INSTALL_LIBDIR=lib - -DWITH_TESTS=OFF - -DSTATICBUILD=ON + meson setup ${{ env.BUILD_DIR }} + --buildtype=${{ matrix.build-type }} + --prefix=$PWD/_dist + --libdir=lib + --warnlevel=0 + -Dlapack=openblas + + - name: Configure build (Meson, Intel) + if: ${{ matrix.toolchain.build == 'meson' && contains(matrix.toolchain.compiler, 'intel') }} + run: > + meson setup ${{ env.BUILD_DIR }} + --buildtype=${{ matrix.build-type }} + --prefix=$PWD/_dist + --libdir=lib + --warnlevel=0 + --native-file=config/intel-llvm.ini + -Dlapack=mkl # ---------------------------------------------------------------------- # Build / test / install @@ -220,4 +220,3 @@ jobs: run: | ninja -C ${{ env.BUILD_DIR }} install echo "CREST_PREFIX=$PWD/_dist" >> $GITHUB_ENV - diff --git a/.github/workflows/build-upload.yml b/.github/workflows/build-upload.yml index 25effbea..6957fdf8 100644 --- a/.github/workflows/build-upload.yml +++ b/.github/workflows/build-upload.yml @@ -1,4 +1,4 @@ -name: Continuous release (static Linux) +name: Continuous release (static builds) on: push: @@ -16,11 +16,6 @@ env: numpy ase matplotlib - LINUX_INTEL_COMPONENTS: >- - intel-oneapi-compiler-fortran-2023.1.0 - intel-oneapi-compiler-dpcpp-cpp-and-cpp-classic-2023.1.0 - intel-oneapi-mkl-2023.1.0 - intel-oneapi-mkl-devel-2023.1.0 jobs: build-static: @@ -29,13 +24,23 @@ jobs: strategy: fail-fast: false matrix: - os: [ubuntu-latest] - build-type: [static] - toolchain: - # GNU static CMake build - - { compiler: gcc, version: '14', build: cmake } - # Intel static Meson build - #- { compiler: intel, version: '2023.1.0', build: meson } + include: + # Linux x86_64 — GNU static (CMake) + - { os: ubuntu-latest, build-type: static, + toolchain: { compiler: gcc, version: '14', build: cmake } } + + # Linux x86_64 — Intel LLVM static (Meson; better ifx static support) + - { os: ubuntu-latest, build-type: static, + toolchain: { compiler: intel, version: '2025.1', mkl_version: '2025.1', build: meson } } + + # Linux aarch64 — GNU static (CMake; Intel oneAPI is x86-only) + - { os: ubuntu-24.04-arm, build-type: static, + toolchain: { compiler: gcc, version: '14', build: cmake } } + + # macOS arm64 — GNU mostly-static (CMake) + # Note: macOS does not support fully-static executables; system libs remain dynamic. + - { os: macos-latest, build-type: static, + toolchain: { compiler: gcc, version: '14', build: cmake } } defaults: run: @@ -52,65 +57,76 @@ jobs: # --- Compiler setup ---------------------------------------------------- - - name: Install GCC (Linux) using setup-fortran + - name: Install GCC using setup-fortran if: ${{ contains(matrix.toolchain.compiler, 'gcc') }} uses: fortran-lang/setup-fortran@v1 with: compiler: ${{ matrix.toolchain.compiler }} version: ${{ matrix.toolchain.version }} - - name: Install libopenblas (Linux GNU builds only) - if: ${{ contains(matrix.toolchain.compiler, 'gcc') }} + - name: Install libopenblas (Linux GCC builds) + if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.toolchain.compiler, 'gcc') }} run: | sudo apt-get update sudo apt-get install -y libopenblas-dev + - name: Install OpenBLAS (macOS) + if: ${{ contains(matrix.os, 'macos') }} + run: | + brew update + brew install openblas + echo "PKG_CONFIG_PATH=/usr/local/opt/openblas/lib/pkgconfig:/opt/homebrew/opt/openblas/lib/pkgconfig" >> $GITHUB_ENV + echo "LDFLAGS=-L/usr/local/opt/openblas/lib -L/opt/homebrew/opt/openblas/lib" >> $GITHUB_ENV + echo "CPPFLAGS=-I/usr/local/opt/openblas/include -I/opt/homebrew/opt/openblas/include" >> $GITHUB_ENV + - name: Prepare for Intel cache restore if: ${{ contains(matrix.toolchain.compiler, 'intel') }} run: | sudo mkdir -p /opt/intel - sudo chown "$USER" /opt/intel + sudo chown $USER /opt/intel - - name: Cache Intel oneAPI install + - name: Cache Intel installation if: ${{ contains(matrix.toolchain.compiler, 'intel') }} id: cache-install uses: actions/cache@v4 with: path: /opt/intel/oneapi - key: install-${{ matrix.toolchain.compiler }}-${{ matrix.toolchain.version }}-${{ matrix.os }} + key: install-${{ matrix.toolchain.compiler }}-${{ matrix.toolchain.version }}-${{ matrix.toolchain.mkl_version }}-${{ matrix.os }} - - name: Install Intel oneAPI (compiler + MKL) - if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.toolchain.compiler, 'intel') && steps.cache-install.outputs.cache-hit != 'true' }} - run: | - KEY=GPG-PUB-KEY-INTEL-SW-PRODUCTS-2023.PUB - wget https://apt.repos.intel.com/intel-gpg-keys/$KEY - sudo apt-key add $KEY - rm $KEY + - name: Install Intel Compiler + if: ${{ contains(matrix.toolchain.compiler, 'intel') && steps.cache-install.outputs.cache-hit != 'true' }} + uses: fortran-lang/setup-fortran@v1 + with: + compiler: ${{ matrix.toolchain.compiler }} + version: ${{ matrix.toolchain.version }} - echo "deb https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list - sudo apt-get update - sudo apt-get install -y $PKG - env: - PKG: ${{ env.LINUX_INTEL_COMPONENTS }} + - name: Install Intel MKL + if: ${{ contains(matrix.toolchain.compiler, 'intel') && steps.cache-install.outputs.cache-hit != 'true' }} + run: | + sudo apt-get install -y \ + intel-oneapi-mkl-${{ matrix.toolchain.mkl_version }} \ + intel-oneapi-mkl-devel-${{ matrix.toolchain.mkl_version }} - name: Setup Intel oneAPI environment if: ${{ contains(matrix.toolchain.compiler, 'intel') }} run: | - source /opt/intel/oneapi/setvars.sh + source /opt/intel/oneapi/setvars.sh --force printenv >> $GITHUB_ENV - name: Set compiler environment variables run: | - if [ "${{ matrix.toolchain.compiler }}" = "gcc" ]; then - echo "FC=gfortran" >> $GITHUB_ENV - echo "CC=gcc" >> $GITHUB_ENV - elif [ "${{ matrix.toolchain.compiler }}" = "intel" ]; then - echo "FC=ifort" >> $GITHUB_ENV - echo "CC=icx" >> $GITHUB_ENV + if [ ! -n "$FC" ]; then + if [ "${{ matrix.toolchain.compiler }}" = "gcc" ]; then + echo "FC=gfortran" >> $GITHUB_ENV + echo "CC=gcc" >> $GITHUB_ENV + elif [ "${{ matrix.toolchain.compiler }}" = "intel" ]; then + echo "FC=ifx" >> $GITHUB_ENV + echo "CC=icx" >> $GITHUB_ENV + fi fi echo "COMPILER_VERSION=${{ matrix.toolchain.version }}" >> $GITHUB_ENV - # --- Dependencies & submodules --------------------------------------- + # --- Dependencies & submodules ----------------------------------------- - name: Git submodules checkout run: git submodule update --init @@ -119,16 +135,7 @@ jobs: run: | pip3 install ${{ env.PIP_PACKAGES }} ${{ env.PIP_EXTRAS }} - # --- Configure -------------------------------------------------------- - - - name: Configure build (Meson, static-ish) - if: ${{ matrix.toolchain.build == 'meson' }} - run: > - meson setup ${{ env.BUILD_DIR }} - --buildtype=debugoptimized - --prefix=$PWD/_dist - --libdir=lib - --warnlevel=0 + # --- Configure --------------------------------------------------------- - name: Configure build (CMake, static) if: ${{ matrix.toolchain.build == 'cmake' && matrix.build-type == 'static' }} @@ -141,7 +148,20 @@ jobs: -DWITH_TESTS=OFF -DSTATICBUILD=ON - # --- Build / (optional) test / install -------------------------------- + - name: Configure build (Meson, Intel static) + if: ${{ matrix.toolchain.build == 'meson' && matrix.build-type == 'static' }} + run: > + meson setup ${{ env.BUILD_DIR }} + --buildtype=release + --prefix=$PWD/_dist + --libdir=lib + --warnlevel=0 + --native-file=config/intel-llvm.ini + -Dstatic=true + -Dlapack=mkl + -Dtests=false + + # --- Build / install --------------------------------------------------- - name: Build project run: ninja -C ${{ env.BUILD_DIR }} @@ -157,17 +177,16 @@ jobs: cp COPYING crest/LICENSE cp COPYING.LESSER crest/LICENSE.LESSER cp _dist/bin/crest crest/ + ARCH=$(uname -m) + UNAME_OS=$(uname -s | tr '[:upper:]' '[:lower:]') COMPILER_NAME="${{ matrix.toolchain.compiler }}" - # Map GCC → gnu for backwards-compatible file names - if [ "$COMPILER_NAME" = "gcc" ]; then - COMPILER_NAME="gnu" - fi - OUTPUT="crest-${COMPILER_NAME}-${{ matrix.toolchain.version }}-${{ matrix.os }}.tar" + [ "$COMPILER_NAME" = "gcc" ] && COMPILER_NAME="gnu" + [ "$COMPILER_NAME" = "intel" ] && COMPILER_NAME="intel" + OUTPUT="crest-${COMPILER_NAME}-${{ matrix.toolchain.version }}-${UNAME_OS}-${ARCH}.tar" tar cvf "$OUTPUT" crest xz -T0 "$OUTPUT" echo "CREST_OUTPUT=${OUTPUT}.xz" >> $GITHUB_ENV - - name: Upload package uses: actions/upload-artifact@v4 with: @@ -264,4 +283,3 @@ jobs: --name "$f" \ --file "$f" done - diff --git a/CMakeLists.txt b/CMakeLists.txt index 5579ca3e..ce0fa91b 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -33,8 +33,7 @@ project( # Apply debug flags when building in Debug mode set(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG} \ - -g -O0 -fcheck=all -fbacktrace -finit-real=snan -finit-integer=-999 \ - -Wall -Wextra -Wuninitialized -Wmaybe-uninitialized") + -g -O0 -fcheck=all -fbacktrace -finit-real=snan -finit-integer=-999") # Follow GNU conventions for installing directories include(GNUInstallDirs) @@ -65,7 +64,12 @@ if(NOT TARGET "OpenMP::OpenMP_Fortran" AND WITH_OpenMP) message(STATUS "OpenMP::OpenMP_Fortran is linking the following libraries:") foreach(lib ${OpenMP_Fortran_LIBRARIES}) message(STATUS "${lib}") - endforeach() + endforeach() +endif() +# Propagate OpenMP link flags globally so subproject executables (e.g. pvol tests) +# that bypass CMake target dependencies still link the OpenMP runtime correctly. +if(WITH_OpenMP AND OpenMP_Fortran_FOUND) + set(CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}") endif() # Check if we are using OpenBLAS (need a precompiler definition if yes) From 8de089701eb42d6b9651124f3192014c9217fd92 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 26 Apr 2026 11:42:07 +0200 Subject: [PATCH 300/374] workflow rework, part 2 --- config/modules/Findgfn0.cmake | 2 +- config/modules/Findgfnff.cmake | 2 +- src/dynamics/dynamics_module.f90 | 2 +- src/optimize/rfo.f90 | 2 +- src/sorting/irmsd_module.f90 | 5 ++++- src/symmetry_i.f90 | 5 +++++ subprojects/gfn0 | 2 +- subprojects/gfn0.wrap | 2 +- subprojects/gfnff | 2 +- subprojects/gfnff.wrap | 2 +- 10 files changed, 17 insertions(+), 9 deletions(-) diff --git a/config/modules/Findgfn0.cmake b/config/modules/Findgfn0.cmake index e5031dae..af60fe62 100644 --- a/config/modules/Findgfn0.cmake +++ b/config/modules/Findgfn0.cmake @@ -17,7 +17,7 @@ set(_lib "gfn0") set(_pkg "GFN0") set(_url "https://github.com/pprcht/gfn0") -set(_branch "255d47bb2c2b443d8bc70b1ce45c0f4deac42f02") +set(_branch "4fbf39bf6790eaef74e06fbb49b98f676db66a2b") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") diff --git a/config/modules/Findgfnff.cmake b/config/modules/Findgfnff.cmake index cbd8c028..7bc54ed2 100644 --- a/config/modules/Findgfnff.cmake +++ b/config/modules/Findgfnff.cmake @@ -17,7 +17,7 @@ set(_lib "gfnff") set(_pkg "GFNFF") set(_url "https://github.com/pprcht/gfnff") -set(_branch "112a7a1bb5707f0e1ab1e86327c669b88cabafe0") +set(_branch "b846775c42526a769242be5607d0cde6983764d1") if(NOT DEFINED "${_pkg}_FIND_METHOD") set("${_pkg}_FIND_METHOD" "subproject" "cmake" "fetch" "pkgconf") diff --git a/src/dynamics/dynamics_module.f90 b/src/dynamics/dynamics_module.f90 index e1524d7f..1f317766 100644 --- a/src/dynamics/dynamics_module.f90 +++ b/src/dynamics/dynamics_module.f90 @@ -763,7 +763,7 @@ subroutine u_block(mol,dat,epot,temp,pr,bdump) contains subroutine regress(n1,n2,rege,slope) implicit none - real(wp) :: rege(stdout),slope + real(wp) :: rege(*),slope integer :: n1,n2,n real(wp) :: sx,sy,sxx,sxy,x integer :: i,j,k,l,ich,och,io diff --git a/src/optimize/rfo.f90 b/src/optimize/rfo.f90 index 6da0be89..a5245dd0 100644 --- a/src/optimize/rfo.f90 +++ b/src/optimize/rfo.f90 @@ -219,7 +219,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) molopt%xyz = mol%xyz molopt%wrextxyz = calc%logextxyz estart = etot - !energy = etot + energy = etot !>--- initialize .log file, if desired ilog = 942 diff --git a/src/sorting/irmsd_module.f90 b/src/sorting/irmsd_module.f90 index 61dad8c7..51607551 100644 --- a/src/sorting/irmsd_module.f90 +++ b/src/sorting/irmsd_module.f90 @@ -181,7 +181,10 @@ subroutine initialize_rmsd_cache(self,nat) class(rmsd_cache) :: self integer,intent(in) :: nat - if (.not.self%initialized.or.size(self%xyzscratch,2) .ne. nat) then + if (.not.self%initialized) then + call self%allocate(nat) + self%initialized = .true. + else if (size(self%xyzscratch,2) .ne. nat) then call self%allocate(nat) self%initialized = .true. end if diff --git a/src/symmetry_i.f90 b/src/symmetry_i.f90 index 7a9cf9d2..b5d77ccf 100644 --- a/src/symmetry_i.f90 +++ b/src/symmetry_i.f90 @@ -601,6 +601,11 @@ subroutine optimize_transformation_params(state,elem) integer :: vars,cycle,i,hits logical :: finish + values = 0.0_wp + grad = 0.0_wp + force = 0.0_wp + step = 0.0_wp + vars = elem%nparam if (vars > MAXPARAM) then write (*,*) "Catastrophe in optimize_transformation_params!" diff --git a/subprojects/gfn0 b/subprojects/gfn0 index 255d47bb..4fbf39bf 160000 --- a/subprojects/gfn0 +++ b/subprojects/gfn0 @@ -1 +1 @@ -Subproject commit 255d47bb2c2b443d8bc70b1ce45c0f4deac42f02 +Subproject commit 4fbf39bf6790eaef74e06fbb49b98f676db66a2b diff --git a/subprojects/gfn0.wrap b/subprojects/gfn0.wrap index 182fac86..0b930fcc 100644 --- a/subprojects/gfn0.wrap +++ b/subprojects/gfn0.wrap @@ -1,6 +1,6 @@ [wrap-git] url = https://github.com/pprcht/gfn0 -revision = 255d47bb2c2b443d8bc70b1ce45c0f4deac42f02 +revision = 4fbf39bf6790eaef74e06fbb49b98f676db66a2b clone-recursive = true [provide] diff --git a/subprojects/gfnff b/subprojects/gfnff index 112a7a1b..b846775c 160000 --- a/subprojects/gfnff +++ b/subprojects/gfnff @@ -1 +1 @@ -Subproject commit 112a7a1bb5707f0e1ab1e86327c669b88cabafe0 +Subproject commit b846775c42526a769242be5607d0cde6983764d1 diff --git a/subprojects/gfnff.wrap b/subprojects/gfnff.wrap index ae3c5bbc..9214f782 100644 --- a/subprojects/gfnff.wrap +++ b/subprojects/gfnff.wrap @@ -1,6 +1,6 @@ [wrap-git] url = https://github.com/pprcht/gfnff -revision = 112a7a1bb5707f0e1ab1e86327c669b88cabafe0 +revision = b846775c42526a769242be5607d0cde6983764d1 clone-recursive = true [provide] From 96f93a057c8cd39406161d9ef6a14c2798a84cf2 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 3 May 2026 11:46:10 +0200 Subject: [PATCH 301/374] printout update --- src/printouts.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/printouts.f90 b/src/printouts.f90 index 05dfaa7c..61f45980 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -1060,7 +1060,7 @@ subroutine crest_no_runtype_selected() write (stdout,'(5x,a,t30,a)') '--sp','Single-point energy calculation' write (stdout,'(5x,a,t30,a)') '--opt','Structure optimization' write (stdout,'(5x,a,t30,a)') '--md','Molecular dynamics simulation' - write (stdout,'(5x,a,t30,a)') '--v3','iMTD-GC conformational search' + write (stdout,'(5x,a,t30,a)') '--imtdgc/--v3','iMTD-GC conformational search' write (stdout,'(5x,a,t30,a)') '--entropy','Entropy/free-energy sampling' write (stdout,'(5x,a,t30,a)') '--mdopt','Ensemble optimization (no sorting)' write (stdout,'(5x,a,t30,a)') '--screen','Ensemble screening' From c7cbf6e3f27f9bf7d8c11c4441df8ffaa02693b5 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 3 May 2026 12:26:59 +0200 Subject: [PATCH 302/374] Perpare for spin-polarized xtb via tblite --- src/calculator/calc_type.f90 | 1 + src/calculator/tblite_api.F90 | 72 ++++++++++++++++++++++++++--------- 2 files changed, 56 insertions(+), 17 deletions(-) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index bf5d4371..01471d5d 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -162,6 +162,7 @@ module calc_type type(tblite_data),allocatable :: tblite character(len=:),allocatable :: tbliteparam logical :: ceh_guess = .false. + logical :: spin_polarized = .false. !>--- GFN0-xTB data type(gfn0_data),allocatable :: g0calc diff --git a/src/calculator/tblite_api.F90 b/src/calculator/tblite_api.F90 index bf2bdfe4..dbf88728 100644 --- a/src/calculator/tblite_api.F90 +++ b/src/calculator/tblite_api.F90 @@ -23,7 +23,6 @@ !====================================================! module tblite_api -! use iso_fortran_env,only:wp => real64,stdout => output_unit use crest_parameters use strucrd #ifdef WITH_TBLITE @@ -42,6 +41,8 @@ module tblite_api use tblite_wavefunction_mulliken,only:get_molecular_dipole_moment use tblite_ceh_singlepoint,only:ceh_singlepoint use tblite_ceh_ceh,only:new_ceh_calculator + use tblite_spin,only:spin_polarization,new_spin_polarization + use tblite_container,only:container_type #endif use wiberg_mayer implicit none @@ -73,10 +74,11 @@ module tblite_api real(wp) :: accuracy = 1.0_wp character(len=:),allocatable :: paramfile type(wavefunction_type) :: wfn - type(wavefunction_type),allocatable :: wfn_aux + type(wavefunction_type),allocatable :: wfn_aux type(xtb_calculator) :: calc type(tblite_ctx) :: ctx type(tblite_resultstype) :: res + logical :: spin_polarized = .false. end type tblite_data public :: tblite_data @@ -145,7 +147,7 @@ subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite,ceh_guess) real(wp) :: etemp_au,energy real(wp),allocatable :: grad(:,:) logical :: pr - integer :: io + integer :: io,nspin pr = (tblite%ctx%verbosity > 0) @@ -201,8 +203,9 @@ subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite,ceh_guess) !>-- setup wavefunction object etemp_au = etemp*ktoau + nspin = merge(2,1,tblite%spin_polarized) call new_wavefunction(tblite%wfn,mol%nat,tblite%calc%bas%nsh, & - & tblite%calc%bas%nao,1,etemp_au) + & tblite%calc%bas%nao,nspin,etemp_au) #ifdef WITH_GXTB if (tblite%lvl == xtblvl%gxtb) then call sad_guess(mctcmol,tblite%calc,tblite%wfn) @@ -212,12 +215,26 @@ subroutine tblite_setup(mol,chrg,uhf,lvl,etemp,tblite,ceh_guess) call tblite_internal_ceh_guess(mctcmol,tblite) end if +!>--- spin-polarization setup (spGFN2-xTB etc.) + if (tblite%spin_polarized) then + block + class(container_type),allocatable :: cont + type(spin_polarization),allocatable :: spin + real(wp),allocatable :: wll(:,:,:) + allocate (spin) + call get_spin_constants(wll,mctcmol,tblite%calc%bas) + call new_spin_polarization(spin,mctcmol,wll,tblite%calc%bas%nsh_id) + call move_alloc(spin,cont) + call tblite%calc%push_back(cont) + end block + end if + !>--- for methods with an auxiliary charge model (e.g., gxTB), pre-allocate wfn_aux. !>--- Charges are updated at each singlepoint call (geometry-dependent). #ifdef WITH_GXTB if (allocated(tblite%calc%charge_model)) then - if (allocated(tblite%wfn_aux)) deallocate(tblite%wfn_aux) - allocate(tblite%wfn_aux) + if (allocated(tblite%wfn_aux)) deallocate (tblite%wfn_aux) + allocate (tblite%wfn_aux) call new_wavefunction(tblite%wfn_aux,mctcmol%nat,tblite%calc%bas%nsh,0,1,0.0_wp,.true.) end if #endif @@ -338,10 +355,6 @@ subroutine tblite_add_solv(mol,chrg,uhf,tblite,smodel,solvent) return end select - !str = 'tblite> WARNING: implicit solvation energies are not entirely '// & - !&'consistent with the xtb implementation.' - !if (pr) call tblite%ctx%message(str) - !>--- add electrostatic (Born part) to calculator call new_solvation(solv,mctcmol,solv_inp,error,method) if (allocated(error)) then @@ -445,8 +458,8 @@ subroutine tblite_singlepoint(mol,chrg,uhf,tblite,energy,gradient,iostatus) & energy,gradient,sigma,verbosity,results=tblite%res) end if #else - call xtb_singlepoint(tblite%ctx,mctcmol,tblite%calc,tblite%wfn,tblite%accuracy, & - & energy,gradient,sigma,verbosity,results=tblite%res) + call xtb_singlepoint(tblite%ctx,mctcmol,tblite%calc,tblite%wfn,tblite%accuracy, & + & energy,gradient,sigma,verbosity,results=tblite%res) #endif case (xtblvl%ceh) call ceh_singlepoint(tblite%ctx,tblite%calc,mctcmol,tblite%wfn, & @@ -756,19 +769,19 @@ subroutine tblite_quick_ceh_q(mol,q,chrg,uhf,pr,prch) integer :: verbosity,uhf_loc logical :: pr_loc real(wp),parameter :: etemp_guess_au = 4000.0_wp*ktoau - real(wp),parameter :: accuracy=1.0_wp + real(wp),parameter :: accuracy = 1.0_wp pr_loc = .false. - if(present(pr)) pr_loc = pr + if (present(pr)) pr_loc = pr verbosity = 0 - if(pr_loc) verbosity = 2 + if (pr_loc) verbosity = 2 - allocate(q(mol%nat), source=0.0_wp) + allocate (q(mol%nat),source=0.0_wp) #ifdef WITH_TBLITE uhf_loc = 0 if (present(uhf)) uhf_loc = uhf - if(present(prch)) ctx%unit=prch + if (present(prch)) ctx%unit = prch !>--- make an mctcmol object from mol call tblite_mol2mol(mol,chrg,uhf_loc,mctcmol) @@ -802,6 +815,31 @@ subroutine tblite_quick_ceh_q(mol,q,chrg,uhf,pr,prch) #endif end subroutine tblite_quick_ceh_q +! ══════════════════════════════════════════════════════════════════════════════ +#ifdef WITH_TBLITE + subroutine get_spin_constants(wll,mol,bas) + use tblite_basis_type,only:basis_type + use tblite_data_spin,only:get_spin_constant + real(wp),allocatable,intent(out) :: wll(:,:,:) + type(structure_type),intent(in) :: mol + type(basis_type),intent(in) :: bas + + integer :: izp,ish,jsh,il,jl + + allocate (wll(bas%nsh,bas%nsh,mol%nid),source=0.0_wp) + + do izp = 1,mol%nid + do ish = 1,bas%nsh_id(izp) + il = bas%cgto(ish,izp)%ang + do jsh = 1,bas%nsh_id(izp) + jl = bas%cgto(jsh,izp)%ang + wll(jsh,ish,izp) = get_spin_constant(jl,il,mol%num(izp)) + end do + end do + end do + end subroutine get_spin_constants +#endif + !========================================================================================! !========================================================================================! end module tblite_api From bbf448e05e8561d14c90e8321d830625777ee0ca Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 3 May 2026 12:52:41 +0200 Subject: [PATCH 303/374] spin-polarization flags/toml --- src/calculator/api_engrad.f90 | 4 ++-- src/calculator/api_helpers.F90 | 1 + src/classes.f90 | 2 ++ src/confparse.f90 | 4 ++++ src/legacy_wrappers.f90 | 9 +++++++++ src/parsing/parse_calcdata.f90 | 2 ++ 6 files changed, 20 insertions(+), 2 deletions(-) diff --git a/src/calculator/api_engrad.f90 b/src/calculator/api_engrad.f90 index 1cb9e37d..08b6ad35 100644 --- a/src/calculator/api_engrad.f90 +++ b/src/calculator/api_engrad.f90 @@ -499,7 +499,7 @@ subroutine mlip_engrad(mol,calc,energy,grad,iostatus) logical :: ex iostatus = 0 pr = .false. - !$omp critical + !$omp critical !>--- setup system call information if (calc%MPAR%iid == 0) then iid = OMP_GET_THREAD_NUM()+1 @@ -513,7 +513,7 @@ subroutine mlip_engrad(mol,calc,energy,grad,iostatus) !>--- do the engrad call call initsignal() - call mlip_engrad_core(mol,calc%MPAR,energy,grad,iostatus, & + call mlip_engrad_core(mol,calc%MPAR,energy,grad,iostatus, & & charge=calc%chrg,spin=calc%uhf) if (iostatus /= 0) return diff --git a/src/calculator/api_helpers.F90 b/src/calculator/api_helpers.F90 index 0b1eccc7..b268b938 100644 --- a/src/calculator/api_helpers.F90 +++ b/src/calculator/api_helpers.F90 @@ -155,6 +155,7 @@ subroutine tblite_init(calc,loadnew) if(allocated(calc%tbliteparam))then calc%tblite%paramfile = calc%tbliteparam endif + calc%tblite%spin_polarized = calc%spin_polarized loadnew = .true. end if if (calc%apiclean) loadnew = .true. diff --git a/src/classes.f90 b/src/classes.f90 index 1ea43440..36d43d77 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -565,6 +565,7 @@ module crest_data logical :: allowrestart = .true. !> allow restart in crest algos? logical :: better = .false. !> found a better conformer and restart in V1 logical :: ceh_guess = .false. !> use CEH guess in tblite or gfnff, if available + logical :: spin_polarized = .false. !> enable spin-polarized calculations logical :: cff !> CFF used in QCG-energy calculation logical :: cluster = .false. !> perform a clustering analysis logical :: checktopo = .true. !> perform topolgy check in CREGEN @@ -1376,6 +1377,7 @@ subroutine systemdata_copy(self,src) self%allowrestart = src%allowrestart self%better = src%better self%ceh_guess = src%ceh_guess + self%spin_polarized = src%spin_polarized self%cff = src%cff self%cluster = src%cluster self%checktopo = src%checktopo diff --git a/src/confparse.f90 b/src/confparse.f90 index 7d3b0409..4c091169 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -1534,6 +1534,10 @@ subroutine parseflags(env,arg,nra) processedarg(i) = .true. env%ceh_guess = .true. + case ('-spin-polarized','-spinpol') + processedarg(i) = .true. + env%spin_polarized = .true. + case ('-dscal','-dispscal','-dscal_global','-dispscal_global') processedarg(i) = .true. env%cts%dispscal_md = .true. diff --git a/src/legacy_wrappers.f90 b/src/legacy_wrappers.f90 index 26433937..159ccea5 100644 --- a/src/legacy_wrappers.f90 +++ b/src/legacy_wrappers.f90 @@ -48,6 +48,7 @@ subroutine env2calc(env,calc,molin) cal%uhf = env%uhf cal%chrg = env%chrg + cal%spin_polarized = env%spin_polarized !>-- obtain WBOs OFF by default cal%rdwbo = .false. cal%rddip = .false. @@ -90,6 +91,7 @@ subroutine env2calc(env,calc,molin) cal2%chrg = cal%chrg cal2%uhf = cal%uhf + cal2%spin_polarized = cal%spin_polarized if (env%gbsa) then cal2%solvmodel = cal%solvmodel cal2%solvent = cal%solvent @@ -190,6 +192,13 @@ subroutine env2calc_modify(env) end do end if + !>--- pass on spin-polarized flag + if (env%spin_polarized) then + do i = 1,env%calc%ncalculations + env%calc%calcs(i)%spin_polarized = env%spin_polarized + end do + end if + !>--- ONIOM setup from toml file if (allocated(env%ONIOM_toml)) then if (.not.allocated(env%calc%ONIOM)) allocate (env%calc%ONIOM) diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index 9dced63d..a2143784 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -509,6 +509,8 @@ subroutine parse_setting_auto(env,job,kv,rd) job%getlmocent = kv%value_b case ('ceh_guess') job%ceh_guess = kv%value_b + case ('spin_polarized') + job%spin_polarized = kv%value_b case default !>--- keyword not correctly read/found From 406aadd7c2608988f6b6abb36402bac9c140aacd Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 3 May 2026 13:01:15 +0200 Subject: [PATCH 304/374] spin-polarization, some printouts --- src/calculator/calc_type.f90 | 4 ++++ src/printouts.f90 | 1 + 2 files changed, 5 insertions(+) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 01471d5d..0c46b868 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -1431,6 +1431,10 @@ subroutine calculation_settings_info(self,iunit) write (atmp,*) 'UHF parameter' write (iunit,fmt1) atmp,self%uhf end if + if (self%id == jobtype%tblite .and. self%spin_polarized) then + write (atmp,*) 'Spin-polarization' + write (iunit,fmt3) atmp,'yes' + end if if (allocated(self%solvmodel)) then write (atmp,*) 'Solvation model' diff --git a/src/printouts.f90 b/src/printouts.f90 index 61f45980..7a4fba80 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -238,6 +238,7 @@ subroutine confscript_morehelp(flag) call help_opt('-T ',fw,'Number of CPU threads (or read from OMP_NUM_THREADS)') call help_opt('-chrg ',fw,"Molecular charge") call help_opt('-uhf ',fw,'Unpaired electrons (N_alpha - N_beta)') + call help_opt('-spin-polarized',fw,'Spin-polarized treatment (open-shell, tblite only)') call help_opt('-g/-gbsa ',fw,'GBSA implicit solvation') call help_opt('-alpb ',fw,'ALPB implicit solvation') call help_opt('-efield ',fw,'External electric field in V/Ang along x, y, z') From 023e25f83d5e60798294c42c67a34c0bbad79c86 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 3 May 2026 13:13:48 +0200 Subject: [PATCH 305/374] unit test for spin-polarization --- test/test_tblite.F90 | 47 +++++++++++++++++++++++++++++++++++++++++++- test/testmol.f90 | 29 +++++++++++++++++++++++++++ 2 files changed, 75 insertions(+), 1 deletion(-) diff --git a/test/test_tblite.F90 b/test/test_tblite.F90 index fecefd74..97916c5f 100644 --- a/test/test_tblite.F90 +++ b/test/test_tblite.F90 @@ -33,7 +33,8 @@ subroutine collect_tblite(testsuite) new_unittest("GFN2-xTB singlepoint (anion) ",test_gfn2_sp_anion), & new_unittest("GFN2-xTB singlepoint (S1) ",test_gfn2_sp_uhf), & new_unittest("GFN2-xTB singlepoint (ALPB) ",test_gfn2_sp_alpb), & - new_unittest("GFN1-xTB singlepoint ",test_gfn1_sp) & + new_unittest("GFN1-xTB singlepoint ",test_gfn1_sp), & + new_unittest("GFN2-xTB spin-polarized ",test_gfn2_sp_spinpol) & #else new_unittest("Compiled tblite subproject",test_compiled_tblite,should_fail=.true.) & #endif @@ -409,6 +410,50 @@ subroutine test_gfn1_sp(error) deallocate (grad) end subroutine test_gfn1_sp +!========================================================================================! + + subroutine test_gfn2_sp_spinpol(error) + type(error_type),allocatable,intent(out) :: error + type(calcdata) :: calc1,calc2 + type(calculation_settings) :: sett + type(coord) :: mol + real(wp) :: e_nospin,e_spinpol + real(wp),allocatable :: grad(:,:) + integer :: io + + call get_testmol('co_cnx6',mol) + allocate (grad(3,mol%nat)) + + !> without spin-polarization + call sett%create('gfn2') + sett%chrg = mol%chrg + sett%uhf = mol%uhf + sett%spin_polarized = .false. + call calc1%add(sett) + call engrad(mol,calc1,e_nospin,grad,io) + call check(error,io,0) + if (allocated(error)) return + + !> with spin-polarization + call sett%create('gfn2') + sett%chrg = mol%chrg + sett%uhf = mol%uhf + sett%spin_polarized = .true. + call calc2%add(sett) + call engrad(mol,calc2,e_spinpol,grad,io) + call check(error,io,0) + if (allocated(error)) return + + !> spin-polarization must lower the energy of this open-shell complex + if (e_spinpol >= e_nospin) then + call test_failed(error,"spin-polarized energy is not lower than non-spin-polarized energy") + write(*,'(" e_nospin =",f20.10)') e_nospin + write(*,'(" e_spinpol =",f20.10)') e_spinpol + end if + + deallocate (grad) + end subroutine test_gfn2_sp_spinpol + !========================================================================================! !========================================================================================! end module test_tblite diff --git a/test/testmol.f90 b/test/testmol.f90 index 452fef0c..375fce14 100644 --- a/test/testmol.f90 +++ b/test/testmol.f90 @@ -53,6 +53,27 @@ module crest_testmol !&> +!&< + !> [Co(CN)6]^3- , charge=-3, high-spin uhf=4 + integer,parameter :: co_cnx6_nat = 13 + integer,parameter :: co_cnx6_at(co_cnx6_nat) = [27, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7] + real(wp),parameter :: co_cnx6_xyz(3,co_cnx6_nat) = reshape([ & + & 3.68215_wp, 0.36449_wp, -0.34727_wp, & ! Co + & 3.43538_wp, 3.94151_wp, -0.25682_wp, & ! C + & 7.25036_wp, 0.61671_wp, -0.60916_wp, & ! C + & 0.11412_wp, 0.11336_wp, -0.08221_wp, & ! C + & 3.92717_wp, -3.21273_wp, -0.43437_wp, & ! C + & 3.95079_wp, 0.29514_wp, 3.22866_wp, & ! C + & 3.41157_wp, 0.43202_wp, -3.92302_wp, & ! C + & 9.43883_wp, 0.76955_wp, -0.77211_wp, & ! N + & -2.07440_wp, -0.04270_wp, 0.07811_wp, & ! N + & 3.28682_wp, 6.13570_wp, -0.20479_wp, & ! N + & 4.07811_wp, -5.40669_wp, -0.48872_wp, & ! N + & 4.11534_wp, 0.25224_wp, 5.42203_wp, & ! N + & 3.24974_wp, 0.47806_wp, -6.12230_wp & ! N + & ], shape(co_cnx6_xyz)) +!&> + !&< !> distorted methane integer,parameter :: cytosine_nat = 13 @@ -80,6 +101,14 @@ subroutine get_testmol(name,mol) character(len=*),intent(in) :: name type(coord),intent(out) :: mol select case (name) + case ('co_cnx6') + mol%nat = co_cnx6_nat + allocate (mol%at(mol%nat)) + mol%at(:) = co_cnx6_at(:) + allocate (mol%xyz(3,mol%nat)) + mol%xyz(:,:) = co_cnx6_xyz(:,:) + mol%chrg = -3 + mol%uhf = 4 case ('methane') mol%nat = methane_nat allocate (mol%at(mol%nat)) From 1a6e936af342329011d817a430189e4ee11eb1cd Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 3 May 2026 15:51:02 +0200 Subject: [PATCH 306/374] Repair entropy mode functionality --- src/algos/parallel.f90 | 36 +++++++++---- src/confparse.f90 | 11 +++- src/entropy/thermocalc.f90 | 107 ++++++++----------------------------- src/sorting/cregen.f90 | 2 + 4 files changed, 59 insertions(+), 97 deletions(-) diff --git a/src/algos/parallel.f90 b/src/algos/parallel.f90 index a736f76e..26fb2221 100644 --- a/src/algos/parallel.f90 +++ b/src/algos/parallel.f90 @@ -70,7 +70,7 @@ end subroutine crest_oloop end interface interface - subroutine crest_hessloop(env,nat,nall,at,xyz,eread) + subroutine crest_hessloop(env,nat,nall,at,xyz,eread,gt_out,stot_out) use crest_parameters,only:wp,stdout,sep use crest_calculator use omp_lib @@ -84,6 +84,8 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread) integer,intent(in) :: at(nat) real(wp),intent(inout) :: eread(nall) integer,intent(in) :: nat,nall + real(wp),optional,intent(out) :: gt_out(:,:) !> (nall, nt_full) + real(wp),optional,intent(out) :: stot_out(:,:) !> (nall, nt_full) end subroutine crest_hessloop end interface @@ -255,12 +257,14 @@ end subroutine crest_sploop !> Routines for concurrent singlepoint evaluations !========================================================================================! !========================================================================================! -subroutine crest_hessloop(env,nat,nall,at,xyz,eread) +subroutine crest_hessloop(env,nat,nall,at,xyz,eread,gt_out,stot_out) !*************************************************************** -!* subroutine crest_sploop -!* This subroutine performs concurrent singlepoint evaluations -!* for the given ensemble. Input eread is overwritten -!* xyz must be in Bohrs +!* subroutine crest_hessloop +!* Concurrent numerical Hessian evaluations for an ensemble. +!* Input eread is overwritten with Gibbs free energies. +!* xyz must be in Bohrs. +!* Optional gt_out/stot_out return G and S at all temperatures +!* from env%thermo; requires pre-allocated (nall,nt) arrays. !* !* Parallelization is enabled using numhess1 (OpenMP-compatible). !* @@ -279,6 +283,8 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread) integer,intent(in) :: at(nat) real(wp),intent(inout) :: eread(nall) integer,intent(in) :: nat,nall + real(wp),optional,intent(out) :: gt_out(:,:) !> (nall, nt_full) + real(wp),optional,intent(out) :: stot_out(:,:) !> (nall, nt_full) type(coord),allocatable :: mols(:) integer :: i,j,k,l,io,ich,ich2,c,z,job_id,zcopy,nat3 @@ -349,9 +355,17 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread) if (.not.allocated(env%thermo%temps)) then call env%thermo%get_temps() end if - nt = 1 - allocate (temps(nt,T),et(nt,T),ht(nt,T),gt(nt,T),stot(nt,T),source=0.0_wp) - temps = env%thermo%get_close_rt(nrt) + if (present(gt_out)) then + nt = env%thermo%ntemps + allocate (temps(nt,T),et(nt,T),ht(nt,T),gt(nt,T),stot(nt,T),source=0.0_wp) + do i = 1,T + temps(:,i) = env%thermo%temps(:) + end do + else + nt = 1 + allocate (temps(nt,T),et(nt,T),ht(nt,T),gt(nt,T),stot(nt,T),source=0.0_wp) + temps = env%thermo%get_close_rt(nrt) + end if !>--- printout directions and timer initialization pr = .false. !> stdout printout @@ -418,14 +432,14 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread) !$omp critical if (io == 0) then - !>--- successful optimization (io==0) c = c+1 eread(zcopy) = gt(1,job) + if (present(gt_out)) gt_out(zcopy,:) = gt(:,job) + if (present(stot_out)) stot_out(zcopy,:) = stot(:,job) else eread(zcopy) = big end if k = k+1 - !>--- print progress call crest_oloop_pr_progress(env,nall,k) !$omp end critical !$omp end task diff --git a/src/confparse.f90 b/src/confparse.f90 index 4c091169..6cf0e8f2 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -390,6 +390,13 @@ subroutine parseflags(env,arg,nra) write (stdout,'(2x,a,'' : iMTD-GC'')') trim(arg(i)) exit + case ('-entropy') !> sMTD-iMTD+entropy extrapol + processedarg(i) = .false. !> THIS IS IMPORTANT, WE READ FURTHER ENTROPY SETTINGS BELOW + env%crestver = crest_imtd + env%iterativeV2 = .true. + write (stdout,'(2x,a,'' : iMTD-sMTD + entropy extrapolation'')') trim(arg(i)) + exit + case ('-v4') !> sMTD-iMTD (same as entropy mode) processedarg(i) = .true. env%crestver = crest_imtd2 @@ -907,7 +914,7 @@ subroutine parseflags(env,arg,nra) env%inputcoords = ctmp env%ensemblename = ctmp end if - if (argument == '-sort' .and. nra >= i+2) then + if (argument == '-sort'.and.nra >= i+2) then ctmp = arg2 if (ctmp(1:1) .ne. '-') then processedarg(i+2) = .true. @@ -979,7 +986,7 @@ subroutine parseflags(env,arg,nra) processedarg(1) = .true. end if !> For sorting runtypes, fall back to the input file if no ensemble was set explicitly - if (env%crestver == crest_sorting .and. len_trim(env%ensemblename) == 0) then + if (env%crestver == crest_sorting.and.len_trim(env%ensemblename) == 0) then env%ensemblename = env%inputcoords end if diff --git a/src/entropy/thermocalc.f90 b/src/entropy/thermocalc.f90 index cca2f51c..95c863fc 100644 --- a/src/entropy/thermocalc.f90 +++ b/src/entropy/thermocalc.f90 @@ -433,7 +433,6 @@ subroutine thermo_wrap_new(env,pr,nat,at,xyz,dirname, & if (len_trim(dirname) > 0) subdir = .true. !>-- create a calculation object locally, modify calc dir -!$omp critical calctmp = env%calc calctmp%pr_energies = .false. !> never do that! mol%nat = nat @@ -452,7 +451,6 @@ subroutine thermo_wrap_new(env,pr,nat,at,xyz,dirname, & nfreq = 3*nat allocate (freq(nfreq),source=0.0_wp) allocate (hess(nfreq,nfreq),source=0.0_wp) -!$omp end critical !>-- numerical Hessian @@ -469,27 +467,20 @@ subroutine thermo_wrap_new(env,pr,nat,at,xyz,dirname, & end if !>-- project and get frequencies -!$omp critical - !>-- Projects and mass-weights the Hessian call prj_mw_hess(mol%nat,mol%at,nfreq,mol%xyz,hess) - !>-- Computes the Frequencies call frequencies(mol%nat,mol%at,mol%xyz,nfreq,hess,freq,io) -!$omp end critical !>--- get thermodynamics -!$omp critical et = 0.0_wp ht = 0.0_wp gt = 0.0_wp stot = 0.0_wp - ithr = env%thermo%ithr fscal = env%thermo%fscal sthr = env%thermo%sthr call calcthermo(mol%nat,mol%at,mol%xyz,freq,pr,ithr,fscal,sthr, & & nt,temps,et,ht,gt,stot,stdout,emodel=env%thermo%emodel) deallocate (hess,freq) -!$omp end critical call initsignal() return end subroutine thermo_wrap_new @@ -501,10 +492,11 @@ subroutine calcSrrhoav(env,ensname) !******************************************************* !* Calculate S_RRHO averages for a given ensemlbe !******************************************************* - use crest_parameters + use crest_parameters,only:wp,stdout,autokcal,aatoau use crest_data use strucrd use iomod + use parallel_interface implicit none !> INPUT type(systemdata) :: env @@ -530,24 +522,17 @@ subroutine calcSrrhoav(env,ensname) real(wp) :: psum,emin,sdum real(wp) :: quick_rmsd,rmsdval integer :: eloc,ploc - logical :: avbhess - integer :: nt real(wp),allocatable :: temps(:) real(wp),allocatable :: et(:) real(wp),allocatable :: ht(:) real(wp),allocatable :: gt(:) - real(wp),allocatable :: stot(:) - real(wp),allocatable :: c0(:,:) real(wp),allocatable :: sref(:) character(len=64) :: atmp - integer :: i,j,k,ich,io,popf,ii,T,Tn + integer :: i,j,k,ich,io,popf,ii logical :: ex - logical :: niceprint - real(wp) :: percent - character(len=52) :: bar - integer :: ncalc,vz,nlimit,nav - character(len=512) :: thispath,tmppath + integer :: ncalc,nlimit,nav + character(len=512) :: tmppath real(wp),parameter :: Tref = 298.15 !> room temperature is reference real(wp),parameter :: kcal = autokcal @@ -642,70 +627,24 @@ subroutine calcSrrhoav(env,ensname) !>--- calculate Hessians for ncalc lowest structures allocate (gatt(nall,nt),satt(nall,nt),source=0.0_wp) - io = makedir('HESSIANS') - call getcwd(thispath) - inquire (file='gfnff_topo',exist=ex) - - call chdir('HESSIANS') - if (env%legacy) then - if (env%gfnver == '--gff'.and.ex) then - call getcwd(tmppath) - io = sylnk(trim(thispath)//'/'//'gfnff_topo',trim(tmppath)//'/'//'gfnff_topo') - end if - if (index(env%fixfile,'none selected') .eq. 0) then - io = sylnk(trim(thispath)//'/'//env%fixfile,trim(tmppath)//'/'//env%fixfile) - end if - end if - - k = 0 - niceprint = env%niceprint - -!>--- OMP stuff - call new_ompautoset(env,'auto',ncalc,T,Tn) - -!>--- the parallel loop - avbhess = env%thermo%avbhess - write (stdout,'(1x,a,i0,a)') 'Running ',ncalc,' calculations ...' - call crest_oloop_pr_progress(env,ncalc,0) -!$omp parallel & -!$omp shared( vz,tmppath,ncalc,percent,k,bar,niceprint) & -!$omp shared( env,nat,at,xyz,c0,et,ht,gt,stot,temps,nt,gatt,satt,avbhess,pindex ) -!$omp single - allocate (et(nt),ht(nt),gt(nt),stot(nt)) - allocate (c0(3,nat)) - do i = 1,ncalc - call initsignal() - vz = pindex(i) !> restore index - !$omp task firstprivate( vz ) private( tmppath,et,ht,gt,stot,c0 ) - call initsignal() - !$omp critical - write (tmppath,'(''hess'',i0)') vz - c0(1:3,1:nat) = xyz(1:3,1:nat,vz) - !$omp end critical - - call thermo_wrap(env,.false.,nat,at,c0,tmppath, & - & nt,temps,et,ht,gt,stot,avbhess) - - !$omp critical - gatt(vz,1:nt) = gt(1:nt) - satt(vz,1:nt) = stot(1:nt) - !$omp end critical - if (.not.env%keepModef) call rmrf(trim(tmppath)) - - !$omp critical - k = k+1 - call crest_oloop_pr_progress(env,ncalc,k) - !$omp end critical - !$omp end task - end do - deallocate (c0) - deallocate (stot,gt,ht,et) -!$omp taskwait -!$omp end single -!$omp end parallel - call crest_oloop_pr_progress(env,ncalc,-1) - call chdir(thispath) - if (.not.env%keepModef) call rmrf('HESSIANS') +! ── build coordinate subset and call parallel Hessian loop ─────── + block + integer :: ii + real(wp),allocatable :: xyz_calc(:,:,:),er_calc(:) + real(wp),allocatable :: gt_out(:,:),stot_out(:,:) + allocate (xyz_calc(3,nat,ncalc),er_calc(ncalc)) + allocate (gt_out(ncalc,nt),stot_out(ncalc,nt)) + do ii = 1,ncalc + xyz_calc(:,:,ii) = xyz(:,:,pindex(ii))*aatoau !> Å → Bohr + end do + write (stdout,'(1x,a,i0,a)') 'Running ',ncalc,' calculations ...' + call crest_hessloop(env,nat,ncalc,at,xyz_calc,er_calc,gt_out,stot_out) + do ii = 1,ncalc + gatt(pindex(ii),1:nt) = gt_out(ii,1:nt) + satt(pindex(ii),1:nt) = stot_out(ii,1:nt) + end do + deallocate (xyz_calc,er_calc,gt_out,stot_out) + end block !========================================================================================! !>--- process the calculated free energies and entropies into accurate populations diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 7ea8fe1d..a43f7c23 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -219,12 +219,14 @@ subroutine newcregen(env,quickset,infile,structurelist) !>--- write new file with ALL remaining structures if (newfile) then + structures(:)%wrextxyz = .false. call cregen_file_wr(env,oname,structures) !>--- track ensemble for restart ! call trackensemble(oname,nat,nall,at,xyz,comments) end if !>--- write a file containing only conformers (no rotamers) if (conffile) then + structures(:)%wrextxyz = .false. call cregen_conffile(env,cname,structures,ng,degen) end if if (saveelow) then From 0f380e973f892d4a47f5ef07eb59f945c72bdfcf Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 3 May 2026 16:57:16 +0200 Subject: [PATCH 307/374] small modification to extxyz, energy and froces units --- src/molecule/io.f90 | 31 ++++++++++++++++++++++--- src/molecule/type.f90 | 41 +++++++++++++++++++++------------- src/molecule/type_ensemble.f90 | 17 +++++++++----- src/sorting/cregen.f90 | 2 -- 4 files changed, 65 insertions(+), 26 deletions(-) diff --git a/src/molecule/io.f90 b/src/molecule/io.f90 index 87ea7e52..f5e87d82 100644 --- a/src/molecule/io.f90 +++ b/src/molecule/io.f90 @@ -1006,7 +1006,8 @@ end subroutine wrsdfV3000_channel ! ────────────────────────────────────────────────────────────────────────────── - subroutine read_extxyz_frame(iunit,ext_sigs,ext_props,nat,energy,lat,success) + subroutine read_extxyz_frame(iunit,ext_sigs,ext_props,nat,energy,lat,success, & + & energy_units,forces_units) implicit none ! Formal Arguments @@ -1017,6 +1018,8 @@ subroutine read_extxyz_frame(iunit,ext_sigs,ext_props,nat,energy,lat,success) real(wp),intent(out) :: energy real(wp),intent(out),allocatable :: lat(:,:) logical,intent(out) :: success + character(len=32),intent(out),optional :: energy_units + character(len=32),intent(out),optional :: forces_units ! Internal variables integer :: i,ierr,total_fields @@ -1049,6 +1052,19 @@ subroutine read_extxyz_frame(iunit,ext_sigs,ext_props,nat,energy,lat,success) call get_key_value(comment_line,"energy",val_str,found,case_sensitive=.false.) if (found) read (val_str,*) energy + ! Extract optional unit specifications (defaults: eV for energy, eV/Ang for forces) + ! Values are stored lowercase so callers can do case-insensitive comparisons. + if (present(energy_units)) then + energy_units = 'ev' + call get_key_value(comment_line,"energy_units",val_str,found,case_sensitive=.false.) + if (found) energy_units = lowerCase(trim(adjustl(val_str))) + end if + if (present(forces_units)) then + forces_units = 'ev/ang' + call get_key_value(comment_line,"forces_units",val_str,found,case_sensitive=.false.) + if (found) forces_units = lowerCase(trim(adjustl(val_str))) + end if + ! Extract Lattice call get_key_value(comment_line,"lattice",val_str,found,case_sensitive=.false.) if (found) then @@ -1167,11 +1183,15 @@ subroutine get_xyz_from_ext(ext_props,xyz) end do end subroutine get_xyz_from_ext - subroutine get_grad_from_ext(ext_props,grad) + subroutine get_grad_from_ext(ext_props,grad,forces_units) implicit none type(extxyz_properties) :: ext_props real(wp),intent(out),allocatable :: grad(:,:) + character(len=32),intent(in),optional :: forces_units integer :: ii,jj,nat + character(len=32) :: units_loc + units_loc = 'eV/Ang' + if (present(forces_units)) units_loc = forces_units do ii = 1,ext_props%n_props associate (prop => ext_props%props(ii)) select case (trim(prop%signat%name)) @@ -1179,7 +1199,12 @@ subroutine get_grad_from_ext(ext_props,grad) nat = prop%natoms allocate (grad(3,nat),source=0.0_wp) do jj = 1,nat - grad(:,jj) = prop%R(:,jj)*(-autoaa/autoeV) + select case (trim(units_loc)) + case ('ha/bohr','hartree/bohr','au') + grad(:,jj) = prop%R(:,jj)*(-1.0_wp) ! forces → gradient (sign flip only) + case default ! 'ev/ang' and anything unrecognised + grad(:,jj) = prop%R(:,jj)*(-autoaa/autoeV) + end select end do end select end associate diff --git a/src/molecule/type.f90 b/src/molecule/type.f90 index d60fbd58..4b15ff00 100644 --- a/src/molecule/type.f90 +++ b/src/molecule/type.f90 @@ -181,6 +181,7 @@ subroutine opencoord(self,fname) integer :: i,j,k,ich,io,iunit logical :: ex,success real(wp) :: en + character(len=32) :: eu,fu type(extxyz_signatures) :: ext_sigs type(extxyz_properties) :: ext_props @@ -205,13 +206,19 @@ subroutine opencoord(self,fname) case (coordtype%extxyz) open (newunit=iunit,file=fname) - call read_extxyz_frame(iunit,ext_sigs,ext_props,nat,en,lat,success) + call read_extxyz_frame(iunit,ext_sigs,ext_props,nat,en,lat,success, & + & energy_units=eu,forces_units=fu) close (iunit) if (success) then - en = en / autoeV + select case (trim(eu)) + case ('hartree','ha','au') + ! energy already in Hartree, no conversion needed + case default !> 'ev' and anything unrecognised + en = en/autoeV + end select call get_at_from_ext(ext_props,at) - call get_xyz_from_ext(ext_props,xyz) !> converts AA to Bohr - call get_grad_from_ext(ext_props,grad) !> converts eV/AA to Ha/Bohr + call get_xyz_from_ext(ext_props,xyz) + call get_grad_from_ext(ext_props,grad,forces_units=fu) if (allocated(lat)) call move_alloc(lat,self%lat) if (allocated(grad)) call move_alloc(grad,self%gradient) end if @@ -396,30 +403,31 @@ end subroutine coord_cn_to_bond ! ══════════════════════════════════════════════════════════════════════════════ subroutine write_extxyz(self,iunit) -!************************************************************************ -!* Write an extended xyz file from the coord object. * -!* By convention energies will be in eV for extxyz! * -!* By convention (and if present), forces will be in eV/Ang for extxyz! * -!************************************************************************ +!*********************************************************************** +!* Write an extended xyz file from the coord object. * +!* Energies are written in Hartree, tagged with energy_units=Hartree. * +!* Forces (if present) are written in Ha/Bohr, tagged forces_units. * +!*********************************************************************** class(coord) :: self - integer,intent(in) :: iunit !> assue the unit is open for writing + integer,intent(in) :: iunit !> assume the unit is open for writing character(len=200) :: atmp - real(wp) :: eeV integer :: ii - real(wp),parameter :: grad2force = -autoeV/autoaa !> print number of atoms write (iunit,'(i10)') self%nat !> construct ext comment line bit by bit - eeV = self%energy*autoeV - write (atmp,'(f20.10)') eeV + write (atmp,'(f20.10)') self%energy write (iunit,'(a,a)',advance='no') trim('energy='//adjustl(atmp)),' ' + write (iunit,'(a)',advance='no') 'energy_units=Hartree ' if (allocated(self%lat)) then write (iunit,'(a)',advance='no') 'Lattice="' write (iunit,'(9f15.8)',advance='no') reshape(self%lat, [9]) - write (iunit,'(a)',advance='no') '" pbc="T T T"' + write (iunit,'(a)',advance='no') '" pbc="T T T" ' + end if + if (allocated(self%gradient)) then + write (iunit,'(a)',advance='no') 'forces_units=Ha/Bohr ' end if if (allocated(self%extxyz)) then call assemble_properties_tag(self%extxyz,atmp) @@ -437,8 +445,9 @@ subroutine write_extxyz(self,iunit) call exit(1) else if (allocated(self%gradient)) then do ii = 1,self%nat + !> positions in Ang, forces in Ha/Bohr (sign flip: forces = -gradient) write (iunit,'(1x,a2,1x,6f20.10)') & - & i2e(self%at(ii)),self%xyz(1:3,ii)*autoaa,self%gradient(1:3,ii)*grad2force + & i2e(self%at(ii)),self%xyz(1:3,ii)*autoaa,self%gradient(1:3,ii)*(-1.0_wp) end do else do ii = 1,self%nat diff --git a/src/molecule/type_ensemble.f90 b/src/molecule/type_ensemble.f90 index fd9a8abf..9b7734c3 100644 --- a/src/molecule/type_ensemble.f90 +++ b/src/molecule/type_ensemble.f90 @@ -433,7 +433,8 @@ subroutine rdensemble_coord_type(fname,nall,structures) type(extxyz_properties) :: ext_props real(wp),allocatable :: exyz(:,:),egrd(:,:),lat(:,:) integer,allocatable :: eat(:) - reaL(wp) :: energy + real(wp) :: energy + character(len=32) :: eu,fu is_extxyz = sgrep(fname,'Properties=',casesensitive=.false.) @@ -446,12 +447,18 @@ subroutine rdensemble_coord_type(fname,nall,structures) !>-- extended xyz case open (newunit=iunit,file=trim(fname)) do ii = 1,nall - call read_extxyz_frame(iunit,ext_sigs,ext_props,nat,energy,lat,success) + call read_extxyz_frame(iunit,ext_sigs,ext_props,nat,energy,lat,success, & + & energy_units=eu,forces_units=fu) if (success) then - energy = energy / autoeV + select case (trim(eu)) + case ('hartree','ha','au') + ! energy already in Hartree, no conversion needed + case default !> 'ev' and anything unrecognised + energy = energy/autoeV + end select call get_at_from_ext(ext_props,eat) - call get_xyz_from_ext(ext_props,exyz) !> converts AA to Bohr - call get_grad_from_ext(ext_props,egrd) !> converts eV/AA to Ha/Bohr + call get_xyz_from_ext(ext_props,exyz) + call get_grad_from_ext(ext_props,egrd,forces_units=fu) if (allocated(eat)) call move_alloc(eat,structures(ii)%at) if(allocated(exyz)) call move_alloc(exyz,structures(ii)%xyz) if (allocated(lat)) call move_alloc(lat,structures(ii)%lat) diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index a43f7c23..7ea8fe1d 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -219,14 +219,12 @@ subroutine newcregen(env,quickset,infile,structurelist) !>--- write new file with ALL remaining structures if (newfile) then - structures(:)%wrextxyz = .false. call cregen_file_wr(env,oname,structures) !>--- track ensemble for restart ! call trackensemble(oname,nat,nall,at,xyz,comments) end if !>--- write a file containing only conformers (no rotamers) if (conffile) then - structures(:)%wrextxyz = .false. call cregen_conffile(env,cname,structures,ng,degen) end if if (saveelow) then From 84b85bd1172c253254ea51ee558dcc9249e2647c Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 3 May 2026 17:06:18 +0200 Subject: [PATCH 308/374] prepare global setting for output units in extxyz --- src/molecule/parameters.f90 | 3 +++ src/molecule/type.f90 | 49 ++++++++++++++++++++++++---------- src/parsing/parse_maindata.f90 | 3 +++ 3 files changed, 41 insertions(+), 14 deletions(-) diff --git a/src/molecule/parameters.f90 b/src/molecule/parameters.f90 index 7386aa5f..8cb7afb0 100644 --- a/src/molecule/parameters.f90 +++ b/src/molecule/parameters.f90 @@ -31,6 +31,9 @@ module molecule_parameters real(wp),parameter,public :: autokcal = 627.509541_wp real(wp),parameter,public :: autoeV = 27.211324570273_wp +!>--- global extxyz output unit preference (mutable, set at runtime via TOML) + character(len=32),public :: extxyz_units_global = 'hartree' + !>-- filetypes as integers type ,private:: enum_coordtype integer :: unknown = 0 diff --git a/src/molecule/type.f90 b/src/molecule/type.f90 index 4b15ff00..1d0f82cf 100644 --- a/src/molecule/type.f90 +++ b/src/molecule/type.f90 @@ -403,31 +403,44 @@ end subroutine coord_cn_to_bond ! ══════════════════════════════════════════════════════════════════════════════ subroutine write_extxyz(self,iunit) -!*********************************************************************** -!* Write an extended xyz file from the coord object. * -!* Energies are written in Hartree, tagged with energy_units=Hartree. * -!* Forces (if present) are written in Ha/Bohr, tagged forces_units. * -!*********************************************************************** +!************************************************************************* +!* Write an extended xyz file from the coord object. * +!* Output units are controlled by the module variable extxyz_units_global* +!* (default 'Hartree'). Set to 'eV' to use eV/Ang conventions instead. * +!************************************************************************* class(coord) :: self integer,intent(in) :: iunit !> assume the unit is open for writing character(len=200) :: atmp integer :: ii + logical :: use_hartree + + use_hartree = (trim(extxyz_units_global) .ne. 'ev') !> print number of atoms write (iunit,'(i10)') self%nat !> construct ext comment line bit by bit - write (atmp,'(f20.10)') self%energy - write (iunit,'(a,a)',advance='no') trim('energy='//adjustl(atmp)),' ' - write (iunit,'(a)',advance='no') 'energy_units=Hartree ' + if (use_hartree) then + write (atmp,'(f20.10)') self%energy + write (iunit,'(a,a)',advance='no') trim('energy='//adjustl(atmp)),' ' + write (iunit,'(a)',advance='no') 'energy_units=Hartree ' + else + write (atmp,'(f20.10)') self%energy*autoeV + write (iunit,'(a,a)',advance='no') trim('energy='//adjustl(atmp)),' ' + write (iunit,'(a)',advance='no') 'energy_units=eV ' + end if if (allocated(self%lat)) then write (iunit,'(a)',advance='no') 'Lattice="' write (iunit,'(9f15.8)',advance='no') reshape(self%lat, [9]) write (iunit,'(a)',advance='no') '" pbc="T T T" ' end if if (allocated(self%gradient)) then - write (iunit,'(a)',advance='no') 'forces_units=Ha/Bohr ' + if (use_hartree) then + write (iunit,'(a)',advance='no') 'forces_units=Ha/Bohr ' + else + write (iunit,'(a)',advance='no') 'forces_units=eV/Ang ' + end if end if if (allocated(self%extxyz)) then call assemble_properties_tag(self%extxyz,atmp) @@ -444,11 +457,19 @@ subroutine write_extxyz(self,iunit) write (stdout,*) '**ERROR** This extxyz write function is TODO' call exit(1) else if (allocated(self%gradient)) then - do ii = 1,self%nat - !> positions in Ang, forces in Ha/Bohr (sign flip: forces = -gradient) - write (iunit,'(1x,a2,1x,6f20.10)') & - & i2e(self%at(ii)),self%xyz(1:3,ii)*autoaa,self%gradient(1:3,ii)*(-1.0_wp) - end do + if (use_hartree) then + do ii = 1,self%nat + !> positions in Ang, forces in Ha/Bohr (sign flip: forces = -gradient) + write (iunit,'(1x,a2,1x,6f20.10)') & + & i2e(self%at(ii)),self%xyz(1:3,ii)*autoaa,self%gradient(1:3,ii)*(-1.0_wp) + end do + else + do ii = 1,self%nat + !> positions in Ang, forces in eV/Ang + write (iunit,'(1x,a2,1x,6f20.10)') & + & i2e(self%at(ii)),self%xyz(1:3,ii)*autoaa,self%gradient(1:3,ii)*(-autoeV/autoaa) + end do + end if else do ii = 1,self%nat write (iunit,'(1x,a2,1x,3f20.10)') i2e(self%at(ii)),self%xyz(1:3,ii)*autoaa diff --git a/src/parsing/parse_maindata.f90 b/src/parsing/parse_maindata.f90 index 962138f7..652b7248 100644 --- a/src/parsing/parse_maindata.f90 +++ b/src/parsing/parse_maindata.f90 @@ -28,6 +28,7 @@ module parse_maindata use crest_data use crest_restartlog use strucrd,only:coord + use molecule_parameters,only:extxyz_units_global !> modules used for parsing the root_object use parse_keyvalue,only:keyvalue,valuetypes use parse_block,only:datablock @@ -284,6 +285,8 @@ subroutine parse_main_c(env,key,val,rd) case ('watlist','wat') env%potatlist = val env%wallsetup = .true. + case ('extxyz_units') + extxyz_units_global = trim(val) case default rd = .false. end select From 29c270a00aafe9a2ee0e03828d3c7b3e90e631fd Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 5 May 2026 22:03:10 +0200 Subject: [PATCH 309/374] Working on restart logic --- src/algos/parallel.f90 | 22 -- src/algos/search_conformers.f90 | 60 ++- src/algos/search_entropy.f90 | 63 ++- src/crest_main.f90 | 2 - src/legacy_algos/confscript2_misc.f90 | 3 - src/parsing/parse_maindata.f90 | 5 - src/restartlog.f90 | 531 ++++++++------------------ src/sigterm.F90 | 8 +- src/sorting/cregen.f90 | 6 +- 9 files changed, 263 insertions(+), 437 deletions(-) diff --git a/src/algos/parallel.f90 b/src/algos/parallel.f90 index 26fb2221..13bf7c6d 100644 --- a/src/algos/parallel.f90 +++ b/src/algos/parallel.f90 @@ -57,7 +57,6 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) use strucrd use optimize_module use iomod,only:makedir,directory_exist,remove - use crest_restartlog,only:trackrestart,restart_write_dummy implicit none type(systemdata),target,intent(inout) :: env real(wp),intent(inout) :: xyz(3,nat,nall) @@ -501,7 +500,6 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) use strucrd use optimize_module use iomod,only:makedir,directory_exist,remove - use crest_restartlog,only:trackrestart,restart_write_dummy implicit none type(systemdata),target,intent(inout) :: env real(wp),intent(inout) :: xyz(3,nat,nall) @@ -526,12 +524,6 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) integer :: T,Tn !> threads and threads per core logical :: nested -!>--- decide wether to skip this call - if (trackrestart(env)) then - call restart_write_dummy(ensemblefile) - return - end if - !>--- check which calc to use if (present(customcalc)) then mycalc => customcalc @@ -767,7 +759,6 @@ subroutine crest_search_multimd(env,mol,mddats,nsim) use dynamics_module use iomod,only:makedir,directory_exist,remove use omp_lib - use crest_restartlog,only:trackrestart,restart_write_dummy implicit none type(systemdata),intent(inout) :: env type(mddata) :: mddats(nsim) @@ -787,12 +778,6 @@ subroutine crest_search_multimd(env,mol,mddats,nsim) real(wp),allocatable :: grdtmp(:,:) type(timer) :: profiler !===========================================================! -!>--- decide wether to skip this call - if (trackrestart(env)) then - call restart_write_dummy('crest_dynamics.trj.xyz') - return - end if - !>--- check if we have any MD & calculation settings allocated if (.not.env%mddat%requested) then write (stdout,*) 'MD requested, but no MD settings present.' @@ -1076,7 +1061,6 @@ subroutine crest_search_multimd2(env,mols,mddats,nsim) use shake_module use iomod,only:makedir,directory_exist,remove use omp_lib - use crest_restartlog,only:trackrestart,restart_write_dummy implicit none !> INPUT type(systemdata),intent(inout) :: env @@ -1095,12 +1079,6 @@ subroutine crest_search_multimd2(env,mols,mddats,nsim) integer :: vz,job,thread_id type(timer) :: profiler !===========================================================! -!>--- decide wether to skip this call - if (trackrestart(env)) then - call restart_write_dummy('crest_dynamics.trj.xyz') - return - end if - !>--- check if we have any MD & calculation settings allocated if (.not.env%mddat%requested) then write (stdout,*) 'MD requested, but no MD settings present.' diff --git a/src/algos/search_conformers.f90 b/src/algos/search_conformers.f90 index df5fc133..54b28f69 100644 --- a/src/algos/search_conformers.f90 +++ b/src/algos/search_conformers.f90 @@ -34,6 +34,7 @@ subroutine crest_search_imtdgc(env,tim) use iomod use utilities use cregen_interface + use crest_restartlog implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim @@ -59,6 +60,9 @@ subroutine crest_search_imtdgc(env,tim) character(len=80) :: atmp,btmp,str logical :: multilevel(6) logical :: start,lower +!===========================================================! + type(restart_data) :: rdat + logical :: do_restart,skip_mtdloop,firstiter !===========================================================! !>--- printout header write (stdout,*) @@ -67,6 +71,19 @@ subroutine crest_search_imtdgc(env,tim) write (stdout,'(10x,"┕",49("━"),"┙")') write (stdout,*) +! ── restart detection ───────────────────────────────────────────── + do_restart = .false. + skip_mtdloop = .false. + if (env%allowrestart .and. restart_file_exists()) then + call read_restart_log(rdat) + if (rdat%runtype == crest_imtd .and. rdat%stage /= 'done') then + do_restart = .true. + call print_restart_info(rdat) + !> skip entire mtdloop only when CREGEN collection already ran + skip_mtdloop = (rdat%stage == 'post_collect') + end if + end if + !===========================================================! !>--- setup call env%ref%to(mol) @@ -95,9 +112,20 @@ subroutine crest_search_imtdgc(env,tim) !>--- Start mainloop env%nreset = 0 start = .true. +! ── apply restart state ─────────────────────────────────────────── + if (do_restart) then + env%nreset = rdat%main_iter + env%elowest = rdat%elowest + env%eprivious = rdat%eprivious + env%nmetadyn = rdat%nmetadyn + start = .false. + end if MAINLOOP: do call printiter - if (.not.start) then + if (do_restart) then +!>--- restart: preserve .cre_*.xyz files, skip cleanup + continue + else if (.not.start) then !>--- clean Dir for new iterations, but leave iteration backup files call clean_V2i env%nreset = env%nreset+1 @@ -106,9 +134,13 @@ subroutine crest_search_imtdgc(env,tim) call V2cleanup(.false.) end if !===========================================================! -!>--- Meta-dynamics loop +!>--- Meta-dynamics loop (skipped on restart to use existing .cre_*.xyz) + if (.not.skip_mtdloop) then mtdloop: do i = 1,env%Maxrestart +! ── restart: skip already-completed MTD iterations ──────────────── + if (do_restart .and. i <= rdat%mtd_iter) cycle mtdloop + write (stdout,*) write (stdout,'(1x,a)') '------------------------------' write (stdout,'(1x,a,i0)') 'Meta-Dynamics Iteration ',i @@ -144,8 +176,9 @@ subroutine crest_search_imtdgc(env,tim) call rename('cregen.out.tmp',btmp) !=========================================================! -!>--- cleanup after first iteration and prepare next - if (i .eq. 1.and.start) then +!>--- cleanup and state update after first iteration (before checkpoint) + firstiter = (i .eq. 1 .and. start) + if (firstiter) then start = .false. !>-- obtain a first lowest energy as reference env%eprivious = env%elowest @@ -156,9 +189,12 @@ subroutine crest_search_imtdgc(env,tim) end if !>-- the cleanup call clean_V2i -!>-- and always do two cycles of MTDs - cycle mtdloop end if +!>--- checkpoint after this MTD iteration (nmetadyn already updated above) + call write_restart_log(crest_imtd,'mtd_loop',env%nreset,i, & + & env%nmetadyn,env%elowest,env%eprivious,trim(str)) +!>-- always do two cycles of MTDs + if (firstiter) cycle mtdloop !=========================================================! !>--- Check for lowest energy call elowcheck(lower,env) @@ -166,6 +202,9 @@ subroutine crest_search_imtdgc(env,tim) exit mtdloop end if end do mtdloop + end if !> end skip_mtdloop guard + skip_mtdloop = .false. + do_restart = .false. !=========================================================! !>--- collect all ensembles from mtdloop and merge write (stdout,*) @@ -177,6 +216,9 @@ subroutine crest_search_imtdgc(env,tim) call collectcre(env) call newcregen(env,0) call checkname_xyz(crefile,atmp,btmp) +!>--- checkpoint after collection and CREGEN + call write_restart_log(crest_imtd,'post_collect',env%nreset,0, & + & env%nmetadyn,env%elowest,env%eprivious,trim(atmp)) !>--- remaining number of structures call remaining_in(atmp,env%ewin,nallout) @@ -242,6 +284,11 @@ subroutine crest_search_imtdgc(env,tim) call tim%stop(3) if (env%iostatus_meta .ne. 0) return +!==========================================================! +!>--- checkpoint: run is complete + call write_restart_log(crest_imtd,'done',env%nreset,0, & + & env%nmetadyn,env%elowest,env%eprivious,conformerfile) + !==========================================================! !>--- final ensemble sorting ! call newcregen(env,0) @@ -304,7 +351,6 @@ subroutine crest_multilevel_oloop(env,ensnam,multilevel_in) use strucrd use optimize_module use utilities - use crest_restartlog use parallel_interface implicit none type(systemdata) :: env diff --git a/src/algos/search_entropy.f90 b/src/algos/search_entropy.f90 index a2b62afb..7aaf667f 100644 --- a/src/algos/search_entropy.f90 +++ b/src/algos/search_entropy.f90 @@ -32,6 +32,7 @@ subroutine crest_search_entropy(env,tim) use iomod use utilities use cregen_interface + use crest_restartlog implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim @@ -61,6 +62,9 @@ subroutine crest_search_entropy(env,tim) !> Entropy algo variables logical :: stopiter,fail integer :: bref,dum,eit,eit2 +!===========================================================! + type(restart_data) :: rdat + logical :: do_restart,skip_mtdloop,firstiter !===========================================================! !>--- printout header write (stdout,*) @@ -73,6 +77,19 @@ subroutine crest_search_entropy(env,tim) write (stdout,'(1x,a)') '• J.Gorges, S.Grimme, A.Hansen, P.Pracht, PCCP, 2022,24, 12249-12259.' write (stdout,*) +! ── restart detection ───────────────────────────────────────────── + do_restart = .false. + skip_mtdloop = .false. + if (env%allowrestart .and. restart_file_exists()) then + call read_restart_log(rdat) + if (rdat%runtype == crest_imtd2 .and. rdat%stage /= 'done') then + do_restart = .true. + call print_restart_info(rdat) + !> skip entire mtdloop only when CREGEN collection already ran + skip_mtdloop = (rdat%stage == 'post_collect') + end if + end if + !===========================================================! !>--- setup call env%ref%to(mol) @@ -80,7 +97,7 @@ subroutine crest_search_entropy(env,tim) call mol%append(stdout) write (stdout,*) -!>--- saftey terminations +!>--- saftey terminations call crest_sampling_skip(env,doreturn) if (doreturn) return @@ -92,7 +109,7 @@ subroutine crest_search_entropy(env,tim) if (env%performMTD) then !>--- (optional) calculate a short 1ps test MTD to check settings call tim%start(1,'Trial metadynamics (MTD)') - call trialmd(env) + call trialmd(env) call tim%stop(1) if(env%iostatus_meta .ne. 0) return end if @@ -101,9 +118,20 @@ subroutine crest_search_entropy(env,tim) !>--- Start mainloop env%nreset = 0 start = .true. +! ── apply restart state ─────────────────────────────────────────── + if (do_restart) then + env%nreset = rdat%main_iter + env%elowest = rdat%elowest + env%eprivious = rdat%eprivious + env%nmetadyn = rdat%nmetadyn + start = .false. + end if MAINLOOP: do call printiter - if (.not.start) then + if (do_restart) then +!>--- restart: preserve .cre_*.xyz files, skip cleanup + continue + else if (.not.start) then !>--- clean Dir for new iterations, but leave iteration backup files call clean_V2i env%nreset = env%nreset+1 @@ -112,9 +140,13 @@ subroutine crest_search_entropy(env,tim) call V2cleanup(.false.) end if !===========================================================! -!>--- Meta-dynamics loop +!>--- Meta-dynamics loop (skipped on restart to use existing .cre_*.xyz) + if (.not.skip_mtdloop) then mtdloop: do i = 1,env%Maxrestart +! ── restart: skip already-completed MTD iterations ──────────────── + if (do_restart .and. i <= rdat%mtd_iter) cycle mtdloop + write (stdout,*) write (stdout,'(1x,a)') '------------------------------' write (stdout,'(1x,a,i0)') 'Meta-Dynamics Iteration ',i @@ -150,8 +182,9 @@ subroutine crest_search_entropy(env,tim) call rename('cregen.out.tmp',btmp) !=========================================================! -!>--- cleanup after first iteration and prepare next - if (i .eq. 1.and.start) then +!>--- cleanup and state update after first iteration (before checkpoint) + firstiter = (i .eq. 1 .and. start) + if (firstiter) then start = .false. !>-- obtain a first lowest energy as reference env%eprivious = env%elowest @@ -162,9 +195,12 @@ subroutine crest_search_entropy(env,tim) end if !>-- the cleanup call clean_V2i -!>-- and always do two cycles of MTDs - cycle mtdloop end if +!>--- checkpoint after this MTD iteration (nmetadyn already updated above) + call write_restart_log(crest_imtd2,'mtd_loop',env%nreset,i, & + & env%nmetadyn,env%elowest,env%eprivious,trim(str)) +!>-- always do two cycles of MTDs + if (firstiter) cycle mtdloop !=========================================================! !>--- Check for lowest energy call elowcheck(lower,env) @@ -172,6 +208,9 @@ subroutine crest_search_entropy(env,tim) exit mtdloop end if end do mtdloop + end if !> end skip_mtdloop guard + skip_mtdloop = .false. + do_restart = .false. !=========================================================! !>--- collect all ensembles from mtdloop and merge write (stdout,*) @@ -183,6 +222,9 @@ subroutine crest_search_entropy(env,tim) call collectcre(env) call newcregen(env,0) call checkname_xyz(crefile,atmp,btmp) +!>--- checkpoint after collection and CREGEN + call write_restart_log(crest_imtd2,'post_collect',env%nreset,0, & + & env%nmetadyn,env%elowest,env%eprivious,trim(atmp)) !>--- remaining number of structures call remaining_in(atmp,env%ewin,nallout) @@ -261,6 +303,11 @@ subroutine crest_search_entropy(env,tim) exit MAINLOOP end do MAINLOOP +!==========================================================! +!>--- checkpoint: run is complete + call write_restart_log(crest_imtd2,'done',env%nreset,0, & + & env%nmetadyn,env%elowest,env%eprivious,conformerfile) + !==========================================================! !>--- print CREGEN results and clean up Directory a bit write (stdout,'(/)') diff --git a/src/crest_main.f90 b/src/crest_main.f90 index 41aca294..bd9abc82 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -25,7 +25,6 @@ program CREST use crest_parameters !> Datatypes and constants use crest_data !> module for the main data storage (imports systemdata and timer) use crest_calculator - use crest_restartlog USE,INTRINSIC :: IEEE_EXCEPTIONS implicit none type(systemdata) :: env !> MAIN STORAGE OF SYSTEM DATA @@ -59,7 +58,6 @@ program CREST end do call parseflags(env,arg,args) deallocate (arg) - call restart_save_env(env) !=========================================================================================! !> scratch dir handling diff --git a/src/legacy_algos/confscript2_misc.f90 b/src/legacy_algos/confscript2_misc.f90 index b954896b..4e6353a5 100644 --- a/src/legacy_algos/confscript2_misc.f90 +++ b/src/legacy_algos/confscript2_misc.f90 @@ -990,7 +990,6 @@ end subroutine append_INPUT_to subroutine remaining_in(filename,ewin,nall) use crest_data use crest_parameters - use crest_restartlog, only: restart_write_dummy use strucrd,only:rdensembleparam,rdensemble implicit none integer :: nall @@ -998,8 +997,6 @@ subroutine remaining_in(filename,ewin,nall) character(len=*) :: filename integer :: k,nat,io - call restart_write_dummy(trim(filename)) - open (newunit=k,file=trim(filename)) read (k,*,iostat=io) nat if(io/=0)then diff --git a/src/parsing/parse_maindata.f90 b/src/parsing/parse_maindata.f90 index 652b7248..c912443f 100644 --- a/src/parsing/parse_maindata.f90 +++ b/src/parsing/parse_maindata.f90 @@ -26,7 +26,6 @@ module parse_maindata use crest_parameters !> modules for data storage in crest use crest_data - use crest_restartlog use strucrd,only:coord use molecule_parameters,only:extxyz_units_global !> modules used for parsing the root_object @@ -308,10 +307,6 @@ subroutine parse_main_bool(env,key,val,rd) env%checktopo = val case ('notopo') env%checktopo = .not.val - case ('restart') - if (val) then - call read_restart(env) - end if case ('multilevelopt') env%multilevelopt = val case ('refine_presort') diff --git a/src/restartlog.f90 b/src/restartlog.f90 index 1128a69d..b46c3fc6 100644 --- a/src/restartlog.f90 +++ b/src/restartlog.f90 @@ -17,417 +17,186 @@ ! along with crest. If not, see . !================================================================================! -!> global variables to keep track of restart +!> Lightweight restart checkpoint for conformational search runtypes. +!> Records only which stage completed and which file was last written — +!> no ensemble data is stored. module crest_restartlog - use crest_parameters - use crest_data - use miscdata, only: PSE - use iomod, only: command + use crest_parameters,only:wp,stdout implicit none private - !logical,parameter :: debug = .true. - logical,parameter :: debug = .false. - logical,parameter :: saveensembles = .true. - -!>--- tracking variables - integer :: restart_tracker = 0 - integer :: restart_goal = 0 - - logical,allocatable :: last_processed(:) - character(len=300) :: last_dumped - - !> a backup of the crest envrionment - type(systemdata),allocatable :: restart_env - - !> backup of the last processed ensemble - character(len=300) :: last_file - integer :: last_nat = 0 - integer :: last_nall = 0 - integer,allocatable :: last_at(:) - real(wp),allocatable :: last_xyz(:,:,:) - character(len=128),allocatable :: last_comments(:) - -!>--- routines/functions - public :: trackrestart - public :: restart_save_env - public :: trackensemble - interface trackensemble - module procedure :: trackensemble_comments - module procedure :: trackensemble_energy - end interface trackensemble - public :: restart_write_dummy - - public :: dump_restart,read_restart + character(len=*),parameter,public :: restart_file = 'crest.restart' + + !> All state needed to resume a conformational search. + type,public :: restart_data + integer :: version = 1 + integer :: runtype = 0 !> crestver (crest_imtd=2 or crest_imtd2=22) + integer :: main_iter = 0 !> env%nreset at checkpoint + integer :: mtd_iter = 0 !> last completed MTD iteration index + integer :: nmetadyn = 0 !> env%nmetadyn (trimmed after first MTD pass) + character(len=64) :: stage = 'none' + character(len=512) :: last_file = '' !> last CREGEN-sorted file written + real(wp) :: elowest = 0.0_wp + real(wp) :: eprivious = 0.0_wp + end type restart_data + + public :: write_restart_log + public :: read_restart_log + public :: restart_file_exists + public :: print_restart_info !========================================================================================! !========================================================================================! contains !> MODULE PROCEDURES START HERE !========================================================================================! !========================================================================================! -!> Tracking routines to be called within the algos - function trackrestart(env) result(skip) -!**************************************** -!* This function is to be called both -!* to increment the restart tracker, and -!* to check if a step needs to be skiped -!**************************************** + logical function restart_file_exists() +!************************************* +!* Returns .true. if crest.restart +!* exists in the current directory. +!************************************* implicit none - logical :: skip - type(systemdata),intent(in),optional :: env - skip = .false. - return - - restart_tracker = restart_tracker+1 - if (debug) write (stdout,*) '%%% RESTART_TRACKER =',restart_tracker - - if (restart_tracker < restart_goal) skip = .true. - if (.not.skip.and.present(env)) then - call restart_save_env(env) - call dump_restart() - end if - if(restart_tracker == restart_goal-1)then - if (debug) write (stdout,*) '%%% RESTART_RESTORE %%%' - call restore_ensemble() - endif - end function trackrestart - - - subroutine trackensemble_comments(fname,nat,nall,at,xyz,comments) -!******************************************************* -!* This subroutine decides wether to track the ensemble -!* Typically, this routine is called in CREGEN -!******************************************************* - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: nat,nall - integer,intent(in) :: at(nat) - real(wp),intent(in) :: xyz(3,nat,nall) - character(len=*),intent(in) :: comments(nall) - - if (restart_tracker > restart_goal)then - call restart_save_ensemble(fname,nat,nall,at,xyz,comments) - if (debug) write (stdout,*) '%%% RESTART_ENSEMBLE = ',trim(fname) - endif - end subroutine trackensemble_comments - - subroutine trackensemble_energy(fname,nat,nall,at,xyz,eread) -!******************************************************* -!* This subroutine decides wether to track the ensemble -!* Typically, this routine is called in CREGEN -!******************************************************* - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: nat,nall - integer,intent(in) :: at(nat) - real(wp),intent(in) :: xyz(3,nat,nall) - real(wp),intent(in) :: eread(nall) - character(len=50),allocatable :: comments(:) - integer :: i - if (restart_tracker > restart_goal)then - allocate(comments(nall)) - do i=1,nall - write(comments(i),*) eread(i) - enddo - call restart_save_ensemble(fname,nat,nall,at,xyz,comments) - deallocate(comments) - if (debug) write (stdout,*) '%%% RESTART_ENSEMBLE = ',trim(last_file) - endif - end subroutine trackensemble_energy - + inquire(file=restart_file,exist=restart_file_exists) + end function restart_file_exists - subroutine restart_write_dummy(fname) -!******************************************************* -!* This subroutine produces a placeholder file with -!* only one structure -!******************************************************* - implicit none - character(len=*),intent(in) :: fname - integer :: i,ich - if (restart_tracker < restart_goal-1)then - if(.not.debug) write (stdout,'(a,a)') 'CREST_RESTART> writing DUMMY file ',trim(fname) - open(newunit=ich, file=trim(fname)) - write(ich,*) last_nat - write(ich,*) trim(last_comments(1)) - do i=1,last_nat - write(ich,'(a2,3f20.10)') PSE(last_at(i)),last_xyz(1:3,i,1) - enddo - close(ich) - if (debug) write (stdout,*) '%%% RESTART_DUMMY = ',trim(fname) - endif - end subroutine restart_write_dummy - - - subroutine restore_ensemble() -!******************************************************* -!* This subroutine produces a placeholder file with -!* only one structure -!******************************************************* - implicit none - integer :: i,ich,j,k - character(len=:),allocatable :: fname - character(len=:),allocatable :: atmp - !if(index(last_file,crefile).ne.0)then - ! call command('rm -f '//crefile//'* 2>/dev/null') - ! fname = crefile//'_0.xyz' - !else - fname=trim(last_file) - !endif - - if(.not.debug)then - atmp = 'CREST_RESTART> RESTORING file '//trim(fname) - k = len_trim(atmp)+2 - write (stdout,'(a,/,a,/,a)') repeat(':',k),trim(atmp),repeat(':',k) - endif - open(newunit=ich, file=trim(fname)) - do j=1,last_nall - write(ich,*) last_nat - write(ich,*) trim(last_comments(j)) - do i=1,last_nat - write(ich,'(a2,3f20.10)') PSE(last_at(i)),last_xyz(1:3,i,j) - enddo - enddo - close(ich) - if (debug) write (stdout,*) '%%% RESTORE_ENSEMBLE = ',trim(fname) - end subroutine restore_ensemble - - - - - -!========================================================================================! !========================================================================================! -!> DUMP to binary routines - subroutine dump_restart() + subroutine write_restart_log(runtype,stage,main_iter,mtd_iter,nmetadyn, & + & elowest,eprivious,last_file_in) +!************************************************************* +!* Write a text-based checkpoint to crest.restart. +!* Called after each MTD iteration and after collectcre. +!* +!* Arguments: +!* runtype - crestver constant (crest_imtd or crest_imtd2) +!* stage - stage label: 'mtd_loop', 'post_collect', 'done' +!* main_iter - env%nreset (MAINLOOP iteration counter) +!* mtd_iter - last completed MTD iteration (0 for post-loop stages) +!* nmetadyn - env%nmetadyn (may differ from initial after first pass) +!* elowest - current lowest energy +!* eprivious - previous lowest energy +!* last_file_in - last CREGEN-sorted file written to disk +!************************************************************* implicit none - integer :: ich,i,j,k,l - character(len=250) :: atmp - if (debug) write (stdout,*) '%%% RESTART DEBUG dump summary' - - !> DO NOT OVERWRITE IF WE HAVEN'T REACHED THE PREVIOUS RESTART ENTRY POINT - if( restart_goal .eq. 0 ) return - if( restart_tracker < restart_goal) return - - open (newunit=ich,file='crest.restart',status='replace',form='unformatted') - - write (ich) restart_tracker - if (debug) write (stdout,*) '%%% RESTART_TRACKER =',restart_tracker - - if (allocated(restart_env)) then - atmp = restart_env%cmd - write (ich) atmp - if (debug) write (stdout,*) '%%% cmd: ',trim(atmp) - - atmp = restart_env%inputcoords - write (ich) atmp - if (debug) write (stdout,*) '%%% inputcoords: ',trim(atmp) - - write (ich) restart_env%eprivious - if (debug) write (stdout,*) '%%% eprivious: ',restart_env%eprivious - - write (ich) restart_env%elowest - if (debug) write (stdout,*) '%%% elowest: ',restart_env%elowest - - j = restart_env%ref%nat - write(ich) j - if (debug) write (stdout,*) '%%% ref natoms: ', j - do i=1,j - write(ich) restart_env%ref%at(i) - enddo - do i=1,j - write(ich) restart_env%ref%xyz(1:3,i) - enddo - + integer,intent(in) :: runtype,main_iter,mtd_iter,nmetadyn + character(len=*),intent(in) :: stage,last_file_in + real(wp),intent(in) :: elowest,eprivious + integer :: ich,io + open(newunit=ich,file=restart_file,status='replace',iostat=io) + if (io /= 0) then + write(stdout,'(a)') '**WARNING** could not write crest.restart' + return end if - - call dump_last_ensemble(ich) - if (debug) write (stdout,'(1x,a,a)') '%%% ensemble: ',trim(last_file) - if (debug) write (stdout,*) '%%% nall: ',last_nall - - close (ich) - end subroutine dump_restart - - subroutine dump_last_ensemble(ich) -!****************************************** -!* dump last saved ensemble as binary data -!****************************************** - implicit none - integer, intent(in) :: ich - integer :: nat,nall,i,j,k,l - write(ich) last_file - nat = last_nat - write(ich) nat - nall = last_nall - write(ich) nall - if(allocated(last_comments) .and. allocated(last_xyz))then - do k=1,nat - write(ich) last_at(k) - enddo - do i=1,nall - write(ich) last_comments(i) - do j=1,nat - write(ich) last_xyz(1:3,j,i) - enddo - enddo - endif - end subroutine dump_last_ensemble + write(ich,'(a)') '# CREST restart checkpoint - do not edit manually' + write(ich,'(a,1x,i0)') 'version', 1 + write(ich,'(a,1x,i0)') 'runtype', runtype + write(ich,'(a,1x,i0)') 'main_iter', main_iter + write(ich,'(a,1x,i0)') 'mtd_iter', mtd_iter + write(ich,'(a,1x,i0)') 'nmetadyn', nmetadyn + write(ich,'(a,1x,a)') 'stage', trim(stage) + write(ich,'(a,1x,a)') 'last_file', trim(last_file_in) + write(ich,'(a,1x,f25.15)') 'elowest', elowest + write(ich,'(a,1x,f25.15)') 'eprivious', eprivious + close(ich) + end subroutine write_restart_log !========================================================================================! -!========================================================================================! -!> read from binary subroutines - subroutine read_restart(env) + subroutine read_restart_log(rdat) +!************************************************************* +!* Read crest.restart into a restart_data object. +!* Unknown keys are silently ignored for forward compatibility. +!* +!* Arguments: +!* rdat - restart_data object to populate +!************************************************************* implicit none - type(systemdata),intent(inout) :: env - integer :: ich,i,j,k,l - character(len=250) :: atmp - real(wp) :: rdum,xyzdum(3) - integer :: idum - logical :: ex - integer,allocatable :: at(:) - real(wp),allocatable :: xyz(:,:) - inquire(file='crest.restart', exist=ex) - - if(.not.ex)then - write(stderr,'(a)') '**ERROR** while attempting to read crest.restart: file does not exist' - error stop - endif - - open (newunit=ich,file='crest.restart',status='old',form='unformatted') - write(stdout,'(/,a)') repeat(":",80) - write(stdout,'(a)') 'READING crest.restart ...' - write(stdout,'(/,a)') '**WARNING**' - write(stdout,'(1x,a)') "It is a user responsibility to re-use an identical job setup," - write(stdout,'(1x,a)') 'either via cmd or input file. The restart option only tracks' - write(stdout,'(1x,a)') 'structure information and a non-unique restart step ID' - write(stdout,'(a,/)') '**WARNING**' - - - - read (ich) restart_goal - write(stdout,'(1x,a,i0)') 'Target restart step: ',restart_goal - - read (ich) atmp - env%cmd = trim(atmp) - write(stdout,'(1x,a,2a)') 'Previous crest cmd: "',env%cmd,'"' + type(restart_data),intent(out) :: rdat + integer :: ich,io + character(len=512) :: line,key,val + integer :: pos - read (ich) atmp - env%inputcoords = trim(atmp) - write(stdout,'(1x,a,a)') 'Previous coord input file: ',env%inputcoords - - read (ich) env%eprivious - read (ich) env%elowest - write(stdout,'(1x,a,f20.10)') 'Previous lowest energy: ',env%elowest - - read (ich) j - write(stdout,'(1x,a,i0,a)') 'Original input coordinates for ',j,' atoms (Angström, CMA shifted): ' - allocate(at(j)) - do i=1,j - read(ich) at(i) - enddo - allocate(xyz(3,j)) - do i=1,j - read(ich) xyzdum(1:3) - xyz(:,i) = xyzdum(:) - enddo - write(stdout,'(a5,3a16)') 'at','X','Y','Z' - do i=1,j - write(stdout,'(a5,3f16.8)') trim(PSE(at(i))),xyz(1:3,i)*autoaa - enddo - env%ref%nat = j - call move_alloc(at, env%ref%at) - call move_alloc(xyz, env%ref%xyz) - - - call read_last_ensemble(ich) - if(last_nat > 0 .and. last_nall > 0)then - write(stdout,'(1x,a,a)') 'Last processed ensemble file: ',trim(last_file) - write(stdout,'(1x,a,i0)') 'Number of saved structures: ',last_nall - endif - - - close (ich) - write(stdout,'(a)') 'FINISHED READING crest.restart ...' - write(stdout,'(a,/)') repeat(":",80) - !stop - - end subroutine read_restart - - subroutine read_last_ensemble(ich) -!****************************************** -!* dump last saved ensemble as binary data -!****************************************** - implicit none - integer, intent(in) :: ich - integer :: nat,nall,i,j,k,l - read(ich) last_file - read(ich) nat - last_nat = nat - read(ich) nall - last_nall = nall - if(nat > 0 .and. nall > 0) then - allocate(last_at(nat)) - allocate(last_xyz(3,nat,nall)) - allocate(last_comments(nall)) - do k=1,nat - read(ich) last_at(k) - enddo - do i=1,nall - read(ich) last_comments(i) - do j=1,nat - read(ich) last_xyz(1:3,j,i) - enddo - enddo - endif - end subroutine read_last_ensemble + rdat = restart_data() !> initialise with defaults + open(newunit=ich,file=restart_file,status='old',iostat=io) + if (io /= 0) then + write(stdout,'(a)') '**WARNING** could not read crest.restart' + return + end if + do + read(ich,'(a)',iostat=io) line + if (io /= 0) exit + line = adjustl(line) + if (len_trim(line) == 0) cycle + if (line(1:1) == '#') cycle + pos = index(line,' ') + if (pos < 2) cycle + key = line(1:pos-1) + val = adjustl(line(pos+1:)) + select case(trim(key)) + case('version') + read(val,*,iostat=io) rdat%version + case('runtype') + read(val,*,iostat=io) rdat%runtype + case('main_iter') + read(val,*,iostat=io) rdat%main_iter + case('mtd_iter') + read(val,*,iostat=io) rdat%mtd_iter + case('nmetadyn') + read(val,*,iostat=io) rdat%nmetadyn + case('stage') + rdat%stage = trim(val) + case('last_file') + rdat%last_file = trim(val) + case('elowest') + read(val,*,iostat=io) rdat%elowest + case('eprivious') + read(val,*,iostat=io) rdat%eprivious + end select + end do + close(ich) + end subroutine read_restart_log !========================================================================================! -!========================================================================================! -!> some routines to create backup data - subroutine restart_save_env(env) -!************* -!* backup env -!************* + subroutine print_restart_info(rdat) +!***************************************************** +!* Print a summary of the restart checkpoint to stdout. +!***************************************************** implicit none - type(systemdata),intent(in) :: env - if (.not.allocated(restart_env)) then - allocate (restart_env,source=env) + type(restart_data),intent(in) :: rdat + character(len=64) :: rtname + integer :: w + w = 57 + + select case(rdat%runtype) + case(2) + rtname = 'iMTD-GC' + case(22) + rtname = 'sMTD-iMTD (entropy)' + case default + write(rtname,'(a,i0)') 'runtype ',rdat%runtype + end select + + write(stdout,*) + write(stdout,'(1x,a)') repeat(':',w) + write(stdout,'(1x,a,a,a)') ' RESTART DETECTED (',trim(restart_file),')' + write(stdout,'(1x,a,a)') ' runtype : ',trim(rtname) + write(stdout,'(1x,a,a)') ' stage : ',trim(rdat%stage) + if (rdat%stage == 'mtd_loop') then + write(stdout,'(1x,a,i0,a,i0,a)') ' MTD iter : ',rdat%mtd_iter, & + & ' (MAINLOOP ',rdat%main_iter,')' end if - restart_env = env - end subroutine restart_save_env - - - subroutine restart_save_ensemble(fname,nat,nall,at,xyz,comments) -!********************************* -!* backup last processed ensemble -!********************************* - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: nat,nall - integer,intent(in) :: at(nat) - real(wp),intent(in) :: xyz(3,nat,nall) - character(len=*),intent(in) :: comments(nall) - integer :: i - if(.not.saveensembles) return - !> backup of the last processed ensemble - last_file = trim(fname) - last_nat = nat - last_nall = nall - if(.not.allocated(last_at)) allocate(last_at(nat)) - last_at(:) = at(:) - if(allocated(last_xyz)) deallocate(last_xyz) - if(allocated(last_comments)) deallocate(last_comments) - allocate(last_xyz(3,nat,nall)) - allocate(last_comments(nall)) - last_xyz(:,:,:) = xyz(:,:,:) - last_comments(:) = comments(:) - end subroutine restart_save_ensemble + if (len_trim(rdat%last_file) > 0) then + write(stdout,'(1x,a,a)') ' last file: ',trim(rdat%last_file) + end if + write(stdout,'(1x,a,f20.10)') ' elowest : ',rdat%elowest + write(stdout,'(1x,a)') repeat(':',w) + write(stdout,*) + end subroutine print_restart_info !========================================================================================! !========================================================================================! diff --git a/src/sigterm.F90 b/src/sigterm.F90 index 9d4d3551..09823d00 100644 --- a/src/sigterm.F90 +++ b/src/sigterm.F90 @@ -59,7 +59,7 @@ subroutine wsigint() bind(C,name="crest_wsigint") !> Ctrl+C subroutine wsigint() !> Ctrl+C #endif use crest_parameters,only:stderr,stdout - use crest_restartlog,only:dump_restart + use ConfSolv_module integer :: myunit,io write (*,*) @@ -76,7 +76,7 @@ subroutine wsigquit() bind(C,name="crest_wsigquit") !> Ctrl+D subroutine wsigquit() !> Ctrl+D #endif use crest_parameters,only:stderr,stdout - use crest_restartlog,only:dump_restart + use ConfSolv_module integer :: myunit,io write (*,*) @@ -93,7 +93,7 @@ subroutine wsigterm() bind(C,name="crest_wsigterm") !> Recieved by the "kill" pi subroutine wsigterm() !> Recieved by the "kill" pid command #endif use crest_parameters,only:stderr,stdout - use crest_restartlog,only:dump_restart + use ConfSolv_module integer :: io write (stdout,*) @@ -110,7 +110,7 @@ subroutine wsigkill() bind(C,name="crest_wsigkill") subroutine wsigkill() #endif use crest_parameters,only:stderr,stdout - use crest_restartlog,only:dump_restart + use ConfSolv_module integer :: io !call dump_restart() diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 7ea8fe1d..bb620fdf 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -40,7 +40,6 @@ subroutine newcregen(env,quickset,infile,structurelist) !**************************************************************************************** use crest_parameters use crest_data - use crest_restartlog use strucrd use cregen_subroutines implicit none @@ -93,9 +92,6 @@ subroutine newcregen(env,quickset,infile,structurelist) integer :: prch !> the main printout channel logical :: pr1,pr2,pr3,pr4 -!>--- restart skip & tracking - if (trackrestart(env)) return - !====================================================================! !> S E T T I N G S !====================================================================! @@ -372,7 +368,7 @@ subroutine cregen_files(env,fname,oname,cname,simpleset,userinput,ensembleinput, inquire (file=fname,exist=ex) if (.not.ex.and..not.ensembleinput) then - write (stdout,'(a)') 'CREGEN> **WARNING** file ',trim(fname),' does not exist!' + write (stdout,'(a,a,a)') 'CREGEN> **WARNING** file ',trim(fname),' does not exist!' error stop end if From ab02d467ac3c1de4f53f694b4262ea5dc211fc0f Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Tue, 5 May 2026 23:07:20 +0200 Subject: [PATCH 310/374] Update restart logic --- src/algos/search_conformers.f90 | 99 +++++++++++++++++++-------- src/algos/search_entropy.f90 | 117 +++++++++++++++++++++++--------- 2 files changed, 154 insertions(+), 62 deletions(-) diff --git a/src/algos/search_conformers.f90 b/src/algos/search_conformers.f90 index 54b28f69..0e24d617 100644 --- a/src/algos/search_conformers.f90 +++ b/src/algos/search_conformers.f90 @@ -62,7 +62,7 @@ subroutine crest_search_imtdgc(env,tim) logical :: start,lower !===========================================================! type(restart_data) :: rdat - logical :: do_restart,skip_mtdloop,firstiter + logical :: do_restart,skip_mtdloop,skip_collect,firstiter,fex !===========================================================! !>--- printout header write (stdout,*) @@ -74,13 +74,15 @@ subroutine crest_search_imtdgc(env,tim) ! ── restart detection ───────────────────────────────────────────── do_restart = .false. skip_mtdloop = .false. + skip_collect = .false. if (env%allowrestart .and. restart_file_exists()) then call read_restart_log(rdat) if (rdat%runtype == crest_imtd .and. rdat%stage /= 'done') then do_restart = .true. call print_restart_info(rdat) - !> skip entire mtdloop only when CREGEN collection already ran + !> skip entire mtdloop and collectcre only when past the MTD loop skip_mtdloop = (rdat%stage == 'post_collect') + skip_collect = (rdat%stage == 'post_collect') end if end if @@ -138,32 +140,46 @@ subroutine crest_search_imtdgc(env,tim) if (.not.skip_mtdloop) then mtdloop: do i = 1,env%Maxrestart -! ── restart: skip already-completed MTD iterations ──────────────── - if (do_restart .and. i <= rdat%mtd_iter) cycle mtdloop +! ── restart: skip based on stage ────────────────────────────────── + if (do_restart) then + if (rdat%stage == 'mtd_loop' .and. i <= rdat%mtd_iter) cycle mtdloop + if (rdat%stage == 'mtd_trj' .and. i < rdat%mtd_iter) cycle mtdloop + end if write (stdout,*) write (stdout,'(1x,a)') '------------------------------' write (stdout,'(1x,a,i0)') 'Meta-Dynamics Iteration ',i write (stdout,'(1x,a)') '------------------------------' - nsim = -1 !>--- enambles automatic MTD setup in init routines - call crest_search_multimd_init(env,mol,mddat,nsim) - allocate (mddats(nsim),source=mddat) - call crest_search_multimd_init2(env,mddats,nsim) - - call tim%start(2,'Metadynamics (MTD)') - call crest_search_multimd(env,mol,mddats,nsim) - call tim%stop(2) +!==========================================================! +!>--- MTD run (skipped for mtd_trj restart: trajectory already exists) + if (do_restart .and. i == rdat%mtd_iter .and. & + & rdat%stage == 'mtd_trj') then + write (stdout,'(1x,a,i0,a)') 'Restarting iteration ',i, & + & ' from existing trajectory/ensemble' + ensnam = trim(rdat%last_file) + else + nsim = -1 !>--- enambles automatic MTD setup in init routines + call crest_search_multimd_init(env,mol,mddat,nsim) + allocate (mddats(nsim),source=mddat) + call crest_search_multimd_init2(env,mddats,nsim) + + call tim%start(2,'Metadynamics (MTD)') + call crest_search_multimd(env,mol,mddats,nsim) + call tim%stop(2) !>--- a file called crest_dynamics.trj.xyz should have been written - ensnam = 'crest_dynamics.trj.xyz' -!>--- deallocate for next iteration - if (allocated(mddats)) deallocate (mddats) + ensnam = 'crest_dynamics.trj.xyz' + if (allocated(mddats)) deallocate (mddats) +!>--- checkpoint: trajectory ready, optimization about to start + call write_restart_log(crest_imtd,'mtd_trj',env%nreset,i, & + & env%nmetadyn,env%elowest,env%eprivious,ensnam) + end if !==========================================================! !>--- Reoptimization of trajectories call tim%start(3,'Geometry optimization') call optlev_to_multilev(env%optlev,multilevel) - call crest_multilevel_oloop(env,ensnam,multilevel) + call crest_multilevel_oloop(env,ensnam,multilevel,i) call tim%stop(3) if (env%iostatus_meta .ne. 0) return @@ -207,18 +223,32 @@ subroutine crest_search_imtdgc(env,tim) do_restart = .false. !=========================================================! !>--- collect all ensembles from mtdloop and merge - write (stdout,*) - write (stdout,'(''========================================'')') - write (stdout,'('' MTD Simulations done '')') - write (stdout,'(''========================================'')') - write (stdout,'(1x,''Collecting ensmbles.'')') + if (skip_collect) then +!>--- post_collect restart: collectcre already ran, reuse last file + inquire(file=trim(rdat%last_file),exist=fex) + if (.not.fex) then + write (stdout,'(/,a)') '**ERROR** restart ensemble not found: ' & + & //trim(rdat%last_file) + write (stdout,'(a,/)') ' Delete crest.restart and rerun from scratch.' + call creststop(status_safety) + end if + atmp = trim(rdat%last_file) + write (stdout,'(1x,a,a)') 'Restarting from ensemble: ',trim(atmp) + skip_collect = .false. + else + write (stdout,*) + write (stdout,'(''========================================'')') + write (stdout,'('' MTD Simulations done '')') + write (stdout,'(''========================================'')') + write (stdout,'(1x,''Collecting ensmbles.'')') !>-- collecting all ensembles saved as ".cre_*.xyz" - call collectcre(env) - call newcregen(env,0) - call checkname_xyz(crefile,atmp,btmp) + call collectcre(env) + call newcregen(env,0) + call checkname_xyz(crefile,atmp,btmp) !>--- checkpoint after collection and CREGEN - call write_restart_log(crest_imtd,'post_collect',env%nreset,0, & - & env%nmetadyn,env%elowest,env%eprivious,trim(atmp)) + call write_restart_log(crest_imtd,'post_collect',env%nreset,0, & + & env%nmetadyn,env%elowest,env%eprivious,trim(atmp)) + end if !>--- remaining number of structures call remaining_in(atmp,env%ewin,nallout) @@ -335,15 +365,17 @@ subroutine crest_multilevel_wrap(env,ensnam,level) k = max(1,k) multilevel(k) = .true. end select - call crest_multilevel_oloop(env,ensnam,multilevel) + call crest_multilevel_oloop(env,ensnam,multilevel,0) end subroutine crest_multilevel_wrap !========================================================================================! -subroutine crest_multilevel_oloop(env,ensnam,multilevel_in) +subroutine crest_multilevel_oloop(env,ensnam,multilevel_in,mtd_iter_in) !******************************************************* !* multilevel optimization loop. !* construct consecutive optimizations starting with -!* crude thresholds to very tight ones +!* crude thresholds to very tight ones. +!* mtd_iter_in: when > 0, writes a mtd_trj restart +!* checkpoint after each CREGEN step (pass 0 to skip). !******************************************************* use crest_parameters,only:wp,stdout,bohr use crest_data @@ -352,10 +384,12 @@ subroutine crest_multilevel_oloop(env,ensnam,multilevel_in) use optimize_module use utilities use parallel_interface + use crest_restartlog implicit none type(systemdata) :: env character(len=*),intent(in) :: ensnam logical,intent(in) :: multilevel_in(6) + integer,intent(in) :: mtd_iter_in integer :: nat,nall real(wp),allocatable :: eread(:) real(wp),allocatable :: xyz(:,:,:) @@ -463,6 +497,11 @@ end subroutine crest_refine !>--- CREGEN sorting call sort_and_check(env,trim(inpnam)) call checkname_xyz(crefile,inpnam,outnam) +! ── restart checkpoint: intermediate ensemble after this opt. level ── + if (mtd_iter_in > 0) then + call write_restart_log(env%crestver,'mtd_trj',env%nreset, & + & mtd_iter_in,env%nmetadyn,env%elowest,env%eprivious,trim(inpnam)) + end if !>--- check for empty ensemble content (again) call rdensembleparam(trim(inpnam),nat,nall) if (nall .lt. 1) then @@ -686,7 +725,7 @@ subroutine crest_newcross3(env) else multilevel(4) = .true. end if - call crest_multilevel_oloop(env,'confcross.xyz',multilevel) + call crest_multilevel_oloop(env,'confcross.xyz',multilevel,0) if (env%iostatus_meta .ne. 0) return !>-- append optimized crossed structures and original to a single file diff --git a/src/algos/search_entropy.f90 b/src/algos/search_entropy.f90 index 7aaf667f..7c68015e 100644 --- a/src/algos/search_entropy.f90 +++ b/src/algos/search_entropy.f90 @@ -64,7 +64,7 @@ subroutine crest_search_entropy(env,tim) integer :: bref,dum,eit,eit2 !===========================================================! type(restart_data) :: rdat - logical :: do_restart,skip_mtdloop,firstiter + logical :: do_restart,skip_mtdloop,skip_collect,skip_emtdcopy0,firstiter,fex !===========================================================! !>--- printout header write (stdout,*) @@ -80,13 +80,20 @@ subroutine crest_search_entropy(env,tim) ! ── restart detection ───────────────────────────────────────────── do_restart = .false. skip_mtdloop = .false. + skip_collect = .false. + skip_emtdcopy0 = .false. if (env%allowrestart .and. restart_file_exists()) then call read_restart_log(rdat) - if (rdat%runtype == crest_imtd2 .and. rdat%stage /= 'done') then + if (rdat%runtype == env%crestver .and. rdat%stage /= 'done') then do_restart = .true. call print_restart_info(rdat) - !> skip entire mtdloop only when CREGEN collection already ran - skip_mtdloop = (rdat%stage == 'post_collect') + !> skip entire mtdloop and collectcre when past the MTD loop + skip_mtdloop = (rdat%stage == 'post_collect' .or. & + & rdat%stage == 'entropy_smtd') + skip_collect = (rdat%stage == 'post_collect' .or. & + & rdat%stage == 'entropy_smtd') + !> additionally skip emtdcopy(iter=0) when that call already ran + skip_emtdcopy0 = (rdat%stage == 'entropy_smtd') end if end if @@ -144,32 +151,46 @@ subroutine crest_search_entropy(env,tim) if (.not.skip_mtdloop) then mtdloop: do i = 1,env%Maxrestart -! ── restart: skip already-completed MTD iterations ──────────────── - if (do_restart .and. i <= rdat%mtd_iter) cycle mtdloop +! ── restart: skip based on stage ────────────────────────────────── + if (do_restart) then + if (rdat%stage == 'mtd_loop' .and. i <= rdat%mtd_iter) cycle mtdloop + if (rdat%stage == 'mtd_trj' .and. i < rdat%mtd_iter) cycle mtdloop + end if write (stdout,*) write (stdout,'(1x,a)') '------------------------------' write (stdout,'(1x,a,i0)') 'Meta-Dynamics Iteration ',i write (stdout,'(1x,a)') '------------------------------' - nsim = -1 !>--- enambles automatic MTD setup in init routines - call crest_search_multimd_init(env,mol,mddat,nsim) - allocate (mddats(nsim),source=mddat) - call crest_search_multimd_init2(env,mddats,nsim) - - call tim%start(2,'Metadynamics (MTD)') - call crest_search_multimd(env,mol,mddats,nsim) - call tim%stop(2) +!==========================================================! +!>--- MTD run (skipped for mtd_trj restart: trajectory already exists) + if (do_restart .and. i == rdat%mtd_iter .and. & + & rdat%stage == 'mtd_trj') then + write (stdout,'(1x,a,i0,a)') 'Restarting iteration ',i, & + & ' from existing trajectory/ensemble' + ensnam = trim(rdat%last_file) + else + nsim = -1 !>--- enambles automatic MTD setup in init routines + call crest_search_multimd_init(env,mol,mddat,nsim) + allocate (mddats(nsim),source=mddat) + call crest_search_multimd_init2(env,mddats,nsim) + + call tim%start(2,'Metadynamics (MTD)') + call crest_search_multimd(env,mol,mddats,nsim) + call tim%stop(2) !>--- a file called crest_dynamics.trj.xyz should have been written - ensnam = 'crest_dynamics.trj.xyz' -!>--- deallocate for next iteration - if (allocated(mddats)) deallocate (mddats) + ensnam = 'crest_dynamics.trj.xyz' + if (allocated(mddats)) deallocate (mddats) +!>--- checkpoint: trajectory ready, optimization about to start + call write_restart_log(env%crestver,'mtd_trj',env%nreset,i, & + & env%nmetadyn,env%elowest,env%eprivious,ensnam) + end if !==========================================================! !>--- Reoptimization of trajectories call tim%start(3,'Geometry optimization') call optlev_to_multilev(env%optlev,multilevel) - call crest_multilevel_oloop(env,ensnam,multilevel) + call crest_multilevel_oloop(env,ensnam,multilevel,i) call tim%stop(3) if(env%iostatus_meta .ne. 0 ) return @@ -197,7 +218,7 @@ subroutine crest_search_entropy(env,tim) call clean_V2i end if !>--- checkpoint after this MTD iteration (nmetadyn already updated above) - call write_restart_log(crest_imtd2,'mtd_loop',env%nreset,i, & + call write_restart_log(env%crestver,'mtd_loop',env%nreset,i, & & env%nmetadyn,env%elowest,env%eprivious,trim(str)) !>-- always do two cycles of MTDs if (firstiter) cycle mtdloop @@ -213,18 +234,32 @@ subroutine crest_search_entropy(env,tim) do_restart = .false. !=========================================================! !>--- collect all ensembles from mtdloop and merge - write (stdout,*) - write (stdout,'(''========================================'')') - write (stdout,'('' MTD Simulations done '')') - write (stdout,'(''========================================'')') - write (stdout,'(1x,''Collecting ensmbles.'')') + if (skip_collect) then +!>--- post_collect restart: collectcre already ran, reuse last file + inquire(file=trim(rdat%last_file),exist=fex) + if (.not.fex) then + write (stdout,'(/,a)') '**ERROR** restart ensemble not found: ' & + & //trim(rdat%last_file) + write (stdout,'(a,/)') ' Delete crest.restart and rerun from scratch.' + call creststop(status_safety) + end if + atmp = trim(rdat%last_file) + write (stdout,'(1x,a,a)') 'Restarting from ensemble: ',trim(atmp) + skip_collect = .false. + else + write (stdout,*) + write (stdout,'(''========================================'')') + write (stdout,'('' MTD Simulations done '')') + write (stdout,'(''========================================'')') + write (stdout,'(1x,''Collecting ensmbles.'')') !>-- collecting all ensembles saved as ".cre_*.xyz" - call collectcre(env) - call newcregen(env,0) - call checkname_xyz(crefile,atmp,btmp) + call collectcre(env) + call newcregen(env,0) + call checkname_xyz(crefile,atmp,btmp) !>--- checkpoint after collection and CREGEN - call write_restart_log(crest_imtd2,'post_collect',env%nreset,0, & - & env%nmetadyn,env%elowest,env%eprivious,trim(atmp)) + call write_restart_log(env%crestver,'post_collect',env%nreset,0, & + & env%nmetadyn,env%elowest,env%eprivious,trim(atmp)) + end if !>--- remaining number of structures call remaining_in(atmp,env%ewin,nallout) @@ -235,7 +270,17 @@ subroutine crest_search_entropy(env,tim) !>--- and other entropy mode parameters call adjustnormmd(env) call mtdatoms(env) - call emtdcopy(env,0,stopiter,fail) + if (.not.skip_emtdcopy0) then + call emtdcopy(env,0,stopiter,fail) +! ── checkpoint: entropy rotamer file written, sMTD iterations about to start ── + if (env%crestver == crest_imtd2) then + write (btmp,'(a,i0,a)') 'crest_smtd_',0,'.xyz' + else + write (btmp,'(a,i0,a)') 'crest_entropy_rotamer_',0,'.xyz' + end if + call write_restart_log(env%crestver,'entropy_smtd',env%nreset,0, & + & env%nmetadyn,env%elowest,env%eprivious,trim(btmp)) + end if bref = env%emtd%nbias !>--- sMTD iterations, done until max iterations or convergence @@ -267,7 +312,7 @@ subroutine crest_search_entropy(env,tim) call checkname_xyz(crefile,atmp,btmp) call tim%start(3,'Geometry optimization') multilevel = (/.true.,.false.,.false.,.false.,.false.,.true./) - call crest_multilevel_oloop(env,trim(atmp),multilevel) + call crest_multilevel_oloop(env,trim(atmp),multilevel,0) call tim%stop(3) if(env%iostatus_meta .ne. 0 ) return @@ -282,6 +327,14 @@ subroutine crest_search_entropy(env,tim) eit2 = eit call emtdcopy(env,eit2,stopiter,fail) env%emtd%iterlast = eit2 +! ── checkpoint: update last_file to current entropy rotamer file ────── + if (env%crestver == crest_imtd2) then + write (btmp,'(a,i0,a)') 'crest_smtd_',eit2,'.xyz' + else + write (btmp,'(a,i0,a)') 'crest_entropy_rotamer_',eit2,'.xyz' + end if + call write_restart_log(env%crestver,'entropy_smtd',env%nreset,0, & + & env%nmetadyn,env%elowest,env%eprivious,trim(btmp)) end if if (.not.lower.and.fail.and..not.stopiter) then @@ -305,7 +358,7 @@ subroutine crest_search_entropy(env,tim) !==========================================================! !>--- checkpoint: run is complete - call write_restart_log(crest_imtd2,'done',env%nreset,0, & + call write_restart_log(env%crestver,'done',env%nreset,0, & & env%nmetadyn,env%elowest,env%eprivious,conformerfile) !==========================================================! From 3cf92938fee63f4ccbc40e9593b5c8cf869726da Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 6 May 2026 13:56:35 +0200 Subject: [PATCH 311/374] Trimmed down workflows + manual trigger full workflow --- .github/workflows/build-CI-full.yml | 388 ++++++++++++++++++++++++++++ .github/workflows/build-CI.yml | 24 +- test/test_irmsd.F90 | 2 +- 3 files changed, 394 insertions(+), 20 deletions(-) create mode 100644 .github/workflows/build-CI-full.yml diff --git a/.github/workflows/build-CI-full.yml b/.github/workflows/build-CI-full.yml new file mode 100644 index 00000000..8aeaf94a --- /dev/null +++ b/.github/workflows/build-CI-full.yml @@ -0,0 +1,388 @@ +name: CI (full) + +on: + workflow_dispatch: + +env: + BUILD_DIR: _build + PIP_PACKAGES: >- + meson!=1.8.0 + cmake + ninja + PIP_EXTRAS: >- + pkgconfig + numpy + ase + matplotlib + +jobs: + build: + runs-on: ${{ matrix.os }} + + strategy: + fail-fast: false + matrix: + include: + # ---- Linux GCC + OpenBLAS — CMake debug -------------------------- + - { os: ubuntu-latest, build-type: debug, + toolchain: { compiler: gcc, version: '12', build: cmake } } + - { os: ubuntu-latest, build-type: debug, + toolchain: { compiler: gcc, version: '14', build: cmake } } + + # ---- Linux GCC + OpenBLAS — Meson debugoptimized ----------------- + - { os: ubuntu-latest, build-type: debugoptimized, + toolchain: { compiler: gcc, version: '12', build: meson } } + - { os: ubuntu-latest, build-type: debugoptimized, + toolchain: { compiler: gcc, version: '14', build: meson } } + + # ---- Linux Intel (ifx/icx) + MKL — CMake debug ------------------ + - { os: ubuntu-latest, build-type: debug, + toolchain: { compiler: intel, version: '2025.1', mkl_version: '2025.1', build: cmake } } + + # ---- Linux Intel (ifx/icx) + MKL — Meson debugoptimized --------- + - { os: ubuntu-latest, build-type: debugoptimized, + toolchain: { compiler: intel, version: '2025.1', mkl_version: '2025.1', build: meson } } + + # ---- macOS GCC + OpenBLAS — CMake debug (GNU only) --------------- + - { os: macos-latest, build-type: debug, + toolchain: { compiler: gcc, version: '12', build: cmake } } + - { os: macos-latest, build-type: debug, + toolchain: { compiler: gcc, version: '14', build: cmake } } + + defaults: + run: + shell: bash + + steps: + # ---------------------------------------------------------------------- + # Setup + # ---------------------------------------------------------------------- + - name: Checkout code + uses: actions/checkout@v4 + + - name: Setup Python + uses: actions/setup-python@v5 + with: + python-version: "3.10" + + # ---------------------------------------------------------------------- + # Compiler setup + # ---------------------------------------------------------------------- + + - name: Install GCC using setup-fortran + if: ${{ contains(matrix.toolchain.compiler, 'gcc') }} + uses: fortran-lang/setup-fortran@v1 + with: + compiler: ${{ matrix.toolchain.compiler }} + version: ${{ matrix.toolchain.version }} + + - name: Install libopenblas (Linux GCC builds) + if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.toolchain.compiler, 'gcc') }} + run: | + sudo apt-get update + sudo apt-get install -y libopenblas-dev + + - name: Install OpenBLAS (macOS) + if: ${{ contains(matrix.os, 'macos') }} + run: | + brew update + brew install openblas + echo "PKG_CONFIG_PATH=/usr/local/opt/openblas/lib/pkgconfig:/opt/homebrew/opt/openblas/lib/pkgconfig" >> $GITHUB_ENV + echo "LDFLAGS=-L/usr/local/opt/openblas/lib -L/opt/homebrew/opt/openblas/lib" >> $GITHUB_ENV + echo "CPPFLAGS=-I/usr/local/opt/openblas/include -I/opt/homebrew/opt/openblas/include" >> $GITHUB_ENV + + - name: Prepare for Intel cache restore + if: ${{ contains(matrix.toolchain.compiler, 'intel') }} + run: | + sudo mkdir -p /opt/intel + sudo chown $USER /opt/intel + + - name: Cache Intel installation + if: ${{ contains(matrix.toolchain.compiler, 'intel') }} + id: cache-install + uses: actions/cache@v4 + with: + path: /opt/intel/oneapi + key: install-${{ matrix.toolchain.compiler }}-${{ matrix.toolchain.version }}-${{ matrix.toolchain.mkl_version }}-${{ matrix.os }} + + - name: Install Intel Compiler + if: ${{ contains(matrix.toolchain.compiler, 'intel') && steps.cache-install.outputs.cache-hit != 'true' }} + uses: fortran-lang/setup-fortran@v1 + with: + compiler: ${{ matrix.toolchain.compiler }} + version: ${{ matrix.toolchain.version }} + + - name: Install Intel MKL + if: ${{ contains(matrix.toolchain.compiler, 'intel') && steps.cache-install.outputs.cache-hit != 'true' }} + run: | + sudo apt-get install -y \ + intel-oneapi-mkl-${{ matrix.toolchain.mkl_version }} \ + intel-oneapi-mkl-devel-${{ matrix.toolchain.mkl_version }} + + - name: Setup Intel oneAPI environment + if: ${{ contains(matrix.toolchain.compiler, 'intel') }} + run: | + source /opt/intel/oneapi/setvars.sh --force + printenv >> $GITHUB_ENV + + - name: Set compiler environment variables + run: | + if [ ! -n "$FC" ]; then + if [ "${{ matrix.toolchain.compiler }}" = "gcc" ]; then + echo "FC=gfortran" >> $GITHUB_ENV + echo "CC=gcc" >> $GITHUB_ENV + elif [ "${{ matrix.toolchain.compiler }}" = "intel" ]; then + echo "FC=ifx" >> $GITHUB_ENV + echo "CC=icx" >> $GITHUB_ENV + fi + fi + echo "COMPILER_VERSION=${{ matrix.toolchain.version }}" >> $GITHUB_ENV + + # ---------------------------------------------------------------------- + # Dependencies & submodules + # ---------------------------------------------------------------------- + + - name: Git submodules checkout + run: git submodule update --init + + - name: Install build and test dependencies + run: | + pip3 install ${{ env.PIP_PACKAGES }} ${{ env.PIP_EXTRAS }} + + # ---------------------------------------------------------------------- + # Configure + # ---------------------------------------------------------------------- + + - name: Configure build (CMake, debug) + if: ${{ matrix.toolchain.build == 'cmake' && matrix.build-type == 'debug' }} + run: > + cmake -B${{ env.BUILD_DIR }} + -GNinja + -DCMAKE_BUILD_TYPE=Debug + -DCMAKE_INSTALL_PREFIX=$PWD/_dist + -DCMAKE_INSTALL_LIBDIR=lib + + - name: Configure build (CMake, debugoptimized) + if: ${{ matrix.toolchain.build == 'cmake' && matrix.build-type == 'debugoptimized' }} + run: > + cmake -B${{ env.BUILD_DIR }} + -GNinja + -DCMAKE_BUILD_TYPE=RelWithDebInfo + -DCMAKE_INSTALL_PREFIX=$PWD/_dist + -DCMAKE_INSTALL_LIBDIR=lib + + - name: Configure build (Meson, GNU) + if: ${{ matrix.toolchain.build == 'meson' && matrix.toolchain.compiler == 'gcc' }} + run: > + meson setup ${{ env.BUILD_DIR }} + --buildtype=${{ matrix.build-type }} + --prefix=$PWD/_dist + --libdir=lib + --warnlevel=0 + -Dlapack=openblas + + - name: Configure build (Meson, Intel) + if: ${{ matrix.toolchain.build == 'meson' && contains(matrix.toolchain.compiler, 'intel') }} + run: > + meson setup ${{ env.BUILD_DIR }} + --buildtype=${{ matrix.build-type }} + --prefix=$PWD/_dist + --libdir=lib + --warnlevel=0 + --native-file=config/intel-llvm.ini + -Dlapack=mkl + + # ---------------------------------------------------------------------- + # Build / test / install + # ---------------------------------------------------------------------- + + - name: Build project + run: ninja -C ${{ env.BUILD_DIR }} + + - name: Run unit tests (ctest) + if: ${{ matrix.toolchain.build == 'cmake' && contains(matrix.toolchain.compiler, 'gcc') }} + run: | + ctest --output-on-failure --parallel 2 -R '^crest/' + working-directory: ${{ env.BUILD_DIR }} + env: + OMP_NUM_THREADS: 1,2,1 + + - name: Install project + run: | + ninja -C ${{ env.BUILD_DIR }} install + echo "CREST_PREFIX=$PWD/_dist" >> $GITHUB_ENV + + build-static: + runs-on: ${{ matrix.os }} + + strategy: + fail-fast: false + matrix: + include: + # Linux x86_64 — GNU static (CMake) + - { os: ubuntu-latest, build-type: static, + toolchain: { compiler: gcc, version: '14', build: cmake } } + + # Linux x86_64 — Intel LLVM static (Meson; better ifx static support) + - { os: ubuntu-latest, build-type: static, + toolchain: { compiler: intel, version: '2025.1', mkl_version: '2025.1', build: meson } } + + # Linux aarch64 — GNU static (CMake; Intel oneAPI is x86-only) + - { os: ubuntu-24.04-arm, build-type: static, + toolchain: { compiler: gcc, version: '14', build: cmake } } + + # macOS arm64 — GNU mostly-static (CMake) + # Note: macOS does not support fully-static executables; system libs remain dynamic. + - { os: macos-latest, build-type: static, + toolchain: { compiler: gcc, version: '14', build: cmake } } + + defaults: + run: + shell: bash + + steps: + - name: Checkout code + uses: actions/checkout@v4 + + - name: Setup Python + uses: actions/setup-python@v5 + with: + python-version: "3.10" + + # --- Compiler setup ---------------------------------------------------- + + - name: Install GCC using setup-fortran + if: ${{ contains(matrix.toolchain.compiler, 'gcc') }} + uses: fortran-lang/setup-fortran@v1 + with: + compiler: ${{ matrix.toolchain.compiler }} + version: ${{ matrix.toolchain.version }} + + - name: Install libopenblas (Linux GCC builds) + if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.toolchain.compiler, 'gcc') }} + run: | + sudo apt-get update + sudo apt-get install -y libopenblas-dev + + - name: Install OpenBLAS (macOS) + if: ${{ contains(matrix.os, 'macos') }} + run: | + brew update + brew install openblas + echo "PKG_CONFIG_PATH=/usr/local/opt/openblas/lib/pkgconfig:/opt/homebrew/opt/openblas/lib/pkgconfig" >> $GITHUB_ENV + echo "LDFLAGS=-L/usr/local/opt/openblas/lib -L/opt/homebrew/opt/openblas/lib" >> $GITHUB_ENV + echo "CPPFLAGS=-I/usr/local/opt/openblas/include -I/opt/homebrew/opt/openblas/include" >> $GITHUB_ENV + + - name: Prepare for Intel cache restore + if: ${{ contains(matrix.toolchain.compiler, 'intel') }} + run: | + sudo mkdir -p /opt/intel + sudo chown $USER /opt/intel + + - name: Cache Intel installation + if: ${{ contains(matrix.toolchain.compiler, 'intel') }} + id: cache-install + uses: actions/cache@v4 + with: + path: /opt/intel/oneapi + key: install-${{ matrix.toolchain.compiler }}-${{ matrix.toolchain.version }}-${{ matrix.toolchain.mkl_version }}-${{ matrix.os }} + + - name: Install Intel Compiler + if: ${{ contains(matrix.toolchain.compiler, 'intel') && steps.cache-install.outputs.cache-hit != 'true' }} + uses: fortran-lang/setup-fortran@v1 + with: + compiler: ${{ matrix.toolchain.compiler }} + version: ${{ matrix.toolchain.version }} + + - name: Install Intel MKL + if: ${{ contains(matrix.toolchain.compiler, 'intel') && steps.cache-install.outputs.cache-hit != 'true' }} + run: | + sudo apt-get install -y \ + intel-oneapi-mkl-${{ matrix.toolchain.mkl_version }} \ + intel-oneapi-mkl-devel-${{ matrix.toolchain.mkl_version }} + + - name: Setup Intel oneAPI environment + if: ${{ contains(matrix.toolchain.compiler, 'intel') }} + run: | + source /opt/intel/oneapi/setvars.sh --force + printenv >> $GITHUB_ENV + + - name: Set compiler environment variables + run: | + if [ ! -n "$FC" ]; then + if [ "${{ matrix.toolchain.compiler }}" = "gcc" ]; then + echo "FC=gfortran" >> $GITHUB_ENV + echo "CC=gcc" >> $GITHUB_ENV + elif [ "${{ matrix.toolchain.compiler }}" = "intel" ]; then + echo "FC=ifx" >> $GITHUB_ENV + echo "CC=icx" >> $GITHUB_ENV + fi + fi + echo "COMPILER_VERSION=${{ matrix.toolchain.version }}" >> $GITHUB_ENV + + # --- Dependencies & submodules ----------------------------------------- + + - name: Git submodules checkout + run: git submodule update --init + + - name: Install build dependencies + run: | + pip3 install ${{ env.PIP_PACKAGES }} ${{ env.PIP_EXTRAS }} + + # --- Configure --------------------------------------------------------- + + - name: Configure build (CMake, static) + if: ${{ matrix.toolchain.build == 'cmake' && matrix.build-type == 'static' }} + run: > + cmake -B${{ env.BUILD_DIR }} + -GNinja + -DCMAKE_BUILD_TYPE=RelWithDebInfo + -DCMAKE_INSTALL_PREFIX=$PWD/_dist + -DCMAKE_INSTALL_LIBDIR=lib + -DWITH_TESTS=OFF + -DSTATICBUILD=ON + + - name: Configure build (Meson, Intel static) + if: ${{ matrix.toolchain.build == 'meson' && matrix.build-type == 'static' }} + run: > + meson setup ${{ env.BUILD_DIR }} + --buildtype=release + --prefix=$PWD/_dist + --libdir=lib + --warnlevel=0 + --native-file=config/intel-llvm.ini + -Dstatic=true + -Dlapack=mkl + -Dtests=false + + # --- Build / install --------------------------------------------------- + + - name: Build project + run: ninja -C ${{ env.BUILD_DIR }} + + - name: Install project + run: | + ninja -C ${{ env.BUILD_DIR }} install + echo "CREST_PREFIX=$PWD/_dist" >> $GITHUB_ENV + + - name: Create package + run: | + mkdir crest + cp COPYING crest/LICENSE + cp COPYING.LESSER crest/LICENSE.LESSER + cp _dist/bin/crest crest/ + ARCH=$(uname -m) + UNAME_OS=$(uname -s | tr '[:upper:]' '[:lower:]') + COMPILER_NAME="${{ matrix.toolchain.compiler }}" + [ "$COMPILER_NAME" = "gcc" ] && COMPILER_NAME="gnu" + [ "$COMPILER_NAME" = "intel" ] && COMPILER_NAME="intel" + OUTPUT="crest-${COMPILER_NAME}-${{ matrix.toolchain.version }}-${UNAME_OS}-${ARCH}.tar" + tar cvf "$OUTPUT" crest + xz -T0 "$OUTPUT" + echo "CREST_OUTPUT=${OUTPUT}.xz" >> $GITHUB_ENV + + - name: Upload package + uses: actions/upload-artifact@v4 + with: + name: ${{ env.CREST_OUTPUT }} + path: ${{ env.CREST_OUTPUT }} diff --git a/.github/workflows/build-CI.yml b/.github/workflows/build-CI.yml index 2b1bd33b..174e5def 100644 --- a/.github/workflows/build-CI.yml +++ b/.github/workflows/build-CI.yml @@ -32,30 +32,16 @@ jobs: fail-fast: false matrix: include: - # ---- Linux GCC + OpenBLAS — CMake debug -------------------------- - - { os: ubuntu-latest, build-type: debug, - toolchain: { compiler: gcc, version: '12', build: cmake } } - - { os: ubuntu-latest, build-type: debug, - toolchain: { compiler: gcc, version: '14', build: cmake } } - - # ---- Linux GCC + OpenBLAS — Meson debugoptimized ----------------- - - { os: ubuntu-latest, build-type: debugoptimized, - toolchain: { compiler: gcc, version: '12', build: meson } } + # ---- Linux GCC 14 + OpenBLAS — CMake debugoptimized -------------- - { os: ubuntu-latest, build-type: debugoptimized, - toolchain: { compiler: gcc, version: '14', build: meson } } - - # ---- Linux Intel (ifx/icx) + MKL — CMake debug ------------------ - - { os: ubuntu-latest, build-type: debug, - toolchain: { compiler: intel, version: '2025.1', mkl_version: '2025.1', build: cmake } } + toolchain: { compiler: gcc, version: '14', build: cmake } } # ---- Linux Intel (ifx/icx) + MKL — Meson debugoptimized --------- - { os: ubuntu-latest, build-type: debugoptimized, toolchain: { compiler: intel, version: '2025.1', mkl_version: '2025.1', build: meson } } - # ---- macOS GCC + OpenBLAS — CMake debug (GNU only) --------------- - - { os: macos-latest, build-type: debug, - toolchain: { compiler: gcc, version: '12', build: cmake } } - - { os: macos-latest, build-type: debug, + # ---- macOS GCC 14 + OpenBLAS — CMake debugoptimized -------------- + - { os: macos-latest, build-type: debugoptimized, toolchain: { compiler: gcc, version: '14', build: cmake } } defaults: @@ -209,7 +195,7 @@ jobs: run: ninja -C ${{ env.BUILD_DIR }} - name: Run unit tests (ctest) - if: ${{ matrix.toolchain.build == 'cmake' && contains(matrix.toolchain.compiler, 'gcc') }} + if: ${{ matrix.toolchain.build == 'cmake' }} run: | ctest --output-on-failure --parallel 2 -R '^crest/' working-directory: ${{ env.BUILD_DIR }} diff --git a/test/test_irmsd.F90 b/test/test_irmsd.F90 index 7964ad4a..1990f550 100644 --- a/test/test_irmsd.F90 +++ b/test/test_irmsd.F90 @@ -171,7 +171,7 @@ subroutine test_rmsd_self(error) real(wp) :: rmsdval call get_testmol('caffeine',mol) rmsdval = rmsd(mol,mol) - if (abs(rmsdval) > thr) & + if (abs(rmsdval) > 1.0e-6_wp) & call test_failed(error,'RMSD(mol,mol) should be 0, got: '//to_str(rmsdval)) end subroutine test_rmsd_self From 1b43773ff208fcdf10b806500257c7e67c593d9d Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 6 May 2026 17:56:51 +0200 Subject: [PATCH 312/374] Some additions to printouts --- src/algos/parallel.f90 | 2 +- src/confparse.f90 | 1 + src/crest_main.f90 | 4 + src/entropy/entropy.f90 | 4 + src/printouts.f90 | 324 +++++++++++++++++++++++++++------------- 5 files changed, 232 insertions(+), 103 deletions(-) diff --git a/src/algos/parallel.f90 b/src/algos/parallel.f90 index 13bf7c6d..fe52a803 100644 --- a/src/algos/parallel.f90 +++ b/src/algos/parallel.f90 @@ -1235,7 +1235,7 @@ subroutine parallel_md_block_printout(MD,vz) end if end if if (allocated(MD%active_potentials)) then - write (stdout,'(2x,"| active potentials :",i4," potential |")') size(MD%active_potentials,1) + write (stdout,'(2x,"| active potentials :",i4," potential |")') size(MD%active_potentials,1) end if if (MD%simtype == type_mtd) then if (MD%cvtype(1) == cv_rmsd) then diff --git a/src/confparse.f90 b/src/confparse.f90 index 6cf0e8f2..5a0017e1 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -1430,6 +1430,7 @@ subroutine parseflags(env,arg,nra) processedarg(i) = .true. env%gfnver = '--gxtb' write (stdout,'(2x,a,'' : Use of g-xTB requested.'')') env%gfnver + call gxtb_syscall_warning() case ('-gxtb_dev') processedarg(i) = .true. diff --git a/src/crest_main.f90 b/src/crest_main.f90 index bd9abc82..89aacbfb 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -360,6 +360,10 @@ program CREST !> one final cleanup call custom_cleanup(env) +!=========================================================================================! +!> Print a summary of output files written in this run + call crest_output_summary(env) + !=========================================================================================! !> Evaluate and print timings, then stop the program call eval_timer(tim) diff --git a/src/entropy/entropy.f90 b/src/entropy/entropy.f90 index a48148a2..5aeaef0f 100644 --- a/src/entropy/entropy.f90 +++ b/src/entropy/entropy.f90 @@ -442,6 +442,10 @@ subroutine entropyprintout(T,Srrho,S,Cp,H) write (*,*) write (*,'(3x,''Cp(total) = '',f12.6,1x,a)') cp, sunit write (*,*) + write (*,'(3x,a)') 'Note: S and G above are conformational contributions only.' + write (*,'(3x,a)') 'They are additive to the free energy of the lowest-energy conformer.' + write (*,'(3x,a)') 'Ref.: P.Pracht, S.Grimme, Chem. Sci., 2021, 12, 6551-6568.' + write (*,*) return end subroutine entropyprintout diff --git a/src/printouts.f90 b/src/printouts.f90 index 7a4fba80..c7c287c9 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -142,11 +142,10 @@ subroutine help_section(title) character(len=*),intent(in) :: title integer :: n n = len_trim(title) - write(stdout,'(/,1x,a)') colorify(trim(title),'yellow') - write(stdout,'(1x,a)') colorify(repeat('─',n),'yellow') + write (stdout,'(/,1x,a)') colorify(trim(title),'yellow') + write (stdout,'(1x,a)') colorify(repeat('─',n),'yellow') end subroutine help_section - subroutine help_opt(flag,fw,desc) !********************************************************************* !* Print one colored flag + description, padding the flag column to * @@ -160,7 +159,7 @@ subroutine help_opt(flag,fw,desc) integer :: fl,pad fl = len_trim(flag) pad = max(fw-fl,1) - write(stdout,'(a,a,a,a,a)') ' ',colorify(trim(flag),'green'), & + write (stdout,'(a,a,a,a,a)') ' ',colorify(trim(flag),'green'), & & repeat(' ',pad),' : ',trim(desc) end subroutine help_opt @@ -171,20 +170,20 @@ subroutine confscript_help() use crest_parameters,only:stdout implicit none - write(stdout,'(/,1x,a)') colorify(repeat('─',76),'gold') - write(stdout,'(1x,a,a)') colorify('Usage:','yellow'),' crest [INPUT] [OPTIONS]' - write(stdout,'(1x,a)') colorify(repeat('─',76),'gold') - write(stdout,*) - write(stdout,'(1x,a)') 'The '//colorify('[INPUT]','blue')//' argument CAN be a coordinate file in the' - write(stdout,'(1x,a)') 'TM (coord, Bohr) or Xmol (*.xyz, Ang.) format.' - write(stdout,'(1x,a)') 'If no such file is present as the first argument, crest will' - write(stdout,'(1x,a)') 'automatically search for a file called "coord" in the TM format.' - write(stdout,*) - write(stdout,'(1x,a)') colorify('Versions >3.0 allow specifying detailed input instructions via','green') - write(stdout,'(1x,a)') colorify('input files in the TOML format.','green') - write(stdout,'(1x,a)') colorify('*.toml files can be ','green')//colorify(' [INPUT]','blue')// & + write (stdout,'(/,1x,a)') colorify(repeat('─',76),'gold') + write (stdout,'(1x,a,a)') colorify('Usage:','yellow'),' crest [INPUT] [OPTIONS]' + write (stdout,'(1x,a)') colorify(repeat('─',76),'gold') + write (stdout,*) + write (stdout,'(1x,a)') 'The '//colorify('[INPUT]','blue')//' argument CAN be a coordinate file in the' + write (stdout,'(1x,a)') 'TM (coord, Bohr) or Xmol (*.xyz, Ang.) format.' + write (stdout,'(1x,a)') 'If no such file is present as the first argument, crest will' + write (stdout,'(1x,a)') 'automatically search for a file called "coord" in the TM format.' + write (stdout,*) + write (stdout,'(1x,a)') colorify('Versions >3.0 allow specifying detailed input instructions via','green') + write (stdout,'(1x,a)') colorify('input files in the TOML format.','green') + write (stdout,'(1x,a)') colorify('*.toml files can be ','green')//colorify(' [INPUT]','blue')// & colorify(' or specified via "--input "','green') - write(stdout,*) + write (stdout,*) call confscript_morehelp2() stop ' [-h] displayed. exit.' end subroutine confscript_help @@ -196,11 +195,11 @@ subroutine confscript_morehelp(flag) character(len=*),intent(in) :: flag integer :: fw - write(stdout,'(/,1x,a)') colorify(repeat('─',76),'gold') - write(stdout,*) + write (stdout,'(/,1x,a)') colorify(repeat('─',76),'gold') + write (stdout,*) select case (flag) - ! ── General / technical ────────────────────────────────────────────── + ! ── General / technical ────────────────────────────────────────────── case default fw = 16 call help_section('Run modes:') @@ -219,7 +218,7 @@ subroutine confscript_morehelp(flag) call help_opt('-msreact',fw,'MS fragment generator (see --help msreact)') call help_opt('-bh/-GMIN',fw,'Basin-hopping global optimization') call help_opt('-sort',fw,'Ensemble sorting via CREGEN (see --help compare)') - write(stdout,*) + write (stdout,*) fw = 22 call help_section('Method selection:') call help_opt('-gfn2',fw,'Use GFN2-xTB [default]') @@ -230,9 +229,9 @@ subroutine confscript_morehelp(flag) call help_opt('-gfn2//gfnff',fw,'GFN-FF trajectories with GFN2-xTB energy reweighting') call help_opt('-refine ',fw,'Post-process conformers at a higher level') call help_opt('-optlev ',fw,'Optimization convergence level for ALL semiempirical calculations') - write(stdout,'(9x,a)') ' = crude, vloose, loose, normal, tight, vtight, extreme' + write (stdout,'(9x,a)') ' = crude, vloose, loose, normal, tight, vtight, extreme' call help_opt('-dscal []',fw,'Scale dispersion energy in MD/MTD simulations') - write(stdout,*) + write (stdout,*) fw = 22 call help_section('Molecular system:') call help_opt('-T ',fw,'Number of CPU threads (or read from OMP_NUM_THREADS)') @@ -243,7 +242,7 @@ subroutine confscript_morehelp(flag) call help_opt('-alpb ',fw,'ALPB implicit solvation') call help_opt('-efield ',fw,'External electric field in V/Ang along x, y, z') call help_opt('-charges []',fw,'Read atomic partial charges from file [default: "charges"]') - write(stdout,*) + write (stdout,*) fw = 22 call help_section('Technical:') call help_opt('--input ',fw,'Specify TOML input file with detailed settings') @@ -252,7 +251,7 @@ subroutine confscript_morehelp(flag) call help_opt('-niceprint',fw,'Show progress bar during optimizations') call help_opt('-dry',fw,'Parse args, print resolved settings, then exit') call help_opt('-legacy',fw,'Force CREST < 3.0 behavior') - write(stdout,*) + write (stdout,*) fw = 22 call help_section('Constraints (applied to ALL calculations):') call help_opt('-cinp ',fw,'Read constraints file (xtb format; formerly ".constrains")') @@ -260,14 +259,14 @@ subroutine confscript_morehelp(flag) call help_opt('-cbonds_md []',fw,'Constrain all bonds during MDs/MTDs only') call help_opt('-nocbonds',fw,'Disable automatic bond constraints') call help_opt('-fc ',fw,'Global force constant for bond constraints') - write(stdout,*) + write (stdout,*) - ! ── Ensemble comparison / CREGEN ───────────────────────────────────── + ! ── Ensemble comparison / CREGEN ───────────────────────────────────── case ('compare','cregen') fw = 20 call help_section('Options for ensemble comparisons:') call help_opt('-cregen [file]',fw,'Run CREGEN standalone to sort an ensemble file.') - write(stdout,*) + write (stdout,*) call help_section('Thresholds:') call help_opt('-ewin ',fw,'Energy window in kcal/mol [default: 6.0]') call help_opt('-rthr ',fw,'RMSD threshold in Ang [default: 0.125]') @@ -275,7 +274,7 @@ subroutine confscript_morehelp(flag) call help_opt('-bthr ',fw,'Rotational constant threshold [default: 0.01 = 1%]') call help_opt('-pthr ',fw,'Boltzmann population threshold (0-1) [default: 0.05]') call help_opt('-temp ',fw,'Boltzmann temperature in K [default: 298.15]') - write(stdout,*) + write (stdout,*) call help_section('Algorithm options:') call help_opt('-topo/-notopo',fw,'Enable/disable topology change check') call help_opt('-ezcheck',fw,'Enable E/Z double-bond isomer check') @@ -283,14 +282,14 @@ subroutine confscript_morehelp(flag) call help_opt('-allrot',fw,'Use all three rotational constants (A, B, C)') call help_opt('-eqv/-nmr',fw,'NMR nuclear equivalence analysis (requires rotamers)') call help_opt('-cluster ',fw,'PCA + k-Means clustering ( = number of clusters)') - write(stdout,*) + write (stdout,*) call help_section('Output:') call help_opt('-prsc',fw,'Write scoord.* file for each conformer') call help_opt('-nowr',fw,"Skip writing the sorted ensemble file") call help_opt('-osdf',fw,'Also write output ensemble in SDF format') - write(stdout,*) + write (stdout,*) - ! ── Conformer search / sampling ────────────────────────────────────── + ! ── Conformer search / sampling ────────────────────────────────────── case ('conf','sampling') fw = 20 call help_section('Conformer search algorithms:') @@ -298,7 +297,7 @@ subroutine confscript_morehelp(flag) call help_opt('-v4',fw,'iMTD-sMTD (entropy-focused search)') call help_opt('-entropy',fw,'Same as -v4, specialized for conformational entropy') - write(stdout,*) + write (stdout,*) call help_section('MD / MTD parameters:') call help_opt('-len/-mdlen [x]',fw,'MD/MTD length in ps; append "x" for a scaling factor') call help_opt('-tstep ',fw,'MD timestep in fs [default: 5 fs]') @@ -308,7 +307,7 @@ subroutine confscript_morehelp(flag) call help_opt('-mddump ',fw,'Trajectory dump interval in fs [default: 100]') call help_opt('-vbdump ',fw,'Vbias dump frequency in ps [default: 1.0]') call help_opt('-nmtd ',fw,'Number of MTD simulations per cycle') - write(stdout,*) + write (stdout,*) call help_section('Search control:') call help_opt('-cross/-nocross',fw,'Enable/disable genetic structure crossing [cross=default]') call help_opt('-gcmax ',fw,'Max structures fed into genetic crossing') @@ -321,14 +320,14 @@ subroutine confscript_morehelp(flag) call help_opt('-wscal ',fw,'Scale wall potential sphere radius') call help_opt('-hflip/-noflip',fw,'OH proton flip after MTD [default: OFF]') call help_opt('-maxflip ',fw,'Max OH flip attempts [default: 1000]') - write(stdout,*) + write (stdout,*) - ! ── Thermochemistry / entropy ───────────────────────────────────────── + ! ── Thermochemistry / entropy ───────────────────────────────────────── case ('thermo','entropy') fw = 28 call help_section('Thermostatistical options:') call help_opt('-trange ',fw,'Temperature range in K for entropy output') - write(stdout,'(9x,a)') '[default: 280-380 K in 10 K steps]' + write (stdout,'(9x,a)') '[default: 280-380 K in 10 K steps]' call help_opt('-tread ',fw,'Read temperatures (one per line) from file') call help_opt('-fscal ',fw,'Frequency scaling factor [default: 1.0]') call help_opt('-sthr/-rotorcut ',fw,'Rotor cutoff in cm^-1 (free-rotor interpolation) [default: 25.0]') @@ -337,15 +336,15 @@ subroutine confscript_morehelp(flag) call help_opt('-pcap ',fw,'Max structures used in property calculations') call help_opt('-printpop',fw,'Print Boltzmann populations at every temperature') call help_opt('-avbhess',fw,'Use Boltzmann-averaged Hessian in rrhoav') - write(stdout,*) + write (stdout,*) - ! ── QCG ────────────────────────────────────────────────────────────── + ! ── QCG ────────────────────────────────────────────────────────────── case ('qcg') fw = 20 call help_section('Quantum Cluster Growth (QCG)') - write(stdout,'(1x,a)') 'General usage: crest -qcg [options]' - write(stdout,'(1x,a)') 'Options (in addition to general / iMTD-GC options):' - write(stdout,*) + write (stdout,'(1x,a)') 'General usage: crest -qcg [options]' + write (stdout,'(1x,a)') 'Options (in addition to general / iMTD-GC options):' + write (stdout,*) call help_section('Cluster growth:') call help_opt('-grow',fw,'Cluster generation run type') call help_opt('-nsolv ',fw,'Number of solvent molecules to add') @@ -359,7 +358,7 @@ subroutine confscript_morehelp(flag) call help_opt('-samerand',fw,'Use same random seed for every xtbiff run') call help_opt('-directed ',fw,'Directed solvation at positions in ') call help_opt('-fin_opt_gfn2',fw,'Final GFN2-xTB optimization for grow and ensemble') - write(stdout,*) + write (stdout,*) call help_section('Ensemble generation:') call help_opt('-ensemble',fw,'Ensemble generation run type') call help_opt('-qcgmtd',fw,'NCI-MTD CREST ensemble generation [default]') @@ -368,7 +367,7 @@ subroutine confscript_morehelp(flag) call help_opt('-md',fw,'Normal MD for QCG ensemble search') call help_opt('-enslvl [method]',fw,'Method for ensemble search (all GFN methods supported)') call help_opt('-clustering',fw,'Clustering for ensemble search (qcgmtd/ncimtd only)') - write(stdout,*) + write (stdout,*) call help_section('Solvation free energy:') call help_opt('-esolv',fw,'Solvation energy (reference cluster generation)') call help_opt('-gsolv',fw,'Solvation free energy (reference cluster generation)') @@ -377,14 +376,14 @@ subroutine confscript_morehelp(flag) call help_opt('-freqscal',fw,'Frequency scale factor (output only)') call help_opt('-freqlvl [method]',fw,'Method for frequency computation') call help_opt('-keepdir',fw,'Keep temporary directories') - write(stdout,*) + write (stdout,*) - ! ── MSReact ────────────────────────────────────────────────────────── + ! ── MSReact ────────────────────────────────────────────────────────── case ('msreact') fw = 22 call help_section('Mass spectral fragment generator (msreact)') - write(stdout,'(1x,a)') 'General usage: crest -msreact [options]' - write(stdout,*) + write (stdout,'(1x,a)') 'General usage: crest -msreact [options]' + write (stdout,*) call help_opt('-msnoattrh',fw,'Deactivate H–LMO attractive potential') call help_opt('-msnshifts ',fw,'n optimizations with randomly shifted atoms [default: 0]') call help_opt('-msnshifts2 ',fw,'Same but with bond-repulsive potential [default: 0]') @@ -398,7 +397,7 @@ subroutine confscript_morehelp(flag) call help_opt('-chrg ',fw,"Molecular charge") call help_opt('-ewin ',fw,'Energy window for fragment sorting in kcal/mol [default: 200.0]') call help_opt('-msinput ',fw,'Read special settings from input file') - write(stdout,*) + write (stdout,*) fw = 22 call help_section('msreact input file keywords:') call help_opt('fragdist ',fw,'Inter-fragment distance increase [default: 0.0 Ang]') @@ -407,9 +406,9 @@ subroutine confscript_morehelp(flag) call help_opt('fc_rep ',fw,'Repulsive potential force constant [default: 0.5]') call help_opt('fc_attr ',fw,'H–LMO attractive force constant [default: -0.5]') call help_opt('etemp ',fw,'Electronic temperature in xTB optimizations') - write(stdout,*) + write (stdout,*) - ! ── Standalone tools ───────────────────────────────────────────────── + ! ── Standalone tools ───────────────────────────────────────────────── case ('other') fw = 26 call help_section('Single-structure calculations:') @@ -418,8 +417,8 @@ subroutine confscript_morehelp(flag) call help_opt('-hess/-numhess',fw,'Numerical Hessian / vibrational frequencies') call help_opt('-dynamics/-dyn',fw,'Stand-alone MD run') call help_opt('-thermo ',fw,'Thermochemistry from existing Hessian data') - write(stdout,'(9x,a)') '(also requires "vibspectrum" in TM format)' - write(stdout,*) + write (stdout,'(9x,a)') '(also requires "vibspectrum" in TM format)' + write (stdout,*) call help_section('Ensemble tools:') call help_opt('-mdopt ',fw,'Optimize every structure in an ensemble (XYZ)') call help_opt('-screen ',fw,'Multi-level energy screening of an ensemble') @@ -428,45 +427,45 @@ subroutine confscript_morehelp(flag) call help_opt('-symmetries',fw,'Symmetry analysis of all structures in an ensemble') call help_opt('-printboltz',fw,'Print Boltzmann population weights') call help_opt('-compare ',fw,'Compare two ensembles for structural overlap') - write(stdout,'(9x,a)') colorify('-maxcomp ','green')//' : max conformers per ensemble [default: 10]' + write (stdout,'(9x,a)') colorify('-maxcomp ','green')//' : max conformers per ensemble [default: 10]' call help_opt('-splitfile [i] [j]',fw,'Split ensemble into per-structure directories (SPLIT/)') call help_opt('-rmsd ',fw,'RMSD between two structures (auto-converted to Ang)') call help_opt('-rmsdheavy ',fw,'Heavy-atom RMSD between two structures') - write(stdout,*) + write (stdout,*) call help_section('Protonation / tautomerization:') call help_opt('-protonate',fw,"Find a molecule's protomers (LMO π/LP-center approach)") call help_opt('-deprotonate',fw,"Find a molecule's deprotomers") call help_opt('-tautomerize',fw,'Find prototropic tautomers (protonation + deprotonation)') - write(stdout,'(9x,a)') colorify('-trev','green')//' : deprotonate first, then protonate (reverse order)' - write(stdout,'(9x,a)') colorify('-iter ','green')//' : number of prot/deprot cycles [default: 2]' - write(stdout,*) + write (stdout,'(9x,a)') colorify('-trev','green')//' : deprotonate first, then protonate (reverse order)' + write (stdout,'(9x,a)') colorify('-iter ','green')//' : number of prot/deprot cycles [default: 2]' + write (stdout,*) call help_section('Miscellaneous:') call help_opt('-cregen [file]',fw,'CREGEN ensemble sorting (see also --help compare)') call help_opt('-zsort',fw,'Z-matrix sorting of the input coord file') call help_opt('-testtopo ',fw,'Topology / bond connectivity analysis') call help_opt('-constrain ',fw,'Write example constraint file ".xcontrol.sample"') - write(stdout,*) + write (stdout,*) - ! ── TOML input files ───────────────────────────────────────────────── + ! ── TOML input files ───────────────────────────────────────────────── case ('toml') call help_section('TOML input files') - write(stdout,'(1x,a)') 'CREST (v3+) accepts a TOML file as a flexible alternative to CLI flags.' - write(stdout,'(1x,a)') 'Pass it as the first argument or explicitly with --input:' - write(stdout,*) - write(stdout,'(3x,a)') colorify('crest structure.xyz --input settings.toml','green') - write(stdout,'(3x,a)') colorify('crest settings.toml','green')//' (structure path given inside the file)' - write(stdout,*) + write (stdout,'(1x,a)') 'CREST (v3+) accepts a TOML file as a flexible alternative to CLI flags.' + write (stdout,'(1x,a)') 'Pass it as the first argument or explicitly with --input:' + write (stdout,*) + write (stdout,'(3x,a)') colorify('crest structure.xyz --input settings.toml','green') + write (stdout,'(3x,a)') colorify('crest settings.toml','green')//' (structure path given inside the file)' + write (stdout,*) call help_section('Minimal example:') - write(stdout,'(3x,a)') colorify('input','yellow')//' = "struc.xyz"' - write(stdout,'(3x,a)') colorify('runtype','yellow')//' = "iMTD-GC"' - write(stdout,'(3x,a)') colorify('threads','yellow')//' = 4' - write(stdout,*) - write(stdout,'(3x,a)') colorify('[calculation]','yellow') - write(stdout,'(5x,a)') colorify('[[calculation.level]]','yellow') - write(stdout,'(7x,a)') 'method = "gfn2"' - write(stdout,'(7x,a)') 'chrg = 0' - write(stdout,'(7x,a)') 'gbsa = "h2o"' - write(stdout,*) + write (stdout,'(3x,a)') colorify('input','yellow')//' = "struc.xyz"' + write (stdout,'(3x,a)') colorify('runtype','yellow')//' = "iMTD-GC"' + write (stdout,'(3x,a)') colorify('threads','yellow')//' = 4' + write (stdout,*) + write (stdout,'(3x,a)') colorify('[calculation]','yellow') + write (stdout,'(5x,a)') colorify('[[calculation.level]]','yellow') + write (stdout,'(7x,a)') 'method = "gfn2"' + write (stdout,'(7x,a)') 'chrg = 0' + write (stdout,'(7x,a)') 'gbsa = "h2o"' + write (stdout,*) call help_section('Key root-level settings:') fw = 20 call help_opt('input / structure',fw,'Input coordinate file') @@ -474,27 +473,27 @@ subroutine confscript_morehelp(flag) call help_opt('threads',fw,'Number of CPU threads') call help_opt('preopt',fw,'Pre-optimize input structure (true/false)') call help_opt('constraints',fw,'Path to an xtb-format constraint file') - write(stdout,*) + write (stdout,*) call help_section('Main blocks:') ! ── padding = 30 - visible_len, so ' — ' aligns at column 30 ── - write(stdout,'(3x,a,a)') colorify('[calculation]','yellow'), & + write (stdout,'(3x,a,a)') colorify('[calculation]','yellow'), & & repeat(' ',17)//' — method, charge, solvent, …' - write(stdout,'(3x,a,a)') colorify(' [[calculation.level]]','yellow'), & + write (stdout,'(3x,a,a)') colorify(' [[calculation.level]]','yellow'), & & repeat(' ',7)//' — one or more calculation levels' - write(stdout,'(3x,a,a)') colorify(' [[calculation.constraint]]','yellow'), & + write (stdout,'(3x,a,a)') colorify(' [[calculation.constraint]]','yellow'), & & repeat(' ',2)//' — geometric constraints' - write(stdout,'(3x,a,a)') colorify('[dynamics]','yellow'), & + write (stdout,'(3x,a,a)') colorify('[dynamics]','yellow'), & & repeat(' ',20)//' — MD length, timestep, temperature, …' - write(stdout,'(3x,a,a)') colorify(' [[dynamics.meta]]','yellow'), & + write (stdout,'(3x,a,a)') colorify(' [[dynamics.meta]]','yellow'), & & repeat(' ',11)//' — metadynamics bias settings' - write(stdout,'(3x,a,a)') colorify('[cregen]','yellow'), & + write (stdout,'(3x,a,a)') colorify('[cregen]','yellow'), & & repeat(' ',22)//' — ensemble sorting thresholds' - write(stdout,'(3x,a,a)') colorify('[thermo]','yellow'), & + write (stdout,'(3x,a,a)') colorify('[thermo]','yellow'), & & repeat(' ',22)//' — thermochemistry settings' - write(stdout,*) - write(stdout,'(1x,a)') 'Full TOML keyword reference:' - write(stdout,'(3x,a)') colorify('https://crest-lab.github.io/crest-docs/','blue') - write(stdout,*) + write (stdout,*) + write (stdout,'(1x,a)') 'Full TOML keyword reference:' + write (stdout,'(3x,a)') colorify('https://crest-lab.github.io/crest-docs/','blue') + write (stdout,*) end select call confscript_morehelp2() @@ -505,18 +504,18 @@ subroutine confscript_morehelp2 use iomod,only:colorify use crest_parameters,only:stdout implicit none - write(stdout,'(/,1x,a)') 'For detailed help on option groups, use:' - write(stdout,'(3x,a)') colorify('--help general','gold')//' '// & + write (stdout,'(/,1x,a)') 'For detailed help on option groups, use:' + write (stdout,'(3x,a)') colorify('--help general','gold')//' '// & & colorify('--help compare','gold')//' '//colorify('--help conf','gold') - write(stdout,'(3x,a)') colorify('--help thermo','gold')//' '// & + write (stdout,'(3x,a)') colorify('--help thermo','gold')//' '// & & colorify('--help qcg','gold')//' '//colorify('--help msreact','gold') - write(stdout,'(3x,a)') colorify('--help other','gold')//' '// & + write (stdout,'(3x,a)') colorify('--help other','gold')//' '// & & colorify('--help toml','gold') - write(stdout,*) - write(stdout,'(1x,a,a)') 'View literature references with ',colorify('--cite','green') - write(stdout,'(1x,a)') 'For detailed documentation refer to:' - write(stdout,'(3x,a)') colorify('https://crest-lab.github.io/crest-docs/','blue') - write(stdout,*) + write (stdout,*) + write (stdout,'(1x,a,a)') 'View literature references with ',colorify('--cite','green') + write (stdout,'(1x,a)') 'For detailed documentation refer to:' + write (stdout,'(3x,a)') colorify('https://crest-lab.github.io/crest-docs/','blue') + write (stdout,*) end subroutine confscript_morehelp2 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC @@ -849,7 +848,7 @@ subroutine construct_boxed_headline(str,width,bold) strlen2 = wid+2 k = strlen2-strlen j = k/2 - jj = k-j-2 + jj = k-j-2 if (bold) then write (stdout,'(a)') "┃"//repeat(" ",j)//trim(str)//repeat(" ",jj)//"┃" write (stdout,'(a)') "┗"//repeat("━",wid)//"┛" @@ -871,7 +870,7 @@ subroutine print_crest_metadata() write (*,'(2x,a,t22,": ",a)') 'CREST version ',version write (*,'(2x,a,t22,": ",a)') 'timestamp ',date write (*,'(2x,a,t22,": ",a)') 'commit ',commit - l = len_trim(author) + l = len_trim(author) if (author(1:2) .eq. "'@") then write (*,'(2x,a,t22,": ",a)') 'compiled by ',"usr"//author(2:l-1) else @@ -889,7 +888,6 @@ subroutine print_crest_metadata() write (*,'(2x,a,t22,": ",a)') '-DWITH_FMLIP_RELAY',fmliprelayvar end subroutine print_crest_metadata - subroutine cat_mod(ch,pre,fname,post) implicit none integer :: ch @@ -1039,6 +1037,29 @@ subroutine gxtb_dev_warning call creststop(status_safety) end subroutine gxtb_dev_warning +!========================================================================================! + +subroutine gxtb_syscall_warning +!************************************************************* +!* Warn the user that this build runs g-xTB by invoking the +!* xtb binary via system calls (slow, temporary workaround). +!* Printed only when compiled with WITH_GXTB. +!* A proper tblite-native implementation is pending. +!************************************************************* + use crest_parameters,only:stdout + use tblite_api,only:have_gxtb + implicit none + if (have_gxtb) return + write (stdout,*) + write (stdout,'(1x,a)') repeat('!',68) + write (stdout,'(1x,a)') '! Note: g-xTB is currently invoked via the xtb binary !' + write (stdout,'(1x,a)') '! (system calls). This is a temporary implementation and !' + write (stdout,'(1x,a)') '! may be slow. A native interface via the tblite package !' + write (stdout,'(1x,a)') '! is planned for an upcoming release. !' + write (stdout,'(1x,a)') repeat('!',68) + write (stdout,*) +end subroutine gxtb_syscall_warning + !========================================================================================! !========================================================================================! @@ -1049,6 +1070,7 @@ subroutine crest_no_runtype_selected() !***************************************************** use crest_parameters,only:stdout use crest_data,only:status_safety + use iomod,only:colorify implicit none write (stdout,*) write (stdout,'(1x,a)') repeat('=',60) @@ -1061,14 +1083,14 @@ subroutine crest_no_runtype_selected() write (stdout,'(5x,a,t30,a)') '--sp','Single-point energy calculation' write (stdout,'(5x,a,t30,a)') '--opt','Structure optimization' write (stdout,'(5x,a,t30,a)') '--md','Molecular dynamics simulation' - write (stdout,'(5x,a,t30,a)') '--imtdgc/--v3','iMTD-GC conformational search' + write (stdout,'(5x,a,t30,a)') '--imtdgc/--v3','iMTD-GC conformational search '//colorify('(PREVIOUS DEFAULT)','gold') write (stdout,'(5x,a,t30,a)') '--entropy','Entropy/free-energy sampling' write (stdout,'(5x,a,t30,a)') '--mdopt','Ensemble optimization (no sorting)' write (stdout,'(5x,a,t30,a)') '--screen','Ensemble screening' write (stdout,'(5x,a,t30,a)') '--protonate','Protonation site search' write (stdout,'(5x,a,t30,a)') '--deprotonate','Deprotonation site search' write (stdout,'(5x,a,t30,a)') '--tautomerize','Tautomer generation' - write (stdout,'(5x,a,t30,a)') '--qcg','QCG workflows' + write (stdout,'(5x,a,t30,a)') '--qcg','QCG workflows' write (stdout,'(5x,a,t30,a)') '--msreact','MSREACT workflows' write (stdout,'(5x,a,t30,a)') '--bh','Basin-hopping global optimization' write (stdout,'(5x,a,t30,a)') '--sort','Ensemble sorting (CREGEN)' @@ -1078,3 +1100,101 @@ subroutine crest_no_runtype_selected() write (stdout,*) call creststop(status_safety) end subroutine crest_no_runtype_selected + +!========================================================================================! + +subroutine crest_output_summary(env) +!************************************************** +!* Print a table of output files written by CREST * +!* and a short description of their contents. * +!* Which files are listed depends on the runtype. * +!************************************************** + use crest_parameters,only:stdout + use crest_data + implicit none + type(systemdata),intent(in) :: env + character(len=72),parameter :: hbar = repeat('-',80) + + select case (env%crestver) + case (crest_imtd,crest_imtd2,crest_screen,crest_mdopt, & + & crest_sorting,crest_optimize,crest_trialopt,crest_rigcon, & + & crest_moldyn,crest_bh,crest_bhpt,crest_protonate,crest_deprotonate, & + & crest_tautomerize) + write (stdout,*) + write (stdout,*) + write (stdout,'(2x,a)') 'Important files written by CREST during this run' + write (stdout,'(1x,a)') hbar + end select + + select case (env%crestver) + ! ── iMTD-GC / sMTD-iMTD conformer search ───── + case (crest_imtd,crest_imtd2) + call wfe('crest_conformers.xyz','unique conformers (1 per rotamer group), energy-sorted') + call wfe('crest_rotamers.xyz','all structures including rotamers, with Boltzmann weights') + call wfe('crest_best.xyz','lowest-energy conformer') + call wfe('cregen.full','full CREGEN output (written when terminal output is abbreviated)') + call wfe('crest.restart','restart/checkpoint file for the iMTD-GC algorithm') + + ! ── ensemble screening / MDOPT ──────────────── + case (crest_screen) + call wfe('crest_ensemble.xyz','ensemble output') + call wfe('crest_conformers.xyz','unique conformers (1 per rotamer group), energy-sorted') + call wfe('crest_rotamers.xyz','all structures including rotamers') + call wfe('crest_best.xyz','lowest-energy structure') + + case (crest_mdopt) + call wfe('crest_ensemble.xyz','ensemble output with optimized geometries') + + ! ── standalone CREGEN sorting ───────────────── + case (crest_sorting) + call wfe('crest_conformers.xyz','unique conformers (1 per rotamer group), energy-sorted') + call wfe('crest_rotamers.xyz','all structures including rotamers') + call wfe('crest_best.xyz','lowest-energy structure') + call wfe('cregen.full','full CREGEN output (written when terminal output is abbreviated)') + + ! ── geometry optimization ───────────────────── + case (crest_optimize,crest_trialopt,crest_rigcon) + call wfe('crestopt.xyz','final optimized geometry') + call wfe('crestopt.log.xyz','step-by-step optimization trajectory') + + ! ── molecular dynamics ──────────────────────── + case (crest_moldyn) + call wfe('crest_dynamics.trj.xyz','MD trajectory (snapshots)') + + ! ── basin-hopping ───────────────────────────── + case (crest_bh,crest_bhpt) + call wfe('crest_conformers.xyz','unique conformers found by basin-hopping, energy-sorted') + call wfe('crest_rotamers.xyz','all accepted structures including rotamers') + call wfe('crest_best.xyz','lowest-energy structure') + + ! ── protonation / deprotonation / tautomers ─── + case (crest_protonate) + call wfe('crest_protonated.xyz','unique site candidates, energy-sorted') + call wfe('crest_best.xyz','lowest-energy structure') + case (crest_deprotonate) + call wfe('crest_deprotonated.xyz','unique site candidates, energy-sorted') + call wfe('crest_best.xyz','lowest-energy structure') + case (crest_tautomerize) + call wfe('crest_tautomers.xyz','unique site candidates, energy-sorted') + call wfe('crest_best.xyz','lowest-energy structure') + + case default + ! no dedicated file summary for this runtype + + end select + + select case (env%crestver) + case (crest_imtd,crest_imtd2,crest_screen,crest_mdopt, & + & crest_sorting,crest_optimize,crest_trialopt,crest_rigcon, & + & crest_moldyn,crest_bh,crest_bhpt,crest_protonate,crest_deprotonate, & + & crest_tautomerize) + + write (stdout,'(1x,a)') hbar + end select + +contains + subroutine wfe(fname,descr) + character(len=*),intent(in) :: fname,descr + write (stdout,'(1x,a,t26,''│ '',a)') fname,trim(descr) + end subroutine wfe +end subroutine crest_output_summary From 06eccc001415158807570302ac5e02ea61a29ca2 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 6 May 2026 18:17:12 +0200 Subject: [PATCH 313/374] g-xTB via tblite requires Fermi temperature 0 instead of 300 --- src/calculator/api_engrad.f90 | 8 +++++++- src/calculator/calc_type.f90 | 5 ++++- src/parsing/parse_calcdata.f90 | 1 + 3 files changed, 12 insertions(+), 2 deletions(-) diff --git a/src/calculator/api_engrad.f90 b/src/calculator/api_engrad.f90 index 08b6ad35..3f2c2d55 100644 --- a/src/calculator/api_engrad.f90 +++ b/src/calculator/api_engrad.f90 @@ -97,7 +97,13 @@ subroutine tblite_engrad(mol,calc,energy,grad,iostatus) !>-- populate parameters and wavefunction if (loadnew) then - call tblite_setup(mol,calc%chrg,calc%uhf,calc%tblitelvl,calc%etemp,calc%tblite,calc%ceh_guess) +! ── resolve effective Fermi temperature (gxtb defaults to 0 K) ─────── + block + real(wp) :: etemp_eff + etemp_eff = calc%etemp + if (calc%tblitelvl == xtblvl%gxtb .and. .not. calc%etemp_user_set) etemp_eff = 0.0_wp + call tblite_setup(mol,calc%chrg,calc%uhf,calc%tblitelvl,etemp_eff,calc%tblite,calc%ceh_guess) + end block call tblite_addsettings(calc%tblite,calc%maxscc,calc%rdwbo,calc%saveint,calc%accuracy) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 0c46b868..2e3ae22d 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -145,6 +145,7 @@ module calc_type !>--- API constructs integer :: tblitelvl = 2 real(wp) :: etemp = 300.0_wp + logical :: etemp_user_set = .false. real(wp) :: accuracy = 1.0_wp logical :: apiclean = .true. integer :: maxscc = 500 @@ -1125,6 +1126,7 @@ subroutine calculation_settings_deallocate(self) self%tblitelvl = 2 self%etemp = 300.0_wp + self%etemp_user_set = .false. self%accuracy = 1.0_wp self%apiclean = .false. self%maxscc = 500 @@ -1204,7 +1206,8 @@ subroutine calculation_settings_copy(self,src) ! ── API / backend settings ─────────────────────────────────────────────────── self%tblitelvl = src%tblitelvl - self%etemp = src%etemp + self%etemp = src%etemp + self%etemp_user_set = src%etemp_user_set self%accuracy = src%accuracy self%apiclean = src%apiclean self%maxscc = src%maxscc diff --git a/src/parsing/parse_calcdata.f90 b/src/parsing/parse_calcdata.f90 index a2143784..17f71270 100644 --- a/src/parsing/parse_calcdata.f90 +++ b/src/parsing/parse_calcdata.f90 @@ -182,6 +182,7 @@ subroutine parse_setting_auto(env,job,kv,rd) !>--- floats case ('etemp') job%etemp = kv%value_f + job%etemp_user_set = .true. case ('accuracy') job%accuracy = kv%value_f case ('weight') From c4974ca733c34b5354a2231597547bda425e5434 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 6 May 2026 18:50:27 +0200 Subject: [PATCH 314/374] port the TOML keyword "freeze" as cli arg --- src/confparse.f90 | 14 ++++++++++++++ src/printouts.f90 | 1 + 2 files changed, 15 insertions(+) diff --git a/src/confparse.f90 b/src/confparse.f90 index 5a0017e1..a2a928b3 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -62,6 +62,7 @@ subroutine parseflags(env,arg,nra) logical :: ex,bondconst character(len=:),allocatable :: argument logical,allocatable :: processedarg(:) + logical,allocatable :: atlist(:) character(len=:),allocatable :: arg1,arg2,arg3 allocate (xx(10),floats(3),strings(3)) @@ -1805,6 +1806,19 @@ subroutine parseflags(env,arg,nra) call quick_constrain_file('coord',env%nat,env%ref%at,ctmp) processedarg(i+1) = .true. + case ('-freeze') !> freeze atoms during optimization/MD + processedarg(i) = .true. + if (i+1 .le. nra) then + ctmp = arg1 + call get_atlist(env%ref%nat,atlist,ctmp,env%ref%at) + env%calc%nfreeze = count(atlist) + call move_alloc(atlist,env%calc%freezelist) + processedarg(i+1) = .true. + write (stdout,'(2x,a,1x,i0,1x,a)') '-freeze :',env%calc%nfreeze,'atoms frozen' + else + call parseflags_missing(argument) + end if + case ('-nocbonds') processedarg(i) = .true. bondconst = .false. diff --git a/src/printouts.f90 b/src/printouts.f90 index c7c287c9..361761a6 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -255,6 +255,7 @@ subroutine confscript_morehelp(flag) fw = 22 call help_section('Constraints (applied to ALL calculations):') call help_opt('-cinp ',fw,'Read constraints file (xtb format; formerly ".constrains")') + call help_opt('-freeze ',fw,'Freeze atoms in optimizations/MD (indices, ranges, or element symbols)') call help_opt('-cbonds []',fw,'Constrain all bonds globally (set up from topology)') call help_opt('-cbonds_md []',fw,'Constrain all bonds during MDs/MTDs only') call help_opt('-nocbonds',fw,'Disable automatic bond constraints') From adfb6f86e0c09af62e1515daa743ef9419315295 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Wed, 6 May 2026 20:17:08 +0200 Subject: [PATCH 315/374] Add hybrid method selection cli args --- src/algos/propcalc.f90 | 89 +++++++++++++++- src/classes.f90 | 3 + src/confparse.f90 | 73 ++++--------- src/iomod.F90 | 19 ++++ src/legacy_wrappers.f90 | 4 + src/parsing/CMakeLists.txt | 1 + src/parsing/confparse2.f90 | 1 + src/parsing/meson.build | 1 + src/parsing/parse_hybrid.f90 | 191 +++++++++++++++++++++++++++++++++++ src/printouts.f90 | 7 +- 10 files changed, 330 insertions(+), 59 deletions(-) create mode 100644 src/parsing/parse_hybrid.f90 diff --git a/src/algos/propcalc.f90 b/src/algos/propcalc.f90 index 01cef584..d4b4b4f3 100644 --- a/src/algos/propcalc.f90 +++ b/src/algos/propcalc.f90 @@ -23,8 +23,9 @@ !> See git history for reference. subroutine propcalc(iname,imode,env,tim) - use crest_parameters + use crest_parameters use crest_data + use cregen_interface implicit none character(len=*),intent(in) :: iname integer,intent(in) :: imode @@ -43,8 +44,9 @@ subroutine propcalc(iname,imode,env,tim) case (p_prop_reopt) !> TODO: Vtight reoptimization for all conformers (was: xtb --opt vtight) case (p_prop_multilevel:p_prop_multilevel+9) - !> TODO: Multilevel/hybrid reoptimization of entire CRE, e.g. GFN2@GFF - !> (was: xtb --opt vtight with gfnver2) + !> Post-search re-optimization of the conformer ensemble at the higher level. + !> Input iname is typically crest_rotamers.xyz; output is crest_reopt.xyz. + call crest_multilevel_reopt(iname,env,tim) case (p_prop_dipole) !> TODO: Singlepoint + dipole extraction (was: xtb --sp, grep molecular dipole) case (p_prop_rerank) @@ -54,3 +56,84 @@ subroutine propcalc(iname,imode,env,tim) end select end subroutine propcalc + +!========================================================================================! + +subroutine crest_multilevel_reopt(iname,env,tim) +!******************************************************************* +!* Read the ensemble iname, optimize all structures using the +!* calculator tagged with refine_lvl == refine%post_opt (set by the +!* A@B hybrid keyword), sort via CREGEN, and write crest_reopt.xyz. +!* +!* The refine_stage mechanism in calculator.F90 is used to activate +!* only the post-search calculator during crest_oloop. +!* +!* Input: +!* iname - path to input ensemble (e.g. crest_rotamers.xyz) +!* Output: +!* crest_reopt.xyz (sorted conformer ensemble at the higher level) +!******************************************************************* + use crest_parameters,only:wp,stdout,bohr + use crest_data + use crest_calculator + use strucrd + use parallel_interface + use cregen_interface + use iomod,only:drawbox,catdel + implicit none + character(len=*),intent(in) :: iname + type(systemdata),intent(inout) :: env + type(timer),intent(inout) :: tim + integer :: nat,nall,T,Tn,old_stage + real(wp),allocatable :: xyz(:,:,:),eread(:) + integer,allocatable :: at(:) + character(len=*),parameter :: outname = 'crest_reopt.xyz' + logical :: ex + + inquire(file=iname,exist=ex) + if (.not.ex) then + write(stdout,'(a,a,a)') '**WARNING** ',trim(iname),' not found, skipping multilevel reopt' + return + end if + + call tim%start(16,'Multilevel reopt') + + call rdensembleparam(iname,nat,nall) + if (nall < 1) then + write(stdout,*) '**WARNING** empty ensemble, skipping multilevel reopt' + call tim%stop(16) + return + end if + allocate(xyz(3,nat,nall),at(nat),eread(nall)) + call rdensemble(iname,nat,nall,at,xyz,eread) +! ── crest_oloop requires Bohr ──────────────────────────────────── + xyz = xyz/bohr + + call new_ompautoset(env,'auto',nall,T,Tn) + + write(stdout,*) + call drawbox(stdout,'MULTILEVEL ENSEMBLE REOPT',charset=7,width=51,ltab=10) + write(stdout,'(1x,a,i0,a,1x,a)') & + & 'Re-optimizing ',nall,' structures of file ',trim(iname) + +! ── activate only the post-search calculator ───────────────────── + old_stage = env%calc%refine_stage + env%calc%refine_stage = refine%post_opt + + call crest_oloop(env,nat,nall,at,xyz,eread,.true.) + + env%calc%refine_stage = old_stage + +! ── back to Angstrom, write output ─────────────────────────────── + xyz = xyz*bohr + call wrensemble(outname,nat,nall,at,xyz,eread) + + write(stdout,'(/,a,a,a)') 'Re-optimized ensemble written to <',outname,'>' + +! ── sort via CREGEN ────────────────────────────────────────────── + call newcregen(env,0,outname) + call catdel('cregen.out.tmp') + + deallocate(xyz,at,eread) + call tim%stop(16) +end subroutine crest_multilevel_reopt diff --git a/src/classes.f90 b/src/classes.f90 index 36d43d77..0de4d3a5 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -144,6 +144,9 @@ module crest_data integer :: geoopt = 3 integer :: ConfSolv = 4 integer :: deltaG = 5 + !> post_opt (= 10): post-search re-optimization via pqueue job 51 (e.g. A@B) + !> Values 6-9 reserved for future inline stages. + integer :: post_opt = 10 end type refine_type type(refine_type), parameter,public :: refine = refine_type() diff --git a/src/confparse.f90 b/src/confparse.f90 index a2a928b3..de5fcb70 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -46,6 +46,7 @@ subroutine parseflags(env,arg,nra) use optimize_module use parse_inputfile use crest_restartlog + use parse_hybrid implicit none type(systemdata),intent(inout) :: env @@ -64,6 +65,8 @@ subroutine parseflags(env,arg,nra) logical,allocatable :: processedarg(:) logical,allocatable :: atlist(:) character(len=:),allocatable :: arg1,arg2,arg3 + character(len=:),allocatable :: hybrid_quality,hybrid_workhorse + character(len=4) :: hybrid_mode allocate (xx(10),floats(3),strings(3)) ctmp = '' @@ -1009,6 +1012,7 @@ subroutine parseflags(env,arg,nra) argument = argument(2:) end if if (argument .ne. '') then + !========================================================================================! !-------- switch between legacy (systemcall) and new code (API) implementations !========================================================================================! @@ -1438,58 +1442,6 @@ subroutine parseflags(env,arg,nra) env%gfnver = '--gxtb' write (stdout,'(2x,a)') 'Note: --gxtb_dev is deprecated, redirecting to --gxtb.' - case ('-gfn2@gfn0','-gfn2@gfn1','-gfn2@gff','-gfn2@ff','-gfn2@gfnff') - processedarg(i) = .true. - if (.not.env%legacy) then !TODO - write (stdout,'("> ",a,1x,a)') argument,'option not yet available with new calculator' - error stop - end if - select case (argument) !> GFN2ON - case ('-gfn2@gfn0') - env%gfnver = '--gfn0' - case ('-gfn2@gfn1') - env%gfnver = '--gfn1' - case ('-gfn2@gff','-gfn2@ff','-gfn2@gfnff') - env%gfnver = '--gff' - env%mdstep = 2.0d0 - case default - env%gfnver = '--gfn2' - end select !> GFN2ON - env%gfnver2 = '--gfn2' - call env%addjob(51) - call env%checkhy() - env%reweight = .false. - - case ('-gfn2//gfnff') - processedarg(i) = .true. - if (.not.env%legacy) then !TODO - write (stdout,'("> ",a,1x,a)') argument,'option only available with TOML setup in new calculator'// & - & " or the --refine flag" - error stop - end if - env%gfnver = '--gff' - env%mdstep = 2.0d0 - env%gfnver2 = '--gfn2' - env%reweight = .true. - env%mdstep = 2.0d0 - env%hmass = 4.0d0 - ctype = 1 !> bond constraint - bondconst = .true. - env%cts%cbonds_md = .true. - env%checkiso = .true. - if (i+1 .le. nra) then - ctmp = arg1 - else - ctmp = '' - end if - if (ctmp(1:1) .ne. '-'.and.index(ctmp,'opt') .ne. 0) then - processedarg(i+1) = .true. - env%altopt = .true. - write (stdout,'(2x,a,a)') argument,' : GFN-FF MDs + GFN2 opt.' - else - write (stdout,'(2x,a,a)') argument,' : energy reweighting' - end if - case ('-refine','-rsp','-ropt') !> add one refinement step (via cmd only one is possible) processedarg(i) = .true. env%legacy = .false. !> new calculators only! @@ -1500,6 +1452,18 @@ subroutine parseflags(env,arg,nra) processedarg(i+1) = .true. end if + case default !> catch composite method arguments: A@B, A//B, A/sp/B, A/opt/B + if (argument(1:1) == '-') then + call parse_hybrid_argument(argument(2:),hybrid_quality,hybrid_workhorse, & + & hybrid_mode,io) + if (io == 0) then + processedarg(i) = .true. + env%legacy = .false. + call setup_hybrid_calc(env,trim(hybrid_workhorse), & + & trim(hybrid_quality),trim(hybrid_mode)) + end if + end if + case ('-charges') !> read charges from file for GFN-FF calcs. processedarg(i) = .true. ctmp = arg1 @@ -2951,8 +2915,6 @@ subroutine parseflags(env,arg,nra) case ('-keepscratch') processedarg(i) = .true. env%keepScratch = .true. - case default - continue end select !> ARGPARSER1 !========================================================================================! end if @@ -3480,3 +3442,6 @@ end subroutine inputcoords !========================================================================================! !========================================================================================! + +!========================================================================================! +!========================================================================================! diff --git a/src/iomod.F90 b/src/iomod.F90 index 47712c13..000a803d 100644 --- a/src/iomod.F90 +++ b/src/iomod.F90 @@ -867,6 +867,25 @@ end function colorify !=========================================================================================! subroutine drawbox(prch,str,width,charset,padl,padr,ltab,procedual,color) + !*********************************************************************** + !* Print a text string inside a drawn box to Fortran unit prch. + !* + !* Arguments: + !* prch - Fortran output unit (e.g. stdout) + !* str - text to display on the centre line + !* charset - border style (default 1): + !* 1 → ****** 2 → +-+|++ 3 → === == + !* 4 → ┌─┐│└┘ 5 → ┏━┓┃┗┛ 6 → ╔═╗║╚╝ + !* 7 → ┍━┑│┕┙ (mixed: flat top/bottom, straight sides) + !* width - total box width including borders; if omitted, box is + !* sized to str + padding + !* padl/padr - inner padding spaces left/right of str (default 1 each); + !* when width is given, padl is auto-centred and padr fills + !* ltab - leading spaces before the box (default 0) + !* procedual - which lines to emit: -1=all three (default), + !* 0=top only, 1=centre line only, 2=bottom only + !* color - optional border colour name passed to colorify() + !*********************************************************************** implicit none integer,intent(in) :: prch character(len=*),intent(in) :: str diff --git a/src/legacy_wrappers.f90 b/src/legacy_wrappers.f90 index 159ccea5..664a75b4 100644 --- a/src/legacy_wrappers.f90 +++ b/src/legacy_wrappers.f90 @@ -221,6 +221,10 @@ subroutine env2calc_modify(env) env%calc%emodel = env%thermo%emodel end if +! ── apply GFN-FF special cases for CLI-only setups ─────────────── +! Also a safety net for refine_queue; duplicate-level guard is idempotent. + call env_calcdat_specialcases(env) + end subroutine env2calc_modify !================================================================================! diff --git a/src/parsing/CMakeLists.txt b/src/parsing/CMakeLists.txt index 1b52b129..e5fd6286 100644 --- a/src/parsing/CMakeLists.txt +++ b/src/parsing/CMakeLists.txt @@ -18,6 +18,7 @@ set(dir "${CMAKE_CURRENT_SOURCE_DIR}") list(APPEND srcs "${dir}/confparse2.f90" + "${dir}/parse_hybrid.f90" "${dir}/constraining.f90" "${dir}/parse_block.f90" "${dir}/parse_calcdata.f90" diff --git a/src/parsing/confparse2.f90 b/src/parsing/confparse2.f90 index e4705bf1..dabe7602 100644 --- a/src/parsing/confparse2.f90 +++ b/src/parsing/confparse2.f90 @@ -216,6 +216,7 @@ subroutine env_calcdat_specialcases(env) do i = 1,env%calc%ncalculations refine_lvl = env%calc%calcs(i)%refine_lvl if (refine_lvl <= 0) cycle + if (refine_lvl >= refine%post_opt) cycle !> post-search calcs handled via pqueue if (allocated(env%refine_queue)) then if (any(env%refine_queue(:) == refine_lvl)) cycle end if diff --git a/src/parsing/meson.build b/src/parsing/meson.build index 54f932ca..f999512f 100644 --- a/src/parsing/meson.build +++ b/src/parsing/meson.build @@ -16,6 +16,7 @@ srcs += files( 'confparse2.f90', + 'parse_hybrid.f90', 'constraining.f90', 'parse_block.f90', 'parse_calcdata.f90', diff --git a/src/parsing/parse_hybrid.f90 b/src/parsing/parse_hybrid.f90 new file mode 100644 index 00000000..5a22b3b4 --- /dev/null +++ b/src/parsing/parse_hybrid.f90 @@ -0,0 +1,191 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2024 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +!> Routines for parsing and setting up hybrid two-level method combinations +!> expressed as CLI arguments of the form A@B, A//B, A/sp/B, A/opt/B. + +module parse_hybrid + use crest_parameters + use crest_data + use crest_calculator,only:calcdata,calculation_settings + use iomod,only:lowercase + implicit none + private + + public :: parse_hybrid_argument + public :: is_valid_method + public :: setup_hybrid_calc + +contains + +!========================================================================================! + + subroutine parse_hybrid_argument(str,quality,workhorse,mode,iostat) + !*************************************************************** + !* Parse a composite method argument of the form: + !* A@B → quality=A, workhorse=B, mode='at' (post-search opt) + !* A//B → quality=A, workhorse=B, mode='sp' (inline SP refine) + !* A/sp/B → quality=A, workhorse=B, mode='sp' + !* A/opt/B → quality=A, workhorse=B, mode='opt' (inline geo-opt refine) + !* Returns iostat=0 on success, non-zero if not recognised. + !* + !* Input: + !* str - argument string (without leading dash) + !* Output: + !* quality - the higher-level method token (left of separator) + !* workhorse - the fast workhorse method token (right of separator) + !* mode - 'at', 'sp', or 'opt' + !* iostat - 0 on success + !*************************************************************** + implicit none + character(len=*),intent(in) :: str + character(len=:),intent(out),allocatable :: quality,workhorse + character(len=4),intent(out) :: mode + integer,intent(out) :: iostat + integer :: k + character(len=:),allocatable :: s + + iostat = 1 + quality = '' + workhorse = '' + mode = '' + s = lowercase(trim(str)) + + ! ── try each separator in order of specificity ──────────────── + k = index(s,'/opt/') + if (k > 0) then + quality = s(1:k-1) + workhorse = s(k+5:) + mode = 'opt' + end if + if (mode == '') then + k = index(s,'/sp/') + if (k > 0) then + quality = s(1:k-1) + workhorse = s(k+4:) + mode = 'sp' + end if + end if + if (mode == '') then + k = index(s,'//') + if (k > 0) then + quality = s(1:k-1) + workhorse = s(k+2:) + mode = 'sp' + end if + end if + if (mode == '') then + k = index(s,'@') + if (k > 0) then + quality = s(1:k-1) + workhorse = s(k+1:) + mode = 'at' + end if + end if + + if (mode == '') return + + if (.not.is_valid_method(quality)) return + if (.not.is_valid_method(workhorse)) return + iostat = 0 + end subroutine parse_hybrid_argument + +!========================================================================================! + + logical function is_valid_method(token) + !************************************************* + !* Returns .true. if token names a supported method. + !************************************************* + implicit none + character(len=*),intent(in) :: token + select case (lowercase(trim(token))) + case ('gfn0','gfn1','gfn2','gxtb','gfnff','gff') + is_valid_method = .true. + case default + is_valid_method = .false. + end select + end function is_valid_method + +!========================================================================================! + + subroutine setup_hybrid_calc(env,workhorse_str,quality_str,mode) + !******************************************************************* + !* Set up a two-level calcdata from a hybrid method pair. + !* workhorse → primary calc (refine_lvl=0, runs during iMTD-GC) + !* quality → secondary calc: + !* mode='sp' → refine_lvl=singlepoint (inline SP) + !* mode='opt' → refine_lvl=geoopt (inline opt) + !* mode='at' → refine_lvl=post_opt (post-search + pqueue 51) + !* + !* Input: + !* workhorse_str - method string for the fast workhorse (e.g. 'gfnff') + !* quality_str - method string for the quality level (e.g. 'gfn2') + !* mode - 'sp', 'opt', or 'at' + !******************************************************************* + implicit none + type(systemdata),intent(inout) :: env + character(len=*),intent(in) :: workhorse_str,quality_str,mode + type(calculation_settings) :: cal_work,cal_qual + integer :: rlvl + + select case (trim(mode)) + case ('sp'); rlvl = refine%singlepoint + case ('opt'); rlvl = refine%geoopt + case ('at'); rlvl = refine%post_opt + case default; rlvl = refine%singlepoint + end select + + ! ── workhorse (active during normal search) ──────────────────── + call cal_work%create(workhorse_str) + cal_work%chrg = env%chrg + cal_work%uhf = env%uhf + cal_work%refine_lvl = 0 + call cal_work%autocomplete(1) + call env%calc%add(cal_work) + + ! ── quality level ────────────────────────────────────────────── + call cal_qual%create(quality_str) + cal_qual%chrg = env%chrg + cal_qual%uhf = env%uhf + cal_qual%refine_lvl = rlvl + call cal_qual%autocomplete(2) + call env%calc%add(cal_qual) + + ! ── register refine_queue / pqueue ──────────────────────────── + if (trim(mode) == 'at') then + call env%addjob(51) + call env%checkhy() + write(stdout,'(2x,a,"@",a,a)') trim(quality_str),trim(workhorse_str), & + & ' : post-search re-optimization of conformer ensemble' + else + ! Mirror what env2calc does for --refine: populate refine_queue now + ! so the inline refine path is active even without a TOML input file. + call env%addrefine(rlvl) + if (trim(mode) == 'opt') then + write(stdout,'(2x,a,"/opt/",a,a)') trim(quality_str),trim(workhorse_str), & + & ' : inline geometry refinement' + else + write(stdout,'(2x,a,"//",a,a)') trim(quality_str),trim(workhorse_str), & + & ' : inline singlepoint re-ranking' + end if + end if + end subroutine setup_hybrid_calc + +!========================================================================================! +end module parse_hybrid diff --git a/src/printouts.f90 b/src/printouts.f90 index 361761a6..61da903b 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -226,8 +226,11 @@ subroutine confscript_morehelp(flag) call help_opt('-gfn0',fw,'Use GFN0-xTB') call help_opt('-gff/-gfnff',fw,'Use GFN-FF (bond constraints applied automatically)') call help_opt('-gxtb',fw,'Use g-xTB (requires special build)') - call help_opt('-gfn2//gfnff',fw,'GFN-FF trajectories with GFN2-xTB energy reweighting') - call help_opt('-refine ',fw,'Post-process conformers at a higher level') + call help_opt('-A//B -A/sp/B',fw,'sampling at B; inline SP re-ranking at A (e.g. -gfn2//gfnff)') + call help_opt('-A/opt/B',fw,'sampling at B; inline geometry refinement at A') + call help_opt('-A@B',fw,'sampling at B; post-search re-optimization of ensemble at A') + write(stdout,'(9x,a)') 'A, B in: gfn0, gfn1, gfn2, gxtb, gfnff' + call help_opt('-refine ',fw,'Post-process conformers at a higher level (single step)') call help_opt('-optlev ',fw,'Optimization convergence level for ALL semiempirical calculations') write (stdout,'(9x,a)') ' = crude, vloose, loose, normal, tight, vtight, extreme' call help_opt('-dscal []',fw,'Scale dispersion energy in MD/MTD simulations') From 936e8bdda4b77cde267be50f873b76079e67b847 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 7 May 2026 16:33:18 +0200 Subject: [PATCH 316/374] Experimental branch static build test --- .../workflows/build-static-experimental.yml | 206 ++++++++++++++++++ 1 file changed, 206 insertions(+) create mode 100644 .github/workflows/build-static-experimental.yml diff --git a/.github/workflows/build-static-experimental.yml b/.github/workflows/build-static-experimental.yml new file mode 100644 index 00000000..5a58065a --- /dev/null +++ b/.github/workflows/build-static-experimental.yml @@ -0,0 +1,206 @@ +name: Static builds (experimental branch) + +on: + push: + branches: + - experimental + +env: + BUILD_DIR: _build + PIP_PACKAGES: >- + meson!=1.8.0 + cmake + ninja + PIP_EXTRAS: >- + pkgconfig + numpy + ase + matplotlib + +jobs: + build-static: + runs-on: ${{ matrix.os }} + + strategy: + fail-fast: false + matrix: + include: + # Linux x86_64 — GNU static (CMake) + - { os: ubuntu-latest, build-type: static, + toolchain: { compiler: gcc, version: '14', build: cmake } } + + # Linux x86_64 — Intel LLVM static (Meson; better ifx static support) + - { os: ubuntu-latest, build-type: static, + toolchain: { compiler: intel, version: '2025.3', mkl_version: '2025.3', build: meson } } + + # Linux aarch64 — GNU static (CMake; Intel oneAPI is x86-only) + - { os: ubuntu-24.04-arm, build-type: static, + toolchain: { compiler: gcc, version: '14', build: cmake } } + + # macOS arm64 — dynamic release (CMake) + # macOS has no static libpthread/libSystem, so fully-static builds are + # not possible. This produces a dynamic binary; users need Homebrew GCC + # and OpenBLAS (see release notes). + - { os: macos-latest, build-type: release, + toolchain: { compiler: gcc, version: '14', build: cmake } } + + defaults: + run: + shell: bash + + steps: + - name: Checkout code + uses: actions/checkout@v4 + + - name: Setup Python + uses: actions/setup-python@v5 + with: + python-version: "3.10" + + # --- Compiler setup ---------------------------------------------------- + + - name: Install GCC using setup-fortran + if: ${{ contains(matrix.toolchain.compiler, 'gcc') }} + uses: fortran-lang/setup-fortran@v1 + with: + compiler: ${{ matrix.toolchain.compiler }} + version: ${{ matrix.toolchain.version }} + + - name: Install libopenblas (Linux GCC builds) + if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.toolchain.compiler, 'gcc') }} + run: | + sudo apt-get update + sudo apt-get install -y libopenblas-dev + + - name: Install OpenBLAS (macOS) + if: ${{ contains(matrix.os, 'macos') }} + run: | + brew update + brew install openblas + echo "PKG_CONFIG_PATH=/usr/local/opt/openblas/lib/pkgconfig:/opt/homebrew/opt/openblas/lib/pkgconfig" >> $GITHUB_ENV + echo "LDFLAGS=-L/usr/local/opt/openblas/lib -L/opt/homebrew/opt/openblas/lib" >> $GITHUB_ENV + echo "CPPFLAGS=-I/usr/local/opt/openblas/include -I/opt/homebrew/opt/openblas/include" >> $GITHUB_ENV + + - name: Prepare for Intel cache restore + if: ${{ contains(matrix.toolchain.compiler, 'intel') }} + run: | + sudo mkdir -p /opt/intel + sudo chown $USER /opt/intel + + - name: Cache Intel installation + if: ${{ contains(matrix.toolchain.compiler, 'intel') }} + id: cache-install + uses: actions/cache@v4 + with: + path: /opt/intel/oneapi + key: install-${{ matrix.toolchain.compiler }}-${{ matrix.toolchain.version }}-${{ matrix.toolchain.mkl_version }}-${{ matrix.os }} + + - name: Install Intel Compiler + if: ${{ contains(matrix.toolchain.compiler, 'intel') && steps.cache-install.outputs.cache-hit != 'true' }} + uses: fortran-lang/setup-fortran@v1 + with: + compiler: ${{ matrix.toolchain.compiler }} + version: ${{ matrix.toolchain.version }} + + - name: Install Intel MKL + if: ${{ contains(matrix.toolchain.compiler, 'intel') && steps.cache-install.outputs.cache-hit != 'true' }} + run: | + sudo apt-get install -y \ + intel-oneapi-mkl-${{ matrix.toolchain.mkl_version }} \ + intel-oneapi-mkl-devel-${{ matrix.toolchain.mkl_version }} + + - name: Setup Intel oneAPI environment + if: ${{ contains(matrix.toolchain.compiler, 'intel') }} + run: | + source /opt/intel/oneapi/setvars.sh --force + printenv >> $GITHUB_ENV + + - name: Set compiler environment variables + run: | + if [ ! -n "$FC" ]; then + if [ "${{ matrix.toolchain.compiler }}" = "gcc" ]; then + echo "FC=gfortran" >> $GITHUB_ENV + echo "CC=gcc" >> $GITHUB_ENV + elif [ "${{ matrix.toolchain.compiler }}" = "intel" ]; then + echo "FC=ifx" >> $GITHUB_ENV + echo "CC=icx" >> $GITHUB_ENV + fi + fi + echo "COMPILER_VERSION=${{ matrix.toolchain.version }}" >> $GITHUB_ENV + + # --- Dependencies & submodules ----------------------------------------- + + - name: Git submodules checkout + run: git submodule update --init + + - name: Install build dependencies + run: | + pip3 install ${{ env.PIP_PACKAGES }} ${{ env.PIP_EXTRAS }} + + # --- Configure --------------------------------------------------------- + + - name: Configure build (CMake, static) + if: ${{ matrix.toolchain.build == 'cmake' && matrix.build-type == 'static' }} + run: > + cmake -B${{ env.BUILD_DIR }} + -GNinja + -DCMAKE_BUILD_TYPE=RelWithDebInfo + -DCMAKE_INSTALL_PREFIX=$PWD/_dist + -DCMAKE_INSTALL_LIBDIR=lib + -DWITH_TESTS=OFF + -DSTATICBUILD=ON + + - name: Configure build (CMake, macOS dynamic release) + if: ${{ matrix.toolchain.build == 'cmake' && matrix.build-type == 'release' }} + run: > + cmake -B${{ env.BUILD_DIR }} + -GNinja + -DCMAKE_BUILD_TYPE=Release + -DCMAKE_INSTALL_PREFIX=$PWD/_dist + -DCMAKE_INSTALL_LIBDIR=lib + -DWITH_TESTS=OFF + + - name: Configure build (Meson, Intel static) + if: ${{ matrix.toolchain.build == 'meson' && matrix.build-type == 'static' }} + run: > + meson setup ${{ env.BUILD_DIR }} + --buildtype=release + --prefix=$PWD/_dist + --libdir=lib + --warnlevel=0 + --native-file=config/intel-llvm.ini + -Dstatic=true + -Dlapack=mkl + -Dtests=false + + # --- Build / install --------------------------------------------------- + + - name: Build project + run: ninja -C ${{ env.BUILD_DIR }} + + - name: Install project + run: | + ninja -C ${{ env.BUILD_DIR }} install + echo "CREST_PREFIX=$PWD/_dist" >> $GITHUB_ENV + + - name: Create package + run: | + mkdir crest + cp COPYING crest/LICENSE + cp COPYING.LESSER crest/LICENSE.LESSER + cp _dist/bin/crest crest/ + ARCH=$(uname -m) + UNAME_OS=$(uname -s | tr '[:upper:]' '[:lower:]') + COMPILER_NAME="${{ matrix.toolchain.compiler }}" + [ "$COMPILER_NAME" = "gcc" ] && COMPILER_NAME="gnu" + [ "$COMPILER_NAME" = "intel" ] && COMPILER_NAME="intel" + OUTPUT="crest-${COMPILER_NAME}-${{ matrix.toolchain.version }}-${UNAME_OS}-${ARCH}.tar" + tar cvf "$OUTPUT" crest + xz -T0 "$OUTPUT" + echo "CREST_OUTPUT=${OUTPUT}.xz" >> $GITHUB_ENV + + - name: Upload package + uses: actions/upload-artifact@v4 + with: + name: ${{ env.CREST_OUTPUT }} + path: ${{ env.CREST_OUTPUT }} From aa2221862ce2253cab8b2556ccf50af8f172b946 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 7 May 2026 17:13:28 +0200 Subject: [PATCH 317/374] Update build-upload.yml workflow --- .../workflows/build-static-experimental.yml | 4 +--- .github/workflows/build-upload.yml | 20 +++++++++++++++---- 2 files changed, 17 insertions(+), 7 deletions(-) diff --git a/.github/workflows/build-static-experimental.yml b/.github/workflows/build-static-experimental.yml index 5a58065a..74177d29 100644 --- a/.github/workflows/build-static-experimental.yml +++ b/.github/workflows/build-static-experimental.yml @@ -1,9 +1,7 @@ name: Static builds (experimental branch) on: - push: - branches: - - experimental + workflow_dispatch: env: BUILD_DIR: _build diff --git a/.github/workflows/build-upload.yml b/.github/workflows/build-upload.yml index 6957fdf8..50ac0b9e 100644 --- a/.github/workflows/build-upload.yml +++ b/.github/workflows/build-upload.yml @@ -31,15 +31,17 @@ jobs: # Linux x86_64 — Intel LLVM static (Meson; better ifx static support) - { os: ubuntu-latest, build-type: static, - toolchain: { compiler: intel, version: '2025.1', mkl_version: '2025.1', build: meson } } + toolchain: { compiler: intel, version: '2025.3', mkl_version: '2025.3', build: meson } } # Linux aarch64 — GNU static (CMake; Intel oneAPI is x86-only) - { os: ubuntu-24.04-arm, build-type: static, toolchain: { compiler: gcc, version: '14', build: cmake } } - # macOS arm64 — GNU mostly-static (CMake) - # Note: macOS does not support fully-static executables; system libs remain dynamic. - - { os: macos-latest, build-type: static, + # macOS arm64 — dynamic release (CMake) + # macOS has no static libpthread/libSystem, so fully-static builds are + # not possible. This produces a dynamic binary; users need Homebrew GCC + # and OpenBLAS (see release notes). + - { os: macos-latest, build-type: release, toolchain: { compiler: gcc, version: '14', build: cmake } } defaults: @@ -148,6 +150,16 @@ jobs: -DWITH_TESTS=OFF -DSTATICBUILD=ON + - name: Configure build (CMake, macOS dynamic release) + if: ${{ matrix.toolchain.build == 'cmake' && matrix.build-type == 'release' }} + run: > + cmake -B${{ env.BUILD_DIR }} + -GNinja + -DCMAKE_BUILD_TYPE=Release + -DCMAKE_INSTALL_PREFIX=$PWD/_dist + -DCMAKE_INSTALL_LIBDIR=lib + -DWITH_TESTS=OFF + - name: Configure build (Meson, Intel static) if: ${{ matrix.toolchain.build == 'meson' && matrix.build-type == 'static' }} run: > From 5807032e0038dd59afe55ecf585da3b9d73b9c11 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 7 May 2026 21:49:37 +0200 Subject: [PATCH 318/374] -rerank and -reopt flags --- src/algos/propcalc.f90 | 116 +++++++++++++++++++++++++++++++++++----- src/classes.f90 | 10 +++- src/confparse.f90 | 22 ++++++++ src/crest_main.f90 | 1 - src/legacy_wrappers.f90 | 32 ++++++++++- src/printouts.f90 | 2 + 6 files changed, 167 insertions(+), 16 deletions(-) diff --git a/src/algos/propcalc.f90 b/src/algos/propcalc.f90 index d4b4b4f3..153b17bd 100644 --- a/src/algos/propcalc.f90 +++ b/src/algos/propcalc.f90 @@ -44,9 +44,25 @@ subroutine propcalc(iname,imode,env,tim) case (p_prop_reopt) !> TODO: Vtight reoptimization for all conformers (was: xtb --opt vtight) case (p_prop_multilevel:p_prop_multilevel+9) - !> Post-search re-optimization of the conformer ensemble at the higher level. - !> Input iname is typically crest_rotamers.xyz; output is crest_reopt.xyz. - call crest_multilevel_reopt(iname,env,tim) + !> Post-search processing of the conformer ensemble at a higher level. + !> Dispatched by job number; input is typically crest_rotamers.xyz. + block + integer :: saved_stage + saved_stage = env%calc%refine_stage + select case (imode) + case (p_prop_multilevel+1) !> A@B post-search geo-opt (existing) + env%calc%refine_stage = refine%post_opt + call crest_multilevel_reopt(iname,env,tim) + case (p_prop_multilevel+2) !> --rerank post-search SP re-ranking + call crest_rerank_sp(iname,env,tim) + case (p_prop_multilevel+3) !> --reopt post-search geo-opt (standalone) + env%calc%refine_stage = refine%post_reopt + call crest_multilevel_reopt(iname,env,tim) + case default + write (stdout,'(a,i0,a)') 'propcalc: multilevel mode ',imode,' not implemented' + end select + env%calc%refine_stage = saved_stage + end block case (p_prop_dipole) !> TODO: Singlepoint + dipole extraction (was: xtb --sp, grep molecular dipole) case (p_prop_rerank) @@ -62,11 +78,11 @@ end subroutine propcalc subroutine crest_multilevel_reopt(iname,env,tim) !******************************************************************* !* Read the ensemble iname, optimize all structures using the -!* calculator tagged with refine_lvl == refine%post_opt (set by the -!* A@B hybrid keyword), sort via CREGEN, and write crest_reopt.xyz. +!* calculator whose refine_lvl matches env%calc%refine_stage, +!* sort via CREGEN, and write crest_reopt.xyz. !* -!* The refine_stage mechanism in calculator.F90 is used to activate -!* only the post-search calculator during crest_oloop. +!* The caller is responsible for setting env%calc%refine_stage +!* to the desired level before this routine is called. !* !* Input: !* iname - path to input ensemble (e.g. crest_rotamers.xyz) @@ -84,7 +100,7 @@ subroutine crest_multilevel_reopt(iname,env,tim) character(len=*),intent(in) :: iname type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim - integer :: nat,nall,T,Tn,old_stage + integer :: nat,nall,T,Tn real(wp),allocatable :: xyz(:,:,:),eread(:) integer,allocatable :: at(:) character(len=*),parameter :: outname = 'crest_reopt.xyz' @@ -116,11 +132,85 @@ subroutine crest_multilevel_reopt(iname,env,tim) write(stdout,'(1x,a,i0,a,1x,a)') & & 'Re-optimizing ',nall,' structures of file ',trim(iname) -! ── activate only the post-search calculator ───────────────────── +! ── refine_stage is set by the caller; run geo-opt ─────────────── + call crest_oloop(env,nat,nall,at,xyz,eread,.true.) + +! ── back to Angstrom, write output ─────────────────────────────── + xyz = xyz*bohr + call wrensemble(outname,nat,nall,at,xyz,eread) + + write(stdout,'(/,a,a,a)') 'Re-optimized ensemble written to <',outname,'>' + +! ── sort via CREGEN ────────────────────────────────────────────── + call newcregen(env,0,outname) + call catdel('cregen.out.tmp') + + deallocate(xyz,at,eread) + call tim%stop(16) +end subroutine crest_multilevel_reopt + +!========================================================================================! + +subroutine crest_rerank_sp(iname,env,tim) +!******************************************************************* +!* Read the ensemble iname, run single-point energies using the +!* calculator tagged with refine_lvl == refine%post_sp (= 11, +!* set by the --rerank keyword), re-sort via CREGEN, and write +!* crest_reopt.xyz. Geometries are not changed. +!* +!* Input: +!* iname - path to input ensemble (e.g. crest_rotamers.xyz) +!* Output: +!* crest_reopt.xyz (ensemble re-ranked by higher-level SP energies) +!******************************************************************* + use crest_parameters,only:wp,stdout,bohr + use crest_data + use crest_calculator + use strucrd + use parallel_interface + use cregen_interface + use iomod,only:drawbox,catdel + implicit none + character(len=*),intent(in) :: iname + type(systemdata),intent(inout) :: env + type(timer),intent(inout) :: tim + integer :: nat,nall,T,Tn,old_stage + real(wp),allocatable :: xyz(:,:,:),eread(:) + integer,allocatable :: at(:) + character(len=*),parameter :: outname = 'crest_reopt.xyz' + logical :: ex + + inquire(file=iname,exist=ex) + if (.not.ex) then + write(stdout,'(a,a,a)') '**WARNING** ',trim(iname),' not found, skipping SP rerank' + return + end if + + call tim%start(16,'Post-search SP rerank') + + call rdensembleparam(iname,nat,nall) + if (nall < 1) then + write(stdout,*) '**WARNING** empty ensemble, skipping SP rerank' + call tim%stop(16) + return + end if + allocate(xyz(3,nat,nall),at(nat),eread(nall)) + call rdensemble(iname,nat,nall,at,xyz,eread) +! ── crest_sploop requires coordinates in Bohr ──────────────────── + xyz = xyz/bohr + + call new_ompautoset(env,'auto',nall,T,Tn) + + write(stdout,*) + call drawbox(stdout,'POST-SEARCH SP RE-RANKING',charset=7,width=51,ltab=10) + write(stdout,'(1x,a,i0,a,1x,a)') & + & 'Re-ranking ',nall,' structures of file ',trim(iname) + +! ── activate only the SP reranking calculator ──────────────────── old_stage = env%calc%refine_stage - env%calc%refine_stage = refine%post_opt + env%calc%refine_stage = refine%post_sp - call crest_oloop(env,nat,nall,at,xyz,eread,.true.) + call crest_sploop(env,nat,nall,at,xyz,eread) env%calc%refine_stage = old_stage @@ -128,7 +218,7 @@ subroutine crest_multilevel_reopt(iname,env,tim) xyz = xyz*bohr call wrensemble(outname,nat,nall,at,xyz,eread) - write(stdout,'(/,a,a,a)') 'Re-optimized ensemble written to <',outname,'>' + write(stdout,'(/,a,a,a)') 'Re-ranked ensemble written to <',outname,'>' ! ── sort via CREGEN ────────────────────────────────────────────── call newcregen(env,0,outname) @@ -136,4 +226,4 @@ subroutine crest_multilevel_reopt(iname,env,tim) deallocate(xyz,at,eread) call tim%stop(16) -end subroutine crest_multilevel_reopt +end subroutine crest_rerank_sp diff --git a/src/classes.f90 b/src/classes.f90 index 0de4d3a5..6d8d19cc 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -144,9 +144,13 @@ module crest_data integer :: geoopt = 3 integer :: ConfSolv = 4 integer :: deltaG = 5 - !> post_opt (= 10): post-search re-optimization via pqueue job 51 (e.g. A@B) + !> post_opt (= 10): post-search re-optimization via pqueue job 51 (e.g. A@B) + !> post_sp (= 11): post-search SP reranking via pqueue job 52 (--rerank) + !> post_reopt (= 12): post-search geo-opt standalone via pqueue job 53 (--reopt) !> Values 6-9 reserved for future inline stages. integer :: post_opt = 10 + integer :: post_sp = 11 + integer :: post_reopt = 12 end type refine_type type(refine_type), parameter,public :: refine = refine_type() @@ -411,6 +415,8 @@ module crest_data character(len=:),allocatable :: solv !> the entrie gbsa flag including solvent character(len=20) :: gfnver = '' !> GFN version character(len=20) :: gfnver2 = '' !> GFN version (multilevel) + character(len=40) :: rerank_lvl = '' !> method for post-search SP reranking (--rerank) + character(len=40) :: reopt_lvl = '' !> method for post-search geo-opt standalone (--reopt) character(len=20) :: lmover = '' !> GFN version for LMO computation in xtb_lmo subroutine character(len=512) :: ProgName = '' !> name of the xtb executable (+ path) character(len=512) :: ProgIFF = '' !> name of xtbiff for QCG-mode @@ -1218,6 +1224,8 @@ subroutine systemdata_copy(self,src) self%solvent = src%solvent self%gfnver = src%gfnver self%gfnver2 = src%gfnver2 + self%rerank_lvl = src%rerank_lvl + self%reopt_lvl = src%reopt_lvl self%lmover = src%lmover self%ProgName = src%ProgName self%ProgIFF = src%ProgIFF diff --git a/src/confparse.f90 b/src/confparse.f90 index de5fcb70..084e900d 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -1452,6 +1452,28 @@ subroutine parseflags(env,arg,nra) processedarg(i+1) = .true. end if + case ('-rerank') !> post-search SP reranking at a higher level (pqueue job 52) + processedarg(i) = .true. + env%legacy = .false. + if (i+1 .le. nra) then + env%rerank_lvl = lowercase(trim(arg1)) + processedarg(i+1) = .true. + call env%addjob(p_prop_multilevel+2) + write (stdout,'(2x,a,1x,a,a)') argument,trim(env%rerank_lvl), & + & ' : post-search SP re-ranking of conformer ensemble' + end if + + case ('-reopt') !> post-search geometry re-optimization (standalone, pqueue job 53) + processedarg(i) = .true. + env%legacy = .false. + if (i+1 .le. nra) then + env%reopt_lvl = lowercase(trim(arg1)) + processedarg(i+1) = .true. + call env%addjob(p_prop_multilevel+3) + write (stdout,'(2x,a,1x,a,a)') argument,trim(env%reopt_lvl), & + & ' : post-search re-optimization of conformer ensemble' + end if + case default !> catch composite method arguments: A@B, A//B, A/sp/B, A/opt/B if (argument(1:1) == '-') then call parse_hybrid_argument(argument(2:),hybrid_quality,hybrid_workhorse, & diff --git a/src/crest_main.f90 b/src/crest_main.f90 index 89aacbfb..9261ee9e 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -331,7 +331,6 @@ program CREST call tim%stop(15) case (p_prop_multilevel:p_prop_multilevel+9) !hybrid reoptimization (e.g. gfn2@gff) call propcalc(infile,j,env,tim) - infile = 'crest_reopt.xyz' case (70) !PCA and clustering call ccegen(env,.true.,conformerfile) case (555) diff --git a/src/legacy_wrappers.f90 b/src/legacy_wrappers.f90 index 664a75b4..698b96a9 100644 --- a/src/legacy_wrappers.f90 +++ b/src/legacy_wrappers.f90 @@ -35,7 +35,7 @@ subroutine env2calc(env,calc,molin) !> OUTPUT type(calcdata) :: calc !> LOCAL - type(calculation_settings) :: cal,cal2 + type(calculation_settings) :: cal,cal2,cal_rerank,cal_reopt type(coord) :: mol !>--- Calculator level @@ -105,6 +105,36 @@ subroutine env2calc(env,calc,molin) call env%addrefine(refine%singlepoint) end if +!>--- Post-search SP reranking level (--rerank) + if (trim(env%rerank_lvl) .ne. '') then + call cal_rerank%create(trim(env%rerank_lvl)) + cal_rerank%chrg = cal%chrg + cal_rerank%uhf = cal%uhf + cal_rerank%spin_polarized = cal%spin_polarized + if (env%gbsa) then + cal_rerank%solvmodel = cal%solvmodel + cal_rerank%solvent = cal%solvent + end if + call cal_rerank%autocomplete(2) + cal_rerank%refine_lvl = refine%post_sp + call calc%add(cal_rerank) + end if + +!>--- Post-search geometry re-optimization level (--reopt) + if (trim(env%reopt_lvl) .ne. '') then + call cal_reopt%create(trim(env%reopt_lvl)) + cal_reopt%chrg = cal%chrg + cal_reopt%uhf = cal%uhf + cal_reopt%spin_polarized = cal%spin_polarized + if (env%gbsa) then + cal_reopt%solvmodel = cal%solvmodel + cal_reopt%solvent = cal%solvent + end if + call cal_reopt%autocomplete(2) + cal_reopt%refine_lvl = refine%post_reopt + call calc%add(cal_reopt) + end if + if (.not.allocated(env%calc%temperatures)) then if (.not.allocated(env%thermo%temps)) then call env%thermo%get_temps() diff --git a/src/printouts.f90 b/src/printouts.f90 index 61da903b..32e77da5 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -230,6 +230,8 @@ subroutine confscript_morehelp(flag) call help_opt('-A/opt/B',fw,'sampling at B; inline geometry refinement at A') call help_opt('-A@B',fw,'sampling at B; post-search re-optimization of ensemble at A') write(stdout,'(9x,a)') 'A, B in: gfn0, gfn1, gfn2, gxtb, gfnff' + call help_opt('-rerank ',fw,'Post-search SP re-ranking of conformer ensemble at ') + call help_opt('-reopt ',fw,'Post-search geometry optimization of conformer ensemble at ') call help_opt('-refine ',fw,'Post-process conformers at a higher level (single step)') call help_opt('-optlev ',fw,'Optimization convergence level for ALL semiempirical calculations') write (stdout,'(9x,a)') ' = crude, vloose, loose, normal, tight, vtight, extreme' From f7e09d0faf053b55b13ff0516c3eb09efaaf353e Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 7 May 2026 22:13:05 +0200 Subject: [PATCH 319/374] multilevel keyword compatibility with --opt --- src/algos/optimization.f90 | 32 +++++++++++++++++++++++++++++--- src/calculator/calc_type.f90 | 17 ++++++++++++++++- src/classes.f90 | 2 +- 3 files changed, 46 insertions(+), 5 deletions(-) diff --git a/src/algos/optimization.f90 b/src/algos/optimization.f90 index cd9ec4b7..8655b47b 100644 --- a/src/algos/optimization.f90 +++ b/src/algos/optimization.f90 @@ -21,8 +21,11 @@ subroutine crest_optimization(env,tim) !*********************************************** !* subroutine crest_optimization !* This routine implements a standalone runtype -!* to perform geometry optimization for the -!* specified input file (read from env%ref) +!* to perform geometry optimization for the +!* specified input file (read from env%ref). +!* An optional inline refinement step is run +!* after geometry optimization when refine_queue +!* is allocated (e.g. set by --A//B or --refine). !*********************************************** use crest_parameters,only:wp,stdout,bohr use crest_data @@ -88,8 +91,31 @@ subroutine crest_optimization(env,tim) call calculation_summary(calc,mol,energy,grad,molnew) write (stdout,*) - write (stdout,'(a)') '> Optimized geometry written to crestopt.xyz' gnorm = norm2(grad) + +! ── optional inline refinement (e.g. --A//B or --refine) ───────── + if (allocated(env%refine_queue)) then + do i = 1,size(env%refine_queue,1) + select case (env%refine_queue(i)) + case (refine%singlepoint) + write (stdout,'(a)') '> Running SP refinement ...' + calc%refine_stage = refine%singlepoint + call engrad(molnew,calc,energy,grad,io) + calc%refine_stage = 0 + gnorm = norm2(grad) + if (io == 0) write (stdout,'(1x,a,f20.10,a)') 'Refined energy: ',energy,' Eh' + case (refine%geoopt) + write (stdout,'(a)') '> Re-optimizing at higher level ...' + mol = molnew + calc%refine_stage = refine%geoopt + call optimize_geometry(mol,molnew,calc,energy,grad,pr,wr,io) + calc%refine_stage = 0 + gnorm = norm2(grad) + end select + end do + end if + + write (stdout,'(a)') '> Optimized geometry written to crestopt.xyz' write (atmp,'(1x,"Etot=",f16.10,1x,"g norm=",f12.8)') energy,gnorm molnew%comment = trim(atmp) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 2e3ae22d..d6cbb4cc 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -1424,7 +1424,22 @@ subroutine calculation_settings_info(self,iunit) end if if (self%refine_lvl > 0) then write (atmp,*) 'refinement stage' - write (iunit,fmt1) atmp,self%refine_lvl + block + character(len=20) :: rtmp + select case (self%refine_lvl) + case (1); rtmp = 'singlepoint' + case (2); rtmp = 'correction' + case (3); rtmp = 'geoopt' + case (4); rtmp = 'ConfSolv' + case (5); rtmp = 'deltaG' + case (10); rtmp = 'post_opt' + case (11); rtmp = 'post_sp' + case (12); rtmp = 'post_reopt' + case default + write (rtmp,'(i0)') self%refine_lvl + end select + write (iunit,fmt3) atmp,trim(rtmp) + end block end if !> system data diff --git a/src/classes.f90 b/src/classes.f90 index 6d8d19cc..ac7a4527 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -845,7 +845,7 @@ subroutine add_to_refinequeue(self,refinetype) allocate (qdum(idum+1)) qdum(1:idum) = self%refine_queue(1:idum) qdum(idum+1) = refinetype - call move_alloc(qdum,self%pqueue) + call move_alloc(qdum,self%refine_queue) end if return end subroutine add_to_refinequeue From 5dc2ac34f121087d2908ecfaa59a8ca6c1ef39bd Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 7 May 2026 22:32:02 +0200 Subject: [PATCH 320/374] deprecate -for flag --- src/confparse.f90 | 32 +++++++++++--------------------- 1 file changed, 11 insertions(+), 21 deletions(-) diff --git a/src/confparse.f90 b/src/confparse.f90 index 084e900d..fb193bbc 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -526,26 +526,8 @@ subroutine parseflags(env,arg,nra) write (stdout,'(2x,''Note: Use of GFN-FF required for stereoisomer generation.'')') exit - case ('-forall','-for') !> property mode with ensemble as input - processedarg(i) = .true. - env%properties = p_propcalc - atmp = '' - env%ensemblename = 'none selected' - if (nra .ge. (i+1)) atmp = adjustl(arg(i+1)) - if ((atmp(1:1) /= '-').and.(len_trim(atmp) .ge. 1)) then - env%ensemblename = trim(atmp) - processedarg(i+1) = .true. - end if - inquire (file=env%ensemblename,exist=ex) - if (.not.ex) then - write (stdout,'(1x,a,a,a)') 'invalid ensemble file <',trim(env%ensemblename),'>. exit.' - error stop - end if - call xyz2coord(env%ensemblename,'coord') !> write coord from lowest structure - env%inputcoords = env%ensemblename !> just for a printout - if (argument == '-forall') then - env%protb%alldivers = .true. - end if + case ('-forall','-for') !> property mode with ensemble as input (deprecated) + call parseflags_deprecated(argument) exit case ('-rrhoav') !> Hessians along given ensemble and average @@ -3134,10 +3116,18 @@ subroutine parseflags_missing(arg) end subroutine parseflags_missing subroutine parseflags_deprecated(arg) + !********************************************** + !* Print a deprecation error and stop. + !********************************************** use crest_parameters + use crest_data implicit none character(len=*),intent(in) :: arg - write (stdout,'(a)') '** WARNING ** '//trim(arg)//' is deprecated!' + write (stdout,'(/,a)') repeat('!',60) + write (stdout,'(a)') ' DEPRECATED FLAG: '//trim(arg) + write (stdout,'(a)') ' This flag has been removed. Please update your input.' + write (stdout,'(a,/)') repeat('!',60) + call creststop(status_safety) end subroutine parseflags_deprecated subroutine parseflags_cli_summary(nra,args,processedarg) From cc36974ab796ada5f1b039e38bf80559dc35a5a8 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Thu, 7 May 2026 23:47:52 +0200 Subject: [PATCH 321/374] --ensemblehess and --finalhess keywords --- src/algos/numhess.f90 | 84 +++++++++++++++++++++++++++++++++++++++++ src/algos/parallel.f90 | 12 ++++-- src/algos/propcalc.f90 | 85 ++++++++++++++++++++++++++++++++++++++++++ src/classes.f90 | 2 + src/confparse.f90 | 26 ++++++++++++- src/crest_main.f90 | 5 ++- src/printouts.f90 | 3 ++ 7 files changed, 211 insertions(+), 6 deletions(-) diff --git a/src/algos/numhess.f90 b/src/algos/numhess.f90 index 6c4fcea2..569e4ac2 100644 --- a/src/algos/numhess.f90 +++ b/src/algos/numhess.f90 @@ -450,3 +450,87 @@ subroutine thermo_standalone(env) deallocate (stot,gt,ht,et,temps) end subroutine thermo_standalone +!========================================================================================! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: crest_hessloop requires coordinates in Bohr + xyz = xyz/bohr +!>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Back to Angstrom + xyz = xyz*bohr +!>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<' + + call dumpenergies('crest.energies',eread) + write(stdout,'(/,a,a,a)') 'List of free energies written to <','crest.energies','>' + + deallocate(eread,at,xyz) +!========================================================================================! + call tim%stop(14) + return +end subroutine crest_ensemble_hessians + diff --git a/src/algos/parallel.f90 b/src/algos/parallel.f90 index fe52a803..e9feecb9 100644 --- a/src/algos/parallel.f90 +++ b/src/algos/parallel.f90 @@ -262,6 +262,7 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread,gt_out,stot_out) !* Concurrent numerical Hessian evaluations for an ensemble. !* Input eread is overwritten with Gibbs free energies. !* xyz must be in Bohrs. +!* eread contains only the gt@RT on output! !* Optional gt_out/stot_out return G and S at all temperatures !* from env%thermo; requires pre-allocated (nall,nt) arrays. !* @@ -298,7 +299,7 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread,gt_out,stot_out) integer :: nt,nrt real(wp),allocatable :: temps(:,:),et(:,:),ht(:,:),gt(:,:),stot(:,:) - real(wp) :: ithr,sthr,fscal + real(wp) :: ithr,sthr,fscal,rt character(len=:),allocatable :: emodel type(timer) :: profiler @@ -360,10 +361,13 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread,gt_out,stot_out) do i = 1,T temps(:,i) = env%thermo%temps(:) end do + rt = env%thermo%get_close_rt(nrt) else nt = 1 allocate (temps(nt,T),et(nt,T),ht(nt,T),gt(nt,T),stot(nt,T),source=0.0_wp) - temps = env%thermo%get_close_rt(nrt) + rt = env%thermo%get_close_rt(nrt) + temps = rt + nrt = 1 end if !>--- printout directions and timer initialization @@ -384,7 +388,7 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread,gt_out,stot_out) grads(:,:,:) = 0.0_wp !>--- loop over ensemble !$omp parallel & - !$omp shared(env,calculations,nat,nall,at,xyz,eread,grads,c,k,z,pr,wr) & + !$omp shared(env,calculations,nat,nall,at,xyz,eread,grads,c,k,z,pr,wr,nrt) & !$omp shared(mols,nested,Tn,freqs,hess,temps,et,ht,gt,stot,nat3,ithr,fscal,sthr,nt,emodel) !$omp single do i = 1,nall @@ -432,7 +436,7 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread,gt_out,stot_out) !$omp critical if (io == 0) then c = c+1 - eread(zcopy) = gt(1,job) + eread(zcopy) = gt(nrt,job) if (present(gt_out)) gt_out(zcopy,:) = gt(:,job) if (present(stot_out)) stot_out(zcopy,:) = stot(:,job) else diff --git a/src/algos/propcalc.f90 b/src/algos/propcalc.f90 index 153b17bd..0f33eb5f 100644 --- a/src/algos/propcalc.f90 +++ b/src/algos/propcalc.f90 @@ -43,6 +43,9 @@ subroutine propcalc(iname,imode,env,tim) !> TODO: Free energy in solvation, 2-step (was: xtb --sp + xtb --ohess) case (p_prop_reopt) !> TODO: Vtight reoptimization for all conformers (was: xtb --opt vtight) + case (p_prop_finalhess) + call crest_finalhess(iname,env,tim) + case (p_prop_multilevel:p_prop_multilevel+9) !> Post-search processing of the conformer ensemble at a higher level. !> Dispatched by job number; input is typically crest_rotamers.xyz. @@ -227,3 +230,85 @@ subroutine crest_rerank_sp(iname,env,tim) deallocate(xyz,at,eread) call tim%stop(16) end subroutine crest_rerank_sp + +!========================================================================================! + +subroutine crest_finalhess(iname,env,tim) +!******************************************************************* +!* Run Hessians + thermochemistry on the final conformer ensemble, +!* then re-sort via CREGEN using Gibbs free energies. +!* Falls back from crest_conformers.xyz to crest_ensemble.xyz. +!* Uses the main calculator as-is (no separate refine level). +!* Input: +!* iname - primary input file (crest_conformers.xyz) +!* Output: +!* crest_hess.xyz (intermediate), then CREGEN overwrites +!* crest_conformers.xyz / crest_ensemble.xyz sorted by Gfree +!******************************************************************* + use crest_parameters,only:wp,stdout,bohr + use crest_data + use crest_calculator + use strucrd + use parallel_interface + use cregen_interface + use iomod,only:drawbox,catdel + implicit none + character(len=*),intent(in) :: iname + type(systemdata),intent(inout) :: env + type(timer),intent(inout) :: tim + character(len=:),allocatable :: infile + integer :: nat,nall,T,Tn + real(wp),allocatable :: xyz(:,:,:),eread(:),etmp(:) + integer,allocatable :: at(:) + character(len=*),parameter :: outname = 'crest_hess.xyz' + logical :: ex + +! ── select input file with fallback to crest_ensemble.xyz ──────── + inquire(file=iname,exist=ex) + if (ex) then + infile = iname + else + inquire(file=ensemblefile,exist=ex) + if (ex) then + infile = ensemblefile + else + write(stdout,'(a)') '**WARNING** no conformer ensemble found, skipping --finalhess' + return + end if + end if + + call tim%start(16,'Final ensemble Hessians') + + call rdensembleparam(infile,nat,nall) + if (nall < 1) then + write(stdout,*) '**WARNING** empty ensemble, skipping --finalhess' + call tim%stop(16) + return + end if + allocate(xyz(3,nat,nall),at(nat),eread(nall),etmp(nall)) + call rdensemble(infile,nat,nall,at,xyz,eread) +! ── crest_hessloop requires coordinates in Bohr ────────────────── + xyz = xyz/bohr + + call new_ompautoset(env,'auto',nall,T,Tn) + + write(stdout,*) + call drawbox(stdout,'FINAL ENSEMBLE HESSIANS',charset=7,width=51,ltab=10) + write(stdout,'(1x,a,i0,a,1x,a)') & + & 'Computing Hessians for ',nall,' structures of file ',trim(infile) + + call crest_hessloop(env,nat,nall,at,xyz,etmp) + eread(:) = eread(:) + etmp(:) + +! ── back to Angstrom, write intermediate file ───────────────────── + xyz = xyz*bohr + call wrensemble(outname,nat,nall,at,xyz,eread) + write(stdout,'(/,a,a,a)') 'Hessian ensemble written to <',outname,'>' + +! ── sort via CREGEN using Gibbs free energies ──────────────────── + call newcregen(env,0,outname) + call catdel('cregen.out.tmp') + + deallocate(xyz,at,eread) + call tim%stop(16) +end subroutine crest_finalhess diff --git a/src/classes.f90 b/src/classes.f90 index ac7a4527..d2d12834 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -91,6 +91,7 @@ module crest_data integer,parameter,public :: crest_bh = 274 integer,parameter,public :: crest_bhpt = 275 integer,parameter,public :: crest_dryrun = 276 + integer,parameter,public :: crest_ensemblehess = 277 !>> < Hessian for all conformers integer,parameter,public :: p_prop_autoir = 2 !> IR spectrum averaging integer,parameter,public :: p_prop_ohess = 10 !> Optimization + Hessian + integer,parameter,public :: p_prop_finalhess = 11 !> Hessian+thermo for final conformer ensemble integer,parameter,public :: p_prop_gsolv = 13 !> Free energy in solvation (2-step) integer,parameter,public :: p_prop_reopt = 20 !> Vtight reoptimization integer,parameter,public :: p_prop_multilevel = 50 !> Multilevel/hybrid reopt base (range 50:59) diff --git a/src/confparse.f90 b/src/confparse.f90 index fb193bbc..ac17af50 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -442,6 +442,7 @@ subroutine parseflags(env,arg,nra) exit case ('-mdsp','-ensemblesp') !> Singlepoints along ensemble + processedarg(i) = .true. env%crestver = crest_ensemblesp atmp = '' env%preopt = .false. @@ -455,6 +456,21 @@ subroutine parseflags(env,arg,nra) end if exit + case ('-mdhess','-ensemblehess') !> Hessians + thermochemistry along ensemble + processedarg(i) = .true. + env%crestver = crest_ensemblehess + atmp = '' + env%preopt = .false. + env%ensemblename = 'none selected' + if (nra .ge. (i+1)) atmp = adjustl(arg(i+1)) + if ((atmp(1:1) /= '-').and.(len_trim(atmp) .ge. 1)) then + processedarg(i+1) = .true. + env%ensemblename = trim(atmp) + call xyz2coord(env%ensemblename,'coord') !> write coord from lowest structure + env%inputcoords = env%ensemblename !> just for a printout + end if + exit + case ('-pka','-pKa') !> pKa calculation script processedarg(i) = .true. env%crestver = crest_pka @@ -1456,6 +1472,13 @@ subroutine parseflags(env,arg,nra) & ' : post-search re-optimization of conformer ensemble' end if + case ('-finalhess') + processedarg(i) = .true. + env%legacy = .false. + call env%addjob(p_prop_finalhess) + write (stdout,'(2x,a,a)') argument, & + & ' : post-search Hessian + free-energy re-ranking of conformer ensemble' + case default !> catch composite method arguments: A@B, A//B, A/sp/B, A/opt/B if (argument(1:1) == '-') then call parse_hybrid_argument(argument(2:),hybrid_quality,hybrid_workhorse, & @@ -3392,7 +3415,8 @@ subroutine inputcoords(env,arg) if (.not.allocated(env%inputcoords)) env%inputcoords = 'coord' call mol%open('coord') !>-- shift to CMA and/or align according to rot.const. We have to be careful about this. - if (any((/crest_sp,crest_optimize,crest_numhessian,crest_trialopt/) == env%crestver)) then + if (any((/crest_sp,crest_optimize,crest_numhessian,crest_trialopt, & + & crest_ensemblesp,crest_ensemblehess/) == env%crestver)) then !> some runtypes should only do a CMA translation, but no rotation call CMAtrf(mol%nat,mol%nat,mol%at,mol%xyz) else if (env%crestver == crest_solv) then diff --git a/src/crest_main.f90 b/src/crest_main.f90 index 9261ee9e..1a9498a9 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -270,6 +270,9 @@ program CREST case (crest_ensemblesp) !> singlepoints along ensemble call crest_ensemble_singlepoints(env,tim) + case (crest_ensemblehess) !> Hessians + thermochemistry along ensemble + call crest_ensemble_hessians(env,tim) + case (crest_protonate) call protonate(env,tim) @@ -323,7 +326,7 @@ program CREST do i = 1,env%npq j = env%pqueue(i) select case (j) - case (p_prop_hess,p_prop_autoir,p_prop_ohess,p_prop_reopt,p_prop_dipole) + case (p_prop_hess,p_prop_autoir,p_prop_ohess,p_prop_reopt,p_prop_dipole,p_prop_finalhess) call propcalc(conformerfile,j,env,tim) case (45) call tim%start(15,'Conf. entropy evaluation') diff --git a/src/printouts.f90 b/src/printouts.f90 index 32e77da5..4b4f3175 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -232,6 +232,7 @@ subroutine confscript_morehelp(flag) write(stdout,'(9x,a)') 'A, B in: gfn0, gfn1, gfn2, gxtb, gfnff' call help_opt('-rerank ',fw,'Post-search SP re-ranking of conformer ensemble at ') call help_opt('-reopt ',fw,'Post-search geometry optimization of conformer ensemble at ') + call help_opt('-finalhess',fw,'Post-search Hessians on final ensemble, re-sort by Gibbs free energy') call help_opt('-refine ',fw,'Post-process conformers at a higher level (single step)') call help_opt('-optlev ',fw,'Optimization convergence level for ALL semiempirical calculations') write (stdout,'(9x,a)') ' = crude, vloose, loose, normal, tight, vtight, extreme' @@ -427,6 +428,8 @@ subroutine confscript_morehelp(flag) write (stdout,*) call help_section('Ensemble tools:') call help_opt('-mdopt ',fw,'Optimize every structure in an ensemble (XYZ)') + call help_opt('-mdsp ',fw,'Singlepoints for every structure in an ensemble (XYZ)') + call help_opt('-mdhess ',fw,'Hessians + thermochemistry for every structure in an ensemble (XYZ)') call help_opt('-screen ',fw,'Multi-level energy screening of an ensemble') call help_opt('-entropy []',fw,'Conformational entropy from ensemble') call help_opt('-sort',fw,'Sort ensemble structures by energy') From 75107ad0c32f080813d6734dd8e88b8271acf664 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 8 May 2026 13:09:57 +0200 Subject: [PATCH 322/374] fix some crest_multilevel_oloop calls --- src/algos/optimization.f90 | 2 +- src/algos/queueing.f90 | 5 ++--- src/algos/search_newnci.f90 | 2 +- 3 files changed, 4 insertions(+), 5 deletions(-) diff --git a/src/algos/optimization.f90 b/src/algos/optimization.f90 index 8655b47b..c3f158be 100644 --- a/src/algos/optimization.f90 +++ b/src/algos/optimization.f90 @@ -350,7 +350,7 @@ subroutine crest_ensemble_screening(env,tim) !>--- call the loop call rmrfw('crest_rotamers_') call optlev_to_multilev(3.0d0,multilevel) - call crest_multilevel_oloop(env,ensnam,multilevel) + call crest_multilevel_oloop(env,ensnam,multilevel,0) if(env%iostatus_meta .ne. 0 ) return !>--- printout diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 9b116044..6f84bd2a 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -510,7 +510,7 @@ subroutine crest_queue_reconstruct(env,tim) call crest_optimization(env,timtmp) case default call optlev_to_multilev(env%optlev,multilevel) - call crest_multilevel_oloop(env,recfile,multilevel) + call crest_multilevel_oloop(env,recfile,multilevel,0) if (env%iostatus_meta .ne. 0) return call smallheadline('FINAL GEOMETRY OPTIMIZATION IN QUEUE RECONSTRUCTION') @@ -619,7 +619,6 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) do kk = 1,nall_b structures_b(kk) = heap%layer(jj)%mols(kk) end do - !deallocate (heap%layer(jj)%mols) else if (ii == 2) then nall_s = heap%layer(jj)%nmols @@ -645,7 +644,7 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) allocate (layer%mols(kk)) write (stdout,'(2x,a,i0)') 'Max. new structs stored : ',kk - RTHR = env%rthr*aatoau !> RMSD threshold in Bohr + RTHR = env%rthr*aatoau !> RMSD threshold in Bohr ETHR = env%ethr/autokcal !> deltaE threshold in hartree duplicates = 0 T = 1 diff --git a/src/algos/search_newnci.f90 b/src/algos/search_newnci.f90 index eaf1f403..c93e531b 100644 --- a/src/algos/search_newnci.f90 +++ b/src/algos/search_newnci.f90 @@ -128,7 +128,7 @@ subroutine crest_search_newnci(env,tim) !>--- Reoptimization of trajectories call tim%start(3,'Geometry optimization') call optlev_to_multilev(env%optlev,multilevel) - call crest_multilevel_oloop(env,ensnam,multilevel) + call crest_multilevel_oloop(env,ensnam,multilevel,i) call tim%stop(3) if(env%iostatus_meta .ne. 0 ) return From 3a801c8dbc1925258aa318baa03995f4e0c4dad2 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 8 May 2026 13:23:13 +0200 Subject: [PATCH 323/374] explicit --alkylize simple keyword for completeness --- src/confparse.f90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/confparse.f90 b/src/confparse.f90 index ac17af50..f2bf13d6 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -2082,6 +2082,9 @@ subroutine parseflags(env,arg,nra) env%alkylizeskip = .false. write (stdout,'(a,1x)',advance='no') ctmp processedarg(i+1) = .true. + case ('simple') + write (stdout,'(a,1x)',advance='no') ctmp + processedarg(i+1) = .true. end select end if write (stdout,'(a)') ': automatic alkyl group dispatch' From ab7a9d843f0d72a5ed73982b6c7fe9da32420fab Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 8 May 2026 23:06:40 +0200 Subject: [PATCH 324/374] scaling logic for alkylize reconstriction --- src/algos/queueing.f90 | 81 +++++++++++++++++++++++-------- src/classes.f90 | 6 ++- src/molbuilder/construct_list.f90 | 47 ++++++++++++++++++ 3 files changed, 112 insertions(+), 22 deletions(-) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 6f84bd2a..8ecd1536 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -486,6 +486,7 @@ subroutine crest_queue_reconstruct(env,tim) env%calc => env%splitheap%origincalc call chdir(env%splitheap%origindir) + call env%splitheap%fill_inverse_depth() call recusrive_construct(env,env%splitheap,1) nall = env%splitheap%layer(1)%nmols allocate (structures(nall)) @@ -529,7 +530,8 @@ subroutine crest_queue_reconstruct(env,tim) contains recursive subroutine recusrive_construct(env,heap,targetlayer) - use irmsd_module,only:irmsd,rmsd,rmsd_cache,rmsd_core_cache + use irmsd_module,only:irmsd,rmsd,rmsd_cache,rmsd_core_cache,min_rmsd + use canonical_mod use omp_lib implicit none type(systemdata),intent(inout) :: env @@ -541,14 +543,16 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) character(len=:),allocatable :: basefile,sidefile type(coord),allocatable :: structures_b(:) type(coord),allocatable :: structures_s(:) - type(coord) :: mol + type(coord) :: mol,moltmp integer :: nall_b,nall_s,id_b,id_s,nallsq,sss integer :: iliml,ilimu,jliml,jlimu,rr,io integer :: duplicates logical :: ex,clash,duplicate - real(wp) :: RTHR,rmsval,ETHR,deltaE - type(rmsd_cache) :: rcache + real(wp) :: RTHR,rmsval,ETHR,deltaE,depthlimit + real(wp) :: layerfactor_b,layerfactor_s,weight_s,weight_b + type(rmsd_cache),allocatable :: rcache(:) type(rmsd_core_cache),allocatable :: ccache(:) + type(canonical_sorter) :: canref real(wp),allocatable :: xyzscratch(:,:,:,:) logical,allocatable :: mask(:) integer :: T,Tn,tt @@ -566,6 +570,7 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) stop end if + layer%inverse_depth = layer%inverse_depth+1.0_wp do ii = 1,layer%nnodes if (allocated(layer%childlayer)) then jj = layer%childlayer(ii) @@ -591,6 +596,7 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) write (stdout,'(1x,a,i0,a)') '--> ',nall_b,' structure(s)' end if + layerfactor_b = 1.0_wp else if (jj == 0.and.ii == 2) then @@ -610,6 +616,7 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) call rdensemble(subdirfile,nall_s,structures_s) write (stdout,'(1x,a,i0,a)') '--> ',nall_s,' structure(s)' end if + layerfactor_s = 1.0_wp else call recusrive_construct(env,heap,jj) @@ -619,6 +626,8 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) do kk = 1,nall_b structures_b(kk) = heap%layer(jj)%mols(kk) end do + layerfactor_b = heap%layer(jj)%inverse_depth + else if (ii == 2) then nall_s = heap%layer(jj)%nmols @@ -626,10 +635,13 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) do kk = 1,nall_s structures_s(kk) = heap%layer(jj)%mols(kk) end do + layerfactor_s = heap%layer(jj)%inverse_depth !deallocate (heap%layer(jj)%mols) end if end if end do + weight_s = layerfactor_s/(layerfactor_s+layerfactor_b) + weight_b = layerfactor_b/(layerfactor_s+layerfactor_b) write (stdout,*) write (stdout,'(a,i0)') 'Reconstructing layer : ',targetlayer @@ -640,8 +652,11 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) write (stdout,'(2x,a,f7.5,a)') 'ΔE threshold (ETHR) : ',env%ethr,' kcal/mol' layer%nmols = 0 - kk = nint(min(real(nall_b,wp)*real(nall_s,wp),real(env%queue_maxreconstruct,wp))) + depthlimit = real(env%queue_maxreconstruct,wp)*(env%queue_depthfac**real(targetlayer-1,wp)) + kk = nint(min(real(nall_b,wp)*real(nall_s,wp),depthlimit)) allocate (layer%mols(kk)) + write (stdout,'(2x,a,i0)') 'Capping limit : ',env%queue_maxreconstruct + write (stdout,'(2x,a,f4.2,a)') 'Depth factor : ',env%queue_depthfac,'^(layer-1)' write (stdout,'(2x,a,i0)') 'Max. new structs stored : ',kk RTHR = env%rthr*aatoau !> RMSD threshold in Bohr @@ -651,14 +666,22 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) call new_ompautoset(env,'max',kk,T,Tn) write (stdout,'(2x,a,i0)') 'OpenMP threads : ',T allocate (ccache(T)) + allocate (rcache(T)) allocate (mask(layer%refmol%nat),source=.true.) + call canref%init(layer%refmol,invtype='apsp+',heavy=.false.) + do tt = 1,T call ccache(tt)%allocate(layer%refmol%nat,scratch=.true.) + call rcache(tt)%allocate(layer%refmol%nat) + rcache(tt)%stereocheck = .not. (canref%hasstereo(layer%refmol)) + rcache(tt)%rank(:,1) = canref%rank(:) + rcache(tt)%rank(:,2) = canref%rank(:) end do do ii = 1,layer%refmol%nat if (layer%refmol%at(ii) == 1) mask(ii) = .false. end do - write (stdout,'(2x,a)') 'Recombining under heavy-atom RMSD consideration (this may take a while) ... ' +! write (stdout,'(2x,a)') 'Recombining under heavy-atom RMSD consideration (this may take a while) ... ' + write (stdout,'(2x,a)') 'Recombining under iRMSD consideration (this may take a while) ... ' call crest_oloop_pr_progress(env,kk,0) call profiler%init(1) @@ -674,14 +697,20 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) !> 3. if we have space left, increase sampling nallsq = nint(sqrt(real(kk,wp))) - if (nall_b > nall_s) then + if (nall_b < nall_s) then sssloop: do sss = 1,3 select case (sss) case (1) iliml = 1 jliml = 1 - ilimu = min(nall_b,nallsq) - jlimu = min(nall_s,nallsq) + ilimu = min(nall_b,nint(nallsq*weight_b)) + if (ilimu < nint(nallsq*weight_b)) then + jlimu = nint(real(kk/ilimu,wp)) + jlimu = min(nall_s,jlimu) + else + jlimu = min(nall_s,nint(nallsq*weight_s)) + end if + case (2) if (jlimu == nall_s) then iliml = ilimu+1 @@ -707,16 +736,19 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) duplicate = .false. !$omp parallel & - !$omp shared(duplicate,duplicates,mol,ccache,mask,ETHR) & - !$omp private(rr,tt,deltaE,rmsval) + !$omp shared(duplicate,duplicates,mol,ccache,rcache,mask,ETHR) & + !$omp private(rr,tt,deltaE,rmsval,moltmp) !$omp do schedule(dynamic) rrloop: do rr = 2,layer%nmols if (duplicate) cycle tt = omp_get_thread_num()+1 deltaE = abs(mol%energy-layer%mols(rr)%energy) if (deltaE < ETHR) then -! rmsval = irmsd(layer%mols(rr),mol,rcache=rcache,topocheck=.false.,allcanon=.true.) - rmsval = rmsd(layer%mols(rr),mol,ccache=ccache(tt),mask=mask) + call moltmp%copy(layer%mols(rr)) +! rmsval = irmsd(layer%mols(rr),mol,rcache=rcache(tt),topocheck=.false.,allcanon=.true.) +! call min_rmsd(mol,layer%mols(rr),rcache=rcache(tt),rmsdout=rmsval,align=.false.) + call min_rmsd(mol,moltmp,rcache=rcache(tt),rmsdout=rmsval,align=.false.) +! rmsval = rmsd(layer%mols(rr),mol,ccache=ccache(tt),mask=mask) !$omp critical if (rmsval < RTHR.and..not.duplicate) then duplicate = .true. @@ -739,15 +771,21 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) end do jjloop end do iiloop end do sssloop - else ! i.e., nall_b <= nall_s + else ! i.e., nall_b >= nall_s sssloop2: do sss = 1,3 select case (sss) case (1) iliml = 1 jliml = 1 - ilimu = min(nall_b,nallsq) - jlimu = min(nall_s,nallsq) + !ilimu = min(nall_b,nallsq) + jlimu = min(nall_s,nint(nallsq*weight_s)) + if (jlimu < nint(nallsq*weight_s)) then + ilimu = nint(real(kk/jlimu,wp)) + ilimu = min(nall_b,ilimu) + else + ilimu = min(nall_b,nint(nallsq*weight_b)) + end if case (2) if (ilimu == nall_b) then jliml = jlimu+1 @@ -773,16 +811,19 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) duplicate = .false. !$omp parallel & - !$omp shared(duplicate,duplicates,mol,ccache,mask,ETHR) & - !$omp private(rr,tt,deltaE,rmsval) + !$omp shared(duplicate,duplicates,mol,ccache,rcache,mask,ETHR) & + !$omp private(rr,tt,deltaE,rmsval,moltmp) !$omp do schedule(dynamic) rrloop2: do rr = 2,layer%nmols if (duplicate) cycle tt = omp_get_thread_num()+1 deltaE = abs(mol%energy-layer%mols(rr)%energy) if (deltaE < ETHR) then -! rmsval = irmsd(layer%mols(rr),mol,rcache=rcache,topocheck=.false.,allcanon=.true.) - rmsval = rmsd(layer%mols(rr),mol,ccache=ccache(tt),mask=mask) + call moltmp%copy(layer%mols(rr)) +! rmsval = irmsd(layer%mols(rr),mol,rcache=rcache(tt),topocheck=.false.,allcanon=.true.) +! call min_rmsd(mol,layer%mols(rr),rcache=rcache(tt),rmsdout=rmsval,align=.false.) + call min_rmsd(mol,moltmp,rcache=rcache(tt),rmsdout=rmsval,align=.false.) +! rmsval = rmsd(layer%mols(rr),mol,ccache=ccache(tt),mask=mask) !$omp critical if (rmsval < RTHR) then duplicate = .true. diff --git a/src/classes.f90 b/src/classes.f90 index d2d12834..5c52c55e 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -490,8 +490,9 @@ module crest_data logical :: substructure_queue = .false. type(split_atms),allocatable :: splitqueue(:) type(construct_heap) :: splitheap - integer :: queue_iter = 0 - integer :: queue_maxreconstruct = 7500 + integer :: queue_iter = 0 + integer :: queue_maxreconstruct = 7500 + real(wp) :: queue_depthfac = 0.85_wp !>--- QCG data integer :: qcg_runtype = 0 !> Default is grow, 1= ensemble & opt, 2= e_solv, 3= g_solv @@ -1320,6 +1321,7 @@ subroutine systemdata_copy(self,src) self%substructure_queue = src%substructure_queue self%queue_iter = src%queue_iter self%queue_maxreconstruct = src%queue_maxreconstruct + self%queue_depthfac = src%queue_depthfac ! splitqueue (split_atms) and splitheap (construct_heap): placeholder if (allocated(src%splitqueue)) self%splitqueue = src%splitqueue self%splitheap = src%splitheap diff --git a/src/molbuilder/construct_list.f90 b/src/molbuilder/construct_list.f90 index aa72ff23..775bec55 100644 --- a/src/molbuilder/construct_list.f90 +++ b/src/molbuilder/construct_list.f90 @@ -24,6 +24,7 @@ module molbuilder_construct_list integer :: parent = 0 integer :: parentnode = 0 integer :: nnodes = 0 + real(wp) :: inverse_depth = 0.0_wp type(coord),allocatable :: node(:) integer,allocatable :: childlayer(:) integer,allocatable :: alignmap(:,:) @@ -64,6 +65,7 @@ module molbuilder_construct_list procedure find_current_position procedure count_endpoints procedure setup_queue + procedure fill_inverse_depth end type construct_heap !> exported types @@ -257,4 +259,49 @@ subroutine setup_queue(heap) end subroutine setup_queue + subroutine fill_inverse_depth(heap) + !***************************************************** + !* Precompute inverse_depth for all layers by * + !* recursing from each root layer (parent == 0). * + !***************************************************** + implicit none + class(construct_heap),intent(inout) :: heap + integer :: ii + do ii = 1,heap%nlayer + if (heap%layer(ii)%parent == 0) then + call fill_inverse_depth_layer(heap,ii) + end if + end do + end subroutine fill_inverse_depth + + recursive subroutine fill_inverse_depth_layer(heap,layerid) + !************************************************************* + !* Recursively assign inverse_depth to layer layerid and all * + !* its descendants. Leaves get 1.0; internal layers get the * + !* sum of their children's inverse_depth values. * + !************************************************************* + implicit none + type(construct_heap),intent(inout) :: heap + integer,intent(in) :: layerid + integer :: jj,childid + real(wp) :: s + associate (lyr => heap%layer(layerid)) + if (.not.allocated(lyr%childlayer)) then + lyr%inverse_depth = 1.0_wp + return + end if + s = 0.0_wp + do jj = 1,lyr%nnodes + childid = lyr%childlayer(jj) + if (childid == 0) then + s = s+1.0_wp + else + call fill_inverse_depth_layer(heap,childid) + s = s+heap%layer(childid)%inverse_depth + end if + end do + lyr%inverse_depth = s + end associate + end subroutine fill_inverse_depth_layer + end module molbuilder_construct_list From 7d3d9f77f26966d353998f235f87be2938e2815f Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 9 May 2026 00:03:07 +0200 Subject: [PATCH 325/374] Refactor queue reconstruct --- src/algos/queueing.f90 | 280 ++++++++++++++++++----------------------- 1 file changed, 119 insertions(+), 161 deletions(-) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 8ecd1536..2e304d55 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -544,8 +544,12 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) type(coord),allocatable :: structures_b(:) type(coord),allocatable :: structures_s(:) type(coord) :: mol,moltmp - integer :: nall_b,nall_s,id_b,id_s,nallsq,sss - integer :: iliml,ilimu,jliml,jlimu,rr,io + integer :: nall_b,nall_s,id_b,id_s + integer :: rr,io,rg,nregions,max_structs + integer :: reg_blo(3),reg_bhi(3),reg_slo(3),reg_shi(3) + integer :: target_bhi,target_shi + integer :: outer_lo,outer_hi,inner_lo,inner_hi,outer_idx,inner_idx + logical :: base_is_outer integer :: duplicates logical :: ex,clash,duplicate real(wp) :: RTHR,rmsval,ETHR,deltaE,depthlimit @@ -653,17 +657,17 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) layer%nmols = 0 depthlimit = real(env%queue_maxreconstruct,wp)*(env%queue_depthfac**real(targetlayer-1,wp)) - kk = nint(min(real(nall_b,wp)*real(nall_s,wp),depthlimit)) - allocate (layer%mols(kk)) + max_structs = nint(min(real(nall_b,wp)*real(nall_s,wp),depthlimit)) + allocate (layer%mols(max_structs)) write (stdout,'(2x,a,i0)') 'Capping limit : ',env%queue_maxreconstruct write (stdout,'(2x,a,f4.2,a)') 'Depth factor : ',env%queue_depthfac,'^(layer-1)' - write (stdout,'(2x,a,i0)') 'Max. new structs stored : ',kk + write (stdout,'(2x,a,i0)') 'Max. new structs stored : ',max_structs RTHR = env%rthr*aatoau !> RMSD threshold in Bohr ETHR = env%ethr/autokcal !> deltaE threshold in hartree duplicates = 0 T = 1 - call new_ompautoset(env,'max',kk,T,Tn) + call new_ompautoset(env,'max',max_structs,T,Tn) write (stdout,'(2x,a,i0)') 'OpenMP threads : ',T allocate (ccache(T)) allocate (rcache(T)) @@ -682,174 +686,128 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) end do ! write (stdout,'(2x,a)') 'Recombining under heavy-atom RMSD consideration (this may take a while) ... ' write (stdout,'(2x,a)') 'Recombining under iRMSD consideration (this may take a while) ... ' - call crest_oloop_pr_progress(env,kk,0) + call crest_oloop_pr_progress(env,max_structs,0) call profiler%init(1) call profiler%start(1) - !> NOTE: - !> we want a balanced amount of combinations, sourcing - !> roughly equal amounts of structures from base and - !> side chain ensembles. - !> We implement some additional logic to do so: - !> 1. decide on size which is the inner loop (the smaller one) - !> 2. limit loops to square of max allowed output combis (kk) - !> 3. if we have space left, increase sampling - - nallsq = nint(sqrt(real(kk,wp))) - if (nall_b < nall_s) then - sssloop: do sss = 1,3 - select case (sss) - case (1) - iliml = 1 - jliml = 1 - ilimu = min(nall_b,nint(nallsq*weight_b)) - if (ilimu < nint(nallsq*weight_b)) then - jlimu = nint(real(kk/ilimu,wp)) - jlimu = min(nall_s,jlimu) - else - jlimu = min(nall_s,nint(nallsq*weight_s)) - end if + ! ── Precompute sampling regions ────────────────────────────── + !> Region 1 targets max_structs combinations in the correct + !> weight ratio. Regions 2–3 expand into remaining structures. + base_is_outer = (nall_b <= nall_s) + nregions = 0 + + target_bhi = nint(sqrt(real(max_structs,wp)*weight_b/weight_s)) + target_shi = nint(sqrt(real(max_structs,wp)*weight_s/weight_b)) + + reg_blo(1) = 1 + reg_slo(1) = 1 + reg_bhi(1) = min(nall_b,target_bhi) + reg_shi(1) = min(nall_s,target_shi) + !> reciprocal fill if one dimension was capped + if (reg_bhi(1) < target_bhi.and.reg_bhi(1) > 0) then + reg_shi(1) = min(nall_s,nint(real(max_structs,wp)/real(reg_bhi(1),wp))) + else if (reg_shi(1) < target_shi.and.reg_shi(1) > 0) then + reg_bhi(1) = min(nall_b,nint(real(max_structs,wp)/real(reg_shi(1),wp))) + end if + nregions = 1 + + !> Region 2: expand whichever dimension wasn't exhausted + if (reg_shi(1) == nall_s.and.reg_bhi(1) < nall_b) then + nregions = 2 + reg_blo(2) = reg_bhi(1)+1 + reg_bhi(2) = nall_b + reg_slo(2) = 1 + reg_shi(2) = nall_s + else if (reg_bhi(1) == nall_b.and.reg_shi(1) < nall_s) then + nregions = 2 + reg_blo(2) = 1 + reg_bhi(2) = nall_b + reg_slo(2) = reg_shi(1)+1 + reg_shi(2) = nall_s + else if (reg_bhi(1) < nall_b.and.reg_shi(1) < nall_s) then + !> Neither exhausted: expand larger dim first, then the other + nregions = 3 + if (base_is_outer) then + reg_blo(2) = 1 + reg_bhi(2) = reg_bhi(1) + reg_slo(2) = reg_shi(1)+1 + reg_shi(2) = nall_s + reg_blo(3) = reg_bhi(1)+1 + reg_bhi(3) = nall_b + reg_slo(3) = 1 + reg_shi(3) = nall_s + else + reg_blo(2) = reg_bhi(1)+1 + reg_bhi(2) = nall_b + reg_slo(2) = 1 + reg_shi(2) = reg_shi(1) + reg_blo(3) = 1 + reg_bhi(3) = nall_b + reg_slo(3) = reg_shi(1)+1 + reg_shi(3) = nall_s + end if + end if - case (2) - if (jlimu == nall_s) then - iliml = ilimu+1 - ilimu = nall_b + ! ── Reconstruct by iterating over regions ─────────────────── + regionloop: do rg = 1,nregions + if (base_is_outer) then + outer_lo = reg_blo(rg); outer_hi = reg_bhi(rg) + inner_lo = reg_slo(rg); inner_hi = reg_shi(rg) + else + outer_lo = reg_slo(rg); outer_hi = reg_shi(rg) + inner_lo = reg_blo(rg); inner_hi = reg_bhi(rg) + end if + do outer_idx = outer_lo,outer_hi + do inner_idx = inner_lo,inner_hi + if (base_is_outer) then + ii = outer_idx; jj = inner_idx else - jliml = jlimu+1 - jlimu = nall_s + ii = inner_idx; jj = outer_idx end if - case (3) - iliml = ilimu+1 - ilimu = nall_b - jliml = 1 - end select - iiloop: do ii = iliml,ilimu - jjloop: do jj = jliml,jlimu - call attach(structures_b(ii),structures_s(jj),layer%alignmap,mol, & - & remove_lastx=layer%ncapped,original_map=layer%position_mapping, & - & clash=clash,reficn=layer%reficn) - !> proxy energy as sum of fragments - mol%energy = structures_b(ii)%energy+structures_s(jj)%energy - if (.not.clash) then - !> check for duplicates - duplicate = .false. - - !$omp parallel & - !$omp shared(duplicate,duplicates,mol,ccache,rcache,mask,ETHR) & - !$omp private(rr,tt,deltaE,rmsval,moltmp) - !$omp do schedule(dynamic) - rrloop: do rr = 2,layer%nmols - if (duplicate) cycle - tt = omp_get_thread_num()+1 - deltaE = abs(mol%energy-layer%mols(rr)%energy) - if (deltaE < ETHR) then - call moltmp%copy(layer%mols(rr)) -! rmsval = irmsd(layer%mols(rr),mol,rcache=rcache(tt),topocheck=.false.,allcanon=.true.) -! call min_rmsd(mol,layer%mols(rr),rcache=rcache(tt),rmsdout=rmsval,align=.false.) - call min_rmsd(mol,moltmp,rcache=rcache(tt),rmsdout=rmsval,align=.false.) -! rmsval = rmsd(layer%mols(rr),mol,ccache=ccache(tt),mask=mask) - !$omp critical - if (rmsval < RTHR.and..not.duplicate) then - duplicate = .true. - duplicates = duplicates+1 - !exit rrloop - end if - !$omp end critical + + call attach(structures_b(ii),structures_s(jj),layer%alignmap,mol, & + & remove_lastx=layer%ncapped,original_map=layer%position_mapping, & + & clash=clash,reficn=layer%reficn) + mol%energy = structures_b(ii)%energy+structures_s(jj)%energy + if (.not.clash) then + duplicate = .false. + + !$omp parallel & + !$omp shared(duplicate,duplicates,mol,ccache,rcache,mask,ETHR) & + !$omp private(rr,tt,deltaE,rmsval,moltmp) + !$omp do schedule(dynamic) + do rr = 1,layer%nmols + if (duplicate) cycle + tt = omp_get_thread_num()+1 + deltaE = abs(mol%energy-layer%mols(rr)%energy) + if (deltaE < ETHR) then + call moltmp%copy(layer%mols(rr)) + call min_rmsd(mol,moltmp,rcache=rcache(tt),rmsdout=rmsval,align=.false.) + !$omp critical + if (rmsval < RTHR.and..not.duplicate) then + duplicate = .true. + duplicates = duplicates+1 end if - end do rrloop - !$omp end do - !$omp end parallel - - if (.not.duplicate) then - layer%nmols = layer%nmols+1 - layer%mols(layer%nmols) = mol - call crest_oloop_pr_progress(env,kk,layer%nmols) - if (layer%nmols == kk) exit sssloop + !$omp end critical end if + end do + !$omp end do + !$omp end parallel + + if (.not.duplicate) then + layer%nmols = layer%nmols+1 + layer%mols(layer%nmols) = mol + call crest_oloop_pr_progress(env,max_structs,layer%nmols) + if (layer%nmols == max_structs) exit regionloop end if - end do jjloop - end do iiloop - end do sssloop - else ! i.e., nall_b >= nall_s - sssloop2: do sss = 1,3 - - select case (sss) - case (1) - iliml = 1 - jliml = 1 - !ilimu = min(nall_b,nallsq) - jlimu = min(nall_s,nint(nallsq*weight_s)) - if (jlimu < nint(nallsq*weight_s)) then - ilimu = nint(real(kk/jlimu,wp)) - ilimu = min(nall_b,ilimu) - else - ilimu = min(nall_b,nint(nallsq*weight_b)) - end if - case (2) - if (ilimu == nall_b) then - jliml = jlimu+1 - jlimu = nall_s - else - iliml = ilimu+1 - ilimu = nall_b end if - case (3) - jliml = jlimu+1 - jlimu = nall_s - iliml = 1 - end select - jjloop2: do jj = jliml,jlimu - iiloop2: do ii = iliml,ilimu - call attach(structures_b(ii),structures_s(jj),layer%alignmap,mol, & - & remove_lastx=layer%ncapped,original_map=layer%position_mapping, & - & clash=clash,reficn=layer%reficn) - !> proxy energy as sum of fragments - mol%energy = structures_b(ii)%energy+structures_s(jj)%energy - if (.not.clash) then - !> check for duplicates - duplicate = .false. - - !$omp parallel & - !$omp shared(duplicate,duplicates,mol,ccache,rcache,mask,ETHR) & - !$omp private(rr,tt,deltaE,rmsval,moltmp) - !$omp do schedule(dynamic) - rrloop2: do rr = 2,layer%nmols - if (duplicate) cycle - tt = omp_get_thread_num()+1 - deltaE = abs(mol%energy-layer%mols(rr)%energy) - if (deltaE < ETHR) then - call moltmp%copy(layer%mols(rr)) -! rmsval = irmsd(layer%mols(rr),mol,rcache=rcache(tt),topocheck=.false.,allcanon=.true.) -! call min_rmsd(mol,layer%mols(rr),rcache=rcache(tt),rmsdout=rmsval,align=.false.) - call min_rmsd(mol,moltmp,rcache=rcache(tt),rmsdout=rmsval,align=.false.) -! rmsval = rmsd(layer%mols(rr),mol,ccache=ccache(tt),mask=mask) - !$omp critical - if (rmsval < RTHR) then - duplicate = .true. - duplicates = duplicates+1 - !exit rrloop2 - end if - !$omp end critical - end if - end do rrloop2 - !$omp end do - !$omp end parallel - if (.not.duplicate) then - layer%nmols = layer%nmols+1 - layer%mols(layer%nmols) = mol - call crest_oloop_pr_progress(env,kk,layer%nmols) - if (layer%nmols == kk) exit sssloop2 - end if - end if - end do iiloop2 - end do jjloop2 - end do sssloop2 - end if - if (layer%nmols < kk) then + end do + end do + end do regionloop + if (layer%nmols < max_structs) then call crest_oloop_pr_progress(env,1,1) end if - !call crest_oloop_pr_progress(env,kk,-1) write (stdout,'(2x,a)') 'done!' if (duplicates > 0) then write (stdout,'(2x,a,i0)') 'Avoided duplicates : ',duplicates From d4aac15602f31f755253353ef53875060e4c6cc5 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 15 May 2026 16:19:41 +0200 Subject: [PATCH 326/374] Activate the new protonate/deprotonate protocols by default --- src/confparse.f90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/confparse.f90 b/src/confparse.f90 index f2bf13d6..b841000b 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -116,11 +116,11 @@ subroutine parseflags(env,arg,nra) end if if (index(arg(i),'-newversion') .ne. 0) then !> as in CREST version >= 3.0 env%legacy = .false. - processedarg(i) = .true. + !processedarg(i) = .true. end if if (index(arg(i),'-legacy') .ne. 0) then !> as in CREST version <3.0 env%legacy = .true. - processedarg(i) = .true. + !processedarg(i) = .true. end if if (index(arg(i),'-dry') .ne. 0) then !> "dry" run to print settings env%dryrun = .true. @@ -515,7 +515,7 @@ subroutine parseflags(env,arg,nra) processedarg(i) = .true. env%properties = p_protonate env%crestver = crest_protonate - env%legacy = .true. !> TODO, set active at later version + env%legacy = .false. write (stdout,'(2x,a,'' : automated protonation script'')') trim(arg(i)) exit @@ -523,7 +523,7 @@ subroutine parseflags(env,arg,nra) processedarg(i) = .true. env%properties = p_deprotonate env%crestver = crest_deprotonate - env%legacy = .true. !> TODO, set active at later version + env%legacy = .false. write (stdout,'(2x,a,'' : automated deprotonation script'')') trim(arg(i)) exit @@ -531,7 +531,7 @@ subroutine parseflags(env,arg,nra) processedarg(i) = .true. env%properties = p_tautomerize env%crestver = crest_tautomerize - env%legacy = .true. !> TODO, set active at later version + env%legacy = .false. write (stdout,'(2x,a,'' : automated tautomerization script'')') trim(arg(i)) exit From 30eae3e17bcc2e97114aa0350effd1a274b9f7fd Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 15 May 2026 17:09:12 +0200 Subject: [PATCH 327/374] Update examples --- examples/README.md | 59 +++++++++++++++--------- examples/expl-0/run.sh | 31 ++++--------- examples/expl-1/input.toml | 6 +++ examples/expl-1/run.sh | 30 +++--------- examples/expl-10/input.toml | 13 ++++++ examples/expl-10/run.sh | 15 ++++++ examples/{expl-2.5 => expl-10}/struc.xyz | 0 examples/expl-11/input.toml | 6 +++ examples/expl-11/run.sh | 11 +++++ examples/{expl-3 => expl-11}/xtb.trj | 0 examples/expl-12/input.toml | 6 +++ examples/expl-12/run.sh | 12 +++++ examples/expl-12/struc.xyz | 11 +++++ examples/expl-13/input.toml | 9 ++++ examples/expl-13/run.sh | 12 +++++ examples/expl-13/struc.xyz | 14 ++++++ examples/expl-14/input.toml | 9 ++++ examples/expl-14/run.sh | 13 ++++++ examples/expl-14/struc.xyz | 26 +++++++++++ examples/expl-15/input.toml | 9 ++++ examples/expl-15/run.sh | 12 +++++ examples/expl-15/struc.xyz | 18 ++++++++ examples/expl-2.5/run.sh | 29 ------------ examples/expl-2/input.toml | 9 ++++ examples/expl-2/run.sh | 33 +++---------- examples/expl-3/input.toml | 9 ++++ examples/expl-3/run.sh | 28 ++++------- examples/expl-3/struc.xyz | 28 +++++------ examples/expl-4/input.toml | 13 ++++++ examples/expl-4/run.sh | 39 +++++----------- examples/expl-5/input.toml | 9 ++++ examples/expl-5/run.sh | 25 +++------- examples/expl-5/struc.xyz | 14 ++++++ examples/expl-6/input.toml | 15 ++++++ examples/expl-6/run.sh | 36 ++++++--------- examples/expl-6/struc.xyz | 25 +++++----- examples/expl-7/input.toml | 11 +++++ examples/expl-7/run.sh | 28 +++++------ examples/expl-7/struc.xyz | 26 +++++------ examples/expl-8/input.toml | 11 +++++ examples/expl-8/run.sh | 37 ++++++--------- examples/expl-8/struc.xyz | 40 ++++++---------- examples/expl-9/input.toml | 14 ++++++ examples/expl-9/run.sh | 35 +++++--------- examples/expl-9/struc.xyz | 32 ++++++------- examples/{expl-5 => expl-9}/xtb.trj | 0 46 files changed, 513 insertions(+), 355 deletions(-) create mode 100644 examples/expl-1/input.toml create mode 100644 examples/expl-10/input.toml create mode 100755 examples/expl-10/run.sh rename examples/{expl-2.5 => expl-10}/struc.xyz (100%) create mode 100644 examples/expl-11/input.toml create mode 100755 examples/expl-11/run.sh rename examples/{expl-3 => expl-11}/xtb.trj (100%) create mode 100644 examples/expl-12/input.toml create mode 100755 examples/expl-12/run.sh create mode 100644 examples/expl-12/struc.xyz create mode 100644 examples/expl-13/input.toml create mode 100755 examples/expl-13/run.sh create mode 100644 examples/expl-13/struc.xyz create mode 100644 examples/expl-14/input.toml create mode 100755 examples/expl-14/run.sh create mode 100644 examples/expl-14/struc.xyz create mode 100644 examples/expl-15/input.toml create mode 100755 examples/expl-15/run.sh create mode 100644 examples/expl-15/struc.xyz delete mode 100755 examples/expl-2.5/run.sh create mode 100644 examples/expl-2/input.toml create mode 100644 examples/expl-3/input.toml create mode 100644 examples/expl-4/input.toml create mode 100644 examples/expl-5/input.toml create mode 100644 examples/expl-5/struc.xyz create mode 100644 examples/expl-6/input.toml create mode 100644 examples/expl-7/input.toml create mode 100644 examples/expl-8/input.toml create mode 100644 examples/expl-9/input.toml rename examples/{expl-5 => expl-9}/xtb.trj (100%) diff --git a/examples/README.md b/examples/README.md index 36bd25ad..1f0bbfb0 100644 --- a/examples/README.md +++ b/examples/README.md @@ -1,34 +1,49 @@ # Example applications of the CREST program -This directory contains several examples for -standard applications of the `crest` program. +This directory contains examples covering the most common workflows +of the `crest` program. -Each example directory contains a input structure -(typically called `struc.xyz`) and a bash script -called `run.sh` that includes some information about -the example and will execute the calculation upon -execution. +Each example directory contains an input structure (`struc.xyz` or +similar), a shell script `run.sh`, and a TOML input file `input.toml`. -To run the example scripts simply go to the respective -directory and execute it from the command line: +## Running an example + +Go to the example directory and execute the script: ```bash +cd expl-6 ./run.sh ``` -It is assumed that the `xtb` and `crest` binaries -are present in the *PATH* variable as such. -The `run.sh` scripts will check for this, however. +The `run.sh` scripts show CLI usage. Alternatively, every example can +be run through its TOML input file: +```bash +crest input.toml +``` + +TOML files are detected automatically by their `.toml` extension. They +offer the same settings as the CLI flags but in a structured, documented +format that is easier to modify and reuse. + +It is assumed that the `crest` binary is available in `$PATH`. ## Examples -0. *dry run* of the `crest` program -1. default conformational search (iMTD-GC) -2. example for different CMD settings -3. sorting an ensemble file (CREGEN) -4. constrained conformational sampling -5. standalone optimization along a trajectory -6. NCI sampling mode (iMTD-NCI) -7. protonation site sampling -8. modified protonation site sampling -9. tautomer sampling +| # | Topic | Molecule | +|---|-------|---------| +| **0** | *Dry run* — print settings without computing | 1-propanol | +| **1** | Single-point energy | 1-propanol | +| **2** | Geometry optimization | 1-propanol | +| **3** | Optimization + Hessian (vibrational frequencies) | 1-propanol | +| **4** | Standalone MD simulation | 1-propanol | +| **5** | Default iMTD-GC conformer search | 1-propanol | +| **6** | Two-level conformer search (GFN2//GFN-FF, A//B) | 1-propanol | +| **7** | iMTD-GC with ALPB implicit solvation (GFN2) | 1-propanol | +| **8** | Quick iMTD-GC conformer search (with -finalhess) | 1-propanol | +| **9** | Standalone CREGEN ensemble sorting | 1-propanol | +| **10** | Constrained conformer search | 1-propanol | +| **11** | Ensemble optimization (mdopt) | 1-propanol | +| **12** | NCI sampling mode (iMTD-NCI) | water trimer | +| **13** | Protonation site sampling | uracil | +| **14** | Metal/ion adducts (Cs+) | alpha-D-glucose | +| **15** | Tautomer screening | guanine | diff --git a/examples/expl-0/run.sh b/examples/expl-0/run.sh index 881b7737..3745edd7 100755 --- a/examples/expl-0/run.sh +++ b/examples/expl-0/run.sh @@ -1,27 +1,12 @@ #!/bin/bash +# Dry run of CREST: prints settings and thresholds without running any calculation. +# Use this to preview the iMTD-GC setup before committing to a full run. +# Note: -dry is a CLI-only flag; see input.toml for the equivalent full-run settings. -xtbin='xtb' -crst='crest' +command -v crest >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary."; exit 1; } -command -v $xtbin >/dev/null 2>&1 || { echo >&2 "Cannot find xtb binary. Exit."; exit 1; } -command -v $crst >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary. Exit."; exit 1; } +# --- CLI run --- +crest struc.xyz -dry -if [ $xtbin == 'xtb' ] - then - $crst struc.xyz -dry - else - $crst struc.xyz -dry -xnam $xtbin - fi - -# Before starting any calculation, settings -# can be checked with the '-dry' flag. -# This will only print a summary about the -# selected settings and thresholds to the -# consol and check for the xtb binary. -# -# Every time the input file (struc.xyz) is -# something else than 'coord', a file called -# 'coord' will be (over-)written, containing -# the atomic coordinates in Bohr. CREST will -# then continue to use and overwrite this -# coord file for all further calculations. +# --- TOML run (equivalent full run without -dry) --- +# crest input.toml diff --git a/examples/expl-1/input.toml b/examples/expl-1/input.toml new file mode 100644 index 00000000..8be94e2a --- /dev/null +++ b/examples/expl-1/input.toml @@ -0,0 +1,6 @@ +# Single-point energy calculation +runtype = "singlepoint" +input = "struc.xyz" # input structure file (1-propanol) + +[[calculation.level]] +method = "gfn2" # GFN2-xTB semi-empirical Hamiltonian diff --git a/examples/expl-1/run.sh b/examples/expl-1/run.sh index 015ccee7..425cd9ca 100755 --- a/examples/expl-1/run.sh +++ b/examples/expl-1/run.sh @@ -1,27 +1,11 @@ #!/bin/bash +# Single-point GFN2-xTB energy evaluation of 1-propanol. +# Output: energy printed to stdout; no structure files are written. -xtbin='xtb' -crst='crest' - -command -v $xtbin >/dev/null 2>&1 || { echo >&2 "Cannot find xtb binary. Exit."; exit 1; } -command -v $crst >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary. Exit."; exit 1; } - -if [ $xtbin == 'xtb' ] - then - $crst struc.xyz -ewin 2.0 - else - $crst struc.xyz -ewin 2.0 -xnam $xtbin - fi - - -# This will execute a conformational search with default settings -# for the 1-propanol molecule. -# The energy window is set to 2.0 kcal/mol with the '-ewin' flag -# (instead of the default 6.0 kcal/mol window) -# Within this window there should be 4 conformers for 1-propanol -# in the gas phase. -# The 4 unique conformers can be found in the file 'crest_conformers.xyz'. -# All degenerate conformers (rotamers, pseudo-enantiomers) of the 4 structures -# can be found in the file 'crest_rotamers.xyz' +command -v crest >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary."; exit 1; } +# --- CLI run --- +crest struc.xyz -sp +# --- TOML run (equivalent settings) --- +# crest input.toml diff --git a/examples/expl-10/input.toml b/examples/expl-10/input.toml new file mode 100644 index 00000000..ba5279e7 --- /dev/null +++ b/examples/expl-10/input.toml @@ -0,0 +1,13 @@ +# Constrained iMTD-GC: atoms 1-4 (C-C-C-O backbone) frozen in Cartesian space; +# only OH dihedral angles are sampled. +runtype = "imtd-gc" +input = "struc.xyz" # input structure file (1-propanol) + +[[calculation.level]] +method = "gfnff" # GFN-FF force field + +[calculation] +freeze = "1-4" # freeze atoms 1-4 at their input Cartesian coordinates + +[cregen] +ewin = 2.0 # keep conformers within 2.0 kcal/mol of the lowest diff --git a/examples/expl-10/run.sh b/examples/expl-10/run.sh new file mode 100755 index 00000000..38774e59 --- /dev/null +++ b/examples/expl-10/run.sh @@ -0,0 +1,15 @@ +#!/bin/bash +# Constrained iMTD-GC conformer search of 1-propanol: +# the C-C-C-O backbone (atoms 1-4) is frozen; only the OH dihedral is sampled. +# Expected output: 2 conformers (different OH rotamers) in crest_conformers.xyz. + +command -v crest >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary."; exit 1; } + +# --- CLI run --- +# Step 1: generate a constraint template (.xcontrol.sample): +crest struc.xyz -constrain 1-4 +# Step 2: run the constrained conformer search: +crest struc.xyz -gfnff -cinp .xcontrol.sample -ewin 2.0 + +# --- TOML run (constraints defined directly in the input file) --- +# crest input.toml diff --git a/examples/expl-2.5/struc.xyz b/examples/expl-10/struc.xyz similarity index 100% rename from examples/expl-2.5/struc.xyz rename to examples/expl-10/struc.xyz diff --git a/examples/expl-11/input.toml b/examples/expl-11/input.toml new file mode 100644 index 00000000..dabcad9f --- /dev/null +++ b/examples/expl-11/input.toml @@ -0,0 +1,6 @@ +# Optimize every structure in an ensemble or trajectory file +runtype = "mdopt" +ensemble = "xtb.trj" # input trajectory or multi-structure XYZ file + +[[calculation.level]] +method = "gfn2" # GFN2-xTB for geometry optimization diff --git a/examples/expl-11/run.sh b/examples/expl-11/run.sh new file mode 100755 index 00000000..ac133c72 --- /dev/null +++ b/examples/expl-11/run.sh @@ -0,0 +1,11 @@ +#!/bin/bash +# Optimize all structures in a trajectory/ensemble file with GFN2-xTB. +# Output: crest_ensemble.xyz (optimized structures, not sorted) + +command -v crest >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary."; exit 1; } + +# --- CLI run --- +crest -mdopt xtb.trj + +# --- TOML run (equivalent settings) --- +# crest input.toml diff --git a/examples/expl-3/xtb.trj b/examples/expl-11/xtb.trj similarity index 100% rename from examples/expl-3/xtb.trj rename to examples/expl-11/xtb.trj diff --git a/examples/expl-12/input.toml b/examples/expl-12/input.toml new file mode 100644 index 00000000..af5fac97 --- /dev/null +++ b/examples/expl-12/input.toml @@ -0,0 +1,6 @@ +# Non-covalent interaction (NCI) conformer sampling +runtype = "nci" +input = "struc.xyz" # input structure file (water trimer) + +[[calculation.level]] +method = "gfnff" # GFN-FF for fast NCI sampling diff --git a/examples/expl-12/run.sh b/examples/expl-12/run.sh new file mode 100755 index 00000000..9fc0ba6b --- /dev/null +++ b/examples/expl-12/run.sh @@ -0,0 +1,12 @@ +#!/bin/bash +# Non-covalent interaction (NCI / iMTD-NCI) conformer sampling of a water trimer. +# A wall potential is generated automatically to prevent cluster dissociation. +# Output: crest_conformers.xyz, crest_rotamers.xyz + +command -v crest >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary."; exit 1; } + +# --- CLI run --- +crest struc.xyz -nci + +# --- TOML run (equivalent settings) --- +# crest input.toml diff --git a/examples/expl-12/struc.xyz b/examples/expl-12/struc.xyz new file mode 100644 index 00000000..5553af95 --- /dev/null +++ b/examples/expl-12/struc.xyz @@ -0,0 +1,11 @@ + 9 +FINAL HEAT OF FORMATION = 0.000000 + H -1.091354 2.083948 0.561412 + O -0.873213 1.360333 -0.037725 + H -1.126153 -0.540943 0.037240 + H 0.094609 1.245770 0.037306 + O 1.614744 0.076014 -0.037729 + O -0.741528 -1.436357 -0.037711 + H -1.259101 -1.987119 0.561339 + H 2.350402 -0.096756 0.561513 + H 1.031565 -0.704748 0.037192 diff --git a/examples/expl-13/input.toml b/examples/expl-13/input.toml new file mode 100644 index 00000000..f4f3915f --- /dev/null +++ b/examples/expl-13/input.toml @@ -0,0 +1,9 @@ +# Protonation site sampling: generates protomers by adding H+ to basic sites +runtype = "protonate" +input = "struc.xyz" # input structure file (uracil) + +[[calculation.level]] +method = "gfn2" # GFN2-xTB for protonation site ranking + +[protonation] +ewin = 30.0 # energy window for protomer selection (kcal/mol) diff --git a/examples/expl-13/run.sh b/examples/expl-13/run.sh new file mode 100755 index 00000000..0195d57a --- /dev/null +++ b/examples/expl-13/run.sh @@ -0,0 +1,12 @@ +#!/bin/bash +# Protonation site sampling of uracil with GFN2-xTB. +# Generates protomers by adding H+ to basic sites on the molecule. +# Expected output: 3 major protomers in protonated.xyz within 30 kcal/mol. + +command -v crest >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary."; exit 1; } + +# --- CLI run --- +crest struc.xyz -protonate + +# --- TOML run (equivalent settings) --- +# crest input.toml diff --git a/examples/expl-13/struc.xyz b/examples/expl-13/struc.xyz new file mode 100644 index 00000000..73524a28 --- /dev/null +++ b/examples/expl-13/struc.xyz @@ -0,0 +1,14 @@ +12 + energy: -24.614946947602 gnorm: 0.000456827525 xtb: 6.2.2 (89a525f) +O 1.01382029544030 0.03880681993718 0.26260657568622 +C 2.21194959420030 0.00777551853774 0.13894624850894 +N 2.97633014247497 1.15928881874167 0.06760158128732 +C 4.33128423994495 1.14641376546424 -0.07421492522129 +C 5.02090106234646 -0.00303350704424 -0.15435476958224 +C 4.32754207903802 -1.27903972647711 -0.09166688984675 +O 4.83244816077160 -2.37420082989590 -0.15422059425404 +N 2.94450163810970 -1.14763022456257 0.05629094590508 +H 2.46829084494664 2.03038084438831 0.12488082938105 +H 4.81038312241915 2.11362921965719 -0.11757996835012 +H 6.09011013882395 -0.02137897779485 -0.26646726330202 +H 2.41547828301905 -2.01176145142300 0.10488837035251 diff --git a/examples/expl-14/input.toml b/examples/expl-14/input.toml new file mode 100644 index 00000000..32727569 --- /dev/null +++ b/examples/expl-14/input.toml @@ -0,0 +1,9 @@ +# Metal-ion adduct generation: replace H+ with Cs+ to form adducts +runtype = "protonate" +input = "struc.xyz" # input structure file (alpha-D-glucose) + +[[calculation.level]] +method = "gfn2" # GFN2-xTB for adduct ranking + +[protonation] +swel = "Cs+" # replace added H+ with Cs+ ion (also accepts Na+, Li+, Ca2+, …) diff --git a/examples/expl-14/run.sh b/examples/expl-14/run.sh new file mode 100755 index 00000000..efce1960 --- /dev/null +++ b/examples/expl-14/run.sh @@ -0,0 +1,13 @@ +#!/bin/bash +# Metal/ion adduct generation for alpha-D-glucose with GFN2-xTB. +# Replaces H+ with Cs+ (via -swel) to generate Cs+ adducts. +# Other ions (Na+, Li+, Ca2+, …) can be used the same way. +# Output: protonated.xyz + +command -v crest >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary."; exit 1; } + +# --- CLI run --- +crest struc.xyz -protonate -swel Cs+ + +# --- TOML run (equivalent settings) --- +# crest input.toml diff --git a/examples/expl-14/struc.xyz b/examples/expl-14/struc.xyz new file mode 100644 index 00000000..a3c58227 --- /dev/null +++ b/examples/expl-14/struc.xyz @@ -0,0 +1,26 @@ + 24 +FINAL HEAT OF FORMATION = 0.000000 + O -1.240000 0.500286 0.389534 + O -3.422179 -1.988021 -1.200876 + O -1.030343 -2.500198 1.371244 + O -0.269585 -1.376682 -2.050459 + O 0.714096 0.825174 -0.948699 + O -4.564244 0.596025 -1.237038 + C -2.604750 -1.434635 -0.186435 + C -1.275745 -2.232516 0.002738 + C -2.309462 0.069148 -0.458819 + C -0.090913 -1.462394 -0.648941 + C 0.038626 -0.020969 -0.037264 + C -3.562580 0.927621 -0.299600 + H -3.175049 -1.514611 0.751562 + H -1.394054 -3.206789 -0.495459 + H -1.941229 0.164323 -1.490086 + H 0.840456 -2.024192 -0.479114 + H 0.639496 -0.057270 0.885117 + H -3.985456 0.780616 0.699514 + H -3.317920 1.993716 -0.382206 + H -4.113958 -1.329897 -1.403262 + H -1.021769 -1.655987 1.868817 + H 0.187245 -0.582574 -2.396515 + H 1.659435 0.569359 -1.034662 + H -4.311180 0.903728 -2.134995 diff --git a/examples/expl-15/input.toml b/examples/expl-15/input.toml new file mode 100644 index 00000000..b4f52c28 --- /dev/null +++ b/examples/expl-15/input.toml @@ -0,0 +1,9 @@ +# Tautomer screening via protonation/deprotonation sequences +runtype = "tautomerize" +input = "struc.xyz" # input structure file (guanine) + +[[calculation.level]] +method = "gfn2" # GFN2-xTB for tautomer ranking + +[cregen] +ewin = 10.0 # energy window for tautomer selection (kcal/mol) diff --git a/examples/expl-15/run.sh b/examples/expl-15/run.sh new file mode 100755 index 00000000..60f8ee69 --- /dev/null +++ b/examples/expl-15/run.sh @@ -0,0 +1,12 @@ +#!/bin/bash +# Tautomer screening of guanine via protonation/deprotonation sequences. +# Explores prototropic tautomers at GFN2-xTB level. +# Expected output: 5 major tautomers within 10 kcal/mol in tautomers.xyz. + +command -v crest >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary."; exit 1; } + +# --- CLI run --- +crest struc.xyz -tautomerize -ewin 10.0 + +# --- TOML run (equivalent settings) --- +# crest input.toml diff --git a/examples/expl-15/struc.xyz b/examples/expl-15/struc.xyz new file mode 100644 index 00000000..725a04d3 --- /dev/null +++ b/examples/expl-15/struc.xyz @@ -0,0 +1,18 @@ +16 + energy: -31.983681788270 gnorm: 0.000372144832 xtb: 6.2.2 (89a525f) +N 1.46226284012671 0.18335744247169 -0.07855270314916 +C 1.31781205014203 -1.15293393777405 0.05955064599303 +C 1.54055132778996 -2.13428714261960 -0.91007075980005 +C 1.98029754954570 -1.74761862944617 -2.21865239727883 +N 2.10914370306048 -0.33402358897783 -2.27674973147307 +C 1.86775867472018 0.54390043382692 -1.26343764079100 +N 1.27680953207984 -3.36757233307534 -0.37748854905490 +C 0.91461226786592 -3.14740906594264 0.84460715972356 +N 0.91768716624572 -1.81594469141732 1.17440471889163 +O 2.23471850070944 -2.39670706107528 -3.20454497820690 +N 2.11460025487082 1.85836120568312 -1.49845077783225 +H 0.67952040591559 -1.39514835256529 2.05664466916869 +H 0.63659476510547 -3.91144927326480 1.54245387480526 +H 2.43918920019300 0.01672894983906 -3.16809193535854 +H 1.78950116764777 2.49655065642122 -0.79277065540295 +H 2.15173216814906 2.19392916334893 -2.44513710915798 diff --git a/examples/expl-2.5/run.sh b/examples/expl-2.5/run.sh deleted file mode 100755 index 2215a633..00000000 --- a/examples/expl-2.5/run.sh +++ /dev/null @@ -1,29 +0,0 @@ -#!/bin/bash - -xtbin='xtb' -crst='crest' - -command -v $xtbin >/dev/null 2>&1 || { echo >&2 "Cannot find xtb binary. Exit."; exit 1; } -command -v $crst >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary. Exit."; exit 1; } - -if [ $xtbin == 'xtb' ] - then - $crst struc.xyz -ewin 2.0 -quick -prop ohess - else - $crst struc.xyz -ewin 2.0 -quick -prop ohess -xnam $xtbin - fi - -# Some further calculations can be added automatically -# after the conformer search with the '-prop' command. -# In the above example, after searching for the -# conformers of 1-propanol, each conformer is optimized -# again and frequencies are calculated (ohess). -# The conformer ensemble is then re-ranked with free -# energies from RRHO contributions. -# -# There are also some different 'quick'-modes to run -# the conformational search with reduced settings. -# With these modes the conformational space will be -# explored less extensively, but it will speed up -# the calculation. ('-quick','-squick','-mquick') - diff --git a/examples/expl-2/input.toml b/examples/expl-2/input.toml new file mode 100644 index 00000000..82479488 --- /dev/null +++ b/examples/expl-2/input.toml @@ -0,0 +1,9 @@ +# Geometry optimization +runtype = "optimize" +input = "struc.xyz" # input structure file (1-propanol) + +[calculation] +optlev = "normal" # convergence level: crude/loose/normal/tight/vtight + +[[calculation.level]] +method = "gfn2" # GFN2-xTB semi-empirical Hamiltonian diff --git a/examples/expl-2/run.sh b/examples/expl-2/run.sh index e2da43e9..e681d0ba 100755 --- a/examples/expl-2/run.sh +++ b/examples/expl-2/run.sh @@ -1,30 +1,11 @@ #!/bin/bash +# Geometry optimization of 1-propanol with GFN2-xTB. +# Output: crest_best.xyz (optimized structure) -xtbin='xtb' -crst='crest' - -command -v $xtbin >/dev/null 2>&1 || { echo >&2 "Cannot find xtb binary. Exit."; exit 1; } -command -v $crst >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary. Exit."; exit 1; } - -if [ $xtbin == 'xtb' ] - then - $crst struc.xyz -ewin 2.0 -g h2o -gfn2 -T 4 - else - $crst struc.xyz -ewin 2.0 -g h2o -gfn2 -T 4 -xnam $xtbin - fi - - -# This will execute a conformational search with some manually changed -# settings for the 1-propanol molecule. -# The GBSA implicit solvation model for H2O is employed with the -# '-g' flag. -# Furthermore, the use of GFN2-xTB is requested explicitly ('-gfn2') -# and the program is ordered to use 4 CPU threads ('-T'). -# For a 1-propanol the conformers in implicit solvation are the -# same as in the gas phase, but the relative energies should -# differ significantly. -# Unique conformers can be found in the file 'crest_conformers.xyz'. -# All degenerate conformers (rotamers, pseudo-enantiomers) -# can be found in the file 'crest_rotamers.xyz' +command -v crest >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary."; exit 1; } +# --- CLI run --- +crest struc.xyz -opt +# --- TOML run (equivalent settings) --- +# crest input.toml diff --git a/examples/expl-3/input.toml b/examples/expl-3/input.toml new file mode 100644 index 00000000..9f176ff0 --- /dev/null +++ b/examples/expl-3/input.toml @@ -0,0 +1,9 @@ +# Geometry optimization followed by Hessian (vibrational frequency) calculation +runtype = "ohess" +input = "struc.xyz" # input structure file (1-propanol) + +[calculation] +optlev = "tight" # tighter convergence before frequency calculation + +[[calculation.level]] +method = "gfn2" # GFN2-xTB semi-empirical Hamiltonian diff --git a/examples/expl-3/run.sh b/examples/expl-3/run.sh index 00d10ba9..7fb84261 100755 --- a/examples/expl-3/run.sh +++ b/examples/expl-3/run.sh @@ -1,24 +1,12 @@ #!/bin/bash +# Geometry optimization followed by numerical Hessian (vibrational frequencies) +# of 1-propanol with GFN2-xTB. +# Output: crest_best.xyz (optimized structure), vibspectrum (frequencies) -xtbin='xtb' -crst='crest' +command -v crest >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary."; exit 1; } -command -v $xtbin >/dev/null 2>&1 || { echo >&2 "Cannot find xtb binary. Exit."; exit 1; } -command -v $crst >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary. Exit."; exit 1; } - -$crst struc.xyz -cregen xtb.trj -ewin 100.0 - - -# The sorting routine from the CREST conformational search can be -# used as a standalone to sort any .xyz or .trj ensemble file. -# The above command will sort the file xtb.trj according to -# its energy and determine duplicate structures. -# Two files are written analogous to 'crest_conformers.xyz' -# and 'crest_rotamers.xyz'. -# The new file 'crest_ensemble.xyz' will contain only unique -# structures from xtb.trj, while the new file 'xtb.trj.sorted' -# is just a sorted version of the original file (without the -# -ewin flag the default 6.0 kcal/mol window will be used) -# The routine requires a reference structure which is given -# by 'struc.xyz'. +# --- CLI run --- +crest struc.xyz -ohess +# --- TOML run (equivalent settings) --- +# crest input.toml diff --git a/examples/expl-3/struc.xyz b/examples/expl-3/struc.xyz index 38692b20..4297fe9a 100644 --- a/examples/expl-3/struc.xyz +++ b/examples/expl-3/struc.xyz @@ -1,14 +1,14 @@ - 12 -FINAL HEAT OF FORMATION = -1.651323 - C 1.625257 -0.262628 -0.323273 - C 0.518221 0.706221 -0.335177 - C -0.859313 -0.005477 -0.327969 - H -1.683026 0.654493 -0.607965 - H -0.974493 -0.754480 -1.061658 - O -1.171503 -0.423846 1.012985 - H -0.837975 0.254126 1.683603 - H 0.615912 1.428650 0.457852 - H 0.597843 1.325129 -1.321583 - H 1.504113 -0.866659 0.564875 - H 2.639815 0.049302 -0.353007 - H 1.502315 -1.001480 -1.109649 +12 + +C 1.00510 -0.04436 0.07729 +C 2.52196 -0.10014 0.05638 +C 3.03386 -1.52959 -0.04885 +O 4.45512 -1.53382 -0.04957 +H 0.66450 0.99293 0.15400 +H 0.60392 -0.59767 0.93240 +H 0.58435 -0.47325 -0.83778 +H 2.92490 0.36854 0.96213 +H 2.90338 0.49174 -0.78421 +H 2.68484 -2.01184 -0.96764 +H 2.69552 -2.12845 0.80244 +H 4.74911 -1.01511 -0.81774 diff --git a/examples/expl-4/input.toml b/examples/expl-4/input.toml new file mode 100644 index 00000000..d1378bf1 --- /dev/null +++ b/examples/expl-4/input.toml @@ -0,0 +1,13 @@ +# Standalone molecular dynamics simulation +runtype = "dynamics" +input = "struc.xyz" # input structure file (1-propanol) + +[[calculation.level]] +method = "gfnff" # GFN-FF force field for fast MD + +[dynamics] +length_ps = 20.0 # total simulation length (ps) +tstep = 1.0 # integration timestep (fs) +temperature = 400.0 # thermostat target temperature (K) +dump = 100.0 # trajectory dump interval (fs) +shake = 1 # constrain X-H bonds (0 = off, 1 = X-H, 2 = all bonds) diff --git a/examples/expl-4/run.sh b/examples/expl-4/run.sh index 7f62e3c2..91cd67ad 100755 --- a/examples/expl-4/run.sh +++ b/examples/expl-4/run.sh @@ -1,32 +1,15 @@ #!/bin/bash +# Standalone molecular dynamics (MD) simulation of 1-propanol with GFN-FF. +# Runs a 20 ps NVT trajectory at 400 K. +# Output: crest_dynamics.trj (trajectory), crest_property.out (energies) -xtbin='xtb' -crst='crest' +command -v crest >/dev/null 2>&1 || { + echo >&2 "Cannot find crest binary." + exit 1 +} -command -v $xtbin >/dev/null 2>&1 || { echo >&2 "Cannot find xtb binary. Exit."; exit 1; } -command -v $crst >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary. Exit."; exit 1; } +# --- CLI run --- +crest struc.xyz -dyn -gfnff -mdtemp 400 -mdlen 20 -tstep 1.0 -if [ $xtbin == 'xtb' ] - then - $crst struc.xyz -constrain 1-4 - $crst struc.xyz -cinp .xcontrol.sample - else - $crst struc.xyz -constrain 1-4 - $crst struc.xyz -cinp .xcontorl.sample -xnam $xtbin - fi - - -# Constraint conformational sampling is possible by -# providing the constrainment info as a file -# via the '-cinp' flag. -# For detailed information about the constraining -# options see the online documentation of -# CREST and xTB. -# However, a dummy constraining file '.xcontrol.sample' -# can be written by CREST with a seperate call using -# The '-constrain ' flag. -# In the above example the carbon atoms and the oxygen -# atom of 1-propanol (atoms 1-4) will be constrained. -# In the resulting "ensemble" only conformers resulting -# from different OH dihedral angles will be present -# (2 conformers total) +# --- TOML run (equivalent settings) --- +# crest input.toml diff --git a/examples/expl-5/input.toml b/examples/expl-5/input.toml new file mode 100644 index 00000000..d2b0a0e2 --- /dev/null +++ b/examples/expl-5/input.toml @@ -0,0 +1,9 @@ +# Default iMTD-GC conformer search +runtype = "imtd-gc" +input = "struc.xyz" # input structure file (1-propanol) + +[[calculation.level]] +method = "gfnff" # GFN-FF force field for fast conformer sampling + +[cregen] +ewin = 2.0 # keep conformers within 2.0 kcal/mol of the lowest diff --git a/examples/expl-5/run.sh b/examples/expl-5/run.sh index f9a722ac..30ad4021 100755 --- a/examples/expl-5/run.sh +++ b/examples/expl-5/run.sh @@ -1,22 +1,11 @@ #!/bin/bash +# Default iMTD-GC conformer search of 1-propanol with GFN-FF. +# Expected output: ~4 unique conformers in crest_conformers.xyz within 2.0 kcal/mol. -xtbin='xtb' -crst='crest' +command -v crest >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary."; exit 1; } -command -v $xtbin >/dev/null 2>&1 || { echo >&2 "Cannot find xtb binary. Exit."; exit 1; } -command -v $crst >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary. Exit."; exit 1; } +# --- CLI run --- +crest struc.xyz -imtdgc -gfnff -ewin 2.0 -if [ $xtbin == 'xtb' ] - then - $crst -mdopt xtb.trj - else - $crst -mdopt xtb.trj -xnam $xtbin - fi - - -# A ensemble file (or MD trajectory) can also -# be optimized in a standalone application -# of CREST using the '-mdopt' flag. -# The optimized structures are written to a -# file called 'crest_ensemble.xyz', but will -# not be sorted in any way. +# --- TOML run (equivalent settings) --- +# crest input.toml diff --git a/examples/expl-5/struc.xyz b/examples/expl-5/struc.xyz new file mode 100644 index 00000000..4297fe9a --- /dev/null +++ b/examples/expl-5/struc.xyz @@ -0,0 +1,14 @@ +12 + +C 1.00510 -0.04436 0.07729 +C 2.52196 -0.10014 0.05638 +C 3.03386 -1.52959 -0.04885 +O 4.45512 -1.53382 -0.04957 +H 0.66450 0.99293 0.15400 +H 0.60392 -0.59767 0.93240 +H 0.58435 -0.47325 -0.83778 +H 2.92490 0.36854 0.96213 +H 2.90338 0.49174 -0.78421 +H 2.68484 -2.01184 -0.96764 +H 2.69552 -2.12845 0.80244 +H 4.74911 -1.01511 -0.81774 diff --git a/examples/expl-6/input.toml b/examples/expl-6/input.toml new file mode 100644 index 00000000..1a28eaf6 --- /dev/null +++ b/examples/expl-6/input.toml @@ -0,0 +1,15 @@ +# iMTD-GC conformer search with two-level (A//B) calculation: +# Level 1 – GFN-FF: fast force field used for MD/MTD sampling +# Level 2 – GFN2: re-ranks the final ensemble with single-point energies +runtype = "imtd-gc" +input = "struc.xyz" # input structure file (1-propanol) + +[[calculation.level]] +method = "gfnff" # GFN-FF force field for fast MD sampling + +[[calculation.level]] +method = "gfn2" # GFN2-xTB for accurate final ranking +refine = "singlepoint" # apply this level as single-point re-ranking step + +[cregen] +ewin = 6.0 # keep conformers within 6.0 kcal/mol of the lowest diff --git a/examples/expl-6/run.sh b/examples/expl-6/run.sh index d507701b..14d1d58c 100755 --- a/examples/expl-6/run.sh +++ b/examples/expl-6/run.sh @@ -1,27 +1,19 @@ #!/bin/bash +# Two-level iMTD-GC conformer search of 1-propanol using the A//B scheme: +# GFN-FF handles the fast MD/MTD sampling phase; GFN2 single-points +# re-rank the final ensemble. This gives good accuracy at reduced cost. +# Output: crest_conformers.xyz -xtbin='xtb' -crst='crest' +command -v crest >/dev/null 2>&1 || { + echo >&2 "Cannot find crest binary." + exit 1 +} -command -v $xtbin >/dev/null 2>&1 || { echo >&2 "Cannot find xtb binary. Exit."; exit 1; } -command -v $crst >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary. Exit."; exit 1; } - -if [ $xtbin == 'xtb' ] - then - $crst struc.xyz -nci - else - $crst struc.xyz -nci -xnam $xtbin - fi - - -# This will execute the NCI sampling mode of CREST of the -# water trimer with default settings. -# A wall-potential is automatically generated and added to -# the calculation to prevent dissociation. -# The NCI mode is a special case of the constrained sampling. -# Just like the regular conformational search unique conformers -# can be found in the file 'crest_conformers.xyz'. -# All degenerate conformers (rotamers, pseudo-enantiomers) -# can be found in the file 'crest_rotamers.xyz' +# --- CLI run (A//B: B for sampling, A for single-point re-ranking) --- +crest struc.xyz -imtdgc --gfn2//gfnff -ewin 6.0 +# Alternative: GFN-FF sampling + GFN2 geometry refinement of each conformer: +# crest struc.xyz -imtdgc --gfnff/opt/gfn2 -ewin 6.0 +# --- TOML run (equivalent settings) --- +# crest input.toml diff --git a/examples/expl-6/struc.xyz b/examples/expl-6/struc.xyz index 5553af95..4297fe9a 100644 --- a/examples/expl-6/struc.xyz +++ b/examples/expl-6/struc.xyz @@ -1,11 +1,14 @@ - 9 -FINAL HEAT OF FORMATION = 0.000000 - H -1.091354 2.083948 0.561412 - O -0.873213 1.360333 -0.037725 - H -1.126153 -0.540943 0.037240 - H 0.094609 1.245770 0.037306 - O 1.614744 0.076014 -0.037729 - O -0.741528 -1.436357 -0.037711 - H -1.259101 -1.987119 0.561339 - H 2.350402 -0.096756 0.561513 - H 1.031565 -0.704748 0.037192 +12 + +C 1.00510 -0.04436 0.07729 +C 2.52196 -0.10014 0.05638 +C 3.03386 -1.52959 -0.04885 +O 4.45512 -1.53382 -0.04957 +H 0.66450 0.99293 0.15400 +H 0.60392 -0.59767 0.93240 +H 0.58435 -0.47325 -0.83778 +H 2.92490 0.36854 0.96213 +H 2.90338 0.49174 -0.78421 +H 2.68484 -2.01184 -0.96764 +H 2.69552 -2.12845 0.80244 +H 4.74911 -1.01511 -0.81774 diff --git a/examples/expl-7/input.toml b/examples/expl-7/input.toml new file mode 100644 index 00000000..effe947c --- /dev/null +++ b/examples/expl-7/input.toml @@ -0,0 +1,11 @@ +# iMTD-GC conformer search with GFN2-xTB and ALPB implicit solvation +runtype = "imtd-gc" +input = "struc.xyz" # input structure file (1-propanol) +threads = 4 # number of parallel threads + +[[calculation.level]] +method = "gfn2" # GFN2-xTB semi-empirical Hamiltonian +alpb = "h2o" # ALPB implicit solvation model, water solvent + +[cregen] +ewin = 2.0 # keep conformers within 2.0 kcal/mol of the lowest diff --git a/examples/expl-7/run.sh b/examples/expl-7/run.sh index d1341045..7f95eff0 100755 --- a/examples/expl-7/run.sh +++ b/examples/expl-7/run.sh @@ -1,21 +1,15 @@ #!/bin/bash +# iMTD-GC conformer search of 1-propanol with GFN2-xTB and ALPB implicit solvation (water). +# Conformers in solution differ in relative energy from the gas phase. +# Uses 4 CPU threads. Output: crest_conformers.xyz -xtbin='xtb' -crst='crest' +command -v crest >/dev/null 2>&1 || { + echo >&2 "Cannot find crest binary." + exit 1 +} -command -v $xtbin >/dev/null 2>&1 || { echo >&2 "Cannot find xtb binary. Exit."; exit 1; } -command -v $crst >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary. Exit."; exit 1; } +# --- CLI run --- +crest struc.xyz -gfn2 -alpb h2o -T 4 -ewin 2.0 -imtdgc -if [ $xtbin == 'xtb' ] - then - $crst struc.xyz -protonate - else - $crst struc.xyz -protonate -xnam $xtbin - fi - - -# This command will create protomers of the uracil molecule. -# The default energy window for this application is 30 kcal/mol -# Only 3 structures should remain in the gas phase at the -# default GFN2-xTB level. -# The structures can be found in the file 'protonated.xyz' +# --- TOML run (equivalent settings) --- +# crest input.toml diff --git a/examples/expl-7/struc.xyz b/examples/expl-7/struc.xyz index 73524a28..4297fe9a 100644 --- a/examples/expl-7/struc.xyz +++ b/examples/expl-7/struc.xyz @@ -1,14 +1,14 @@ 12 - energy: -24.614946947602 gnorm: 0.000456827525 xtb: 6.2.2 (89a525f) -O 1.01382029544030 0.03880681993718 0.26260657568622 -C 2.21194959420030 0.00777551853774 0.13894624850894 -N 2.97633014247497 1.15928881874167 0.06760158128732 -C 4.33128423994495 1.14641376546424 -0.07421492522129 -C 5.02090106234646 -0.00303350704424 -0.15435476958224 -C 4.32754207903802 -1.27903972647711 -0.09166688984675 -O 4.83244816077160 -2.37420082989590 -0.15422059425404 -N 2.94450163810970 -1.14763022456257 0.05629094590508 -H 2.46829084494664 2.03038084438831 0.12488082938105 -H 4.81038312241915 2.11362921965719 -0.11757996835012 -H 6.09011013882395 -0.02137897779485 -0.26646726330202 -H 2.41547828301905 -2.01176145142300 0.10488837035251 + +C 1.00510 -0.04436 0.07729 +C 2.52196 -0.10014 0.05638 +C 3.03386 -1.52959 -0.04885 +O 4.45512 -1.53382 -0.04957 +H 0.66450 0.99293 0.15400 +H 0.60392 -0.59767 0.93240 +H 0.58435 -0.47325 -0.83778 +H 2.92490 0.36854 0.96213 +H 2.90338 0.49174 -0.78421 +H 2.68484 -2.01184 -0.96764 +H 2.69552 -2.12845 0.80244 +H 4.74911 -1.01511 -0.81774 diff --git a/examples/expl-8/input.toml b/examples/expl-8/input.toml new file mode 100644 index 00000000..33d2fc84 --- /dev/null +++ b/examples/expl-8/input.toml @@ -0,0 +1,11 @@ +# Quick iMTD-GC conformer search with reduced MTD simulation length. +# Uncomment finalhess to add a post-search Hessian and re-rank by Gibbs free energy. +runtype = "mtd_search_quick" # reduced settings; alternatives: mtd_search_squick, mtd_search_mquick +input = "struc.xyz" # input structure file (1-propanol) +# Note: -finalhess (post-search Hessian + free-energy re-ranking) is CLI-only; add it to the crest call above. + +[[calculation.level]] +method = "gfnff" # GFN-FF force field + +[cregen] +ewin = 2.0 # keep conformers within 2.0 kcal/mol of the lowest diff --git a/examples/expl-8/run.sh b/examples/expl-8/run.sh index d28b597c..d3b8404e 100755 --- a/examples/expl-8/run.sh +++ b/examples/expl-8/run.sh @@ -1,26 +1,19 @@ #!/bin/bash +# Quick iMTD-GC conformer search of 1-propanol with reduced MTD simulation length. +# Useful for a fast first survey of conformational space. +# Output: crest_conformers.xyz +# Also available: -squick (super quick) and -mquick (mega quick) modes. +# +# -finalhess adds a post-search Hessian on each conformer in the final ensemble +# and re-ranks by Gibbs free energy. -xtbin='xtb' -crst='crest' - -command -v $xtbin >/dev/null 2>&1 || { echo >&2 "Cannot find xtb binary. Exit."; exit 1; } -command -v $crst >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary. Exit."; exit 1; } - -if [ $xtbin == 'xtb' ] - then - $crst struc.xyz -protonate -swel Cs+ - else - $crst struc.xyz -protonate -swel Cs+ -xnam $xtbin - fi +command -v crest >/dev/null 2>&1 || { + echo >&2 "Cannot find crest binary." + exit 1 +} -# In a modified version of the protonation tool -# other ionization adducts can be created -# (only mono nuclear ions) -# To do this, the flag '-swel' (short for switch element) -# is used to indicate the new ion and its charge, -# e.g., Na+, Ca2+, Li+, etc. -# -# As a example the alpha-D-glucose-Cs+ adducts -# will be created at the GFN2-xTB level with the above command. -# The adducts can be found in the file 'protonated.xyz' +# --- CLI run (quick search only) --- +crest struc.xyz -quick -gfnff -ewin 2.0 -imtdgc -finalhess +# --- TOML run (equivalent settings) --- +# crest input.toml diff --git a/examples/expl-8/struc.xyz b/examples/expl-8/struc.xyz index a3c58227..4297fe9a 100644 --- a/examples/expl-8/struc.xyz +++ b/examples/expl-8/struc.xyz @@ -1,26 +1,14 @@ - 24 -FINAL HEAT OF FORMATION = 0.000000 - O -1.240000 0.500286 0.389534 - O -3.422179 -1.988021 -1.200876 - O -1.030343 -2.500198 1.371244 - O -0.269585 -1.376682 -2.050459 - O 0.714096 0.825174 -0.948699 - O -4.564244 0.596025 -1.237038 - C -2.604750 -1.434635 -0.186435 - C -1.275745 -2.232516 0.002738 - C -2.309462 0.069148 -0.458819 - C -0.090913 -1.462394 -0.648941 - C 0.038626 -0.020969 -0.037264 - C -3.562580 0.927621 -0.299600 - H -3.175049 -1.514611 0.751562 - H -1.394054 -3.206789 -0.495459 - H -1.941229 0.164323 -1.490086 - H 0.840456 -2.024192 -0.479114 - H 0.639496 -0.057270 0.885117 - H -3.985456 0.780616 0.699514 - H -3.317920 1.993716 -0.382206 - H -4.113958 -1.329897 -1.403262 - H -1.021769 -1.655987 1.868817 - H 0.187245 -0.582574 -2.396515 - H 1.659435 0.569359 -1.034662 - H -4.311180 0.903728 -2.134995 +12 + +C 1.00510 -0.04436 0.07729 +C 2.52196 -0.10014 0.05638 +C 3.03386 -1.52959 -0.04885 +O 4.45512 -1.53382 -0.04957 +H 0.66450 0.99293 0.15400 +H 0.60392 -0.59767 0.93240 +H 0.58435 -0.47325 -0.83778 +H 2.92490 0.36854 0.96213 +H 2.90338 0.49174 -0.78421 +H 2.68484 -2.01184 -0.96764 +H 2.69552 -2.12845 0.80244 +H 4.74911 -1.01511 -0.81774 diff --git a/examples/expl-9/input.toml b/examples/expl-9/input.toml new file mode 100644 index 00000000..65f0e83f --- /dev/null +++ b/examples/expl-9/input.toml @@ -0,0 +1,14 @@ +# Note: standalone CREGEN sorting (-cregen CLI flag) has no TOML runtype equivalent. +# The [cregen] block below shows the CREGEN duplicate-detection thresholds +# that are used during a full iMTD-GC conformer search. +runtype = "imtd-gc" +input = "struc.xyz" # input structure file (1-propanol) + +[[calculation.level]] +method = "gfnff" # GFN-FF for sampling + +[cregen] +ewin = 100.0 # energy window for conformer selection (kcal/mol) +rthr = 0.125 # RMSD threshold for duplicate detection (Å) +ethr = 0.05 # energy threshold for duplicate detection (kcal/mol) +bthr = 15.0 # rotational constant threshold (MHz) diff --git a/examples/expl-9/run.sh b/examples/expl-9/run.sh index a487ef16..e975e556 100755 --- a/examples/expl-9/run.sh +++ b/examples/expl-9/run.sh @@ -1,27 +1,16 @@ #!/bin/bash +# Standalone CREGEN sorting of an ensemble/trajectory file. +# Removes duplicate structures (by RMSD and energy) and sorts by energy. +# Output: crest_conformers.xyz (unique), crest_rotamers.xyz (all), xtb.trj.sorted +# Note: -cregen standalone mode has no TOML runtype; use the CLI form below. -xtbin='xtb' -crst='crest' +command -v crest >/dev/null 2>&1 || { + echo >&2 "Cannot find crest binary." + exit 1 +} -command -v $xtbin >/dev/null 2>&1 || { echo >&2 "Cannot find xtb binary. Exit."; exit 1; } -command -v $crst >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary. Exit."; exit 1; } - -if [ $xtbin == 'xtb' ] - then - $crst struc.xyz -tautomerize -ewin 10.0 - else - $crst struc.xyz -tautomerize -ewin 10.0 -xnam $xtbin - fi - -# The -tautomerize flag can be used to request -# a screening of prototropic tautomers. -# The structures are build from a sequence of -# protonating and deprotonating steps of the -# (neutral) input structure. -# In the above example this procedure is -# performed on the guanine molecule to get -# the gas phase tautomers at GFN2-xTB level. -# Within the 10 kcal/mol window 5 tautomers -# should remain at this level. -# The structures can be found in 'tautomers.xyz'. +# --- CLI run --- +crest -cregen xtb.trj -ewin 100.0 +# (no TOML runtype equivalent for standalone CREGEN; see input.toml for +# the [cregen] settings used during a full iMTD-GC run) diff --git a/examples/expl-9/struc.xyz b/examples/expl-9/struc.xyz index 725a04d3..38692b20 100644 --- a/examples/expl-9/struc.xyz +++ b/examples/expl-9/struc.xyz @@ -1,18 +1,14 @@ -16 - energy: -31.983681788270 gnorm: 0.000372144832 xtb: 6.2.2 (89a525f) -N 1.46226284012671 0.18335744247169 -0.07855270314916 -C 1.31781205014203 -1.15293393777405 0.05955064599303 -C 1.54055132778996 -2.13428714261960 -0.91007075980005 -C 1.98029754954570 -1.74761862944617 -2.21865239727883 -N 2.10914370306048 -0.33402358897783 -2.27674973147307 -C 1.86775867472018 0.54390043382692 -1.26343764079100 -N 1.27680953207984 -3.36757233307534 -0.37748854905490 -C 0.91461226786592 -3.14740906594264 0.84460715972356 -N 0.91768716624572 -1.81594469141732 1.17440471889163 -O 2.23471850070944 -2.39670706107528 -3.20454497820690 -N 2.11460025487082 1.85836120568312 -1.49845077783225 -H 0.67952040591559 -1.39514835256529 2.05664466916869 -H 0.63659476510547 -3.91144927326480 1.54245387480526 -H 2.43918920019300 0.01672894983906 -3.16809193535854 -H 1.78950116764777 2.49655065642122 -0.79277065540295 -H 2.15173216814906 2.19392916334893 -2.44513710915798 + 12 +FINAL HEAT OF FORMATION = -1.651323 + C 1.625257 -0.262628 -0.323273 + C 0.518221 0.706221 -0.335177 + C -0.859313 -0.005477 -0.327969 + H -1.683026 0.654493 -0.607965 + H -0.974493 -0.754480 -1.061658 + O -1.171503 -0.423846 1.012985 + H -0.837975 0.254126 1.683603 + H 0.615912 1.428650 0.457852 + H 0.597843 1.325129 -1.321583 + H 1.504113 -0.866659 0.564875 + H 2.639815 0.049302 -0.353007 + H 1.502315 -1.001480 -1.109649 diff --git a/examples/expl-5/xtb.trj b/examples/expl-9/xtb.trj similarity index 100% rename from examples/expl-5/xtb.trj rename to examples/expl-9/xtb.trj From 5760b682f3df643a250698c4e92f31b01d1cda4a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 15 May 2026 18:32:37 +0200 Subject: [PATCH 328/374] Add toml keyword for CREGEN --- examples/expl-9/input.toml | 11 +++-------- examples/expl-9/run.sh | 5 ++--- src/parsing/parse_maindata.f90 | 11 ++++++++++- 3 files changed, 15 insertions(+), 12 deletions(-) diff --git a/examples/expl-9/input.toml b/examples/expl-9/input.toml index 65f0e83f..45937e4b 100644 --- a/examples/expl-9/input.toml +++ b/examples/expl-9/input.toml @@ -1,11 +1,6 @@ -# Note: standalone CREGEN sorting (-cregen CLI flag) has no TOML runtype equivalent. -# The [cregen] block below shows the CREGEN duplicate-detection thresholds -# that are used during a full iMTD-GC conformer search. -runtype = "imtd-gc" -input = "struc.xyz" # input structure file (1-propanol) - -[[calculation.level]] -method = "gfnff" # GFN-FF for sampling +# Standalone CREGEN ensemble sorting +runtype = "cregen" +ensemble = "xtb.trj" # ensemble/trajectory file to sort [cregen] ewin = 100.0 # energy window for conformer selection (kcal/mol) diff --git a/examples/expl-9/run.sh b/examples/expl-9/run.sh index e975e556..ce164da2 100755 --- a/examples/expl-9/run.sh +++ b/examples/expl-9/run.sh @@ -2,7 +2,6 @@ # Standalone CREGEN sorting of an ensemble/trajectory file. # Removes duplicate structures (by RMSD and energy) and sorts by energy. # Output: crest_conformers.xyz (unique), crest_rotamers.xyz (all), xtb.trj.sorted -# Note: -cregen standalone mode has no TOML runtype; use the CLI form below. command -v crest >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary." @@ -12,5 +11,5 @@ command -v crest >/dev/null 2>&1 || { # --- CLI run --- crest -cregen xtb.trj -ewin 100.0 -# (no TOML runtype equivalent for standalone CREGEN; see input.toml for -# the [cregen] settings used during a full iMTD-GC run) +# --- TOML run (equivalent settings) --- +# crest input.toml diff --git a/src/parsing/parse_maindata.f90 b/src/parsing/parse_maindata.f90 index c912443f..9b163144 100644 --- a/src/parsing/parse_maindata.f90 +++ b/src/parsing/parse_maindata.f90 @@ -257,11 +257,20 @@ subroutine parse_main_c(env,key,val,rd) env%properties = p_tautomerize env%crestver = crest_tautomerize - case ('thermo') + case ('thermo') env%properties = p_thermo env%crestver = crest_none env%preopt = .false. + case ('cregen','sort') + env%preopt = .false. + env%crestver = crest_sorting + env%autozsort = .false. + if (val .eq. 'cregen') then + env%sortmode = 'cregen' + env%confgo = .true. + end if + case default !>--- keyword was recognized, but invalid argument supplied write (stdout,fmtura) val From 0adb694824d9869c33bf0a8865db29384045401b Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 15 May 2026 18:39:00 +0200 Subject: [PATCH 329/374] update example 10 --- examples/expl-10/run.sh | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/examples/expl-10/run.sh b/examples/expl-10/run.sh index 38774e59..862d3278 100755 --- a/examples/expl-10/run.sh +++ b/examples/expl-10/run.sh @@ -1,15 +1,14 @@ #!/bin/bash # Constrained iMTD-GC conformer search of 1-propanol: # the C-C-C-O backbone (atoms 1-4) is frozen; only the OH dihedral is sampled. -# Expected output: 2 conformers (different OH rotamers) in crest_conformers.xyz. -command -v crest >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary."; exit 1; } +command -v crest >/dev/null 2>&1 || { + echo >&2 "Cannot find crest binary." + exit 1 +} # --- CLI run --- -# Step 1: generate a constraint template (.xcontrol.sample): -crest struc.xyz -constrain 1-4 -# Step 2: run the constrained conformer search: -crest struc.xyz -gfnff -cinp .xcontrol.sample -ewin 2.0 +crest struc.xyz -gfnff -freeze 1-4 -ewin 2.0 --imtdgc # --- TOML run (constraints defined directly in the input file) --- # crest input.toml From efa31749e51f4db8955a39664cdbbc626b1c7f33 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 15 May 2026 18:44:49 +0200 Subject: [PATCH 330/374] Update example 12 --- examples/expl-12/run.sh | 7 +++++-- src/parsing/parse_maindata.f90 | 1 + 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/examples/expl-12/run.sh b/examples/expl-12/run.sh index 9fc0ba6b..28a4cc08 100755 --- a/examples/expl-12/run.sh +++ b/examples/expl-12/run.sh @@ -3,10 +3,13 @@ # A wall potential is generated automatically to prevent cluster dissociation. # Output: crest_conformers.xyz, crest_rotamers.xyz -command -v crest >/dev/null 2>&1 || { echo >&2 "Cannot find crest binary."; exit 1; } +command -v crest >/dev/null 2>&1 || { + echo >&2 "Cannot find crest binary." + exit 1 +} # --- CLI run --- -crest struc.xyz -nci +crest struc.xyz --gfnff --imtdgc -nci # --- TOML run (equivalent settings) --- # crest input.toml diff --git a/src/parsing/parse_maindata.f90 b/src/parsing/parse_maindata.f90 index 9b163144..bd77d954 100644 --- a/src/parsing/parse_maindata.f90 +++ b/src/parsing/parse_maindata.f90 @@ -221,6 +221,7 @@ subroutine parse_main_c(env,key,val,rd) env%autozsort = .false. env%performCross = .false. env%rotamermds = .false. + env%crestver = crest_imtd case ('bh','gmin') env%crestver = crest_bh case ('entropy','imtd-smtd','entropy_search') From 0d3e634afa7ae50f003fd19e98818e3419503330 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 15 May 2026 18:48:28 +0200 Subject: [PATCH 331/374] Update file name info protonate/deprotonate/tautomerize --- src/printouts.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/printouts.f90 b/src/printouts.f90 index 4b4f3175..c212a8c0 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -1178,13 +1178,13 @@ subroutine crest_output_summary(env) ! ── protonation / deprotonation / tautomers ─── case (crest_protonate) - call wfe('crest_protonated.xyz','unique site candidates, energy-sorted') + call wfe('protonated.xyz','unique site candidates, energy-sorted') call wfe('crest_best.xyz','lowest-energy structure') case (crest_deprotonate) - call wfe('crest_deprotonated.xyz','unique site candidates, energy-sorted') + call wfe('deprotonated.xyz','unique site candidates, energy-sorted') call wfe('crest_best.xyz','lowest-energy structure') case (crest_tautomerize) - call wfe('crest_tautomers.xyz','unique site candidates, energy-sorted') + call wfe('tautomers.xyz','unique site candidates, energy-sorted') call wfe('crest_best.xyz','lowest-energy structure') case default From fa99644980eb21656c6f7545845f90ef60b3ec53 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 15 May 2026 19:44:05 +0200 Subject: [PATCH 332/374] Version bump in preparation of merge --- CMakeLists.txt | 2 +- meson.build | 2 +- src/qcg/qcg_printouts.f90 | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index ce0fa91b..4012a62a 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -27,7 +27,7 @@ endif() project( crest LANGUAGES "C" "CXX" "Fortran" - VERSION 3.0.3 + VERSION 3.1.0 DESCRIPTION "A tool for the exploration of low-energy chemical space" ) diff --git a/meson.build b/meson.build index 5e865741..c2643540 100644 --- a/meson.build +++ b/meson.build @@ -17,7 +17,7 @@ project( 'crest', ['c', 'fortran'], - version : '3.0.3', + version : '3.1.0', license : 'LGPL-3.0-or-later', meson_version : '>=0.57.0', default_options : [ diff --git a/src/qcg/qcg_printouts.f90 b/src/qcg/qcg_printouts.f90 index e13dbf71..6591563f 100644 --- a/src/qcg/qcg_printouts.f90 +++ b/src/qcg/qcg_printouts.f90 @@ -287,7 +287,7 @@ subroutine xtbiff_print_deprecated() write (stdout,*) write (stdout,*) 'WARNING WARNING WARNING' write (stdout,*) ' The use of xtbiff in QCG is deprecated and is disabled' - write (stdout,*) ' following CREST 3.0.3, in favor of the aISS algorithm.' + write (stdout,*) ' following CREST 3.1.0, in favor of the aISS algorithm.' write (stdout,*) ' This requires a current version of the xtb program.' write (stdout,*) call creststop(status_safety) From c5956cc432d6c25e13a1326afea076cb0ade8042 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 22 May 2026 13:41:48 +0200 Subject: [PATCH 333/374] cosmetics (adapting term_ui from github.com/pprcht/irmsd) --- src/algos/CMakeLists.txt | 1 + src/algos/meson.build | 1 + src/algos/parallel.f90 | 91 ++----- src/algos/protonate.f90 | 9 +- src/algos/queueing.f90 | 10 +- src/algos/term_ui.f90 | 516 +++++++++++++++++++++++++++++++++++++++ src/classes.f90 | 2 + src/qcg/qcg_misc.f90 | 79 +++--- 8 files changed, 601 insertions(+), 108 deletions(-) create mode 100644 src/algos/term_ui.f90 diff --git a/src/algos/CMakeLists.txt b/src/algos/CMakeLists.txt index 9e553584..0fd9ddf6 100644 --- a/src/algos/CMakeLists.txt +++ b/src/algos/CMakeLists.txt @@ -39,6 +39,7 @@ list(APPEND srcs "${dir}/alkylize.f90" "${dir}/dryrun.f90" "${dir}/propcalc.f90" + "${dir}/term_ui.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/algos/meson.build b/src/algos/meson.build index 90671de4..09595c2a 100644 --- a/src/algos/meson.build +++ b/src/algos/meson.build @@ -37,4 +37,5 @@ srcs += files( 'deform_opt_hess.f90', 'dryrun.f90', 'propcalc.f90', + 'term_ui.f90', ) diff --git a/src/algos/parallel.f90 b/src/algos/parallel.f90 index e9feecb9..c6da368d 100644 --- a/src/algos/parallel.f90 +++ b/src/algos/parallel.f90 @@ -109,6 +109,7 @@ subroutine crest_sploop(env,nat,nall,at,xyz,eread) use strucrd use optimize_module use iomod,only:makedir,directory_exist,remove + use term_ui,only:progress_init,progress_update,progress_finish implicit none type(systemdata),intent(inout) :: env real(wp),intent(inout) :: xyz(3,nat,nall) @@ -169,8 +170,10 @@ subroutine crest_sploop(env,nat,nall,at,xyz,eread) call profiler%init(1) call profiler%start(1) -!>--- first progress printout (initializes progress variables) - call crest_oloop_pr_progress(env,nall,0) +!>--- initialize progress bar + call progress_init(env%ps,nall,width=50,prefix=" ↳ ", & + & suffix="",show_time=.true.,show_eta=.false.) + call progress_update(env%ps,0,nall) !>--- shared variables allocate (grads(3,nat,T),source=0.0_wp) @@ -218,7 +221,7 @@ subroutine crest_sploop(env,nat,nall,at,xyz,eread) end if k = k+1 !>--- print progress - call crest_oloop_pr_progress(env,nall,k) + call progress_update(env%ps,k,nall) !$omp end critical !$omp end task end do @@ -227,7 +230,7 @@ subroutine crest_sploop(env,nat,nall,at,xyz,eread) !$omp end parallel !>--- finalize progress printout - call crest_oloop_pr_progress(env,nall,-1) + call progress_finish(env%ps) !>--- stop timer call profiler%stop(1) @@ -277,6 +280,7 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread,gt_out,stot_out) use optimize_module use thermochem_module use iomod,only:makedir,directory_exist,remove + use term_ui,only:progress_init,progress_update,progress_finish implicit none type(systemdata),intent(inout) :: env real(wp),intent(inout) :: xyz(3,nat,nall) @@ -376,8 +380,10 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread,gt_out,stot_out) call profiler%init(1) call profiler%start(1) -!>--- first progress printout (initializes progress variables) - call crest_oloop_pr_progress(env,nall,0) +!>--- initialize progress bar + call progress_init(env%ps,nall,width=50,prefix=" ↳ ", & + & suffix="",show_time=.true.,show_eta=.false.) + call progress_update(env%ps,0,nall) !>--- shared variables allocate (grads(3,nat,T),source=0.0_wp) @@ -443,7 +449,7 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread,gt_out,stot_out) eread(zcopy) = big end if k = k+1 - call crest_oloop_pr_progress(env,nall,k) + call progress_update(env%ps,k,nall) !$omp end critical !$omp end task end do @@ -452,7 +458,7 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread,gt_out,stot_out) !$omp end parallel !>--- finalize progress printout - call crest_oloop_pr_progress(env,nall,-1) + call progress_finish(env%ps) !>--- stop timer call profiler%stop(1) @@ -504,6 +510,7 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) use strucrd use optimize_module use iomod,only:makedir,directory_exist,remove + use term_ui,only:progress_init,progress_update,progress_finish implicit none type(systemdata),target,intent(inout) :: env real(wp),intent(inout) :: xyz(3,nat,nall) @@ -581,8 +588,10 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) call profiler%init(1) call profiler%start(1) -!>--- first progress printout (initializes progress variables) - call crest_oloop_pr_progress(env,nall,0) +!>--- initialize progress bar + call progress_init(env%ps,nall,width=50,prefix=" ↳ ", & + & suffix="",show_time=.true.,show_eta=.false.) + call progress_update(env%ps,0,nall) !>--- shared variables allocate (grads(3,nat,T),source=0.0_wp) @@ -647,7 +656,7 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) end if k = k+1 !>--- print progress - call crest_oloop_pr_progress(env,nall,k) + call progress_update(env%ps,k,nall) !$omp end critical !$omp end task end do @@ -656,7 +665,7 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) !$omp end parallel !>--- finalize progress printout - call crest_oloop_pr_progress(env,nall,-1) + call progress_finish(env%ps) !>--- stop timer call profiler%stop(1) @@ -687,64 +696,6 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) return end subroutine crest_oloop -!========================================================================================! -subroutine crest_oloop_pr_progress(env,total,current) -!********************************************* -!* subroutine crest_oloop_pr_progress -!* A subroutine to print and track progress of -!* concurrent geometry optimizations -!********************************************* - use crest_parameters,only:wp,stdout - use crest_data - use iomod,only:to_str - implicit none - type(systemdata),intent(inout) :: env - integer,intent(in) :: total,current - real(wp) :: percent - character(len=5) :: atmp - real(wp),save :: increment - real(wp),save :: progressbarrier - - percent = float(current)/float(total)*100.0_wp - if (current == 0) then !> as a wrapper to start the printout - progressbarrier = 0.0_wp - if (env%niceprint) then - percent = 0.0_wp - call printprogbar(percent) - end if - increment = 10.0_wp - if (total > 1000) increment = 7.5_wp - if (total > 5000) increment = 5.0_wp - if (total > 10000) increment = 2.5_wp - if (total > 20000) increment = 1.0_wp - - else if (current <= total.and.current > 0) then !> the regular printout case - if (env%niceprint) then - call printprogbar(percent) - - else if (.not.env%legacy) then - if (percent >= progressbarrier) then - write (atmp,'(f5.1)') percent - write (stdout,'(1x,a)',advance='no') '|>'//trim(adjustl(atmp))//'%' - progressbarrier = progressbarrier+increment - progressbarrier = min(progressbarrier,100.0_wp) - flush (stdout) - end if - else - write (stdout,'(1x,i0)',advance='no') current - flush (stdout) - end if - - else !> as a wrapper to finalize the printout - if (.not.env%niceprint) then - write (stdout,'(/,1x,a)') 'done.' - else - write (stdout,*) - end if - end if - -end subroutine crest_oloop_pr_progress - !========================================================================================! !========================================================================================! !> Routines for parallel MDs diff --git a/src/algos/protonate.f90 b/src/algos/protonate.f90 index 0edd80bf..5f0234ec 100644 --- a/src/algos/protonate.f90 +++ b/src/algos/protonate.f90 @@ -444,6 +444,7 @@ subroutine protonation_prep_canonical(env,refmol,fname) use iomod,only:remove use adjacency use cregen_interface + use term_ui,only:progress_init,progress_update,progress_finish implicit none type(systemdata) :: env type(coord),intent(in) :: refmol @@ -482,7 +483,9 @@ subroutine protonation_prep_canonical(env,refmol,fname) allocate (canon(nall)) write (stdout,'(a,i0,a)') '> Setting up canonical atom order for ',nall,' structures via CN-based molecular graphs ...' - call crest_oloop_pr_progress(env,nall,0) + call progress_init(env%ps,nall,width=50,prefix=" ↳ ", & + & suffix="",show_time=.true.,show_eta=.false.) + call progress_update(env%ps,0,nall) do i = 1,nall call canon(i)%init(structures(i),invtype='apsp+') call canon(i)%stereo(structures(i)) @@ -490,9 +493,9 @@ subroutine protonation_prep_canonical(env,refmol,fname) !call canon(i)%rankprint(structures(i)) call canon(i)%shrink() - call crest_oloop_pr_progress(env,nall,i) + call progress_update(env%ps,i,nall) end do - call crest_oloop_pr_progress(env,nall,-1) + call progress_finish(env%ps) !>--- grouping loop allocate (group(nall),source=0) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 2e304d55..0560a760 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -455,6 +455,7 @@ subroutine crest_queue_reconstruct(env,tim) use iomod use crest_calculator use utilities,only:checkname_xyz + use term_ui,only:progress_init,progress_update,progress_finish implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim @@ -686,7 +687,9 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) end do ! write (stdout,'(2x,a)') 'Recombining under heavy-atom RMSD consideration (this may take a while) ... ' write (stdout,'(2x,a)') 'Recombining under iRMSD consideration (this may take a while) ... ' - call crest_oloop_pr_progress(env,max_structs,0) + call progress_init(env%ps,max_structs,width=50,prefix=" ↳ ", & + & suffix="",show_time=.true.,show_eta=.false.) + call progress_update(env%ps,0,max_structs) call profiler%init(1) call profiler%start(1) @@ -798,7 +801,7 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) if (.not.duplicate) then layer%nmols = layer%nmols+1 layer%mols(layer%nmols) = mol - call crest_oloop_pr_progress(env,max_structs,layer%nmols) + call progress_update(env%ps,layer%nmols,max_structs) if (layer%nmols == max_structs) exit regionloop end if end if @@ -806,8 +809,9 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) end do end do regionloop if (layer%nmols < max_structs) then - call crest_oloop_pr_progress(env,1,1) + call progress_update(env%ps,1,1) end if + call progress_finish(env%ps) write (stdout,'(2x,a)') 'done!' if (duplicates > 0) then write (stdout,'(2x,a,i0)') 'Avoided duplicates : ',duplicates diff --git a/src/algos/term_ui.f90 b/src/algos/term_ui.f90 new file mode 100644 index 00000000..b9c2313e --- /dev/null +++ b/src/algos/term_ui.f90 @@ -0,0 +1,516 @@ +module term_ui + use crest_parameters + use iso_c_binding,only:c_int + implicit none + private + + interface + integer(c_int) function c_isatty(fd) bind(c,name="isatty") + use iso_c_binding,only:c_int + integer(c_int),value :: fd + end function c_isatty + end interface + + !> Public API + public :: ansi_enabled,set_ansi_enabled + public :: fg,bg,style,reset,strip_ansi + public :: printc,eprintc + public :: progress_state + public :: progress_init,progress_update,progress_finish + public :: clear_line + + !> ============================================================ + !> Configuration + !> ============================================================ + logical :: ansi_enabled = .true. + + integer,parameter :: C_RESET = -1 + + !> Basic 8-color codes (foreground base 30..37, background base 40..47) + integer,parameter,public :: & + & BLACK = 0,RED = 1,GREEN = 2,YELLOW = 3, & + & BLUE = 4,MAGENTA = 5,CYAN = 6,WHITE = 7 + + !> Style SGR codes + integer,parameter,public :: & + & S_BOLD = 1, & + & S_DIM = 2, & + & S_UNDERLINE = 4, & + & S_BLINK = 5, & + & S_REVERSE = 7, & + & S_HIDDEN = 8 + + !> ============================================================ + !> Progress state + !> ============================================================ + type :: progress_state + real(wp) :: t0 = 0.0_wp + integer :: width = 40 + character(:),allocatable :: prefix + character(:),allocatable :: suffix + character(:),allocatable :: fill_char + character(:),allocatable :: empty_char + character(:),allocatable :: left_cap + character(:),allocatable :: right_cap + integer(int64) :: last_draw_ms = -huge(0_int64) + integer(int64) :: min_interval_ms = 50_int64 !> throttle redraw + logical :: show_time = .true. + logical :: show_eta = .true. + logical :: started = .false. + logical :: tty = .false. !> auto-set by progress_init + real(wp) :: increment = 10.0_wp !> % step for non-TTY mode + real(wp) :: barrier = 0.0_wp !> current % threshold for non-TTY mode + end type progress_state + +!========================================================================! +contains !> MODULE PROCEDURES START HERE +!========================================================================! + + !> ============================================================ + !> Time helper (seconds as wp) - based on system_clock + !> ============================================================ + function now_seconds() result(t) + real(wp) :: t + integer(int64) :: count,rate + call system_clock(count=count,count_rate=rate) + if (rate > 0_int64) then + t = real(count,wp)/real(rate,wp) + else + t = 0.0_wp + end if + end function now_seconds + + function now_millis_i64() result(ms) + integer(int64) :: ms + integer(int64) :: count,rate + call system_clock(count=count,count_rate=rate) + if (rate > 0_int64) then + ms = int((real(count,wp)*1000.0_wp)/real(rate,wp),int64) + else + ms = 0_int64 + end if + end function now_millis_i64 + + subroutine set_ansi_enabled(flag) + logical,intent(in) :: flag + ansi_enabled = flag + end subroutine set_ansi_enabled + + !> ============================================================ + !> ANSI builders + !> ============================================================ + pure function sgr(code) result(s) + integer,intent(in) :: code + character(:),allocatable :: s + if (.not.ansi_enabled) then + s = "" + else + s = achar(27)//"["//itoa(code)//"m" + end if + end function sgr + + pure function reset() result(s) + character(:),allocatable :: s + s = sgr(0) + end function reset + + pure function fg(color,bright) result(s) + integer,intent(in) :: color + logical,intent(in),optional :: bright + character(:),allocatable :: s + integer :: base + logical :: b + if (.not.ansi_enabled) then + s = "" + return + end if + b = .false.; if (present(bright)) b = bright + if (color == C_RESET) then + s = achar(27)//"[39m" + else + base = 30+max(0,min(7,color)) + if (b) then + !> "Bright" variant using 90..97 (widely supported) + base = 90+max(0,min(7,color)) + end if + s = achar(27)//"["//itoa(base)//"m" + end if + end function fg + + pure function bg(color,bright) result(s) + integer,intent(in) :: color + logical,intent(in),optional :: bright + character(:),allocatable :: s + integer :: base + logical :: b + if (.not.ansi_enabled) then + s = "" + return + end if + b = .false.; if (present(bright)) b = bright + if (color == C_RESET) then + s = achar(27)//"[49m" + else + base = 40+max(0,min(7,color)) + if (b) then + base = 100+max(0,min(7,color)) + end if + s = achar(27)//"["//itoa(base)//"m" + end if + end function bg + + pure function style(code) result(s) + integer,intent(in) :: code + character(:),allocatable :: s + s = sgr(code) + end function style + + !> ============================================================ + !> Printing helpers + !> ============================================================ + subroutine printc(msg,unit,advance) + character(len=*),intent(in) :: msg + integer,intent(in),optional :: unit + logical,intent(in),optional :: advance + integer :: u + logical :: adv + u = stdout; if (present(unit)) u = unit + adv = .true.; if (present(advance)) adv = advance + if (adv) then + write (u,'(a)') msg + else + write (u,'(a)',advance='no') msg + end if + end subroutine printc + + subroutine eprintc(msg,advance) + character(len=*),intent(in) :: msg + logical,intent(in),optional :: advance + call printc(msg,unit=stderr,advance=advance) + end subroutine eprintc + + !> Clears current line and returns carriage to start (no newline). + pure function clear_line() result(s) + character(:),allocatable :: s + if (.not.ansi_enabled) then + s = achar(13) !> CR only + else + !> CR + "erase line" (EL2) is common; some use EL0. We'll do EL2. + s = achar(13)//achar(27)//"[2K" + end if + end function clear_line + + !> ============================================================ + !> Progress bar API + !> ============================================================ + subroutine progress_init(ps,total,width,prefix,suffix,min_interval_ms,show_time,show_eta, & + fill_char,empty_char,left_cap,right_cap) + !*********************************************************** + !* Initialise a progress_state object. + !* Automatically detects whether stdout is a TTY and selects + !* either the fancy ANSI bar or the sequential |>x% mode. + !* total: total number of steps (used to calibrate the non-TTY + !* print interval). + !*********************************************************** + implicit none + type(progress_state),intent(inout) :: ps + integer,intent(in),optional :: total + integer,intent(in),optional :: width + character(len=*),intent(in),optional :: prefix,suffix + integer(int64),intent(in),optional :: min_interval_ms + logical,intent(in),optional :: show_time,show_eta + character(len=*),intent(in),optional :: fill_char,empty_char,left_cap,right_cap + + ps%t0 = now_seconds() + ps%started = .true. + + if (present(width)) ps%width = max(5,width) + if (present(min_interval_ms)) ps%min_interval_ms = max(0_int64,min_interval_ms) + if (present(show_time)) ps%show_time = show_time + if (present(show_eta)) ps%show_eta = show_eta + + if (present(prefix)) then + ps%prefix = prefix + else + ps%prefix = "" + end if + + if (present(suffix)) then + ps%suffix = suffix + else + ps%suffix = "" + end if + + if (present(fill_char)) then + ps%fill_char = fill_char + else + ps%fill_char = "█" + end if + + if (present(empty_char)) then + ps%empty_char = empty_char + else + ps%empty_char = "░" + end if + + if (present(left_cap)) then + ps%left_cap = left_cap + else + ps%left_cap = "[" + ps%left_cap = "┃" + end if + + if (present(right_cap)) then + ps%right_cap = right_cap + else + ps%right_cap = "]" + ps%right_cap = "┃" + end if + + ps%last_draw_ms = -huge(0_int64) + + ! ── TTY detection & non-TTY state ──────────────────────────── + ps%tty = (c_isatty(1_c_int) /= 0) + ps%barrier = 0.0_wp + ps%increment = 10.0_wp + if (.not.ps%tty .and. present(total)) then + if (total > 20000) ps%increment = 1.0_wp + if (total > 10000 .and. total <= 20000) ps%increment = 2.5_wp + if (total > 5000 .and. total <= 10000) ps%increment = 5.0_wp + if (total > 1000 .and. total <= 5000) ps%increment = 7.5_wp + end if + end subroutine progress_init + + subroutine progress_update(ps,curr,tot,unit,force) + !*********************************************************** + !* Update the progress display. + !* TTY: renders the in-place ANSI bar. + !* non-TTY: prints sequential |>x% markers. + !*********************************************************** + implicit none + type(progress_state),intent(inout) :: ps + integer,intent(in) :: curr,tot + integer,intent(in),optional :: unit + logical,intent(in),optional :: force + + integer :: u + integer(int64) :: current,total + logical :: do_force + integer(int64) :: ms,elapsed_ms + real(wp) :: frac,elapsed_s,rate,eta_s + integer :: filled,nfilled + character(:),allocatable :: line,pct,time_str,eta_str + character(:),allocatable :: bar + real(wp) :: pct_r + character(len=5) :: atmp + + if (.not.ps%started) call progress_init(ps) + + current = int(curr,int64) + total = int(tot,int64) + u = stdout; if (present(unit)) u = unit + do_force = .false.; if (present(force)) do_force = force + + if (ps%tty) then + ! ── Fancy in-place ANSI bar ─────────────────────────────────── + if (current == total) do_force = .true. + + ms = now_millis_i64() + if (.not.do_force) then + if (ps%last_draw_ms >= 0_int64) then + if (ms-ps%last_draw_ms < ps%min_interval_ms) return + end if + end if + ps%last_draw_ms = ms + + if (total <= 0_int64) then + frac = 0.0_wp + else + frac = real(max(0_int64,min(current,total)),wp)/real(total,wp) + end if + + filled = int(frac*real(ps%width,wp)) + filled = max(0,min(ps%width,filled)) + nfilled = max(0,(ps%width-filled)) + + pct = fmt_percent(frac) + + elapsed_s = now_seconds()-ps%t0 + elapsed_ms = int(elapsed_s*1000.0_wp,int64) + + if (ps%show_time) then + time_str = " "//dim_text("("//fmt_hms(elapsed_ms)//")") + else + time_str = "" + end if + + if (ps%show_eta.and.current > 0_int64.and.total > 0_int64.and.current < total) then + rate = real(current,wp)/max(1.0e-12_wp,elapsed_s) + eta_s = real(total-current,wp)/max(1.0e-12_wp,rate) + eta_str = " "//dim_text("ETA "//fmt_hms(int(eta_s*1000.0_wp,int64))) + else if (ps%show_eta.and.total > 0_int64.and.current >= total) then + eta_str = " "//dim_text("ETA 00:00") + else + eta_str = "" + end if + + if (ansi_enabled) then + if (frac >= 0.999_wp) then + bar = ps%left_cap// & + & fg(GREEN,bright=.true.)//repeat(ps%fill_char,filled)//reset()// & + & repeat(ps%empty_char,nfilled)//ps%right_cap + else + bar = ps%left_cap// & + & fg(GREEN,bright=.false.)//repeat(ps%fill_char,filled)//reset()// & + & fg(YELLOW,bright=.false.)//repeat(ps%empty_char,nfilled)//reset()// & + & ps%right_cap + end if + else + bar = ps%left_cap//repeat(ps%fill_char,filled)// & + & repeat(ps%empty_char,nfilled)//ps%right_cap + end if + + line = clear_line()//ps%prefix//bar//" "//pct//ps%suffix//eta_str//time_str + + call printc(line,unit=u,advance=.false.) + call flush_unit(u) + + else + ! ── non-TTY: sequential |>x% printout ──────────────────────── + if (current <= 0_int64) return + if (total <= 0_int64) return + pct_r = real(current,wp)/real(total,wp)*100.0_wp + if (pct_r >= ps%barrier) then + write (atmp,'(f5.1)') pct_r + write (u,'(1x,a)',advance='no') '|>'//trim(adjustl(atmp))//'%' + ps%barrier = min(ps%barrier+ps%increment,100.0_wp) + call flush_unit(u) + end if + + end if + end subroutine progress_update + + subroutine progress_finish(ps,unit,newline) + !*********************************************************** + !* Finalise the progress display. + !* TTY: prints a terminating newline. + !* non-TTY: prints a newline followed by " done." to close the + !* inline |>x% sequence. + !*********************************************************** + implicit none + type(progress_state),intent(inout) :: ps + integer,intent(in),optional :: unit + logical,intent(in),optional :: newline + integer :: u + logical :: nl + + u = stdout; if (present(unit)) u = unit + nl = .true.; if (present(newline)) nl = newline + + if (ps%tty) then + if (nl) call printc("",unit=u,advance=.true.) + else + if (nl) write (u,'(/,1x,a)') 'done.' + end if + call flush_unit(u) + ps%started = .false. + end subroutine progress_finish + + !> ============================================================ + !> Utilities: formatting, flushing, ANSI stripping + !> ============================================================ + subroutine flush_unit(u) + integer,intent(in) :: u + flush (u) + end subroutine flush_unit + + pure function itoa(i) result(s) + integer,intent(in) :: i + character(:),allocatable :: s + character(len=64) :: buf + write (buf,'(i0)') i + s = trim(buf) + end function itoa + + pure function itoa_i64(i) result(s) + integer(int64),intent(in) :: i + character(:),allocatable :: s + character(len=64) :: buf + write (buf,'(i0)') i + s = trim(buf) + end function itoa_i64 + + pure function fmt_percent(frac) result(s) + real(wp),intent(in) :: frac + character(:),allocatable :: s + integer :: p + real(wp) :: rp + character(8) :: buf + rp = min(100.0_wp*max(0.0_wp,min(1.0_wp,frac))+0.5_wp,100.0_wp) + write (buf,'(f5.1,a)') rp,"%" + s = adjustl(buf) + end function fmt_percent + + pure function fmt_hms(ms) result(s) + integer(int64),intent(in) :: ms + character(:),allocatable :: s + integer(int64) :: t,hh,mm,ss + character(32) :: buf + + t = max(0_int64,ms/1000_int64) + hh = t/3600_int64 + mm = (t-hh*3600_int64)/60_int64 + ss = t-hh*3600_int64-mm*60_int64 + + if (hh > 0_int64) then + write (buf,'(i0,":",i2.2,":",i2.2)') hh,int(mm),int(ss) + else + write (buf,'(i2.2,":",i2.2)') int(mm),int(ss) + end if + s = trim(buf) + end function fmt_hms + + pure function dim_text(t) result(s) + character(len=*),intent(in) :: t + character(:),allocatable :: s + if (.not.ansi_enabled) then + s = t + else + s = style(S_DIM)//t//reset() + end if + end function dim_text + + pure function strip_ansi(s_in) result(s_out) + character(len=*),intent(in) :: s_in + character(:),allocatable :: s_out + integer :: i,n + character :: c + logical :: in_esc + in_esc = .false. + s_out = "" + n = len_trim(s_in) + + i = 1 + do while (i <= n) + c = s_in(i:i) + if (.not.in_esc) then + if (c == achar(27)) then + in_esc = .true. + else + s_out = s_out//c + end if + else + !> We are inside ESC[ ... m ; consume until 'm' or end + if (c == "m") then + in_esc = .false. + end if + end if + i = i+1 + end do + end function strip_ansi + +!=============================================================================! +!#############################################################################! +!=============================================================================! +end module term_ui + diff --git a/src/classes.f90 b/src/classes.f90 index 5c52c55e..6369bcdd 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -30,6 +30,7 @@ module crest_data use crest_type_timer,only:timer use lwoniom_module,only:lwoniom_input use molbuilder_construct_list !> from molbuilder dir + use term_ui,only:progress_state implicit none public :: systemdata @@ -668,6 +669,7 @@ module crest_data logical :: water = .false. !> true if water is used as solvent (only QCG) logical :: wallsetup = .false. !> set up a wall potential? logical :: wbotopo = .false. !> set up topo with WBOs + type(progress_state) :: ps !> terminal progress bar state contains procedure :: allocate => allocate_metadyn procedure :: deallocate => deallocate_metadyn diff --git a/src/qcg/qcg_misc.f90 b/src/qcg/qcg_misc.f90 index 5b80fda8..701da8cb 100644 --- a/src/qcg/qcg_misc.f90 +++ b/src/qcg/qcg_misc.f90 @@ -676,6 +676,7 @@ subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added,eread) use iomod use crest_data use strucrd + use term_ui,only:progress_init,progress_update,progress_finish implicit none type(systemdata) :: env @@ -747,7 +748,11 @@ subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added,eread) end if k = 0 !counting the finished jobs - if (pr) call crest_oloop_pr_progress(env,NTMP,k) + if (pr) then + call progress_init(env%ps,NTMP,width=50,prefix=" ↳ ", & + & suffix="",show_time=.true.,show_eta=.false.) + call progress_update(env%ps,0,NTMP) + end if !___________________________________________________________________________________ !$omp parallel & @@ -761,9 +766,7 @@ subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added,eread) !$omp critical k = k+1 percent = real(k)/real(NTMP)*100 - if (pr) then - call crest_oloop_pr_progress(env,NTMP,k) - end if + if (pr) call progress_update(env%ps,k,NTMP) !$omp end critical !$omp end task end do @@ -790,7 +793,11 @@ subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added,eread) end if k = 0 !counting the finished jobs - if (pr) call crest_oloop_pr_progress(env,NTMP,k) + if (pr) then + call progress_init(env%ps,NTMP,width=50,prefix=" ↳ ", & + & suffix="",show_time=.true.,show_eta=.false.) + call progress_update(env%ps,0,NTMP) + end if !___________________________________________________________________________________ !$omp parallel & @@ -804,9 +811,7 @@ subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added,eread) !$omp critical k = k+1 percent = real(k)/real(NTMP)*100 - if (pr) then - call crest_oloop_pr_progress(env,NTMP,k) - end if + if (pr) call progress_update(env%ps,k,NTMP) !$omp end critical !$omp end task end do @@ -827,10 +832,7 @@ subroutine cff_opt(pr,env,fname,n12,NTMP,TMPdir,conv,nothing_added,eread) call chdirdbug(trim(thispath)) end do - if (pr) then - write (stdout,*) '' - write (stdout,'(2x,"done.")') - end if + if (pr) call progress_finish(env%ps) end subroutine cff_opt @@ -842,6 +844,7 @@ subroutine cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir, & use strucrd use crest_calculator use optimize_module + use term_ui,only:progress_init,progress_update,progress_finish implicit none type(systemdata) :: env @@ -934,7 +937,11 @@ subroutine cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir, & !> therefore, just optimize them serially. k = 0 !counting the finished jobs - if (pr) call crest_oloop_pr_progress(env,NTMP,k) + if (pr) then + call progress_init(env%ps,NTMP,width=50,prefix=" ↳ ", & + & suffix="",show_time=.true.,show_eta=.false.) + call progress_update(env%ps,0,NTMP) + end if !___________________________________________________________________________________ do i = 1,NTMP @@ -953,12 +960,11 @@ subroutine cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir, & k = k+1 percent = real(k)/real(NTMP)*100.0_wp - if (pr) then - call crest_oloop_pr_progress(env,NTMP,k) - end if + if (pr) call progress_update(env%ps,k,NTMP) deallocate (grd) end do + if (pr) call progress_finish(env%ps) !> clear up space deallocate (newcalcs) !__________________________________________________________________________________ @@ -980,7 +986,11 @@ subroutine cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir, & end do k = 0 !counting the finished jobs - if (pr) call crest_oloop_pr_progress(env,NTMP,k) + if (pr) then + call progress_init(env%ps,NTMP,width=50,prefix=" ↳ ", & + & suffix="",show_time=.true.,show_eta=.false.) + call progress_update(env%ps,0,NTMP) + end if !___________________________________________________________________________________ do i = 1,NTMP @@ -992,12 +1002,11 @@ subroutine cff_opt_calculator(pr,env,fname,n12,NTMP,TMPdir, & k = k+1 percent = real(k)/real(NTMP)*100.0_wp - if (pr) then - call crest_oloop_pr_progress(env,NTMP,k) - end if + if (pr) call progress_update(env%ps,k,NTMP) deallocate (grd) end do + if (pr) call progress_finish(env%ps) !___________________________________________________________________________________ !> for compatibility reasons, let's write the optimized geometries @@ -1099,6 +1108,7 @@ subroutine ens_sp(env,fname,NTMP,TMPdir) use iomod use crest_data use strucrd + use term_ui,only:progress_init,progress_update,progress_finish implicit none type(systemdata) :: env @@ -1135,7 +1145,9 @@ subroutine ens_sp(env,fname,NTMP,TMPdir) & trim(env%ProgName),trim(fname),trim(env%gfnver),trim(env%solv),trim(pipe) k = 0 !counting the finished jobs - call crest_oloop_pr_progress(env,NTMP,k) + call progress_init(env%ps,NTMP,width=50,prefix=" ↳ ", & + & suffix="",show_time=.true.,show_eta=.false.) + call progress_update(env%ps,0,NTMP) !___________________________________________________________________________________ @@ -1153,7 +1165,7 @@ subroutine ens_sp(env,fname,NTMP,TMPdir) !$omp critical k = k+1 percent = real(k)/real(NTMP)*100 - call crest_oloop_pr_progress(env,NTMP,k) + call progress_update(env%ps,k,NTMP) !$omp end critical !$omp end task end do @@ -1169,8 +1181,7 @@ subroutine ens_sp(env,fname,NTMP,TMPdir) call remove('xtbrestart') call chdirdbug(trim(thispath)) end do - write (stdout,*) '' - write (stdout,'(2x,"done.")') + call progress_finish(env%ps) end subroutine ens_sp @@ -1184,6 +1195,7 @@ subroutine ens_freq(env,fname,NTMP,TMPdir,opt) use iomod use crest_data use strucrd + use term_ui,only:progress_init,progress_update,progress_finish implicit none type(systemdata) :: env @@ -1219,7 +1231,9 @@ subroutine ens_freq(env,fname,NTMP,TMPdir,opt) end if k = 0 !counting the finished jobs - call crest_oloop_pr_progress(env,NTMP,k) + call progress_init(env%ps,NTMP,width=50,prefix=" ↳ ", & + & suffix="",show_time=.true.,show_eta=.false.) + call progress_update(env%ps,0,NTMP) !--- Jobcall if (.not.opt) then @@ -1243,7 +1257,7 @@ subroutine ens_freq(env,fname,NTMP,TMPdir,opt) !$omp critical k = k+1 percent = real(k)/real(NTMP)*100 - call crest_oloop_pr_progress(env,NTMP,k) + call progress_update(env%ps,k,NTMP) !$omp end critical !$omp end task end do @@ -1259,8 +1273,7 @@ subroutine ens_freq(env,fname,NTMP,TMPdir,opt) call remove('xtbrestart') call chdirdbug(trim(thispath)) end do - write (stdout,*) '' - write (stdout,'(2x,"done.")') + call progress_finish(env%ps) end subroutine ens_freq @@ -1272,6 +1285,7 @@ subroutine ens_freq_calculator(env,fname,NTMP,TMPdir,opt) use crest_calculator use thermochem_module use optimize_module + use term_ui,only:progress_init,progress_update,progress_finish implicit none type(systemdata) :: env @@ -1315,7 +1329,9 @@ subroutine ens_freq_calculator(env,fname,NTMP,TMPdir,opt) end if k = 0 !counting the finished jobs - call crest_oloop_pr_progress(env,NTMP,k) + call progress_init(env%ps,NTMP,width=50,prefix=" ↳ ", & + & suffix="",show_time=.true.,show_eta=.false.) + call progress_update(env%ps,0,NTMP) !--- Jobcall if (.not.opt) then @@ -1387,14 +1403,13 @@ subroutine ens_freq_calculator(env,fname,NTMP,TMPdir,opt) deallocate (freq,hess,tmpgrd) k = k+1 - call crest_oloop_pr_progress(env,NTMP,k) + call progress_update(env%ps,k,NTMP) call chdirdbug(trim(thispath)) end do !__________________________________________________________________________________ - write (stdout,*) - write (stdout,'(2x,"done.")') + call progress_finish(env%ps) end subroutine ens_freq_calculator !============================================================! From 7598806c1763d3cbd25445f3c36968fe6851f114 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 22 May 2026 14:38:20 +0200 Subject: [PATCH 334/374] cosmetics (warning due to temporary array in axis() call) --- src/sorting/cregen.f90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index bb620fdf..41e77be1 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -977,6 +977,7 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & type(coord),pointer :: ref,mol real(wp) :: rmsdval,RTHR,ediff,eii,avmom,rsq,frac real(wp),allocatable :: rot(:,:) + real(wp),allocatable :: xyz_aa(:,:) integer,allocatable :: prune_table(:) real(wp),allocatable :: enuc(:) logical :: l1,l2 @@ -1104,10 +1105,12 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & !> Prepare axis comparison !> axis alignment and rotational constant calculation allocate (rot(3,nall),source=0.0_wp) + allocate (xyz_aa(3,nat),source=0.0_wp) do ii = 1,nall mol => structures(ii) call axis(mol%nat,mol%at,mol%xyz) !> all coordinates to CMA - call axis(mol%nat,mol%at,moL%xyz*autoaa,rot(1:3,ii),avmom)!> B_0 in MHz + xyz_aa = mol%xyz*autoaa + call axis(mol%nat,mol%at,xyz_aa,rot(1:3,ii),avmom) !> B_0 in MHz end do !> Scaled sum of atom-atom-distances (empirical measure) From e373720c2b9d6170fa8554f1e2231048e4c97ee0 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 22 May 2026 14:46:31 +0200 Subject: [PATCH 335/374] cleaner stack handling in queue reconstruction for static build --- src/algos/queueing.f90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/algos/queueing.f90 b/src/algos/queueing.f90 index 0560a760..04492afb 100644 --- a/src/algos/queueing.f90 +++ b/src/algos/queueing.f90 @@ -545,6 +545,7 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) type(coord),allocatable :: structures_b(:) type(coord),allocatable :: structures_s(:) type(coord) :: mol,moltmp + type(coord),allocatable :: moltmp_arr(:) integer :: nall_b,nall_s,id_b,id_s integer :: rr,io,rg,nregions,max_structs integer :: reg_blo(3),reg_bhi(3),reg_slo(3),reg_shi(3) @@ -672,6 +673,7 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) write (stdout,'(2x,a,i0)') 'OpenMP threads : ',T allocate (ccache(T)) allocate (rcache(T)) + allocate (moltmp_arr(T)) allocate (mask(layer%refmol%nat),source=.true.) call canref%init(layer%refmol,invtype='apsp+',heavy=.false.) @@ -777,16 +779,16 @@ recursive subroutine recusrive_construct(env,heap,targetlayer) duplicate = .false. !$omp parallel & - !$omp shared(duplicate,duplicates,mol,ccache,rcache,mask,ETHR) & - !$omp private(rr,tt,deltaE,rmsval,moltmp) + !$omp shared(duplicate,duplicates,mol,ccache,rcache,mask,ETHR,moltmp_arr) & + !$omp private(rr,tt,deltaE,rmsval) !$omp do schedule(dynamic) do rr = 1,layer%nmols if (duplicate) cycle tt = omp_get_thread_num()+1 deltaE = abs(mol%energy-layer%mols(rr)%energy) if (deltaE < ETHR) then - call moltmp%copy(layer%mols(rr)) - call min_rmsd(mol,moltmp,rcache=rcache(tt),rmsdout=rmsval,align=.false.) + call moltmp_arr(tt)%copy(layer%mols(rr)) + call min_rmsd(mol,moltmp_arr(tt),rcache=rcache(tt),rmsdout=rmsval,align=.false.) !$omp critical if (rmsval < RTHR.and..not.duplicate) then duplicate = .true. From 95729d9a39d0d15efd597f1b3b240b76334be5b7 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 22 May 2026 14:54:31 +0200 Subject: [PATCH 336/374] cosmetics (avoid ifx warnings in ancopt for static builds) --- src/optimize/ancopt.f90 | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/optimize/ancopt.f90 b/src/optimize/ancopt.f90 index 2fbfee9f..d2b9c6f7 100644 --- a/src/optimize/ancopt.f90 +++ b/src/optimize/ancopt.f90 @@ -348,7 +348,7 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & real(wp) :: lambda,gnorm,dnorm,eold,xdum,estart,acc,e_in real(wp) :: depred,echng,dummy,maxd,alp,alpold,gchng,gnold real(wp),allocatable :: gold(:) - real(wp),allocatable :: displ(:),gint(:) + real(wp),allocatable :: displ(:),gint(:),dxold(:) real(wp),allocatable :: eaug(:) real(wp),allocatable :: Uaug(:,:) real(wp),allocatable :: Aaug(:) @@ -364,7 +364,7 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & iostatus = 0 !$omp critical - allocate (gold(OPT%nvar),displ(OPT%nvar),gint(OPT%nvar),source=0.0_wp) + allocate (gold(OPT%nvar),displ(OPT%nvar),gint(OPT%nvar),dxold(OPT%nvar),source=0.0_wp) gnorm = 0.0_wp depred = 0.0_wp @@ -395,9 +395,10 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & eold = energy !>--- calc predicted energy change based on E = E0 + delta * G + delta^2 * H alpold = alp + dxold = displ*alpold if (ii > 1) then - call prdechng(OPT%nvar,gold,displ*alpold,OPT%hess,depred) + call prdechng(OPT%nvar,gold,dxold,OPT%hess,depred) end if !>------------------------------------------------------------------------ @@ -475,15 +476,15 @@ subroutine relax(mol,calc,OPT,iter,maxmicro,etot,grd, & !>--- Hessian update, but only after first iteration (ii > 1) select case (iupdat) case (0) - call bfgs(OPT%nvar,gnorm,gint,gold,displ*alpold,OPT%hess) + call bfgs(OPT%nvar,gnorm,gint,gold,dxold,OPT%hess) case (1) - call powell(OPT%nvar,gnorm,gint,gold,displ*alpold,OPT%hess) + call powell(OPT%nvar,gnorm,gint,gold,dxold,OPT%hess) case (2) - call sr1(OPT%nvar,gnorm,gint,gold,displ*alpold,OPT%hess) + call sr1(OPT%nvar,gnorm,gint,gold,dxold,OPT%hess) case (3) - call bofill(OPT%nvar,gnorm,gint,gold,displ*alpold,OPT%hess) + call bofill(OPT%nvar,gnorm,gint,gold,dxold,OPT%hess) case (4) - call schlegel(OPT%nvar,gnorm,gint,gold,displ*alpold,OPT%hess) + call schlegel(OPT%nvar,gnorm,gint,gold,dxold,OPT%hess) case default write (*,*) 'invalid hessian update selection' stop From 58175d9038ff9d733fc5b59427f18c87f5f7f1d8 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 22 May 2026 19:38:19 +0200 Subject: [PATCH 337/374] update fermi smearing default for g-xTB, consistent with tblite --- src/calculator/api_engrad.f90 | 8 +------- src/calculator/calc_type.f90 | 1 + 2 files changed, 2 insertions(+), 7 deletions(-) diff --git a/src/calculator/api_engrad.f90 b/src/calculator/api_engrad.f90 index 3f2c2d55..08b6ad35 100644 --- a/src/calculator/api_engrad.f90 +++ b/src/calculator/api_engrad.f90 @@ -97,13 +97,7 @@ subroutine tblite_engrad(mol,calc,energy,grad,iostatus) !>-- populate parameters and wavefunction if (loadnew) then -! ── resolve effective Fermi temperature (gxtb defaults to 0 K) ─────── - block - real(wp) :: etemp_eff - etemp_eff = calc%etemp - if (calc%tblitelvl == xtblvl%gxtb .and. .not. calc%etemp_user_set) etemp_eff = 0.0_wp - call tblite_setup(mol,calc%chrg,calc%uhf,calc%tblitelvl,etemp_eff,calc%tblite,calc%ceh_guess) - end block + call tblite_setup(mol,calc%chrg,calc%uhf,calc%tblitelvl,calc%etemp,calc%tblite,calc%ceh_guess) call tblite_addsettings(calc%tblite,calc%maxscc,calc%rdwbo,calc%saveint,calc%accuracy) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index d6cbb4cc..d463f789 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -1550,6 +1550,7 @@ subroutine create_calclevel_shortcut(self,levelstring, & if (have_gxtb) then self%id = jobtype%tblite self%tblitelvl = xtblvl%gxtb + self%etemp = 0.0_wp ! g-xTB uses integer occupations (T=0) else self%id = jobtype%xtbsys self%other = '--gxtb' From cda173370c41e3cc1d79a4174a2632dd932af724 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 22 May 2026 21:57:35 +0200 Subject: [PATCH 338/374] cosmetics (ir intensities in "vibspectrum" file) --- src/algos/numhess.f90 | 103 ++++++++++++++++++------------ src/entropy/thermochem_module.f90 | 54 ++++++++++++---- src/printouts.f90 | 21 +++++- src/qmhelpers/CMakeLists.txt | 1 + src/qmhelpers/ir_spectrum.f90 | 83 ++++++++++++++++++++++++ src/qmhelpers/meson.build | 1 + 6 files changed, 205 insertions(+), 58 deletions(-) create mode 100644 src/qmhelpers/ir_spectrum.f90 diff --git a/src/algos/numhess.f90 b/src/algos/numhess.f90 index 569e4ac2..aef91c30 100644 --- a/src/algos/numhess.f90 +++ b/src/algos/numhess.f90 @@ -36,6 +36,7 @@ subroutine crest_numhess(env,tim) use gradreader_module use xtb_sc use oniom_hessian + use ir_spectrum implicit none type(systemdata),intent(inout) :: env @@ -48,6 +49,7 @@ subroutine crest_numhess(env,tim) real(wp) :: energy real(wp),allocatable :: hess(:,:,:),freq(:,:),grad(:),grad1(:,:),grad2(:,:),heff(:,:) real(wp),allocatable :: ohess(:,:),ofreq(:),grad0(:,:),energies0(:) + real(wp),allocatable :: ir_int(:) character(len=60) :: atmp !========================================================================================! call tim%start(15,'Numerical Hessian') @@ -115,6 +117,11 @@ subroutine crest_numhess(env,tim) allocate (hess(nat3,nat3,calc%ncalculations),source=0.0_wp) allocate (freq(nat3,n_freqs),source=0.0_wp) +! ── auto-enable dipole gradient for single tblite level ────────────────────── + if (calc%ncalculations == 1) then + if (calc%calcs(1)%id == jobtype%tblite) calc%calcs(1)%rddip = .true. + end if + !********************************************************************************* !>--- Computes numerical Hessians and stores them individually for each level call numhess2(mol%nat,mol%at,mol%xyz,calc,hess,io) @@ -177,13 +184,19 @@ subroutine crest_numhess(env,tim) else - write (atmp,*) i + !> omit numeric suffix when there is only one calculation level + if (calc%ncalculations == 1) then + atmp = '' + else + write (atmp,*) i + atmp = trim(adjustl(atmp)) + end if !>-- Prints Hessian - call print_hessian(hess(:,:,i),nat3,'','numhess'//trim(adjustl(atmp))) + call print_hessian(hess(:,:,i),nat3,'','numhess'//trim(atmp)) !>--- Print dipole gradients (if they exist) - call calc%calcs(i)%dumpdipgrad('dipgrad'//trim(adjustl(atmp))) + call calc%calcs(i)%dumpdipgrad('dipgrad'//trim(atmp)) !>-- Projects and mass-weights the Hessian call prj_mw_hess(mol%nat,mol%at,nat3,mol%xyz,hess(:,:,i)) @@ -195,16 +208,24 @@ subroutine crest_numhess(env,tim) write (stdout,*) 'FAILED!' else - !>-- Prints vibspectrum with artifical intensities +! ── project dipole gradient onto normal modes → IR intensities ─────────── + if (allocated(calc%calcs(i)%dipgrad)) then + allocate(ir_int(nat3),source=0.0_wp) + call ir_intensities(mol%nat,mol%at,nat3,hess(:,:,i), & + & calc%calcs(i)%dipgrad,ir_int) + end if + + !>-- Prints vibspectrum call print_vib_spectrum(mol%nat,mol%at,nat3,mol%xyz,freq(:,i), & - & '','vibspectrum'//trim(adjustl(atmp))) + & '','vibspectrum'//trim(atmp),ir_int=ir_int) - !>-- Prints g98.out format file + !>-- Prints g98.out format file (suffix prevents overwrite for empty calcspace) call print_g98_fake(mol%nat,mol%at,nat3,mol%xyz,freq(:,i),hess(:,:,i), & - & calc%calcs(i)%calcspace,'g98.out') + & calc%calcs(i)%calcspace,'g98'//trim(atmp)//'.out',ir_int=ir_int) - write (atmp,*) i - call smallhead("Thermo contributions for [[calculation.level]] "//trim(adjustl(atmp))) + if (allocated(ir_int)) deallocate(ir_int) + + call smallhead("Thermo contributions for [[calculation.level]] "//trim(atmp)) call numhess_thermostat(env,mol,nat3,hess(:,:,i),freq(:,i),energies0(i)) end if @@ -284,12 +305,9 @@ subroutine numhess_thermostat(env,mol,nat3,hess,freq,etot) !> LOCAL real(wp) :: ithr,fscal,sthr character(len=:),allocatable :: emodel - integer :: nt,nfreq,nrt + integer :: nt,nrt real(wp),allocatable :: temps(:),et(:),ht(:),stot(:),gt(:) real(wp) :: zpve - character(len=*),parameter :: outfmt = & - & '(10x,"::",1x,a,f24.12,1x,a,1x,"::")' - integer :: iunit !> inversion threshold ithr = env%thermo%ithr @@ -313,21 +331,10 @@ subroutine numhess_thermostat(env,mol,nat3,hess,freq,etot) !> calcthermo wants input in Bohr call calcthermo(mol%nat,mol%at,mol%xyz,freq,.true., & - & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,emodel=emodel) !> THIS HAS IUNIT IN IT!!!! + & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,emodel=emodel) - !> printoutgeometr zpve = et(nrt)-ht(nrt) - write (stdout,*) - write (stdout,'(10x,a)') repeat(':',50) - write (stdout,'(10x,"::",7x,a,f12.2,1x,a,8x,"::")') "THERMODYNAMICS at",temps(nrt),'K' - write (stdout,'(10x,a)') repeat(':',50) - write (stdout,outfmt) 'TOTAL FREE ENERGY',etot+gt(nrt),'Eh' - write (stdout,'(10x,a)') '::'//repeat('-',46)//'::' - write (stdout,outfmt) 'total energy ',etot,'Eh' - write (stdout,outfmt) 'ZPVE ',zpve,'Eh' - write (stdout,outfmt) 'G(RRHO) w/o ZPVE ',gt(nrt)-zpve,'Eh' - write (stdout,outfmt) 'G(RRHO) total ',gt(nrt),'Eh' - write (stdout,'(10x,a)') repeat(':',50) + call print_thermo_summary(stdout,temps(nrt),etot,zpve,gt(nrt)) deallocate (stot,gt,ht,et,temps) end subroutine numhess_thermostat @@ -355,12 +362,10 @@ subroutine thermo_standalone(env) real(wp) :: etot real(wp) :: ithr,fscal,sthr character(len=:),allocatable :: emodel - integer :: nt,nfreq,nrt + integer :: nt,nrt real(wp),allocatable :: temps(:),et(:),ht(:),stot(:),gt(:) real(wp) :: zpve - integer :: ich,i,iunit - character(len=*),parameter :: outfmt = & - & '(10x,"::",1x,a,f24.12,1x,a,1x,"::")' + integer :: ich,i !> header write (stdout,'(t10,a)') " _ _ " @@ -424,19 +429,8 @@ subroutine thermo_standalone(env) call calcthermo(mol%nat,mol%at,mol%xyz,freq,.true., & & ithr,fscal,sthr,nt,temps,et,ht,gt,stot,stdout,emodel=emodel) - !> printout zpve = et(nrt)-ht(nrt) - write (stdout,*) - write (stdout,'(10x,a)') repeat(':',50) - write (stdout,'(10x,"::",7x,a,f12.2,1x,a,8x,"::")') "THERMODYNAMICS at",temps(nrt),'K' - write (stdout,'(10x,a)') repeat(':',50) - write (stdout,outfmt) 'TOTAL FREE ENERGY',etot+gt(nrt),'Eh' - write (stdout,'(10x,a)') '::'//repeat('-',46)//'::' - write (stdout,outfmt) 'total energy ',etot,'Eh' - write (stdout,outfmt) 'ZPVE ',zpve,'Eh' - write (stdout,outfmt) 'G(RRHO) w/o ZPVE ',gt(nrt)-zpve,'Eh' - write (stdout,outfmt) 'G(RRHO) total ',gt(nrt),'Eh' - write (stdout,'(10x,a)') repeat(':',50) + call print_thermo_summary(stdout,temps(nrt),etot,zpve,gt(nrt)) !> for plotting temperature dependencies etc. write (stdout,*) @@ -450,6 +444,31 @@ subroutine thermo_standalone(env) deallocate (stot,gt,ht,et,temps) end subroutine thermo_standalone +!========================================================================================! + +subroutine print_thermo_summary(iunit,temp,etot,zpve,grrho) +!********************************************************** +!* Print the standard THERMODYNAMICS summary box. +!* Called from numhess_thermostat and thermo_standalone. +!********************************************************** + use crest_parameters,only:wp,stdout + implicit none + integer,intent(in) :: iunit + real(wp),intent(in) :: temp,etot,zpve,grrho + character(len=*),parameter :: outfmt = '(10x,"::",1x,a,f24.12,1x,a,1x,"::")' + write (iunit,*) + write (iunit,'(10x,a)') repeat(':',50) + write (iunit,'(10x,"::",7x,a,f12.2,1x,a,8x,"::")') "THERMODYNAMICS at",temp,'K' + write (iunit,'(10x,a)') repeat(':',50) + write (iunit,outfmt) 'TOTAL FREE ENERGY',etot+grrho,'Eh' + write (iunit,'(10x,a)') '::'//repeat('-',46)//'::' + write (iunit,outfmt) 'total energy ',etot,'Eh' + write (iunit,outfmt) 'ZPVE ',zpve,'Eh' + write (iunit,outfmt) 'G(RRHO) w/o ZPVE ',grrho-zpve,'Eh' + write (iunit,outfmt) 'G(RRHO) total ',grrho,'Eh' + write (iunit,'(10x,a)') repeat(':',50) +end subroutine print_thermo_summary + !========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< PRINTOUT ROUTINES - subroutine print_vib_spectrum(nat,at,nat3,xyz,freq,dir,fname) -!********************************************************************* -!* Prints the frequencies in Turbomoles "vibspectrum" format -!* The intensity is only artficially set to 1000 for every vibration!! -!********************************************************************** + subroutine print_vib_spectrum(nat,at,nat3,xyz,freq,dir,fname,ir_int) +!****************************************************************** +!* Prints the frequencies in Turbomole "vibspectrum" format. +!* When ir_int is provided, genuine intensities (km/mol) and +!* a threshold-based IR-activity flag are written; otherwise a +!* dummy intensity of 1000 km/mol is used for all active modes. +!* Input: +!* ir_int (optional) - IR intensities in km/mol, shape (nat3) +!****************************************************************** integer,intent(in) :: nat,nat3 integer :: at(nat),i,ich real(wp) :: xyz(3,nat) real(wp) :: freq(nat3),thr + real(wp),intent(in),optional :: ir_int(nat3) character(len=*) :: fname character(len=*) :: dir + !> IR-activity threshold in km/mol + real(wp),parameter :: ir_thr = 1.0_wp + real(wp) :: irint_i + character(len=3) :: ir_flag thr = 0.01_wp if (len_trim(dir) .eq. 0) then @@ -642,8 +651,19 @@ subroutine print_vib_spectrum(nat,at,nat3,xyz,freq,dir,fname) write (ich,'(i6,9x, f18.2,f16.5,7x," - ",5x," - ")') & i,freq(i),0.0_wp else - write (ich,'(i6,8x,"a",f18.2,f16.5,7x,"YES",5x,"YES")') & - i,freq(i),1000.0_wp + if (present(ir_int)) then + irint_i = ir_int(i) + if (irint_i >= ir_thr) then + ir_flag = 'YES' + else + ir_flag = 'NO ' + end if + else + irint_i = 1000.0_wp + ir_flag = 'YES' + end if + write (ich,'(i6,8x,"a",f18.2,f16.5,7x,a3,5x,"YES")') & + i,freq(i),irint_i,ir_flag end if end do @@ -655,18 +675,23 @@ end subroutine print_vib_spectrum !=========================================================================================! - subroutine print_g98_fake(nat,at,nat3,xyz,freq,hess,dir,fname) -!**************************************************************** -!* Prints the vibration spectrum of the a system as a g98.out. + subroutine print_g98_fake(nat,at,nat3,xyz,freq,hess,dir,fname,ir_int) +!****************************************************************** +!* Prints the vibration spectrum of a system as a g98.out file. !* Routine is adapted from the xtb code. -!**************************************************************** +!* When ir_int is provided, genuine IR intensities (km/mol) are +!* written; otherwise a dummy value of 99 km/mol is used. +!* Input: +!* ir_int (optional) - IR intensities in km/mol, shape (nat3) +!****************************************************************** integer,intent(in) :: nat,nat3 integer :: at(nat) integer :: gu,i,j,ka,kb,kc,la,lb,k real(wp) :: xyz(3,nat) real(wp),intent(in) :: hess(nat3,nat3) - real(wp) :: freq(nat3),red_mass(nat3),force(nat3),ir_int(nat3),zero(1),f2(nat3),u(nat3,nat3) + real(wp),intent(in),optional :: ir_int(nat3) + real(wp) :: freq(nat3),red_mass(nat3),force(nat3),ir_f(nat3),zero(1),f2(nat3),u(nat3,nat3) character(len=2) :: irrep character(len=*) :: fname @@ -676,7 +701,7 @@ subroutine print_g98_fake(nat,at,nat3,xyz,freq,hess,dir,fname) red_mass = 99.0 force = 99.0 - ir_int = 99.0 + ir_f = 99.0 zero = 0.0 k = 0 @@ -686,6 +711,7 @@ subroutine print_g98_fake(nat,at,nat3,xyz,freq,hess,dir,fname) k = k+1 u(1:nat3,k) = hess(1:nat3,i) f2(k) = freq(i) + if (present(ir_int)) ir_f(k) = ir_int(i) end if end do @@ -740,7 +766,7 @@ subroutine print_g98_fake(nat,at,nat3,xyz,freq,hess,dir,fname) write (gu,110) ' Frequencies --', (f2(j),j=ka,kb) write (gu,110) ' Red. masses --', (red_mass(j),j=ka,kb) write (gu,110) ' Frc consts --', (force(j),j=ka,kb) - write (gu,110) ' IR Inten --', (ir_int(j),j=ka,kb) + write (gu,110) ' IR Inten --', (ir_f(j),j=ka,kb) write (gu,110) ' Raman Activ --', (zero,j=ka,kb) write (gu,110) ' Depolar --', (zero,j=ka,kb) write (gu,*) 'Atom AN X Y Z X Y', & diff --git a/src/printouts.f90 b/src/printouts.f90 index c212a8c0..e490b9c1 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -1128,7 +1128,7 @@ subroutine crest_output_summary(env) case (crest_imtd,crest_imtd2,crest_screen,crest_mdopt, & & crest_sorting,crest_optimize,crest_trialopt,crest_rigcon, & & crest_moldyn,crest_bh,crest_bhpt,crest_protonate,crest_deprotonate, & - & crest_tautomerize) + & crest_tautomerize,crest_numhessian,crest_ensemblehess) write (stdout,*) write (stdout,*) write (stdout,'(2x,a)') 'Important files written by CREST during this run' @@ -1165,6 +1165,23 @@ subroutine crest_output_summary(env) case (crest_optimize,crest_trialopt,crest_rigcon) call wfe('crestopt.xyz','final optimized geometry') call wfe('crestopt.log.xyz','step-by-step optimization trajectory') + if (env%crest_ohess) then + call wfe('numhess','Hessian matrix in Turbomole format (2nd derivatives, a.u.)') + call wfe('vibspectrum','vibrational frequencies (cm⁻¹) and IR intensities (km/mol)') + call wfe('g98.out','frequencies and normal modes in Gaussian 98 output format') + end if + + ! ── numerical Hessian ───────────────────────── + case (crest_numhessian) + call wfe('numhess','Hessian matrix in Turbomole format (2nd derivatives, a.u.)') + call wfe('vibspectrum','vibrational frequencies (cm⁻¹) and IR intensities (km/mol)') + call wfe('g98.out','frequencies and normal modes in Gaussian 98 output format') + call wfe('dipgrad','Cartesian dipole gradient ∂μ/∂x (a.u.), if available') + + ! ── ensemble Hessians ───────────────────────── + case (crest_ensemblehess) + call wfe('crest_ensemble.xyz','input ensemble with Gibbs free energies as comments') + call wfe('crest.energies','plain list of total Gibbs free energies (Eh)') ! ── molecular dynamics ──────────────────────── case (crest_moldyn) @@ -1196,7 +1213,7 @@ subroutine crest_output_summary(env) case (crest_imtd,crest_imtd2,crest_screen,crest_mdopt, & & crest_sorting,crest_optimize,crest_trialopt,crest_rigcon, & & crest_moldyn,crest_bh,crest_bhpt,crest_protonate,crest_deprotonate, & - & crest_tautomerize) + & crest_tautomerize,crest_numhessian,crest_ensemblehess) write (stdout,'(1x,a)') hbar end select diff --git a/src/qmhelpers/CMakeLists.txt b/src/qmhelpers/CMakeLists.txt index 76954b44..0fdb9eb6 100644 --- a/src/qmhelpers/CMakeLists.txt +++ b/src/qmhelpers/CMakeLists.txt @@ -21,6 +21,7 @@ list(APPEND srcs "${dir}/intpack.f90" "${dir}/lopt.f90" "${dir}/local.f90" + "${dir}/ir_spectrum.f90" ) set(srcs ${srcs} PARENT_SCOPE) diff --git a/src/qmhelpers/ir_spectrum.f90 b/src/qmhelpers/ir_spectrum.f90 new file mode 100644 index 00000000..b4372aff --- /dev/null +++ b/src/qmhelpers/ir_spectrum.f90 @@ -0,0 +1,83 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2025 Philipp Pracht +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module ir_spectrum + use crest_parameters,only:wp,amutokg,metokg + use atmasses,only:ams + implicit none + private + public :: ir_intensities + +contains + + subroutine ir_intensities(nat,at,nat3,evec,dipd,intens) +!*********************************************************************** +!* Compute double-harmonic IR intensities from Cartesian dipole +!* gradients projected onto normal mode eigenvectors. +!* Intensities are returned in km/mol. +!* +!* Input: +!* nat - number of atoms +!* at - atomic numbers (nat) +!* nat3 - 3*nat +!* evec - mass-weighted Hessian eigenvectors, shape (nat3,nat3), +!* columns are normal modes (output of dsyevd via frequencies()) +!* dipd - Cartesian dipole gradient ∂μ/∂x_i in a.u., shape (3,nat3) +!* Output: +!* intens - IR intensities in km/mol, shape (nat3) +!*********************************************************************** + implicit none + integer,intent(in) :: nat,nat3 + integer,intent(in) :: at(nat) + real(wp),intent(in) :: evec(nat3,nat3) + real(wp),intent(in) :: dipd(3,nat3) + real(wp),intent(out) :: intens(nat3) + !> conversion: |∂μ/∂Q|² in a.u. → km/mol + real(wp),parameter :: au_to_kmmol = 1.7770969e+6_wp + real(wp),allocatable :: invmass(:) + real(wp) :: trdip(3),sum2,amutoau + integer :: i,j,k,ii + +! ── inverse square root mass vector, one entry per Cartesian coordinate ── + amutoau = amutokg/metokg + allocate(invmass(nat3),source=0.0_wp) + do i = 1,nat + do j = 1,3 + ii = (i-1)*3+j + invmass(ii) = 1.0_wp/sqrt(ams(at(i))*amutoau) + end do + end do + +! ── project dipole gradient onto each normal mode ──────────────────────── + intens = 0.0_wp + do i = 1,nat3 + do k = 1,3 + sum2 = 0.0_wp + do j = 1,nat3 + sum2 = sum2+dipd(k,j)*(evec(j,i)*invmass(j)) + end do + trdip(k) = sum2 + end do + intens(i) = au_to_kmmol*(trdip(1)**2+trdip(2)**2+trdip(3)**2) + end do + + deallocate(invmass) + end subroutine ir_intensities + +end module ir_spectrum diff --git a/src/qmhelpers/meson.build b/src/qmhelpers/meson.build index 0716e307..9adba846 100644 --- a/src/qmhelpers/meson.build +++ b/src/qmhelpers/meson.build @@ -19,4 +19,5 @@ srcs += files( 'intpack.f90', 'lopt.f90', 'local.f90', + 'ir_spectrum.f90', ) From 12c6caa7d9e729e546f10e7ca3a5585e2d14b8fd Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Fri, 22 May 2026 22:54:26 +0200 Subject: [PATCH 339/374] cosmetics (nicer MD/MTD block printout) --- src/algos/parallel.f90 | 42 +++++++++++++++++++++++------------------- src/algos/scan.f90 | 2 -- src/iomod.F90 | 22 ++++++++++++++++++++-- src/sorting/cregen.f90 | 4 ++-- 4 files changed, 45 insertions(+), 25 deletions(-) diff --git a/src/algos/parallel.f90 b/src/algos/parallel.f90 index c6da368d..1805fba2 100644 --- a/src/algos/parallel.f90 +++ b/src/algos/parallel.f90 @@ -1158,14 +1158,15 @@ subroutine parallel_md_block_printout(MD,vz) use strucrd use dynamics_module use shake_module - use iomod,only:to_str + use iomod,only:to_str,drawbox implicit none type(mddata),intent(in) :: MD integer,intent(in) :: vz - character(len=40) :: atmp - integer :: il + character(len=60) :: atmp + integer,parameter :: bw = 54 !$omp critical + ! ── title ──────────────────────────────────────────────────── if (MD%simtype == type_md) then write (atmp,'(a,1x,i3)') 'starting MD',vz else if (MD%simtype == type_mtd) then @@ -1175,40 +1176,43 @@ subroutine parallel_md_block_printout(MD,vz) write (atmp,'(a,1x,i4)') 'starting MTD',vz end if end if - il = (44-len_trim(atmp))/2 - write (stdout,'(2x,a,1x,a,1x,a)') repeat(':',il),trim(atmp),repeat(':',il) - - write (stdout,'(2x,"| MD simulation time :",f8.1," ps |")') MD%length_ps - write (stdout,'(2x,"| target T :",f8.1," K |")') MD%tsoll - write (stdout,'(2x,"| timestep dt :",f8.1," fs |")') MD%tstep - write (stdout,'(2x,"| dump interval(trj) :",f8.1," fs |")') MD%dumpstep + call drawbox(stdout,trim(atmp),width=bw,charset=4,ltab=1,procedual=0) + call drawbox(stdout,trim(atmp),width=bw,charset=4,ltab=1,procedual=1) + call drawbox(stdout,trim(atmp),width=bw,charset=4,ltab=1,procedual=3) + + ! ── simulation parameters ──────────────────────────────────── + write (stdout,'(1x,"│ MD simulation time :",f8.1," ps",16x,"│")') MD%length_ps + write (stdout,'(1x,"│ target T :",f8.1," K",17x,"│")') MD%tsoll + write (stdout,'(1x,"│ timestep dt :",f8.1," fs",16x,"│")') MD%tstep + write (stdout,'(1x,"│ dump interval(trj) :",f8.1," fs",16x,"│")') MD%dumpstep if (MD%shake.and.MD%shk%shake_mode > 0) then if (MD%shk%shake_mode == 2) then - write (stdout,'(2x,"| SHAKE algorithm :",a5," (all bonds) |")') to_str(MD%shake) + write (stdout,'(1x,"│ SHAKE algorithm :",a5," (all bonds)",10x,"│")') to_str(MD%shake) else - write (stdout,'(2x,"| SHAKE algorithm :",a5," (H only) |")') to_str(MD%shake) + write (stdout,'(1x,"│ SHAKE algorithm :",a5," (H only)",13x,"│")') to_str(MD%shake) end if end if if (allocated(MD%active_potentials)) then - write (stdout,'(2x,"| active potentials :",i4," potential |")') size(MD%active_potentials,1) + write (stdout,'(1x,"│ active potentials :",i4," potential(s)",10x,"│")') size(MD%active_potentials,1) end if if (MD%simtype == type_mtd) then if (MD%cvtype(1) == cv_rmsd) then - write (stdout,'(2x,"| dump interval(Vbias) :",f8.2," ps |")') & + write (stdout,'(1x,"│ dump interval(Vbias) :",f8.2," ps",16x,"│")') & & MD%mtd(1)%cvdump_fs/1000.0_wp end if - write (stdout,'(2x,"| Vbias prefactor (k) :",f8.4," Eh |")') & - & MD%mtd(1)%kpush + write (stdout,'(1x,"│ Vbias prefactor (k) :",f8.4," Eh",16x,"│")') MD%mtd(1)%kpush if (MD%cvtype(1) == cv_rmsd.or.MD%cvtype(1) == cv_rmsd_static) then - write (stdout,'(2x,"| Vbias exponent (α) :",f8.4," bohr⁻² |")') MD%mtd(1)%alpha + write (stdout,'(1x,"│ Vbias exponent (α) :",f8.4," bohr⁻²",12x,"│")') MD%mtd(1)%alpha else - write (stdout,'(2x,"| Vbias exponent (α) :",f8.4," |")') MD%mtd(1)%alpha + write (stdout,'(1x,"│ Vbias exponent (α) :",f8.4,19x,"│")') MD%mtd(1)%alpha end if if (allocated(MD%mtd(1)%atinclude)) then - write (stdout,'(2x,"| # active atoms :",i9," atoms |")') count(MD%mtd(1)%atinclude,1) + write (stdout,'(1x,"│ # active atoms :",i9," atoms",12x,"│")') count(MD%mtd(1)%atinclude,1) end if end if + call drawbox(stdout,'',width=bw,charset=4,ltab=1,procedual=2) + !$omp end critical end subroutine parallel_md_block_printout diff --git a/src/algos/scan.f90 b/src/algos/scan.f90 index abf20a48..7f79dab5 100644 --- a/src/algos/scan.f90 +++ b/src/algos/scan.f90 @@ -190,8 +190,6 @@ subroutine initscans(mol,calc) deallocate (tmppoints) end do - write(*,*) 'constraints',calc%nconstraints - !>--- set calculations to 1 for the geometry generation calc%ncalculations = 1 diff --git a/src/iomod.F90 b/src/iomod.F90 index 000a803d..82b02e89 100644 --- a/src/iomod.F90 +++ b/src/iomod.F90 @@ -883,7 +883,8 @@ subroutine drawbox(prch,str,width,charset,padl,padr,ltab,procedual,color) !* when width is given, padl is auto-centred and padr fills !* ltab - leading spaces before the box (default 0) !* procedual - which lines to emit: -1=all three (default), - !* 0=top only, 1=centre line only, 2=bottom only + !* 0=top only, 1=centre line only, 2=bottom only, + !* 3=separator (T-intersection) line only !* color - optional border colour name passed to colorify() !*********************************************************************** implicit none @@ -904,7 +905,7 @@ subroutine drawbox(prch,str,width,charset,padl,padr,ltab,procedual,color) character(len=*),parameter :: set7 = '┍━┑│┕┙' integer :: ul,ho,ur,ve,ll,lr,d - character(len=:),allocatable :: boxchars + character(len=:),allocatable :: boxchars,sepchars ul = 1; ho = 2; ur = 3; ve = 4; ll = 5; lr = 6; d = 0 if (present(charset)) then @@ -915,21 +916,29 @@ subroutine drawbox(prch,str,width,charset,padl,padr,ltab,procedual,color) select case (charset) case (2) boxchars = set2 + sepchars = '++' case (3) boxchars = set3 + sepchars = '==' case (4) boxchars = set4 + sepchars = '├┤' case (5) boxchars = set5 + sepchars = '┣┫' case (6) boxchars = set6 + sepchars = '╠╣' case (7) boxchars = set7 + sepchars = '┝┥' case default boxchars = set1 + sepchars = '**' end select else boxchars = set1 + sepchars = '**' end if strlen = len(str) @@ -991,6 +1000,15 @@ subroutine drawbox(prch,str,width,charset,padl,padr,ltab,procedual,color) end if end if + if (procc == 3) then + write (prch,'(a)',advance='no') repeat(' ',ltabb) + if (present(color)) then + write (prch,'(a)') colorify(sepchars(1:1+d)//repeat(boxchars(ho:ho+d),wid)//sepchars(2+d:2*(1+d)),color) + else + write (prch,'(a)') sepchars(1:1+d)//repeat(boxchars(ho:ho+d),wid)//sepchars(2+d:2*(1+d)) + end if + end if + end subroutine drawbox !=========================================================================================! diff --git a/src/sorting/cregen.f90 b/src/sorting/cregen.f90 index 41e77be1..da2449f5 100644 --- a/src/sorting/cregen.f90 +++ b/src/sorting/cregen.f90 @@ -1219,12 +1219,12 @@ subroutine cregen_CRE_new(env,nall,structures,groups,rthresh,ethr,bthr, & if (prlvl > 0) then !if (prlvl > 1 .and.prch == stdout) then - if (prlvl > 1) then + if (prlvl > 1 .and.prch == stdout) then ! call progress_update(ps,nall,nall) ! call progress_finish(ps) write (prch,'(a)') 'done.' else - write (stdout,'(a)') 'done.' + write (stdout,'(a)') ' done.' end if end if From 5b181669f1c578f42e02a64bad76b5ef15e8246c Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 23 May 2026 18:25:16 +0200 Subject: [PATCH 340/374] cosmetics (remove stale refine part) --- src/algos/CMakeLists.txt | 1 - src/algos/ConfSolv.F90 | 577 --------------------------------- src/algos/meson.build | 1 - src/algos/refine.f90 | 7 - src/calculator/calc_type.f90 | 1 - src/classes.f90 | 1 - src/crest_main.f90 | 7 - src/parsing/parse_maindata.f90 | 53 --- src/sigterm.F90 | 16 - 9 files changed, 664 deletions(-) delete mode 100644 src/algos/ConfSolv.F90 diff --git a/src/algos/CMakeLists.txt b/src/algos/CMakeLists.txt index 0fd9ddf6..8f68ab9f 100644 --- a/src/algos/CMakeLists.txt +++ b/src/algos/CMakeLists.txt @@ -30,7 +30,6 @@ list(APPEND srcs "${dir}/setuptest.f90" "${dir}/sorting.f90" "${dir}/protonate.f90" - "${dir}/ConfSolv.F90" "${dir}/search_conformers.f90" "${dir}/search_entropy.f90" "${dir}/parallel.f90" diff --git a/src/algos/ConfSolv.F90 b/src/algos/ConfSolv.F90 deleted file mode 100644 index e0818c47..00000000 --- a/src/algos/ConfSolv.F90 +++ /dev/null @@ -1,577 +0,0 @@ -!================================================================================! -! This file is part of crest. -! -! Copyright (C) 2023 Philipp Pracht -! -! crest is free software: you can redistribute it and/or modify it under -! the terms of the GNU Lesser General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! crest is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU Lesser General Public License for more details. -! -! You should have received a copy of the GNU Lesser General Public License -! along with crest. If not, see . -!================================================================================! - -!> A data storage module for hosting ConfSolv as a http server with requests -!> We need to know the server's PORT to create the request -!> CREST can either try to host the server on its own, or the user -!> must provide the PORT. -!> All of this assumes that the ConfSolv submodule was loaded - -module ConfSolv_module - use crest_parameters - use crest_data - use strucrd - use iomod - implicit none - public - - !> ConfSolv helper script PID - integer,allocatable :: cs_pid - !> ConfSolv helper script name - character(len=:),allocatable :: cs_bin - !> ConfSolv port server port - integer,allocatable :: cs_port - !> ConfSolv teardown instruction - logical :: cs_teardown = .false. - !> Keeping track of setup. Has it been called already? - logical :: cs_setup = .false. - - !> ConfSolv parameter location - character(len=:),allocatable :: cs_param - !> ConfSolv solvent & smiles - character(len=:),allocatable :: cs_solvent - character(len=:),allocatable :: cs_solvfile - character(len=:),allocatable :: cs_smiles - - !> n_threshold_mols - integer :: cs_n_threshold_mols = 1 - -!========================================================================================! -!========================================================================================! -contains !> MODULE PROCEDURES START HERE -!========================================================================================! -!========================================================================================! - - subroutine cs_deallocate() - if (allocated(cs_pid)) deallocate (cs_pid) - if (allocated(cs_bin)) deallocate (cs_bin) - if (allocated(cs_port)) deallocate (cs_port) - if (allocated(cs_param)) deallocate (cs_param) - if (allocated(cs_solvent)) deallocate (cs_solvent) - end subroutine cs_deallocate - -!=================================================! - - function cs_running() result(running) - implicit none - logical :: running - integer :: io - character(len=:),allocatable :: job - running = .false. - - io = 0 - if (.not.allocated(cs_bin).or. & - & .not.allocated(cs_pid).or. & - & .not.allocated(cs_port)) then - running = .false. - return - end if - - job = trim(cs_bin)//' --test '//to_str(cs_port) - - call command(job,io) - - end function cs_running - -!=================================================! - subroutine cs_shutdown(io) - implicit none - integer,intent(out) :: io - - io = 0 - if (cs_teardown.and.allocated(cs_pid).and.allocated(cs_port)) then - write (stdout,'(/,a,i0)') 'Shutting down http://localhost/',cs_port - call kill(cs_pid,9,io) - deallocate (cs_pid) - call cs_shutdown2(io) - end if - - end subroutine cs_shutdown - -!=================================================! - subroutine cs_shutdown2(io) - use iomod - implicit none - integer,intent(out) :: io - integer :: ich,ro,pids - character(len=100) :: str - character(len=50) :: str2 - call command('lsof confsolv.out > tmpcs 2>/dev/null',io) - - open(newunit=ich,file='tmpcs') - do - read(ich,'(a)',iostat=ro) str - if(ro < 0 ) exit - !write(*,*) trim(str) - read(str,*,iostat=ro) str2,pids - if(ro == 0)then - ! write(*,*) pids - call kill(pids,9,io) - endif - enddo - close(ich) - - call remove('tmpcs') - end subroutine cs_shutdown2 - -!=================================================! - - subroutine cs_deploy() - implicit none - character(len=:),allocatable :: job - integer :: io,ich - character(len=50) :: atmp - logical :: ex - - if (.not.allocated(cs_bin)) cs_bin = 'confsolvserver' - !call remove('confsolv.out') - call remove('config_template.toml') - - job = 'nohup '//trim(cs_bin)//' -l '//'> confsolv.out 2>/dev/null'//' &' - - write (stdout,'(2x,a,a)') 'Hosting command: ',trim(job) - call command(job,io) - - if (io /= 0) error stop '**ERROR** failed to host ConfSolv server' - !call sleep(3) - do - call sleep(1) - inquire (file='config_template.toml',exist=ex) - if (ex) exit - end do - - !> read port and pid - open (newunit=ich,file='confsolv.out') - read (ich,*) atmp,cs_pid - read (ich,*) atmp,cs_port - close (ich) - cs_teardown = .true. - cs_setup = .false. - write (stdout,'(2x,2(a,i0))') 'ConfSolv server will be running at http://localhost:',cs_port,' with PID ',cs_pid - end subroutine cs_deploy - -!=================================================! - - subroutine cs_write_config(ensname,threads) - implicit none - character(len=*) :: ensname - integer :: threads - integer :: i,j,k,l,ich,io - character(len=1024) :: atmp - - call getcwd(atmp) - open (newunit=ich,file='config.toml') - call wrtoml_int(ich,'port',cs_port) - call wrtoml_int(ich,'pid',cs_pid) - call wrtoml_int(ich,'num_cores',threads) - if (allocated(cs_param)) then - call wrtoml(ich,'model_path',cs_param) - end if - - call wrtoml(ich,'xyz_file',trim(atmp)//'/'//trim(ensname)) - if (allocated(cs_solvfile)) then - call wrtoml(ich,'solvent_file',trim(atmp)//'/'//cs_solvfile) - else - call wrtoml(ich,'solvent_file',trim(atmp)//'/'//'crest_solvents.csv') - end if - - call wrtoml_int(ich,'n_threshold_mols',cs_n_threshold_mols) - close (ich) - contains - subroutine wrtoml(ch,key,val) - integer :: ch - character(len=*) :: key - character(len=*) :: val - write (ch,'(a,a,a,a)') trim(key),' = "',trim(val),'"' - end subroutine wrtoml - subroutine wrtoml_int(ch,key,val) - integer :: ch - character(len=*) :: key - integer :: val - write (ch,'(a,a,i0)') trim(key),' = ',val - end subroutine wrtoml_int - end subroutine cs_write_config - -!========================================================================================! - - subroutine cs_write_solvent_csv(solvent,smiles,ch) -!************************************************************** -!* From CREST's side it makes only sense to define ONE solvent -!* despite ConfSolv being able to handle multiple. -!* ConfSolv will read the solvents from a CSV file with the -!* columns SOLVENT_NAME and SMILES -!************************************************************** - implicit none - character(len=*),intent(in) :: solvent - character(len=*),intent(in),optional :: smiles - integer,intent(in),optional :: ch - integer :: ich - if (.not.present(ch)) then - open (newunit=ich,file='crest_solvents.csv') - else - ich = ch - end if - !> column names - write (ich,'(a,",",a)') 'SOLVENT_NAME','SMILES' - if (present(smiles)) then - write (ich,'(a,",",a)') solvent,smiles - else - !> switch case for available solvents, if no smiles was given - select case (lowercase(solvent)) - case ('acetate') - write (ich,'(a,",",a)') solvent,'CC(=O)[O-]' - case ('acetic acid') - write (ich,'(a,",",a)') solvent,'CC(=O)O' - case ('acetone') - write (ich,'(a,",",a)') solvent,'CC(=O)C' - case ('acetonitrile') - write (ich,'(a,",",a)') solvent,'CC#N' - case ('ammonia') - write (ich,'(a,",",a)') solvent,'N' - case ('ammonium') - write (ich,'(a,",",a)') solvent,'[NH4+]' - case ('benzene') - write (ich,'(a,",",a)') solvent,'c1ccccc1' - case ('benzoate') - write (ich,'(a,",",a)') solvent,'[O-]C(=O)c1ccccc1' - case ('benzylacetate') - write (ich,'(a,",",a)') solvent,'CC(=O)OCc1ccccc1' - case ('butanone','2-butanone') - write (ich,'(a,",",a)') solvent,'CCC(=O)C' - case ('chloride') - write (ich,'(a,",",a)') solvent,'[Cl-]' - case ('trichlormethane') - write (ich,'(a,",",a)') solvent,'C(Cl)(Cl)Cl' - case ('cyclohexane') - write (ich,'(a,",",a)') solvent,'C1CCCCC1' - case ('dibutylamine') - write (ich,'(a,",",a)') solvent,'CC[C@H](C)N[C@H](C)CC' - case ('dichlormethane') - write (ich,'(a,",",a)') solvent,'C(Cl)Cl' - case ('diethanolamine') - write (ich,'(a,",",a)') solvent,'OCCNCCO' - case ('diethanolammonium') - write (ich,'(a,",",a)') solvent,'OCC[NH2+]CCO' - case ('diethylamine') - write (ich,'(a,",",a)') solvent,'CCNCC' - case ('diethylammonium') - write (ich,'(a,",",a)') solvent,'CC[NH2+]CC' - case ('diethylether') - write (ich,'(a,",",a)') solvent,'CCOCC' - case ('heptyloctylether') - write (ich,'(a,",",a)') solvent,'CCCCCCCCOCCCCCCC' - case ('acetamide') - write (ich,'(a,",",a)') solvent,'CC(=O)N(C)C' - case ('diethylformamide') - write (ich,'(a,",",a)') solvent,'CN(C)C=O' - case ('dmso') - write (ich,'(a,",",a)') solvent,'CS(=O)C' - case ('dioxolone','2-dioxolone') - write (ich,'(a,",",a)') solvent,'C1COC(=O)O1' - case ('ethylmethylester') - write (ich,'(a,",",a)') solvent,'CCOC(=O)OC' - case ('ethanol') - write (ich,'(a,",",a)') solvent,'CCO' - case ('ethylacetate') - write (ich,'(a,",",a)') solvent,'CCOC(=O)C' - case ('ethylamine') - write (ich,'(a,",",a)') solvent,'CCN' - case ('ethylaminium') - write (ich,'(a,",",a)') solvent,'CC[NH3+]' - case ('glycol') - write (ich,'(a,",",a)') solvent,'OCCO' - case ('formate') - write (ich,'(a,",",a)') solvent,'C(=O)[O-]' - case ('formic acid') - write (ich,'(a,",",a)') solvent,'C(=O)O' - case ('butyrolacetone') - write (ich,'(a,",",a)') solvent,'O=C1CCCO1' - case ('glycerin') - write (ich,'(a,",",a)') solvent,'OCC(O)CO' - case ('water','h2o') - write (ich,'(a,",",a)') solvent,'O' - case ('sulfuric acid') - write (ich,'(a,",",a)') solvent,'O=S(=O)(O)O' - case ('hexafluorobenzene') - write (ich,'(a,",",a)') solvent,'Fc1c(F)c(F)c(F)c(F)c1F' - case ('isooctane') - write (ich,'(a,",",a)') solvent,'CC(C)CC(C)(C)C' - case ('isopropanol') - write (ich,'(a,",",a)') solvent,'CC(O)C' - case ('methoxide') - write (ich,'(a,",",a)') solvent,'C[O-]' - case ('hexane','n-hexane') - write (ich,'(a,",",a)') solvent,'CCCCCC' - case ('1-nonadecanol','nonadecanol') - write (ich,'(a,",",a)') solvent,'CCCCCCCCCCCCCCCCCCCO' - case ('1-octanol','octanol') - write (ich,'(a,",",a)') solvent,'OCCCCCCCC' - case ('p-dichlorobenzene','dichlorobenzene') - write (ich,'(a,",",a)') solvent,'Clc1ccccc1Cl' - case ('perfluorohexane') - write (ich,'(a,",",a)') solvent,'C(C(C(C(F)(F)F)(F)F)(F)F)(C(C(F)(F)F)(F)F)(F)F' - case ('propanediol') - write (ich,'(a,",",a)') solvent,'C[C@@H](O)CO' - case ('tetraethylammoniom') - write (ich,'(a,",",a)') solvent,'CC[N+](CC)(CC)CC' - case ('thf','tetrahydrofuran') - write (ich,'(a,",",a)') solvent,'O1CCCC1' - case ('toluene') - write (ich,'(a,",",a)') solvent,'Cc1ccccc1' - case ('tributylphosphate') - write (ich,'(a,",",a)') solvent,'O=P(OCCCC)(OCCCC)OCCCC' - case ('triethanolamine','trolamine') - write (ich,'(a,",",a)') solvent,'OCCN(CCO)CCO' - case ('triethanolammonium') - write (ich,'(a,",",a)') solvent,'OCC[NH+](CCO)CCO' - case ('triethylamine','net3') - write (ich,'(a,",",a)') solvent,'CCN(CC)CC' - case ('triethylammonium') - write (ich,'(a,",",a)') solvent,'CC[NH+](CC)CC' - case ('triglyme') - write (ich,'(a,",",a)') solvent,'COCCOCCOCCOC' - case ('urea') - write (ich,'(a,",",a)') solvent,'NC(=O)N' - case default - write (stderr,'(2a)') '**ERROR** failed to find matching solvent SMILES for: ',solvent - error stop - end select - end if - close (ich) - end subroutine cs_write_solvent_csv - -!========================================================================================! - - subroutine confsolv_select_gsoln(nall,ncol,data,gsoln,mapping) -!************************************************ -!* From the matrix of ΔΔGsoln, select the best -!* for each conformer and document which solvent -!* that corresponds to -!************************************************ - implicit none - integer,intent(in) :: nall,ncol - real(wp),intent(in) :: data(ncol,nall) - real(wp),intent(out) :: gsoln(nall) - integer,intent(out) :: mapping(nall) - integer :: i,j,k,l,mink - real(wp) :: dum - mapping(:) = 0 - gsoln(:) = huge(dum) - if (ncol < 3) then -!>--- ConfSolv should put out at least 3 csv columns. The first two are just IDs - write (stderr,'(a)') '**ERROR** dimension mismatch in ConfSolv data processing' - error stop - end if - do i = 1,nall - do j = 3,ncol - k = j-2 - if (data(j,i) < gsoln(i)) then - mink = k - gsoln(i) = data(j,i) - end if - end do - mapping(i) = mink - end do - end subroutine confsolv_select_gsoln - - - subroutine confsolv_dump_gsoln(nall,ncol,gsoln,mapping,headers) -!**************************************************** -!* Dump the selected ΔΔGsoln, and the corresponding -!* solvent for each conformer -!**************************************************** - implicit none - integer,intent(in) :: nall,ncol - real(wp),intent(in) :: gsoln(nall) - integer,intent(in) :: mapping(nall) - character(len=*),intent(in) :: headers(ncol) - integer :: i,j,k,l,mink,ich - real(wp) :: dum - open(newunit=ich,file='confsolv.dat') - do i = 1,nall - k = mapping(i)+1 - write(ich,'(f15.8,1x,a)') gsoln(i),trim(headers(k)) - end do - close(ich) - end subroutine confsolv_dump_gsoln - - -!========================================================================================! -!========================================================================================! -end module ConfSolv_module - -!========================================================================================! -!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< INPUT - character(len=*),intent(in) :: ensname - integer,intent(in) :: nall - integer,intent(in) :: ncpus - !> OUTPUT - real(wp),intent(out) :: gsoln(nall) - integer,intent(out) :: io - !> LOCAL - integer :: i,j,k,l,ich - logical :: pr,wr - character(len=:),allocatable :: job - real(wp),allocatable :: column(:) - real(wp),allocatable :: data(:,:) - integer,allocatable :: mapping(:) - character(len=:),allocatable :: headers(:) - integer :: ncol,nrow - real(wp) :: avg - - io = 0 - gsoln(:) = 0.0_wp - -!>--- setup - if (allocated(cs_pid).and.allocated(cs_port)) then - !> user-provided PID and port (no automatic teardown) - write (stdout,'(2x,a,i0,a,i0)') 'Looking for ConfSolv server (PID: ',cs_pid,') running at '//& - & 'http://localhost:',cs_port - !cs_teardown = .false. - else - !> fallback: automatic host (not recommended) - allocate (cs_pid,cs_port) - call cs_deploy() - end if - if (allocated(cs_param)) then - write (stdout,'(2x,a,/,3x,a)') 'pyTorch checkpoint files located at ',cs_param - else - write (stderr,*) '**ERROR** cannot run ConfSolv without defining checkpoint file location!' - error stop - end if - !> pass the user-defined solvents-csv, or do a single solvent - if (allocated(cs_solvfile)) then - write (stdout,'(2x,a,a)') 'Requested ΔΔGsoln for solvents in ',cs_solvfile - call parse_csv_file_column(cs_solvfile,1,headers) - else - if (allocated(cs_solvent).and.allocated(cs_smiles)) then - write (stdout,'(2x,a,a,3a)') 'Requested ΔΔGsoln for ',cs_solvent,' (SMILES: ',trim(cs_smiles),')' - call cs_write_solvent_csv(cs_solvent,smiles=cs_smiles) - else if (allocated(cs_solvent)) then - write (stdout,'(2x,a,a,a)') 'Requested ΔΔGsoln for ',cs_solvent,' (trying to find SMILES ...)' - call cs_write_solvent_csv(cs_solvent) - end if - allocate(headers(2), source=trim(cs_solvent)) - end if - write (stdout,'(2x,a,a)') 'Processing ensemble file ',trim(ensname) - -!>---- creating the request configuration - write (stdout,'(2x,a)',advance='no') 'Writing config.toml file ...' - flush (stdout) - call cs_write_config(ensname,ncpus) - write (stdout,*) 'done.' - - job = '' - job = trim(job)//' '//cs_bin//' -c config.toml' -!>----- this should only be called once: - if (.not.cs_setup) then - write (stdout,'(2x,a)',advance='no') 'Instructing ConfSolv model setup ...' - flush (stdout) - call command(trim(job)//' -s >> confsolv.out 2>/dev/null',io) - if (io /= 0) then - write (stdout,*) - write (stderr,'(a)') "**ERROR** failed request to ConfSolv server" - call cs_shutdown(io) - error stop - end if - cs_setup = .true. - write (stdout,*) 'done.' - end if - -!>---- and then the actual evaluation - call remove('confsolv.csv') - call remove('confsolv_uncertainty.csv') - write (stdout,'(2x,a)',advance='no') 'Evaluation of ConfSolv D-MPNN ...' - flush (stdout) - call command(trim(job)//' -r >> confsolv.out 2>/dev/null',io) - write (stdout,*) 'done.' - if (io /= 0) then - write (stdout,*) - write (stderr,'(a)') "**ERROR** failed request to ConfSolv server" - call cs_shutdown(io) - error stop - end if - -!>--- read ΔΔGsoln - write (stdout,'(2x,a)',advance='no') 'Reading confsolv.csv ...' - flush (stdout) - call parse_csv_allcolumns('confsolv.csv',data,cols=ncol,rows=nrow) - write (stdout,*) 'done.' - if (nrow == nall) then - if(.not.allocated(mapping)) allocate(mapping(nall)) - call confsolv_select_gsoln(nall,ncol,data,gsoln,mapping) - call confsolv_dump_gsoln(nall,ncol,gsoln,mapping,headers) - else - write (stdout,'(a)') '**ERROR** dimension mismatch in confsolv_request' - call cs_shutdown(io) - error stop - end if - -!>--- read uncertainty - write (stdout,'(2x,a)',advance='no') 'Reading confsolv_uncertainty.csv ...' - flush (stdout) - call parse_csv_allcolumns('confsolv_uncertainty.csv',data) - write (stdout,*) 'done.' - if (size(data,2) == nall) then - avg = 0.0_wp - do i=1,nall - k=mapping(i) + 2 - avg=avg+data(k,i) - enddo - avg = avg / real(nall,wp) - write (stdout,'(2x,a,f25.15)') 'Average uncertainty of ConfSolv prediction:',avg - else - write (stdout,'(a)') '**ERROR** dimension mismatch in confsolv_request' - call cs_shutdown(io) - error stop - end if - - !call cs_shutdown2(i) - - if (allocated(headers)) deallocate(headers) - if (allocated(data)) deallocate(data) - if (allocated(mapping)) deallocate(mapping) - if (allocated(column)) deallocate (column) - return -end subroutine confsolv_request - -!========================================================================================! -!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ConfSolv: ΔΔGsoln estimation from 3D directed message passing neural networks (D-MPNN)")') - call confsolv_request(input,nall,t2,etmp,io) - if (io == 0) then - eread(:) = etmp(:)*kcaltoau !> since CREGEN deals with Eh energies - end if end select write (stdout,*) end do diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index d463f789..34c72370 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -1430,7 +1430,6 @@ subroutine calculation_settings_info(self,iunit) case (1); rtmp = 'singlepoint' case (2); rtmp = 'correction' case (3); rtmp = 'geoopt' - case (4); rtmp = 'ConfSolv' case (5); rtmp = 'deltaG' case (10); rtmp = 'post_opt' case (11); rtmp = 'post_sp' diff --git a/src/classes.f90 b/src/classes.f90 index 6369bcdd..a37195b5 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -145,7 +145,6 @@ module crest_data integer :: singlepoint = 1 integer :: correction = 2 integer :: geoopt = 3 - integer :: ConfSolv = 4 integer :: deltaG = 5 !> post_opt (= 10): post-search re-optimization via pqueue job 51 (e.g. A@B) !> post_sp (= 11): post-search SP reranking via pqueue job 52 (--rerank) diff --git a/src/crest_main.f90 b/src/crest_main.f90 index 1a9498a9..62e58361 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -351,13 +351,6 @@ program CREST call scrend(env) end if -!=========================================================================================! -!> shout down hosted subprocesses - block - use ConfSolv_module - call cs_shutdown(io) - end block - !=========================================================================================! !> one final cleanup call custom_cleanup(env) diff --git a/src/parsing/parse_maindata.f90 b/src/parsing/parse_maindata.f90 index bd77d954..0284ff3f 100644 --- a/src/parsing/parse_maindata.f90 +++ b/src/parsing/parse_maindata.f90 @@ -344,8 +344,6 @@ subroutine parse_main_blk(env,blk,istat) select case (blk%header) case ('cregen') call parse_cregen(env,blk,istat) - case ('confsolv') - call parse_confsolv(env,blk,istat) case ('thermo') call parse_thermo(env,blk,istat) case ('protonation') @@ -386,57 +384,6 @@ subroutine parse_cregen(env,blk,istat) end do end subroutine parse_cregen -!========================================================================================! - subroutine parse_confsolv(env,blk,istat) - use ConfSolv_module - implicit none - type(systemdata) :: env - type(datablock) :: blk - type(keyvalue) :: kv - integer,intent(inout) :: istat - integer :: i -!>--- add ConfSolv as refinement level to give a ΔΔGsoln - call env%addrefine(refine%ConfSolv) - env%ewin = 100.0_wp - -!>--- parse the arguments - do i = 1,blk%nkv - kv = blk%kv_list(i) - select case (kv%key) - case ('pid') - if (.not.allocated(cs_pid)) allocate (cs_pid) - cs_pid = kv%value_i - case ('bin') - cs_bin = trim(kv%value_c) - case ('port') - if (.not.allocated(cs_port)) allocate (cs_port) - cs_port = kv%value_i - case ('solvent') - !> to define a single solvent like: solvent = ['water','O'] - if (kv%na == 2) then - cs_solvent = trim(kv%value_rawa(1)) - cs_smiles = trim(kv%value_rawa(2)) - else if (index(kv%value_c,'.csv') .ne. 0) then - cs_solvfile = kv%value_c - else - cs_solvent = kv%value_c - end if - case ('solvent_csv','solvfile') - cs_solvfile = kv%value_c - case ('solvent_name') - cs_solvent = kv%value_c - case ('solvent_smiles') - cs_smiles = kv%value_c - case ('model_path','param','checkpoint') - cs_param = kv%value_c - case default - !>--- unrecognized keyword - istat = istat+1 - write (stdout,fmturk) '[confsolv]-block',kv%key - end select - end do - end subroutine parse_confsolv - !========================================================================================! subroutine parse_thermo(env,blk,istat) diff --git a/src/sigterm.F90 b/src/sigterm.F90 index 09823d00..21898c38 100644 --- a/src/sigterm.F90 +++ b/src/sigterm.F90 @@ -59,13 +59,9 @@ subroutine wsigint() bind(C,name="crest_wsigint") !> Ctrl+C subroutine wsigint() !> Ctrl+C #endif use crest_parameters,only:stderr,stdout - - use ConfSolv_module - integer :: myunit,io write (*,*) write (stderr,'(" recieved SIGINT, trying to terminate CREST...")') !call dump_restart() - call cs_shutdown(io) call exit(130) error stop end subroutine wsigint @@ -76,13 +72,9 @@ subroutine wsigquit() bind(C,name="crest_wsigquit") !> Ctrl+D subroutine wsigquit() !> Ctrl+D #endif use crest_parameters,only:stderr,stdout - - use ConfSolv_module - integer :: myunit,io write (*,*) write (stderr,'(" recieved SIGQUIT, trying to terminate CREST...")') !call dump_restart() - call cs_shutdown(io) call exit(131) error stop end subroutine wsigquit @@ -93,13 +85,9 @@ subroutine wsigterm() bind(C,name="crest_wsigterm") !> Recieved by the "kill" pi subroutine wsigterm() !> Recieved by the "kill" pid command #endif use crest_parameters,only:stderr,stdout - - use ConfSolv_module - integer :: io write (stdout,*) write (stderr,'(" recieved SIGTERM, trying to terminate CREST...")') !call dump_restart() - call cs_shutdown(io) call exit(143) error stop end subroutine wsigterm @@ -110,11 +98,7 @@ subroutine wsigkill() bind(C,name="crest_wsigkill") subroutine wsigkill() #endif use crest_parameters,only:stderr,stdout - - use ConfSolv_module - integer :: io !call dump_restart() - call cs_shutdown(io) call exit(137) error stop 'CREST recieved SIGKILL.' end subroutine wsigkill From c4688c199b2e4d2d97f3470e111db169cdfd8e54 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 23 May 2026 19:09:48 +0200 Subject: [PATCH 341/374] cosmetics (sdf ensemble rewrite function) --- src/crest_main.f90 | 9 +-- src/molecule/sdfio.f90 | 141 +++++++++++++++++++++++++++-------------- 2 files changed, 96 insertions(+), 54 deletions(-) diff --git a/src/crest_main.f90 b/src/crest_main.f90 index 62e58361..aeda768e 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -309,14 +309,7 @@ program CREST !=========================================================================================! !> ADDITIONAL OUTPUT FORMATTING !=========================================================================================! - if (env%outputsdf.or.env%sdfformat) then - if (any((/crest_mfmdgc,crest_imtd,crest_imtd2/) == env%crestver)) then - call new_wrsdfens(env,conformerfile,conformerfilebase//'.sdf',.false.) - end if - if (any((/crest_screen,crest_mdopt/) == env%crestver)) then - call new_wrsdfens(env,'crest_ensemble.xyz','crest_ensemble.sdf',.false.) - end if - end if + call crest_ensemble_reformat(env) !=========================================================================================! !> POST-CONFSEARCH PROPERTY CALCS diff --git a/src/molecule/sdfio.f90 b/src/molecule/sdfio.f90 index f166ae9f..207f3206 100644 --- a/src/molecule/sdfio.f90 +++ b/src/molecule/sdfio.f90 @@ -1,7 +1,7 @@ !================================================================================! ! This file is part of crest. ! -! Copyright (C) 2018-2020 Philipp Pracht +! Copyright (C) 2018-2025 Philipp Pracht ! ! crest is free software: you can redistribute it and/or modify it under ! the terms of the GNU Lesser General Public License as published by @@ -39,85 +39,108 @@ subroutine inpsdf(env,fname) return end subroutine inpsdf +!================================================================================! + subroutine new_wrsdfens(env,fname,oname,conf) - use iso_fortran_env,only:wp => real64 - use iomod + !*********************************************************************** + !* Write a conformer ensemble as an SDF file. + !* Bond orders (WBO) are obtained via a singlepoint calculation using + !* the calculator configured in env. + !* + !* Input: + !* env - crest's systemdata object (provides calculator and charge) + !* fname - input XYZ ensemble file + !* oname - output SDF file name + !* conf - if .true., run a separate SP for each structure (loopwbo) + !*********************************************************************** + use crest_parameters use crest_data + use crest_calculator use strucrd - use zdata,only:readwbo implicit none - type(systemdata) :: env + type(systemdata),intent(inout) :: env character(len=*),intent(in) :: fname character(len=*),intent(in) :: oname - logical,intent(in),optional :: conf - integer :: nat,nall - integer,allocatable :: at(:) - real(wp),allocatable :: eread(:) - real(wp),allocatable :: xyz(:,:,:) - real(wp),allocatable :: c0(:,:) + logical,intent(in) :: conf + !> local + type(coord),allocatable :: structures(:) + type(calcdata) :: tmpcalc + type(calculation_settings) :: cal real(wp),allocatable :: wbo(:,:) + real(wp),allocatable :: grad(:,:) real(wp),allocatable :: icharges(:) - integer :: i,j,ich - real(wp) :: er - logical :: ex,loopwbo,atmchrg + integer :: nall,nat,ich,io,i + real(wp) :: energy,er + logical :: loopwbo,atmchrg character(len=120) :: sdfcomment - loopwbo = .false. + atmchrg = .false. - if (present(conf)) loopwbo = conf - !>--- read existing ensemble - call rdensembleparam(fname,nat,nall) - allocate (at(nat),eread(nat),xyz(3,nat,nall)) - call rdensemble(fname,nat,nall,at,xyz,eread) - allocate (wbo(nat,nat),c0(3,nat),source=0.0_wp) - !>--- determine how to obtain wbos - wbo = 0.0_wp - inquire (file='wbo',exist=ex) - if (ex.and..not.loopwbo) then - call readwbo('wbo',nat,wbo) - elseif (.not.ex.and..not.loopwbo) then - call xtbsp(env,0) !> gfn0 singlepoint - call readwbo('wbo',nat,wbo) + loopwbo = conf + + ! ── read ensemble as array of coord objects (xyz in Bohr) ───────────── + call rdensemble(fname,nall,structures) + nat = structures(1)%nat + + ! ── set up a minimal GFN0 singlepoint calculator for WBOs ───────────── + call cal%create('gfn0') + cal%chrg = env%chrg + cal%uhf = env%uhf + cal%rdwbo = .true. + call cal%autocomplete(1) + call tmpcalc%add(cal) + allocate (wbo(nat,nat),grad(3,nat),source=0.0_wp) + energy = 0.0_wp + + ! ── for non-loopwbo: one SP on the first structure, WBO reused for all ─ + if (.not.loopwbo) then + call engrad(structures(1),tmpcalc,energy,grad,io) + if (allocated(tmpcalc%calcs(1)%wbo)) wbo = tmpcalc%calcs(1)%wbo end if - !>--- (optional) some special settings - if (env%properties == p_protonate) atmchrg = .true. + ! ── (optional) special per-atom charge handling ─────────────────────── + if (env%properties == p_protonate) atmchrg = .true. if (atmchrg) allocate (icharges(nat),source=0.0_wp) - !>--- open sdf output file + ! ── write SDF output ────────────────────────────────────────────────── open (newunit=ich,file=oname) do i = 1,nall write (sdfcomment,'(a,i0,a,i0)') 'structure ',i,' of ',nall - c0(1:3,1:nat) = xyz(1:3,1:nat,i) - er = eread(i) + er = structures(i)%energy if (loopwbo) then - call wrxyz('tmpstruc.xyz',nat,at,c0) - call xtbsp2('tmpstruc.xyz',env) !> singlepoint for wbos - call readwbo('wbo',nat,wbo) + ! ── per-structure SP for bond orders (protonation/tautomer modes) ─ + wbo = 0.0_wp + call engrad(structures(i),tmpcalc,energy,grad,io) + if (allocated(tmpcalc%calcs(1)%wbo)) wbo = tmpcalc%calcs(1)%wbo end if if (atmchrg) then if (env%properties == p_protonate) then call set_prot_icharges(nat,wbo,icharges) end if - call wrsdf(ich,nat,at,c0,er,env%chrg,wbo,sdfcomment,icharges) + !> wrsdf expects Angstrom: multiply Bohr coordinates by bohr (Å/bohr) + call wrsdf(ich,nat,structures(i)%at,structures(i)%xyz*bohr, & + & er,env%chrg,wbo,sdfcomment,icharges) else - call wrsdf(ich,nat,at,c0,er,env%chrg,wbo,sdfcomment) + call wrsdf(ich,nat,structures(i)%at,structures(i)%xyz*bohr, & + & er,env%chrg,wbo,sdfcomment) end if end do close (ich) + call tmpcalc%reset() if (allocated(icharges)) deallocate (icharges) - deallocate (c0,wbo,xyz,eread,at) + deallocate (wbo,grad,structures) contains subroutine set_prot_icharges(nat,wbo,icharges) - !>--- special routine for protonation mode - ! find the atom on which the proton was set - ! and set its charge to 1. The added proton is - ! always the last in the list, k=nat + !*********************************************** + !* For protonation mode: locate the heavy atom + !* bonded to the added proton (last in list) + !* and assign it a formal charge of +1. + !*********************************************** integer,intent(in) :: nat real(wp),intent(in) :: wbo(nat,nat) real(wp),intent(out) :: icharges(nat) - integer :: i,j,k + integer :: i,k icharges = 0.0_wp k = nat do i = 1,nat @@ -125,6 +148,32 @@ subroutine set_prot_icharges(nat,wbo,icharges) icharges(i) = 1.0_wp end if end do - return end subroutine set_prot_icharges end subroutine new_wrsdfens + +!================================================================================! + +subroutine crest_ensemble_reformat(env) + !*************************************************************** + !* Reformat the conformer ensemble into requested alternative + !* file formats (currently SDF) after the run completes. + !* + !* Input: + !* env - crest's systemdata object + !*************************************************************** + use crest_parameters + use crest_data + implicit none + type(systemdata),intent(inout) :: env + + ! ── SDF ensemble output ─────────────────────────────────────── + if (env%outputsdf .or. env%sdfformat) then + if (any((/crest_mfmdgc,crest_imtd,crest_imtd2/) == env%crestver)) then + call new_wrsdfens(env,conformerfile,conformerfilebase//'.sdf',.false.) + end if + if (any((/crest_screen,crest_mdopt/) == env%crestver)) then + call new_wrsdfens(env,'crest_ensemble.xyz','crest_ensemble.sdf',.false.) + end if + end if + +end subroutine crest_ensemble_reformat From 4ca4b5046082fd1e1433e25a4af931b570eeb244 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 23 May 2026 19:42:54 +0200 Subject: [PATCH 342/374] cosmetics (pca clustering as --sort runtype via additonal --cluster arg) --- src/algos/sorting.f90 | 7 +++ src/confparse.f90 | 4 +- src/crest_main.f90 | 4 -- src/sorting/ccegen.f90 | 100 ++++++++++++++++++++++++++--------------- 4 files changed, 74 insertions(+), 41 deletions(-) diff --git a/src/algos/sorting.f90 b/src/algos/sorting.f90 index 74de919c..cf493937 100644 --- a/src/algos/sorting.f90 +++ b/src/algos/sorting.f90 @@ -39,6 +39,7 @@ subroutine crest_sort(env,tim) type(coord) :: mol,molnew integer :: i,j,k,l,io,ich logical :: pr,wr + external :: CCEGEN !========================================================================================! integer :: nall type(coord),allocatable :: structures(:) @@ -56,6 +57,8 @@ subroutine crest_sort(env,tim) write (stdout,'(a,a)',advance='no') '> Reading files ',trim(env%ensemblename) flush (stdout) write (stdout,'(a,a)') ' and ',trim(env%ensemblename2) + case ('cluster') + continue !> ccegen reads the ensemble internally end select write (stdout,*) @@ -97,6 +100,10 @@ subroutine crest_sort(env,tim) call newcregen(env,structurelist=structures) call catdel('cregen.out.tmp') + case ('cluster') +!>--- PCA and k-means clustering + call CCEGEN(env,.true.,env%ensemblename) + case default !>--- all unique pairs of the ensemble (only suitable for small ensembles) call cregen_irmsd_sort(env,nall,structures,groups,allcanon=.true.,printlvl=2) diff --git a/src/confparse.f90 b/src/confparse.f90 index b841000b..73a0cf4e 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -2793,8 +2793,8 @@ subroutine parseflags(env,arg,nra) !>--- for standalone use env%properties = p_cluster elseif (env%crestver == crest_sorting) then - !>--- as extension for CREGEN/sorting - env%cluster = .true. + !>--- standalone clustering via --sort --cluster + env%sortmode = 'cluster' else if (any((/crest_imtd,crest_imtd2/) == env%crestver)) then !>--- works as an extensiton to the conformational search env%properties = abs(p_cluster) diff --git a/src/crest_main.f90 b/src/crest_main.f90 index aeda768e..a5902793 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -141,10 +141,6 @@ program CREST call calcSrrhoav(env,env%ensemblename) call tim%stop(4) call propquit(tim) -!>--- to PCA and k-Means clustering for given file - case (p_cluster) - call ccegen(env,.true.,env%ensemblename) - call propquit(tim) !>--- properties for enesemble file case (p_propcalc) call propcalc(env%ensemblename,env%properties2,env,tim) diff --git a/src/sorting/ccegen.f90 b/src/sorting/ccegen.f90 index bd991425..f07c15a8 100644 --- a/src/sorting/ccegen.f90 +++ b/src/sorting/ccegen.f90 @@ -93,6 +93,7 @@ subroutine CCEGEN(env,pr,fname) real(wp),allocatable :: eclust(:) integer,allocatable :: clustbest(:),ind(:) real(wp),allocatable :: statistics(:,:) + integer,allocatable :: clust_sizes(:) logical,allocatable :: extrema(:,:) logical :: autolimit real(wp) :: fraclimit @@ -149,6 +150,11 @@ subroutine CCEGEN(env,pr,fname) !(only for predefined clustersizes with "-cluster N" ) fraclimit = 0.25d0 !if autolimit=true, 1/4 of the ensemble is taken + !>--- override pcthr and csthr based on clustering level + if (env%maxcluster == 0) then + call clustleveval(env,nclustmax,csthr,SSRSSTthr,pcthr) + end if + !>--- 1. topology for reference strucuture if (env%wbotopo) then env%wbofile = 'wbo' @@ -332,19 +338,21 @@ subroutine CCEGEN(env,pr,fname) do j = 1,ntaken do k = 1,3 l = l+1 - measure(j,l) = xyznew(k,j,i) + if (l > mn) exit + measure(l,i) = xyznew(k,j,i) end do + if (l > mn) exit end do end do !==========================================================================! case default !case( 'zmat','zmatrix' ) if (pr) then - write (stdout,'(1x,a)') 'Using ZMATRIX as descriptors:' + write (stdout,'(1x,a)') 'Using ZMATRIX as descriptors (sin/cos of dihedrals):' end if - !>-- dihedral angles - mn = ntaken-3 !>--- first three dihedral angles are zero - mn = min(mm,mn) !>--- no more descriptors than structures for SVD! - if (mn < 1) then !> we need at least 2 dihedral angles, and therefore 5 descriptors + !>-- dihedral angles, sin/cos transformed for periodicity + l = ntaken-3 !>--- first three dihedral angles are zero + mn = min(mm,2*l) !>--- two descriptors per dihedral, no more than structures + if (mn < 2) then !> we need at least 1 dihedral angle (2 descriptors) if (pr) then write (stdout,*) "Not enough descriptors for PCA!" return @@ -357,30 +365,31 @@ subroutine CCEGEN(env,pr,fname) na = 0; nb = 0; nc = 0 geo = 0.0d0 call xyzint(xyznew(1:3,1:ntaken,i),ntaken,na,nb,nc,rad,geo) - do j = 1,mn + do j = 1,mn/2 k = j+3 - measure(j,i) = geo(3,k) + dum = geo(3,k)/rad !> convert degrees to radians + measure(2*j-1,i) = sin(dum) + measure(2*j,i) = cos(dum) end do end do deallocate (nc,nb,na,geo) !=========================================================================! case ('dihedral') - mn = min(mm,ntaken) !>--- no more descriptors than structures for SVD! + mn = min(mm,2*ntaken) !>--- two descriptors per dihedral (sin/cos) allocate (measure(mn,mm),diedr(ndied)) if (pr) then - write (stdout,'(1x,a)') 'Using DIHEDRAL ANGLES as descriptors:' - do i = 1,mn + write (stdout,'(1x,a)') 'Using DIHEDRAL ANGLES as descriptors (sin/cos transformed):' + do i = 1,ntaken write (stdout,'(1x,a,4i6)') 'Atoms: ',diedat(1:4,i) end do write (stdout,*) end if do i = 1,mm call calc_dieders(zens%nat,zens%xyz(:,:,i),ndied,diedat,diedr) - do j = 1,mn - ! if(i<5 .and. pr)then - ! write(*,'(1x,4i6,1x,f8.2)') diedat(1:4,j),diedr(j) - ! endif - measure(j,i) = diedr(j) + do j = 1,min(ntaken,mn/2) + dum = diedr(j)/rad !> convert degrees to radians + measure(2*j-1,i) = sin(dum) + measure(2*j,i) = cos(dum) end do end do if (allocated(diedat)) deallocate (diedat) @@ -520,7 +529,7 @@ subroutine CCEGEN(env,pr,fname) !-----------------------------------------------------------------------! if (env%maxcluster == 0) then !nclustmax=100 !some random default value - call clustleveval(env,nclustmax,csthr,SSRSSTthr) ! defaults + call clustleveval(env,nclustmax,csthr,SSRSSTthr,pcthr) ! defaults nclustmax = min(mm,nclustmax) !SSRSSTthr=0.90 !exit if this value is reached for SSR/SST else @@ -537,6 +546,7 @@ subroutine CCEGEN(env,pr,fname) end if allocate (statistics(3,nclustmax),source=0.0d0) + allocate (clust_sizes(nclustmax),source=0) CLUSTERSIZES: do nclustiter = nclustmin,nclustmax !>-- regular case: test continuous cluster sizes @@ -547,6 +557,7 @@ subroutine CCEGEN(env,pr,fname) dum2 = dum*float(nclustiter) nclust = nint(dum2) end if + clust_sizes(nclustiter) = nclust allocate (centroid(npc,nclust),source=0.0_ap) centroid = 0.0_ap @@ -566,9 +577,9 @@ subroutine CCEGEN(env,pr,fname) call ctimer%stop(3) deallocate (centroid) - statistics(1,nclust) = DBI - statistics(2,nclust) = pSF - statistics(3,nclust) = SSRSST + statistics(1,nclustiter) = DBI + statistics(2,nclustiter) = pSF + statistics(3,nclustiter) = SSRSST if (nclust == env%nclust) exit if (SSRSST > SSRSSTthr) exit @@ -584,15 +595,15 @@ subroutine CCEGEN(env,pr,fname) write (stdout,'(1x,a)') 'Higher SSR/SST vaules indicate more distinct clusters.' write (stdout,'(1x,a)') 'Analyzing statistical values ...' end if - k = nclust + k = min(nclustiter, nclustmax) !> last completed iteration index allocate (extrema(2,k)) call ctimer%start(3,'statistics') - call statanal(k,nclustmax,statistics,extrema,pr) + call statanal(k,nclustmax,statistics,extrema,pr,clust_sizes) if (pr) call statwarning(fname) !>-- determine a suggested cluster size (smallest suggested cluster with good SSR/SST) do i = 2,k if ((extrema(1,i).or.extrema(2,i)).and.(statistics(3,i) > csthr)) then - nclust = i + nclust = clust_sizes(i) exit end if end do @@ -616,7 +627,7 @@ subroutine CCEGEN(env,pr,fname) write (stdout,'(1x,a,i0,a)') 'Ensemble partitioning into ',nclust,' clsuters.' end if end if - deallocate (statistics) + deallocate (statistics,clust_sizes) deallocate (q,p,dist) !>-- finally, assign a representative structure to each group (based on lowest energy) @@ -704,7 +715,11 @@ end subroutine CCEGEN !=======================================================================================! ! set clustering level defaults !=======================================================================================! -subroutine clustleveval(env,maxclust,csthr,SSRSSTthr) +subroutine clustleveval(env,maxclust,csthr,SSRSSTthr,pcthr) + !********************************************************* + !* Set clustering level defaults for maxclust, csthr, * + !* SSRSSTthr, and pcthr based on the clustering level. * + !********************************************************* use crest_parameters,idp => dp use crest_data implicit none @@ -713,6 +728,7 @@ subroutine clustleveval(env,maxclust,csthr,SSRSSTthr) integer :: maxclust real(wp) :: csthr real(wp) :: SSRSSTthr + real(wp) :: pcthr SSRSSTthr = 0.90 !exit if this value is reached for SSR/SST @@ -725,19 +741,23 @@ subroutine clustleveval(env,maxclust,csthr,SSRSSTthr) case (-1) !-- loose maxclust = 25 csthr = 0.80d0 + pcthr = 0.80d0 case (1) !-- tight maxclust = 400 if (env%clustlev >= 10) maxclust = 50 csthr = 0.85d0 + pcthr = 0.90d0 case (2) !-- vtight maxclust = 400 if (env%clustlev >= 10) maxclust = 100 csthr = 0.9d0 + pcthr = 0.95d0 SSRSSTthr = 0.92d0 case default !-- normal maxclust = 100 if (env%clustlev >= 10) maxclust = 25 csthr = 0.80d0 + pcthr = 0.85d0 end select return @@ -905,6 +925,8 @@ subroutine kmeans(nclust,npc,mm,centroid,pcvec,ndist,dist,member) integer,intent(inout) :: member(mm) ! membership for each structure real(ap),intent(inout):: centroid(npc,nclust) integer,allocatable :: refmember(:) + integer :: iter + integer,parameter :: maxiter = 300 if (nclust .le. 1) return !no singular clusters! @@ -913,7 +935,7 @@ subroutine kmeans(nclust,npc,mm,centroid,pcvec,ndist,dist,member) !>-- determine seeds for the centroids (i.e., initial positions) call kmeans_seeds(nclust,npc,mm,centroid,pcvec,ndist,dist) - do + do iter = 1,maxiter !>-- determine cluster membership for all structures !> (by shortest Euc. distance to the respective centroid) member = 0 !reset @@ -988,8 +1010,8 @@ subroutine kmeans_seeds(nclust,npc,mm,centroid,pcvec,ndist,dist) distsum = distsum+eucdist(npc,p,q) end do !$OMP CRITICAL - if (.not.any(taken == j)) then - if (distsum .gt. maxdistsum) then + if (distsum .gt. maxdistsum) then + if (.not.any(taken == j)) then maxdistsum = distsum c = j taken(i) = c @@ -1206,15 +1228,16 @@ end subroutine cluststat ! analyze the statistical values DBI and pSF to get the ! respective extrema !==============================================================! -subroutine statanal(n,nmax,statistics,extrema,pr) +subroutine statanal(n,nmax,statistics,extrema,pr,clust_sizes) use crest_parameters implicit none integer :: n,nmax real(wp) :: statistics(3,nmax) logical,intent(inout) :: extrema(2,n) logical :: pr + integer,intent(in),optional :: clust_sizes(n) real(wp) :: last,next,current - integer :: i + integer :: i,csize extrema = .false. !>--- identify local extrema of the DBI and pSF @@ -1234,16 +1257,23 @@ subroutine statanal(n,nmax,statistics,extrema,pr) extrema(2,i) = .true. end if end do + !>--- boundary check: last cluster count (one-sided comparison) + if (n >= 2) then + if (statistics(1,n) < statistics(1,n-1)) extrema(1,n) = .true. + if (statistics(2,n) > statistics(2,n-1)) extrema(2,n) = .true. + end if if (pr) then write (stdout,*) write (stdout,'(1x,a,/)') 'Suggestions for cluster sizes:' do i = 1,n if (extrema(1,i).or.extrema(2,i)) then + csize = i + if (present(clust_sizes)) csize = clust_sizes(i) if (extrema(1,i).and.extrema(2,i)) then - write (stdout,'(1x,i8,''*'',3x,a,f8.4)') i,'SSR/SST',statistics(3,i) + write (stdout,'(1x,i8,''*'',3x,a,f8.4)') csize,'SSR/SST',statistics(3,i) else - write (stdout,'(1x,i8,4x,a,f8.4)') i,'SSR/SST',statistics(3,i) + write (stdout,'(1x,i8,4x,a,f8.4)') csize,'SSR/SST',statistics(3,i) end if end if end do @@ -1271,11 +1301,11 @@ subroutine statwarning(fname) write (stdout,'(2x,a)') 'the DBI and pSF values for the given data.' write (stdout,*) write (stdout,'(2x,a)') 'If other cluster sizes are desired, rerun CREST with' - write (stdout,'(2x,3a)') '"crest --for ',trim(fname),' --cluster "' + write (stdout,'(2x,3a)') '"crest --sort ',trim(fname),' --cluster "' write (stdout,*) write (stdout,'(2x,a)') 'Other default evaluation settings can be chosen with the' write (stdout,'(2x,a)') 'keywords "loose","normal", and "tight" as via' - write (stdout,'(2x,3a)') '"crest --for ',trim(fname),' --cluster "' + write (stdout,'(2x,3a)') '"crest --sort ',trim(fname),' --cluster "' write (stdout,'(1x,a)') '!--------------------------------------------------------------!' end subroutine statwarning @@ -1364,7 +1394,7 @@ subroutine calc_dieders(nat,xyz,ndied,diedat,diedr) coords(1:3,4) = xyz(1:3,d) call DIHED(coords,1,2,3,4,angle) angle = abs(angle)*rad2degree - if (abs(angle-360.0_wp) < tol) angle = 0.0_wp + !if (abs(angle-360.0_wp) < tol) angle = 0.0_wp diedr(i) = angle end do From e79f12ce3a17545a786ead6b6425432027019849 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 23 May 2026 21:35:24 +0200 Subject: [PATCH 343/374] cosmetics (modernize some ccegen code parts) --- src/sorting/ccegen.f90 | 119 +++++++++++++++++------------------------ 1 file changed, 50 insertions(+), 69 deletions(-) diff --git a/src/sorting/ccegen.f90 b/src/sorting/ccegen.f90 index f07c15a8..5bfb0f2f 100644 --- a/src/sorting/ccegen.f90 +++ b/src/sorting/ccegen.f90 @@ -50,8 +50,9 @@ subroutine CCEGEN(env,pr,fname) integer,allocatable :: inc(:) logical :: heavyonly integer :: i,j,k,l,ich,c + integer :: nat,nall real(wp) :: dum,dum2 - type(ensemble) :: zens + type(coord),allocatable :: mols(:) character(len=:),allocatable :: measuretype @@ -100,9 +101,6 @@ subroutine CCEGEN(env,pr,fname) !>--- printout and params real(wp) :: emin,erel - real(wp),parameter :: kcal = 627.5095d0 - !real(wp),parameter :: pi = 3.14159265358979D0 - real(wp),parameter :: rad = 180.0d0/pi call ctimer%init(20) if (pr) then @@ -119,19 +117,20 @@ subroutine CCEGEN(env,pr,fname) ! Prepare a coordinate ensemble for the clustering !=========================================================! !>--- 0. Set defaults, read ensemble - call zens%open(fname) !read in the ensemble - if (zens%nall < 1) then + call rdensemble(fname,nall,mols) + if (nall < 1) then error stop "Ensemble is empty! must stop" - else if (zens%nall == 1) then + end if + nat = mols(1)%nat + if (nall == 1) then if (pr) then write (stdout,*) 'Only one structure in ensemble!' write (stdout,*) 'Write structure to ',clusterfile,' and skip PCA parts' end if open (newunit=ich,file=clusterfile) - dum = zens%er(1) - call wrxyz(ich,zens%nat,zens%at,zens%xyz(:,:,1),dum) + call mols(1)%append(ich) close (ich) - call zens%deallocate() + deallocate (mols) return end if @@ -155,15 +154,13 @@ subroutine CCEGEN(env,pr,fname) call clustleveval(env,nclustmax,csthr,SSRSSTthr,pcthr) end if - !>--- 1. topology for reference strucuture + !>--- 1. topology for reference structure if (env%wbotopo) then env%wbofile = 'wbo' else env%wbofile = 'none given' end if - zens%xyz = zens%xyz/bohr !ANG to Bohr for topo - call simpletopo(zens%nat,zens%at,zens%xyz,zmol,pr,.false.,env%wbofile) - zens%xyz = zens%xyz*bohr !Bohr to ANG + call simpletopo(nat,mols(1)%at,mols(1)%xyz,zmol,pr,.false.,env%wbofile) allocate (inc(zmol%nat),source=0) !===========================================================! @@ -241,26 +238,25 @@ subroutine CCEGEN(env,pr,fname) !>-- for very large ensemble files limit the clustering if (autolimit) then - if ((env%nclust /= 0).and.(env%nclust*100 < zens%nall)) then - dum = float(zens%nall)*fraclimit + if ((env%nclust /= 0).and.(env%nclust*100 < nall)) then + dum = float(nall)*fraclimit dum2 = float(env%nclust) nallnew = nint(max(dum,dum2)) else - nallnew = zens%nall + nallnew = nall end if else - nallnew = zens%nall + nallnew = nall end if !>--- 5. Transfer the relevant atoms to a new array - allocate (xyznew(3,ntaken,nallnew))!,atnew(ntaken)) + allocate (xyznew(3,ntaken,nallnew)) do i = 1,nallnew k = 0 - do j = 1,zens%nat + do j = 1,nat if (inc(j) == 1) then k = k+1 - xyznew(:,k,i) = zens%xyz(:,j,i) - !atnew(k) = zens%at(j) + xyznew(:,k,i) = mols(i)%xyz(:,j) end if end do end do @@ -271,15 +267,15 @@ subroutine CCEGEN(env,pr,fname) !-- for very large ensemble files limit the clustering if (autolimit) then - if ((env%nclust /= 0).and.(env%nclust*100 < zens%nall)) then - dum = float(zens%nall)*fraclimit + if ((env%nclust /= 0).and.(env%nclust*100 < nall)) then + dum = float(nall)*fraclimit dum2 = float(env%nclust) nallnew = nint(max(dum,dum2)) else - nallnew = zens%nall + nallnew = nall end if else - nallnew = zens%nall + nallnew = nall end if inc = 1 @@ -303,7 +299,6 @@ subroutine CCEGEN(env,pr,fname) write (stdout,*) call smallhead('PRINCIPAL COMPONENT ANALYSIS') end if - !mm = zens%nall mm = nallnew select case (measuretype) !==========================================================================! @@ -364,10 +359,10 @@ subroutine CCEGEN(env,pr,fname) do i = 1,mm na = 0; nb = 0; nc = 0 geo = 0.0d0 - call xyzint(xyznew(1:3,1:ntaken,i),ntaken,na,nb,nc,rad,geo) + call xyzint(xyznew(1:3,1:ntaken,i),ntaken,na,nb,nc,radtodeg,geo) do j = 1,mn/2 k = j+3 - dum = geo(3,k)/rad !> convert degrees to radians + dum = geo(3,k)*degtorad measure(2*j-1,i) = sin(dum) measure(2*j,i) = cos(dum) end do @@ -385,11 +380,10 @@ subroutine CCEGEN(env,pr,fname) write (stdout,*) end if do i = 1,mm - call calc_dieders(zens%nat,zens%xyz(:,:,i),ndied,diedat,diedr) + call calc_dieders(mols(i),ndied,diedat,diedr) do j = 1,min(ntaken,mn/2) - dum = diedr(j)/rad !> convert degrees to radians - measure(2*j-1,i) = sin(dum) - measure(2*j,i) = cos(dum) + measure(2*j-1,i) = sin(diedr(j)) + measure(2*j,i) = cos(diedr(j)) end do end do if (allocated(diedat)) deallocate (diedat) @@ -411,9 +405,8 @@ subroutine CCEGEN(env,pr,fname) write (stdout,*) 'There are not enough descriptors for a PCA!' write (stdout,*) 'Taking all structures as representative and writing ',clusterfile open (newunit=ich,file=clusterfile) - do i = 1,zens%nall - dum = zens%er(i) - call wrxyz(ich,zens%nat,zens%at,zens%xyz(:,:,i),dum) + do i = 1,nall + call mols(i)%append(ich) end do close (ich) return @@ -595,7 +588,7 @@ subroutine CCEGEN(env,pr,fname) write (stdout,'(1x,a)') 'Higher SSR/SST vaules indicate more distinct clusters.' write (stdout,'(1x,a)') 'Analyzing statistical values ...' end if - k = min(nclustiter, nclustmax) !> last completed iteration index + k = min(nclustiter,nclustmax) !> last completed iteration index allocate (extrema(2,k)) call ctimer%start(3,'statistics') call statanal(k,nclustmax,statistics,extrema,pr,clust_sizes) @@ -652,7 +645,7 @@ subroutine CCEGEN(env,pr,fname) iiincb: do i = 1,ncb do j = 1,mm if (member(j) == i) then - eclust(i) = zens%er(j) + eclust(i) = mols(j)%energy clustbest(i) = j cycle iiincb end if @@ -665,8 +658,8 @@ subroutine CCEGEN(env,pr,fname) do j = 1,mm if (member(j) == i) then c = c+1 - if (zens%er(j) < eclust(i)) then - eclust(i) = zens%er(j) + if (mols(j)%energy < eclust(i)) then + eclust(i) = mols(j)%energy clustbest(i) = j end if end if @@ -683,10 +676,10 @@ subroutine CCEGEN(env,pr,fname) do i = 1,ncb k = clustbest(ind(i)) if (k > 0) then - dum = zens%er(k) - call wrxyz(ich,zens%nat,zens%at,zens%xyz(:,:,k),dum) + dum = mols(k)%energy + call mols(k)%append(ich) if (pr) then - erel = (dum-emin)*kcal + erel = (dum-emin)*autokcal write (stdout,'(1x,i6,1x,i6,3x,i6,1x,f16.8,1x,f16.4)') i,k,member(k),dum,erel end if end if @@ -700,7 +693,7 @@ subroutine CCEGEN(env,pr,fname) write (stdout,'(1x,a,i0,a)') '(',ncb-ancb,' clusters discarded due to cluster merge)' end if end if - call zens%deallocate() + if (allocated(mols)) deallocate (mols) if (pr) then write (stdout,*) @@ -979,7 +972,7 @@ subroutine kmeans_seeds(nclust,npc,mm,centroid,pcvec,ndist,dist) ddum = 0.0_sp do kiter = 1,ndist if (dist(kiter) > ddum) then - ddum=dist(kiter) + ddum = dist(kiter) k = kiter end if end do @@ -1153,7 +1146,7 @@ subroutine cluststat(nclust,npc,mm,centroid,pcvec,member,DBI,pSF,SSRSST) SST = 0.0d0 p = 0.0d0 do c = 1,nclust - weight = real(count(member(:)==c,1),wp)/real(mm,wp) + weight = real(count(member(:) == c,1),wp)/real(mm,wp) p(1:npc) = p(1:npc)+centroid(1:npc,c)*weight end do !p = p/float(nclust) @@ -1365,37 +1358,25 @@ subroutine getdiederatoms(zmol,nat,inc,nb,diedat,ndied) return end subroutine getdiederatoms -subroutine calc_dieders(nat,xyz,ndied,diedat,diedr) +subroutine calc_dieders(mol,ndied,diedat,diedr) + !***************************************************** + !* Calculate dihedral angles for selected atom * + !* quartets. Results are in radians (-pi, pi). * + !***************************************************** use crest_parameters,idp => dp - use crest_data - use zdata use strucrd implicit none - integer :: nat,ndied - real(wp) :: xyz(3,nat) - integer :: diedat(4,ndied) + type(coord),intent(in) :: mol + integer,intent(in) :: ndied + integer,intent(in) :: diedat(4,ndied) real(wp),intent(out) :: diedr(ndied) integer :: i - integer :: a,b,c,d - real(wp) :: coords(3,4) - real(wp) :: angle - real(wp),parameter :: rad2degree = 57.29578_wp - real(wp),parameter :: tol = 5.0_wp !tolerance for almost 360 degree diedr = 0.0_wp do i = 1,ndied - a = diedat(2,i) - b = diedat(3,i) - c = diedat(1,i) - d = diedat(4,i) - coords(1:3,1) = xyz(1:3,c) - coords(1:3,2) = xyz(1:3,a) - coords(1:3,3) = xyz(1:3,b) - coords(1:3,4) = xyz(1:3,d) - call DIHED(coords,1,2,3,4,angle) - angle = abs(angle)*rad2degree - !if (abs(angle-360.0_wp) < tol) angle = 0.0_wp - diedr(i) = angle + !> diedat: (1)=neighbour of a, (2)=a, (3)=b, (4)=neighbour of b + diedr(i) = mol%dihedral(diedat(1,i),diedat(2,i), & + & diedat(3,i),diedat(4,i)) end do return From 2e90462d44cad3540d68161b820ce1178a25f8d0 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 23 May 2026 21:54:44 +0200 Subject: [PATCH 344/374] cosmetics (update help menue, in particular --help sort) --- src/printouts.f90 | 54 +++++++++++++++++++++++++++++------------------ 1 file changed, 34 insertions(+), 20 deletions(-) diff --git a/src/printouts.f90 b/src/printouts.f90 index e490b9c1..6f88f5d1 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -60,8 +60,8 @@ subroutine confscript_head(vers) write (*,'(4x,a)') ' P.Pracht, S.Grimme, Universität Bonn, MCTC' write (*,'(3x,a)') 'with help from (alphabetical order):' write (*,'(4x,a)') ' C.Bannwarth, F.Bohle, S.Ehlert, G.Feldmann, J.Gorges,' - write (*,'(4x,a)') ' S.Grimme, C.Plett, P.Pracht, S.Spicher, P.Steinbach,' - write (*,'(4x,a)') ' P.Wesolowski, F.Zeller' + write (*,'(4x,a)') ' S.Grimme, C.Plett, P.Pracht, L.Rindt, S.Spicher,' + write (*,'(4x,a)') ' P.Steinbach, P.Wesolowski, F.Zeller' write (*,*) write (*,'(3x,a)') 'Online documentation is available at' @@ -207,17 +207,17 @@ subroutine confscript_morehelp(flag) call help_opt('-opt/-optimize',fw,'Geometry optimization') call help_opt('-hess/-numhess',fw,'Numerical Hessian / vibrational frequencies') call help_opt('-md/-dynamics',fw,'Molecular dynamics simulation') - call help_opt('-v3/-imtdgc',fw,'iMTD-GC conformational search (see --help conf)') - call help_opt('-v4/-entropy',fw,'Entropy/free-energy sampling (see --help conf)') + call help_opt('-v3/-imtdgc',fw,'iMTD-GC conformational search (see '//colorify('--help conf','gold')//')') + call help_opt('-v4/-entropy',fw,'Entropy/free-energy sampling (see '//colorify('--help conf','gold')//')') call help_opt('-mdopt',fw,'Ensemble optimization (no sorting)') call help_opt('-screen',fw,'Ensemble screening') call help_opt('-protonate',fw,'Protonation site search') call help_opt('-deprotonate',fw,'Deprotonation site search') call help_opt('-tautomerize',fw,'Tautomer generation') - call help_opt('-qcg',fw,'Quantum Cluster Growth workflows (see --help qcg)') - call help_opt('-msreact',fw,'MS fragment generator (see --help msreact)') + call help_opt('-qcg',fw,'Quantum Cluster Growth workflows (see '//colorify('--help qcg','gold')//')') + call help_opt('-msreact',fw,'MS fragment generator (see '//colorify('--help msreact','gold')//')') call help_opt('-bh/-GMIN',fw,'Basin-hopping global optimization') - call help_opt('-sort',fw,'Ensemble sorting via CREGEN (see --help compare)') + call help_opt('-sort/-cregen',fw,'Ensemble sorting, comparison, clustering (see '//colorify('--help compare','gold')//')') write (stdout,*) fw = 22 call help_section('Method selection:') @@ -270,11 +270,13 @@ subroutine confscript_morehelp(flag) ! ── Ensemble comparison / CREGEN ───────────────────────────────────── case ('compare','cregen') - fw = 20 - call help_section('Options for ensemble comparisons:') - call help_opt('-cregen [file]',fw,'Run CREGEN standalone to sort an ensemble file.') + fw = 22 + call help_section('Ensemble sorting (CREGEN):') + call help_opt('-cregen [file]',fw,'Run CREGEN standalone to sort an ensemble file') + call help_opt('-sort ',fw,'Ensemble sorting (default: iRMSD-based conformer assignment)') + call help_opt('-sort cregen',fw,'CREGEN sorting via --sort') write (stdout,*) - call help_section('Thresholds:') + call help_section('CREGEN thresholds:') call help_opt('-ewin ',fw,'Energy window in kcal/mol [default: 6.0]') call help_opt('-rthr ',fw,'RMSD threshold in Ang [default: 0.125]') call help_opt('-ethr ',fw,'Energy threshold in kcal/mol [default: 0.05]') @@ -282,19 +284,35 @@ subroutine confscript_morehelp(flag) call help_opt('-pthr ',fw,'Boltzmann population threshold (0-1) [default: 0.05]') call help_opt('-temp ',fw,'Boltzmann temperature in K [default: 298.15]') write (stdout,*) - call help_section('Algorithm options:') + call help_section('CREGEN algorithm options:') call help_opt('-topo/-notopo',fw,'Enable/disable topology change check') call help_opt('-ezcheck',fw,'Enable E/Z double-bond isomer check') call help_opt('-heavy',fw,'Use heavy-atom-only RMSD') call help_opt('-allrot',fw,'Use all three rotational constants (A, B, C)') call help_opt('-eqv/-nmr',fw,'NMR nuclear equivalence analysis (requires rotamers)') - call help_opt('-cluster ',fw,'PCA + k-Means clustering ( = number of clusters)') write (stdout,*) - call help_section('Output:') + call help_section('CREGEN output:') call help_opt('-prsc',fw,'Write scoord.* file for each conformer') call help_opt('-nowr',fw,"Skip writing the sorted ensemble file") call help_opt('-osdf',fw,'Also write output ensemble in SDF format') write (stdout,*) + call help_section('Structural comparison tools:') + call help_opt('-rmsd ',fw,'RMSD between two structures') + call help_opt('-rmsdheavy ',fw,'Heavy-atom RMSD between two structures') + call help_opt('-irmsd ',fw,'iRMSD (iterative RMSD with atom permutation)') + call help_opt('-compare ',fw,'Compare two ensembles for structural overlap') + write (stdout,'(11x,a)') colorify('-maxcomp ','green')//' : max conformers per ensemble [default: 10]' + write (stdout,*) + call help_section('PCA / k-Means clustering (CCEGEN):') + call help_opt('-sort --cluster',fw,'Standalone PCA clustering of an ensemble') + call help_opt('-cluster []',fw,'PCA + k-Means clustering, optionally fix the cluster count') + call help_opt('-cluster ',fw,'Clustering level: loose, normal, tight, vtight') + call help_opt('-cluster incremental',fw,'Test cluster sizes incrementally (large ensembles)') + call help_opt('-pctype ',fw,'PCA descriptor: dihedral (default), zmat, cartesian, cma') + call help_opt('-pccap ',fw,'Cap the number of principal components [default: 100]') + call help_opt('-nopcmin',fw,'Include all PCs (disable minimum eigenvalue cutoff)') + call help_opt('-pcaexclude ',fw,'Exclude specified atoms from the PCA') + write (stdout,*) ! ── Conformer search / sampling ────────────────────────────────────── case ('conf','sampling') @@ -432,14 +450,11 @@ subroutine confscript_morehelp(flag) call help_opt('-mdhess ',fw,'Hessians + thermochemistry for every structure in an ensemble (XYZ)') call help_opt('-screen ',fw,'Multi-level energy screening of an ensemble') call help_opt('-entropy []',fw,'Conformational entropy from ensemble') - call help_opt('-sort',fw,'Sort ensemble structures by energy') call help_opt('-symmetries',fw,'Symmetry analysis of all structures in an ensemble') call help_opt('-printboltz',fw,'Print Boltzmann population weights') - call help_opt('-compare ',fw,'Compare two ensembles for structural overlap') - write (stdout,'(9x,a)') colorify('-maxcomp ','green')//' : max conformers per ensemble [default: 10]' call help_opt('-splitfile [i] [j]',fw,'Split ensemble into per-structure directories (SPLIT/)') - call help_opt('-rmsd ',fw,'RMSD between two structures (auto-converted to Ang)') - call help_opt('-rmsdheavy ',fw,'Heavy-atom RMSD between two structures') + write (stdout,'(9x,a)') 'For sorting, clustering, RMSD, and ensemble comparison tools' + write (stdout,'(9x,a)') 'see '//colorify('--help compare','gold') write (stdout,*) call help_section('Protonation / tautomerization:') call help_opt('-protonate',fw,"Find a molecule's protomers (LMO π/LP-center approach)") @@ -449,7 +464,6 @@ subroutine confscript_morehelp(flag) write (stdout,'(9x,a)') colorify('-iter ','green')//' : number of prot/deprot cycles [default: 2]' write (stdout,*) call help_section('Miscellaneous:') - call help_opt('-cregen [file]',fw,'CREGEN ensemble sorting (see also --help compare)') call help_opt('-zsort',fw,'Z-matrix sorting of the input coord file') call help_opt('-testtopo ',fw,'Topology / bond connectivity analysis') call help_opt('-constrain ',fw,'Write example constraint file ".xcontrol.sample"') From a9778cc41114a477116b415d1b67805aa4b09bac Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 23 May 2026 23:39:57 +0200 Subject: [PATCH 345/374] cosmetics (cleanup of ancient ensemblecomp routine --> iRMSD) --- src/algos/sorting.f90 | 3 + src/confparse.f90 | 9 +- src/crest_main.f90 | 7 +- src/printouts.f90 | 2 +- src/sorting/ensemblecomp.f90 | 626 +++++++++++++++++------------------ 5 files changed, 305 insertions(+), 342 deletions(-) diff --git a/src/algos/sorting.f90 b/src/algos/sorting.f90 index cf493937..e6b9d7d3 100644 --- a/src/algos/sorting.f90 +++ b/src/algos/sorting.f90 @@ -80,6 +80,9 @@ subroutine crest_sort(env,tim) call irmsd_tool(trim(env%ensemblename),trim(env%ensemblename2),env%iinversion) stop + case ('compare') + call compare_ensembles(env) + case ('isort') !>--- Assigning structures to conformers based on RTHR,with canonical atom IDs call underline('Assigning conformers based on iRMSD and RTHR') diff --git a/src/confparse.f90 b/src/confparse.f90 index 73a0cf4e..004e8f6b 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -206,7 +206,7 @@ subroutine parseflags(env,arg,nra) env%multilevelopt = .true. !> perform multilevel optimization env%trackorigin = .true. !> for v2 track generation step by default env%compareens = .false. !> compare two given ensembles - env%maxcompare = 10 !> maximum number of (lowest) conformers to compare when using "-compare" + env%maxcompare = 100 !> maximum number of (lowest) structures to compare when using "-compare" env%QCG = .false. !> special QCG usage !>--- The following settings are mainly for v.1 (MF-MD-GC) @@ -489,8 +489,9 @@ subroutine parseflags(env,arg,nra) case ('-compare') !> flag for comparing two ensembles, analysis tool processedarg(i) = .true. env%compareens = .true. - env%crestver = 5 - env%properties = p_compare + env%crestver = crest_sorting + env%sortmode = 'compare' + env%preopt = .false. env%ensemblename = 'none selected' env%ensemblename2 = 'none selected' if (nra .ge. (i+2)) then @@ -2118,7 +2119,7 @@ subroutine parseflags(env,arg,nra) processedarg(i) = .true. env%compareens = .true. - case ('-maxcomp') !> maximum number of lowest conformers to compare with "-compare" + case ('-maxcomp') !> maximum number of lowest structures to compare with "-compare" processedarg(i) = .true. call readl(arg1,xx,j) if (j > 0) then diff --git a/src/crest_main.f90 b/src/crest_main.f90 index a5902793..befe0b0a 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -89,7 +89,7 @@ program CREST !> SOME I/O STUFF !=========================================================================================! !>--- check for the coord file in the working directory - if (env%crestver /= crest_solv) then + if (env%crestver /= crest_solv.and.env%crestver /= crest_sorting) then inquire (file='coord',exist=ex) if (.not.ex) then error stop 'No coord file found. Exit.' @@ -110,11 +110,6 @@ program CREST write (*,*) 'exit.' call propquit(tim) -!>--- only ensemble comparison - case (p_compare) - call compare_ensembles(env) - call propquit(tim) - !>--- extended tautomerization case (p_tautomerize2) call tautomerize_ext(env%ensemblename,env,tim) diff --git a/src/printouts.f90 b/src/printouts.f90 index 6f88f5d1..9a34775b 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -301,7 +301,7 @@ subroutine confscript_morehelp(flag) call help_opt('-rmsdheavy ',fw,'Heavy-atom RMSD between two structures') call help_opt('-irmsd ',fw,'iRMSD (iterative RMSD with atom permutation)') call help_opt('-compare ',fw,'Compare two ensembles for structural overlap') - write (stdout,'(11x,a)') colorify('-maxcomp ','green')//' : max conformers per ensemble [default: 10]' + write (stdout,'(11x,a)') colorify('-maxcomp ','green')//' : max structures per ensemble [default: 100]' write (stdout,*) call help_section('PCA / k-Means clustering (CCEGEN):') call help_opt('-sort --cluster',fw,'Standalone PCA clustering of an ensemble') diff --git a/src/sorting/ensemblecomp.f90 b/src/sorting/ensemblecomp.f90 index 241fcbb0..e47dda5c 100644 --- a/src/sorting/ensemblecomp.f90 +++ b/src/sorting/ensemblecomp.f90 @@ -23,358 +23,322 @@ ! crest --compare !================================================================================! subroutine compare_ensembles(env) - use iso_fortran_env,only:wp => real64 - use ls_rmsd - use iomod + !*********************************************************************** + !* Compare two molecular ensembles via iRMSD. * + !* Reads both ensembles into coord arrays, sorts by energy, and * + !* computes iRMSD comparisons for the lowest structures using * + !* OMP-parallel permutation-invariant RMSD. * + !* Per-structure tracking: group ID + best RMSD, O(ncomp1+ncomp2). * + !*********************************************************************** + use crest_parameters use crest_data - use strucrd,only:rdensembleparam,rdensemble - use cregen_interface + use strucrd + use quicksort_interface + use axis_module + use canonical_mod + use irmsd_module + use iomod + use omp_lib + use term_ui implicit none - type(systemdata) :: env - - integer :: i,j,k,l,kk,ll - integer :: be,ed - integer :: tr1,tr2 - integer :: nat - integer :: dum,T,Tn - integer :: nat1,nat2 - integer :: nall1,nall2 - integer :: nconf1,nconf2 - integer :: nrot1,nrot2 - integer :: rcount - integer :: ich,ich2 - - real(wp) :: rthr - real(wp) :: rval - real(wp) :: min_1,min_2,min_tot - - real(wp),allocatable :: gdum(:,:),Udum(:,:),xdum(:),ydum(:) ! rmsd dummy stuff - real(wp),allocatable :: rmat(:,:),rmat2(:) - real(wp),allocatable :: c1(:,:),c2(:,:) - real(wp),allocatable :: xyz1(:,:,:),xyz2(:,:,:) - real(wp),allocatable :: conf1(:,:,:),conf2(:,:,:) - real(wp),allocatable :: eread1(:),eread2(:),en1(:),en2(:) - integer,allocatable :: at1(:),at2(:) - integer,allocatable :: b1(:),b2(:) - integer,allocatable :: e1(:),e2(:) - integer,allocatable :: rots1(:),rots2(:) - - character(len=128) :: ensname1,ensname1backup - character(len=128) :: ensname2 - character(len=60) :: track1,track2 - character(len=6) :: connect - - logical :: matching,ex - - real(wp),parameter :: autokcal = 627.509541d0 - - associate (ensemblename => env%ensemblename,ensemblename2 => env%ensemblename2, & - & thresholds => env%thresholds,cgf => env%cgf,maxcompare => env%maxcompare) - nat = env%nat - -!---- - call compens_cleanup() - -!---- check if two valid files were given - inquire (file=ensemblename,exist=ex) - if (.not.ex) then - write (*,'(2x,a,a,a)') 'File <',trim(ensemblename),'> does not exist!' - error stop - end if - inquire (file=ensemblename2,exist=ex) - if (.not.ex) then - write (*,'(2x,a,a,a)') 'File <',trim(ensemblename2),'> does not exist!' - error stop + type(systemdata),intent(inout) :: env + + type(coord),allocatable :: strucs1(:),strucs2(:) + type(coord),allocatable :: workmols(:) + type(rmsd_cache),allocatable :: rcaches(:) + type(canonical_sorter),allocatable :: sorters(:) + real(wp),allocatable :: rmat(:,:),rmat_1d(:) + + !> per-structure best match and RMSD + real(wp),allocatable :: best_rmsd_a(:),best_rmsd_b(:) + integer,allocatable :: best_partner_a(:),best_partner_b(:) + + integer :: nall1,nall2,ncomp1,ncomp2,nat + integer :: i,j,k,cc,T,Tn,npairs,ich + integer :: nmatch_a,nmatch_b,pn1,pn2,pcount + real(wp) :: RTHR,rmsdval,erel1,erel2,min_1,min_2,min_tot + logical :: ex,stereocheck,first,store_rmat + + type(progress_state) :: pbar + + external :: PRMAT + +! ── cleanup previous output files ─────────────────────────────────── + call compens_cleanup() + +! ── validate input files ──────────────────────────────────────────── + inquire (file=env%ensemblename,exist=ex) + if (.not.ex) then + write (stdout,'(2x,a,a,a)') 'File <',trim(env%ensemblename),'> does not exist!' + error stop + end if + inquire (file=env%ensemblename2,exist=ex) + if (.not.ex) then + write (stdout,'(2x,a,a,a)') 'File <',trim(env%ensemblename2),'> does not exist!' + error stop + end if + +! ── read ensembles into coord arrays ──────────────────────────────── + write (stdout,'(1x,a,a,a)',advance='no') 'Reading ensemble <',trim(env%ensemblename),'> ...' + flush (stdout) + call rdensemble(env%ensemblename,nall1,strucs1) + write (stdout,'(1x,i0,a)') nall1,' structures.' + + write (stdout,'(1x,a,a,a)',advance='no') 'Reading ensemble <',trim(env%ensemblename2),'> ...' + flush (stdout) + call rdensemble(env%ensemblename2,nall2,strucs2) + write (stdout,'(1x,i0,a)') nall2,' structures.' + write (stdout,*) + +! ── validate compatibility ────────────────────────────────────────── + nat = strucs1(1)%nat + if (strucs1(1)%nat /= strucs2(1)%nat) then + write (stdout,'(a)') "Nat1 /= Nat2 : Number of atoms of the two ensembles don't match!" + write (stdout,'(a)') "You are trying to compare two different molecules!" + error stop "exit." + end if + do i = 1,nat + if (strucs1(1)%at(i) /= strucs2(1)%at(i)) then + write (stdout,'(a)') "The ordering of atoms apparently is different between the two ensembles!" + write (stdout,'(a)') "This way it is impossible to calculate RMSDs!" + error stop "exit." end if + end do -!---- settings - allocate (gdum(3,3),Udum(3,3),xdum(3),ydum(3)) - rthr = env%rthr ! RMSD threshold - - ensname1 = 'ensemble1.inp.xyz' - ensname2 = 'ensemble2.inp.xyz' - track1 = 'track.1' - track2 = 'track.2' - -!---- sort the input files with CREGEN - env%confgo = .true. !needs to be activated here -!----- first file - call smallhead('Sorting file <'//trim(ensemblename)//'>') - ensname1backup = trim(ensemblename) - - call newcregen(env,0) - - call rename(trim(ensemblename)//'.sorted',trim(ensname1)) - call rename('.cretrack',track1) - call rdensembleparam(trim(ensname1),nat1,nall1) - allocate (xyz1(3,nat1,nall1),eread1(nall1),at1(nat1)) - call rdensemble(trim(ensname1),nat1,nall1,at1,xyz1,eread1) - !---- read tracking information (which conformer has which rotamers from the files?) - open (newunit=tr1,file=track1) - read (tr1,*) nconf1 !ensemble 1 has "nconf1" conformers - !to compare a limited number "maxcompare" conformers, "nconf1/2" is normalized to maxcompare - !i.e. if nconf > maxcompare, nconf is set to maxcompare; if nconf < maxcompare, it is not changed - dum = nconf1 - nconf1 = min(nconf1,maxcompare) - !---- set up the mapping - allocate (b1(nconf1),e1(nconf1),rots1(nconf1)) - do i = 1,nconf1 - read (tr1,*) l,b1(i),e1(i) - rots1(i) = e1(i)-b1(i)+1 - end do - close (tr1) - write (*,'(2x,a,a,a,i0,a)') 'File <',trim(ensemblename),'> contains ',dum,' conformers.' - if (dum .lt. maxcompare) then - write (*,'(2x,a,i0,a)') 'All of the ',dum,' conformers will be taken for the comparison:' - else - write (*,'(2x,a,i0,a)') 'The ',nconf1,' lowest conformers will be taken for the comparison:' - end if - write (*,'(2x,a9,2x,a9)') 'conformer','#rotamers' - do i = 1,nconf1 - write (*,'(i9,2x,i9)') i,rots1(i) - end do - write (*,*) - -!----- second file - ensemblename = ensemblename2 !done so that CREGEn sorts the correct file - call smallhead('Sorting file <'//trim(ensemblename2)//'>') - - call newcregen(env,0) - - ensemblename = trim(ensname1backup) - call rename(trim(ensemblename2)//'.sorted',trim(ensname2)) - call rename('.cretrack',track2) - call rdensembleparam(trim(ensname2),nat2,nall2) - allocate (xyz2(3,nat2,nall2),eread2(nall2),at2(nat2)) - call rdensemble(trim(ensname2),nat2,nall2,at2,xyz2,eread2) -!---- read tracking information (which conformer has which rotamers from the files?) - open (newunit=tr2,file=track2) - read (tr2,*) nconf2 !ensemble 2 has "nconf2" conformers - !to compare a limited number "maxcompare" conformers, "nconf1/2" is normalized to maxcompare - !i.e. if nconf > maxcompare, nconf is set to maxcompare; if nconf < maxcompare, it is not changed - dum = nconf2 - nconf2 = min(nconf2,maxcompare) -!-----set up the mapping - allocate (b2(nconf2),e2(nconf2),rots2(nconf2)) - do i = 1,nconf2 - read (tr2,*) l,b2(i),e2(i) - rots2(i) = e2(i)-b2(i)+1 - end do - close (tr2) - write (*,'(2x,a,a,a,i0,a)') 'File <',trim(ensemblename2),'> contains ',dum,' conformers.' - if (dum .lt. maxcompare) then - write (*,'(2x,a,i0,a)') 'All of the ',dum,' conformers will be taken for the comparison:' - else - write (*,'(2x,a,i0,a)') 'The ',nconf2,' lowest conformers will be taken for the comparison:' +! ── sort each ensemble by energy ──────────────────────────────────── + call ensemble_qsort(nall1,strucs1,1,nall1) + call ensemble_qsort(nall2,strucs2,1,nall2) + +! ── select lowest structures ──────────────────────────────────────── + ncomp1 = min(nall1,env%maxcompare) + ncomp2 = min(nall2,env%maxcompare) + npairs = ncomp1*ncomp2 + + call smallhead('Comparing the Ensembles') + write (stdout,'(2x,a,a,a,i0,a,i0,a)') & + 'Ensemble A <',trim(env%ensemblename),'> : ', & + nall1,' structures, using ',ncomp1,' lowest' + write (stdout,'(2x,a,a,a,i0,a,i0,a)') & + 'Ensemble B <',trim(env%ensemblename2),'> : ', & + nall2,' structures, using ',ncomp2,' lowest' + +! ── set up OMP parallelization ────────────────────────────────────── + call new_ompautoset(env,'max',0,T,Tn) + write (stdout,'(2x,a,i0)') 'OpenMP threads: ',T + +! ── set up RMSD threshold (in Bohr) ──────────────────────────────── + RTHR = env%rthr*aatoau + write (stdout,'(2x,a,f8.4,a)') 'RMSD threshold: ',env%rthr,' Å' + write (stdout,'(2x,a,i0)') 'Total comparisons: ',npairs + write (stdout,*) + +! ── set up canonical sorter and axis-align structures ─────────────── + write (stdout,'(1x,a)',advance='no') 'Setting up iRMSD infrastructure ...' + flush (stdout) + + allocate (sorters(1)) + call axis(nat,strucs1(1)%at,strucs1(1)%xyz) + call sorters(1)%init(strucs1(1),invtype='apsp+',heavy=.false.) + stereocheck = .not.(sorters(1)%hasstereo(strucs1(1))) + call sorters(1)%shrink() + + select case (env%iinversion) + case (1) + stereocheck = .true. + case (2) + stereocheck = .false. + end select + + do i = 1,ncomp1 + call axis(nat,strucs1(i)%at,strucs1(i)%xyz) + end do + do i = 1,ncomp2 + call axis(nat,strucs2(i)%at,strucs2(i)%xyz) + end do + +! ── allocate per-thread work caches ───────────────────────────────── + allocate (rcaches(T)) + allocate (workmols(T)) + do i = 1,T + allocate (workmols(i)%at(nat)) + allocate (workmols(i)%xyz(3,nat)) + call rcaches(i)%allocate(nat) + rcaches(i)%stereocheck = stereocheck + end do + write (stdout,'(1x,a)') 'done.' + +! ── allocate per-structure tracking (O(ncomp1+ncomp2)) ────────────── + store_rmat = (ncomp1 <= 20.and.ncomp2 <= 20) + allocate (best_rmsd_a(ncomp1),source=huge(1.0_wp)) + allocate (best_rmsd_b(ncomp2),source=huge(1.0_wp)) + allocate (best_partner_a(ncomp1),source=0) + allocate (best_partner_b(ncomp2),source=0) + if (store_rmat) then + allocate (rmat(ncomp1,ncomp2),source=0.0_wp) + end if + +! ── compute iRMSDs (OMP parallel) with progress bar ──────────────── + pcount = 0 + call progress_init(pbar,total=npairs,prefix=' iRMSD ') + + !$omp parallel & + !$omp shared(strucs1,strucs2,rmat,store_rmat) & + !$omp shared(best_rmsd_a,best_rmsd_b,best_partner_a,best_partner_b) & + !$omp shared(sorters,rcaches,workmols,npairs,ncomp2,nat,RTHR,pbar) & + !$omp private(k,i,j,cc,rmsdval) + !$omp do schedule(dynamic) + do k = 1,npairs + cc = omp_get_thread_num()+1 + i = (k-1)/ncomp2+1 + j = mod(k-1,ncomp2)+1 + rcaches(cc)%rank(1:nat,1) = sorters(1)%rank(1:nat) + rcaches(cc)%rank(1:nat,2) = sorters(1)%rank(1:nat) + workmols(cc)%nat = nat + workmols(cc)%at(:) = strucs2(j)%at(:) + workmols(cc)%xyz(:,:) = strucs2(j)%xyz(:,:) + call min_rmsd(strucs1(i),workmols(cc),rcache=rcaches(cc),rmsdout=rmsdval) + if (store_rmat) rmat(i,j) = rmsdval + if (rmsdval < RTHR) then + !$omp critical + if (rmsdval < best_rmsd_a(i)) then + best_rmsd_a(i) = rmsdval + best_partner_a(i) = j + end if + if (rmsdval < best_rmsd_b(j)) then + best_rmsd_b(j) = rmsdval + best_partner_b(j) = i + end if + !$omp end critical end if - write (*,'(2x,a9,2x,a9)') 'conformer','#rotamers' - do i = 1,nconf2 - write (*,'(i9,2x,i9)') i,rots2(i) + !$omp atomic + pcount = pcount+1 + !$omp end atomic + if (cc == 1) call progress_update(pbar,pcount,npairs) + end do + !$omp end do + !$omp end parallel + + call progress_update(pbar,npairs,npairs,force=.true.) + call progress_finish(pbar) + write (stdout,*) + +! ── print RMSD matrix (only for small matrices) ──────────────────── + if (store_rmat) then + pn1 = ncomp1 + pn2 = ncomp2 + allocate (rmat_1d(pn1*pn2)) + do j = 1,pn2 + do i = 1,pn1 + rmat_1d((j-1)*pn1+i) = rmat(i,j)*autoaa + end do end do - write (*,*) - -!---- run some checks that are mandatory in order for the compariso to work properly - if (nat1 /= nat2) then - write (*,'(a)') "Nat1 /= Nat2 : Number of atoms of the two ensembles don't match!" - write (*,'(a)') "You are trying to compare two different molecules!" - error stop "exit." + call PRMAT(stdout,rmat_1d,pn1,pn2,'RMSD (Angstrom)') + deallocate (rmat_1d,rmat) + end if + +! ── correlation printout ──────────────────────────────────────────── + min_1 = strucs1(1)%energy + min_2 = strucs2(1)%energy + min_tot = min(min_1,min_2) + + call smallhead('Correlation between Structures') + write (stdout,'(2x,a,30x,a)') 'Ensemble A','Ensemble B' + write (stdout,'(2x,a4,2x,a14,10x,a4,2x,a14,3x,a8)') & + '#','Erel/kcal','#','Erel/kcal','RMSD/Å' + write (stdout,'(2x,a)') repeat('-',62) + + do i = 1,ncomp1 + erel1 = (strucs1(i)%energy-min_1)*autokcal + if (best_partner_a(i) > 0) then + j = best_partner_a(i) + erel2 = (strucs2(j)%energy-min_2)*autokcal + write (stdout,'(2x,i4,2x,f14.5,2x,a5,2x,i4,2x,f14.5,3x,f8.4)') & + i,erel1,'<--->',j,erel2,best_rmsd_a(i)*autoaa else - nat = nat1 + write (stdout,'(2x,i4,2x,f14.5)') i,erel1 end if - do i = 1,nat - if (at1(i) /= at2(i)) then - write (*,'(a)') "The ordering of atoms apparently is different between the two ensembles!" - write (*,'(a)') "This way it is impossible to calculate RMSDs!" - error stop "exit." - end if - end do - -!---- set the threads for the RMSD calculation (OMP parallel) - call new_ompautoset(env,'max',0,T,Tn) - -!---- printout - call smallhead('Comparing the Ensembles') + end do -!----- set up some more arrays - allocate (rmat(nconf1,nconf2),c1(3,nat),c2(3,nat),en1(nconf1),en2(nconf2)) -!---- get energies of lowest conformers - do i = 1,nconf1 - en1(i) = eread1(b1(i)) - end do - do i = 1,nconf2 - en2(i) = eread2(b2(i)) - end do - deallocate (eread2,eread1) - - write (*,'(1x,a)',advance='no') 'Calculating RMSDs between conformers...' -!-----compare conformer-block-wise, i.e. all rotamers of each conformer pair of ensemble 1 and 2 -!----- THIS IS THE MAIN LOOP OF THE SUBROUTINE - do i = 1,nconf1 - be = b1(i) - ed = e1(i) - nrot1 = ed-be+1 - !write(*,*) b,e,nrot1 - allocate (conf1(3,nat,nrot1)) - conf1(1:3,1:nat,1:nrot1) = xyz1(1:3,1:nat,be:ed) - do j = 1,nconf2 - be = b2(j) - ed = e2(j) - nrot2 = ed-be+1 - allocate (conf2(3,nat,nrot2)) - conf2(1:3,1:nat,1:nrot2) = xyz2(1:3,1:nat,be:ed) - rcount = nrot1*nrot2 !total number of RMSDs between - allocate (rmat2(rcount)) - rmat2 = 100 !<--only done so we can easily get the minimum rmsd later - - do k = 1,nrot1 - c1(1:3,1:nat) = conf1(1:3,1:nat,k) -!$omp parallel private (l,rcount,c2,ydum,xdum,Udum,gdum) & -!$omp shared (k,c1,rmat2,nat,conf2,nrot2) -!$omp do - do l = 1,nrot2 - rcount = ((k-1)*nrot2)+l - c2(1:3,1:nat) = conf2(1:3,1:nat,l) - call rmsd(nat,c1,c2,0,Udum,xdum,ydum,rmat2(rcount),.false.,gdum) ! all atoms - !write(*,*)rmat2(rcount) - end do -!$omp end do -!$omp end parallel - end do - rmat(i,j) = minval(rmat2) - deallocate (rmat2,conf2) - end do - deallocate (conf1) - end do - write (*,'(1x,a)') 'done.' -!--------- - !--- print the RMSD matrix - write (*,'(1x,a,f8.4,a)') 'RMSD threshold:',rthr,' Å' - call pr_rmat(rmat,nconf1,nconf2) -!-------- - write (*,*) - call smallhead('Correlation between Conformers :') - write (*,'(4x,a,5x,a10,13x,a,4x,a10)') '#','Ensemble A','#','Ensemble B' - dum = nconf1+nconf2 - kk = nconf1 - ll = nconf2 - connect = '<---->' - do - matching = .false. - if (kk .gt. 0.and.ll .gt. 0) then - min_1 = en1(kk) - min_2 = en2(ll) - rval = rmat(kk,ll) - if (rval .le. rthr) then !<--- two matching conformers from ensembles - write (*,'(1x,i4,1x,f14.5,3x,a,1x,i4,f14.5)') kk,min_1,connect,ll,min_2 - kk = kk-1 - ll = ll-1 - matching = .true. - end if + write (stdout,'(2x,a)') repeat('-',62) + + nmatch_a = count(best_partner_a > 0) + nmatch_b = count(best_partner_b > 0) + write (stdout,'(2x,i0,a,i0,a)') nmatch_a,' of ',ncomp1, & + ' structures in A have a match in B' + write (stdout,'(2x,i0,a,i0,a)') nmatch_b,' of ',ncomp2, & + ' structures in B have a match in A' + + first = .true. + do i = 1,ncomp1 + if (best_partner_a(i) == 0) then + if (first) then + write (stdout,'(2x,a)',advance='no') 'Unmatched in A:' + first = .false. end if - if (.not.matching) then - if (kk .gt. 0.and.ll .gt. 0) then - min_1 = en1(kk) - min_2 = en2(ll) - if (min_1 .ge. min_2) then - write (*,'(1x,i4,1x,f14.5)') kk,min_1 - kk = kk-1 - else - write (*,'(30x,i4,f14.5)') ll,min_2 - ll = ll-1 - end if - end if - if (kk .gt. 0.and.ll .eq. 0) then - min_1 = en1(kk) - write (*,'(1x,i4,1x,f14.5)') kk,min_1 - kk = kk-1 - end if - if (kk .eq. 0.and.ll .gt. 0) then - min_2 = en2(ll) - write (*,'(30x,i4,f14.5)') ll,min_2 - ll = ll-1 - end if + write (stdout,'(1x,i0)',advance='no') i + end if + end do + if (.not.first) write (stdout,*) + + first = .true. + do j = 1,ncomp2 + if (best_partner_b(j) == 0) then + if (first) then + write (stdout,'(2x,a)',advance='no') 'Unmatched in B:' + first = .false. end if - if (kk .eq. 0.and.ll .eq. 0) exit - end do + write (stdout,'(1x,i0)',advance='no') j + end if + end do + if (.not.first) write (stdout,*) -!----- plotfiles - !--- convert to relative energies - min_1 = minval(en1) - min_2 = minval(en2) - min_tot = min(min_1,min_2) - !en1=(en1-min_tot)*autokcal - !en2=(en2-min_tot)*autokcal - !--- energies of ensemble 1 - open (newunit=ich,file='energy_1.dat') - do i = 1,nconf1 - write (ich,'(2x,f10.5,2x,f14.8)') (en1(i)-min_tot)*autokcal,en1(i) - end do - close (ich) - !--- energies of ensemble 2 - open (newunit=ich,file='energy_2.dat') - do i = 1,nconf2 - write (ich,'(2x,f10.5,2x,f14.8)') (en2(i)-min_tot)*autokcal,en2(i) - end do - close (ich) - !--- correlation between conformers of the two ensembles - open (newunit=ich2,file='rmsdmatch.dat') - do i = 1,nconf1 - do j = 1,nconf2 - rval = rmat(i,j) - if (rval .le. rthr) then - write (ich2,'(2x,i6,i6)') i,j - end if - end do - end do - close (ich2) +! ── write output files ────────────────────────────────────────────── + open (newunit=ich,file='energy_1.dat') + do i = 1,ncomp1 + write (ich,'(2x,f10.5,2x,f14.8)') & + (strucs1(i)%energy-min_tot)*autokcal,strucs1(i)%energy + end do + close (ich) -!----- - deallocate (rmat,c1,c2,en1,en2) - deallocate (b1,e1,b2,e2) - deallocate (xyz2,xyz1,at2,at1) - deallocate (ydum,xdum,Udum,gdum) -!----- - call compens_cleanup() + open (newunit=ich,file='energy_2.dat') + do i = 1,ncomp2 + write (ich,'(2x,f10.5,2x,f14.8)') & + (strucs2(i)%energy-min_tot)*autokcal,strucs2(i)%energy + end do + close (ich) - end associate + open (newunit=ich,file='rmsdmatch.dat') + do i = 1,ncomp1 + if (best_partner_a(i) > 0) then + write (ich,'(2x,i6,i6,f10.4)') i,best_partner_a(i),best_rmsd_a(i)*autoaa + end if + end do + close (ich) + +! ── cleanup ───────────────────────────────────────────────────────── + if (allocated(rmat)) deallocate (rmat) + if (allocated(best_rmsd_a)) deallocate (best_rmsd_a) + if (allocated(best_rmsd_b)) deallocate (best_rmsd_b) + if (allocated(best_partner_a)) deallocate (best_partner_a) + if (allocated(best_partner_b)) deallocate (best_partner_b) + if (allocated(rcaches)) deallocate (rcaches) + if (allocated(workmols)) deallocate (workmols) + if (allocated(sorters)) deallocate (sorters) + if (allocated(strucs1)) deallocate (strucs1) + if (allocated(strucs2)) deallocate (strucs2) end subroutine compare_ensembles !--------------------------------------------------------------------------------------- subroutine compens_cleanup() - use iso_fortran_env,only:wp => real64 + !*********************************************** + !* Remove output files from a previous run. * + !*********************************************** use iomod implicit none - call remove('scoord.1') - call remove('ensemble1.inp.xyz') - call remove('ensemble2.inp.xyz') - call remove('track.1') - call remove('track.2') - call remove('crest_best.xyz') - call remove('cregen.out.tmp') + call remove('energy_1.dat') + call remove('energy_2.dat') + call remove('rmsdmatch.dat') end subroutine compens_cleanup -!-------------------------------------------------------------------------------------- -subroutine pr_rmat(rmat,acon,bcon) - use iso_fortran_env,only:wp => real64 - implicit none - integer :: acon,bcon - real(wp) :: rmat(acon,bcon) - integer :: i,j - write (*,*) - write (*,*) 'RMSD matrix:' - write (*,'(2x,a9)',advance='no') 'conformer' - do j = 1,bcon - write (*,'(1x,i10)',advance='no') j - end do - write (*,*) - do i = 1,acon - write (*,'(1x,i5,5x)',advance='no') i - do j = 1,bcon - write (*,'(1x,f10.5)',advance='no') rmat(i,j) - end do - write (*,*) - end do -end subroutine pr_rmat - From a8e946761d2b3b3fc93a208ba0bd01da9ac2ec68 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 24 May 2026 14:00:15 +0200 Subject: [PATCH 346/374] cosmetics (more CCEGEN cleanup) --- src/crest_main.f90 | 11 +- src/printouts.f90 | 10 +- src/sorting/CMakeLists.txt | 2 + src/sorting/ccegen.f90 | 852 ++----------------------------- src/sorting/ccegen_interface.f90 | 35 ++ src/sorting/ccegen_utils.f90 | 703 +++++++++++++++++++++++++ src/sorting/meson.build | 2 + 7 files changed, 811 insertions(+), 804 deletions(-) create mode 100644 src/sorting/ccegen_interface.f90 create mode 100644 src/sorting/ccegen_utils.f90 diff --git a/src/crest_main.f90 b/src/crest_main.f90 index befe0b0a..181f019f 100644 --- a/src/crest_main.f90 +++ b/src/crest_main.f90 @@ -312,16 +312,21 @@ program CREST select case (j) case (p_prop_hess,p_prop_autoir,p_prop_ohess,p_prop_reopt,p_prop_dipole,p_prop_finalhess) call propcalc(conformerfile,j,env,tim) - case (45) + + case (abs(p_CREentropy)) call tim%start(15,'Conf. entropy evaluation') call newentropyextrapol(env) call tim%stop(15) + case (p_prop_multilevel:p_prop_multilevel+9) !hybrid reoptimization (e.g. gfn2@gff) call propcalc(infile,j,env,tim) - case (70) !PCA and clustering + + case (abs(p_cluster)) !PCA and clustering call ccegen(env,.true.,conformerfile) - case (555) + + case (abs(p_tautomerize2)) call tautomerize_ext(infile,env,tim) + case default continue end select diff --git a/src/printouts.f90 b/src/printouts.f90 index 9a34775b..31accedf 100644 --- a/src/printouts.f90 +++ b/src/printouts.f90 @@ -1137,6 +1137,7 @@ subroutine crest_output_summary(env) implicit none type(systemdata),intent(in) :: env character(len=72),parameter :: hbar = repeat('-',80) + logical :: lexists select case (env%crestver) case (crest_imtd,crest_imtd2,crest_screen,crest_mdopt, & @@ -1182,7 +1183,7 @@ subroutine crest_output_summary(env) if (env%crest_ohess) then call wfe('numhess','Hessian matrix in Turbomole format (2nd derivatives, a.u.)') call wfe('vibspectrum','vibrational frequencies (cm⁻¹) and IR intensities (km/mol)') - call wfe('g98.out','frequencies and normal modes in Gaussian 98 output format') + call wfe('g98.out','frequencies and normal modes in Gaussian output format') end if ! ── numerical Hessian ───────────────────────── @@ -1223,6 +1224,13 @@ subroutine crest_output_summary(env) end select + ! ── if PCA clustering was performed, report the cluster file ───────────────── + select case (env%crestver) + case (crest_imtd,crest_imtd2,crest_sorting) + inquire(file=clusterfile,exist=lexists) + if (lexists) call wfe(clusterfile,'representative structures from PCA/k-means clustering') + end select + select case (env%crestver) case (crest_imtd,crest_imtd2,crest_screen,crest_mdopt, & & crest_sorting,crest_optimize,crest_trialopt,crest_rigcon, & diff --git a/src/sorting/CMakeLists.txt b/src/sorting/CMakeLists.txt index 57107db4..09d42c37 100644 --- a/src/sorting/CMakeLists.txt +++ b/src/sorting/CMakeLists.txt @@ -18,6 +18,8 @@ set(dir "${CMAKE_CURRENT_SOURCE_DIR}") list(APPEND srcs "${dir}/canonical.f90" + "${dir}/ccegen_interface.f90" + "${dir}/ccegen_utils.f90" "${dir}/ccegen.f90" "${dir}/cregen_interfaces.f90" "${dir}/cregen.f90" diff --git a/src/sorting/ccegen.f90 b/src/sorting/ccegen.f90 index 5bfb0f2f..f00b0827 100644 --- a/src/sorting/ccegen.f90 +++ b/src/sorting/ccegen.f90 @@ -17,30 +17,24 @@ ! along with crest. If not, see . !================================================================================! -!=========================================================================================! -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -!=========================================================================================! -!===============================================================================! -! -! This is the CCEGEN routine, used for clustering a conformational ensemble -! and determine representative structures for the molecule. -! -! A principal component analysis (PCA) is performed, and the generated data -! is clustered. -! -! -! On Input: pr - printout boolean -! fname - name of the ensemble file -! -!==============================================================================! subroutine CCEGEN(env,pr,fname) + !***************************************************************************** + !* PCA-based clustering of a conformational ensemble. * + !* Performs SVD to extract principal components, then partitions structures * + !* into representative clusters via k-means. * + !* * + !* Input: env - system data (method settings, thresholds) * + !* pr - printout flag * + !* fname - ensemble file name * + !***************************************************************************** + use ccegen_utils use crest_parameters,idp => dp use crest_data use zdata use strucrd use utilities implicit none - type(systemdata) :: env ! MAIN STORAGE OS SYSTEM DATA + type(systemdata) :: env type(timer) :: ctimer logical,intent(in) :: pr character(len=*),intent(in) :: fname @@ -60,14 +54,13 @@ subroutine CCEGEN(env,pr,fname) integer :: ntaken integer :: nallnew real(wp),allocatable :: xyznew(:,:,:) - !integer,allocatable :: atnew(:) - real(wp),allocatable :: measure(:,:) !this is what is passed to the SVD - integer :: mn,mm !--> measure(mn,mm) - real(wp),allocatable :: pc(:) !the principal components - real(wp),allocatable :: pcvec(:,:) !the principal component eigenvectors + real(wp),allocatable :: measure(:,:) + integer :: mn,mm + real(wp),allocatable :: pc(:) + real(wp),allocatable :: pcvec(:,:) real(wp),allocatable :: pcdum(:,:) integer :: nbnd,ndied - integer,allocatable :: diedat(:,:) !atoms spanning relevant dihedral angles + integer,allocatable :: diedat(:,:) real(wp),allocatable :: diedr(:) real(wp) :: pcsum real(wp) :: pcthr @@ -77,17 +70,16 @@ subroutine CCEGEN(env,pr,fname) real(wp),allocatable :: geo(:,:) integer,allocatable :: na(:),nb(:),nc(:) - !>--- CLUSTERING params + !>--- clustering params character(len=:),allocatable :: clusteralgo - integer :: nclust !number of clusters - integer :: nclustiter !iterator for nclust + integer :: nclust + integer :: nclustiter integer :: nclustmin,nclustmax - integer,allocatable :: member(:) !track cluster correspondence + integer,allocatable :: member(:) real(ap),allocatable :: p(:),q(:) real(sp),allocatable :: dist(:) real(ap),allocatable :: centroid(:,:) integer(idp) :: ndist,klong - real(ap) :: eucdist !this is a function real(wp) :: DBI,pSF,SSRSST,SSRSSTthr real(wp) :: csthr integer :: ncb,ancb @@ -99,7 +91,6 @@ subroutine CCEGEN(env,pr,fname) logical :: autolimit real(wp) :: fraclimit - !>--- printout and params real(wp) :: emin,erel call ctimer%init(20) @@ -108,15 +99,10 @@ subroutine CCEGEN(env,pr,fname) write (stdout,'(1x,a,a)') 'Input file: ',trim(fname) end if -!=========================================================! -! set threads -!=========================================================! +! ── set threads ───────────────────────────────────────────────────────────────── call cregen_setthreads(stdout,env,pr) -!=========================================================! -! Prepare a coordinate ensemble for the clustering -!=========================================================! - !>--- 0. Set defaults, read ensemble +! ── read ensemble ──────────────────────────────────────────────────────────────── call rdensemble(fname,nall,mols) if (nall < 1) then error stop "Ensemble is empty! must stop" @@ -135,26 +121,20 @@ subroutine CCEGEN(env,pr,fname) end if heavyonly = .true. - !measuretype = 'dihedral' measuretype = env%pcmeasure clusteralgo = 'kmeans' - !pcthr = 0.85d0 !PCs must add up to this amount of "representability" pcthr = env%pcthr pcmin = env%pcmin - !csthr = 0.80d0 !threshold for SSR/SST to select a suitable cluster count csthr = env%csthr - !pccap = 100 !a cap for the number of principal components used in the clustering pccap = env%pccap - autolimit = .true. !if the ensemble is very large, take only a fraction to speed up things - !(only for predefined clustersizes with "-cluster N" ) - fraclimit = 0.25d0 !if autolimit=true, 1/4 of the ensemble is taken + autolimit = .true. + fraclimit = 0.25d0 - !>--- override pcthr and csthr based on clustering level if (env%maxcluster == 0) then call clustleveval(env,nclustmax,csthr,SSRSSTthr,pcthr) end if - !>--- 1. topology for reference structure +! ── topology for reference structure ───────────────────────────────────────────── if (env%wbotopo) then env%wbofile = 'wbo' else @@ -166,25 +146,22 @@ subroutine CCEGEN(env,pr,fname) !===========================================================! if (measuretype .ne. 'dihedral') then !===========================================================! - !>--- 2. read nuclear equivalencies if (pr) then write (stdout,*) call smallhead('READING NUCLEAR EQUIVALENCIES') end if call readequals('anmr_nucinfo',zmol,groups) if (pr) then - call groups%prsum(6) !--- print summary to screen + call groups%prsum(6) write (stdout,'(1x,a)') 'Unlisted nuclei (groups) are unique.' end if - !>--- 3. distribute groups into subgroups basedon topology if (pr) then write (stdout,*) call smallhead('ANALYZING EQUIVALENCIES') end if call distsubgr(zmol,groups,subgroups,inc,pr) - !>--- 4. Equivalent atoms must be excluded in clustering to reduce noise if (pr) then write (stdout,*) call smallhead('DETERMINE ATOMS TO INCLUDE IN PCA') @@ -196,7 +173,6 @@ subroutine CCEGEN(env,pr,fname) write (stdout,*) 'Including more atoms ...' end if inc = 1 - !-- for this exclude the equivalent atoms from anmr_nucinfo directly do i = 1,groups%ng if (groups%grp(i)%nm > 1) then write (stdout,*) groups%grp(i)%mem @@ -207,11 +183,9 @@ subroutine CCEGEN(env,pr,fname) end if end do end if - !>-- exclude user set atoms if (env%pcaexclude) then call excludeSelected(zmol,inc,env%atlist) end if - !>-- exclude H atoms if (heavyonly) then call excludeLight(zmol,inc) end if @@ -223,7 +197,7 @@ subroutine CCEGEN(env,pr,fname) end do end if ntaken = sum(inc) - !>--- if we have too few, include the heav atoms at least + ! ── fallback: include all heavy atoms if too few were selected ────────────── if (ntaken <= 3) then do i = 1,zmol%nat if (zmol%at(i) /= 1) then @@ -236,7 +210,7 @@ subroutine CCEGEN(env,pr,fname) call zmol%deallocate - !>-- for very large ensemble files limit the clustering + ! ── for large ensembles, limit the number of structures considered ────────── if (autolimit) then if ((env%nclust /= 0).and.(env%nclust*100 < nall)) then dum = float(nall)*fraclimit @@ -249,7 +223,6 @@ subroutine CCEGEN(env,pr,fname) nallnew = nall end if - !>--- 5. Transfer the relevant atoms to a new array allocate (xyznew(3,ntaken,nallnew)) do i = 1,nallnew k = 0 @@ -265,7 +238,6 @@ subroutine CCEGEN(env,pr,fname) else !measuretype=='dihedral' !===================================================! - !-- for very large ensemble files limit the clustering if (autolimit) then if ((env%nclust /= 0).and.(env%nclust*100 < nall)) then dum = float(nall)*fraclimit @@ -290,10 +262,8 @@ subroutine CCEGEN(env,pr,fname) end if !==================================================! -!===================================================================================================! -! do the SVD to get the principal components -!===================================================================================================! - if (ntaken > 3) then !> all of this only makes sense if we have something to compare +! ── SVD: principal component analysis ──────────────────────────────────────────── + if (ntaken > 3) then !> requires at least 4 descriptors call ctimer%start(1,'PCA') if (pr) then write (stdout,*) @@ -301,14 +271,12 @@ subroutine CCEGEN(env,pr,fname) end if mm = nallnew select case (measuretype) - !==========================================================================! case ('cma','CMA','cmadist') if (pr) then write (stdout,'(1x,a)') 'Using CMA DISTANCES as descriptors:' end if - !>-- all structures should have been shifted to the CMA by CREGEN - !> therefore assume the CMA is at (0,0,0). - !> somewhat robust measure, but provides less information. + !>-- all structures should have been shifted to the CMA by CREGEN; + !> somewhat robust but provides less information than zmatrix mn = min(ntaken,mm) allocate (measure(mn,mm),pc(mn),pcvec(mm,mn)) do i = 1,mm @@ -319,13 +287,11 @@ subroutine CCEGEN(env,pr,fname) measure(j,i) = sqrt(measure(j,i)) end do end do - !==========================================================================! case ('cartesian','coords') if (pr) then write (stdout,'(1x,a)') 'Using CARTESIAN COORDINATES as descriptors:' end if - !>-- all Cartesian components of the selected atoms - !> REQUIRES PERFECT ALIGNMENT(!), hence not very robust + !>-- REQUIRES PERFECT ALIGNMENT; not robust for flexible molecules mn = min(ntaken*3,mm) allocate (measure(mn,mm),pc(mn),pcvec(mm,mn)) do i = 1,mm @@ -339,15 +305,14 @@ subroutine CCEGEN(env,pr,fname) if (l > mn) exit end do end do - !==========================================================================! case default !case( 'zmat','zmatrix' ) if (pr) then write (stdout,'(1x,a)') 'Using ZMATRIX as descriptors (sin/cos of dihedrals):' end if !>-- dihedral angles, sin/cos transformed for periodicity - l = ntaken-3 !>--- first three dihedral angles are zero - mn = min(mm,2*l) !>--- two descriptors per dihedral, no more than structures - if (mn < 2) then !> we need at least 1 dihedral angle (2 descriptors) + l = ntaken-3 !>-- first three dihedral angles are zero by convention + mn = min(mm,2*l) !>-- two descriptors per dihedral, capped at structure count + if (mn < 2) then !>-- need at least one dihedral angle (two descriptors) if (pr) then write (stdout,*) "Not enough descriptors for PCA!" return @@ -368,9 +333,8 @@ subroutine CCEGEN(env,pr,fname) end do end do deallocate (nc,nb,na,geo) - !=========================================================================! case ('dihedral') - mn = min(mm,2*ntaken) !>--- two descriptors per dihedral (sin/cos) + mn = min(mm,2*ntaken) allocate (measure(mn,mm),diedr(ndied)) if (pr) then write (stdout,'(1x,a)') 'Using DIHEDRAL ANGLES as descriptors (sin/cos transformed):' @@ -389,17 +353,13 @@ subroutine CCEGEN(env,pr,fname) if (allocated(diedat)) deallocate (diedat) if (allocated(diedr)) deallocate (diedr) allocate (pc(mn),pcvec(mm,mn)) - !=====================================================! end select - !=====================================================! if (pr) then write (stdout,*) write (stdout,'(1x,a,i0,a,i0,a)') 'Performing SVD for ', & & mm,' structures and ',mn,' props' end if - !>--- do the SVD ! MM must not be smaller than MN ! - call SVD_to_PC(measure,mm,mn,pc,pcvec,.false.) -!=========================================================================================! + call SVD_to_PC(measure,mm,mn,pc,pcvec,.false.) !> MM >= MN required call ctimer%stop(1) else write (stdout,*) 'There are not enough descriptors for a PCA!' @@ -411,15 +371,14 @@ subroutine CCEGEN(env,pr,fname) close (ich) return end if -!========================================================================================! + if (allocated(measure)) deallocate (measure) if (allocated(xyznew)) deallocate (xyznew) if (allocated(inc)) deallocate (inc) - !>--- normalize PC eigenvalues + ! ── normalize eigenvalues and select contributing PCs ────────────────────────── pcsum = sum(pc) pc = pc/pcsum - !>--- get the contributing principal components pcsum = 0.0d0 npc = 0 do i = 1,mn @@ -428,7 +387,6 @@ subroutine CCEGEN(env,pr,fname) npc = npc+1 if (pcsum .ge. pcthr) exit end do - !npc = max(npc,2) !>-- at least 2 principal components should be used npc = min(npc,pccap) pcsum = 0.0d0 do i = 1,npc @@ -447,24 +405,19 @@ subroutine CCEGEN(env,pr,fname) write (stdout,*) mn,'principal component eigenvalues (normalized)' write (stdout,*) pc - !call PRMAT(6,pc,mn,1,'Principal components (eigenvalues)') write (stdout,*) write (stdout,'(1x,a,i0,a,f6.2,a)') 'The first ',npc,' components account for a total of ',100.d0*pcsum,'% of the' write (stdout,'(1x,a)') 'ensembles unique structural features and are used for the clustering' end if - !>--- use some less memory and rearrange the eigenvectors (COLUMNS AND ROWS ARE SWAPPED) - !> untaken PCs are not considered further + !>-- rearrange eigenvectors: drop unused PCs and swap to (npc,mm) layout allocate (pcdum(npc,mm)) do i = 1,mm pcdum(1:npc,i) = pcvec(i,1:npc) end do - call move_alloc(pcdum,pcvec) !>THIS CHANGES THE SHAPE OF pcvec (COLUMNS AND ROWS ARE SWAPPED) - -!=========================================================! -! do the Clustering -!=========================================================! + call move_alloc(pcdum,pcvec) !> pcvec shape changes from (mm,mn) to (npc,mm) +! ── k-means clustering ─────────────────────────────────────────────────────────── if (pr) then write (stdout,*) call smallhead('CLUSTERING ANALYSIS OF PRINCIPAL COMPONENTS') @@ -472,8 +425,7 @@ subroutine CCEGEN(env,pr,fname) allocate (member(mm),source=0) - !>--- get Euclidean distances (packed matrix) between all structures - !> ndist = (mm*(mm+1))/2 ! overflows for large ensembles + !>-- packed distance matrix; split to avoid integer overflow for large mm ndist = mm ndist = ndist*(mm+1) ndist = ndist/2 @@ -495,12 +447,6 @@ subroutine CCEGEN(env,pr,fname) !$OMP END PARALLEL end do - !>-- NOTE - !>-- different clustering algorithms exist, but what is common - !>-- among them is, that no optimal number of clusters is known - !>-- at the beginning. The lower bound for the number of - !>-- clusters is the number of investigated PCs, the upper - !>-- bound is the number of structures if (pr) then select case (clusteralgo) case ('means','kmeans') @@ -517,22 +463,17 @@ subroutine CCEGEN(env,pr,fname) write (stdout,'(1x,a8,4x,a14,4x,a14,4x,a14)') '------','-------------','-------------','-------------' end if -!-----------------------------------------------------------------------! -! Cluster evaluation settings -!-----------------------------------------------------------------------! +! ── cluster evaluation settings ────────────────────────────────────────────────── if (env%maxcluster == 0) then - !nclustmax=100 !some random default value - call clustleveval(env,nclustmax,csthr,SSRSSTthr,pcthr) ! defaults + call clustleveval(env,nclustmax,csthr,SSRSSTthr,pcthr) nclustmax = min(mm,nclustmax) - !SSRSSTthr=0.90 !exit if this value is reached for SSR/SST else - nclustmax = max(2,env%maxcluster) !no less than 2 clusters - nclustmax = min(mm,env%maxcluster) !there cannot be more clustes than structures. + nclustmax = max(2,env%maxcluster) + nclustmax = min(mm,env%maxcluster) end if if (env%nclust == 0) then nclustmin = 1 else - !>-- predefined number of clusters nclust = min(mm,env%nclust) nclustmin = nclust nclustmax = nclust @@ -542,9 +483,7 @@ subroutine CCEGEN(env,pr,fname) allocate (clust_sizes(nclustmax),source=0) CLUSTERSIZES: do nclustiter = nclustmin,nclustmax - !>-- regular case: test continuous cluster sizes nclust = nclustiter - !>-- special case: test cluster sizes incrementally (good for large ensembles) if (env%clustlev >= 10) then dum = float(mm)/float(nclustmax) dum2 = dum*float(nclustiter) @@ -588,12 +527,12 @@ subroutine CCEGEN(env,pr,fname) write (stdout,'(1x,a)') 'Higher SSR/SST vaules indicate more distinct clusters.' write (stdout,'(1x,a)') 'Analyzing statistical values ...' end if - k = min(nclustiter,nclustmax) !> last completed iteration index + k = min(nclustiter,nclustmax) !> last completed iteration index allocate (extrema(2,k)) call ctimer%start(3,'statistics') call statanal(k,nclustmax,statistics,extrema,pr,clust_sizes) if (pr) call statwarning(fname) - !>-- determine a suggested cluster size (smallest suggested cluster with good SSR/SST) + ! ── pick smallest cluster count with adequate SSR/SST ────────────────────── do i = 2,k if ((extrema(1,i).or.extrema(2,i)).and.(statistics(3,i) > csthr)) then nclust = clust_sizes(i) @@ -606,7 +545,6 @@ subroutine CCEGEN(env,pr,fname) write (stdout,*) write (stdout,'(1x,a,f4.2,a,i0)') 'Suggested (SSR/SST >',csthr,') cluster count: ',nclust end if - !>-- calculate the determined partition into clusters again for final file allocate (centroid(npc,nclust),source=0.0_ap) select case (clusteralgo) case ('means','kmeans') @@ -623,13 +561,10 @@ subroutine CCEGEN(env,pr,fname) deallocate (statistics,clust_sizes) deallocate (q,p,dist) - !>-- finally, assign a representative structure to each group (based on lowest energy) - !>-- and write the new ensemble file call PCA_grpwrite(nclust,npc,mm,pcvec,member) - !ncb=maxval(member,1) !--total number of cluster ncb = nclust - ancb = ncb !>--actual number of clusters + ancb = ncb if (ancb .le. 1) return @@ -641,7 +576,6 @@ subroutine CCEGEN(env,pr,fname) end if allocate (eclust(ncb),source=0.0d0) allocate (clustbest(ncb),ind(ncb),source=0) - !>--- initialize eclust and clustbest iiincb: do i = 1,ncb do j = 1,mm if (member(j) == i) then @@ -651,7 +585,6 @@ subroutine CCEGEN(env,pr,fname) end if end do end do iiincb - !>--- then, look for the lowest energy do i = 1,ncb ind(i) = i c = 0 @@ -664,9 +597,8 @@ subroutine CCEGEN(env,pr,fname) end if end if end do - !>-- if there are clusters without structures if (c == 0) then - clustbest(i) = -1 + clustbest(i) = -1 !> empty cluster, excluded from output ancb = ancb-1 end if end do @@ -697,688 +629,8 @@ subroutine CCEGEN(env,pr,fname) if (pr) then write (stdout,*) - !write(*,'(1x,a)') 'Timings:' - !call eval_sub_timer(ctimer) call ctimer%write(stdout,'PCA/k-Means clustering') end if call ctimer%clear() return end subroutine CCEGEN - -!=======================================================================================! -! set clustering level defaults -!=======================================================================================! -subroutine clustleveval(env,maxclust,csthr,SSRSSTthr,pcthr) - !********************************************************* - !* Set clustering level defaults for maxclust, csthr, * - !* SSRSSTthr, and pcthr based on the clustering level. * - !********************************************************* - use crest_parameters,idp => dp - use crest_data - implicit none - type(systemdata) :: env ! MAIN STORAGE OS SYSTEM DATA - integer :: clev - integer :: maxclust - real(wp) :: csthr - real(wp) :: SSRSSTthr - real(wp) :: pcthr - - SSRSSTthr = 0.90 !exit if this value is reached for SSR/SST - - clev = env%clustlev - if (env%clustlev >= 10) then !for incremental modes - clev = env%clustlev-10 - end if - - select case (clev) - case (-1) !-- loose - maxclust = 25 - csthr = 0.80d0 - pcthr = 0.80d0 - case (1) !-- tight - maxclust = 400 - if (env%clustlev >= 10) maxclust = 50 - csthr = 0.85d0 - pcthr = 0.90d0 - case (2) !-- vtight - maxclust = 400 - if (env%clustlev >= 10) maxclust = 100 - csthr = 0.9d0 - pcthr = 0.95d0 - SSRSSTthr = 0.92d0 - case default !-- normal - maxclust = 100 - if (env%clustlev >= 10) maxclust = 25 - csthr = 0.80d0 - pcthr = 0.85d0 - end select - - return -end subroutine clustleveval - -!=======================================================================================! -! write a file with the 2 most contributing principal components of each structure -! and the cluster to which the structure belongs -!=======================================================================================! -subroutine PCA_grpwrite(nclust,npc,mm,pcvec,member) - use crest_parameters,idp => dp - implicit none - integer,intent(in) :: nclust ! number of required centroids - integer,intent(in) :: npc,mm - real(wp),intent(in) :: pcvec(npc,mm) - integer,intent(in) :: member(mm) ! membership for each structure - integer :: ich,i - open (newunit=ich,file='cluster.order') - write (ich,'(4x,i0,4x,i0,4x,i0)') mm,nclust,npc - if (npc > 1) then - do i = 1,mm - write (ich,'(i8,1x,f16.8,1x,f16.8,1x,i8)') i,pcvec(1,i),pcvec(2,i),member(i) - end do - else - do i = 1,mm - write (ich,'(i8,1x,f16.8,1x,i8)') i,pcvec(1,i),member(i) - end do - end if - close (ich) - return -end subroutine PCA_grpwrite - -!=======================================================================================! -! Exclude light - exclude H atoms in the inc array -!=======================================================================================! -subroutine excludeLight(zmol,inc) - use crest_parameters,idp => dp - use zdata - implicit none - type(zmolecule) :: zmol - integer :: inc(zmol%nat) - integer :: i - do i = 1,zmol%nat - if (zmol%at(i) == 1) then - inc(i) = 0 - end if - end do - return -end subroutine excludeLight - -!=======================================================================================! -! Exclude Specified Atoms -!=======================================================================================! -subroutine excludeSelected(zmol,inc,atlist) - use crest_parameters,idp => dp - use zdata - implicit none - type(zmolecule) :: zmol - integer :: inc(zmol%nat) - character(len=*) :: atlist !a string containing atom numbers, needs parsing - integer :: i,ncon - integer,allocatable :: inc2(:) - allocate (inc2(zmol%nat),source=0) - call parse_atlist_new(atlist,ncon,zmol%nat,zmol%at,inc2) - do i = 1,zmol%nat - if (inc2(i) == 1) inc(i) = 0 - end do - deallocate (inc2) - return -end subroutine excludeSelected - -!=======================================================================================! -! Perform a single value decomposition (SVD) and get the principal components -! -! X = U*sig*V^(T) -! -! The eigenvalues saved in sig are the principal components -! The SVD only works if M >= N -! -!=======================================================================================! -subroutine svd_to_pc(measure,m,n,sig,U,pr) - use crest_parameters,idp => dp - implicit none - integer :: n,m - real(wp) :: measure(n,m) - real(wp) :: sig(n) - real(wp) :: U(m,n) - integer :: i,j,info,lwork - real(wp),allocatable :: mean(:),tmp(:) - integer,allocatable :: ind(:) - real(wp),allocatable :: X(:,:),V(:,:),work(:) - integer,allocatable :: iwork(:) - logical :: pr - if (pr) then - write (stdout,*) m,' mesaurements' - write (stdout,*) n,' props' - end if - allocate (mean(n),ind(m),tmp(m)) - lwork = max(2*M+N,6*N+2*N*N) - allocate (X(m,n),V(n,n),iwork(m+3*n),work(lwork)) - mean = 0.0d0 - do i = 1,m - do j = 1,n - mean(j) = mean(j)+measure(j,i) - end do - end do - mean = mean/float(m) - if (pr) write (stdout,*) mean - do i = 1,m - do j = 1,n - X(i,j) = (mean(j)-measure(j,i)) - end do - end do - if (pr) then - call PRMAT(6,X,m,n,'X') - end if -!>--- LAPACKs' DGEJSV - call DGEJSV('C','U','V','N','N','N', & - & m,n,X,m,sig,U,m,V,n, & - & WORK,LWORK,IWORK,INFO) - if (pr) then - write (stdout,*) info - write (stdout,*) sig - call PRMAT(6,U**2,M,N,'U') - call PRMAT(6,V,N,N,'V') - end if - deallocate (work,iwork,V,X,tmp,ind,mean) - return -end subroutine svd_to_pc - -!======================================================================! -! calculate the Euclidian distance between two points p and q -!======================================================================! -function eucdist(ndim,p,q) result(dist) - use crest_parameters,idp => dp - implicit none - real(ap) :: dist - integer :: ndim - real(ap) :: p(ndim) - real(ap) :: q(ndim) - integer :: i - dist = 0.0d0 - do i = 1,ndim - dist = dist+(q(i)-p(i))**2 - end do - dist = sqrt(dist) - return -end function eucdist - -!======================================================================! -! K-means clustering algorithm -! -! determine a position of cluster centroids iteratively for a given -! number of centroids. -! -!======================================================================! -subroutine kmeans(nclust,npc,mm,centroid,pcvec,ndist,dist,member) - use crest_parameters,idp => dp - implicit none - integer,intent(in) :: nclust ! number of required centroids - integer,intent(in) :: npc,mm - real(wp),intent(in) :: pcvec(npc,mm) - integer(idp),intent(in) :: ndist - real(sp),intent(in) :: dist(ndist) - integer,intent(inout) :: member(mm) ! membership for each structure - real(ap),intent(inout):: centroid(npc,nclust) - integer,allocatable :: refmember(:) - integer :: iter - integer,parameter :: maxiter = 300 - - if (nclust .le. 1) return !no singular clusters! - - allocate (refmember(mm),source=0) - - !>-- determine seeds for the centroids (i.e., initial positions) - call kmeans_seeds(nclust,npc,mm,centroid,pcvec,ndist,dist) - - do iter = 1,maxiter - !>-- determine cluster membership for all structures - !> (by shortest Euc. distance to the respective centroid) - member = 0 !reset - call kmeans_assign(nclust,npc,mm,centroid,pcvec,member) - - !>-- check if memberships changed w.r.t. previous memberships - if (all(member == refmember)) then - exit - else - refmember = member - end if - !>-- update centroids if necessary - call kmeans_recenter(nclust,npc,mm,centroid,pcvec,member) - end do - - deallocate (refmember) - return -end subroutine kmeans -!===================================================================! -! determine cluster seeds for the K-means algo -!===================================================================! -subroutine kmeans_seeds(nclust,npc,mm,centroid,pcvec,ndist,dist) - use crest_parameters,idp => dp - use utilities - implicit none - integer :: nclust,npc,mm - real(ap) :: centroid(npc,nclust) - real(wp) :: pcvec(npc,mm) - integer(idp) :: ndist - real(sp) :: dist(ndist) - real(sp) :: ddum - integer(idp) :: k,kiter - integer :: i,j,l,c - real(wp) :: distsum,maxdistsum - real(ap) :: eucdist !this is a function - real(ap),allocatable :: p(:),q(:) - integer,allocatable :: taken(:) - - !>--- first two centroids are located at the most apart points - !> in the PC space - ddum = 0.0_sp - do kiter = 1,ndist - if (dist(kiter) > ddum) then - ddum = dist(kiter) - k = kiter - end if - end do - call revlin(k,j,i) !> reverse of the lin function, get indices i and j - - centroid(1:npc,1) = pcvec(1:npc,i) - centroid(1:npc,2) = pcvec(1:npc,j) - - if (nclust .le. 2) return !>-- if we only need two centroids, return - - !>-- If more centroids are needed, search for one point which has the maximal sum of - !>-- the distances between the already determined centroids and itself. - allocate (p(npc),q(npc),taken(nclust)) - taken = 0 - taken(1) = i - taken(2) = j - do i = 3,nclust - maxdistsum = 0.0d0 - c = 0 -!$OMP PARALLEL PRIVATE ( l, q, p, j, distsum ) & -!$OMP SHARED ( i, centroid, npc, mm, maxdistsum, pcvec, c, taken ) -!$OMP DO - do j = 1,mm - distsum = 0.0d0 - p(1:npc) = pcvec(1:npc,j) - do l = 1,i-1 - q(1:npc) = centroid(1:npc,l) - distsum = distsum+eucdist(npc,p,q) - end do - !$OMP CRITICAL - if (distsum .gt. maxdistsum) then - if (.not.any(taken == j)) then - maxdistsum = distsum - c = j - taken(i) = c - end if - end if - !$OMP END CRITICAL - end do -!$OMP END DO -!$OMP END PARALLEL - if (c == 0) then - exit - else - centroid(1:npc,i) = pcvec(1:npc,c) - end if - end do - - deallocate (taken,q,p) - - return -end subroutine kmeans_seeds -!===================================================================! -! assign structures as members to a centroid -!===================================================================! -subroutine kmeans_assign(nclust,npc,mm,centroid,pcvec,member) - use crest_parameters,idp => dp - implicit none - integer :: nclust,npc,mm - real(ap) :: centroid(npc,nclust) - real(wp) :: pcvec(npc,mm) - integer :: member(mm) - real(ap) :: eucdist !this is a function - integer :: i,j,c - real(ap),allocatable :: centdist(:) - real(ap),allocatable :: p(:),q(:) - - allocate (centdist(nclust),source=0.0_ap) - allocate (p(npc),q(npc)) -!$OMP PARALLEL PRIVATE ( i, j, p, q, c, centdist ) & -!$OMP SHARED ( mm, nclust, member, centroid, npc, pcvec ) -!$OMP DO - do i = 1,mm - p(1:npc) = pcvec(1:npc,i) - do j = 1,nclust - q(1:npc) = centroid(1:npc,j) - centdist(j) = eucdist(npc,p,q) - end do - c = minloc(centdist,1) - member(i) = c - end do -!$OMP END DO -!$OMP END PARALLEL - deallocate (q,p) - deallocate (centdist) - return -end subroutine kmeans_assign - -!===================================================================! -! re-center centroids for given (sorted) structures -!===================================================================! -subroutine kmeans_recenter(nclust,npc,mm,centroid,pcvec,member) - use crest_parameters,idp => dp - implicit none - integer :: nclust,npc,mm - real(ap) :: centroid(npc,nclust) - real(wp) :: pcvec(npc,mm) - integer :: member(mm) - integer :: i,j,c - real(ap),allocatable :: p(:),q(:) - - allocate (p(npc),q(npc)) - do i = 1,nclust - c = 0 - p = 0.0d0 - do j = 1,mm - if (member(j) == i) then - c = c+1 - p(1:npc) = p(1:npc)+pcvec(1:npc,j) - end if - end do - if (c > 0) then - p = p/float(c) - centroid(1:npc,i) = p(1:npc) - else - p = 999.9d0 - end if - end do - deallocate (q,p) - - return -end subroutine kmeans_recenter - -!======================================================================! -! calculate statistical values for the given cluster size -! Values to compute: -! DBI - the Davies-Bouldin index -! pSF - the "pseudo-F statistic" -! SSR/SST ratio -!======================================================================! -subroutine cluststat(nclust,npc,mm,centroid,pcvec,member,DBI,pSF,SSRSST) - use crest_parameters,idp => dp - implicit none - integer,intent(in) :: nclust ! number of required centroids - integer,intent(in) :: npc,mm - real(wp),intent(in) :: pcvec(npc,mm) - integer,intent(in) :: member(mm) ! membership for each structure - real(ap),intent(in):: centroid(npc,nclust) - real(wp),intent(out) :: DBI,pSF,SSRSST - real(wp) :: SSE,SSR,SST - real(ap),allocatable :: p(:),q(:) - real(wp),allocatable :: compact(:) - real(wp),allocatable :: DBmat(:,:) - real(ap) :: eucdist !this is a function - real(wp) :: d,Rij,maxDB,weight - integer :: i,c,k,c2 - - DBI = 0.0d0 - pSF = 0.0d0 - SSRSST = 0.0d0 - - if (nclust < 2) return - - allocate (p(npc),q(npc)) - - !>-- Sum of squares error - SSE = 0.0d0 - do c = 1,nclust - p(1:npc) = centroid(1:npc,c) - do i = 1,mm - if (member(i) == c) then - q(1:npc) = pcvec(1:npc,i) - d = eucdist(npc,p,q) - SSE = SSE+d**2 - end if - end do - end do - SSE = SSE - - !>-- Total sum of squares - SST = 0.0d0 - p = 0.0d0 - do c = 1,nclust - weight = real(count(member(:) == c,1),wp)/real(mm,wp) - p(1:npc) = p(1:npc)+centroid(1:npc,c)*weight - end do - !p = p/float(nclust) - do i = 1,mm - q(1:npc) = pcvec(1:npc,i) - d = eucdist(npc,p,q) - SST = SST+d**2 - end do - SST = SST - - !>-- Sum of squares regression - SSR = SST-SSE - - !>-- SSR/SST ratio - SSRSST = SSR/SST - - !>-- pseudo-F statistic - if (nclust > 1) then - pSF = (SSR/(float(nclust)-1.0d0)) - if (mm == nclust) then - pSF = 0.0d0 - else - pSF = pSF/(SSE/(float(mm)-float(nclust))) - end if - else - pSF = 0.0d0 - end if - - !>-- Davies-Bouldin index (DBI) - allocate (compact(nclust),source=0.0d0) !cluster compactness - do c = 1,nclust - p(1:npc) = centroid(1:npc,c) - k = 0 - do i = 1,mm - if (member(i) == c) then - k = k+1 - q(1:npc) = pcvec(1:npc,i) - d = eucdist(npc,p,q) - compact(c) = compact(c)+d - end if - end do - if (k > 0) then - compact(c) = compact(c)/float(k) - else - compact(c) = 0 - end if - end do - allocate (DBmat(nclust,nclust),source=0.0d0) - do c = 1,nclust - p(1:npc) = centroid(1:npc,c) - do c2 = 1,nclust - if (c2 == c) cycle - q(1:npc) = centroid(1:npc,c2) - d = eucdist(npc,p,q) - Rij = (compact(c)+compact(c2))/d - DBmat(c,c2) = Rij - end do - end do - do c = 1,nclust - maxDB = maxval(DBmat(:,c),1) - DBI = DBI+maxDB - end do - DBI = DBI/float(nclust) - deallocate (DBmat) - deallocate (compact) - - deallocate (q,p) - return -end subroutine cluststat - -!==============================================================! -! analyze the statistical values DBI and pSF to get the -! respective extrema -!==============================================================! -subroutine statanal(n,nmax,statistics,extrema,pr,clust_sizes) - use crest_parameters - implicit none - integer :: n,nmax - real(wp) :: statistics(3,nmax) - logical,intent(inout) :: extrema(2,n) - logical :: pr - integer,intent(in),optional :: clust_sizes(n) - real(wp) :: last,next,current - integer :: i,csize - - extrema = .false. -!>--- identify local extrema of the DBI and pSF - do i = 2,n-1 - !>-- DBI - last = statistics(1,i-1) - next = statistics(1,i+1) - current = statistics(1,i) - if ((current < last).and.(current < next)) then - extrema(1,i) = .true. - end if - !>-- pSF - last = statistics(2,i-1) - next = statistics(2,i+1) - current = statistics(2,i) - if ((current > last).and.(current > next)) then - extrema(2,i) = .true. - end if - end do - !>--- boundary check: last cluster count (one-sided comparison) - if (n >= 2) then - if (statistics(1,n) < statistics(1,n-1)) extrema(1,n) = .true. - if (statistics(2,n) > statistics(2,n-1)) extrema(2,n) = .true. - end if - - if (pr) then - write (stdout,*) - write (stdout,'(1x,a,/)') 'Suggestions for cluster sizes:' - do i = 1,n - if (extrema(1,i).or.extrema(2,i)) then - csize = i - if (present(clust_sizes)) csize = clust_sizes(i) - if (extrema(1,i).and.extrema(2,i)) then - write (stdout,'(1x,i8,''*'',3x,a,f8.4)') csize,'SSR/SST',statistics(3,i) - else - write (stdout,'(1x,i8,4x,a,f8.4)') csize,'SSR/SST',statistics(3,i) - end if - end if - end do - write (stdout,'(/,1x,a)') 'Cluster counts marked with a star (*) are reasonable' - write (stdout,'(1x,a)') 'suggestions according to BOTH the DBI and pSF.' - end if - - return -end subroutine statanal - -!==============================================================! -! print a warning regarding the nature of the cluster partitioning -!==============================================================! -subroutine statwarning(fname) - use crest_parameters - implicit none - character(len=*) :: fname - write (stdout,*) - write (stdout,'(1x,a)') '!---------------------------- NOTE ----------------------------!' - write (stdout,'(2x,a)') 'The partitioning of data (the ensemble) into clusters' - write (stdout,'(2x,a)') 'of similar characteristics (structures) is ARBITRARY' - write (stdout,'(2x,a)') 'and depends on many criteria (e.g. choice of PCs).' - write (stdout,'(2x,a)') 'The selected cluster count is the smallest reasonable' - write (stdout,'(2x,a)') 'number of clusters that can be formed according to' - write (stdout,'(2x,a)') 'the DBI and pSF values for the given data.' - write (stdout,*) - write (stdout,'(2x,a)') 'If other cluster sizes are desired, rerun CREST with' - write (stdout,'(2x,3a)') '"crest --sort ',trim(fname),' --cluster "' - write (stdout,*) - write (stdout,'(2x,a)') 'Other default evaluation settings can be chosen with the' - write (stdout,'(2x,a)') 'keywords "loose","normal", and "tight" as via' - write (stdout,'(2x,3a)') '"crest --sort ',trim(fname),' --cluster "' - write (stdout,'(1x,a)') '!--------------------------------------------------------------!' -end subroutine statwarning - -!====================================================================! -subroutine getdiederatoms(zmol,nat,inc,nb,diedat,ndied) - use crest_parameters,idp => dp - use zdata - use strucrd - implicit none - type(zmolecule) :: zmol - integer :: nat - integer :: inc(nat) !contains 1 (=include) or 0 (=ignore) - integer :: nb - integer :: diedat(4,nb) - integer,intent(out) :: ndied - integer :: a,b,c,d - integer :: i,j,k - - ndied = 0 - do i = 1,nb - a = zmol%bondpairs(1,i) - b = zmol%bondpairs(2,i) - if (inc(a) == 0) cycle !ignored by user? - if (inc(b) == 0) cycle !ignored by user? - if (zmol%zat(a)%nei == 1) cycle !terminal atom? - if (zmol%zat(b)%nei == 1) cycle !terminal atom? - if (zmol%methyl(a)) cycle !methyl C? - if (zmol%methyl(b)) cycle !methyl C? - !>-- passed all checks, so let's get atoms - !>-- a neighbour for a - do j = 1,zmol%zat(a)%nei - c = zmol%zat(a)%ngh(j) - if (c == b) then - cycle - else - exit - end if - end do - !>-- a neighbour for b - do k = 1,zmol%zat(b)%nei - d = zmol%zat(b)%ngh(k) - if (d == a) then - cycle - else - exit - end if - end do - ndied = ndied+1 - !>the bond is between a and b - !>c is a neighbour of a, d is a neighbour of b - diedat(2,ndied) = a - diedat(3,ndied) = b - diedat(1,ndied) = c - diedat(4,ndied) = d - end do - - return -end subroutine getdiederatoms - -subroutine calc_dieders(mol,ndied,diedat,diedr) - !***************************************************** - !* Calculate dihedral angles for selected atom * - !* quartets. Results are in radians (-pi, pi). * - !***************************************************** - use crest_parameters,idp => dp - use strucrd - implicit none - type(coord),intent(in) :: mol - integer,intent(in) :: ndied - integer,intent(in) :: diedat(4,ndied) - real(wp),intent(out) :: diedr(ndied) - integer :: i - - diedr = 0.0_wp - do i = 1,ndied - !> diedat: (1)=neighbour of a, (2)=a, (3)=b, (4)=neighbour of b - diedr(i) = mol%dihedral(diedat(1,i),diedat(2,i), & - & diedat(3,i),diedat(4,i)) - end do - - return -end subroutine calc_dieders - diff --git a/src/sorting/ccegen_interface.f90 b/src/sorting/ccegen_interface.f90 new file mode 100644 index 00000000..e5452073 --- /dev/null +++ b/src/sorting/ccegen_interface.f90 @@ -0,0 +1,35 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2020 Philipp Pracht, Stefan Grimme +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +module ccegen_interface +!********************************************************** +!* module to load an interface to the CCEGEN routine. * +!********************************************************** + implicit none + interface + subroutine CCEGEN(env,pr,fname) + use crest_parameters + use crest_data + implicit none + type(systemdata),intent(inout) :: env + logical,intent(in) :: pr + character(len=*),intent(in) :: fname + end subroutine CCEGEN + end interface +end module ccegen_interface diff --git a/src/sorting/ccegen_utils.f90 b/src/sorting/ccegen_utils.f90 new file mode 100644 index 00000000..4c0dc6cd --- /dev/null +++ b/src/sorting/ccegen_utils.f90 @@ -0,0 +1,703 @@ +!================================================================================! +! This file is part of crest. +! +! Copyright (C) 2020 Philipp Pracht, Stefan Grimme +! +! crest is free software: you can redistribute it and/or modify it under +! the terms of the GNU Lesser General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! crest is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with crest. If not, see . +!================================================================================! + +!> Internal utility routines for CCEGEN (PCA/k-means clustering of conformer ensembles) +! +module ccegen_utils +!************************************************************* +!* Internal utilities for the CCEGEN routine. * +!* Contains PCA helpers, k-means clustering routines, * +!* and statistical evaluation procedures. * +!************************************************************* + implicit none + private + + public :: clustleveval,PCA_grpwrite,excludeLight,excludeSelected,svd_to_pc, & + & eucdist,kmeans,kmeans_seeds,kmeans_assign,kmeans_recenter, & + & cluststat,statanal,statwarning,getdiederatoms,calc_dieders + +! ══════════════════════════════════════════════════════════════════════════════ +contains !> MODULE PROCEDURES START HERE +! ══════════════════════════════════════════════════════════════════════════════ + +subroutine clustleveval(env,maxclust,csthr,SSRSSTthr,pcthr) + !********************************************************* + !* Set clustering level defaults for maxclust, csthr, * + !* SSRSSTthr, and pcthr based on the clustering level. * + !********************************************************* + use crest_parameters,idp => dp + use crest_data + implicit none + type(systemdata) :: env + integer :: clev + integer :: maxclust + real(wp) :: csthr + real(wp) :: SSRSSTthr + real(wp) :: pcthr + + SSRSSTthr = 0.90d0 + + clev = env%clustlev + if (env%clustlev >= 10) then !> incremental clustering mode + clev = env%clustlev-10 + end if + + select case (clev) + case (-1) !-- loose + maxclust = 25 + csthr = 0.80d0 + pcthr = 0.80d0 + case (1) !-- tight + maxclust = 400 + if (env%clustlev >= 10) maxclust = 50 + csthr = 0.85d0 + pcthr = 0.90d0 + case (2) !-- vtight + maxclust = 400 + if (env%clustlev >= 10) maxclust = 100 + csthr = 0.9d0 + pcthr = 0.95d0 + SSRSSTthr = 0.92d0 + case default !-- normal + maxclust = 100 + if (env%clustlev >= 10) maxclust = 25 + csthr = 0.80d0 + pcthr = 0.85d0 + end select + + return +end subroutine clustleveval + +subroutine PCA_grpwrite(nclust,npc,mm,pcvec,member) + !************************************************************* + !* Write the first two principal component projections and * + !* cluster membership for each structure to cluster.order. * + !************************************************************* + use crest_parameters,idp => dp + implicit none + integer,intent(in) :: nclust + integer,intent(in) :: npc,mm + real(wp),intent(in) :: pcvec(npc,mm) + integer,intent(in) :: member(mm) + integer :: ich,i + open (newunit=ich,file='cluster.order') + write (ich,'(4x,i0,4x,i0,4x,i0)') mm,nclust,npc + if (npc > 1) then + do i = 1,mm + write (ich,'(i8,1x,f16.8,1x,f16.8,1x,i8)') i,pcvec(1,i),pcvec(2,i),member(i) + end do + else + do i = 1,mm + write (ich,'(i8,1x,f16.8,1x,i8)') i,pcvec(1,i),member(i) + end do + end if + close (ich) + return +end subroutine PCA_grpwrite + +subroutine excludeLight(zmol,inc) + !******************************************* + !* Zero out hydrogen atoms in the inc * + !* array to exclude them from the PCA. * + !******************************************* + use crest_parameters,idp => dp + use zdata + implicit none + type(zmolecule) :: zmol + integer :: inc(zmol%nat) + integer :: i + do i = 1,zmol%nat + if (zmol%at(i) == 1) then + inc(i) = 0 + end if + end do + return +end subroutine excludeLight + +subroutine excludeSelected(zmol,inc,atlist) + !******************************************* + !* Zero out user-specified atoms in inc * + !* to exclude them from the PCA. * + !******************************************* + use crest_parameters,idp => dp + use zdata + implicit none + type(zmolecule) :: zmol + integer :: inc(zmol%nat) + character(len=*) :: atlist + integer :: i,ncon + integer,allocatable :: inc2(:) + allocate (inc2(zmol%nat),source=0) + call parse_atlist_new(atlist,ncon,zmol%nat,zmol%at,inc2) + do i = 1,zmol%nat + if (inc2(i) == 1) inc(i) = 0 + end do + deallocate (inc2) + return +end subroutine excludeSelected + +subroutine svd_to_pc(measure,m,n,sig,U,pr) + !************************************************************* + !* Singular value decomposition via LAPACK DGEJSV. * + !* Factorises X = U * diag(sig) * V^T after mean-centering. * + !* The singular values (sig) are the principal components. * + !* Requires M >= N. * + !* * + !* Input: measure(n,m) - descriptor matrix * + !* Output: sig(n) - singular values (eigenvalues) * + !* U(m,n) - left singular vectors * + !************************************************************* + use crest_parameters,idp => dp + implicit none + integer :: n,m + real(wp) :: measure(n,m) + real(wp) :: sig(n) + real(wp) :: U(m,n) + integer :: i,j,info,lwork + real(wp),allocatable :: mean(:),tmp(:) + integer,allocatable :: ind(:) + real(wp),allocatable :: X(:,:),V(:,:),work(:) + integer,allocatable :: iwork(:) + logical :: pr + if (pr) then + write (stdout,*) m,' mesaurements' + write (stdout,*) n,' props' + end if + allocate (mean(n),ind(m),tmp(m)) + lwork = max(2*M+N,6*N+2*N*N) + allocate (X(m,n),V(n,n),iwork(m+3*n),work(lwork)) + mean = 0.0d0 + do i = 1,m + do j = 1,n + mean(j) = mean(j)+measure(j,i) + end do + end do + mean = mean/float(m) + if (pr) write (stdout,*) mean + do i = 1,m + do j = 1,n + X(i,j) = (mean(j)-measure(j,i)) + end do + end do + if (pr) then + call PRMAT(6,X,m,n,'X') + end if +! ── LAPACKs' DGEJSV ────────────────────────────────────────────────────────── + call DGEJSV('C','U','V','N','N','N', & + & m,n,X,m,sig,U,m,V,n, & + & WORK,LWORK,IWORK,INFO) + if (pr) then + write (stdout,*) info + write (stdout,*) sig + call PRMAT(6,U**2,M,N,'U') + call PRMAT(6,V,N,N,'V') + end if + deallocate (work,iwork,V,X,tmp,ind,mean) + return +end subroutine svd_to_pc + +function eucdist(ndim,p,q) result(dist) + !******************************************* + !* Euclidean distance between points p * + !* and q in ndim-dimensional space. * + !******************************************* + use crest_parameters,idp => dp + implicit none + real(ap) :: dist + integer :: ndim + real(ap) :: p(ndim) + real(ap) :: q(ndim) + integer :: i + dist = 0.0d0 + do i = 1,ndim + dist = dist+(q(i)-p(i))**2 + end do + dist = sqrt(dist) + return +end function eucdist + +subroutine kmeans(nclust,npc,mm,centroid,pcvec,ndist,dist,member) + !************************************************************* + !* K-means clustering: iteratively assigns structures to the * + !* nearest centroid and recenters until convergence or * + !* maxiter iterations are reached. * + !************************************************************* + use crest_parameters,idp => dp + implicit none + integer,intent(in) :: nclust + integer,intent(in) :: npc,mm + real(wp),intent(in) :: pcvec(npc,mm) + integer(idp),intent(in) :: ndist + real(sp),intent(in) :: dist(ndist) + integer,intent(inout) :: member(mm) + real(ap),intent(inout):: centroid(npc,nclust) + integer,allocatable :: refmember(:) + integer :: iter + integer,parameter :: maxiter = 300 + + if (nclust .le. 1) return + + allocate (refmember(mm),source=0) + + call kmeans_seeds(nclust,npc,mm,centroid,pcvec,ndist,dist) + + do iter = 1,maxiter + ! ── assign each structure to its nearest centroid ──────────────────────── + member = 0 + call kmeans_assign(nclust,npc,mm,centroid,pcvec,member) + + if (all(member == refmember)) then + exit + else + refmember = member + end if + call kmeans_recenter(nclust,npc,mm,centroid,pcvec,member) + end do + + deallocate (refmember) + return +end subroutine kmeans + +subroutine kmeans_seeds(nclust,npc,mm,centroid,pcvec,ndist,dist) + !************************************************************* + !* Initialise k-means centroids by finding maximally * + !* separated points in PC space (greedy farthest-first). * + !************************************************************* + use crest_parameters,idp => dp + use utilities + implicit none + integer :: nclust,npc,mm + real(ap) :: centroid(npc,nclust) + real(wp) :: pcvec(npc,mm) + integer(idp) :: ndist + real(sp) :: dist(ndist) + real(sp) :: ddum + integer(idp) :: k,kiter + integer :: i,j,l,c + real(wp) :: distsum,maxdistsum + real(ap),allocatable :: p(:),q(:) + integer,allocatable :: taken(:) + + ! ── seed 1 & 2: the two most distant structures ──────────────────────────── + ddum = 0.0_sp + do kiter = 1,ndist + if (dist(kiter) > ddum) then + ddum = dist(kiter) + k = kiter + end if + end do + call revlin(k,j,i) !> reverse of the lin index to get (i,j) + + centroid(1:npc,1) = pcvec(1:npc,i) + centroid(1:npc,2) = pcvec(1:npc,j) + + if (nclust .le. 2) return + + ! ── seeds 3+: farthest point from all existing centroids ─────────────────── + allocate (p(npc),q(npc),taken(nclust)) + taken = 0 + taken(1) = i + taken(2) = j + do i = 3,nclust + maxdistsum = 0.0d0 + c = 0 +!$OMP PARALLEL PRIVATE ( l, q, p, j, distsum ) & +!$OMP SHARED ( i, centroid, npc, mm, maxdistsum, pcvec, c, taken ) +!$OMP DO + do j = 1,mm + distsum = 0.0d0 + p(1:npc) = pcvec(1:npc,j) + do l = 1,i-1 + q(1:npc) = centroid(1:npc,l) + distsum = distsum+eucdist(npc,p,q) + end do + !$OMP CRITICAL + if (distsum .gt. maxdistsum) then + if (.not.any(taken == j)) then + maxdistsum = distsum + c = j + taken(i) = c + end if + end if + !$OMP END CRITICAL + end do +!$OMP END DO +!$OMP END PARALLEL + if (c == 0) then + exit + else + centroid(1:npc,i) = pcvec(1:npc,c) + end if + end do + + deallocate (taken,q,p) + + return +end subroutine kmeans_seeds + +subroutine kmeans_assign(nclust,npc,mm,centroid,pcvec,member) + !************************************************************* + !* Assign each structure to the nearest centroid. * + !************************************************************* + use crest_parameters,idp => dp + implicit none + integer :: nclust,npc,mm + real(ap) :: centroid(npc,nclust) + real(wp) :: pcvec(npc,mm) + integer :: member(mm) + integer :: i,j,c + real(ap),allocatable :: centdist(:) + real(ap),allocatable :: p(:),q(:) + + allocate (centdist(nclust),source=0.0_ap) + allocate (p(npc),q(npc)) +!$OMP PARALLEL PRIVATE ( i, j, p, q, c, centdist ) & +!$OMP SHARED ( mm, nclust, member, centroid, npc, pcvec ) +!$OMP DO + do i = 1,mm + p(1:npc) = pcvec(1:npc,i) + do j = 1,nclust + q(1:npc) = centroid(1:npc,j) + centdist(j) = eucdist(npc,p,q) + end do + c = minloc(centdist,1) + member(i) = c + end do +!$OMP END DO +!$OMP END PARALLEL + deallocate (q,p) + deallocate (centdist) + return +end subroutine kmeans_assign + +subroutine kmeans_recenter(nclust,npc,mm,centroid,pcvec,member) + !************************************************************* + !* Recompute each centroid as the mean of its member * + !* structures in PC space. * + !************************************************************* + use crest_parameters,idp => dp + implicit none + integer :: nclust,npc,mm + real(ap) :: centroid(npc,nclust) + real(wp) :: pcvec(npc,mm) + integer :: member(mm) + integer :: i,j,c + real(ap),allocatable :: p(:),q(:) + + allocate (p(npc),q(npc)) + do i = 1,nclust + c = 0 + p = 0.0d0 + do j = 1,mm + if (member(j) == i) then + c = c+1 + p(1:npc) = p(1:npc)+pcvec(1:npc,j) + end if + end do + if (c > 0) then + p = p/float(c) + centroid(1:npc,i) = p(1:npc) + else + p = 999.9d0 + end if + end do + deallocate (q,p) + + return +end subroutine kmeans_recenter + +subroutine cluststat(nclust,npc,mm,centroid,pcvec,member,DBI,pSF,SSRSST) + !************************************************************* + !* Compute cluster quality metrics for a given partition: * + !* DBI = Davies-Bouldin index (lower is better) * + !* pSF = pseudo-F statistic (higher is better) * + !* SSRSST = SSR/SST ratio (higher means more distinct) * + !************************************************************* + use crest_parameters,idp => dp + implicit none + integer,intent(in) :: nclust + integer,intent(in) :: npc,mm + real(wp),intent(in) :: pcvec(npc,mm) + integer,intent(in) :: member(mm) + real(ap),intent(in):: centroid(npc,nclust) + real(wp),intent(out) :: DBI,pSF,SSRSST + real(wp) :: SSE,SSR,SST + real(ap),allocatable :: p(:),q(:) + real(wp),allocatable :: compact(:) + real(wp),allocatable :: DBmat(:,:) + real(wp) :: d,Rij,maxDB,weight + integer :: i,c,k,c2 + + DBI = 0.0d0 + pSF = 0.0d0 + SSRSST = 0.0d0 + + if (nclust < 2) return + + allocate (p(npc),q(npc)) + + ! ── sum of squares error (within-cluster) ────────────────────────────────── + SSE = 0.0d0 + do c = 1,nclust + p(1:npc) = centroid(1:npc,c) + do i = 1,mm + if (member(i) == c) then + q(1:npc) = pcvec(1:npc,i) + d = eucdist(npc,p,q) + SSE = SSE+d**2 + end if + end do + end do + + ! ── total sum of squares (weighted centroid as global mean) ──────────────── + SST = 0.0d0 + p = 0.0d0 + do c = 1,nclust + weight = real(count(member(:) == c,1),wp)/real(mm,wp) + p(1:npc) = p(1:npc)+centroid(1:npc,c)*weight + end do + do i = 1,mm + q(1:npc) = pcvec(1:npc,i) + d = eucdist(npc,p,q) + SST = SST+d**2 + end do + + SSR = SST-SSE + SSRSST = SSR/SST + + ! ── pseudo-F statistic ───────────────────────────────────────────────────── + if (nclust > 1) then + pSF = (SSR/(float(nclust)-1.0d0)) + if (mm == nclust) then + pSF = 0.0d0 + else + pSF = pSF/(SSE/(float(mm)-float(nclust))) + end if + else + pSF = 0.0d0 + end if + + ! ── Davies-Bouldin index ─────────────────────────────────────────────────── + allocate (compact(nclust),source=0.0d0) + do c = 1,nclust + p(1:npc) = centroid(1:npc,c) + k = 0 + do i = 1,mm + if (member(i) == c) then + k = k+1 + q(1:npc) = pcvec(1:npc,i) + d = eucdist(npc,p,q) + compact(c) = compact(c)+d + end if + end do + if (k > 0) then + compact(c) = compact(c)/float(k) + else + compact(c) = 0 + end if + end do + allocate (DBmat(nclust,nclust),source=0.0d0) + do c = 1,nclust + p(1:npc) = centroid(1:npc,c) + do c2 = 1,nclust + if (c2 == c) cycle + q(1:npc) = centroid(1:npc,c2) + d = eucdist(npc,p,q) + Rij = (compact(c)+compact(c2))/d + DBmat(c,c2) = Rij + end do + end do + do c = 1,nclust + maxDB = maxval(DBmat(:,c),1) + DBI = DBI+maxDB + end do + DBI = DBI/float(nclust) + deallocate (DBmat) + deallocate (compact) + + deallocate (q,p) + return +end subroutine cluststat + +subroutine statanal(n,nmax,statistics,extrema,pr,clust_sizes) + !************************************************************* + !* Identify local minima of DBI and local maxima of pSF * + !* across the tested cluster counts. * + !************************************************************* + use crest_parameters + implicit none + integer :: n,nmax + real(wp) :: statistics(3,nmax) + logical,intent(inout) :: extrema(2,n) + logical :: pr + integer,intent(in),optional :: clust_sizes(n) + real(wp) :: last,next,current + integer :: i,csize + + extrema = .false. +! ── identify local extrema of the DBI and pSF ──────────────────────────────── + do i = 2,n-1 + last = statistics(1,i-1) + next = statistics(1,i+1) + current = statistics(1,i) + if ((current < last).and.(current < next)) then + extrema(1,i) = .true. + end if + last = statistics(2,i-1) + next = statistics(2,i+1) + current = statistics(2,i) + if ((current > last).and.(current > next)) then + extrema(2,i) = .true. + end if + end do + !>-- boundary check: one-sided comparison for the last cluster count + if (n >= 2) then + if (statistics(1,n) < statistics(1,n-1)) extrema(1,n) = .true. + if (statistics(2,n) > statistics(2,n-1)) extrema(2,n) = .true. + end if + + if (pr) then + write (stdout,*) + write (stdout,'(1x,a,/)') 'Suggestions for cluster sizes:' + do i = 1,n + if (extrema(1,i).or.extrema(2,i)) then + csize = i + if (present(clust_sizes)) csize = clust_sizes(i) + if (extrema(1,i).and.extrema(2,i)) then + write (stdout,'(1x,i8,''*'',3x,a,f8.4)') csize,'SSR/SST',statistics(3,i) + else + write (stdout,'(1x,i8,4x,a,f8.4)') csize,'SSR/SST',statistics(3,i) + end if + end if + end do + write (stdout,'(/,1x,a)') 'Cluster counts marked with a star (*) are reasonable' + write (stdout,'(1x,a)') 'suggestions according to BOTH the DBI and pSF.' + end if + + return +end subroutine statanal + +subroutine statwarning(fname) + !************************************************************* + !* Print a note about the arbitrary nature of clustering. * + !************************************************************* + use crest_parameters + implicit none + character(len=*) :: fname + write (stdout,*) + write (stdout,'(1x,a)') '!---------------------------- NOTE ----------------------------!' + write (stdout,'(2x,a)') 'The partitioning of data (the ensemble) into clusters' + write (stdout,'(2x,a)') 'of similar characteristics (structures) is ARBITRARY' + write (stdout,'(2x,a)') 'and depends on many criteria (e.g. choice of PCs).' + write (stdout,'(2x,a)') 'The selected cluster count is the smallest reasonable' + write (stdout,'(2x,a)') 'number of clusters that can be formed according to' + write (stdout,'(2x,a)') 'the DBI and pSF values for the given data.' + write (stdout,*) + write (stdout,'(2x,a)') 'If other cluster sizes are desired, rerun CREST with' + write (stdout,'(2x,3a)') '"crest --sort ',trim(fname),' --cluster "' + write (stdout,*) + write (stdout,'(2x,a)') 'Other default evaluation settings can be chosen with the' + write (stdout,'(2x,a)') 'keywords "loose","normal", and "tight" as via' + write (stdout,'(2x,3a)') '"crest --sort ',trim(fname),' --cluster "' + write (stdout,'(1x,a)') '!--------------------------------------------------------------!' +end subroutine statwarning + +subroutine getdiederatoms(zmol,nat,inc,nb,diedat,ndied) + !************************************************************* + !* Extract dihedral angle atom quartets from the molecular * + !* topology, skipping terminal, ignored, and methyl atoms. * + !************************************************************* + use crest_parameters,idp => dp + use zdata + use strucrd + implicit none + type(zmolecule) :: zmol + integer :: nat + integer :: inc(nat) !> 1 = include, 0 = ignore + integer :: nb + integer :: diedat(4,nb) + integer,intent(out) :: ndied + integer :: a,b,c,d + integer :: i,j,k + + ndied = 0 + do i = 1,nb + a = zmol%bondpairs(1,i) + b = zmol%bondpairs(2,i) + if (inc(a) == 0) cycle !> ignored by user + if (inc(b) == 0) cycle !> ignored by user + if (zmol%zat(a)%nei == 1) cycle !> terminal atom + if (zmol%zat(b)%nei == 1) cycle !> terminal atom + if (zmol%methyl(a)) cycle !> methyl carbon + if (zmol%methyl(b)) cycle !> methyl carbon + ! ── get one neighbour of a and one of b to form the quartet ────────────── + do j = 1,zmol%zat(a)%nei + c = zmol%zat(a)%ngh(j) + if (c == b) then + cycle + else + exit + end if + end do + do k = 1,zmol%zat(b)%nei + d = zmol%zat(b)%ngh(k) + if (d == a) then + cycle + else + exit + end if + end do + ndied = ndied+1 + !> quartet layout: (1)=neighbour of a, (2)=a, (3)=b, (4)=neighbour of b + diedat(2,ndied) = a + diedat(3,ndied) = b + diedat(1,ndied) = c + diedat(4,ndied) = d + end do + + return +end subroutine getdiederatoms + +subroutine calc_dieders(mol,ndied,diedat,diedr) + !***************************************************** + !* Calculate dihedral angles for selected atom * + !* quartets. Results are in radians (-pi, pi). * + !***************************************************** + use crest_parameters,idp => dp + use strucrd + implicit none + type(coord),intent(in) :: mol + integer,intent(in) :: ndied + integer,intent(in) :: diedat(4,ndied) + real(wp),intent(out) :: diedr(ndied) + integer :: i + + diedr = 0.0_wp + do i = 1,ndied + !> quartet: (1)=neighbour of a, (2)=a, (3)=b, (4)=neighbour of b + diedr(i) = mol%dihedral(diedat(1,i),diedat(2,i), & + & diedat(3,i),diedat(4,i)) + end do + + return +end subroutine calc_dieders + +! ══════════════════════════════════════════════════════════════════════════════ +! ══════════════════════════════════════════════════════════════════════════════ +end module ccegen_utils diff --git a/src/sorting/meson.build b/src/sorting/meson.build index a74f7911..2f5168e8 100644 --- a/src/sorting/meson.build +++ b/src/sorting/meson.build @@ -16,6 +16,8 @@ srcs += files( 'canonical.f90', + 'ccegen_interface.f90', + 'ccegen_utils.f90', 'ccegen.f90', 'cregen_interfaces.f90', 'cregen.f90', From 412f4167fa0feecffb80b750d0e768ce5a4745cc Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 24 May 2026 15:26:08 +0200 Subject: [PATCH 347/374] cosmetics (some source cleanup) --- src/CMakeLists.txt | 1 - src/legacy_algos/CMakeLists.txt | 2 ++ src/{ => legacy_algos}/identifiers.f90 | 12 -------- src/legacy_algos/meson.build | 2 ++ src/{sorting => legacy_algos}/sortens.f90 | 0 src/meson.build | 1 - src/select.f90 | 36 ----------------------- src/sorting/CMakeLists.txt | 3 +- src/sorting/meson.build | 3 +- 9 files changed, 6 insertions(+), 54 deletions(-) rename src/{ => legacy_algos}/identifiers.f90 (98%) rename src/{sorting => legacy_algos}/sortens.f90 (100%) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 72c5c643..3d22d8aa 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -52,7 +52,6 @@ list(APPEND srcs "${dir}/flexi.F90" "${dir}/freqmasses.f90" "${dir}/geo.f90" - "${dir}/identifiers.f90" "${dir}/internals.f90" "${dir}/internals2.f90" "${dir}/iomod.F90" diff --git a/src/legacy_algos/CMakeLists.txt b/src/legacy_algos/CMakeLists.txt index af63c5b0..292e8de8 100644 --- a/src/legacy_algos/CMakeLists.txt +++ b/src/legacy_algos/CMakeLists.txt @@ -34,6 +34,8 @@ list(APPEND srcs "${dir}/stereoisomers.f90" "${dir}/tautomerize.f90" "${dir}/trialmd_legacy.f90" + "${dir}/identifiers.f90" + "${dir}/sortens.f90" "${dir}/zsort.f90" ) diff --git a/src/identifiers.f90 b/src/legacy_algos/identifiers.f90 similarity index 98% rename from src/identifiers.f90 rename to src/legacy_algos/identifiers.f90 index ef63192a..b5f432b2 100644 --- a/src/identifiers.f90 +++ b/src/legacy_algos/identifiers.f90 @@ -241,18 +241,6 @@ subroutine countnonh(nat,iz,n) !count all non-hydrogen atoms end do end subroutine countnonh -subroutine counth(nat,iz,n) !count all hydrogen atoms - implicit none - integer :: nat,iz(nat),n,i - n = 0 - do i = 1,nat - if (iz(i) .eq. 1) then - cycle - else - n = n+1 - end if - end do -end subroutine counth subroutine countnonh2(icn,idarr,n2) implicit none diff --git a/src/legacy_algos/meson.build b/src/legacy_algos/meson.build index 29dbea0f..281dee9d 100644 --- a/src/legacy_algos/meson.build +++ b/src/legacy_algos/meson.build @@ -32,5 +32,7 @@ srcs += files( 'stereoisomers.f90', 'tautomerize.f90', 'trialmd_legacy.f90', + 'identifiers.f90', + 'sortens.f90', 'zsort.f90', ) diff --git a/src/sorting/sortens.f90 b/src/legacy_algos/sortens.f90 similarity index 100% rename from src/sorting/sortens.f90 rename to src/legacy_algos/sortens.f90 diff --git a/src/meson.build b/src/meson.build index ca83d424..d3d3e024 100644 --- a/src/meson.build +++ b/src/meson.build @@ -49,7 +49,6 @@ srcs += files( 'flexi.F90', 'freqmasses.f90', 'geo.f90', - 'identifiers.f90', 'internals.f90', 'internals2.f90', 'iomod.F90', diff --git a/src/select.f90 b/src/select.f90 index b64cbb0b..0b1553c2 100644 --- a/src/select.f90 +++ b/src/select.f90 @@ -49,42 +49,6 @@ subroutine mrec(molcount,xyz,nat,at,molvec) molcount = molcount-1 end subroutine mrec -!=================================================================! -! subroutine mreclm -! a variant of the mrec routine with less allocate statements -! should be faster than the old version if several thousand -! calls are done. -!=================================================================! -subroutine mreclm(molcount,nat,at,xyz,molvec,bond,rcov,cn) - use iso_fortran_env,only:wp => real64 - use crest_cn_module - implicit none - integer :: molcount,nat - integer :: at(nat),molvec(nat) - real(wp) :: xyz(3,nat) - real(wp) :: cn(nat),bond(nat,nat) - real(wp) :: bref(nat,nat) - real(wp) :: rcov(*) - integer :: i - logical :: taken(nat) - molvec = 0 - molcount = 1 - taken = .false. - cn = 0.0d0 - bond = 0.0d0 - call calc_ncoord(nat,at,xyz,rcov,cn,400.0_wp,bond) - bref = bond - do i = 1,nat - if (.not.taken(i)) then - molvec(i) = molcount - taken(i) = .true. - call neighbours(i,xyz,at,taken,nat,cn,bond,molvec,molcount) - molcount = molcount+1 - end if - end do - molcount = molcount-1 - bond = bref -end subroutine mreclm !==================================================================================! recursive subroutine neighbours(i,xyz,iat,taken,nat,cn,bond,molvec,molcnt) diff --git a/src/sorting/CMakeLists.txt b/src/sorting/CMakeLists.txt index 09d42c37..979250be 100644 --- a/src/sorting/CMakeLists.txt +++ b/src/sorting/CMakeLists.txt @@ -30,8 +30,7 @@ list(APPEND srcs "${dir}/ls_rmsd.f90" "${dir}/quicksort.f90" "${dir}/rotcompare.f90" - "${dir}/sortens.f90" - "${dir}/unionize.f90" +"${dir}/unionize.f90" "${dir}/zdata.f90" "${dir}/ztopology.f90" ) diff --git a/src/sorting/meson.build b/src/sorting/meson.build index 2f5168e8..8640db2d 100644 --- a/src/sorting/meson.build +++ b/src/sorting/meson.build @@ -28,8 +28,7 @@ srcs += files( 'ls_rmsd.f90', 'quicksort.f90', 'rotcompare.f90', - 'sortens.f90', - 'unionize.f90', +'unionize.f90', 'zdata.f90', 'ztopology.f90', ) From 9813e59d6a69ed389f9c191d41e9084d6a094449 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 24 May 2026 15:53:50 +0200 Subject: [PATCH 348/374] fmlip-relay example --- examples/README.md | 1 + examples/expl-16/input.toml | 12 ++++++++++++ examples/expl-16/run.sh | 27 +++++++++++++++++++++++++++ examples/expl-16/struc.xyz | 6 ++++++ src/calculator/mlip_sc.F90 | 9 ++++++--- 5 files changed, 52 insertions(+), 3 deletions(-) create mode 100644 examples/expl-16/input.toml create mode 100755 examples/expl-16/run.sh create mode 100644 examples/expl-16/struc.xyz diff --git a/examples/README.md b/examples/README.md index 1f0bbfb0..a004efae 100644 --- a/examples/README.md +++ b/examples/README.md @@ -47,3 +47,4 @@ It is assumed that the `crest` binary is available in `$PATH`. | **13** | Protonation site sampling | uracil | | **14** | Metal/ion adducts (Cs+) | alpha-D-glucose | | **15** | Tautomer screening | guanine | +| **16** | fmlip-relay: geometry optimisation with LJ potential | Ar4 cluster | diff --git a/examples/expl-16/input.toml b/examples/expl-16/input.toml new file mode 100644 index 00000000..e5c98cc8 --- /dev/null +++ b/examples/expl-16/input.toml @@ -0,0 +1,12 @@ +# Geometry optimisation of an Ar4 cluster using a Lennard-Jones potential +# served through the fmlip-relay persistent Python backend. +# The LJ backend requires only ASE, no ML framework needed. +runtype = "optimize" +input = "struc.xyz" # input structure file (Ar4 cluster, slightly compressed) + +[calculation] +optlev = "normal" # convergence level: crude/loose/normal/tight/vtight + +[[calculation.level]] +method = "mlip" # ML/classical potential via fmlip-relay socket server +mlip_backend = "lj" # Lennard-Jones backend — default Ar parameters (ε=0.0104 eV, σ=3.40 Å) diff --git a/examples/expl-16/run.sh b/examples/expl-16/run.sh new file mode 100755 index 00000000..3c8f4a63 --- /dev/null +++ b/examples/expl-16/run.sh @@ -0,0 +1,27 @@ +#!/bin/bash +# Geometry optimisation of an Ar4 cluster using the Lennard-Jones potential +# served through the fmlip-relay persistent Python backend. +# fmlip-relay spawns a persistent server process; CREST communicates with it +# over a local TCP socket, avoiding repeated Python startup overhead. +# Output: crest_best.xyz (optimised Ar4 geometry near the LJ minimum ~3.82 Å) + +command -v crest >/dev/null 2>&1 || { + echo >&2 "Cannot find crest binary." + exit 1 +} + +# Check for the fmlip-relay server; suggest pip install if absent +if ! command -v fmlip-relay-server >/dev/null 2>&1; then + echo >&2 "" + echo >&2 "ERROR: 'fmlip-relay-server' not found." + echo >&2 "Install fmlip-relay from the CREST subproject directory:" + echo >&2 "" + echo >&2 " pip install ../../subprojects/fmlip_relay" + echo >&2 "" + echo >&2 "For a user-local install add '--user', or activate a virtual environment first." + exit 1 +fi + +# --- TOML run --- +# (No CLI equivalent; mlip settings are TOML-only.) +crest input.toml diff --git a/examples/expl-16/struc.xyz b/examples/expl-16/struc.xyz new file mode 100644 index 00000000..5de5f994 --- /dev/null +++ b/examples/expl-16/struc.xyz @@ -0,0 +1,6 @@ +4 +Ar4 cluster (compressed, for LJ optimization) +Ar 0.000 0.000 0.000 +Ar 3.300 0.000 0.000 +Ar 1.650 2.860 0.000 +Ar 1.650 0.953 2.694 diff --git a/src/calculator/mlip_sc.F90 b/src/calculator/mlip_sc.F90 index 314a7ad5..f7f01520 100644 --- a/src/calculator/mlip_sc.F90 +++ b/src/calculator/mlip_sc.F90 @@ -130,10 +130,13 @@ subroutine fmlip_relay_init(MPAR,iid) write (stdout,*) call creststop(20) end if + write (cmd,'(a,1x,a,1x,i0,2(1x,a,1x,a),1x,a)') basebin,'--port',tmpport,'--backend', & + & trim(MPAR%backend),'--model',trim(MPAR%modelpath),trim(cmd_1) + else + !> no model path (e.g. lj, dummy backends that need no model file) + write (cmd,'(a,1x,a,1x,i0,1x,a,1x,a,1x,a)') basebin,'--port',tmpport, & + & '--backend',trim(MPAR%backend),trim(cmd_1) end if - - write (cmd,'(a,1x,a,1x,i0,2(1x,a,1x,a),1x,a)') basebin,'--port',tmpport,'--backend', & - & trim(MPAR%backend),'--model',trim(MPAR%modelpath),trim(cmd_1) end select !> check if this particular server is already running by pinging it From aff0a70b8e8470c1ab18477a7f677cc46861e8f4 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 24 May 2026 17:01:21 +0200 Subject: [PATCH 349/374] Better handling of parallel fmlip-relay usage --- src/algos/parallel.f90 | 10 +++++++++ src/basinhopping/algo.f90 | 3 +++ src/calculator/api_engrad.f90 | 35 +++++++++++++++++++++++------ src/calculator/calculator.F90 | 1 + src/calculator/mlip_sc.F90 | 42 +++++++++++++++++------------------ 5 files changed, 63 insertions(+), 28 deletions(-) diff --git a/src/algos/parallel.f90 b/src/algos/parallel.f90 index 1805fba2..09611c6b 100644 --- a/src/algos/parallel.f90 +++ b/src/algos/parallel.f90 @@ -182,6 +182,8 @@ subroutine crest_sploop(env,nat,nall,at,xyz,eread) z = 0 !> counter to perform optimization in right order (1...nall) eread(:) = 0.0_wp grads(:,:,:) = 0.0_wp +!>--- pre-start server-based calculators before forking OMP threads + call preinit_mlip_parallel(calculations,T) !>--- loop over ensemble !$omp parallel & !$omp shared(env,calculations,nat,nall,at,xyz,eread,grads,c,k,z,pr,wr) & @@ -392,6 +394,8 @@ subroutine crest_hessloop(env,nat,nall,at,xyz,eread,gt_out,stot_out) z = 0 !> counter to perform optimization in right order (1...nall) eread(:) = 0.0_wp grads(:,:,:) = 0.0_wp +!>--- pre-start server-based calculators before forking OMP threads + call preinit_mlip_parallel(calculations,T) !>--- loop over ensemble !$omp parallel & !$omp shared(env,calculations,nat,nall,at,xyz,eread,grads,c,k,z,pr,wr,nrt) & @@ -600,6 +604,8 @@ subroutine crest_oloop(env,nat,nall,at,xyz,eread,dump,customcalc) z = 0 !> counter to perform optimization in right order (1...nall) eread(:) = 0.0_wp grads(:,:,:) = 0.0_wp +!>--- pre-start server-based calculators before forking OMP threads + call preinit_mlip_parallel(calculations,T) !>--- loop over ensemble !$omp parallel & !$omp shared(env,calculations,nat,nall,at,xyz,eread,grads,c,k,z,pr,wr,dump) & @@ -775,6 +781,8 @@ subroutine crest_search_multimd(env,mol,mddats,nsim) pr = .false. call profiler%init(nsim) +!>--- pre-start server-based calculators before forking OMP threads + call preinit_mlip_parallel(calculations,T) !>--- run the MDs !$omp parallel & !$omp shared(env,calculations,mddats,mol,pr,percent,ich, nsim, moltmps, nested,Tn) & @@ -1070,6 +1078,8 @@ subroutine crest_search_multimd2(env,mols,mddats,nsim) pr = .false. call profiler%init(nsim) +!>--- pre-start server-based calculators before forking OMP threads + call preinit_mlip_parallel(calculations,T) !>--- run the MDs !$omp parallel & !$omp shared(env,calculations,mddats,mols,pr,percent,ich, moltmps,profiler, nested,Tn) diff --git a/src/basinhopping/algo.f90 b/src/basinhopping/algo.f90 index 0406868f..c800fc67 100644 --- a/src/basinhopping/algo.f90 +++ b/src/basinhopping/algo.f90 @@ -281,6 +281,9 @@ subroutine parallel_basinhopping_core(env,mol,calc,structuredump) !$omp end critical end do +!>--- pre-start server-based calculators before forking OMP threads + call preinit_mlip_parallel(calcp,T) + write (stdout,'(a)') '> Starting parallel Basin-Hopping execution' write (stdout,*) diff --git a/src/calculator/api_engrad.f90 b/src/calculator/api_engrad.f90 index 08b6ad35..6e78366a 100644 --- a/src/calculator/api_engrad.f90 +++ b/src/calculator/api_engrad.f90 @@ -51,6 +51,7 @@ module api_engrad public :: modelhessian_engrad public :: rmsd_engrad public :: mlip_engrad + public :: preinit_mlip_parallel !=========================================================================================! !=========================================================================================! @@ -480,6 +481,29 @@ subroutine rmsd_engrad(mol,calc,energy,grad,iostatus) return end subroutine rmsd_engrad +!========================================================================================! + + subroutine preinit_mlip_parallel(calculations,T) +!*********************************************************************** +!* Serially start one fmlip-relay server instance per OMP thread. +!* Must be called before the OMP parallel region to avoid fork() inside +!* a live thread team (triggers OMP Warning #191). +!* Input: calculations - per-thread calcdata array (size >= T) +!* T - number of OMP threads / instances to start +!*********************************************************************** + implicit none + type(calcdata),intent(inout) :: calculations(:) + integer,intent(in) :: T + integer :: i,j + do i = 1,T + do j = 1,calculations(i)%ncalculations + if (calculations(i)%calcs(j)%id == jobtype%mlip) then + call fmlip_relay_init(calculations(i)%calcs(j)%MPAR,i) + end if + end do + end do + end subroutine preinit_mlip_parallel + !========================================================================================! subroutine mlip_engrad(mol,calc,energy,grad,iostatus) @@ -499,22 +523,19 @@ subroutine mlip_engrad(mol,calc,energy,grad,iostatus) logical :: ex iostatus = 0 pr = .false. +!>--- each OpenMP thread owns one server instance; init is a no-op if running + iid = OMP_GET_THREAD_NUM()+1 !$omp critical -!>--- setup system call information - if (calc%MPAR%iid == 0) then - iid = OMP_GET_THREAD_NUM()+1 - call fmlip_relay_init(calc%MPAR,iid) - end if + call fmlip_relay_init(calc%MPAR,iid) !>--- printout handling call api_handle_output(calc,'mlip.out',mol,pr) -!>--- populate parameters !$omp end critical if (iostatus /= 0) return !>--- do the engrad call call initsignal() call mlip_engrad_core(mol,calc%MPAR,energy,grad,iostatus, & - & charge=calc%chrg,spin=calc%uhf) + & charge=calc%chrg,spin=calc%uhf,iid=iid) if (iostatus /= 0) return !>--- printout diff --git a/src/calculator/calculator.F90 b/src/calculator/calculator.F90 index 6aebaa71..8c31667d 100644 --- a/src/calculator/calculator.F90 +++ b/src/calculator/calculator.F90 @@ -56,6 +56,7 @@ module crest_calculator !>--- public module routines public :: potential_core public :: engrad + public :: preinit_mlip_parallel interface engrad module procedure :: engrad_mol end interface engrad diff --git a/src/calculator/mlip_sc.F90 b/src/calculator/mlip_sc.F90 index f7f01520..eb376e15 100644 --- a/src/calculator/mlip_sc.F90 +++ b/src/calculator/mlip_sc.F90 @@ -74,6 +74,13 @@ subroutine fmlip_relay_init(MPAR,iid) call creststop(20) end if + ! ── fast path: instance already running, nothing to do ─────────────────── + call mlip_ping(iid,io) + if (io == MLIP_OK) then + MPAR%iid = iid + return + end if + call checkprog_silent(basebin,verbose=.false.,iostat=io) if (io .ne. 0) then write (stdout,*) @@ -83,12 +90,6 @@ subroutine fmlip_relay_init(MPAR,iid) call creststop(20) end if - !> check for already running instances that may need reinitialization - !> or rather, shutdown first - if (MPAR%iid .ne. 0) then - call mlip_finalize(MPAR%iid,io) - end if - !> check if we have limitations for parallelity if (iid > MLIP_MAX_INSTANCES) then write (stdout,*) @@ -116,7 +117,7 @@ subroutine fmlip_relay_init(MPAR,iid) & 'mace','--model',trim(MPAR%modelpath),trim(cmd_1) else cmd_0 = '' - if (allocated(MPAR%modelsize)) write (cmd_0,'(a,1x,a)') '--mace_model',trim(MPAR%modelsize) + if (allocated(MPAR%modelsize)) write (cmd_0,'(a,1x,a)') '--mace-model',trim(MPAR%modelsize) write (cmd,'(a,1x,a,1x,i0,2(1x,a,1x,a),1x,a)') basebin,'--port',tmpport,'--backend', & & trim(MPAR%backend),trim(cmd_0),'',trim(cmd_1) end if @@ -139,18 +140,14 @@ subroutine fmlip_relay_init(MPAR,iid) end if end select - !> check if this particular server is already running by pinging it - call mlip_ping(iid,io) + !> spawn the server and verify + call mlip_init(iid,tmpport,trim(cmd)//' 2>/dev/null',MPAR%TIMEOUT_SEC,io) if (io /= MLIP_OK) then - call mlip_init(iid,tmpport,trim(cmd)//' 2>/dev/null',MPAR%TIMEOUT_SEC,io) - if (io /= MLIP_OK) then - write (stdout,*) - write (stdout,*) '** ERROR ** failed to initialize MLIP server' - write (stdout,*) - call creststop(1) - end if + write (stdout,*) + write (stdout,*) '** ERROR ** failed to initialize MLIP server' + write (stdout,*) + call creststop(1) end if - !> Test it call mlip_ping(iid,io) if (io /= MLIP_OK) then write (stdout,*) @@ -169,16 +166,17 @@ subroutine fmlip_relay_init(MPAR,iid) end subroutine fmlip_relay_init subroutine mlip_engrad_core(mol,MPAR,energy,gradient,iostatus, & - & charge,spin) + & charge,spin,iid) type(coord),intent(in) :: mol type(mlip_params),intent(in) :: MPAR integer,intent(in),optional :: charge integer,intent(in),optional :: spin + integer,intent(in),optional :: iid real(wp),intent(out) :: energy real(wp),intent(out) :: gradient(3,mol%nat) integer,intent(out) :: iostatus - integer :: chrg,spn + integer :: chrg,spn,instance_id real(wp) :: stress(3,3) energy = 0.0_wp @@ -189,13 +187,15 @@ subroutine mlip_engrad_core(mol,MPAR,energy,gradient,iostatus, & spn = 1 if (present(charge)) chrg = chrg if (present(spin)) spn = spin + instance_id = MPAR%iid + if (present(iid)) instance_id = iid #ifdef WITH_FMLIP_RELAY if (allocated(mol%lat)) then - call mlip_compute(MPAR%iid,mol%nat,mol%at,mol%xyz*autoaa,mol%lat,allpbc,0,chrg,spn, & + call mlip_compute(instance_id,mol%nat,mol%at,mol%xyz*autoaa,mol%lat,allpbc,0,chrg,spn, & & energy,gradient,stress,iostatus) else - call mlip_compute(MPAR%iid,mol%nat,mol%at,mol%xyz*autoaa,bigcell,nopbc,0,chrg,spn, & + call mlip_compute(instance_id,mol%nat,mol%at,mol%xyz*autoaa,bigcell,nopbc,0,chrg,spn, & & energy,gradient,stress,iostatus) end if From a110036ada514e2ecdca2b9712e749904a88c05a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sun, 24 May 2026 22:56:30 +0200 Subject: [PATCH 350/374] submodule commit update --- config/modules/Findfmlip_relay.cmake | 2 +- subprojects/fmlip_relay | 2 +- subprojects/fmlip_relay.wrap | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/config/modules/Findfmlip_relay.cmake b/config/modules/Findfmlip_relay.cmake index f0816f7a..64781995 100644 --- a/config/modules/Findfmlip_relay.cmake +++ b/config/modules/Findfmlip_relay.cmake @@ -1,7 +1,7 @@ set(_lib "fmlip_relay") set(_pkg "FMLIP_RELAY") set(_url "https://github.com/pprcht/fmlip-relay") -set(_branch "fa44cc393ef51b1c4f38a0e4c1303994268b13c4") +set(_branch "df72296254383d5b4e1ff10d7bd461c5447bc0da") # Discovery method order can be overridden by the parent project, e.g.: # set(FMLIP_RELAY_FIND_METHOD "subproject" "cmake") diff --git a/subprojects/fmlip_relay b/subprojects/fmlip_relay index fa44cc39..df722962 160000 --- a/subprojects/fmlip_relay +++ b/subprojects/fmlip_relay @@ -1 +1 @@ -Subproject commit fa44cc393ef51b1c4f38a0e4c1303994268b13c4 +Subproject commit df72296254383d5b4e1ff10d7bd461c5447bc0da diff --git a/subprojects/fmlip_relay.wrap b/subprojects/fmlip_relay.wrap index 34f5d002..98757992 100644 --- a/subprojects/fmlip_relay.wrap +++ b/subprojects/fmlip_relay.wrap @@ -3,7 +3,7 @@ # the submodule is checked out under subprojects/fmlip_relay/. [wrap-git] url = https://github.com/pprcht/fmlip-relay -revision = fa44cc393ef51b1c4f38a0e4c1303994268b13c4 +revision = df72296254383d5b4e1ff10d7bd461c5447bc0da clone-recursive = true [provide] From 0ea9d24070e64008aa5bf0035f28b0414b460b8a Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Sat, 30 May 2026 18:01:41 +0200 Subject: [PATCH 351/374] update some printout banners and use proper deep copy of "calc" in those routines --- src/algos/dryrun.f90 | 21 ++++++++--- src/algos/dynamics.f90 | 31 ++++++++-------- src/algos/numhess.f90 | 52 ++++++++++++++------------- src/algos/optimization.f90 | 73 ++++++++++++++++++++++---------------- src/algos/scan.f90 | 2 +- src/algos/setuptest.f90 | 7 ++-- src/algos/singlepoint.f90 | 24 +++++++------ 7 files changed, 121 insertions(+), 89 deletions(-) diff --git a/src/algos/dryrun.f90 b/src/algos/dryrun.f90 index 222646cf..0d6451c1 100644 --- a/src/algos/dryrun.f90 +++ b/src/algos/dryrun.f90 @@ -54,7 +54,7 @@ subroutine crest_dry_run(env,tim) if (ex) then write (stdout,*) else - write(stdout,'(1x,"( ",a," )")') colorify('NOT FOUND','red') + write (stdout,'(1x,"( ",a," )")') colorify('NOT FOUND','red') end if write (stdout,*) @@ -81,7 +81,11 @@ subroutine crest_dry_run(env,tim) case (crest_sp) write (stdout,'(2x,a)') 'Standalone singlepoint calculation' case (crest_optimize) - write (stdout,'(2x,a)') 'Standalone geometry optimization' + if (.not.env%crest_ohess) then + write (stdout,'(2x,a)') 'Standalone geometry optimization' + else + write (stdout,'(2x,a)') 'Standalone geometry optimization followed by numerical Hessian' + end if case (crest_moldyn) write (stdout,'(2x,a)') 'Standalone molecular dynamics simulation' case (crest_s1) @@ -128,11 +132,20 @@ subroutine crest_dry_run(env,tim) !========================================================================================! call drawbox(stdout,'Optimization settings',charset=4,padl=2,padr=2) write (stdout,*) + write (stdout,'(2x,a,t35,": ",a,1x,"(",i0,")")') 'Optimization level',optlevflag(env%optlev),nint(env%optlev) if (associated(env%calc)) then + block + use optimize_utils,only:get_optthr + real(wp) :: ethr,gthr + integer :: nat,iolev + nat = env%ref%nat + iolev = nint(env%optlev) + call get_optthr(nat,iolev,env%calc,ethr,gthr) write (stdout,'(2x,a,t35,": ",i0)') 'Max cycles (calc obj)',env%calc%maxcycle - write (stdout,'(2x,a,t35,": ",es12.4)') 'Energy convergence [Eh]',env%calc%ethr_opt - write (stdout,'(2x,a,t35,": ",es12.4)') 'Gradient convergence [Eh/a0]',env%calc%gthr_opt + write (stdout,'(2x,a,t35,": ",es12.4)') 'Energy convergence [Eh]',ethr + write (stdout,'(2x,a,t35,": ",es12.4)') 'Gradient convergence [Eh/a0]',gthr + end block end if write (stdout,*) diff --git a/src/algos/dynamics.f90 b/src/algos/dynamics.f90 index f315e5bc..b0de3158 100644 --- a/src/algos/dynamics.f90 +++ b/src/algos/dynamics.f90 @@ -24,6 +24,7 @@ subroutine crest_moleculardynamics(env,tim) use strucrd use dynamics_module use shake_module + use iomod, only: colorify implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim @@ -39,17 +40,19 @@ subroutine crest_moleculardynamics(env,tim) real(wp),allocatable :: grad(:,:) character(len=80) :: atmp - character(len=*),parameter :: trjf='crest_dynamics.trj.xyz' + character(len=*),parameter :: trjf = 'crest_dynamics.trj.xyz' !========================================================================================! - write(stdout,*) - !call system('figlet dynamics') - write(stdout,*) " _ _ " - write(stdout,*) " __| |_ _ _ __ __ _ _ __ ___ (_) ___ ___ " - write(stdout,*) " / _` | | | | '_ \ / _` | '_ ` _ \| |/ __/ __| " - write(stdout,*) " | (_| | |_| | | | | (_| | | | | | | | (__\__ \ " - write(stdout,*) " \__,_|\__, |_| |_|\__,_|_| |_| |_|_|\___|___/ " - write(stdout,*) " |___/ " - write(stdout,*) + write (stdout,*) + write (stdout,*) colorify(" ██ ██ ","gold") + write (stdout,*) colorify(" ░██ ██ ██ ░░ ","gold") + write (stdout,*) colorify(" ░██ ░░██ ██ ███████ ██████ ██████████ ██ █████ ██████","gold") + write (stdout,*) colorify(" ██████ ░░███ ░░██░░░██ ░░░░░░██ ░░██░░██░░██░██ ██░░░██ ██░░░░ ","gold") + write (stdout,*) colorify(" ██░░░██ ░██ ░██ ░██ ███████ ░██ ░██ ░██░██░██ ░░ ░░█████ ","gold") + write (stdout,*) colorify("░██ ░██ ██ ░██ ░██ ██░░░░██ ░██ ░██ ░██░██░██ ██ ░░░░░██","gold") + write (stdout,*) colorify("░░██████ ██ ███ ░██░░████████ ███ ░██ ░██░██░░█████ ██████ ","gold") + write (stdout,*) colorify(" ░░░░░░ ░░ ░░░ ░░ ░░░░░░░░ ░░░ ░░ ░░ ░░ ░░░░░ ░░░░░░ ","gold") + write (stdout,*) + !========================================================================================! call new_ompautoset(env,'max',0,T,Tn) call ompprint_intern() @@ -65,9 +68,9 @@ subroutine crest_moleculardynamics(env,tim) !>--- default settings from env call env_to_mddat(env) mddat = env%mddat - calc = env%calc + call calc%copy(env%calc) !>--- check if we have any MD & calculation settings allocated - if (.not. mddat%requested) then + if (.not.mddat%requested) then write (stdout,*) 'MD requested, but no MD settings present.' env%iostatus_meta = status_config return @@ -78,12 +81,12 @@ subroutine crest_moleculardynamics(env,tim) end if !>--- print calculation info - call calc%info( stdout ) + call calc%info(stdout) !>--- init SHAKE? --> we need connectivity info if (mddat%shake) then calc%calcs(1)%rdwbo = .true. - if(.not.calc%calcs(1)%active) calc%calcs(1)%active=.true. + if (.not.calc%calcs(1)%active) calc%calcs(1)%active = .true. allocate (grad(3,mol%nat),source=0.0_wp) call engrad(mol,calc,energy,grad,io) deallocate (grad) diff --git a/src/algos/numhess.f90 b/src/algos/numhess.f90 index aef91c30..e7bf0d33 100644 --- a/src/algos/numhess.f90 +++ b/src/algos/numhess.f90 @@ -37,6 +37,7 @@ subroutine crest_numhess(env,tim) use xtb_sc use oniom_hessian use ir_spectrum + use iomod, only: colorify implicit none type(systemdata),intent(inout) :: env @@ -54,13 +55,16 @@ subroutine crest_numhess(env,tim) !========================================================================================! call tim%start(15,'Numerical Hessian') !========================================================================================! - !call system('figlet numhess') + write (stdout,*) - write (stdout,*) " _ " - write (stdout,*) " _ __ _ _ _ __ ___ | |__ ___ ___ ___ " - write (stdout,*) "| '_ \| | | | '_ ` _ \| '_ \ / _ \/ __/ __|" - write (stdout,*) "| | | | |_| | | | | | | | | | __/\__ \__ \" - write (stdout,*) "|_| |_|\__,_|_| |_| |_|_| |_|\___||___/___/" + write (stdout,*) colorify(" ██ ","gold") + write (stdout,*) colorify(" ░██ ","gold") + write (stdout,*) colorify(" ███████ ██ ██ ██████████ ░██ █████ ██████ ██████ ","gold") + write (stdout,*) colorify("░░██░░░██░██ ░██░░██░░██░░██░██████ ██░░░██ ██░░░░ ██░░░░ ","gold") + write (stdout,*) colorify(" ░██ ░██░██ ░██ ░██ ░██ ░██░██░░░██░███████░░█████ ░░█████ ","gold") + write (stdout,*) colorify(" ░██ ░██░██ ░██ ░██ ░██ ░██░██ ░██░██░░░░ ░░░░░██ ░░░░░██ ","gold") + write (stdout,*) colorify(" ███ ░██░░██████ ███ ░██ ░██░██ ░██░░██████ ██████ ██████ ","gold") + write (stdout,*) colorify("░░░ ░░ ░░░░░░ ░░░ ░░ ░░ ░░ ░░ ░░░░░░ ░░░░░░ ░░░░░░ ","gold") write (stdout,*) call env%ref%to(mol) @@ -70,7 +74,7 @@ subroutine crest_numhess(env,tim) write (stdout,*) !========================================================================================! - calc = env%calc + call calc%copy(env%calc) !>--- print some info about the calculation call calc%info(stdout) @@ -210,7 +214,7 @@ subroutine crest_numhess(env,tim) ! ── project dipole gradient onto normal modes → IR intensities ─────────── if (allocated(calc%calcs(i)%dipgrad)) then - allocate(ir_int(nat3),source=0.0_wp) + allocate (ir_int(nat3),source=0.0_wp) call ir_intensities(mol%nat,mol%at,nat3,hess(:,:,i), & & calc%calcs(i)%dipgrad,ir_int) end if @@ -223,7 +227,7 @@ subroutine crest_numhess(env,tim) call print_g98_fake(mol%nat,mol%at,nat3,mol%xyz,freq(:,i),hess(:,:,i), & & calc%calcs(i)%calcspace,'g98'//trim(atmp)//'.out',ir_int=ir_int) - if (allocated(ir_int)) deallocate(ir_int) + if (allocated(ir_int)) deallocate (ir_int) call smallhead("Thermo contributions for [[calculation.level]] "//trim(atmp)) call numhess_thermostat(env,mol,nat3,hess(:,:,i),freq(:,i),energies0(i)) @@ -498,12 +502,12 @@ subroutine crest_ensemble_hessians(env,tim) integer,allocatable :: at(:) logical :: ex !========================================================================================! - write(stdout,*) - inquire(file=env%ensemblename,exist=ex) + write (stdout,*) + inquire (file=env%ensemblename,exist=ex) if (ex) then ensnam = env%ensemblename else - write(stdout,*) '**ERROR** no ensemble file provided.' + write (stdout,*) '**ERROR** no ensemble file provided.' env%iostatus_meta = status_input return end if @@ -512,11 +516,11 @@ subroutine crest_ensemble_hessians(env,tim) call rdensembleparam(ensnam,nat,nall) if (nall < 1) then - write(stdout,*) '**ERROR** empty ensemble file.' + write (stdout,*) '**ERROR** empty ensemble file.' env%iostatus_meta = status_input return end if - allocate(xyz(3,nat,nall),at(nat),eread(nall),etmp(nall)) + allocate (xyz(3,nat,nall),at(nat),eread(nall),etmp(nall)) call rdensemble(ensnam,nat,nall,at,xyz,eread) !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: crest_hessloop requires coordinates in Bohr @@ -526,15 +530,15 @@ subroutine crest_ensemble_hessians(env,tim) call new_ompautoset(env,'auto',nall,T,Tn) !========================================================================================! - write(stdout,*) - write(stdout,'(10x,"┍",49("━"),"┑")') - write(stdout,'(10x,"│",16x,a,16x,"│")') "ENSEMBLE HESSIANS" - write(stdout,'(10x,"┕",49("━"),"┙")') - write(stdout,*) - write(stdout,'(1x,a,i0,a,1x,a)') 'Evaluating all ',nall,' structures of file ',trim(ensnam) + write (stdout,*) + write (stdout,'(10x,"┍",49("━"),"┑")') + write (stdout,'(10x,"│",16x,a,16x,"│")') "ENSEMBLE HESSIANS" + write (stdout,'(10x,"┕",49("━"),"┙")') + write (stdout,*) + write (stdout,'(1x,a,i0,a,1x,a)') 'Evaluating all ',nall,' structures of file ',trim(ensnam) call crest_hessloop(env,nat,nall,at,xyz,etmp) - eread(:) = eread(:) + etmp(:) + eread(:) = eread(:)+etmp(:) !========================================================================================! !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<' + write (stdout,'(/,a,a,a)') 'Ensemble with Gibbs free energies written to <',ensemblefile,'>' call dumpenergies('crest.energies',eread) - write(stdout,'(/,a,a,a)') 'List of free energies written to <','crest.energies','>' + write (stdout,'(/,a,a,a)') 'List of free energies written to <','crest.energies','>' - deallocate(eread,at,xyz) + deallocate (eread,at,xyz) !========================================================================================! call tim%stop(14) return diff --git a/src/algos/optimization.f90 b/src/algos/optimization.f90 index c3f158be..ea7ae7d1 100644 --- a/src/algos/optimization.f90 +++ b/src/algos/optimization.f90 @@ -32,6 +32,7 @@ subroutine crest_optimization(env,tim) use crest_calculator use strucrd use optimize_module + use iomod, only:colorify implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim @@ -46,6 +47,19 @@ subroutine crest_optimization(env,tim) character(len=80) :: atmp character(len=*),parameter :: partial = '∂E/∂' + +! ══════════════════════════════════════════════════════════════════════════════ + write (stdout,*) + write (stdout,*) colorify(" ██ ██ ██ ","gold") + write (stdout,*) colorify(" ██████ ░██ ░░ ░░ ","gold") + write (stdout,*) colorify(" ██████ ░██░░░██ ██████ ██ ██████████ ██ ██████ █████ ","gold") + write (stdout,*) colorify(" ██░░░░██░██ ░██░░░██░ ░██░░██░░██░░██░██░░░░██ ██░░░██","gold") + write (stdout,*) colorify("░██ ░██░██████ ░██ ░██ ░██ ░██ ░██░██ ██ ░███████","gold") + write (stdout,*) colorify("░██ ░██░██░░░ ░██ ░██ ░██ ░██ ░██░██ ██ ░██░░░░ ","gold") + write (stdout,*) colorify("░░██████ ░██ ░░██ ░██ ███ ░██ ░██░██ ██████░░██████","gold") + write (stdout,*) colorify(" ░░░░░░ ░░ ░░ ░░ ░░░ ░░ ░░ ░░ ░░░░░░ ░░░░░░ ","gold") + write (stdout,*) + !========================================================================================! call new_ompautoset(env,'max',0,T,Tn) call ompprint_intern() @@ -60,15 +74,15 @@ subroutine crest_optimization(env,tim) !========================================================================================! allocate (grad(3,mol%nat),source=0.0_wp) - calc = env%calc + call calc%copy(env%calc) !>--- check if we have any calculation settings allocated if (calc%ncalculations < 1) then write (stdout,*) 'no calculations allocated' return else - call calc%info( stdout ) + call calc%info(stdout) end if - write(stdout,'(a)') repeat('-',80) + write (stdout,'(a)') repeat('-',80) !>-- geometry optimization pr = .true. !> stdout printout @@ -83,7 +97,7 @@ subroutine crest_optimization(env,tim) write (stdout,*) 'SUCCESS!' write (stdout,*) 'geometry successfully optimized!' write (stdout,*) - write(stdout,'(a)') repeat('-',80) + write (stdout,'(a)') repeat('-',80) write (stdout,*) write (stdout,'(1x,a)') 'FINAL CALCULATION SUMMARY' @@ -125,7 +139,7 @@ subroutine crest_optimization(env,tim) else write (stdout,*) 'geometry optimization FAILED!' env%iostatus_meta = status_failed - endif + end if write (stdout,*) write (stdout,'(a)') repeat('=',42) @@ -133,9 +147,9 @@ subroutine crest_optimization(env,tim) write (stdout,'(1x,a,f20.10,a)') 'GRADIENT NORM ',norm2(grad),' Eh/a0' write (stdout,'(a)') repeat('=',42) - if(io /= 0)then + if (io /= 0) then write (stdout,*) 'WARNING: geometry optimization FAILED!' - endif + end if deallocate (grad) !========================================================================================! @@ -143,19 +157,19 @@ subroutine crest_optimization(env,tim) !========================================================================================! !>--- append numerical hessian calculation - if( io == 0 .and. env%crest_ohess )then + if (io == 0.and.env%crest_ohess) then call env%ref%load(molnew) !> load the optimized geometry call crest_numhess(env,tim) !> run the numerical hessian - endif + end if !========================================================================================! !========================================================================================! !>--- append deform opt hessian calculation - if( io == 0 .and. calc%deform_opt_hess) then !.and. calc%do_HR )then + if (io == 0.and.calc%deform_opt_hess) then !.and. calc%do_HR )then call env%ref%load(molnew) !> load the optimized geometry call deform_opt_hess(calc,molnew) !> run the hessian reconstruction - endif + end if !========================================================================================! @@ -216,16 +230,16 @@ subroutine crest_ensemble_optimization(env,tim) !>---- read the input ensemble call rdensembleparam(ensnam,nat,nall) - if (nall .lt. 1)then + if (nall .lt. 1) then write (stdout,*) '**ERROR** empty ensemble file.' env%iostatus_meta = status_input return - endif + end if allocate (xyz(3,nat,nall),at(nat),eread(nall)) call rdensemble(ensnam,nat,nall,at,xyz,eread) !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Important: crest_oloop requires coordinates in Bohrs - xyz = xyz / bohr + xyz = xyz/bohr !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- set OMP parallelization @@ -244,29 +258,29 @@ subroutine crest_ensemble_optimization(env,tim) !========================================================================================! !>--- output - write(stdout,'(/,a,a,a)') 'Rewriting ',ensemblefile,' in the correct order'// & + write (stdout,'(/,a,a,a)') 'Rewriting ',ensemblefile,' in the correct order'// & & ' (failed optimizations are assigned an energy of +1.0)' !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<--- Back to Angstroem - xyz = xyz * bohr + xyz = xyz*bohr !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<< 0.0_wp) comments(i) = '!failed' - enddo + allocate (comments(nall)) + do i = 1,nall + comments(i) = '' + if (eread(i) > 0.0_wp) comments(i) = '!failed' + end do call wrensemble(ensemblefile,nat,nall,at,xyz,eread,comments) deallocate (eread,at,xyz) - write(stdout,'(/,a,a,a)') 'Optimized ensemble written to <',ensemblefile,'>' + write (stdout,'(/,a,a,a)') 'Optimized ensemble written to <',ensemblefile,'>' !========================================================================================! !>--- (optional) refinement step if (allocated(env%refine_queue)) then - write(stdout,*) + write (stdout,*) call crest_refine(env,ensemblefile,ensemblefile//'.refine') - write(stdout,'(/,a,a,a)') 'Refined ensemble written to <',ensemblefile,'.refine>' - endif + write (stdout,'(/,a,a,a)') 'Refined ensemble written to <',ensemblefile,'.refine>' + end if !========================================================================================! call tim%stop(14) @@ -288,7 +302,7 @@ subroutine crest_ensemble_screening(env,tim) use crest_calculator use strucrd use optimize_module - use iomod + use iomod implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim @@ -327,11 +341,11 @@ subroutine crest_ensemble_screening(env,tim) !>---- read the input ensemble call rdensembleparam(ensnam,nat,nall) - if (nall .lt. 1)then + if (nall .lt. 1) then write (stdout,*) '**ERROR** empty ensemble file.' env%iostatus_meta = status_input return - endif + end if !>--- set OMP parallelization call new_ompautoset(env,'auto',nall,T,Tn) @@ -351,7 +365,7 @@ subroutine crest_ensemble_screening(env,tim) call rmrfw('crest_rotamers_') call optlev_to_multilev(3.0d0,multilevel) call crest_multilevel_oloop(env,ensnam,multilevel,0) - if(env%iostatus_meta .ne. 0 ) return + if (env%iostatus_meta .ne. 0) return !>--- printout call catdel('cregen.out.tmp') @@ -362,7 +376,6 @@ subroutine crest_ensemble_screening(env,tim) !>--- clean up call screen_cleanup - !========================================================================================! call tim%stop(14) return diff --git a/src/algos/scan.f90 b/src/algos/scan.f90 index 7f79dab5..2460aadf 100644 --- a/src/algos/scan.f90 +++ b/src/algos/scan.f90 @@ -74,7 +74,7 @@ subroutine crest_scan(env,tim) !========================================================================================! allocate (grad(3,mol%nat),source=0.0_wp) - calc = env%calc + call calc%copy(env%calc) calcclean = env%calc !>--- initialize scanning diff --git a/src/algos/setuptest.f90 b/src/algos/setuptest.f90 index c53e2bc3..f7fe77d4 100644 --- a/src/algos/setuptest.f90 +++ b/src/algos/setuptest.f90 @@ -88,7 +88,7 @@ subroutine trialMD_calculator(env) if (allocated(env%ref%wbo)) then !> should be allocated from main program MDSTART%shk%wbo = env%ref%wbo else !> otherwise, obtain from scratch - tmpcalc = env%calc + call tmpcalc%copy(env%calc) mol = molstart tmpcalc%calcs(1)%rdwbo = .true. !> obtain WBOs allocate (grd(3,mol%nat)) @@ -128,9 +128,6 @@ subroutine trialMD_calculator(env) !>--- Restore initial starting geometry mol = molstart -!>--- Restore clean calculation state - !env%calc = calcstart - !call env%calc%copy(calcstart) !>--- Modify MD output trajectory MD = MDSTART @@ -312,7 +309,7 @@ subroutine trialOPT_calculator(env) call env%ref%to(mol) call env%ref%to(molopt) allocate (grd(3,mol%nat),source=0.0_wp) - tmpcalc = env%calc !> create copy of calculator + call tmpcalc%copy(env%calc) !> create copy of calculator tmpcalc%optlev = -1 !> set loose convergence thresholds !>--- perform geometry optimization diff --git a/src/algos/singlepoint.f90 b/src/algos/singlepoint.f90 index 6fb67e27..b1e279d0 100644 --- a/src/algos/singlepoint.f90 +++ b/src/algos/singlepoint.f90 @@ -35,6 +35,7 @@ subroutine crest_singlepoint(env,tim) use crest_calculator use strucrd use gradreader_module,only:write_engrad + use iomod,only:colorify implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim @@ -52,13 +53,14 @@ subroutine crest_singlepoint(env,tim) character(len=*),parameter :: partial = '∂E/∂' !========================================================================================! write (stdout,*) - !call system('figlet singlepoint') - write (stdout,*) " _ _ _ _ " - write (stdout,*) " ___(_)_ __ __ _| | ___ _ __ ___ (_)_ __ | |_ " - write (stdout,*) "/ __| | '_ \ / _` | |/ _ \ '_ \ / _ \| | '_ \| __|" - write (stdout,*) "\__ \ | | | | (_| | | __/ |_) | (_) | | | | | |_ " - write (stdout,*) "|___/_|_| |_|\__, |_|\___| .__/ \___/|_|_| |_|\__|" - write (stdout,*) " |___/ |_| " + write (stdout,*) colorify(" ██ ██ ██ ██ ","gold") + write (stdout,*) colorify(" ░░ █████ ░██ ██████ ░░ ░██ ","gold") + write (stdout,*) colorify(" ██████ ██ ███████ ██░░░██ ░██ █████ ░██░░░██ ██████ ██ ███████ ██████","gold") + write (stdout,*) colorify(" ██░░░░ ░██░░██░░░██░██ ░██ ░██ ██░░░██░██ ░██ ██░░░░██░██░░██░░░██░░░██░ ","gold") + write (stdout,*) colorify("░░█████ ░██ ░██ ░██░░██████ ░██░███████░██████ ░██ ░██░██ ░██ ░██ ░██ ","gold") + write (stdout,*) colorify(" ░░░░░██░██ ░██ ░██ ░░░░░██ ░██░██░░░░ ░██░░░ ░██ ░██░██ ░██ ░██ ░██ ","gold") + write (stdout,*) colorify(" ██████ ░██ ███ ░██ █████ ███░░██████░██ ░░██████ ░██ ███ ░██ ░░██ ","gold") + write (stdout,*) colorify("░░░░░░ ░░ ░░░ ░░ ░░░░░ ░░░ ░░░░░░ ░░ ░░░░░░ ░░ ░░░ ░░ ░░ ","gold") write (stdout,*) !========================================================================================! call new_ompautoset(env,'max',0,T,Tn) @@ -76,7 +78,7 @@ subroutine crest_singlepoint(env,tim) write (stdout,'(a)') allocate (grad(3,mol%nat),source=0.0_wp) - calc = env%calc + call calc%copy(env%calc) calc%calcs(:)%prstdout = .true. !>--- print some info about the calculation @@ -183,7 +185,7 @@ subroutine crest_xtbsp(env,xtblevel,molin) !>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<---- read the input ensemble call rdensembleparam(ensnam,nat,nall) - if (nall .lt. 1)then + if (nall .lt. 1) then write (stdout,*) '**ERROR** empty ensemble file.' env%iostatus_meta = status_input return - endif + end if allocate (xyz(3,nat,nall),at(nat),eread(nall)) call rdensemble(ensnam,nat,nall,at,xyz,eread) !>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<< Date: Sat, 30 May 2026 21:07:27 +0200 Subject: [PATCH 352/374] cosmetic banner change for sp,opt,numhess --- src/algos/dynamics.f90 | 18 +++++++++--------- src/algos/numhess.f90 | 24 +++++++++++++----------- src/algos/optimization.f90 | 18 +++++++++--------- src/algos/singlepoint.f90 | 16 ++++++++-------- 4 files changed, 39 insertions(+), 37 deletions(-) diff --git a/src/algos/dynamics.f90 b/src/algos/dynamics.f90 index b0de3158..e863b709 100644 --- a/src/algos/dynamics.f90 +++ b/src/algos/dynamics.f90 @@ -24,7 +24,7 @@ subroutine crest_moleculardynamics(env,tim) use strucrd use dynamics_module use shake_module - use iomod, only: colorify + use iomod,only:colorify implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim @@ -43,14 +43,14 @@ subroutine crest_moleculardynamics(env,tim) character(len=*),parameter :: trjf = 'crest_dynamics.trj.xyz' !========================================================================================! write (stdout,*) - write (stdout,*) colorify(" ██ ██ ","gold") - write (stdout,*) colorify(" ░██ ██ ██ ░░ ","gold") - write (stdout,*) colorify(" ░██ ░░██ ██ ███████ ██████ ██████████ ██ █████ ██████","gold") - write (stdout,*) colorify(" ██████ ░░███ ░░██░░░██ ░░░░░░██ ░░██░░██░░██░██ ██░░░██ ██░░░░ ","gold") - write (stdout,*) colorify(" ██░░░██ ░██ ░██ ░██ ███████ ░██ ░██ ░██░██░██ ░░ ░░█████ ","gold") - write (stdout,*) colorify("░██ ░██ ██ ░██ ░██ ██░░░░██ ░██ ░██ ░██░██░██ ██ ░░░░░██","gold") - write (stdout,*) colorify("░░██████ ██ ███ ░██░░████████ ███ ░██ ░██░██░░█████ ██████ ","gold") - write (stdout,*) colorify(" ░░░░░░ ░░ ░░░ ░░ ░░░░░░░░ ░░░ ░░ ░░ ░░ ░░░░░ ░░░░░░ ","gold") + write (stdout,*) " ------------------------------------------------- " + write (stdout,*) " ##### # # # # ## # # # #### #### " + write (stdout,*) " # # # # ## # # # ## ## # # # # " + write (stdout,*) " # # # # # # # # # ## # # # #### " + write (stdout,*) " # # # # # # ###### # # # # # " + write (stdout,*) " # # # # ## # # # # # # # # # " + write (stdout,*) " ##### # # # # # # # # #### #### " + write (stdout,*) " ------------------------------------------------- " write (stdout,*) !========================================================================================! diff --git a/src/algos/numhess.f90 b/src/algos/numhess.f90 index e7bf0d33..0c098076 100644 --- a/src/algos/numhess.f90 +++ b/src/algos/numhess.f90 @@ -37,7 +37,7 @@ subroutine crest_numhess(env,tim) use xtb_sc use oniom_hessian use ir_spectrum - use iomod, only: colorify + use iomod,only:colorify implicit none type(systemdata),intent(inout) :: env @@ -52,21 +52,23 @@ subroutine crest_numhess(env,tim) real(wp),allocatable :: ohess(:,:),ofreq(:),grad0(:,:),energies0(:) real(wp),allocatable :: ir_int(:) character(len=60) :: atmp -!========================================================================================! - call tim%start(15,'Numerical Hessian') + !========================================================================================! write (stdout,*) - write (stdout,*) colorify(" ██ ","gold") - write (stdout,*) colorify(" ░██ ","gold") - write (stdout,*) colorify(" ███████ ██ ██ ██████████ ░██ █████ ██████ ██████ ","gold") - write (stdout,*) colorify("░░██░░░██░██ ░██░░██░░██░░██░██████ ██░░░██ ██░░░░ ██░░░░ ","gold") - write (stdout,*) colorify(" ░██ ░██░██ ░██ ░██ ░██ ░██░██░░░██░███████░░█████ ░░█████ ","gold") - write (stdout,*) colorify(" ░██ ░██░██ ░██ ░██ ░██ ░██░██ ░██░██░░░░ ░░░░░██ ░░░░░██ ","gold") - write (stdout,*) colorify(" ███ ░██░░██████ ███ ░██ ░██░██ ░██░░██████ ██████ ██████ ","gold") - write (stdout,*) colorify("░░░ ░░ ░░░░░░ ░░░ ░░ ░░ ░░ ░░ ░░░░░░ ░░░░░░ ░░░░░░ ","gold") + write (stdout,*) " ------------------------------------------------ " + write (stdout,*) " # # # # # # # # ###### #### ### " + write (stdout,*) " ## # # # ## ## # # # # # " + write (stdout,*) " # # # # # # ## # ###### ##### #### #### " + write (stdout,*) " # # # # # # # # # # # # " + write (stdout,*) " # ## # # # # # # # # # # # " + write (stdout,*) " # # #### # # # # ###### #### #### " + write (stdout,*) " ------------------------------------------------ " write (stdout,*) +!========================================================================================! + call tim%start(15,'Numerical Hessian') + call env%ref%to(mol) write (stdout,*) write (stdout,*) 'Input structure:' diff --git a/src/algos/optimization.f90 b/src/algos/optimization.f90 index ea7ae7d1..be544fc7 100644 --- a/src/algos/optimization.f90 +++ b/src/algos/optimization.f90 @@ -32,7 +32,7 @@ subroutine crest_optimization(env,tim) use crest_calculator use strucrd use optimize_module - use iomod, only:colorify + use iomod,only:colorify implicit none type(systemdata),intent(inout) :: env type(timer),intent(inout) :: tim @@ -50,14 +50,14 @@ subroutine crest_optimization(env,tim) ! ══════════════════════════════════════════════════════════════════════════════ write (stdout,*) - write (stdout,*) colorify(" ██ ██ ██ ","gold") - write (stdout,*) colorify(" ██████ ░██ ░░ ░░ ","gold") - write (stdout,*) colorify(" ██████ ░██░░░██ ██████ ██ ██████████ ██ ██████ █████ ","gold") - write (stdout,*) colorify(" ██░░░░██░██ ░██░░░██░ ░██░░██░░██░░██░██░░░░██ ██░░░██","gold") - write (stdout,*) colorify("░██ ░██░██████ ░██ ░██ ░██ ░██ ░██░██ ██ ░███████","gold") - write (stdout,*) colorify("░██ ░██░██░░░ ░██ ░██ ░██ ░██ ░██░██ ██ ░██░░░░ ","gold") - write (stdout,*) colorify("░░██████ ░██ ░░██ ░██ ███ ░██ ░██░██ ██████░░██████","gold") - write (stdout,*) colorify(" ░░░░░░ ░░ ░░ ░░ ░░░ ░░ ░░ ░░ ░░░░░░ ░░░░░░ ","gold") + write (stdout,*) " -------------------------------------------- " + write (stdout,*) " #### ##### ##### # # # # ###### ###### " + write (stdout,*) " # # # # # # ## ## # # # " + write (stdout,*) " # # # # # # # ## # # # ##### " + write (stdout,*) " # # ##### # # # # # # # " + write (stdout,*) " # # # # # # # # # # " + write (stdout,*) " #### # # # # # # ###### ###### " + write (stdout,*) " -------------------------------------------- " write (stdout,*) !========================================================================================! diff --git a/src/algos/singlepoint.f90 b/src/algos/singlepoint.f90 index b1e279d0..a5ffa8aa 100644 --- a/src/algos/singlepoint.f90 +++ b/src/algos/singlepoint.f90 @@ -53,14 +53,14 @@ subroutine crest_singlepoint(env,tim) character(len=*),parameter :: partial = '∂E/∂' !========================================================================================! write (stdout,*) - write (stdout,*) colorify(" ██ ██ ██ ██ ","gold") - write (stdout,*) colorify(" ░░ █████ ░██ ██████ ░░ ░██ ","gold") - write (stdout,*) colorify(" ██████ ██ ███████ ██░░░██ ░██ █████ ░██░░░██ ██████ ██ ███████ ██████","gold") - write (stdout,*) colorify(" ██░░░░ ░██░░██░░░██░██ ░██ ░██ ██░░░██░██ ░██ ██░░░░██░██░░██░░░██░░░██░ ","gold") - write (stdout,*) colorify("░░█████ ░██ ░██ ░██░░██████ ░██░███████░██████ ░██ ░██░██ ░██ ░██ ░██ ","gold") - write (stdout,*) colorify(" ░░░░░██░██ ░██ ░██ ░░░░░██ ░██░██░░░░ ░██░░░ ░██ ░██░██ ░██ ░██ ░██ ","gold") - write (stdout,*) colorify(" ██████ ░██ ███ ░██ █████ ███░░██████░██ ░░██████ ░██ ███ ░██ ░░██ ","gold") - write (stdout,*) colorify("░░░░░░ ░░ ░░░ ░░ ░░░░░ ░░░ ░░░░░░ ░░ ░░░░░░ ░░ ░░░ ░░ ░░ ","gold") + write (stdout,*) " ------------------------------------------------------------------ " + write (stdout,*) " #### # # # #### # ###### ##### #### # # # ##### " + write (stdout,*) " # # ## # # # # # # # # # # ## # # " + write (stdout,*) " #### # # # # # # ##### # # # # # # # # # " + write (stdout,*) " # # # # # # ### # # ##### # # # # # # # " + write (stdout,*) " # # # # ## # # # # # # # # # ## # " + write (stdout,*) " #### # # # #### ###### ###### # #### # # # # " + write (stdout,*) " ------------------------------------------------------------------ " write (stdout,*) !========================================================================================! call new_ompautoset(env,'max',0,T,Tn) From a2baea841e2a87007a86c6c81462a5f9c3b294e6 Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 1 Jun 2026 14:51:09 +0200 Subject: [PATCH 353/374] =?UTF-8?q?Static=20linkage=20of=20subprojects=20i?= =?UTF-8?q?n=20meson=20build=20by=20default=20(=E2=89=A0full=20static=20bu?= =?UTF-8?q?ild)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- config/meson.build | 5 +++++ meson.build | 16 ++++++++-------- meson_options.txt | 10 ++++++++++ 3 files changed, 23 insertions(+), 8 deletions(-) diff --git a/config/meson.build b/config/meson.build index 169ad3eb..45554499 100644 --- a/config/meson.build +++ b/config/meson.build @@ -107,6 +107,11 @@ endif static_build = get_option('static') +# Static subproject linking: selects static archives for subproject deps +# (tblite, gfn0, toml-f, …) without the fully-static `-static` syslib linking. +# A fully static build (-Dstatic) implies it. +link_deps_static = static_build or get_option('static-deps') + if fc_id == 'intel-llvm' ## -lifport : POSIX intrinsics (getcwd, chdir, …) not auto-linked by ifx. ## In static builds -static-intel already bundles libifport.a, so diff --git a/meson.build b/meson.build index c2643540..898b8cc5 100644 --- a/meson.build +++ b/meson.build @@ -258,7 +258,7 @@ tomlf_dep = dependency('toml-f', version : '>=0.2.4', fallback : ['toml-f', 'tomlf_dep'], required : get_option('toml-f'), - static : static_build, + static : link_deps_static, ) with_tomlf = tomlf_dep.found() if with_tomlf @@ -269,7 +269,7 @@ tblite_dep = dependency('tblite', version : '>=0.3.0', fallback : ['tblite', 'tblite_dep'], required : get_option('tblite'), - static : static_build, + static : link_deps_static, default_options: ['api=false'], ) with_tblite = tblite_dep.found() @@ -288,7 +288,7 @@ endif gfnff_dep = dependency('gfnff', fallback : ['gfnff', 'gfnff_dep'], required : get_option('gfnff'), - static : static_build, + static : link_deps_static, default_options : ['tests=false'], ) with_gfnff = gfnff_dep.found() @@ -299,7 +299,7 @@ endif gfn0_dep = dependency('gfn0', fallback : ['gfn0', 'gfn0_dep'], required : get_option('gfn0'), - static : static_build, + static : link_deps_static, ) with_gfn0 = gfn0_dep.found() if with_gfn0 @@ -309,7 +309,7 @@ endif libpvol_dep = dependency('libpvol', fallback : ['pvol', 'libpvol_dep'], required : get_option('libpvol'), - static : static_build, + static : link_deps_static, default_options : ['tests=false'], ) with_libpvol = libpvol_dep.found() @@ -320,7 +320,7 @@ endif lwoniom_dep = dependency('lwoniom', fallback : ['lwoniom', 'lwoniom_dep'], required : get_option('lwoniom'), - static : static_build, + static : link_deps_static, ) with_lwoniom = lwoniom_dep.found() if with_lwoniom @@ -330,7 +330,7 @@ endif fmlip_dep = dependency('fmlip_relay', fallback : ['fmlip_relay', 'fmlip_relay_dep'], required : get_option('fmlip-relay'), - static : static_build, + static : link_deps_static, ) with_fmlip = fmlip_dep.found() if with_fmlip @@ -342,7 +342,7 @@ if get_option('tests') version : '>=0.4.0', fallback : ['test-drive', 'testdrive_dep'], required : true, - static : static_build, + static : link_deps_static, ) endif diff --git a/meson_options.txt b/meson_options.txt index d34d5c81..acdfef5d 100644 --- a/meson_options.txt +++ b/meson_options.txt @@ -41,6 +41,16 @@ option('static', description : 'Attempt a fully static binary (includes OpenMP + LAPACK runtime)', ) +# ── Static subproject linking ───────────────────────────────────────────────── +# Link subprojects (tblite, gfn0, gfnff, pvol, lwoniom, toml-f, …) as static +# archives without forcing a fully static binary. System runtimes stay dynamic. +# Implied by -Dstatic=true. +option('static-deps', + type : 'boolean', + value : true, + description : 'Link subprojects statically without a fully static binary', +) + # ── Optional computational chemistry libraries ───────────────────────────────── option('tblite', type : 'feature', From bee72b899a2192ea775da86e0562371346f267cb Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 1 Jun 2026 15:02:26 +0200 Subject: [PATCH 354/374] allow custom name for optimizer logfile --- src/optimize/ancopt.f90 | 8 +++++--- src/optimize/gd.f90 | 8 +++++--- src/optimize/lbfgs.f90 | 6 ++++-- src/optimize/newton_raphson.f90 | 8 +++++--- src/optimize/optimize_module.f90 | 32 ++++++++++++++++++++++++-------- src/optimize/rfo.f90 | 8 +++++--- 6 files changed, 48 insertions(+), 22 deletions(-) diff --git a/src/optimize/ancopt.f90 b/src/optimize/ancopt.f90 index d2b9c6f7..7a140078 100644 --- a/src/optimize/ancopt.f90 +++ b/src/optimize/ancopt.f90 @@ -47,7 +47,7 @@ module ancopt_module !========================================================================================! !========================================================================================! - subroutine ancopt(mol,calc,etot,grd,pr,wr,iostatus) + subroutine ancopt(mol,calc,etot,grd,pr,wr,iostatus,logfile) !************************************************************************* !> subroutine ancopt !> Implementation of the Aproximate Normal Coordinate (ANC) optimizer @@ -62,9 +62,10 @@ subroutine ancopt(mol,calc,etot,grd,pr,wr,iostatus) !> on output final energy !> grd - Cartesian gradient !> pr - printout bool -!> wr - logfile (crestopt.log.xyz) bool +!> wr - logfile bool (name given by logfile, default crestopt.log.xyz) !> iostatus - return status of the routine !> (success=0, error<0, not converged>0) +!> logfile - name of the trajectory logfile to write when wr is set !!*********************************************************************** implicit none !> INPUT/OUTPUT @@ -75,6 +76,7 @@ subroutine ancopt(mol,calc,etot,grd,pr,wr,iostatus) logical,intent(in) :: pr logical,intent(in) :: wr integer,intent(out) :: iostatus + character(len=*),intent(in) :: logfile !> LOCAL integer :: tight real(wp) :: eel @@ -173,7 +175,7 @@ subroutine ancopt(mol,calc,etot,grd,pr,wr,iostatus) !>--- initialize .log file, if desired ilog = 942 if (wr) then - open (newunit=ilog,file='crestopt.log.xyz') + open (newunit=ilog,file=logfile) end if !>--- The ANCOPT iteration loop. "iter" is updated in relax() subroutine diff --git a/src/optimize/gd.f90 b/src/optimize/gd.f90 index 17f5a653..f176f11a 100644 --- a/src/optimize/gd.f90 +++ b/src/optimize/gd.f90 @@ -42,7 +42,7 @@ module gradientdescent_module !========================================================================================! !========================================================================================! - subroutine gradientdescent(mol,calc,etot,grd,pr,wr,iostatus) + subroutine gradientdescent(mol,calc,etot,grd,pr,wr,iostatus,logfile) !************************************************************************* !> subroutine gradientdescent !> Implementation of a simple gradient descent algorithm @@ -57,9 +57,10 @@ subroutine gradientdescent(mol,calc,etot,grd,pr,wr,iostatus) !> on output final energy !> grd - Cartesian gradient !> pr - printout bool -!> wr - logfile (crestopt.log.xyz) bool +!> wr - logfile bool (name given by logfile, default crestopt.log.xyz) !> iostatus - return status of the routine !> (success=0, error<0, not converged>0) +!> logfile - name of the trajectory logfile to write when wr is set !!*********************************************************************** implicit none !> INPUT/OUTPUT @@ -70,6 +71,7 @@ subroutine gradientdescent(mol,calc,etot,grd,pr,wr,iostatus) logical,intent(in) :: pr logical,intent(in) :: wr integer,intent(out) :: iostatus + character(len=*),intent(in) :: logfile !> LOCAL integer :: tight real(wp) :: eel @@ -165,7 +167,7 @@ subroutine gradientdescent(mol,calc,etot,grd,pr,wr,iostatus) !>--- initialize .log file, if desired ilog = 942 if (wr) then - open (newunit=ilog,file='crestopt.log.xyz') + open (newunit=ilog,file=logfile) end if !>--- The gradient descent iteration loop. "iter" diff --git a/src/optimize/lbfgs.f90 b/src/optimize/lbfgs.f90 index 5fe2ee86..f338a02a 100644 --- a/src/optimize/lbfgs.f90 +++ b/src/optimize/lbfgs.f90 @@ -117,7 +117,7 @@ end function lbfgs_direction !========================================================================================! - subroutine lbfgs_optimize(mol,calc,etot,grd,pr,io) + subroutine lbfgs_optimize(mol,calc,etot,grd,pr,io,logfile) !************************************************************************** !* L-BFGS Optimization Routine !* @@ -134,6 +134,7 @@ subroutine lbfgs_optimize(mol,calc,etot,grd,pr,io) !* the history using a shifting strategy when full. !* !* @param io Integer. Output status variable (0 indicates success). + !* @param logfile name of the trajectory logfile (default crestopt.log.xyz). !************************************************************************** implicit none !> INPUT @@ -142,6 +143,7 @@ subroutine lbfgs_optimize(mol,calc,etot,grd,pr,io) real(wp),intent(inout) :: etot real(wp),intent(inout) :: grd(3,mol%nat) logical,intent(in) :: pr + character(len=*),intent(in) :: logfile !> OUTPUT integer,intent(out) :: io !> LOCAL @@ -170,7 +172,7 @@ subroutine lbfgs_optimize(mol,calc,etot,grd,pr,io) converged = .false. mol%wrextxyz = calc%logextxyz - open (newunit=ilog,file='crestopt.log.xyz') + open (newunit=ilog,file=logfile) if(calc%logextxyz)then mol%gradient = grd endif diff --git a/src/optimize/newton_raphson.f90 b/src/optimize/newton_raphson.f90 index 35390a9e..2130bcc5 100644 --- a/src/optimize/newton_raphson.f90 +++ b/src/optimize/newton_raphson.f90 @@ -47,7 +47,7 @@ module newton_raphson_module !========================================================================================! !========================================================================================! - subroutine newton_raphson(mol,calc,etot,grd,pr,wr,iostatus) + subroutine newton_raphson(mol,calc,etot,grd,pr,wr,iostatus,logfile) !************************************************************************* !> subroutine rfopt !> Implementation of the standard rational function optimizer (RFO) @@ -62,9 +62,10 @@ subroutine newton_raphson(mol,calc,etot,grd,pr,wr,iostatus) !> on output final energy !> grd - Cartesian gradient !> pr - printout bool -!> wr - logfile (crestopt.log.xyz) bool +!> wr - logfile bool (name given by logfile, default crestopt.log.xyz) !> iostatus - return status of the routine !> (success=0, error<0, not converged>0) +!> logfile - name of the trajectory logfile to write when wr is set !!*********************************************************************** implicit none !> INPUT/OUTPUT @@ -75,6 +76,7 @@ subroutine newton_raphson(mol,calc,etot,grd,pr,wr,iostatus) logical,intent(in) :: pr logical,intent(in) :: wr integer,intent(out) :: iostatus + character(len=*),intent(in) :: logfile !> LOCAL integer :: tight real(wp) :: eel @@ -215,7 +217,7 @@ subroutine newton_raphson(mol,calc,etot,grd,pr,wr,iostatus) !>--- initialize .log file, if desired ilog = 942 if (wr) then - open (newunit=ilog,file='crestopt.log.xyz') + open (newunit=ilog,file=logfile) end if iter = 0 diff --git a/src/optimize/optimize_module.f90 b/src/optimize/optimize_module.f90 index eaffa170..dbb3ad05 100644 --- a/src/optimize/optimize_module.f90 +++ b/src/optimize/optimize_module.f90 @@ -49,13 +49,21 @@ module optimize_module !========================================================================================! !========================================================================================! - subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) + subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus,logfile) + !********************************************************************** + !* Driver that dispatches to the selected geometry optimizer engine. + !* + !* logfile - optional name for the step-by-step trajectory logfile; + !* defaults to 'crestopt.log.xyz' when absent. Only written + !* when the engine's wr flag is set. + !********************************************************************** implicit none !> Input type(coord) :: mol type(calcdata) :: calc logical,intent(in) :: pr logical,intent(in) :: wr + character(len=*),intent(in),optional :: logfile !> Output type(coord) :: molnew integer,intent(out) :: iostatus @@ -65,9 +73,17 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) integer :: nat3,io,idx,nrt real(wp),allocatable :: hess(:),g_hess(:), g_hess_full(:,:), int_temps(:) logical :: pr2 + character(len=:),allocatable :: logfile_l - - !write(stdout,*) "RUNNING AN OPT" + + !write(stdout,*) "RUNNING AN OPT" + + !> resolve the logfile name (default if not provided) + if (present(logfile)) then + logfile_l = logfile + else + logfile_l = 'crestopt.log.xyz' + end if iostatus = -1 !> do NOT overwrite original geometry @@ -100,20 +116,20 @@ subroutine optimize_geometry(mol,molnew,calc,etot,grd,pr,wr,iostatus) !> optimization select case (calc%opt_engine) case (0) - call ancopt(molnew,calc,etot,grd,pr,wr,iostatus) + call ancopt(molnew,calc,etot,grd,pr,wr,iostatus,logfile_l) case (1) !> l-bfgs goes here !write(stdout,'(a)') 'L-BFGS currently not implemented' !stop - call lbfgs_optimize(molnew,calc,etot,grd,pr,iostatus) + call lbfgs_optimize(molnew,calc,etot,grd,pr,iostatus,logfile_l) case (2) !> rfo goes here - call rfopt(molnew,calc,etot,grd,pr,wr,iostatus) + call rfopt(molnew,calc,etot,grd,pr,wr,iostatus,logfile_l) case (3) !> newton-raphson step goes here, this is a newton step with updated hessians, i.e. quasi Newton - call newton_raphson(molnew,calc,etot,grd,pr,wr,iostatus) + call newton_raphson(molnew,calc,etot,grd,pr,wr,iostatus,logfile_l) case (-1) - call gradientdescent(molnew,calc,etot,grd,pr,wr,iostatus) + call gradientdescent(molnew,calc,etot,grd,pr,wr,iostatus,logfile_l) case default write (stdout,'(a)') 'Unknown optimization engine!' stop diff --git a/src/optimize/rfo.f90 b/src/optimize/rfo.f90 index a5245dd0..a978999a 100644 --- a/src/optimize/rfo.f90 +++ b/src/optimize/rfo.f90 @@ -47,7 +47,7 @@ module rfo_module !========================================================================================! !========================================================================================! - subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) + subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus,logfile) !************************************************************************* !> subroutine rfopt !> Implementation of the standard rational function optimizer (RFO) @@ -62,9 +62,10 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !> on output final energy !> grd - Cartesian gradient !> pr - printout bool -!> wr - logfile (crestopt.log.xyz) bool +!> wr - logfile bool (name given by logfile, default crestopt.log.xyz) !> iostatus - return status of the routine !> (success=0, error<0, not converged>0) +!> logfile - name of the trajectory logfile to write when wr is set !!*********************************************************************** implicit none !> INPUT/OUTPUT @@ -75,6 +76,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) logical,intent(in) :: pr logical,intent(in) :: wr integer,intent(out) :: iostatus + character(len=*),intent(in) :: logfile !> LOCAL integer :: tight real(wp) :: eel @@ -224,7 +226,7 @@ subroutine rfopt(mol,calc,etot,grd,pr,wr,iostatus) !>--- initialize .log file, if desired ilog = 942 if (wr) then - open (newunit=ilog,file='crestopt.log.xyz') + open (newunit=ilog,file=logfile) end if !>--- The ANCOPT iteration loop. "iter" is updated in relax() subroutine From 6be326d4295b2949b0881a1f5c79d25cd34b903d Mon Sep 17 00:00:00 2001 From: Philipp Pracht Date: Mon, 1 Jun 2026 16:24:08 +0200 Subject: [PATCH 355/374] Simplified orca driver via cli --- src/calculator/calc_type.f90 | 2 +- src/classes.f90 | 2 ++ src/confparse.f90 | 27 +++++++++++++++++++++++++++ src/legacy_wrappers.f90 | 13 ++++++++++++- src/printouts.f90 | 2 ++ 5 files changed, 44 insertions(+), 2 deletions(-) diff --git a/src/calculator/calc_type.f90 b/src/calculator/calc_type.f90 index 34c72370..1cca028f 100644 --- a/src/calculator/calc_type.f90 +++ b/src/calculator/calc_type.f90 @@ -1554,7 +1554,7 @@ subroutine create_calclevel_shortcut(self,levelstring, & self%id = jobtype%xtbsys self%other = '--gxtb' end if - case ('orca') + case ('orca','--orca') self%id = jobtype%orca case ('generic') diff --git a/src/classes.f90 b/src/classes.f90 index a37195b5..b3e4afbe 100644 --- a/src/classes.f90 +++ b/src/classes.f90 @@ -417,6 +417,8 @@ module crest_data character(len=:),allocatable :: solv !> the entrie gbsa flag including solvent character(len=20) :: gfnver = '' !> GFN version character(len=20) :: gfnver2 = '' !> GFN version (multilevel) + character(len=:),allocatable :: orca_template !> ORCA input template (--orca) + character(len=:),allocatable :: orca_cmd !> ORCA executable path (--orca) character(len=40) :: rerank_lvl = '' !> method for post-search SP reranking (--rerank) character(len=40) :: reopt_lvl = '' !> method for post-search geo-opt standalone (--reopt) character(len=20) :: lmover = '' !> GFN version for LMO computation in xtb_lmo subroutine diff --git a/src/confparse.f90 b/src/confparse.f90 index 004e8f6b..e6c955bc 100644 --- a/src/confparse.f90 +++ b/src/confparse.f90 @@ -1441,6 +1441,33 @@ subroutine parseflags(env,arg,nra) env%gfnver = '--gxtb' write (stdout,'(2x,a)') 'Note: --gxtb_dev is deprecated, redirecting to --gxtb.' + case ('-orca') !> set up a single ORCA driver level: --orca