diff --git a/.gitmodules b/.gitmodules
index 89c3b98c8c19ca24ee0c473576be089201d41144..47e4f90df0d5bfb3135e18f9cb40dab76c346374 100644
--- a/.gitmodules
+++ b/.gitmodules
@@ -4,3 +4,6 @@
[submodule "third_party/Spglib"]
path = third_party/Spglib
url = https://github.com/spglib/spglib.git
+[submodule "third_party/fortran_stdlib"]
+ path = third_party/fortran_stdlib
+ url = https://github.com/fortran-lang/stdlib
diff --git a/CMakeLists.txt b/CMakeLists.txt
index 9d1b0e54509a2229b9aa4b928f79357199b75e60..2927c1e0826bb8ed01cf2e0a84660fd14de75660 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -233,6 +233,11 @@ Octopus_FetchContent_Declare(Spglib
GIT_TAG v2.1.0
FIND_PACKAGE_ARGS MODULE COMPONENTS Fortran
)
+Octopus_FetchContent_Declare(fortran_stdlib
+ GIT_REPOSITORY https://github.com/fortran-lang/stdlib
+ GIT_TAG master
+ FIND_PACKAGE_ARGS MODULE
+)
# Optional dependencies
find_package(netCDF-Fortran MODULE)
diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt
index 0fb6035a127f5f73bf2768947add8b5c4dbf7a57..493d12b3b6f2f6fcaaefe6afb0b20a46d089cc15 100644
--- a/src/CMakeLists.txt
+++ b/src/CMakeLists.txt
@@ -30,6 +30,7 @@ list(APPEND OctopusFolderObjects
classical
communication
electrons
+ extensions
grid
hamiltonian
interactions
diff --git a/src/Makefile.am b/src/Makefile.am
index 444d68d7da3d1c1c068a21fca7237163b6f446c8..9b57ede94f95e4a23135e630305d4e3f4cb17b69 100644
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -55,6 +55,7 @@ basic_f_srcs = \
basic/debug.F90 \
basic/gdlib.F90 \
basic/global.F90 \
+ basic/global_h.F90 \
basic/hardware.F90 \
basic/heap.F90 \
basic/iihash.F90 \
@@ -466,9 +467,10 @@ hamiltonian_f_srcs = \
hamiltonian/exchange_operator.F90 \
hamiltonian/xc_functional.F90 \
hamiltonian/gauge_field.F90 \
- hamiltonian/hamiltonian_abst.F90 \
+ hamiltonian/hamiltonian_abst_h.F90 \
hamiltonian/hamiltonian_elec_base.F90 \
hamiltonian/hamiltonian_elec.F90 \
+ hamiltonian/hamiltonian_elec_h.F90 \
hamiltonian/hgh_projector.F90 \
hamiltonian/hirshfeld.F90 \
hamiltonian/ion_interaction.F90 \
@@ -551,6 +553,7 @@ multisystem_f_srcs = \
multisystem/propagator_verlet.F90 \
multisystem/quantity.F90 \
multisystem/system.F90 \
+ multisystem/system_h.F90 \
multisystem/system_factory_abst.F90
multisystem_srcs = $(multisystem_f_srcs)
@@ -658,6 +661,7 @@ electrons_f_srcs = \
electrons/stress.F90 \
electrons/subspace.F90 \
electrons/electrons.F90 \
+ electrons/electrons_h.F90 \
electrons/v_ks.F90 \
electrons/x_fbe.F90 \
electrons/x_slater.F90 \
@@ -704,6 +708,7 @@ maxwell_f_srcs = \
maxwell/external_densities.F90 \
maxwell/external_waves.F90 \
maxwell/hamiltonian_mxll.F90 \
+ maxwell/hamiltonian_mxll_h.F90 \
maxwell/propagator_mxll.F90 \
maxwell/dispersive_medium.F90 \
maxwell/linear_medium.F90 \
@@ -722,6 +727,7 @@ scf_f_srcs = \
scf/criteria_factory.F90 \
scf/density_criterion.F90 \
scf/electrons_ground_state.F90 \
+ scf/electrons_ground_state_h.F90 \
scf/eigenval_criterion.F90 \
scf/energy_criterion.F90 \
scf/lcao.F90 \
@@ -729,7 +735,9 @@ scf_f_srcs = \
scf/mix.F90 \
scf/mixing_preconditioner.F90 \
scf/rdmft.F90 \
- scf/scf.F90 \
+ scf/scf_interface.F90 \
+ scf/scf_interface_h.F90 \
+ scf/scf_h.F90 \
scf/unocc.F90
scf_srcs = $(scf_f_srcs)
@@ -750,6 +758,7 @@ td_f_srcs = \
td/propagator_base.F90 \
td/propagator_cn.F90 \
td/propagator_elec.F90 \
+ td/propagator_elec_h.F90 \
td/propagator_etrs.F90 \
td/propagator_expmid.F90 \
td/propagator_magnus.F90 \
@@ -757,7 +766,9 @@ td_f_srcs = \
td/propagator_rk.F90 \
td/spectrum.F90 \
td/td_calc.F90 \
- td/td.F90 \
+ td/td_interface.F90 \
+ td/td_interface_h.F90 \
+ td/td_h.F90 \
td/td_write.F90 \
td/td_write_low.F90 \
td/propagation_ops_elec.F90
diff --git a/src/basic/CMakeLists.txt b/src/basic/CMakeLists.txt
index 96efa8109495d6eb432b7bd5321d845b121df6f3..dbc87ab05212470fa6003d764c6a601373e5347a 100644
--- a/src/basic/CMakeLists.txt
+++ b/src/basic/CMakeLists.txt
@@ -13,10 +13,13 @@ target_sources(Octopus_lib PRIVATE
cuda.F90
cuda_low.cc
debug.F90
+ dict.F90
+ dict_h.F90
gdlib.F90
gdlib_f.c
getopt_f.c
global.F90
+ global_h.F90
hardware.F90
heap.F90
iihash.F90
@@ -110,6 +113,7 @@ endif ()
if (TARGET GD::GD)
target_link_libraries(Octopus_lib PRIVATE GD::GD)
endif ()
+target_link_libraries(Octopus_lib PRIVATE fortran_stdlib)
if (OCTOPUS_INSTALL)
install(TARGETS Octopus_lib)
diff --git a/src/basic/dict.F90 b/src/basic/dict.F90
new file mode 100644
index 0000000000000000000000000000000000000000..ebc7502103a0d52854e0b964d4141952a243ca64
--- /dev/null
+++ b/src/basic/dict.F90
@@ -0,0 +1,170 @@
+submodule (dict_oct_m) impl
+ use stdlib_kinds, only: int8
+ use stdlib_hashmap_wrappers, only: fnv_1_hasher, key_type, other_type, get, set
+ implicit none
+
+ type raw_ptr_holder
+ class(*), pointer :: ptr
+ logical :: owning = .false.
+ contains
+ final :: raw_ptr_holder_end
+ end type raw_ptr_holder
+contains
+ subroutine raw_ptr_holder_end(this)
+ type(raw_ptr_holder), intent(inout) :: this
+
+ if (this%owning) then
+ if (associated(this%ptr)) then
+ deallocate(this%ptr)
+ end if
+ end if
+ end subroutine raw_ptr_holder_end
+
+ module subroutine dict_init(this)
+ class(dict_t), target, intent(inout) :: this
+
+ call this%dict%init(fnv_1_hasher)
+ ! TODO: Use these to check the data type
+ this%key_type = ""
+ this%value_type = ""
+ end subroutine dict_init
+
+ module subroutine dict_end(this)
+ type(dict_t), target, intent(in) :: this
+ end subroutine dict_end
+
+ module subroutine get_string_rawptr(this, key, value)
+ class(dict_t), intent(inout) :: this
+ character(*), intent(in) :: key
+ class(*), pointer, intent(out) :: value
+
+ type(key_type) :: k
+ type(other_type) :: v
+ class(*), allocatable :: holder
+
+ call set(k, [transfer(key, 1_int8, len(key))])
+
+ call this%dict%get_other_data(k, v)
+ call get(v, holder)
+
+ select type(holder)
+ class is (raw_ptr_holder)
+ value => holder%ptr
+ class default
+ stop 1
+ end select
+ end subroutine get_string_rawptr
+
+ module subroutine get_string_ptr_integer(this, key, value)
+ class(dict_t), intent(inout) :: this
+ character(*), intent(in) :: key
+ integer, pointer, intent(out) :: value
+
+ class(*), pointer :: raw_ptr
+
+ call this%get_raw_ptr(key, raw_ptr)
+ select type(raw_ptr)
+ type is (integer)
+ value => raw_ptr
+ class default
+ stop 1
+ end select
+ end subroutine get_string_ptr_integer
+
+ module subroutine get_string_obj(this, key, value)
+ class(dict_t), intent(inout) :: this
+ character(*), intent(in) :: key
+ class(*), allocatable, intent(out) :: value
+
+ type(key_type) :: k
+ type(other_type) :: v
+
+ call set(k, [transfer(key, 1_int8, len(key))])
+
+ call this%dict%get_other_data(k, v)
+ call get(v, value)
+ end subroutine get_string_obj
+
+ module subroutine set_string_target(this, key, value)
+ class(dict_t), intent(inout) :: this
+ character(*), intent(in) :: key
+ class(*), target, intent(in) :: value
+
+ type(key_type) :: k
+ type(other_type) :: v
+ type(raw_ptr_holder) :: holder
+ logical :: exists
+
+ holder%ptr => value
+ call set(k, [transfer(key, 1_int8, len(key))])
+ call set(v, holder)
+
+ call this%dict%map_entry(k, v, exists)
+ if (exists) then
+ call this%dict%set_other_data(k, v)
+ end if
+ end subroutine set_string_target
+
+ module subroutine move_string_target(this, key, value)
+ class(dict_t), intent(inout) :: this
+ character(*), intent(in) :: key
+ class(*), pointer, intent(inout) :: value
+
+ type(key_type) :: k
+ type(other_type) :: v
+ type(raw_ptr_holder) :: holder
+ logical :: exists
+
+ holder%ptr => value
+ call set(k, [transfer(key, 1_int8, len(key))])
+ call set(v, holder)
+
+ call this%dict%map_entry(k, v, exists)
+ if (exists) then
+ call this%dict%set_other_data(k, v)
+ end if
+ holder%owning = .true.
+ nullify(value)
+ end subroutine move_string_target
+
+ module subroutine set_string_obj(this, key, value)
+ class(dict_t), intent(inout) :: this
+ character(*), intent(in) :: key
+ class(*), intent(in) :: value
+
+ type(key_type) :: k
+ type(other_type) :: v
+ logical :: exists
+
+ call set(k, [transfer(key, 1_int8, len(key))])
+ call set(v, value)
+
+ call this%dict%map_entry(k, v, exists)
+ if (exists) then
+ call this%dict%set_other_data(k, v)
+ end if
+ end subroutine set_string_obj
+
+ module function has_key_string(this, key) result(res)
+ class(dict_t), intent(inout) :: this
+ character(*), intent(in) :: key
+ logical :: res
+
+ type(key_type) :: k
+
+ call set(k, [transfer(key, 1_int8, len(key))])
+
+ call this%dict%key_test(k, res)
+ end function has_key_string
+
+ module subroutine delete_key_string(this, key)
+ class(dict_t), intent(inout) :: this
+ character(*), intent(in) :: key
+
+ type(key_type) :: k
+
+ call set(k, [transfer(key, 1_int8, len(key))])
+
+ call this%dict%remove(k)
+ end subroutine delete_key_string
+end submodule impl
diff --git a/src/basic/dict_h.F90 b/src/basic/dict_h.F90
new file mode 100644
index 0000000000000000000000000000000000000000..c82b727fe9d0209b0311b1ee522dcf3b527ccd27
--- /dev/null
+++ b/src/basic/dict_h.F90
@@ -0,0 +1,110 @@
+module dict_oct_m
+ use stdlib_hashmaps, only: chaining_hashmap_type
+ implicit none
+ private
+
+ !> Basic dictionary wrapper
+ !!
+ !! Uses stdlib_hashmaps internally
+ type, public :: dict_t
+ private
+ character(:), allocatable :: key_type
+ character(:), allocatable :: value_type
+ type(chaining_hashmap_type) :: dict
+ contains
+ private
+ !> Constructor
+ procedure, public :: init => dict_init
+ !> Get the key item
+ generic, public :: get => get_string_obj
+ generic, public :: get_ptr => get_string_ptr_integer
+ generic, public :: get_raw_ptr => get_string_rawptr
+ !> Set the key item to the value
+ generic, public :: set_ptr => set_string_target
+ !> Set the key item to the value
+ generic, public :: set => set_string_obj
+ !> Set the key item to the value
+ generic, public :: move_ptr => move_string_target
+ !> Check if the key item exist
+ generic, public :: has_key => has_key_string
+ !> Delete the key item
+ generic, public :: delete_key => delete_key_string
+ procedure :: get_string_rawptr
+ procedure :: get_string_obj
+ procedure :: get_string_ptr_integer
+ procedure :: set_string_target
+ procedure :: set_string_obj
+ procedure :: move_string_target
+ procedure :: has_key_string
+ procedure :: delete_key_string
+ !> Destructor
+ final :: dict_end
+ end type dict_t
+
+ interface
+ !> Dictionary constructor
+ module subroutine dict_init(this)
+ class(dict_t), target, intent(inout) :: this
+ end subroutine dict_init
+
+ !> Dictionary destructor
+ module subroutine dict_end(this)
+ type(dict_t), target, intent(in) :: this
+ end subroutine dict_end
+
+ !> Get the raw pointer of the dict item with string type key
+ module subroutine get_string_rawptr(this, key, value)
+ class(dict_t), intent(inout) :: this
+ character(*), intent(in) :: key
+ class(*), pointer, intent(out) :: value
+ end subroutine get_string_rawptr
+
+ !> Get the raw pointer of the dict item with string type key
+ module subroutine get_string_ptr_integer(this, key, value)
+ class(dict_t), intent(inout) :: this
+ character(*), intent(in) :: key
+ integer, pointer, intent(out) :: value
+ end subroutine get_string_ptr_integer
+
+ !> Get a copy of the dict item with string type key
+ module subroutine get_string_obj(this, key, value)
+ class(dict_t), intent(inout) :: this
+ character(*), intent(in) :: key
+ class(*), allocatable, intent(out) :: value
+ end subroutine get_string_obj
+
+ !> Set the dict item with string type key to a raw pointer
+ module subroutine set_string_target(this, key, value)
+ class(dict_t), intent(inout) :: this
+ character(*), intent(in) :: key
+ class(*), target, intent(in) :: value
+ end subroutine set_string_target
+
+ !> Set the dict item with string type key to a raw pointer
+ module subroutine move_string_target(this, key, value)
+ class(dict_t), intent(inout) :: this
+ character(*), intent(in) :: key
+ class(*), pointer, intent(inout) :: value
+ end subroutine move_string_target
+
+ !> Set the dict item with string type key to a raw pointer
+ module subroutine set_string_obj(this, key, value)
+ class(dict_t), intent(inout) :: this
+ character(*), intent(in) :: key
+ class(*), intent(in) :: value
+ end subroutine set_string_obj
+
+ !> Check if the string type key exists
+ module function has_key_string(this, key) result(res)
+ class(dict_t), intent(inout) :: this
+ character(*), intent(in) :: key
+ logical :: res
+ end function has_key_string
+
+ !> Delete the string type key
+ module subroutine delete_key_string(this, key)
+ class(dict_t), intent(inout) :: this
+ character(*), intent(in) :: key
+ end subroutine delete_key_string
+ end interface
+end module dict_oct_m
diff --git a/src/basic/global.F90 b/src/basic/global.F90
index 1d610352feeae4e458fd0ea0dab83bbd2d2e6a34..1a69fb666f651884683a47eeeecd3f36603622f2 100644
--- a/src/basic/global.F90
+++ b/src/basic/global.F90
@@ -18,197 +18,21 @@
#include "global.h"
-module global_oct_m
- use, intrinsic :: iso_fortran_env
+submodule (global_oct_m) impl
+ use global_oct_m
use hardware_oct_m
use loct_oct_m
- use mpi_oct_m
use varinfo_oct_m
#ifdef HAVE_OPENMP
use omp_lib
#endif
+ use extension_oct_m
implicit none
-
- private
-
- !> Public types, variables and procedures.
- public :: &
- conf_t, &
- global_init, &
- global_end, &
- init_octopus_globals, &
- optional_default, &
- assert_die, &
- not_in_openmp, &
- operator(+), &
- bitand, &
- int32, int64, &
- real32, real64, &
- i4_to_i8, &
- i8_to_i4
- ! Make these kind variables from kind_oct_m public here so that they are
- ! available basically everywhere in the code. They still need to be in a
- ! separate module because they are also needed in some low-level modules.
-
- integer, public, parameter :: MAX_PATH_LEN=512
- integer, public, parameter :: MAX_OUTPUT_TYPES=44
-
- !> @brief Build configuration type
- type conf_t
- logical :: devel_version !< If true then allow unstable parts of the code
- logical :: report_memory
- character(len=256) :: share = SHARE_DIR !< Name of the share dir
- character(len=256) :: git_commit = GIT_COMMIT !< hash of latest git commit
- character(len=50) :: config_time = BUILD_TIME !< time octopus was configured
- character(len=20) :: version = PACKAGE_VERSION !< version number
- character(len=256) :: cc = CC !< C compiler
- character(len=256) :: cxx = CXX !< C++ compiler
- character(len=256) :: fc = FC !< Fortran compiler
- ! Split flag definitions in case they don`t fit in one line, following preprocessing
- character(len=256) :: cflags = &
- CFLAGS //&
- CFLAGS_EXTRA
- character(len=256) :: cxxflags = &
- CXXFLAGS //&
- CXXFLAGS_EXTRA
- character(len=256) :: fcflags = &
- FCFLAGS //&
- FCFLAGS_EXTRA
- integer :: target_states_block_size = -1
- contains
- procedure :: init => conf_init
- end type conf_t
-
- !> Global instance of Octopus configuration
- type(conf_t), public :: conf
-
- real(real64), public, parameter :: R_SMALL = 1e-8_real64
-
- !> Minimal distance between two distinguishable atoms
- real(real64), public, parameter :: R_MIN_ATOM_DIST = 1e-3_real64
-
- !> some mathematical constants
- real(real64), public, parameter :: M_Pi = 3.1415926535897932384626433832795029_real64
- real(real64), public, parameter :: M_E = 2.7182818284590452353602874713526625_real64
- real(real64), public, parameter :: M_ZERO = 0.0_real64
- real(real64), public, parameter :: M_ONE = 1.0_real64
- real(real64), public, parameter :: M_TWO = 2.0_real64
- real(real64), public, parameter :: M_THREE = 3.0_real64
- real(real64), public, parameter :: M_FOUR = 4.0_real64
- real(real64), public, parameter :: M_FIVE = 5.0_real64
- real(real64), public, parameter :: M_HALF = 0.5_real64
- real(real64), public, parameter :: M_THIRD = M_ONE/M_THREE
- real(real64), public, parameter :: M_TWOTHIRD = M_TWO/M_THREE
- real(real64), public, parameter :: M_FOURTH = M_ONE/M_FOUR
- complex(real64), public, parameter :: M_z0 = (0.0_real64, 0.0_real64)
- complex(real64), public, parameter :: M_z1 = (1.0_real64, 0.0_real64)
- complex(real64), public, parameter :: M_z2 = (2.0_real64, 0.0_real64)
- complex(real64), public, parameter :: M_z2I = (0.0_real64, 2.0_real64)
- complex(real64), public, parameter :: M_zI = (0.0_real64, 1.0_real64)
-
- real(real64), public, parameter :: M_EPSILON = epsilon(M_ONE)
- real(real64), public, parameter :: M_TINY = tiny(M_ONE)
- real(real64), public, parameter :: M_HUGE = huge(M_ONE)
- real(real64), public, parameter :: M_MIN_EXP_ARG = -650_real64
- real(real64), public, parameter :: M_MAX_EXP_ARG = 700_real64
-
- !> Minimal occupation that is considered to be non-zero
- real(real64), public, parameter :: M_MIN_OCC = 1.0e-10_real64
- !> Minimal density that is considered to be non-zero
- real(real64), public, parameter :: M_MIN_DENSITY = 1.0e-20_real64
-
-
- !> some physical constants
- real(real64), public, parameter :: P_a_B = 0.52917720859_real64
- real(real64), public, parameter :: P_Ang = M_ONE / P_a_B
- real(real64), public, parameter :: P_Ry = 13.60569193_real64
- real(real64), public, parameter :: P_eV = M_ONE / P_Ry
- real(real64), public, parameter :: P_Kb = 8.617343e-5_real64/(M_TWO*P_Ry) !< Boltzmann constant in Ha/K
- real(real64), public, parameter :: P_c = 137.035999679_real64
- !< Electron gyromagnetic ratio, see Phys. Rev. Lett. 130, 071801 (2023)
- real(real64), public, parameter :: P_g = 2.00231930436118_real64
- real(real64), public, parameter :: P_PROTON_CHARGE = -1.0_real64
- real(real64), public, parameter :: P_ep = M_ONE/(M_FOUR*M_Pi)
- real(real64), public, parameter :: P_mu = M_FOUR*M_PI/(P_c**2)
-
- !> the standard input and output
- integer, public :: stderr, stdin, stdout
-
- !> global epoch time (time at startup)
- integer, public :: s_epoch_sec, s_epoch_usec
-
- !> The stack.
- character(len=80), public :: sub_stack(50)
- real(real64), public :: time_stack(50)
- integer, public :: no_sub_stack = 0
-
- !> Same for profiling mode.
- logical, public :: in_profiling_mode = .false.
-
- integer, public :: global_alloc_err
- integer(int64), public :: global_sizeof
- character(len=100), public :: global_alloc_errmsg
-
- ! The code directories should be defined here, and not hard coded in the Fortran files.
- character(len=*), public, parameter :: GS_DIR = "gs/"
- character(len=*), public, parameter :: TD_DIR = "td/"
- character(len=*), public, parameter :: STATIC_DIR = "static/"
- character(len=*), public, parameter :: EM_RESP_DIR = "em_resp/"
- character(len=*), public, parameter :: EM_RESP_FD_DIR = "em_resp_fd/"
- character(len=*), public, parameter :: KDOTP_DIR = "kdotp/"
- character(len=*), public, parameter :: VIB_MODES_DIR = "vib_modes/"
- character(len=*), public, parameter :: VDW_DIR = "vdw/"
- character(len=*), public, parameter :: CASIDA_DIR = "casida/"
- character(len=*), public, parameter :: OCT_DIR = "opt-control/"
- character(len=*), public, parameter :: PCM_DIR = "pcm/"
- character(len=*), public, parameter :: PARTITION_DIR = "partition/"
-
- !> Alias MPI_COMM_UNDEFINED for the specific use case of initialising
- !! Octopus utilities with no MPI support
- integer, public, parameter :: SERIAL_DUMMY_COMM = MPI_COMM_UNDEFINED
-
- ! End of declaration of public objects.
- ! ---------------------------------------------------------
-
- interface optional_default
- module procedure doptional_default, zoptional_default, ioptional_default, loptional_default
- module procedure looptional_default, soptional_default
- end interface optional_default
-
-
- !> This function is defined in messages.F90
- interface
- subroutine assert_die(s, f, l)
- implicit none
- character(len=*), intent(in) :: s, f
- integer, intent(in) :: l
- end subroutine assert_die
- end interface
-
- interface operator (+)
- module procedure cat
- end interface operator (+)
-
- interface bitand
- module procedure bitand48
- module procedure bitand84
- module procedure bitand88
- module procedure bitand44
- end interface bitand
-
- interface i4_to_i8
- module procedure i4_to_i8_0, i4_to_i8_1
- end interface i4_to_i8
-
- interface i8_to_i4
- module procedure i8_to_i4_0, i8_to_i4_1
- end interface i8_to_i4
-
contains
!> @brief Initialiser for conf_t
- subroutine conf_init(this)
+ module subroutine conf_init(this)
class(conf_t), intent(inout) :: this
character(len=256) :: share
@@ -225,11 +49,15 @@ contains
!! Main entry point for callers initialising Octopus.
!! If a communicator is passed, no call is made to initialise MPI_COMM_WORLD.
!! Else, Octopus initialises MPI_COMM_WORLD
- subroutine global_init(communicator)
+ module subroutine global_init(communicator)
integer, intent(in), optional :: communicator !< Optional MPI communicator from caller
integer :: comm
+ call global_options%init()
+
+ call init_all_extension_def()
+
if (present(communicator)) then
comm = communicator
else
@@ -254,7 +82,7 @@ contains
!! * Default CPU cache sizes
!! * varinfo file, required for the parser
!! * Configuration instance.
- subroutine init_octopus_globals(comm)
+ module subroutine init_octopus_globals(comm)
integer, intent(in) :: comm !< MPI communicator. Can be a dummy value for serial apps.
call mpi_grp_init(mpi_world, comm)
@@ -282,17 +110,19 @@ contains
!> @brief Finalise parser varinfo file, and MPI
- subroutine global_end()
+ module subroutine global_end()
call varinfo_end()
call mpi_mod_end()
+ call end_all_extension_def()
end subroutine global_end
- real(real64) pure function doptional_default(opt, def) result(val)
+ pure module function doptional_default(opt, def) result(val)
real(real64), optional, intent(in) :: opt
real(real64), intent(in) :: def
+ real(real64) :: val
val = def
if (present(opt)) val = opt
@@ -300,9 +130,10 @@ contains
!----------------------------------------------------------
- complex(real64) pure function zoptional_default(opt, def) result(val)
+ pure module function zoptional_default(opt, def) result(val)
complex(real64), optional, intent(in) :: opt
complex(real64), intent(in) :: def
+ complex(real64) :: val
val = def
if (present(opt)) val = opt
@@ -310,9 +141,10 @@ contains
!----------------------------------------------------------
- integer pure function ioptional_default(opt, def) result(val)
+ pure module function ioptional_default(opt, def) result(val)
integer, optional, intent(in) :: opt
integer, intent(in) :: def
+ integer :: val
val = def
if (present(opt)) val = opt
@@ -320,9 +152,10 @@ contains
!----------------------------------------------------------
- integer(int64) pure function loptional_default(opt, def) result(val)
+ pure module function loptional_default(opt, def) result(val)
integer(int64), optional, intent(in) :: opt
integer(int64), intent(in) :: def
+ integer(int64) :: val
val = def
if (present(opt)) val = opt
@@ -330,9 +163,10 @@ contains
!----------------------------------------------------------
- logical pure function looptional_default(opt, def) result(val)
+ pure module function looptional_default(opt, def) result(val)
logical, optional, intent(in) :: opt
logical, intent(in) :: def
+ logical :: val
val = def
if (present(opt)) val = opt
@@ -340,9 +174,10 @@ contains
!----------------------------------------------------------
- character(len=80) pure function soptional_default(opt, def) result(val)
+ pure module function soptional_default(opt, def) result(val)
character(len=*), optional, intent(in) :: opt
character(len=*), intent(in) :: def
+ character(:), allocatable :: val
val = def
if (present(opt)) val = opt
@@ -350,105 +185,108 @@ contains
!-----------------------------------------------------------
- logical &
-#ifndef HAVE_OPENMP
- pure &
-#endif
- function not_in_openmp()
+ module function not_in_openmp() result(res)
+ logical :: res
#ifdef HAVE_OPENMP
- not_in_openmp = .not. omp_in_parallel()
+ res = .not. omp_in_parallel()
#else
- not_in_openmp = .true.
+ res = .true.
#endif
end function not_in_openmp
!-----------------------------------------------------------
- function cat(str1, str2)
+ module function cat(str1, str2) result(res)
character(len=*), intent(in) :: str1
character(len=*), intent(in) :: str2
+ character(len=len(str1) + len(str2)) :: res
- character(len=len(str1) + len(str2)) :: cat
- cat = str1//str2
+ res = str1//str2
end function cat
! -----------------------------------------------------------
- integer(int64) pure function bitand48(val1, val2)
+ pure module function bitand48(val1, val2) result(res)
integer(int32), intent(in) :: val1
integer(int64), intent(in) :: val2
+ integer(int64) :: res
- bitand48 = iand(int(val1, int64), val2)
+ res = iand(int(val1, int64), val2)
end function bitand48
! -----------------------------------------------------------
- integer(int64) pure function bitand84(val1, val2)
+ pure module function bitand84(val1, val2) result(res)
integer(int64), intent(in) :: val1
integer(int32), intent(in) :: val2
+ integer(int64) :: res
- bitand84 = iand(val1, int(val2, int64))
+ res = iand(val1, int(val2, int64))
end function bitand84
! -----------------------------------------------------------
- integer(int64) pure function bitand88(val1, val2)
+ pure module function bitand88(val1, val2) result(res)
integer(int64), intent(in) :: val1
integer(int64), intent(in) :: val2
+ integer(int64) :: res
- bitand88 = iand(val1, val2)
+ res = iand(val1, val2)
end function bitand88
! -----------------------------------------------------------
- integer(int32) pure function bitand44(val1, val2)
+ pure module function bitand44(val1, val2) result(res)
integer(int32), intent(in) :: val1
integer(int32), intent(in) :: val2
+ integer(int32) :: res
- bitand44 = iand(val1, val2)
+ res = iand(val1, val2)
end function bitand44
! -----------------------------------------------------------
- integer(int64) pure function i4_to_i8_0(ii)
+ pure module function i4_to_i8_0(ii) result(res)
integer(int32), intent(in) :: ii
+ integer(int64) :: res
- i4_to_i8_0 = int(ii, int64)
+ res = int(ii, int64)
end function i4_to_i8_0
! -----------------------------------------------------------
- integer(int32) pure function i8_to_i4_0(ii)
+ pure module function i8_to_i4_0(ii) result(res)
integer(int64), intent(in) :: ii
+ integer(int32) :: res
- i8_to_i4_0 = int(ii, int32)
+ res = int(ii, int32)
end function i8_to_i4_0
! -----------------------------------------------------------
- pure function i4_to_i8_1(ii)
+ pure module function i4_to_i8_1(ii) result(res)
integer(int32), intent(in) :: ii(:)
- integer(int64) :: i4_to_i8_1(lbound(ii, 1, kind=int64):ubound(ii, 1, kind=int64))
+ integer(int64) :: res(lbound(ii, 1, kind=int64):ubound(ii, 1, kind=int64))
- i4_to_i8_1 = int(ii, int64)
+ res = int(ii, int64)
end function i4_to_i8_1
! -----------------------------------------------------------
- pure function i8_to_i4_1(ii)
+ pure module function i8_to_i4_1(ii) result(res)
integer(int64), intent(in) :: ii(:)
- integer(int32) :: i8_to_i4_1(lbound(ii, 1, kind=int64):ubound(ii, 1, kind=int64))
+ integer(int32) :: res(lbound(ii, 1, kind=int64):ubound(ii, 1, kind=int64))
- i8_to_i4_1 = int(ii, int32)
+ res = int(ii, int32)
end function i8_to_i4_1
-end module global_oct_m
+end submodule impl
!! Local Variables:
!! mode: f90
diff --git a/src/basic/global_h.F90 b/src/basic/global_h.F90
new file mode 100644
index 0000000000000000000000000000000000000000..a452f3bea0b54bebf78252fd05feb559c4adc1e5
--- /dev/null
+++ b/src/basic/global_h.F90
@@ -0,0 +1,293 @@
+#include "global.h"
+
+module global_oct_m
+ use dict_oct_m
+ use mpi_oct_m
+ use, intrinsic :: iso_fortran_env
+
+ implicit none
+
+ private
+
+ !> Public types, variables and procedures.
+ public :: &
+ conf_t, &
+ global_init, &
+ global_end, &
+ init_octopus_globals, &
+ optional_default, &
+ assert_die, &
+ not_in_openmp, &
+ operator(+), &
+ bitand, &
+ int32, int64, &
+ real32, real64, &
+ i4_to_i8, &
+ i8_to_i4
+ ! Make these kind variables from kind_oct_m public here so that they are
+ ! available basically everywhere in the code. They still need to be in a
+ ! separate module because they are also needed in some low-level modules.
+
+ integer, public, parameter :: MAX_PATH_LEN=512
+ integer, public, parameter :: MAX_OUTPUT_TYPES=44
+
+ !> @brief Build configuration type
+ type conf_t
+ logical :: devel_version !< If true then allow unstable parts of the code
+ logical :: report_memory
+ character(len=256) :: share = SHARE_DIR !< Name of the share dir
+ character(len=256) :: git_commit = GIT_COMMIT !< hash of latest git commit
+ character(len=50) :: config_time = BUILD_TIME !< time octopus was configured
+ character(len=20) :: version = PACKAGE_VERSION !< version number
+ character(len=256) :: cc = CC !< C compiler
+ character(len=256) :: cxx = CXX !< C++ compiler
+ character(len=256) :: fc = FC !< Fortran compiler
+ ! Split flag definitions in case they don`t fit in one line, following preprocessing
+ character(len=256) :: cflags = &
+ CFLAGS //&
+ CFLAGS_EXTRA
+ character(len=256) :: cxxflags = &
+ CXXFLAGS //&
+ CXXFLAGS_EXTRA
+ character(len=256) :: fcflags = &
+ FCFLAGS //&
+ FCFLAGS_EXTRA
+ integer :: target_states_block_size = -1
+ contains
+ procedure :: init => conf_init
+ end type conf_t
+
+ !> Global instance of Octopus configuration
+ type(conf_t), public :: conf
+
+ real(real64), public, parameter :: R_SMALL = 1e-8_real64
+
+ !> Minimal distance between two distinguishable atoms
+ real(real64), public, parameter :: R_MIN_ATOM_DIST = 1e-3_real64
+
+ !> some mathematical constants
+ real(real64), public, parameter :: M_Pi = 3.1415926535897932384626433832795029_real64
+ real(real64), public, parameter :: M_E = 2.7182818284590452353602874713526625_real64
+ real(real64), public, parameter :: M_ZERO = 0.0_real64
+ real(real64), public, parameter :: M_ONE = 1.0_real64
+ real(real64), public, parameter :: M_TWO = 2.0_real64
+ real(real64), public, parameter :: M_THREE = 3.0_real64
+ real(real64), public, parameter :: M_FOUR = 4.0_real64
+ real(real64), public, parameter :: M_FIVE = 5.0_real64
+ real(real64), public, parameter :: M_HALF = 0.5_real64
+ real(real64), public, parameter :: M_THIRD = M_ONE/M_THREE
+ real(real64), public, parameter :: M_TWOTHIRD = M_TWO/M_THREE
+ real(real64), public, parameter :: M_FOURTH = M_ONE/M_FOUR
+ complex(real64), public, parameter :: M_z0 = (0.0_real64, 0.0_real64)
+ complex(real64), public, parameter :: M_z1 = (1.0_real64, 0.0_real64)
+ complex(real64), public, parameter :: M_z2 = (2.0_real64, 0.0_real64)
+ complex(real64), public, parameter :: M_z2I = (0.0_real64, 2.0_real64)
+ complex(real64), public, parameter :: M_zI = (0.0_real64, 1.0_real64)
+
+ real(real64), public, parameter :: M_EPSILON = epsilon(M_ONE)
+ real(real64), public, parameter :: M_TINY = tiny(M_ONE)
+ real(real64), public, parameter :: M_HUGE = huge(M_ONE)
+ real(real64), public, parameter :: M_MIN_EXP_ARG = -650_real64
+ real(real64), public, parameter :: M_MAX_EXP_ARG = 700_real64
+
+ !> Minimal occupation that is considered to be non-zero
+ real(real64), public, parameter :: M_MIN_OCC = 1.0e-10_real64
+ !> Minimal density that is considered to be non-zero
+ real(real64), public, parameter :: M_MIN_DENSITY = 1.0e-20_real64
+
+
+ !> some physical constants
+ real(real64), public, parameter :: P_a_B = 0.52917720859_real64
+ real(real64), public, parameter :: P_Ang = M_ONE / P_a_B
+ real(real64), public, parameter :: P_Ry = 13.60569193_real64
+ real(real64), public, parameter :: P_eV = M_ONE / P_Ry
+ real(real64), public, parameter :: P_Kb = 8.617343e-5_real64/(M_TWO*P_Ry) !< Boltzmann constant in Ha/K
+ real(real64), public, parameter :: P_c = 137.035999679_real64
+ !< Electron gyromagnetic ratio, see Phys. Rev. Lett. 130, 071801 (2023)
+ real(real64), public, parameter :: P_g = 2.00231930436118_real64
+ real(real64), public, parameter :: P_PROTON_CHARGE = -1.0_real64
+ real(real64), public, parameter :: P_ep = M_ONE/(M_FOUR*M_Pi)
+ real(real64), public, parameter :: P_mu = M_FOUR*M_PI/(P_c**2)
+
+ type(dict_t), public :: global_options
+
+ !> the standard input and output
+ integer, public :: stderr, stdin, stdout
+
+ !> global epoch time (time at startup)
+ integer, public :: s_epoch_sec, s_epoch_usec
+
+ !> The stack.
+ character(len=80), public :: sub_stack(50)
+ real(real64), public :: time_stack(50)
+ integer, public :: no_sub_stack = 0
+
+ !> Same for profiling mode.
+ logical, public :: in_profiling_mode = .false.
+
+ integer, public :: global_alloc_err
+ integer(int64), public :: global_sizeof
+ character(len=100), public :: global_alloc_errmsg
+
+ ! The code directories should be defined here, and not hard coded in the Fortran files.
+ character(len=*), public, parameter :: GS_DIR = "gs/"
+ character(len=*), public, parameter :: TD_DIR = "td/"
+ character(len=*), public, parameter :: STATIC_DIR = "static/"
+ character(len=*), public, parameter :: EM_RESP_DIR = "em_resp/"
+ character(len=*), public, parameter :: EM_RESP_FD_DIR = "em_resp_fd/"
+ character(len=*), public, parameter :: KDOTP_DIR = "kdotp/"
+ character(len=*), public, parameter :: VIB_MODES_DIR = "vib_modes/"
+ character(len=*), public, parameter :: VDW_DIR = "vdw/"
+ character(len=*), public, parameter :: CASIDA_DIR = "casida/"
+ character(len=*), public, parameter :: OCT_DIR = "opt-control/"
+ character(len=*), public, parameter :: PCM_DIR = "pcm/"
+ character(len=*), public, parameter :: PARTITION_DIR = "partition/"
+
+ !> Alias MPI_COMM_UNDEFINED for the specific use case of initialising
+ !! Octopus utilities with no MPI support
+ integer, public, parameter :: SERIAL_DUMMY_COMM = MPI_COMM_UNDEFINED
+
+ ! End of declaration of public objects.
+ ! ---------------------------------------------------------
+
+ interface optional_default
+ module procedure doptional_default, zoptional_default, ioptional_default, loptional_default
+ module procedure looptional_default, soptional_default
+ end interface optional_default
+
+
+ !> This function is defined in messages.F90
+ interface
+ subroutine assert_die(s, f, l)
+ implicit none
+ character(len=*), intent(in) :: s, f
+ integer, intent(in) :: l
+ end subroutine assert_die
+ end interface
+
+ interface operator (+)
+ module procedure cat
+ end interface operator (+)
+
+ interface bitand
+ module procedure bitand48
+ module procedure bitand84
+ module procedure bitand88
+ module procedure bitand44
+ end interface bitand
+
+ interface i4_to_i8
+ module procedure i4_to_i8_0, i4_to_i8_1
+ end interface i4_to_i8
+
+ interface i8_to_i4
+ module procedure i8_to_i4_0, i8_to_i4_1
+ end interface i8_to_i4
+
+ interface
+ module subroutine conf_init(this)
+ class(conf_t), intent(inout) :: this
+ end subroutine conf_init
+
+ module subroutine global_init(communicator)
+ integer, intent(in), optional :: communicator
+ end subroutine global_init
+
+ module subroutine init_octopus_globals(comm)
+ integer, intent(in) :: comm
+ end subroutine init_octopus_globals
+
+ module subroutine global_end()
+ end subroutine global_end
+
+ pure module function doptional_default(opt, def) result(val)
+ real(real64), optional, intent(in) :: opt
+ real(real64), intent(in) :: def
+ real(real64) :: val
+ end function doptional_default
+
+ pure module function zoptional_default(opt, def) result(val)
+ complex(real64), optional, intent(in) :: opt
+ complex(real64), intent(in) :: def
+ complex(real64) :: val
+ end function zoptional_default
+
+ pure module function ioptional_default(opt, def) result(val)
+ integer, optional, intent(in) :: opt
+ integer, intent(in) :: def
+ integer :: val
+ end function ioptional_default
+
+ pure module function loptional_default(opt, def) result(val)
+ integer(int64), optional, intent(in) :: opt
+ integer(int64), intent(in) :: def
+ integer(int64) :: val
+ end function loptional_default
+
+ pure module function looptional_default(opt, def) result(val)
+ logical, optional, intent(in) :: opt
+ logical, intent(in) :: def
+ logical :: val
+ end function looptional_default
+
+ pure module function soptional_default(opt, def) result(val)
+ character(len=*), optional, intent(in) :: opt
+ character(len=*), intent(in) :: def
+ character(:), allocatable :: val
+ end function soptional_default
+
+ module function not_in_openmp() result(res)
+ logical :: res
+ end function not_in_openmp
+
+ module function cat(str1, str2) result(res)
+ character(len=*), intent(in) :: str1
+ character(len=*), intent(in) :: str2
+ character(len=len(str1) + len(str2)) :: res
+ end function cat
+
+ pure module function bitand48(val1, val2) result(res)
+ integer(int32), intent(in) :: val1
+ integer(int64), intent(in) :: val2
+ integer(int64) :: res
+ end function bitand48
+
+ pure module function bitand84(val1, val2) result(res)
+ integer(int64), intent(in) :: val1
+ integer(int32), intent(in) :: val2
+ integer(int64) :: res
+ end function bitand84
+
+ pure module function bitand88(val1, val2) result(res)
+ integer(int64), intent(in) :: val1
+ integer(int64), intent(in) :: val2
+ integer(int64) :: res
+ end function bitand88
+
+ pure module function bitand44(val1, val2) result(res)
+ integer(int32), intent(in) :: val1
+ integer(int32), intent(in) :: val2
+ integer(int32) :: res
+ end function bitand44
+
+ pure module function i4_to_i8_0(ii) result(res)
+ integer(int32), intent(in) :: ii
+ integer(int64) :: res
+ end function i4_to_i8_0
+
+ pure module function i8_to_i4_0(ii) result(res)
+ integer(int64), intent(in) :: ii
+ integer(int32) :: res
+ end function i8_to_i4_0
+
+ pure module function i4_to_i8_1(ii) result(res)
+ integer(int32), intent(in) :: ii(:)
+ integer(int64) :: res(lbound(ii, 1, kind=int64):ubound(ii, 1, kind=int64))
+ end function i4_to_i8_1
+
+ pure module function i8_to_i4_1(ii) result(res)
+ integer(int64), intent(in) :: ii(:)
+ integer(int32) :: res(lbound(ii, 1, kind=int64):ubound(ii, 1, kind=int64))
+ end function i8_to_i4_1
+ end interface
+end module global_oct_m
diff --git a/src/basic/linked_list.F90 b/src/basic/linked_list.F90
index 277a4891c9d3caa8f00f4eab1989ad841a0934ae..cb4a36d00a24a728a039bbc8f4d3a024b6aa4e3e 100644
--- a/src/basic/linked_list.F90
+++ b/src/basic/linked_list.F90
@@ -40,10 +40,14 @@ module linked_list_oct_m
class(list_node_t), pointer :: last_node => null()
contains
procedure :: add_node => linked_list_add_node !< @copydoc linked_list_oct_m::linked_list_add_node
+ procedure :: push_back_node => linked_list_push_back_node !< @copydoc linked_list_oct_m::linked_list_push_back_node
+ procedure :: push_front_node => linked_list_push_front_node !< @copydoc linked_list_oct_m::linked_list_push_front_node
+ procedure :: insert_node_after_iterator => linked_list_insert_after_iterator !< @copydoc linked_list_oct_m::linked_list_insert_after_iterator
procedure :: add_ptr => linked_list_add_node_ptr !< @copydoc linked_list_oct_m::linked_list_add_node_ptr
procedure :: add_copy => linked_list_add_node_copy !< @copydoc linked_list_oct_m::linked_list_add_node_copy
procedure :: delete => linked_list_delete_node !< @copydoc linked_list_oct_m::linked_list_delete_node
procedure :: has => linked_list_has !< @copydoc linked_list_oct_m::linked_list_has
+ procedure :: has_node => linked_list_has_node !< @copydoc linked_list_oct_m::linked_list_has_node
procedure :: copy => linked_list_copy !< @copydoc linked_list_oct_m::linked_list_copy
generic :: assignment(=) => copy
procedure :: empty => linked_list_empty !< @copydoc linked_list_oct_m::linked_list_empty
@@ -58,11 +62,16 @@ module linked_list_oct_m
type :: linked_list_iterator_t
private
+ !> Next node ahead of the iterator
+ !! Effectively the current node just before the iterator advances with get_next
class(list_node_t), pointer :: next_node => null()
contains
procedure :: start => linked_list_iterator_start !< @copydoc linked_list_oct_m::linked_list_iterator_start
procedure :: has_next => linked_list_iterator_has_next !< @copydoc linked_list_oct_m::linked_list_iterator_has_next
+ procedure :: get_ptr => linked_list_iterator_get_ptr !< @copydoc linked_list_oct_m::linked_list_iterator_get_ptr
procedure :: get_next_ptr => linked_list_iterator_get_next_ptr !< @copydoc linked_list_oct_m::linked_list_iterator_get_next_ptr
+ procedure :: peek_next_ptr => linked_list_iterator_peek_next_ptr !< @copydoc linked_list_oct_m::linked_list_iterator_peek_next_ptr
+ procedure :: get_node => linked_list_iterator_get_node !< @copydoc linked_list_oct_m::linked_list_iterator_get_node
end type linked_list_iterator_t
!---------------------------------------------------------------------------
@@ -119,24 +128,112 @@ contains
! Linked list
! ---------------------------------------------------------
!> @brief add a node to the linked list
- subroutine linked_list_add_node(this, value, clone)
+ subroutine linked_list_add_node(this, value, clone, push_back, push_front)
+ class(linked_list_t), intent(inout) :: this
+ class(*), target :: value
+ logical, intent(in) :: clone
+ logical, optional, intent(in) :: push_back
+ logical, optional, intent(in) :: push_front
+
+ ! Fortran does not have short-circuit evaluation :((
+ if (present(push_back)) then
+ if (push_back) then
+ ! Push_back the node
+ call this%push_back_node(value, clone)
+ return
+ end if
+ end if
+
+ if(present(push_front)) then
+ if (push_front) then
+ ! Push_front the node
+ call this%push_front_node(value, clone)
+ return
+ end if
+ end if
+
+ ! For backwards compatibility, default to Push_back
+ call this%push_back_node(value, clone)
+
+ end subroutine linked_list_add_node
+
+ ! ---------------------------------------------------------
+ subroutine linked_list_push_back_node(this, value, clone)
class(linked_list_t), intent(inout) :: this !< the linked list
class(*), target :: value !< data to be added
logical, intent(in) :: clone !< flag whether to clone, or keep a pointer
class(list_node_t), pointer :: new_node
- if (.not. associated(this%first_node)) then
- this%first_node => list_node_t(value, this%first_node, clone)
- this%last_node => this%first_node
+ new_node => list_node_t(value, this%last_node, null(), clone)
+ if (this%size == 0) then
+ this%first_node => new_node
else
- new_node => list_node_t(value, this%last_node%next(), clone)
call this%last_node%set_next(new_node)
+ end if
+ this%last_node => new_node
+ this%size = this%size + 1
+
+ end subroutine linked_list_push_back_node
+
+ ! ---------------------------------------------------------
+ subroutine linked_list_push_front_node(this, value, clone)
+ class(linked_list_t), intent(inout) :: this
+ class(*), target :: value
+ logical, intent(in) :: clone
+
+ class(list_node_t), pointer :: new_node
+
+ new_node => list_node_t(value, null(), this%first_node, clone)
+ if (this%size == 0) then
this%last_node => new_node
+ else
+ call this%first_node%set_prev(new_node)
end if
+ this%first_node => new_node
this%size = this%size + 1
- end subroutine linked_list_add_node
+ end subroutine linked_list_push_front_node
+
+ ! ---------------------------------------------------------
+ subroutine linked_list_insert_after_iterator(this, iterator, value, clone)
+ class(linked_list_t), intent(inout) :: this
+ class(linked_list_iterator_t), intent(in) :: iterator
+ class(*), target, intent(in) :: value
+ logical, intent(in) :: clone
+
+ class(list_node_t), pointer :: new_node
+ class(list_node_t), pointer :: current_node
+ class(list_node_t), pointer :: iterator_node
+
+ ! Get the next node and confirm it is not empty
+ iterator_node => iterator%get_node()
+ ASSERT(associated(iterator_node))
+
+ ! Check that the list is not empty
+ current_node => this%first_node
+ ASSERT(associated(current_node))
+
+ ! Look for the node in the list corresponding to the one in the iterator
+ do while (associated(current_node))
+ if (associated(current_node, iterator_node)) then
+ ! Found the corresponding node. Now add value as a new node after this
+ new_node => list_node_t(value, current_node, current_node%next(), clone)
+ call current_node%set_next(new_node)
+ ! Check if we have just added to the end of the list. If so update last_node
+ if (.not. associated(new_node%next())) then
+ this%last_node => new_node
+ end if
+ this%size = this%size + 1
+ exit
+ end if
+ current_node => current_node%next()
+ ! Making sure that the itertor is part of the list
+ ! No error handling is implemented here
+ ASSERT(associated(current_node))
+ end do
+
+ end subroutine linked_list_insert_after_iterator
! ---------------------------------------------------------
!> @brief add data by pointer to the list
@@ -206,14 +303,22 @@ contains
end subroutine linked_list_finalize
! ---------------------------------------------------------
- subroutine linked_list_empty(this)
+ subroutine linked_list_empty(this, deallocate_items)
class(linked_list_t), intent(inout) :: this
+ logical, optional, intent(in) :: deallocate_items
class(list_node_t), pointer :: current, next
+ class(*), pointer :: raw_ptr
current => this%first_node
do while (associated(current))
next => current%next()
+ if (optional_default(deallocate_items, .false.)) then
+ raw_ptr => current%get()
+ if (associated(raw_ptr)) then
+ deallocate(raw_ptr)
+ end if
+ end if
deallocate(current)
current => next
end do
@@ -231,15 +336,27 @@ contains
class(list_node_t), pointer :: current, new_node
current => rhs%first_node
+
+ ! If it's empty than early exit
+ if (.not. associated(current)) then
+ lhs%first_node => null()
+ lhs%last_node => null()
+ lhs%size = 0
+ return
+ end if
+
+ ! Initialize the list with the first item
+ lhs%first_node => current%copy(null(), null())
+ lhs%last_node => lhs%first_node
+ current => current%next()
do while (associated(current))
- if (.not. associated(lhs%first_node)) then
- lhs%first_node => current%copy(lhs%first_node)
- lhs%last_node => lhs%first_node
- else
- new_node => current%copy(lhs%last_node%next())
- call lhs%last_node%set_next(new_node)
- lhs%last_node => new_node
- end if
+ ! Create the next node to be added at the end
+ new_node => current%copy(lhs%last_node, null())
+ ! Link the previously last node to this one
+ call lhs%last_node%set_next(new_node)
+ ! Set the last node to the newly created one
+ lhs%last_node => new_node
+ ! Continue in the rhs linked list
current => current%next()
end do
lhs%size = rhs%size
@@ -263,10 +380,37 @@ contains
end function linked_list_has
! ---------------------------------------------------------
- subroutine linked_list_iterator_start(this, list)
+ function linked_list_has_node(this, node) result(res)
+ class(linked_list_t), intent(in) :: this
+ class(list_node_t), target, intent(in) :: node
+ logical :: res
+
+ class(list_node_t), pointer :: current
+
+ current => this%first_node
+ res = .false.
+ do while (associated(current) .and. .not. res)
+ res = associated(current, node)
+ current => current%next()
+ end do
+
+ end function linked_list_has_node
+
+ ! ---------------------------------------------------------
+ subroutine linked_list_iterator_start(this, list, reverse)
class(linked_list_iterator_t), intent(inout) :: this
class(linked_list_t), target, intent(in) :: list
+ logical, optional, intent(in) :: reverse
+ if (present(reverse)) then
+ if (reverse) then
+ ! If itterating from the back, start from last_node
+ this%next_node => list%last_node
+ return
+ end if
+ end if
+
+ ! Default to iterate from the front
this%next_node => list%first_node
end subroutine linked_list_iterator_start
@@ -280,15 +424,67 @@ contains
end function linked_list_iterator_has_next
! ---------------------------------------------------------
- function linked_list_iterator_get_next_ptr(this) result(value)
+ function linked_list_iterator_get_ptr(this) result(value)
class(linked_list_iterator_t), intent(inout) :: this
class(*), pointer :: value
value => this%next_node%get()
+
+ end function linked_list_iterator_get_ptr
+
+ ! ---------------------------------------------------------
+ function linked_list_iterator_get_next_ptr(this, reverse) result(value)
+ class(linked_list_iterator_t), intent(inout) :: this
+ logical, optional, intent(in) :: reverse
+ class(*), pointer :: value
+
+ value => this%get_ptr()
+
+ if (present(reverse)) then
+ if (reverse) then
+ ! If itterating from the back, get the node before the current one
+ this%next_node => this%next_node%prev()
+ return
+ end if
+ end if
+
+ ! Default to iterate from the front
this%next_node => this%next_node%next()
end function linked_list_iterator_get_next_ptr
+ ! ---------------------------------------------------------
+ function linked_list_iterator_peek_next_ptr(this) result(value)
+ class(linked_list_iterator_t), intent(inout) :: this
+ class(*), pointer :: value
+
+ class(list_node_t), pointer :: next_node
+
+ ! There has to be a next (current) node in order to peek
+ ASSERT(this%has_next())
+
+ ! Get the next node after the iterator
+ ! Note: this%next_node is effectively current node
+ next_node => this%next_node%next()
+ if (.not. associated(next_node)) then
+ ! If there is no next node, return null
+ value => null()
+ else
+ ! Otherwise get the pointer of the next node
+ value => next_node%get()
+ end if
+
+ end function linked_list_iterator_peek_next_ptr
+
+ ! ---------------------------------------------------------
+ function linked_list_iterator_get_node(this) result(node)
+ class(linked_list_iterator_t), intent(in) :: this
+ class(list_node_t), pointer :: node
+
+ node => this%next_node
+
+ end function linked_list_iterator_get_node
+
! Unlimited polymorphic list
diff --git a/src/basic/list_node.F90 b/src/basic/list_node.F90
index 8d9459d6ada9d53d194119b9b141c90dc8e9a9cf..7c10655bbed5eba88acc4cdd846a3b8e168546eb 100644
--- a/src/basic/list_node.F90
+++ b/src/basic/list_node.F90
@@ -24,10 +24,13 @@ module list_node_oct_m
logical :: clone !< indicate whether this node is a clone of another node.
!! In this case data is copeied, otherwise a pointer is stored.
class(*), pointer :: value => null() !< the data to be stored in the node
+ type(list_node_t), pointer :: prev_node => null()
type(list_node_t), pointer :: next_node => null() !< pointer to the next node
contains
procedure :: get => list_node_get !< @copydoc list_node_oct_m::list_node_get
+ procedure :: prev => list_node_prev
procedure :: next => list_node_next !< @copydoc list_node_oct_m::list_node_next
+ procedure :: set_prev => list_node_set_prev
procedure :: set_next => list_node_set_next !< @copydoc list_node_oct_m::list_node_set_next
procedure :: is_equal => list_node_is_equal !< @copydoc list_node_oct_m::list_node_is_equal
procedure :: copy => list_node_copy !< @copydoc list_node_oct_m::list_node_copy
@@ -43,8 +46,9 @@ contains
! ---------------------------------------------------------
!> @brief create a new node
!!
- function list_node_constructor(value, next, clone) result(constructor)
+ function list_node_constructor(value, prev, next, clone) result(constructor)
class(*), target :: value !< data to store in the node
+ class(list_node_t), pointer :: prev !< pointer to the previous node
class(list_node_t), pointer :: next !< pointer to the next node
logical, intent(in) :: clone !< is this node a clone?
class(list_node_t), pointer :: constructor !< pointer to the new node
@@ -52,6 +56,7 @@ contains
! No safe_allocate macro here, as its counterpart in linked_list.F90
! causes an internal compiler error with GCC 6.4.0
allocate(constructor)
+ constructor%prev_node => prev
constructor%next_node => next
constructor%clone = clone
if (constructor%clone) then
@@ -65,15 +70,25 @@ contains
! ---------------------------------------------------------
!> @brief copy a node
!!
- function list_node_copy(this, next)
+ function list_node_copy(this, prev, next) result(copy_node)
class(list_node_t), target :: this !< the source node
+ class(list_node_t), pointer :: prev !< pointer to the previous node
class(list_node_t), pointer :: next !< pointer to the next node
- class(list_node_t), pointer :: list_node_copy !< pointer to the new copy
+ class(list_node_t), pointer :: copy_node !< pointer to the new copy
- list_node_copy => list_node_constructor(this%value, next, this%clone)
+ copy_node => list_node_constructor(this%value, prev, next, this%clone)
end function list_node_copy
+ ! ---------------------------------------------------------
+ function list_node_prev(this) result(prev)
+ class(list_node_t), intent(in) :: this
+ class(list_node_t), pointer :: prev
+
+ prev => this%prev_node
+
+ end function list_node_prev
+
! ---------------------------------------------------------
!> @brief get next node
function list_node_next(this) result(next)
@@ -84,6 +99,15 @@ contains
end function list_node_next
+ ! ---------------------------------------------------------
+ subroutine list_node_set_prev(this, prev_node)
+ class(list_node_t), intent(inout) :: this
+ class(list_node_t), pointer :: prev_node
+
+ this%prev_node => prev_node
+
+ end subroutine list_node_set_prev
+
! ---------------------------------------------------------
subroutine list_node_set_next(this, next_node)
class(list_node_t), intent(inout) :: this
diff --git a/src/basic/messages.F90 b/src/basic/messages.F90
index f344fa7cbe7164dd0bc615a9f9072c545dbdab88..f0199bbd841588171b4275bba7695c96b7753c1b 100644
--- a/src/basic/messages.F90
+++ b/src/basic/messages.F90
@@ -44,6 +44,7 @@ module messages_oct_m
messages_warning, &
messages_info, &
messages_switch_status, &
+ messages_get_unit, &
print_date, &
time_sum, &
alloc_error, &
diff --git a/src/classical/classical_particles.F90 b/src/classical/classical_particles.F90
index 877862c21fce8943aeb13bc36f0d43b7828ccf54..3472c06438fc290359fd6e6112ad039d7f2b1e44 100644
--- a/src/classical/classical_particles.F90
+++ b/src/classical/classical_particles.F90
@@ -950,7 +950,7 @@ contains
SAFE_DEALLOCATE_A(this%lj_epsilon)
SAFE_DEALLOCATE_A(this%lj_sigma)
- call system_end(this)
+ call this%system_end()
POP_SUB(classical_particles_end)
end subroutine classical_particles_end
diff --git a/src/dftbplus/dftb.F90 b/src/dftbplus/dftb.F90
index a962eb7b31e3ae939c70dcf6a4c4da9be03c69e8..15afa4fa08e864f6f44c57abc2b9c716bad3294a 100644
--- a/src/dftbplus/dftb.F90
+++ b/src/dftbplus/dftb.F90
@@ -747,7 +747,7 @@ contains
call TDftbPlus_destruct(this%dftbp)
#endif
- call system_end(this)
+ call this%system_end()
POP_SUB(dftb_finalize)
end subroutine dftb_finalize
diff --git a/src/electrons/CMakeLists.txt b/src/electrons/CMakeLists.txt
index f87ba1d062cf6f881dbdba40f9c95555d29ce175..0ed1f23bf61a5a0a61856d3312a8321989959d14 100644
--- a/src/electrons/CMakeLists.txt
+++ b/src/electrons/CMakeLists.txt
@@ -9,7 +9,10 @@ target_sources(Octopus_lib PRIVATE
eigen_rmmdiis.F90
eigensolver.F90
electrons.F90
+ electrons_h.F90
electron_space.F90
+ electrons_extension.F90
+ electrons_extension_h.F90
elf.F90
energy_calc.F90
exponential.F90
diff --git a/src/electrons/electrons.F90 b/src/electrons/electrons.F90
index 9d42228f18f7c0bd90b32899721173c0757f0d74..995b967c246079f4a9d700a96529b666df0090ec 100644
--- a/src/electrons/electrons.F90
+++ b/src/electrons/electrons.F90
@@ -20,58 +20,39 @@
#include "global.h"
-
-module electrons_oct_m
+submodule (electrons_oct_m) impl
+ use electrons_oct_m
use accel_oct_m
use absorbing_boundaries_oct_m
- use algorithm_oct_m
- use algorithm_factory_oct_m
use calc_mode_par_oct_m
use classical_particles_oct_m
- use current_oct_m
use current_to_mxll_field_oct_m
use debug_oct_m
use density_oct_m
- use dipole_oct_m
- use electron_space_oct_m
use elf_oct_m
use energy_calc_oct_m
use ext_partner_list_oct_m
use field_transfer_oct_m
use forces_oct_m
- use gauge_field_oct_m
use global_oct_m
- use grid_oct_m
- use hamiltonian_elec_oct_m
use hamiltonian_elec_base_oct_m
use interaction_enum_oct_m
- use interaction_oct_m
- use interaction_partner_oct_m
- use interaction_surrogate_oct_m
use ion_dynamics_oct_m
- use ions_oct_m
use kick_oct_m
- use kpoints_oct_m
use lalg_basic_oct_m
use lattice_vectors_oct_m
- use lasers_oct_m
use lda_u_oct_m
use loct_oct_m
use mesh_oct_m
use messages_oct_m
use modelmb_particles_oct_m
- use mpi_oct_m
- use multicomm_oct_m
use mxll_e_field_to_matter_oct_m
use mxll_b_field_to_matter_oct_m
use mxll_vec_pot_to_matter_oct_m
use mxll_elec_coupling_oct_m
- use namespace_oct_m
use output_oct_m
- use output_low_oct_m
use parser_oct_m
use pes_oct_m
- use photons_oct_m
use photon_mode_oct_m
use photon_mode_mf_oct_m
use poisson_oct_m
@@ -87,100 +68,27 @@ module electrons_oct_m
use profiling_oct_m
use quantity_oct_m
use regridding_oct_m
- use scf_oct_m
+ use scf_interface_oct_m
use space_oct_m
use states_abst_oct_m
- use states_elec_oct_m
use states_elec_dim_oct_m
use stress_oct_m
use sort_oct_m
- use system_oct_m
- use td_oct_m
+ use td_interface_oct_m
use td_write_oct_m
use unit_system_oct_m
- use v_ks_oct_m
use xc_oct_m
use xc_f03_lib_m
use xc_oep_oct_m
- use xc_interaction_oct_m
use xc_oep_photon_oct_m
use xc_functional_oct_m
implicit none
- private
- public :: &
- electrons_t
-
-
- !> @brief Class describing the electron system
- !!
- !! This class describes a system of electrons and ions.
- !!
- !! \todo move the ions into their own ions_t class.
- type, extends(system_t) :: electrons_t
- ! Components are public by default
- type(electron_space_t) :: space
- class(ions_t), pointer :: ions => NULL() !< the ion component of the system
- type(photons_t), pointer :: photons => null()
- type(grid_t) :: gr !< the mesh
- type(states_elec_t) :: st !< the states
- type(v_ks_t) :: ks !< the Kohn-Sham potentials
- type(output_t) :: outp !< the output
- type(multicomm_t) :: mc !< index and domain communicators
- type(hamiltonian_elec_t) :: hm !< the Hamiltonian
- type(td_t) :: td !< everything related to time propagation
- type(current_t) :: current_calculator
- type(dipole_t) :: dipole !< total dipole of electrons and ions
- type(scf_t) :: scf !< SCF for BOMD
-
- type(kpoints_t) :: kpoints !< the k-points
-
- logical :: generate_epot
-
- type(states_elec_t) :: st_copy !< copy of the states
-
- ! At the moment this is not treated as an external potential
- class(lasers_t), pointer :: lasers => null() !< lasers
- class(gauge_field_t), pointer :: gfield => null() !< gauge field
-
- ! List with all the external partners
- ! This will become a list of interactions in the future
- type(partner_list_t) :: ext_partners
-
- !TODO: have a list of self interactions
- type(xc_interaction_t), pointer :: xc_interaction => null()
-
- logical :: ions_propagated = .false.
- contains
- procedure :: init_interaction => electrons_init_interaction
- procedure :: init_parallelization => electrons_init_parallelization
- procedure :: init_algorithm => electrons_init_algorithm
- procedure :: initial_conditions => electrons_initial_conditions
- procedure :: do_algorithmic_operation => electrons_do_algorithmic_operation
- procedure :: is_tolerance_reached => electrons_is_tolerance_reached
- procedure :: update_quantity => electrons_update_quantity
- procedure :: init_interaction_as_partner => electrons_init_interaction_as_partner
- procedure :: copy_quantities_to_interaction => electrons_copy_quantities_to_interaction
- procedure :: output_start => electrons_output_start
- procedure :: output_write => electrons_output_write
- procedure :: output_finish => electrons_output_finish
- procedure :: process_is_slave => electrons_process_is_slave
- procedure :: restart_write_data => electrons_restart_write_data
- procedure :: restart_read_data => electrons_restart_read_data
- procedure :: update_kinetic_energy => electrons_update_kinetic_energy
- procedure :: propagation_start => electrons_propagation_start
- final :: electrons_finalize
- end type electrons_t
-
- interface electrons_t
- procedure electrons_constructor
- end interface electrons_t
-
contains
!----------------------------------------------------------
- function electrons_constructor(namespace, generate_epot) result(sys)
+ module function electrons_constructor(namespace, generate_epot) result(sys)
class(electrons_t), pointer :: sys
type(namespace_t), intent(in) :: namespace
logical, optional, intent(in) :: generate_epot
@@ -193,6 +101,8 @@ contains
allocate(sys)
+ call sys%system_init()
+
sys%namespace = namespace
call messages_obsolete_variable(sys%namespace, 'SystemName')
@@ -268,7 +178,7 @@ contains
end function electrons_constructor
! ---------------------------------------------------------
- subroutine electrons_init_interaction(this, interaction)
+ module subroutine electrons_init_interaction(this, interaction)
class(electrons_t), target, intent(inout) :: this
class(interaction_t), intent(inout) :: interaction
@@ -331,7 +241,7 @@ contains
end subroutine electrons_init_interaction
! ---------------------------------------------------------
- subroutine electrons_init_parallelization(this, grp)
+ module subroutine electrons_init_parallelization(this, grp)
class(electrons_t), intent(inout) :: this
type(mpi_grp_t), intent(in) :: grp
@@ -524,7 +434,7 @@ contains
end subroutine electrons_init_parallelization
! ---------------------------------------------------------
- subroutine electrons_init_algorithm(this, factory)
+ module subroutine electrons_init_algorithm(this, factory)
class(electrons_t), intent(inout) :: this
class(algorithm_factory_t), intent(in) :: factory
@@ -535,12 +445,10 @@ contains
select type (algo => this%algo)
class is (propagator_t)
- call td_init(this%td, this%namespace, this%space, this%gr, this%ions, this%st, this%ks, &
- this%hm, this%ext_partners, this%outp)
+ call td_init(this)
! this corresponds to the first part of td_init_run
- call td_allocate_wavefunctions(this%td, this%namespace, this%mc, this%gr, this%ions, this%st, &
- this%hm, this%space)
+ call td_allocate_wavefunctions(this)
call td_init_gaugefield(this%td, this%namespace, this%gr, this%st, this%ks, this%hm, &
this%ext_partners, this%space)
@@ -550,7 +458,7 @@ contains
end subroutine electrons_init_algorithm
! ---------------------------------------------------------
- subroutine electrons_initial_conditions(this)
+ module subroutine electrons_initial_conditions(this)
class(electrons_t), intent(inout) :: this
PUSH_SUB(electrons_initial_conditions)
@@ -566,7 +474,7 @@ contains
end subroutine electrons_initial_conditions
! ---------------------------------------------------------
- subroutine electrons_propagation_start(this)
+ module subroutine electrons_propagation_start(this)
class(electrons_t), intent(inout) :: this
PUSH_SUB(electrons_propagation_start)
@@ -574,17 +482,17 @@ contains
call system_propagation_start(this)
! additional initialization needed for electrons
- call td_init_with_wavefunctions(this%td, this%namespace, this%space, this%mc, this%gr, this%ions, &
- this%ext_partners, this%st, this%ks, this%hm, this%outp, td_get_from_scratch(this%td))
+ call td_init_with_wavefunctions(this)
POP_SUB(electrons_propagation_start)
end subroutine electrons_propagation_start
! ---------------------------------------------------------
- logical function electrons_do_algorithmic_operation(this, operation, updated_quantities) result(done)
+ module function electrons_do_algorithmic_operation(this, operation, updated_quantities) result(done)
class(electrons_t), intent(inout) :: this
class(algorithmic_operation_t), intent(in) :: operation
integer, allocatable, intent(out) :: updated_quantities(:)
+ logical :: done
logical :: update_energy_
type(gauge_field_t), pointer :: gfield
@@ -682,7 +590,7 @@ contains
call propagation_ops_elec_restore_ions(this%td%tr%propagation_ops_elec, this%td%ions_dyn, this%ions)
case (BOMD_START)
- call scf_init(this%scf, this%namespace, this%gr, this%ions, this%st, this%mc, this%hm, this%space)
+ call scf_init(this)
! the ions are propagated inside the propagation step already, so no need to do it at the end
this%ions_propagated = .true.
@@ -695,8 +603,7 @@ contains
call hamiltonian_elec_epot_generate(this%hm, this%namespace, this%space, this%gr, this%ions, &
this%ext_partners, this%st, time = time+algo%dt)
! now calculate the eigenfunctions
- call scf_run(this%scf, this%namespace, this%space, this%mc, this%gr, this%ions, &
- this%ext_partners, this%st, this%ks, this%hm, verbosity = VERB_COMPACT)
+ call scf_run(this, verbosity = VERB_COMPACT)
! TODO: Check if this call is realy needed. - NTD
call hamiltonian_elec_epot_generate(this%hm, this%namespace, this%space, this%gr, this%ions, &
this%ext_partners, this%st, time = time+algo%dt)
@@ -730,7 +637,7 @@ contains
done = .false.
case (BOMD_FINISH)
- call scf_end(this%scf)
+ call scf_end(this)
case (EXPMID_FINISH, AETRS_FINISH)
case default
@@ -744,9 +651,10 @@ contains
end function electrons_do_algorithmic_operation
! ---------------------------------------------------------
- logical function electrons_is_tolerance_reached(this, tol) result(converged)
+ module function electrons_is_tolerance_reached(this, tol) result(converged)
class(electrons_t), intent(in) :: this
real(real64), intent(in) :: tol
+ logical :: converged
PUSH_SUB(electrons_is_tolerance_reached)
@@ -756,7 +664,7 @@ contains
end function electrons_is_tolerance_reached
! ---------------------------------------------------------
- subroutine electrons_update_quantity(this, iq)
+ module subroutine electrons_update_quantity(this, iq)
class(electrons_t), intent(inout) :: this
integer, intent(in) :: iq
@@ -783,7 +691,7 @@ contains
end subroutine electrons_update_quantity
! ---------------------------------------------------------
- subroutine electrons_init_interaction_as_partner(partner, interaction)
+ module subroutine electrons_init_interaction_as_partner(partner, interaction)
class(electrons_t), intent(in) :: partner
class(interaction_surrogate_t), intent(inout) :: interaction
@@ -801,7 +709,7 @@ contains
end subroutine electrons_init_interaction_as_partner
! ---------------------------------------------------------
- subroutine electrons_copy_quantities_to_interaction(partner, interaction)
+ module subroutine electrons_copy_quantities_to_interaction(partner, interaction)
class(electrons_t), intent(inout) :: partner
class(interaction_surrogate_t), intent(inout) :: interaction
@@ -823,7 +731,7 @@ contains
end subroutine electrons_copy_quantities_to_interaction
! ---------------------------------------------------------
- subroutine electrons_output_start(this)
+ module subroutine electrons_output_start(this)
class(electrons_t), intent(inout) :: this
PUSH_SUB(electrons_output_start)
@@ -832,7 +740,7 @@ contains
end subroutine electrons_output_start
! ---------------------------------------------------------
- subroutine electrons_output_write(this)
+ module subroutine electrons_output_write(this)
class(electrons_t), intent(inout) :: this
integer :: iter
@@ -853,12 +761,14 @@ contains
end if
end select
+ call system_output_write(this)
+
call profiling_out(trim(this%namespace%get())//":"//"OUTPUT_WRITE")
POP_SUB(electrons_output_write)
end subroutine electrons_output_write
! ---------------------------------------------------------
- subroutine electrons_output_finish(this)
+ module subroutine electrons_output_finish(this)
class(electrons_t), intent(inout) :: this
PUSH_SUB(electrons_output_finish)
@@ -867,8 +777,9 @@ contains
end subroutine electrons_output_finish
! ---------------------------------------------------------
- logical function electrons_process_is_slave(this) result(is_slave)
+ module function electrons_process_is_slave(this) result(is_slave)
class(electrons_t), intent(in) :: this
+ logical :: is_slave
PUSH_SUB(electrons_process_is_slave)
@@ -985,7 +896,7 @@ contains
end subroutine electrons_exec_end_of_timestep_tasks
! ---------------------------------------------------------
- subroutine electrons_restart_write_data(this)
+ module subroutine electrons_restart_write_data(this)
class(electrons_t), intent(inout) :: this
integer :: ierr
@@ -1014,8 +925,9 @@ contains
! ---------------------------------------------------------
! this function returns true if restart data could be read
- logical function electrons_restart_read_data(this)
+ module function electrons_restart_read_data(this) result(res)
class(electrons_t), intent(inout) :: this
+ logical :: res
logical :: from_scratch
@@ -1030,10 +942,10 @@ contains
call td_set_from_scratch(this%td, from_scratch)
if (from_scratch) then
! restart data could not be loaded
- electrons_restart_read_data = .false.
+ res = .false.
else
! restart data could be loaded
- electrons_restart_read_data = .true.
+ res = .true.
end if
end select
@@ -1042,7 +954,7 @@ contains
end function electrons_restart_read_data
!----------------------------------------------------------
- subroutine electrons_update_kinetic_energy(this)
+ module subroutine electrons_update_kinetic_energy(this)
class(electrons_t), intent(inout) :: this
PUSH_SUB(electrons_update_kinetic_energy)
@@ -1099,19 +1011,16 @@ contains
end subroutine get_fields_from_interaction
!----------------------------------------------------------
- subroutine electrons_finalize(sys)
+ module subroutine electrons_finalize(sys)
type(electrons_t), intent(inout) :: sys
- type(partner_iterator_t) :: iter
- class(interaction_partner_t), pointer :: partner
-
PUSH_SUB(electrons_finalize)
if (associated(sys%algo)) then
select type (algo => sys%algo)
class is (propagator_t)
- call td_end_run(sys%td, sys%st, sys%hm)
- call td_end(sys%td)
+ call td_end_run(sys)
+ call td_end(sys)
end select
end if
@@ -1119,12 +1028,7 @@ contains
call poisson_async_end(sys%hm%psolver, sys%mc)
end if
- call iter%start(sys%ext_partners)
- do while (iter%has_next())
- partner => iter%get_next()
- SAFE_DEALLOCATE_P(partner)
- end do
- call sys%ext_partners%empty()
+ call deallocate_ext_partners()
SAFE_DEALLOCATE_P(sys%xc_interaction)
@@ -1153,12 +1057,32 @@ contains
call grid_end(sys%gr)
- call system_end(sys)
+ call sys%system_end()
POP_SUB(electrons_finalize)
+ contains
+ subroutine deallocate_ext_partners()
+
+ type(partner_iterator_t) :: iter
+ class(interaction_partner_t), pointer :: partner
+
+ call iter%start(sys%ext_partners)
+ do while (iter%has_next())
+ partner => iter%get_next()
+ SAFE_DEALLOCATE_P(partner)
+ end do
+ call sys%ext_partners%empty()
+ end subroutine deallocate_ext_partners
end subroutine electrons_finalize
-end module electrons_oct_m
+ module subroutine electrons_post_init(this)
+ class(electrons_t), intent(inout) :: this
+
+ call this%system_post_init()
+ call this%hm%post_init()
+ end subroutine electrons_post_init
+
+end submodule impl
!! Local Variables:
!! mode: f90
diff --git a/src/electrons/electrons_extension.F90 b/src/electrons/electrons_extension.F90
new file mode 100644
index 0000000000000000000000000000000000000000..fe30b6b2c7d9ac1a2c96a460d4f1956d40c05b60
--- /dev/null
+++ b/src/electrons/electrons_extension.F90
@@ -0,0 +1,56 @@
+submodule (electrons_extension_oct_m) impl
+ use system_extension_oct_m
+ use system_oct_m
+ implicit none
+contains
+ module subroutine electrons_extension_def_init(this, name, priority, unique)
+ class(electrons_extension_def_t), target, intent(inout) :: this
+ character(*), intent(in) :: name
+ integer, intent(in) :: priority
+ logical, intent(in) :: unique
+
+ ! Call base constructor
+ call this%system_extension_def_init(name, priority, unique)
+ end subroutine electrons_extension_def_init
+
+ module subroutine electrons_extension_def_end(this)
+ class(electrons_extension_def_t), intent(inout) :: this
+
+ ! Call base destructor
+ call this%system_extension_def_end()
+ end subroutine electrons_extension_def_end
+
+ module subroutine electrons_extension_init(this, def, sys)
+ class(electrons_extension_t), target, intent(inout) :: this
+ class(electrons_extension_def_t), pointer, intent(in) :: def
+ class(electrons_t), pointer, intent(in) :: sys
+
+ class(system_extension_def_t), pointer :: ext_def
+ class(system_t), pointer :: ext_sys
+
+ ! Intel compiler complains about dummy argument
+ ext_def => def
+ ext_sys => sys
+
+ this%electrons => sys
+ ! Nothing special to do, just call base constructor
+ call this%system_extension_init(ext_def, ext_sys)
+ end subroutine electrons_extension_init
+
+ module subroutine electrons_extension_post_init(this)
+ class(electrons_extension_t), target, intent(inout) :: this
+
+ call this%system_extension_t%post_init()
+ end subroutine electrons_extension_post_init
+
+ module subroutine electrons_extension_end(this)
+ type(electrons_extension_t), intent(inout) :: this
+
+ ! Nothing special to do
+ end subroutine electrons_extension_end
+
+ module subroutine electrons_extension_propagation_operation(this)
+ class(electrons_extension_t), intent(inout) :: this
+ ! Do nothing
+ end subroutine electrons_extension_propagation_operation
+end submodule impl
diff --git a/src/electrons/electrons_extension_h.F90 b/src/electrons/electrons_extension_h.F90
new file mode 100644
index 0000000000000000000000000000000000000000..3cb3adda76f1b38c6aa235c31c58978533c025de
--- /dev/null
+++ b/src/electrons/electrons_extension_h.F90
@@ -0,0 +1,94 @@
+module electrons_extension_oct_m
+ use electrons_oct_m
+ use system_extension_oct_m
+ implicit none
+
+ private
+
+ !> Electon system extension
+ !!
+ !! Enables adding specific functionalities to electron systems non-intrusively.
+ type, extends(system_extension_t), public :: electrons_extension_t
+ private
+ class(electrons_t), pointer, public :: electrons
+ contains
+ private
+ procedure, public :: electrons_extension_init
+ procedure, public :: post_init => electrons_extension_post_init
+ !> Extension run before propagation step
+ procedure, public :: pre_propagation_legacy => electrons_extension_propagation_operation
+ !> Extension run after propagation step
+ procedure, public :: post_propagation_legacy => electrons_extension_propagation_operation
+ final :: electrons_extension_end
+ end type electrons_extension_t
+
+ !> System extension definition
+ !!
+ !! Stores metadata of system extension
+ type, extends(system_extension_def_t), abstract, public :: electrons_extension_def_t
+ private
+ contains
+ private
+ procedure, public :: electrons_extension_def_init
+ procedure, public :: electrons_extension_def_end
+ end type electrons_extension_def_t
+
+ interface
+ !> Constructor for the abstract class electrons_extension_def_t
+ !!
+ !! Fortran limitation: Cannot define abstract constructor. Have to use subroutine instead.
+ !!
+ !! IMPORTANT: The actual constructors must call this subroutine exactly ONCE
+ !!
+ !! @param this electrons_extension_def_t object
+ !! @param name Value of this%name
+ module subroutine electrons_extension_def_init(this, name, priority, unique)
+ class(electrons_extension_def_t), target, intent(inout) :: this
+ character(*), intent(in) :: name
+ integer, intent(in) :: priority
+ logical, intent(in) :: unique
+ end subroutine electrons_extension_def_init
+
+ !> Destructor for the abstract class electrons_extension_def_t
+ !!
+ !! Fortran limitation: Cannot define abstract destructor. Have to use subroutine instead.
+ !!
+ !! IMPORTANT: The actual destructors must call this subroutine exactly ONCE
+ !!
+ !! @param this electrons_extension_def_t object
+ module subroutine electrons_extension_def_end(this)
+ class(electrons_extension_def_t), intent(inout) :: this
+ end subroutine electrons_extension_def_end
+
+ !> Default base constructor for electrons_extension
+ !!
+ !! @param system Parent system of the extension
+ !! @return System extension
+ module subroutine electrons_extension_init(this, def, sys)
+ class(electrons_extension_t), target, intent(inout) :: this
+ class(electrons_extension_def_t), pointer, intent(in) :: def
+ class(electrons_t), pointer, intent(in) :: sys
+ end subroutine electrons_extension_init
+
+ !> Electrons extension post initializations
+ !!
+ !! @param this system_extension_t object
+ module subroutine electrons_extension_post_init(this)
+ class(electrons_extension_t), target, intent(inout) :: this
+ end subroutine electrons_extension_post_init
+
+ !> Electrons extension destructor
+ !!
+ !! @param this electrons_extension_t object
+ module subroutine electrons_extension_end(this)
+ type(electrons_extension_t), intent(inout) :: this
+ end subroutine electrons_extension_end
+
+ !> Stub: Do nothing operator
+ !!
+ !! @param this electrons_extension_t object
+ module subroutine electrons_extension_propagation_operation(this)
+ class(electrons_extension_t), intent(inout) :: this
+ end subroutine electrons_extension_propagation_operation
+ end interface
+end module electrons_extension_oct_m
diff --git a/src/electrons/electrons_h.F90 b/src/electrons/electrons_h.F90
new file mode 100644
index 0000000000000000000000000000000000000000..bb0157451eba5708bd8e78637f694b608c17b8b4
--- /dev/null
+++ b/src/electrons/electrons_h.F90
@@ -0,0 +1,204 @@
+module electrons_oct_m
+ use algorithm_factory_oct_m
+ use algorithm_oct_m
+ use current_oct_m
+ use dipole_oct_m
+ use electron_space_oct_m
+ use gauge_field_oct_m
+ use global_oct_m
+ use grid_oct_m
+ use hamiltonian_elec_oct_m
+ use interaction_oct_m
+ use interaction_partner_oct_m
+ use interaction_surrogate_oct_m
+ use ions_oct_m
+ use kpoints_oct_m
+ use lasers_oct_m
+ use mpi_oct_m
+ use multicomm_oct_m
+ use namespace_oct_m
+ use output_low_oct_m
+ use photons_oct_m
+ use scf_oct_m
+ use states_elec_oct_m
+ use system_oct_m
+ use td_oct_m
+ use v_ks_oct_m
+ use xc_interaction_oct_m
+
+ implicit none
+
+ private
+ public :: &
+ electrons_t
+
+
+ !> @brief Class describing the electron system
+ !!
+ !! This class describes a system of electrons and ions.
+ !!
+ !! \todo move the ions into their own ions_t class.
+ type, extends(system_t) :: electrons_t
+ ! Components are public by default
+ type(electron_space_t) :: space
+ class(ions_t), pointer :: ions => NULL() !< the ion component of the system
+ type(photons_t), pointer :: photons => null()
+ type(grid_t) :: gr !< the mesh
+ type(states_elec_t) :: st !< the states
+ type(v_ks_t) :: ks !< the Kohn-Sham potentials
+ type(output_t) :: outp !< the output
+ type(multicomm_t) :: mc !< index and domain communicators
+ type(hamiltonian_elec_t) :: hm !< the Hamiltonian
+ type(td_t) :: td !< everything related to time propagation
+ type(current_t) :: current_calculator
+ type(dipole_t) :: dipole !< total dipole of electrons and ions
+ type(scf_t) :: scf !< SCF for BOMD
+
+ type(kpoints_t) :: kpoints !< the k-points
+
+ logical :: generate_epot
+
+ type(states_elec_t) :: st_copy !< copy of the states
+
+ ! At the moment this is not treated as an external potential
+ class(lasers_t), pointer :: lasers => null() !< lasers
+ class(gauge_field_t), pointer :: gfield => null() !< gauge field
+
+ ! List with all the external partners
+ ! This will become a list of interactions in the future
+ type(partner_list_t) :: ext_partners
+
+ !TODO: have a list of self interactions
+ type(xc_interaction_t), pointer :: xc_interaction => null()
+
+ logical :: ions_propagated = .false.
+ contains
+ procedure :: post_init => electrons_post_init
+ procedure :: init_interaction => electrons_init_interaction
+ procedure :: init_parallelization => electrons_init_parallelization
+ procedure :: init_algorithm => electrons_init_algorithm
+ procedure :: initial_conditions => electrons_initial_conditions
+ procedure :: do_algorithmic_operation => electrons_do_algorithmic_operation
+ procedure :: is_tolerance_reached => electrons_is_tolerance_reached
+ procedure :: update_quantity => electrons_update_quantity
+ procedure :: init_interaction_as_partner => electrons_init_interaction_as_partner
+ procedure :: copy_quantities_to_interaction => electrons_copy_quantities_to_interaction
+ procedure :: output_start => electrons_output_start
+ procedure :: output_write => electrons_output_write
+ procedure :: output_finish => electrons_output_finish
+ procedure :: process_is_slave => electrons_process_is_slave
+ procedure :: restart_write_data => electrons_restart_write_data
+ procedure :: restart_read_data => electrons_restart_read_data
+ procedure :: update_kinetic_energy => electrons_update_kinetic_energy
+ procedure :: propagation_start => electrons_propagation_start
+ final :: electrons_finalize
+ end type electrons_t
+
+ interface electrons_t
+ procedure electrons_constructor
+ end interface electrons_t
+
+ interface
+ !> see system_t%post_init
+ module subroutine electrons_post_init(this)
+ class(electrons_t), intent(inout) :: this
+ end subroutine electrons_post_init
+
+ module function electrons_constructor(namespace, generate_epot) result(sys)
+ type(namespace_t), intent(in) :: namespace
+ logical, optional, intent(in) :: generate_epot
+ class(electrons_t), pointer :: sys
+ end function electrons_constructor
+
+ module subroutine electrons_init_interaction(this, interaction)
+ class(electrons_t), target, intent(inout) :: this
+ class(interaction_t), intent(inout) :: interaction
+ end subroutine electrons_init_interaction
+
+ module subroutine electrons_init_parallelization(this, grp)
+ class(electrons_t), intent(inout) :: this
+ type(mpi_grp_t), intent(in) :: grp
+ end subroutine electrons_init_parallelization
+
+ module subroutine electrons_init_algorithm(this, factory)
+ class(electrons_t), intent(inout) :: this
+ class(algorithm_factory_t), intent(in) :: factory
+ end subroutine electrons_init_algorithm
+
+ module subroutine electrons_initial_conditions(this)
+ class(electrons_t), intent(inout) :: this
+ end subroutine electrons_initial_conditions
+
+ module subroutine electrons_propagation_start(this)
+ class(electrons_t), intent(inout) :: this
+ end subroutine electrons_propagation_start
+
+ module function electrons_do_algorithmic_operation(this, operation, updated_quantities) result(done)
+ class(electrons_t), intent(inout) :: this
+ class(algorithmic_operation_t), intent(in) :: operation
+ integer, allocatable, intent(out) :: updated_quantities(:)
+ logical :: done
+ end function electrons_do_algorithmic_operation
+
+ module function electrons_is_tolerance_reached(this, tol) result(converged)
+ class(electrons_t), intent(in) :: this
+ real(real64), intent(in) :: tol
+ logical :: converged
+ end function electrons_is_tolerance_reached
+
+ module subroutine electrons_update_quantity(this, iq)
+ class(electrons_t), intent(inout) :: this
+ integer, intent(in) :: iq
+ end subroutine electrons_update_quantity
+
+ module subroutine electrons_update_exposed_quantity(partner, iq)
+ class(electrons_t), intent(inout) :: partner
+ integer, intent(in) :: iq
+ end subroutine electrons_update_exposed_quantity
+
+ module subroutine electrons_init_interaction_as_partner(partner, interaction)
+ class(electrons_t), intent(in) :: partner
+ class(interaction_surrogate_t), intent(inout) :: interaction
+ end subroutine electrons_init_interaction_as_partner
+
+ module subroutine electrons_copy_quantities_to_interaction(partner, interaction)
+ class(electrons_t), intent(inout) :: partner
+ class(interaction_surrogate_t), intent(inout) :: interaction
+ end subroutine electrons_copy_quantities_to_interaction
+
+ module subroutine electrons_output_start(this)
+ class(electrons_t), intent(inout) :: this
+ end subroutine electrons_output_start
+
+ module subroutine electrons_output_write(this)
+ class(electrons_t), intent(inout) :: this
+ end subroutine electrons_output_write
+
+ module subroutine electrons_output_finish(this)
+ class(electrons_t), intent(inout) :: this
+ end subroutine electrons_output_finish
+
+ module function electrons_process_is_slave(this) result(is_slave)
+ class(electrons_t), intent(in) :: this
+ logical :: is_slave
+ end function electrons_process_is_slave
+
+ module subroutine electrons_restart_write_data(this)
+ class(electrons_t), intent(inout) :: this
+ end subroutine electrons_restart_write_data
+
+ module function electrons_restart_read_data(this) result(res)
+ class(electrons_t), intent(inout) :: this
+ logical :: res
+ end function electrons_restart_read_data
+
+ module subroutine electrons_update_kinetic_energy(this)
+ class(electrons_t), intent(inout) :: this
+ end subroutine electrons_update_kinetic_energy
+
+ module subroutine electrons_finalize(sys)
+ type(electrons_t), intent(inout) :: sys
+ end subroutine electrons_finalize
+ end interface
+
+end module electrons_oct_m
diff --git a/src/extensions/CMakeLists.txt b/src/extensions/CMakeLists.txt
new file mode 100644
index 0000000000000000000000000000000000000000..96e8b2dfafe343f2db0639c8626e97d63b7b7e0f
--- /dev/null
+++ b/src/extensions/CMakeLists.txt
@@ -0,0 +1,5 @@
+target_sources(Octopus_lib PRIVATE
+ all_system_extensions.F90
+ extension.F90
+ extension_h.F90
+ )
diff --git a/src/extensions/all_system_extensions.F90 b/src/extensions/all_system_extensions.F90
new file mode 100644
index 0000000000000000000000000000000000000000..22378053258d495e945a86056989a6cf8d38ebf6
--- /dev/null
+++ b/src/extensions/all_system_extensions.F90
@@ -0,0 +1,12 @@
+submodule (extension_oct_m) all_system_extensions
+ implicit none
+contains
+ module subroutine init_all_extension_def()
+ class(extension_def_t), pointer :: def
+
+ call all_extension_defs%init()
+ end subroutine init_all_extension_def
+ module subroutine end_all_extension_def()
+ ! TODO: Implement
+ end subroutine end_all_extension_def
+end submodule all_system_extensions
diff --git a/src/extensions/extension.F90 b/src/extensions/extension.F90
new file mode 100644
index 0000000000000000000000000000000000000000..40d54519865051e97a91c4d1cb29b6624a41dbce
--- /dev/null
+++ b/src/extensions/extension.F90
@@ -0,0 +1,373 @@
+#include "global.h"
+
+submodule (extension_oct_m) impl
+ use write_iter_oct_m
+ implicit none
+contains
+ module function extension_def_get_name(this) result(res)
+ class(extension_def_t), intent(in) :: this
+ character(:), allocatable :: res
+
+ ASSERT(allocated(this%name))
+ allocate(character(len(this%name))::res)
+ res = this%name
+ end function extension_def_get_name
+
+ module function extension_def_get_priority(this) result(res)
+ class(extension_def_t), intent(in) :: this
+ integer :: res
+
+ res = this%priority
+ end function extension_def_get_priority
+
+ module function extension_def_get_unique(this) result(res)
+ class(extension_def_t), intent(in) :: this
+ logical :: res
+
+ res = this%unique
+ end function extension_def_get_unique
+
+ module function extension_get_def(this) result(res)
+ class(extension_t), intent(in) :: this
+ class(extension_def_t), pointer :: res
+
+ res => this%def
+ end function extension_get_def
+
+ module subroutine extension_def_init(this, name, priority, unique)
+ class(extension_def_t), target, intent(inout) :: this
+ character(*), intent(in) :: name
+ integer, intent(in) :: priority
+ logical, intent(in) :: unique
+
+ logical :: exists
+ class(*), pointer :: raw_ptr
+
+ raw_ptr => this
+
+ ! Extension_def name should be unique
+ exists = all_extension_defs%has_key(name)
+ ASSERT(.not. exists)
+
+ ! Do the initialization
+ this%name = name
+ this%priority = priority
+ this%unique = unique
+ ! Register the extension_def to the global dictionary
+ call all_extension_defs%set_ptr(name, raw_ptr)
+ end subroutine extension_def_init
+
+ module subroutine extension_def_end(this)
+ class(extension_def_t), target, intent(inout) :: this
+
+ logical :: exists
+ class(extension_def_t), pointer :: dict_item_ptr
+ class(*), pointer :: raw_ptr
+
+ ! Delete extension from extension dictionary
+ ASSERT(allocated(this%name))
+ exists = all_extension_defs%has_key(this%name)
+ ASSERT(exists)
+ call all_extension_defs%get_raw_ptr(this%name, raw_ptr)
+ ASSERT(associated(raw_ptr, this))
+ call all_extension_defs%delete_key(this%name)
+
+ if(allocated(this%name)) then;
+ deallocate(this%name)
+ end if
+ end subroutine extension_def_end
+
+ module subroutine extension_init(this, def, ext_list)
+ class(extension_t), target, intent(inout) :: this
+ class(extension_def_t), pointer, intent(in) :: def
+ class(extension_list_t), target, intent(inout) :: ext_list
+
+ type(extension_iterator_t) :: ext_iter
+ class(extension_t), pointer :: list_item
+ class(extension_def_t), pointer :: list_item_def
+
+ this%def => def
+ this%list => ext_list
+
+ ! Add the extension to the extension list in the correct order
+ call ext_iter%start(ext_list)
+ if (.not. ext_iter%has_next()) then
+ ! If the list is empty, just add the extension
+ call ext_list%push_front(this)
+ else
+ list_item => ext_iter%get()
+ list_item_def => list_item%get_def()
+ if ( this%def%get_priority() < list_item_def%get_priority() ) then
+ ! Add it to the top
+ call ext_list%push_front(this)
+ return
+ end if
+ ! Go through the list until the first item with a bigger priority value is seen
+ do while (.true.)
+ ! list_item here always looks at the next item (not the current one (get/get_next)) after the current iteration
+ list_item => ext_iter%peek_next()
+ ! Check if we are at the end of the list
+ if ( .not. associated(list_item)) then
+ ! Finish searching and continue to add the extension
+ exit
+ end if
+ list_item_def => list_item%get_def()
+ ! Check if the next item has a bigger priority value
+ if ( this%def%get_priority() < list_item_def%get_priority() ) then
+ ! Finish searching and continue to add the extension
+ exit
+ end if
+ ! Advance the iterator. Note the list_item (current one) here is discared in the next loop
+ list_item => ext_iter%get_next()
+ end do
+ ! Add the extension between the current value and the next
+ call ext_list%insert_after_iterator(ext_iter, this)
+ end if
+ end subroutine extension_init
+
+ module subroutine extension_end(this)
+ type(extension_t), intent(inout) :: this
+
+ integer :: i_handle
+
+ ! Deconstruct the output handles
+ if (allocated(this%output_handles)) then
+ do i_handle = 1, size(this%output_handles)
+ call write_iter_end(this%output_handles(i_handle))
+ end do
+ ! Deconstruct the output handle array
+ deallocate(this%output_handles)
+ end if
+
+ ! De-register self from the extension list
+ call this%list%delete(this)
+ end subroutine extension_end
+
+ module subroutine extension_post_init(this)
+ class(extension_t), target, intent(inout) :: this
+
+ ! Do nothing
+ end subroutine extension_post_init
+
+ module subroutine extension_parse_block(this, block, ind)
+ class(extension_t), intent(inout) :: this
+ class(block_t), intent(in) :: block
+ integer, intent(in) :: ind
+
+ ! Do nothing
+ end subroutine extension_parse_block
+
+ module subroutine extension_output(this)
+ class(extension_t), intent(inout) :: this
+
+ ! Do nothing
+ end subroutine extension_output
+
+ module function extension_restrart_read(this) result(res)
+ class(extension_t), intent(inout) :: this
+ logical :: res
+
+ ! Do nothing
+ res = .true.
+ end function extension_restrart_read
+
+ module subroutine extension_restrart_write(this)
+ class(extension_t), intent(inout) :: this
+
+ ! Do nothing
+ end subroutine extension_restrart_write
+end submodule impl
+
+submodule (extension_oct_m) boilerplate
+ implicit none
+
+contains
+ module subroutine extension_def_list_push_back(this, item)
+ class(extension_def_list_t), intent(inout) :: this
+ class(extension_def_t), target, intent(in) :: item
+
+ select type (item)
+ class is (extension_def_t)
+ call this%push_back_node(item, clone=.false.)
+ class default
+ ASSERT(.false.)
+ end select
+ end subroutine extension_def_list_push_back
+
+ module subroutine extension_def_list_push_front(this, item)
+ class(extension_def_list_t), intent(inout) :: this
+ class(extension_def_t), target, intent(in) :: item
+
+ select type (item)
+ class is (extension_def_t)
+ call this%push_front_node(item, clone=.false.)
+ class default
+ ASSERT(.false.)
+ end select
+ end subroutine extension_def_list_push_front
+
+ module subroutine extension_def_list_insert_after_iterator(this, iterator, item)
+ class(extension_def_list_t), intent(inout) :: this
+ class(extension_def_iterator_t), intent(in) :: iterator
+ class(extension_def_t), target, intent(in) :: item
+
+ select type (item)
+ class is (extension_def_t)
+ call this%insert_node_after_iterator(iterator, item, clone=.false.)
+ class default
+ ASSERT(.false.)
+ end select
+ end subroutine extension_def_list_insert_after_iterator
+
+ module subroutine extension_list_push_back(this, item)
+ class(extension_list_t), intent(inout) :: this
+ class(extension_t), target, intent(in) :: item
+
+ select type (item)
+ class is (extension_t)
+ call this%push_back_node(item, clone=.false.)
+ class default
+ ASSERT(.false.)
+ end select
+ end subroutine extension_list_push_back
+
+ module subroutine extension_list_push_front(this, item)
+ class(extension_list_t), intent(inout) :: this
+ class(extension_t), target, intent(in) :: item
+
+ select type (item)
+ class is (extension_t)
+ call this%push_front_node(item, clone=.false.)
+ class default
+ ASSERT(.false.)
+ end select
+ end subroutine extension_list_push_front
+
+ module subroutine extension_list_insert_after_iterator(this, iterator, item)
+ class(extension_list_t), intent(inout) :: this
+ class(extension_iterator_t), intent(in) :: iterator
+ class(extension_t), target, intent(in) :: item
+
+ select type (item)
+ class is (extension_t)
+ call this%insert_node_after_iterator(iterator, item, clone=.false.)
+ class default
+ ASSERT(.false.)
+ end select
+ end subroutine extension_list_insert_after_iterator
+
+ module function extension_list_has_ext(this, name) result(res)
+ class(extension_list_t), intent(in) :: this
+ character(*), intent(in) :: name
+ logical :: res
+
+ type(extension_iterator_t) :: iter
+ class(extension_t), pointer :: extension
+
+ res = .false.
+
+ call iter%start(this)
+ do while (iter%has_next())
+ extension => iter%get_next()
+ if (extension%def%name == name) then
+ res = .true.
+ return
+ end if
+ end do
+ end function extension_list_has_ext
+
+ module function extension_def_iterator_get(this) result(res)
+ class(extension_def_iterator_t), intent(inout) :: this
+ class(extension_def_t), pointer :: res
+
+ select type (ptr => this%get_ptr())
+ class is (extension_def_t)
+ res => ptr
+ class default
+ ASSERT(.false.)
+ end select
+ end function extension_def_iterator_get
+
+ module function extension_def_iterator_get_next(this) result(res)
+ class(extension_def_iterator_t), intent(inout) :: this
+ class(extension_def_t), pointer :: res
+
+ select type (ptr => this%get_next_ptr())
+ class is (extension_def_t)
+ res => ptr
+ class default
+ ASSERT(.false.)
+ end select
+ end function extension_def_iterator_get_next
+
+ module function extension_def_iterator_peek_next(this) result(res)
+ class(extension_def_iterator_t), intent(inout) :: this
+ class(extension_def_t), pointer :: res
+
+ class(*), pointer :: ptr
+
+ if (.not. this%has_next()) then
+ res => null()
+ else
+ ptr => this%peek_next_ptr()
+ if (.not. associated(ptr)) then
+ res => null()
+ return
+ end if
+ select type (ptr)
+ class is (extension_def_t)
+ res => ptr
+ class default
+ ASSERT(.false.)
+ end select
+ end if
+ end function extension_def_iterator_peek_next
+
+ module function extension_iterator_get(this) result(res)
+ class(extension_iterator_t), intent(inout) :: this
+ class(extension_t), pointer :: res
+
+ select type (ptr => this%get_ptr())
+ class is (extension_t)
+ res => ptr
+ class default
+ ASSERT(.false.)
+ end select
+ end function extension_iterator_get
+
+ module function extension_iterator_get_next(this, reverse) result(res)
+ class(extension_iterator_t), intent(inout) :: this
+ logical, optional, intent(in) :: reverse
+ class(extension_t), pointer :: res
+
+ select type (ptr => this%get_next_ptr(reverse))
+ class is (extension_t)
+ res => ptr
+ class default
+ ASSERT(.false.)
+ end select
+ end function extension_iterator_get_next
+
+ module function extension_iterator_peek_next(this) result(res)
+ class(extension_iterator_t), intent(inout) :: this
+ class(extension_t), pointer :: res
+
+ class(*), pointer :: ptr
+
+ if (.not. this%has_next()) then
+ res => null()
+ else
+ ptr => this%peek_next_ptr()
+ if (.not. associated(ptr)) then
+ res => null()
+ return
+ end if
+ select type (ptr)
+ class is (extension_t)
+ res => ptr
+ class default
+ ASSERT(.false.)
+ end select
+ end if
+ end function extension_iterator_peek_next
+end submodule boilerplate
diff --git a/src/extensions/extension_h.F90 b/src/extensions/extension_h.F90
new file mode 100644
index 0000000000000000000000000000000000000000..97d28af4c15c1d1caf766ddaeebe26abc6656676
--- /dev/null
+++ b/src/extensions/extension_h.F90
@@ -0,0 +1,374 @@
+module extension_oct_m
+ use dict_oct_m
+ use iso_c_binding
+ use linked_list_oct_m, only: linked_list_t, linked_list_iterator_t
+ use parser_oct_m, only: block_t
+ implicit none
+ private
+ public :: &
+ init_all_extension_def, &
+ end_all_extension_def
+
+ !!! Boilerplate
+
+ !> List of extension_def_t
+ !!
+ !! Ensures the nodes in the list are of extension_def_t type
+ type, public, extends(linked_list_t) :: extension_def_list_t
+ private
+ contains
+ private
+ procedure, public :: push_back => extension_def_list_push_back
+ procedure, public :: push_front => extension_def_list_push_front
+ procedure, public :: insert_after_iterator => extension_def_list_insert_after_iterator
+ end type extension_def_list_t
+
+ !> Iterator of extension_def_t list
+ !!
+ !! Gets linked list node with appropriate type
+ type, public, extends(linked_list_iterator_t) :: extension_def_iterator_t
+ private
+ contains
+ private
+ procedure, public :: get => extension_def_iterator_get
+ procedure, public :: get_next => extension_def_iterator_get_next
+ procedure, public :: peek_next => extension_def_iterator_peek_next
+ end type extension_def_iterator_t
+
+ !> List of extensions
+ !!
+ !! Ensures the nodes in the list are of extension_t type
+ type, public, extends(linked_list_t) :: extension_list_t
+ private
+ contains
+ private
+ procedure, public :: push_back => extension_list_push_back
+ procedure, public :: push_front => extension_list_push_front
+ procedure, public :: insert_after_iterator => extension_list_insert_after_iterator
+ procedure, public :: has_ext => extension_list_has_ext
+ end type extension_list_t
+
+ !> Iterator of extension_t list
+ !!
+ !! Gets linked list node with appropriate type
+ type, public, extends(linked_list_iterator_t) :: extension_iterator_t
+ private
+ contains
+ private
+ procedure, public :: get => extension_iterator_get
+ procedure, public :: get_next => extension_iterator_get_next
+ procedure, public :: peek_next => extension_iterator_peek_next
+ end type extension_iterator_t
+
+ !> System extension
+ !!
+ !! Enables adding functionalities to the systems non-intrusively.
+ type, public :: extension_t
+ private
+ class(extension_def_t), pointer :: def => null()
+ class(extension_list_t), pointer :: list => null()
+ type(c_ptr), public, allocatable :: output_handles(:)
+
+ contains
+ private
+ ! Fortran limitation: No proper move constructors
+ procedure, public :: extension_init
+ !> Post initialization. Executed just after system is initialized
+ procedure, public :: post_init => extension_post_init
+ !> Getter: this%def
+ procedure, public :: get_def => extension_get_def
+ !> Parse the input data associated with the extension
+ procedure, public :: parse_block => extension_parse_block
+ !> Get restart data
+ procedure, public :: restart_read => extension_restrart_read
+ !> Write restart data
+ procedure, public :: restart_write => extension_restrart_write
+ !> Write output at each iteration
+ procedure, public :: output => extension_output
+ !> Extension destructor
+ final :: extension_end
+ end type extension_t
+
+ !> Extension definition
+ !!
+ !! Stores metadata of the extension and its constructor
+ !! Has to be a singleton. All identities are in all_extension_defs
+ !!
+ type, public, abstract :: extension_def_t
+ private
+ character(:), allocatable :: name
+ integer :: priority
+ logical :: unique
+ contains
+ private
+ ! Fotran limitaion: This should be an abstract constructor
+ ! Fotran limitaion: This should be protected
+ procedure, public :: extension_def_init
+ ! Fotran limitaion: This should be an abstract destructor
+ ! Fotran limitaion: This should be protected
+ procedure, public :: extension_def_end
+ !> Getter: this%name
+ procedure, public :: get_name => extension_def_get_name
+ !> Getter: this%priority
+ procedure, public :: get_priority => extension_def_get_priority
+ !> Getter: this%unique
+ procedure, public :: get_unique => extension_def_get_unique
+ !> Extension factory interface
+ procedure(extension_creator), public, deferred :: create_extension
+ end type extension_def_t
+
+ !!! Global variables
+ !> Dictionary of all registered extension definitions
+ type(dict_t), public :: all_extension_defs
+
+ !!! Global subroutines/functions
+ interface
+ !> Initialise all extension_def
+ !!
+ !! Fortran limitaion: Cannot initialize global object variables.
+ !! Have to call all the initializers in one subroutine
+ module subroutine init_all_extension_def()
+ end subroutine init_all_extension_def
+ !> Deconstruct all extension_def
+ !!
+ !! Fortran limitaion: Cannot initialize global object variables.
+ !! Have to call all the initializers in one subroutine
+ module subroutine end_all_extension_def()
+ end subroutine end_all_extension_def
+ end interface
+
+ !!! Abstract methods
+ abstract interface
+ !> Create a system extension object
+ !!
+ !! Factory function for extensions matching their extension_def_t
+ !!
+ !! @param this extension_def_t object
+ !! @param parent Parent object that is being extended
+ !! @return Pointer to the extension
+ function extension_creator(this, parent) result(ext)
+ import extension_def_t, extension_t
+ class(extension_def_t), target, intent(in) :: this
+ class(*), pointer, intent(inout) :: parent
+ class(extension_t), pointer :: ext
+ end function extension_creator
+ end interface
+
+ !!! Getter/Setters
+ interface
+ !> Getter: extension_def_t%name
+ module function extension_def_get_name(this) result(res)
+ class(extension_def_t), intent(in) :: this
+ character(:), allocatable :: res
+ end function extension_def_get_name
+
+ !> Getter: extension_def_t%priority
+ module function extension_def_get_priority(this) result(res)
+ class(extension_def_t), intent(in) :: this
+ integer :: res
+ end function extension_def_get_priority
+
+ !> Getter: extension_def_t%unqiue
+ module function extension_def_get_unique(this) result(res)
+ class(extension_def_t), intent(in) :: this
+ logical :: res
+ end function extension_def_get_unique
+
+ !> Getter: extension_t%def
+ module function extension_get_def(this) result(res)
+ class(extension_t), intent(in) :: this
+ class(extension_def_t), pointer :: res
+ end function extension_get_def
+ end interface
+
+ !!! Subroutine/Functions
+ interface
+ !> Constructor for the abstract class extension_def_t
+ !!
+ !! Fortran limitation: Cannot define abstract constructor. Have to use subroutine instead.
+ !!
+ !! IMPORTANT: The actual constructors must call this subroutine exactly ONCE
+ !!
+ !! @param this extension_def_t object
+ !! @param name Value of this%name
+ !! @param priority Value of this%priority
+ !! @param unique Value of this%unique
+ module subroutine extension_def_init(this, name, priority, unique)
+ class(extension_def_t), target, intent(inout) :: this
+ character(*), intent(in) :: name
+ integer, intent(in) :: priority
+ logical, intent(in) :: unique
+ end subroutine extension_def_init
+
+ !> Destructor for the abstract class extension_def_t
+ !!
+ !! Fortran limitation: Cannot define abstract destructor. Have to use subroutine instead.
+ !!
+ !! IMPORTANT: The actual destructors must call this subroutine exactly ONCE
+ !!
+ !! @param this extension_def_t object
+ module subroutine extension_def_end(this)
+ class(extension_def_t), target, intent(inout) :: this
+ end subroutine extension_def_end
+ !> Constructor for the class extension_t
+ !!
+ !! Fortran limitation: Cannot define proper copy/move constructor. Have to use subroutine instead.
+ !!
+ !! IMPORTANT: The actual constructors must call this subroutine exactly ONCE
+ !!
+ !! @param this extension_t object
+ !! @param name Value of this%name
+ module subroutine extension_init(this, def, ext_list)
+ class(extension_t), target, intent(inout) :: this
+ class(extension_def_t), pointer, intent(in) :: def
+ class(extension_list_t), target, intent(inout) :: ext_list
+ end subroutine extension_init
+
+ !> Destructor for the class extension_t
+ !!
+ !! @param this extension_def_t object
+ module subroutine extension_end(this)
+ type(extension_t), intent(inout) :: this
+ end subroutine extension_end
+
+ !> Extension post initializations
+ !!
+ !! Run after all parent objects have finished initializing
+ !!
+ !! @param this extension_t object
+ module subroutine extension_post_init(this)
+ class(extension_t), target, intent(inout) :: this
+ end subroutine extension_post_init
+
+ !> Extension parse input data
+ !!
+ !! Parse additional input variables
+ !!
+ !! @param this extension_t object
+ !! @param block parser block containing additional variable data
+ !! @param ind parser block index corresponding to this extension
+ module subroutine extension_parse_block(this, block, ind)
+ class(extension_t), intent(inout) :: this
+ class(block_t), intent(in) :: block
+ integer, intent(in) :: ind
+ end subroutine extension_parse_block
+
+ !> Write output at each iteration
+ !!
+ !! Note: the extension should check if it should write an output for the
+ !! current iteration or not
+ !!
+ !! The extension is responsible for initializing output_handles
+ !! The outputs are automatically ended by the base system deconstructor
+ !!
+ !! @param this extension_t object
+ module subroutine extension_output(this)
+ class(extension_t), intent(inout) :: this
+ ! TODO: Add iteration index to system_output_write
+ end subroutine extension_output
+
+ !> Read restart data
+ !!
+ !! @param this extension_t object
+ !! @return Whether the restart data was loaded correctly
+ module function extension_restrart_read(this) result(res)
+ class(extension_t), intent(inout) :: this
+ logical :: res
+ end function extension_restrart_read
+
+ !> Write restart data
+ !!
+ !! @param this extension_t object
+ !! @return Whether the restart data was loaded correctly
+ module subroutine extension_restrart_write(this)
+ class(extension_t), intent(inout) :: this
+ end subroutine extension_restrart_write
+ end interface
+
+ !!! Boilerplate Subroutine/Functions
+ interface
+
+ !> See list_t%push_back
+ module subroutine extension_def_list_push_back(this, item)
+ class(extension_def_list_t), intent(inout) :: this
+ class(extension_def_t), target, intent(in) :: item
+ end subroutine extension_def_list_push_back
+
+ !> See list_t%push_front
+ module subroutine extension_def_list_push_front(this, item)
+ class(extension_def_list_t), intent(inout) :: this
+ class(extension_def_t), target, intent(in) :: item
+ end subroutine extension_def_list_push_front
+
+ !> See list_t%insert_after_iterator
+ module subroutine extension_def_list_insert_after_iterator(this, iterator, item)
+ class(extension_def_list_t), intent(inout) :: this
+ class(extension_def_iterator_t), intent(in) :: iterator
+ class(extension_def_t), target, intent(in) :: item
+ end subroutine extension_def_list_insert_after_iterator
+
+ !> See list_t%push_back
+ module subroutine extension_list_push_back(this, item)
+ class(extension_list_t), intent(inout) :: this
+ class(extension_t), target, intent(in) :: item
+ end subroutine extension_list_push_back
+
+ !> See list_t%push_front
+ module subroutine extension_list_push_front(this, item)
+ class(extension_list_t), intent(inout) :: this
+ class(extension_t), target, intent(in) :: item
+ end subroutine extension_list_push_front
+
+ !> See list_t%insert_after_iterator
+ module subroutine extension_list_insert_after_iterator(this, iterator, item)
+ class(extension_list_t), intent(inout) :: this
+ class(extension_iterator_t), intent(in) :: iterator
+ class(extension_t), target, intent(in) :: item
+ end subroutine extension_list_insert_after_iterator
+
+ !> See list_t%insert_after_iterator
+ module function extension_list_has_ext(this, name) result(res)
+ class(extension_list_t), intent(in) :: this
+ character(*), intent(in) :: name
+ logical :: res
+ end function extension_list_has_ext
+
+ !> See list_iterator_t%get
+ module function extension_def_iterator_get(this) result(res)
+ class(extension_def_iterator_t), intent(inout) :: this
+ class(extension_def_t), pointer :: res
+ end function extension_def_iterator_get
+
+ !> See list_iterator_t%get_next
+ module function extension_def_iterator_get_next(this) result(res)
+ class(extension_def_iterator_t), intent(inout) :: this
+ class(extension_def_t), pointer :: res
+ end function extension_def_iterator_get_next
+
+ !> See list_iterator_t%peek_next
+ module function extension_def_iterator_peek_next(this) result(res)
+ class(extension_def_iterator_t), intent(inout) :: this
+ class(extension_def_t), pointer :: res
+ end function extension_def_iterator_peek_next
+
+ !> See list_iterator_t%get
+ module function extension_iterator_get(this) result(res)
+ class(extension_iterator_t), intent(inout) :: this
+ class(extension_t), pointer :: res
+ end function extension_iterator_get
+
+ !> See list_iterator_t%get_next
+ module function extension_iterator_get_next(this, reverse) result(res)
+ class(extension_iterator_t), intent(inout) :: this
+ logical, optional, intent(in) :: reverse
+ class(extension_t), pointer :: res
+ end function extension_iterator_get_next
+
+ !> See list_iterator_t%peek_next
+ module function extension_iterator_peek_next(this) result(res)
+ class(extension_iterator_t), intent(inout) :: this
+ class(extension_t), pointer :: res
+ end function extension_iterator_peek_next
+ end interface
+
+end module extension_oct_m
diff --git a/src/fdep/fortran_dependencies.pl b/src/fdep/fortran_dependencies.pl
index d9644ea6b71b40ae4bab6d619b7d396fa257f3e6..51bf106b3936241dafb06e18f14d0f87b29bc38f 100755
--- a/src/fdep/fortran_dependencies.pl
+++ b/src/fdep/fortran_dependencies.pl
@@ -17,8 +17,9 @@ my %files = ();
# mode is the first argument: either mod or inc
my $mode = shift;
-my $use_re = qr/^\s*use\s+(\S+)\s*$/;
-my $def_re = qr/^\s*(?:submodule|module)\s+(\S+)\s*$/;
+# Trick fdep to take `use *` and `submodule (*)` as dependency
+my $use_re = qr/^\s*(?:use|submodule)\s+\(?(\w+)\)?.*$/;
+my $def_re = qr/^\s*module\s+(\S+)\s*$/;
my $inc_re = qr/^\s*(\S+)\s*$/;
sub add_use {
diff --git a/src/grid/io_function.F90 b/src/grid/io_function.F90
index 6ee3531d6e7804bef403ef0dc5837f0b96696220..4fad9f976341c76f9431acfc704fc087d24d1132 100644
--- a/src/grid/io_function.F90
+++ b/src/grid/io_function.F90
@@ -67,6 +67,7 @@ module io_function_oct_m
write_xsf_geometry_file, &
dio_function_input, &
zio_function_input, &
+ io_function_output, &
dio_function_output, &
zio_function_output, &
io_function_output_vector, &
@@ -92,6 +93,10 @@ module io_function_oct_m
index2label(3) = (/ 're ', 'im ', 'abs' /)
+ interface io_function_output
+ module procedure dio_function_output, zio_function_output
+ end interface io_function_output
+
interface io_function_output_vector
module procedure dio_function_output_vector, zio_function_output_vector
end interface io_function_output_vector
diff --git a/src/grid/mesh_function.F90 b/src/grid/mesh_function.F90
index d1d68f323df66e6c47627f5295313ff8113cb841..b20e2176123cda80bdc48ed5f4351f4fec24f31d 100644
--- a/src/grid/mesh_function.F90
+++ b/src/grid/mesh_function.F90
@@ -45,6 +45,7 @@ module mesh_function_oct_m
zmf_integrate, &
dmf_dotp, &
zmf_dotp, &
+ mf_dotp, &
dmf_nrm2, &
zmf_nrm2, &
dmf_moment, &
@@ -68,6 +69,7 @@ module mesh_function_oct_m
zmf_nrm2_aux, &
dmf_normalize, &
zmf_normalize, &
+ mf_normalize, &
zmf_fix_phase
! These variables are to be used by the "distdot" function, that is outside the module
@@ -89,6 +91,15 @@ module mesh_function_oct_m
zmf_line_integral_scalar, zmf_line_integral_vector
end interface mf_line_integral
+ interface mf_dotp
+ module procedure dmf_dotp_1, dmf_dotp_2
+ module procedure zmf_dotp_1, zmf_dotp_2
+ end interface mf_dotp
+
+ interface mf_normalize
+ module procedure dmf_normalize, zmf_normalize
+ end interface mf_normalize
+
interface dmf_dotp
module procedure dmf_dotp_1, dmf_dotp_2
end interface dmf_dotp
@@ -97,6 +108,11 @@ module mesh_function_oct_m
module procedure zmf_dotp_1, zmf_dotp_2
end interface zmf_dotp
+ interface mf_nrm2
+ module procedure dmf_nrm2_1, dmf_nrm2_2
+ module procedure zmf_nrm2_1, zmf_nrm2_2
+ end interface mf_nrm2
+
interface dmf_nrm2
module procedure dmf_nrm2_1, dmf_nrm2_2
end interface dmf_nrm2
diff --git a/src/hamiltonian/CMakeLists.txt b/src/hamiltonian/CMakeLists.txt
index 803f9218f56b7ad0b9301925139084d124d144da..869fefb2eb45907a78dd78a8366834dcb91ba584 100644
--- a/src/hamiltonian/CMakeLists.txt
+++ b/src/hamiltonian/CMakeLists.txt
@@ -7,8 +7,12 @@ target_sources(Octopus_lib PRIVATE
ext_partner_list.F90
gauge_field.F90
hamiltonian_abst.F90
+ hamiltonian_abst_h.F90
hamiltonian_elec.F90
hamiltonian_elec_base.F90
+ hamiltonian_elec_h.F90
+ hamiltonian_extensions.F90
+ hamiltonian_extensions_h.F90
hgh_projector.F90
hirshfeld.F90
ion_interaction.F90
diff --git a/src/hamiltonian/hamiltonian_abst.F90 b/src/hamiltonian/hamiltonian_abst.F90
index 7ae72767d51559f80eb1829d22a0c4aa2a9849fc..d1da52c32bdf4072dd78af5e6a526ede7ff8a2f6 100644
--- a/src/hamiltonian/hamiltonian_abst.F90
+++ b/src/hamiltonian/hamiltonian_abst.F90
@@ -1,115 +1,198 @@
-!! Copyright (C) 2019 N. Tancogne-Dejean, M. Oliveira
-!!
-!! 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, 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 st program; if not, write to the Free Software
-!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-!! 02110-1301, USA.
-!!
#include "global.h"
-!> @brief This module defines an abstract class for Hamiltonians
-!!
-!! From this, the electronic and the Maxwell Hamiltonians are derived
-
-module hamiltonian_abst_oct_m
- use batch_oct_m
+submodule (hamiltonian_abst_oct_m) hamiltonian_abst_impl
use global_oct_m
- use mesh_oct_m
- use namespace_oct_m
-
+ use hamiltonian_extensions_oct_m
+ use messages_oct_m
+ use profiling_oct_m
implicit none
- private
-
- public :: &
- hamiltonian_abst_t
-
- !> @brief The abstract Hamiltonian class defines a skeleton for specific implementations
- type, abstract :: hamiltonian_abst_t
- !> Spectral range
- real(real64) :: spectral_middle_point
- real(real64) :: spectral_half_span
-
- contains
- procedure(is_hermitian), deferred :: is_hermitian !< @copydoc is_hermitian
- procedure(hamiltonian_update_span), deferred :: update_span !< @copydoc hamiltonian_update_span
- procedure(dhamiltonian_apply), deferred :: dapply !< @copydoc dhamiltonian_apply
- procedure(zhamiltonian_apply), deferred :: zapply !< @copydoc zhamiltonian_apply
- procedure(dhamiltonian_magnus_apply), deferred :: dmagnus_apply !< @copydoc dhamiltonian_magnus_apply
- procedure(zhamiltonian_magnus_apply), deferred :: zmagnus_apply !< @copydoc zhamiltonian_magnus_apply
- end type hamiltonian_abst_t
-
- abstract interface
- logical function is_hermitian(hm)
- import
- class(hamiltonian_abst_t), intent(in) :: hm
- end function is_hermitian
-
- subroutine hamiltonian_update_span(hm, delta, emin, namespace)
- import
- class(hamiltonian_abst_t), intent(inout) :: hm
- real(real64), intent(in) :: delta(:)
- real(real64), intent(in) :: emin
- type(namespace_t), intent(in) :: namespace
- end subroutine hamiltonian_update_span
-
- subroutine dhamiltonian_apply(hm, namespace, mesh, psib, hpsib, terms, set_bc)
- import
- class(hamiltonian_abst_t), intent(in) :: hm
- type(namespace_t), intent(in) :: namespace
- class(mesh_t), intent(in) :: mesh
- class(batch_t), target, intent(inout) :: psib
- class(batch_t), target, intent(inout) :: hpsib
- integer, optional, intent(in) :: terms
- logical, optional, intent(in) :: set_bc
- end subroutine dhamiltonian_apply
-
- subroutine zhamiltonian_apply(hm, namespace, mesh, psib, hpsib, terms, set_bc)
- import
- class(hamiltonian_abst_t), intent(in) :: hm
- type(namespace_t), intent(in) :: namespace
- class(mesh_t), intent(in) :: mesh
- class(batch_t), target, intent(inout) :: psib
- class(batch_t), target, intent(inout) :: hpsib
- integer, optional, intent(in) :: terms
- logical, optional, intent(in) :: set_bc
- end subroutine zhamiltonian_apply
-
- subroutine dhamiltonian_magnus_apply(hm, namespace, mesh, psib, hpsib, vmagnus)
- import
- class(hamiltonian_abst_t), intent(in) :: hm
- type(namespace_t), intent(in) :: namespace
- class(mesh_t), intent(in) :: mesh
- class(batch_t), intent(inout) :: psib
- class(batch_t), intent(inout) :: hpsib
- real(real64), intent(in) :: vmagnus(:, :, :)
- end subroutine dhamiltonian_magnus_apply
-
- subroutine zhamiltonian_magnus_apply(hm, namespace, mesh, psib, hpsib, vmagnus)
- import
- class(hamiltonian_abst_t), intent(in) :: hm
- type(namespace_t), intent(in) :: namespace
- class(mesh_t), intent(in) :: mesh
- class(batch_t), intent(inout) :: psib
- class(batch_t), intent(inout) :: hpsib
- real(real64), intent(in) :: vmagnus(:, :, :)
- end subroutine zhamiltonian_magnus_apply
- end interface
-
-end module hamiltonian_abst_oct_m
-
-
-!! Local Variables:
-!! mode: f90
-!! coding: utf-8
-!! End:
+contains
+ module subroutine hamiltonian_abst_init(this)
+ class(hamiltonian_abst_t), target, intent(inout) :: this
+
+ call this%context%init()
+ end subroutine
+
+ module subroutine hamiltonian_abst_post_init(this)
+ class(hamiltonian_abst_t), intent(inout) :: this
+
+ type(extension_iterator_t) :: iter_ext
+ class(extension_t), pointer :: extension
+
+ ! Run all post initialization of the extensions
+ call iter_ext%start(this%extensions)
+ do while (iter_ext%has_next())
+ extension => iter_ext%get_next()
+ call extension%post_init()
+ end do
+ end subroutine
+
+ module subroutine hamiltonian_abst_end(this)
+ class(hamiltonian_abst_t), intent(inout) :: this
+
+ type(extension_iterator_t) :: iter_ext
+ class(extension_t), pointer :: extension
+
+ call iter_ext%start(this%extensions)
+ do while (iter_ext%has_next())
+ extension => iter_ext%get_next()
+ SAFE_DEALLOCATE_P(extension)
+ end do
+ call this%extensions%empty()
+ end subroutine
+
+ module subroutine dhamiltonian_apply(hm, namespace, mesh, psib, hpsib, terms, set_bc)
+ class(hamiltonian_abst_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), target, intent(inout) :: psib
+ class(batch_t), target, intent(inout) :: hpsib
+ integer, optional, intent(in) :: terms
+ logical, optional, intent(in) :: set_bc
+
+ type(extension_iterator_t) :: iter_ext
+ class(extension_t), pointer :: extension
+
+ ! Run pre-extensions
+ call iter_ext%start(hm%extensions)
+ do while (iter_ext%has_next())
+ extension => iter_ext%get_next()
+ select type (extension)
+ class is (hamiltonian_extension_t)
+ call extension%pre_dapply(namespace, mesh, psib, hpsib)
+ class default
+ ASSERT(.false.)
+ end select
+ end do
+
+ call hm%dapply_impl(namespace, mesh, psib, hpsib, terms, set_bc)
+
+ ! Run post-extensions (in reverse order)
+ call iter_ext%start(hm%extensions, reverse=.true.)
+ do while (iter_ext%has_next())
+ extension => iter_ext%get_next(reverse=.true.)
+ select type (extension)
+ class is (hamiltonian_extension_t)
+ call extension%post_dapply(namespace, mesh, psib, hpsib)
+ class default
+ ASSERT(.false.)
+ end select
+ end do
+ end subroutine dhamiltonian_apply
+
+ module subroutine zhamiltonian_apply(hm, namespace, mesh, psib, hpsib, terms, set_bc)
+ class(hamiltonian_abst_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), target, intent(inout) :: psib
+ class(batch_t), target, intent(inout) :: hpsib
+ integer, optional, intent(in) :: terms
+ logical, optional, intent(in) :: set_bc
+
+ type(extension_iterator_t) :: iter_ext
+ class(extension_t), pointer :: extension
+
+ ! Run pre-extensions
+ call iter_ext%start(hm%extensions)
+ do while (iter_ext%has_next())
+ extension => iter_ext%get_next()
+ select type (extension)
+ class is (hamiltonian_extension_t)
+ call extension%pre_zapply(namespace, mesh, psib, hpsib)
+ class default
+ ASSERT(.false.)
+ end select
+ end do
+
+ call hm%zapply_impl(namespace, mesh, psib, hpsib, terms, set_bc)
+
+ ! Run post-extensions (in reverse order)
+ call iter_ext%start(hm%extensions, reverse=.true.)
+ do while (iter_ext%has_next())
+ extension => iter_ext%get_next(reverse=.true.)
+ select type (extension)
+ class is (hamiltonian_extension_t)
+ call extension%post_zapply(namespace, mesh, psib, hpsib)
+ class default
+ ASSERT(.false.)
+ end select
+ end do
+ end subroutine zhamiltonian_apply
+
+ module subroutine dhamiltonian_magnus_apply(hm, namespace, mesh, psib, hpsib, vmagnus)
+ class(hamiltonian_abst_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), intent(inout) :: psib
+ class(batch_t), intent(inout) :: hpsib
+ real(real64), intent(in) :: vmagnus(:, :, :)
+
+ type(extension_iterator_t) :: iter_ext
+ class(extension_t), pointer :: extension
+
+ ! Run pre-extensions
+ call iter_ext%start(hm%extensions)
+ do while (iter_ext%has_next())
+ extension => iter_ext%get_next()
+ select type (extension)
+ class is (hamiltonian_extension_t)
+ call extension%pre_dmagnus_apply(namespace, mesh, psib, hpsib)
+ class default
+ ASSERT(.false.)
+ end select
+ end do
+
+ call hm%dmagnus_apply_impl(namespace, mesh, psib, hpsib, vmagnus)
+
+ ! Run post-extensions (in reverse order)
+ call iter_ext%start(hm%extensions, reverse=.true.)
+ do while (iter_ext%has_next())
+ extension => iter_ext%get_next(reverse=.true.)
+ select type (extension)
+ class is (hamiltonian_extension_t)
+ call extension%post_dmagnus_apply(namespace, mesh, psib, hpsib)
+ class default
+ ASSERT(.false.)
+ end select
+ end do
+ end subroutine dhamiltonian_magnus_apply
+
+ module subroutine zhamiltonian_magnus_apply(hm, namespace, mesh, psib, hpsib, vmagnus)
+ class(hamiltonian_abst_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), intent(inout) :: psib
+ class(batch_t), intent(inout) :: hpsib
+ real(real64), intent(in) :: vmagnus(:, :, :)
+
+ type(extension_iterator_t) :: iter_ext
+ class(extension_t), pointer :: extension
+
+ ! Run pre-extensions
+ call iter_ext%start(hm%extensions)
+ do while (iter_ext%has_next())
+ extension => iter_ext%get_next()
+ select type (extension)
+ class is (hamiltonian_extension_t)
+ call extension%pre_zmagnus_apply(namespace, mesh, psib, hpsib)
+ class default
+ ASSERT(.false.)
+ end select
+ end do
+
+ call hm%zmagnus_apply_impl(namespace, mesh, psib, hpsib, vmagnus)
+
+ ! Run post-extensions (in reverse order)
+ call iter_ext%start(hm%extensions, reverse=.true.)
+ do while (iter_ext%has_next())
+ extension => iter_ext%get_next(reverse=.true.)
+ select type (extension)
+ class is (hamiltonian_extension_t)
+ call extension%post_zmagnus_apply(namespace, mesh, psib, hpsib)
+ class default
+ ASSERT(.false.)
+ end select
+ end do
+ end subroutine zhamiltonian_magnus_apply
+end submodule hamiltonian_abst_impl
diff --git a/src/hamiltonian/hamiltonian_abst_h.F90 b/src/hamiltonian/hamiltonian_abst_h.F90
new file mode 100644
index 0000000000000000000000000000000000000000..c133396550d9486c9ace6d3d84a865a61b0abc0c
--- /dev/null
+++ b/src/hamiltonian/hamiltonian_abst_h.F90
@@ -0,0 +1,134 @@
+!! Copyright (C) 2019 N. Tancogne-Dejean, M. Oliveira
+!!
+!! 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, 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 st program; if not, write to the Free Software
+!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+!! 02110-1301, USA.
+!!
+
+!> @brief This module defines an abstract class for Hamiltonians
+!!
+!! From this, the electronic and the Maxwell Hamiltonians are derived
+
+module hamiltonian_abst_oct_m
+ use batch_oct_m
+ use dict_oct_m
+ use extension_oct_m
+ use global_oct_m
+ use mesh_oct_m
+ use namespace_oct_m
+
+ implicit none
+
+ private
+
+ !> @brief The abstract Hamiltonian class defines a skeleton for specific implementations
+ type, abstract, public :: hamiltonian_abst_t
+ private
+ !> Spectral range
+ real(real64), public :: spectral_middle_point
+ real(real64), public :: spectral_half_span
+ type(extension_list_t), public :: extensions
+ type(dict_t), public :: context
+
+ contains
+ private
+ procedure, public :: hamiltonian_abst_init
+ procedure, public :: post_init => hamiltonian_abst_post_init
+ procedure, public :: hamiltonian_abst_end
+ procedure(is_hermitian), deferred, public :: is_hermitian !< @copydoc is_hermitian
+ procedure(hamiltonian_update_span), deferred, public :: update_span !< @copydoc hamiltonian_update_span
+ procedure, public :: dapply => dhamiltonian_apply
+ procedure, public :: zapply => zhamiltonian_apply
+ procedure, public :: dmagnus_apply => dhamiltonian_magnus_apply
+ procedure, public :: zmagnus_apply => zhamiltonian_magnus_apply
+ procedure(dhamiltonian_apply), deferred, public :: dapply_impl !< @copydoc dhamiltonian_apply
+ procedure(zhamiltonian_apply), deferred, public :: zapply_impl !< @copydoc zhamiltonian_apply
+ procedure(dhamiltonian_magnus_apply), deferred, public :: dmagnus_apply_impl !< @copydoc dhamiltonian_magnus_apply
+ procedure(zhamiltonian_magnus_apply), deferred, public :: zmagnus_apply_impl !< @copydoc zhamiltonian_magnus_apply
+ end type hamiltonian_abst_t
+
+ abstract interface
+ logical function is_hermitian(hm)
+ import
+ class(hamiltonian_abst_t), intent(in) :: hm
+ end function is_hermitian
+
+ subroutine hamiltonian_update_span(hm, delta, emin, namespace)
+ import
+ class(hamiltonian_abst_t), intent(inout) :: hm
+ real(real64), intent(in) :: delta(:)
+ real(real64), intent(in) :: emin
+ type(namespace_t), intent(in) :: namespace
+ end subroutine hamiltonian_update_span
+ end interface
+
+ interface
+ module subroutine dhamiltonian_apply(hm, namespace, mesh, psib, hpsib, terms, set_bc)
+ class(hamiltonian_abst_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), target, intent(inout) :: psib
+ class(batch_t), target, intent(inout) :: hpsib
+ integer, optional, intent(in) :: terms
+ logical, optional, intent(in) :: set_bc
+ end subroutine dhamiltonian_apply
+
+ module subroutine zhamiltonian_apply(hm, namespace, mesh, psib, hpsib, terms, set_bc)
+ class(hamiltonian_abst_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), target, intent(inout) :: psib
+ class(batch_t), target, intent(inout) :: hpsib
+ integer, optional, intent(in) :: terms
+ logical, optional, intent(in) :: set_bc
+ end subroutine zhamiltonian_apply
+
+ module subroutine dhamiltonian_magnus_apply(hm, namespace, mesh, psib, hpsib, vmagnus)
+ class(hamiltonian_abst_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), intent(inout) :: psib
+ class(batch_t), intent(inout) :: hpsib
+ real(real64), intent(in) :: vmagnus(:, :, :)
+ end subroutine dhamiltonian_magnus_apply
+
+ module subroutine zhamiltonian_magnus_apply(hm, namespace, mesh, psib, hpsib, vmagnus)
+ class(hamiltonian_abst_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), intent(inout) :: psib
+ class(batch_t), intent(inout) :: hpsib
+ real(real64), intent(in) :: vmagnus(:, :, :)
+ end subroutine zhamiltonian_magnus_apply
+
+ module subroutine hamiltonian_abst_init(this)
+ class(hamiltonian_abst_t), target, intent(inout) :: this
+ end subroutine
+
+ module subroutine hamiltonian_abst_post_init(this)
+ class(hamiltonian_abst_t), intent(inout) :: this
+ end subroutine
+
+ module subroutine hamiltonian_abst_end(this)
+ class(hamiltonian_abst_t), intent(inout) :: this
+ end subroutine
+ end interface
+
+end module hamiltonian_abst_oct_m
+
+
+!! Local Variables:
+!! mode: f90
+!! coding: utf-8
+!! End:
diff --git a/src/hamiltonian/hamiltonian_elec.F90 b/src/hamiltonian/hamiltonian_elec.F90
index 1a9a97b196a572b55010034ee230b05fb7aa0af9..21c20de09f75abce8f83ef0f617eefa427f0f68f 100644
--- a/src/hamiltonian/hamiltonian_elec.F90
+++ b/src/hamiltonian/hamiltonian_elec.F90
@@ -19,228 +19,48 @@
#include "global.h"
-module hamiltonian_elec_oct_m
- use absorbing_boundaries_oct_m
+submodule (hamiltonian_elec_oct_m) impl
+ use hamiltonian_elec_oct_m
use accel_oct_m
use affine_coordinates_oct_m
- use batch_oct_m
use batch_ops_oct_m
use boundaries_oct_m
use comm_oct_m
use debug_oct_m
- use derivatives_oct_m
- use distributed_oct_m
- use energy_oct_m
- use electron_space_oct_m
- use exchange_operator_oct_m
- use external_potential_oct_m
- use hamiltonian_elec_base_oct_m
- use epot_oct_m
use ext_partner_list_oct_m
+ use external_potential_oct_m
use gauge_field_oct_m
use global_oct_m
- use grid_oct_m
- use hamiltonian_abst_oct_m
- use interaction_partner_oct_m
- use ion_electron_local_potential_oct_m
use io_oct_m
- use ions_oct_m
- use kick_oct_m
- use, intrinsic :: iso_fortran_env
- use kpoints_oct_m
use lalg_basic_oct_m
use lasers_oct_m
- use lattice_vectors_oct_m
- use lda_u_oct_m
use linked_list_oct_m
- use magnetic_constrain_oct_m
use math_oct_m
- use mesh_oct_m
use mesh_function_oct_m
use messages_oct_m
use mpi_oct_m
- use multicomm_oct_m
- use mxll_elec_coupling_oct_m
- use namespace_oct_m
- use nlcc_oct_m
- use nonlocal_pseudopotential_oct_m
- use oct_exchange_oct_m
- use parser_oct_m
use par_vec_oct_m
- use poisson_oct_m
+ use parser_oct_m
use profiling_oct_m
use projector_oct_m
- use pcm_oct_m
- use phase_oct_m
- use restart_oct_m
- use scissor_oct_m
- use space_oct_m
- use species_oct_m
use states_abst_oct_m
- use states_elec_oct_m
- use states_elec_dim_oct_m
use states_elec_parallel_oct_m
- use symmetries_oct_m
use symm_op_oct_m
+ use symmetries_oct_m
use types_oct_m
use unit_oct_m
use unit_system_oct_m
- use wfs_elec_oct_m
- use xc_oct_m
use xc_f03_lib_m
use xc_functional_oct_m
use xc_interaction_oct_m
- use xc_photons_oct_m
- use zora_oct_m
+ use extension_oct_m
+ use hamiltonian_extensions_oct_m
implicit none
-
- private
- public :: &
- hamiltonian_elec_t, &
- hamiltonian_elec_init, &
- hamiltonian_elec_end, &
- dhamiltonian_elec_apply_single, &
- zhamiltonian_elec_apply_single, &
- zhamiltonian_elec_apply_all, &
- dhamiltonian_elec_apply_batch, &
- zhamiltonian_elec_apply_batch, &
- dhamiltonian_elec_diagonal, &
- zhamiltonian_elec_diagonal, &
- magnus, &
- dvmask, &
- zvmask, &
- hamiltonian_elec_inh_term, &
- hamiltonian_elec_set_inh, &
- hamiltonian_elec_remove_inh, &
- hamiltonian_elec_adjoint, &
- hamiltonian_elec_not_adjoint, &
- hamiltonian_elec_epot_generate, &
- hamiltonian_elec_needs_current, &
- hamiltonian_elec_update_pot, &
- hamiltonian_elec_update_with_ext_pot, &
- hamiltonian_elec_get_time, &
- hamiltonian_elec_apply_packed, &
- zhamiltonian_elec_apply_atom, &
- hamiltonian_elec_dump_vhxc, &
- hamiltonian_elec_load_vhxc, &
- hamiltonian_elec_set_vhxc, &
- hamiltonian_elec_has_kick, &
- hamiltonian_elec_copy_and_set_phase
-
-
- type, extends(hamiltonian_abst_t) :: hamiltonian_elec_t
- ! Components are public by default
-
- !> The Hamiltonian must know what are the "dimensions" of the spaces,
- !! in order to be able to operate on the states.
- type(space_t), private :: space
- type(states_elec_dim_t) :: d
- type(hamiltonian_elec_base_t) :: hm_base
- type(phase_t) :: phase
- type(energy_t), allocatable :: energy
- type(absorbing_boundaries_t) :: abs_boundaries !< absorbing boundaries
- real(real64), allocatable :: vhartree(:) !< Hartree potential
- real(real64), allocatable :: vxc(:,:) !< XC potential
- real(real64), allocatable :: vhxc(:,:) !< XC potential + Hartree potential + Berry potential
- real(real64), allocatable :: vtau(:,:) !< Derivative of e_XC w.r.t. tau
- real(real64), allocatable :: vberry(:,:) !< Berry phase potential from external e_field
-
- type(derivatives_t), pointer, private :: der !< pointer to derivatives
-
- type(nonlocal_pseudopotential_t) :: vnl !< Nonlocal part of the pseudopotential
-
- type(ions_t), pointer :: ions
- real(real64) :: exx_coef !< how much of EXX to mix
-
- type(poisson_t) :: psolver !< Poisson solver
-
- !> The self-induced vector potential and magnetic field
- logical :: self_induced_magnetic
- real(real64), allocatable :: a_ind(:, :)
- real(real64), allocatable :: b_ind(:, :)
-
- integer :: theory_level !< copied from sys%ks
- type(xc_t), pointer :: xc !< pointer to xc object
- type(xc_photons_t), pointer :: xc_photons !< pointer to the xc_photons object
-
- type(epot_t) :: ep !< handles the external potential
- type(pcm_t) :: pcm !< handles pcm variables
-
- !> absorbing boundaries
- logical, private :: adjoint
-
- !> Mass of the particle (in most cases, mass = 1, electron mass)
- real(real64), private :: mass
-
- !> There may be an "inhomogeneous", "source", or "forcing" term (useful for the OCT formalism)
- logical, private :: inh_term
- type(states_elec_t) :: inh_st
-
- !> There may also be a exchange-like term, similar to the one necessary for time-dependent
- !! Hartree Fock, also useful only for the OCT equations
- type(oct_exchange_t) :: oct_exchange
-
- type(scissor_t) :: scissor
-
- real(real64) :: current_time
- logical, private :: is_applied_packed !< This is initialized by the StatesPack variable.
-
- !> For the DFT+U
- type(lda_u_t) :: lda_u
- integer :: lda_u_level
-
- logical, public :: time_zero
-
- type(exchange_operator_t), public :: exxop
-
- type(kpoints_t), pointer, public :: kpoints => null()
-
- type(partner_list_t) :: external_potentials !< List with all the external potentials
- real(real64), allocatable, public :: v_ext_pot(:) !< the potential comming from external potentials
- real(real64), allocatable, public :: v_static(:) !< static scalar potential
-
- type(ion_electron_local_potential_t) :: v_ie_loc !< Ion-electron local potential interaction
- type(nlcc_t) :: nlcc !< Ion-electron NLCC interaction
-
- type(magnetic_constrain_t) :: magnetic_constrain
-
- !> The possible kick
- type(kick_t) :: kick
-
- !> Maxwell-electrons coupling information
- type(mxll_coupling_t) :: mxll
- type(zora_t), pointer :: zora
-
- contains
- procedure :: update => hamiltonian_elec_update
- procedure :: apply_packed => hamiltonian_elec_apply_packed
- procedure :: update_span => hamiltonian_elec_span
- procedure :: dapply => dhamiltonian_elec_apply
- procedure :: zapply => zhamiltonian_elec_apply
- procedure :: dmagnus_apply => dhamiltonian_elec_magnus_apply
- procedure :: zmagnus_apply => zhamiltonian_elec_magnus_apply
- procedure :: is_hermitian => hamiltonian_elec_hermitian
- procedure :: set_mass => hamiltonian_elec_set_mass
- end type hamiltonian_elec_t
-
- integer, public, parameter :: &
- LENGTH = 1, &
- VELOCITY = 2
-
- integer, public, parameter :: &
- INDEPENDENT_PARTICLES = 2, &
- HARTREE = 1, &
- HARTREE_FOCK = 3, &
- KOHN_SHAM_DFT = 4, &
- GENERALIZED_KOHN_SHAM_DFT = 5, &
- RDMFT = 7
-
-
contains
! ---------------------------------------------------------
- subroutine hamiltonian_elec_init(hm, namespace, space, gr, ions, ext_partners, st, theory_level, xc, &
+ module subroutine hamiltonian_elec_init(hm, namespace, space, gr, ions, ext_partners, st, theory_level, xc, &
mc, kpoints, need_exchange, xc_photons)
type(hamiltonian_elec_t), target, intent(inout) :: hm
type(namespace_t), intent(in) :: namespace
@@ -261,8 +81,11 @@ contains
real(real64) :: rashba_coupling
PUSH_SUB(hamiltonian_elec_init)
+
call profiling_in('HAMILTONIAN_ELEC_INIT')
+ call hm%hamiltonian_abst_init()
+
! make a couple of local copies
hm%space = space
hm%theory_level = theory_level
@@ -687,7 +510,7 @@ contains
! ---------------------------------------------------------
- subroutine hamiltonian_elec_end(hm)
+ module subroutine hamiltonian_elec_end(hm)
type(hamiltonian_elec_t), target, intent(inout) :: hm
type(partner_iterator_t) :: iter
@@ -750,17 +573,20 @@ contains
call mxll_coupling_end(hm%mxll)
+ call hm%hamiltonian_abst_end()
+
POP_SUB(hamiltonian_elec_end)
end subroutine hamiltonian_elec_end
! ---------------------------------------------------------
! True if the Hamiltonian is Hermitian, false otherwise
- logical function hamiltonian_elec_hermitian(hm)
+ module function hamiltonian_elec_hermitian(hm) result(res)
class(hamiltonian_elec_t), intent(in) :: hm
+ logical :: res
PUSH_SUB(hamiltonian_elec_hermitian)
- hamiltonian_elec_hermitian = .not.((hm%abs_boundaries%abtype == IMAGINARY_ABSORBING) .or. &
+ res = .not.((hm%abs_boundaries%abtype == IMAGINARY_ABSORBING) .or. &
oct_exchange_enabled(hm%oct_exchange))
POP_SUB(hamiltonian_elec_hermitian)
@@ -768,7 +594,7 @@ contains
! ---------------------------------------------------------
- subroutine hamiltonian_elec_span(hm, delta, emin, namespace)
+ module subroutine hamiltonian_elec_span(hm, delta, emin, namespace)
class(hamiltonian_elec_t), intent(inout) :: hm
real(real64), intent(in) :: delta(:)
real(real64), intent(in) :: emin
@@ -805,15 +631,16 @@ contains
! ---------------------------------------------------------
- pure logical function hamiltonian_elec_inh_term(hm) result(inh)
+ pure module function hamiltonian_elec_inh_term(hm) result(inh)
type(hamiltonian_elec_t), intent(in) :: hm
+ logical :: inh
inh = hm%inh_term
end function hamiltonian_elec_inh_term
! ---------------------------------------------------------
- subroutine hamiltonian_elec_set_inh(hm, st)
+ module subroutine hamiltonian_elec_set_inh(hm, st)
type(hamiltonian_elec_t), intent(inout) :: hm
type(states_elec_t), intent(in) :: st
@@ -828,7 +655,7 @@ contains
! ---------------------------------------------------------
- subroutine hamiltonian_elec_remove_inh(hm)
+ module subroutine hamiltonian_elec_remove_inh(hm)
type(hamiltonian_elec_t), intent(inout) :: hm
PUSH_SUB(hamiltonian_elec_remove_inh)
@@ -842,7 +669,7 @@ contains
end subroutine hamiltonian_elec_remove_inh
! ---------------------------------------------------------
- subroutine hamiltonian_elec_adjoint(hm)
+ module subroutine hamiltonian_elec_adjoint(hm)
type(hamiltonian_elec_t), intent(inout) :: hm
PUSH_SUB(hamiltonian_elec_adjoint)
@@ -859,7 +686,7 @@ contains
! ---------------------------------------------------------
- subroutine hamiltonian_elec_not_adjoint(hm)
+ module subroutine hamiltonian_elec_not_adjoint(hm)
type(hamiltonian_elec_t), intent(inout) :: hm
PUSH_SUB(hamiltonian_elec_not_adjoint)
@@ -877,7 +704,7 @@ contains
! ---------------------------------------------------------
!> (re-)build the Hamiltonian for the next application:
- subroutine hamiltonian_elec_update(this, mesh, namespace, space, ext_partners, time)
+ module subroutine hamiltonian_elec_update(this, mesh, namespace, space, ext_partners, time)
class(hamiltonian_elec_t), intent(inout) :: this
class(mesh_t), intent(in) :: mesh
type(namespace_t), intent(in) :: namespace
@@ -892,6 +719,9 @@ contains
type(gauge_field_t), pointer :: gfield
real(real64) :: am(space%dim)
+ type(extension_iterator_t) :: iter_ext
+ class(extension_t), pointer :: extension
+
PUSH_SUB(hamiltonian_elec_update)
call profiling_in("HAMILTONIAN_ELEC_UPDATE")
@@ -900,6 +730,18 @@ contains
time_ = optional_default(time, 0.0_real64)
+ ! Run pre-extensions
+ call iter_ext%start(this%extensions)
+ do while (iter_ext%has_next())
+ extension => iter_ext%get_next()
+ select type (extension)
+ class is (hamiltonian_extension_t)
+ call extension%pre_update(time)
+ class default
+ ASSERT(.false.)
+ end select
+ end do
+
! set everything to zero
call this%hm_base%clear(mesh%np)
@@ -1019,6 +861,18 @@ contains
call build_phase()
+ ! Run post-extensions (in reverse order)
+ call iter_ext%start(this%extensions, reverse=.true.)
+ do while (iter_ext%has_next())
+ extension => iter_ext%get_next(reverse=.true.)
+ select type (extension)
+ class is (hamiltonian_extension_t)
+ call extension%post_update(time)
+ class default
+ ASSERT(.false.)
+ end select
+ end do
+
call profiling_out("HAMILTONIAN_ELEC_UPDATE")
POP_SUB(hamiltonian_elec_update)
@@ -1108,7 +962,7 @@ contains
!>@brief Update the KS potential of the electronic Hamiltonian
!!
! TODO: See Issue #1064
- subroutine hamiltonian_elec_update_pot(this, mesh, accumulate)
+ module subroutine hamiltonian_elec_update_pot(this, mesh, accumulate)
type(hamiltonian_elec_t), intent(inout) :: this
class(mesh_t), intent(in) :: mesh
logical, optional, intent(in) :: accumulate
@@ -1228,7 +1082,7 @@ contains
end subroutine hamiltonian_elec_update_pot
! ---------------------------------------------------------
- subroutine hamiltonian_elec_epot_generate(this, namespace, space, gr, ions, ext_partners, st, time)
+ module subroutine hamiltonian_elec_epot_generate(this, namespace, space, gr, ions, ext_partners, st, time)
type(hamiltonian_elec_t), intent(inout) :: this
type(namespace_t), intent(in) :: namespace
class(electron_space_t), intent(in) :: space
@@ -1311,16 +1165,18 @@ contains
! -----------------------------------------------------------------
- real(real64) function hamiltonian_elec_get_time(this) result(time)
+ module function hamiltonian_elec_get_time(this) result(time)
type(hamiltonian_elec_t), intent(inout) :: this
+ real(real64) :: time
time = this%current_time
end function hamiltonian_elec_get_time
! -----------------------------------------------------------------
- pure logical function hamiltonian_elec_apply_packed(this) result(apply)
+ pure module function hamiltonian_elec_apply_packed(this) result(apply)
class(hamiltonian_elec_t), intent(in) :: this
+ logical :: apply
apply = this%is_applied_packed
@@ -1328,7 +1184,7 @@ contains
! -----------------------------------------------------------------
- subroutine zhamiltonian_elec_apply_atom (hm, namespace, space, latt, species, pos, ia, mesh, psi, vpsi)
+ module subroutine zhamiltonian_elec_apply_atom (hm, namespace, space, latt, species, pos, ia, mesh, psi, vpsi)
type(hamiltonian_elec_t), intent(in) :: hm
type(namespace_t), intent(in) :: namespace
class(space_t), intent(in) :: space
@@ -1358,7 +1214,7 @@ contains
! -----------------------------------------------------------------
- subroutine hamiltonian_elec_dump_vhxc(restart, hm, space, mesh, ierr)
+ module subroutine hamiltonian_elec_dump_vhxc(restart, hm, space, mesh, ierr)
type(restart_t), intent(in) :: restart
type(hamiltonian_elec_t), intent(in) :: hm
class(space_t), intent(in) :: space
@@ -1454,7 +1310,7 @@ contains
! ---------------------------------------------------------
- subroutine hamiltonian_elec_load_vhxc(restart, hm, space, mesh, ierr)
+ module subroutine hamiltonian_elec_load_vhxc(restart, hm, space, mesh, ierr)
type(restart_t), intent(in) :: restart
type(hamiltonian_elec_t), intent(inout) :: hm
class(space_t), intent(in) :: space
@@ -1524,7 +1380,7 @@ contains
!! CFM4 propagator. It updates the Hamiltonian by considering a
!! weighted sum of the external potentials at times time(1) and time(2),
!! weighted by alpha(1) and alpha(2).
- subroutine hamiltonian_elec_update_with_ext_pot(this, mesh, space, ext_partners, time, mu)
+ module subroutine hamiltonian_elec_update_with_ext_pot(this, mesh, space, ext_partners, time, mu)
type(hamiltonian_elec_t), intent(inout) :: this
class(space_t), intent(in) :: space
class(mesh_t), intent(in) :: mesh
@@ -1720,7 +1576,7 @@ contains
end subroutine hamiltonian_elec_update_with_ext_pot
! ---------------------------------------------------------
- subroutine hamiltonian_elec_set_vhxc(hm, mesh, vold, vold_tau)
+ module subroutine hamiltonian_elec_set_vhxc(hm, mesh, vold, vold_tau)
type(hamiltonian_elec_t), intent(inout) :: hm
class(mesh_t), intent(in) :: mesh
real(real64), intent(in) :: vold(:, :)
@@ -1736,15 +1592,16 @@ contains
POP_SUB(hamiltonian_elec_set_vhxc)
end subroutine hamiltonian_elec_set_vhxc
- logical function hamiltonian_elec_needs_current(hm, states_are_real)
+ module function hamiltonian_elec_needs_current(hm, states_are_real) result(res)
type(hamiltonian_elec_t), intent(in) :: hm
logical, intent(in) :: states_are_real
+ logical :: res
- hamiltonian_elec_needs_current = .false.
+ res = .false.
if (hm%self_induced_magnetic) then
if (.not. states_are_real) then
- hamiltonian_elec_needs_current = .true.
+ res = .true.
else
message(1) = 'No current density for real states since it is identically zero.'
call messages_warning(1)
@@ -1754,7 +1611,7 @@ contains
end function hamiltonian_elec_needs_current
! ---------------------------------------------------------
- subroutine zhamiltonian_elec_apply_all(hm, namespace, mesh, st, hst)
+ module subroutine zhamiltonian_elec_apply_all(hm, namespace, mesh, st, hst)
type(hamiltonian_elec_t), intent(inout) :: hm
type(namespace_t), intent(in) :: namespace
class(mesh_t), intent(in) :: mesh
@@ -1803,7 +1660,7 @@ contains
! ---------------------------------------------------------
- subroutine magnus(hm, namespace, mesh, psi, hpsi, ik, vmagnus, set_phase)
+ module subroutine magnus(hm, namespace, mesh, psi, hpsi, ik, vmagnus, set_phase)
type(hamiltonian_elec_t), intent(in) :: hm
type(namespace_t), intent(in) :: namespace
class(mesh_t), intent(in) :: mesh
@@ -1855,7 +1712,7 @@ contains
end subroutine magnus
! ---------------------------------------------------------
- subroutine vborders (mesh, hm, psi, hpsi)
+ module subroutine vborders (mesh, hm, psi, hpsi)
class(mesh_t), intent(in) :: mesh
type(hamiltonian_elec_t), intent(in) :: hm
complex(real64), intent(in) :: psi(:)
@@ -1875,19 +1732,20 @@ contains
end subroutine vborders
! ---------------------------------------------------------
- logical function hamiltonian_elec_has_kick(hm)
+ module function hamiltonian_elec_has_kick(hm) result(res)
type(hamiltonian_elec_t), intent(in) :: hm
+ logical :: res
PUSH_SUB(hamiltonian_elec_has_kick)
- hamiltonian_elec_has_kick = (abs(hm%kick%delta_strength) > M_EPSILON)
+ res = (abs(hm%kick%delta_strength) > M_EPSILON)
POP_SUB(hamiltonian_elec_has_kick)
end function hamiltonian_elec_has_kick
!> set the effective electron mass, checking whether it was previously redefined.
!
- subroutine hamiltonian_elec_set_mass(this, namespace, mass)
+ module subroutine hamiltonian_elec_set_mass(this, namespace, mass)
class(hamiltonian_elec_t) , intent(inout) :: this
type(namespace_t), intent(in) :: namespace
real(real64), intent(in) :: mass
@@ -1911,7 +1769,7 @@ contains
!! If no phase is defined, a packed copy of psib is returned
!!
!! TODO: This should should probably belong to wfs_elec_t, but cannot due to circular dependencies
- subroutine hamiltonian_elec_copy_and_set_phase(hm, gr, kpt, psib, psib_with_phase)
+ module subroutine hamiltonian_elec_copy_and_set_phase(hm, gr, kpt, psib, psib_with_phase)
type(hamiltonian_elec_t), intent(in) :: hm
type(grid_t), intent(in) :: gr
type(distributed_t), intent(in) :: kpt !< k-point distribution
@@ -1949,7 +1807,7 @@ contains
#include "complex.F90"
#include "hamiltonian_elec_inc.F90"
-end module hamiltonian_elec_oct_m
+end submodule impl
!! Local Variables:
!! mode: f90
diff --git a/src/hamiltonian/hamiltonian_elec_h.F90 b/src/hamiltonian/hamiltonian_elec_h.F90
new file mode 100644
index 0000000000000000000000000000000000000000..cb59793fc6ae65cb9077470828e15b0e92de0a97
--- /dev/null
+++ b/src/hamiltonian/hamiltonian_elec_h.F90
@@ -0,0 +1,532 @@
+module hamiltonian_elec_oct_m
+ use absorbing_boundaries_oct_m
+ use batch_oct_m
+ use derivatives_oct_m
+ use distributed_oct_m
+ use electron_space_oct_m
+ use energy_oct_m
+ use epot_oct_m
+ use exchange_operator_oct_m
+ use global_oct_m
+ use grid_oct_m
+ use hamiltonian_abst_oct_m
+ use hamiltonian_elec_base_oct_m
+ use interaction_partner_oct_m
+ use ion_electron_local_potential_oct_m
+ use ions_oct_m
+ use kick_oct_m
+ use kpoints_oct_m
+ use lattice_vectors_oct_m
+ use lda_u_oct_m
+ use magnetic_constrain_oct_m
+ use mesh_oct_m
+ use multicomm_oct_m
+ use mxll_elec_coupling_oct_m
+ use namespace_oct_m
+ use nlcc_oct_m
+ use nonlocal_pseudopotential_oct_m
+ use oct_exchange_oct_m
+ use pcm_oct_m
+ use phase_oct_m
+ use poisson_oct_m
+ use restart_oct_m
+ use scissor_oct_m
+ use space_oct_m
+ use species_oct_m
+ use states_elec_dim_oct_m
+ use states_elec_oct_m
+ use wfs_elec_oct_m
+ use xc_oct_m
+ use xc_photons_oct_m
+ use zora_oct_m
+
+ implicit none
+
+ private
+ public :: &
+ hamiltonian_elec_t, &
+ hamiltonian_elec_init, &
+ hamiltonian_elec_end, &
+ dhamiltonian_elec_apply_single, &
+ zhamiltonian_elec_apply_single, &
+ zhamiltonian_elec_apply_all, &
+ dhamiltonian_elec_apply_batch, &
+ zhamiltonian_elec_apply_batch, &
+ dhamiltonian_elec_diagonal, &
+ zhamiltonian_elec_diagonal, &
+ magnus, &
+ dvmask, &
+ zvmask, &
+ hamiltonian_elec_inh_term, &
+ hamiltonian_elec_set_inh, &
+ hamiltonian_elec_remove_inh, &
+ hamiltonian_elec_adjoint, &
+ hamiltonian_elec_not_adjoint, &
+ hamiltonian_elec_epot_generate, &
+ hamiltonian_elec_needs_current, &
+ hamiltonian_elec_update_pot, &
+ hamiltonian_elec_update_with_ext_pot, &
+ hamiltonian_elec_get_time, &
+ hamiltonian_elec_apply_packed, &
+ zhamiltonian_elec_apply_atom, &
+ hamiltonian_elec_dump_vhxc, &
+ hamiltonian_elec_load_vhxc, &
+ hamiltonian_elec_set_vhxc, &
+ hamiltonian_elec_has_kick, &
+ hamiltonian_elec_copy_and_set_phase
+
+
+ type, extends(hamiltonian_abst_t) :: hamiltonian_elec_t
+ ! Components are public by default
+
+ !> The Hamiltonian must know what are the "dimensions" of the spaces,
+ !! in order to be able to operate on the states.
+ type(space_t), private :: space
+ type(states_elec_dim_t) :: d
+ type(hamiltonian_elec_base_t) :: hm_base
+ type(phase_t) :: phase
+ type(energy_t), allocatable :: energy
+ type(absorbing_boundaries_t) :: abs_boundaries !< absorbing boundaries
+ real(real64), allocatable :: vhartree(:) !< Hartree potential
+ real(real64), allocatable :: vxc(:,:) !< XC potential
+ real(real64), allocatable :: vhxc(:,:) !< XC potential + Hartree potential + Berry potential
+ real(real64), allocatable :: vtau(:,:) !< Derivative of e_XC w.r.t. tau
+ real(real64), allocatable :: vberry(:,:) !< Berry phase potential from external e_field
+
+ type(derivatives_t), pointer, private :: der !< pointer to derivatives
+
+ type(nonlocal_pseudopotential_t) :: vnl !< Nonlocal part of the pseudopotential
+
+ type(ions_t), pointer :: ions
+ real(real64) :: exx_coef !< how much of EXX to mix
+
+ type(poisson_t) :: psolver !< Poisson solver
+
+ !> The self-induced vector potential and magnetic field
+ logical :: self_induced_magnetic
+ real(real64), allocatable :: a_ind(:, :)
+ real(real64), allocatable :: b_ind(:, :)
+
+ integer :: theory_level !< copied from sys%ks
+ type(xc_t), pointer :: xc !< pointer to xc object
+ type(xc_photons_t), pointer :: xc_photons !< pointer to the xc_photons object
+
+ type(epot_t) :: ep !< handles the external potential
+ type(pcm_t) :: pcm !< handles pcm variables
+
+ !> absorbing boundaries
+ logical, private :: adjoint
+
+ !> Mass of the particle (in most cases, mass = 1, electron mass)
+ real(real64), private :: mass
+
+ !> There may be an "inhomogeneous", "source", or "forcing" term (useful for the OCT formalism)
+ logical, private :: inh_term
+ type(states_elec_t) :: inh_st
+
+ !> There may also be a exchange-like term, similar to the one necessary for time-dependent
+ !! Hartree Fock, also useful only for the OCT equations
+ type(oct_exchange_t) :: oct_exchange
+
+ type(scissor_t) :: scissor
+
+ real(real64) :: current_time
+ logical, private :: is_applied_packed !< This is initialized by the StatesPack variable.
+
+ !> For the DFT+U
+ type(lda_u_t) :: lda_u
+ integer :: lda_u_level
+
+ logical, public :: time_zero
+
+ type(exchange_operator_t), public :: exxop
+
+ type(kpoints_t), pointer, public :: kpoints => null()
+
+ type(partner_list_t) :: external_potentials !< List with all the external potentials
+ real(real64), allocatable, public :: v_ext_pot(:) !< the potential comming from external potentials
+ real(real64), allocatable, public :: v_static(:) !< static scalar potential
+
+ type(ion_electron_local_potential_t) :: v_ie_loc !< Ion-electron local potential interaction
+ type(nlcc_t) :: nlcc !< Ion-electron NLCC interaction
+
+ type(magnetic_constrain_t) :: magnetic_constrain
+
+ !> The possible kick
+ type(kick_t) :: kick
+
+ !> Maxwell-electrons coupling information
+ type(mxll_coupling_t) :: mxll
+ type(zora_t), pointer :: zora
+
+ contains
+ procedure :: update => hamiltonian_elec_update
+ procedure :: apply_packed => hamiltonian_elec_apply_packed
+ procedure :: update_span => hamiltonian_elec_span
+ procedure :: dapply_impl => dhamiltonian_elec_apply
+ procedure :: zapply_impl => zhamiltonian_elec_apply
+ procedure :: dmagnus_apply_impl => dhamiltonian_elec_magnus_apply
+ procedure :: zmagnus_apply_impl => zhamiltonian_elec_magnus_apply
+ procedure :: is_hermitian => hamiltonian_elec_hermitian
+ procedure :: set_mass => hamiltonian_elec_set_mass
+ end type hamiltonian_elec_t
+
+ integer, public, parameter :: &
+ LENGTH = 1, &
+ VELOCITY = 2
+
+ integer, public, parameter :: &
+ INDEPENDENT_PARTICLES = 2, &
+ HARTREE = 1, &
+ HARTREE_FOCK = 3, &
+ KOHN_SHAM_DFT = 4, &
+ GENERALIZED_KOHN_SHAM_DFT = 5, &
+ RDMFT = 7
+
+ interface
+ module subroutine hamiltonian_elec_init(hm, namespace, space, gr, ions, ext_partners, st, theory_level, xc, &
+ mc, kpoints, need_exchange, xc_photons)
+ type(hamiltonian_elec_t), target, intent(inout) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(space_t), intent(in) :: space
+ type(grid_t), target, intent(inout) :: gr
+ type(ions_t), target, intent(inout) :: ions
+ type(partner_list_t), intent(inout) :: ext_partners
+ type(states_elec_t), target, intent(inout) :: st
+ integer, intent(in) :: theory_level
+ type(xc_t), target, intent(in) :: xc
+ type(multicomm_t), intent(in) :: mc
+ type(kpoints_t), target, intent(in) :: kpoints
+ logical, optional, intent(in) :: need_exchange
+ type(xc_photons_t), optional, target, intent(in) :: xc_photons
+ end subroutine hamiltonian_elec_init
+
+ module subroutine hamiltonian_elec_end(hm)
+ type(hamiltonian_elec_t), target, intent(inout) :: hm
+ end subroutine hamiltonian_elec_end
+
+ module function hamiltonian_elec_hermitian(hm) result(res)
+ class(hamiltonian_elec_t), intent(in) :: hm
+ logical :: res
+ end function hamiltonian_elec_hermitian
+
+ module subroutine hamiltonian_elec_span(hm, delta, emin, namespace)
+ class(hamiltonian_elec_t), intent(inout) :: hm
+ real(real64), intent(in) :: delta(:)
+ real(real64), intent(in) :: emin
+ type(namespace_t), intent(in) :: namespace
+ end subroutine hamiltonian_elec_span
+
+ pure module function hamiltonian_elec_inh_term(hm) result(inh)
+ type(hamiltonian_elec_t), intent(in) :: hm
+ logical :: inh
+ end function hamiltonian_elec_inh_term
+
+ module subroutine hamiltonian_elec_set_inh(hm, st)
+ type(hamiltonian_elec_t), intent(inout) :: hm
+ type(states_elec_t), intent(in) :: st
+ end subroutine hamiltonian_elec_set_inh
+
+ module subroutine hamiltonian_elec_remove_inh(hm)
+ type(hamiltonian_elec_t), intent(inout) :: hm
+ end subroutine hamiltonian_elec_remove_inh
+
+ module subroutine hamiltonian_elec_adjoint(hm)
+ type(hamiltonian_elec_t), intent(inout) :: hm
+ end subroutine hamiltonian_elec_adjoint
+
+ module subroutine hamiltonian_elec_not_adjoint(hm)
+ type(hamiltonian_elec_t), intent(inout) :: hm
+ end subroutine hamiltonian_elec_not_adjoint
+
+ module subroutine hamiltonian_elec_update(this, mesh, namespace, space, ext_partners, time)
+ class(hamiltonian_elec_t), intent(inout) :: this
+ class(mesh_t), intent(in) :: mesh
+ type(namespace_t), intent(in) :: namespace
+ class(space_t), intent(in) :: space
+ type(partner_list_t), intent(in) :: ext_partners
+ real(real64), optional, intent(in) :: time
+ end subroutine hamiltonian_elec_update
+
+ module subroutine hamiltonian_elec_update_pot(this, mesh, accumulate)
+ type(hamiltonian_elec_t), intent(inout) :: this
+ class(mesh_t), intent(in) :: mesh
+ logical, optional, intent(in) :: accumulate
+ end subroutine hamiltonian_elec_update_pot
+
+ module subroutine hamiltonian_elec_epot_generate(this, namespace, space, gr, ions, ext_partners, st, time)
+ type(hamiltonian_elec_t), intent(inout) :: this
+ type(namespace_t), intent(in) :: namespace
+ class(electron_space_t), intent(in) :: space
+ type(grid_t), intent(in) :: gr
+ type(ions_t), target, intent(inout) :: ions
+ type(partner_list_t), intent(in) :: ext_partners
+ type(states_elec_t), intent(inout) :: st
+ real(real64), optional, intent(in) :: time
+ end subroutine hamiltonian_elec_epot_generate
+
+ module function hamiltonian_elec_get_time(this) result(time)
+ type(hamiltonian_elec_t), intent(inout) :: this
+ real(real64) :: time
+ end function hamiltonian_elec_get_time
+
+ pure module function hamiltonian_elec_apply_packed(this) result(apply)
+ class(hamiltonian_elec_t), intent(in) :: this
+ logical :: apply
+ end function hamiltonian_elec_apply_packed
+
+ module subroutine zhamiltonian_elec_apply_atom (hm, namespace, space, latt, species, pos, ia, mesh, psi, vpsi)
+ type(hamiltonian_elec_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(space_t), intent(in) :: space
+ type(lattice_vectors_t), intent(in) :: latt
+ class(species_t), intent(in) :: species
+ real(real64), intent(in) :: pos(1:space%dim)
+ integer, intent(in) :: ia
+ class(mesh_t), intent(in) :: mesh
+ complex(real64), intent(in) :: psi(:,:) !< (gr%np_part, hm%d%dim)
+ complex(real64), intent(out) :: vpsi(:,:) !< (gr%np, hm%d%dim)
+ end subroutine zhamiltonian_elec_apply_atom
+
+ module subroutine hamiltonian_elec_dump_vhxc(restart, hm, space, mesh, ierr)
+ type(restart_t), intent(in) :: restart
+ type(hamiltonian_elec_t), intent(in) :: hm
+ class(space_t), intent(in) :: space
+ class(mesh_t), intent(in) :: mesh
+ integer, intent(out) :: ierr
+ end subroutine hamiltonian_elec_dump_vhxc
+
+ module subroutine hamiltonian_elec_load_vhxc(restart, hm, space, mesh, ierr)
+ type(restart_t), intent(in) :: restart
+ type(hamiltonian_elec_t), intent(inout) :: hm
+ class(space_t), intent(in) :: space
+ class(mesh_t), intent(in) :: mesh
+ integer, intent(out) :: ierr
+ end subroutine hamiltonian_elec_load_vhxc
+
+ module subroutine hamiltonian_elec_update_with_ext_pot(this, mesh, space, ext_partners, time, mu)
+ type(hamiltonian_elec_t), intent(inout) :: this
+ class(space_t), intent(in) :: space
+ class(mesh_t), intent(in) :: mesh
+ type(partner_list_t), intent(in) :: ext_partners
+ real(real64), intent(in) :: time(1:2)
+ real(real64), intent(in) :: mu(1:2)
+ end subroutine hamiltonian_elec_update_with_ext_pot
+
+ module subroutine hamiltonian_elec_set_vhxc(hm, mesh, vold, vold_tau)
+ type(hamiltonian_elec_t), intent(inout) :: hm
+ class(mesh_t), intent(in) :: mesh
+ real(real64), intent(in) :: vold(:, :)
+ real(real64), optional, intent(in) :: vold_tau(:, :)
+ end subroutine hamiltonian_elec_set_vhxc
+
+ module function hamiltonian_elec_needs_current(hm, states_are_real) result(res)
+ type(hamiltonian_elec_t), intent(in) :: hm
+ logical, intent(in) :: states_are_real
+ logical :: res
+ end function hamiltonian_elec_needs_current
+
+ module subroutine zhamiltonian_elec_apply_all(hm, namespace, mesh, st, hst)
+ type(hamiltonian_elec_t), intent(inout) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ type(states_elec_t), intent(inout) :: st
+ type(states_elec_t), intent(inout) :: hst
+ end subroutine zhamiltonian_elec_apply_all
+
+ module subroutine magnus(hm, namespace, mesh, psi, hpsi, ik, vmagnus, set_phase)
+ type(hamiltonian_elec_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ complex(real64), intent(inout) :: psi(:,:)
+ complex(real64), intent(out) :: hpsi(:,:)
+ integer, intent(in) :: ik
+ real(real64), intent(in) :: vmagnus(:, :, :)
+ logical, optional, intent(in) :: set_phase
+ end subroutine magnus
+
+ module subroutine vborders (mesh, hm, psi, hpsi)
+ class(mesh_t), intent(in) :: mesh
+ type(hamiltonian_elec_t), intent(in) :: hm
+ complex(real64), intent(in) :: psi(:)
+ complex(real64), intent(inout) :: hpsi(:)
+ end subroutine vborders
+
+ module function hamiltonian_elec_has_kick(hm) result(res)
+ type(hamiltonian_elec_t), intent(in) :: hm
+ logical :: res
+ end function hamiltonian_elec_has_kick
+
+ module subroutine dhamiltonian_elec_apply(hm, namespace, mesh, psib, hpsib, terms, set_bc)
+ class(hamiltonian_elec_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), target, intent(inout) :: psib
+ class(batch_t), target, intent(inout) :: hpsib
+ integer, optional, intent(in) :: terms
+ logical, optional, intent(in) :: set_bc
+ end subroutine dhamiltonian_elec_apply
+
+ module subroutine dhamiltonian_elec_magnus_apply(hm, namespace, mesh, psib, hpsib, vmagnus)
+ class(hamiltonian_elec_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), intent(inout) :: psib
+ class(batch_t), intent(inout) :: hpsib
+ real(real64), intent(in) :: vmagnus(:, :, :)
+ end subroutine dhamiltonian_elec_magnus_apply
+
+ module subroutine dhamiltonian_elec_apply_batch(hm, namespace, mesh, psib, hpsib, terms, set_bc)
+ type(hamiltonian_elec_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ type(wfs_elec_t), target, intent(inout) :: psib
+ type(wfs_elec_t), target, intent(inout) :: hpsib
+ integer, optional, intent(in) :: terms
+ logical, optional, intent(in) :: set_bc
+ end subroutine dhamiltonian_elec_apply_batch
+
+ module subroutine dhamiltonian_elec_external(this, mesh, psib, vpsib)
+ type(hamiltonian_elec_t), intent(in) :: this
+ class(mesh_t), intent(in) :: mesh
+ type(wfs_elec_t), intent(in) :: psib
+ type(wfs_elec_t), intent(inout) :: vpsib
+ end subroutine dhamiltonian_elec_external
+
+ module subroutine dhamiltonian_elec_apply_single(hm, namespace, mesh, psi, hpsi, ist, ik, terms, set_bc, set_phase)
+ type(hamiltonian_elec_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ integer, intent(in) :: ist
+ integer, intent(in) :: ik
+ real(real64), contiguous, target, intent(inout) :: psi(:,:)
+ real(real64), contiguous, target, intent(inout) :: hpsi(:,:)
+ integer, optional, intent(in) :: terms
+ logical, optional, intent(in) :: set_bc
+ logical, optional, intent(in) :: set_phase
+ end subroutine dhamiltonian_elec_apply_single
+
+ module subroutine dhamiltonian_elec_magnus_apply_batch(hm, namespace, mesh, psib, hpsib, vmagnus)
+ type(hamiltonian_elec_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ type(wfs_elec_t), intent(inout) :: psib
+ type(wfs_elec_t), intent(inout) :: hpsib
+ real(real64), intent(in) :: vmagnus(:, :, :)
+ end subroutine dhamiltonian_elec_magnus_apply_batch
+
+ module subroutine dh_mgga_terms(hm, mesh, psib, hpsib, ghost_update)
+ type(hamiltonian_elec_t), intent(in) :: hm
+ class(mesh_t), intent(in) :: mesh
+ type(wfs_elec_t), intent(inout) :: psib
+ type(wfs_elec_t), intent(inout) :: hpsib
+ logical, intent(in) :: ghost_update
+ end subroutine dh_mgga_terms
+
+ module subroutine dvmask(mesh, hm, st)
+ class(mesh_t), intent(in) :: mesh
+ type(hamiltonian_elec_t), intent(in) :: hm
+ type(states_elec_t), intent(inout) :: st
+ end subroutine dvmask
+
+ module subroutine dhamiltonian_elec_diagonal(hm, mesh, diag, ik)
+ type(hamiltonian_elec_t), intent(in) :: hm
+ class(mesh_t), intent(in) :: mesh
+ real(real64), intent(out) :: diag(:,:)
+ integer, intent(in) :: ik
+ end subroutine dhamiltonian_elec_diagonal
+
+ module subroutine zhamiltonian_elec_apply(hm, namespace, mesh, psib, hpsib, terms, set_bc)
+ class(hamiltonian_elec_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), target, intent(inout) :: psib
+ class(batch_t), target, intent(inout) :: hpsib
+ integer, optional, intent(in) :: terms
+ logical, optional, intent(in) :: set_bc
+ end subroutine zhamiltonian_elec_apply
+
+ module subroutine zhamiltonian_elec_magnus_apply(hm, namespace, mesh, psib, hpsib, vmagnus)
+ class(hamiltonian_elec_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), intent(inout) :: psib
+ class(batch_t), intent(inout) :: hpsib
+ real(real64), intent(in) :: vmagnus(:, :, :)
+ end subroutine zhamiltonian_elec_magnus_apply
+
+ module subroutine zhamiltonian_elec_apply_batch(hm, namespace, mesh, psib, hpsib, terms, set_bc)
+ type(hamiltonian_elec_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ type(wfs_elec_t), target, intent(inout) :: psib
+ type(wfs_elec_t), target, intent(inout) :: hpsib
+ integer, optional, intent(in) :: terms
+ logical, optional, intent(in) :: set_bc
+ end subroutine zhamiltonian_elec_apply_batch
+
+ module subroutine zhamiltonian_elec_external(this, mesh, psib, vpsib)
+ type(hamiltonian_elec_t), intent(in) :: this
+ class(mesh_t), intent(in) :: mesh
+ type(wfs_elec_t), intent(in) :: psib
+ type(wfs_elec_t), intent(inout) :: vpsib
+ end subroutine zhamiltonian_elec_external
+
+ module subroutine zhamiltonian_elec_apply_single(hm, namespace, mesh, psi, hpsi, ist, ik, terms, set_bc, set_phase)
+ type(hamiltonian_elec_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ integer, intent(in) :: ist
+ integer, intent(in) :: ik
+ complex(real64), contiguous, target, intent(inout) :: psi(:,:)
+ complex(real64), contiguous, target, intent(inout) :: hpsi(:,:)
+ integer, optional, intent(in) :: terms
+ logical, optional, intent(in) :: set_bc
+ logical, optional, intent(in) :: set_phase
+ end subroutine zhamiltonian_elec_apply_single
+
+ module subroutine zhamiltonian_elec_magnus_apply_batch(hm, namespace, mesh, psib, hpsib, vmagnus)
+ type(hamiltonian_elec_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ type(wfs_elec_t), intent(inout) :: psib
+ type(wfs_elec_t), intent(inout) :: hpsib
+ real(real64), intent(in) :: vmagnus(:, :, :)
+ end subroutine zhamiltonian_elec_magnus_apply_batch
+
+ module subroutine zh_mgga_terms(hm, mesh, psib, hpsib, ghost_update)
+ type(hamiltonian_elec_t), intent(in) :: hm
+ class(mesh_t), intent(in) :: mesh
+ type(wfs_elec_t), intent(inout) :: psib
+ type(wfs_elec_t), intent(inout) :: hpsib
+ logical, intent(in) :: ghost_update
+ end subroutine zh_mgga_terms
+
+ module subroutine zvmask(mesh, hm, st)
+ class(mesh_t), intent(in) :: mesh
+ type(hamiltonian_elec_t), intent(in) :: hm
+ type(states_elec_t), intent(inout) :: st
+ end subroutine zvmask
+
+ module subroutine zhamiltonian_elec_diagonal(hm, mesh, diag, ik)
+ type(hamiltonian_elec_t), intent(in) :: hm
+ class(mesh_t), intent(in) :: mesh
+ complex(real64), intent(out) :: diag(:,:)
+ integer, intent(in) :: ik
+ end subroutine zhamiltonian_elec_diagonal
+
+ module subroutine hamiltonian_elec_set_mass(this, namespace, mass)
+ class(hamiltonian_elec_t) , intent(inout) :: this
+ type(namespace_t), intent(in) :: namespace
+ real(real64), intent(in) :: mass
+ end subroutine hamiltonian_elec_set_mass
+
+ module subroutine hamiltonian_elec_copy_and_set_phase(hm, gr, kpt, psib, psib_with_phase)
+ type(hamiltonian_elec_t), intent(in) :: hm
+ type(grid_t), intent(in) :: gr
+ type(distributed_t), intent(in) :: kpt !< k-point distribution
+ type(wfs_elec_t), intent(in) :: psib !< Batched wave functions
+ type(wfs_elec_t), intent(out) :: psib_with_phase !< Batched wave functions with phase applied
+ end subroutine hamiltonian_elec_copy_and_set_phase
+ end interface
+end module hamiltonian_elec_oct_m
diff --git a/src/hamiltonian/hamiltonian_elec_inc.F90 b/src/hamiltonian/hamiltonian_elec_inc.F90
index 898297ed27644dd98681a9468c415ac010cc7de1..a71db78c8cef6363028a002deaea29cd10c42aa6 100644
--- a/src/hamiltonian/hamiltonian_elec_inc.F90
+++ b/src/hamiltonian/hamiltonian_elec_inc.F90
@@ -17,7 +17,7 @@
!!
! ---------------------------------------------------------
-subroutine X(hamiltonian_elec_apply) (hm, namespace, mesh, psib, hpsib, terms, set_bc)
+module subroutine X(hamiltonian_elec_apply) (hm, namespace, mesh, psib, hpsib, terms, set_bc)
class(hamiltonian_elec_t), intent(in) :: hm
type(namespace_t), intent(in) :: namespace
class(mesh_t), intent(in) :: mesh
@@ -46,7 +46,7 @@ subroutine X(hamiltonian_elec_apply) (hm, namespace, mesh, psib, hpsib, terms, s
end subroutine X(hamiltonian_elec_apply)
! ---------------------------------------------------------
-subroutine X(hamiltonian_elec_magnus_apply) (hm, namespace, mesh, psib, hpsib, vmagnus)
+module subroutine X(hamiltonian_elec_magnus_apply) (hm, namespace, mesh, psib, hpsib, vmagnus)
class(hamiltonian_elec_t), intent(in) :: hm
type(namespace_t), intent(in) :: namespace
class(mesh_t), intent(in) :: mesh
@@ -74,7 +74,7 @@ subroutine X(hamiltonian_elec_magnus_apply) (hm, namespace, mesh, psib, hpsib, v
end subroutine X(hamiltonian_elec_magnus_apply)
! ---------------------------------------------------------
-subroutine X(hamiltonian_elec_apply_batch) (hm, namespace, mesh, psib, hpsib, terms, set_bc)
+module subroutine X(hamiltonian_elec_apply_batch) (hm, namespace, mesh, psib, hpsib, terms, set_bc)
type(hamiltonian_elec_t), intent(in) :: hm
type(namespace_t), intent(in) :: namespace
class(mesh_t), intent(in) :: mesh
@@ -283,7 +283,7 @@ end subroutine X(hamiltonian_elec_apply_batch)
! ---------------------------------------------------------
-subroutine X(hamiltonian_elec_external)(this, mesh, psib, vpsib)
+module subroutine X(hamiltonian_elec_external)(this, mesh, psib, vpsib)
type(hamiltonian_elec_t), intent(in) :: this
class(mesh_t), intent(in) :: mesh
type(wfs_elec_t), intent(in) :: psib
@@ -332,7 +332,7 @@ end subroutine X(hamiltonian_elec_external)
! ---------------------------------------------------------
-subroutine X(hamiltonian_elec_apply_single) (hm, namespace, mesh, psi, hpsi, ist, ik, terms, set_bc, set_phase)
+module subroutine X(hamiltonian_elec_apply_single) (hm, namespace, mesh, psi, hpsi, ist, ik, terms, set_bc, set_phase)
type(hamiltonian_elec_t), intent(in) :: hm
type(namespace_t), intent(in) :: namespace
class(mesh_t), intent(in) :: mesh
@@ -366,7 +366,7 @@ subroutine X(hamiltonian_elec_apply_single) (hm, namespace, mesh, psi, hpsi, ist
end subroutine X(hamiltonian_elec_apply_single)
-subroutine X(hamiltonian_elec_magnus_apply_batch) (hm, namespace, mesh, psib, hpsib, vmagnus)
+module subroutine X(hamiltonian_elec_magnus_apply_batch) (hm, namespace, mesh, psib, hpsib, vmagnus)
type(hamiltonian_elec_t), intent(in) :: hm
type(namespace_t), intent(in) :: namespace
class(mesh_t), intent(in) :: mesh
@@ -418,7 +418,7 @@ subroutine X(hamiltonian_elec_magnus_apply_batch) (hm, namespace, mesh, psib, hp
end subroutine X(hamiltonian_elec_magnus_apply_batch)
! ---------------------------------------------------------
-subroutine X(h_mgga_terms) (hm, mesh, psib, hpsib, ghost_update)
+module subroutine X(h_mgga_terms) (hm, mesh, psib, hpsib, ghost_update)
type(hamiltonian_elec_t), intent(in) :: hm
class(mesh_t), intent(in) :: mesh
type(wfs_elec_t), intent(inout) :: psib
@@ -482,7 +482,7 @@ end subroutine X(h_mgga_terms)
! ---------------------------------------------------------
-subroutine X(vmask) (mesh, hm, st)
+module subroutine X(vmask) (mesh, hm, st)
class(mesh_t), intent(in) :: mesh
type(hamiltonian_elec_t), intent(in) :: hm
type(states_elec_t), intent(inout) :: st
@@ -513,7 +513,7 @@ end subroutine X(vmask)
! ---------------------------------------------------------
-subroutine X(hamiltonian_elec_diagonal) (hm, mesh, diag, ik)
+module subroutine X(hamiltonian_elec_diagonal) (hm, mesh, diag, ik)
type(hamiltonian_elec_t), intent(in) :: hm
class(mesh_t), intent(in) :: mesh
R_TYPE, intent(out) :: diag(:,:) !< hpsi(gr%mesh%np, hm%d%dim)
diff --git a/src/hamiltonian/hamiltonian_extensions.F90 b/src/hamiltonian/hamiltonian_extensions.F90
new file mode 100644
index 0000000000000000000000000000000000000000..8331100ed7db18be55bbad402563b4828812fbed
--- /dev/null
+++ b/src/hamiltonian/hamiltonian_extensions.F90
@@ -0,0 +1,65 @@
+submodule (hamiltonian_extensions_oct_m) impl
+ implicit none
+
+contains
+ ! Hamiltonian extension
+ module subroutine hamiltonian_extension_init(this, def, hm)
+ class(hamiltonian_extension_t), target, intent(inout) :: this
+ class(hamiltonian_extension_def_t), pointer, intent(in) :: def
+ class(hamiltonian_abst_t), pointer, intent(in) :: hm
+
+ class(extension_def_t), pointer :: ext_def
+
+ ! Intel compiler complains about dummy argument
+ ext_def => def
+ this%hamiltonian => hm
+ ! Register self to hamiltonian's extensions list
+ call this%extension_init(ext_def, hm%extensions)
+ end subroutine hamiltonian_extension_init
+
+ module subroutine hamiltonian_extension_end(this)
+ type(hamiltonian_extension_t), intent(inout) :: this
+
+ end subroutine hamiltonian_extension_end
+
+ module subroutine hamiltonian_extension_post_init(this)
+ class(hamiltonian_extension_t), target, intent(inout) :: this
+
+ call this%extension_t%post_init()
+ end subroutine hamiltonian_extension_post_init
+
+ module subroutine hamiltonian_extension_apply_stub(this, namespace, mesh, psib, hpsib)
+ class(hamiltonian_extension_t), intent(inout) :: this
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), target, intent(inout) :: psib
+ class(batch_t), target, intent(inout) :: hpsib
+
+ ! Do nothing
+ end subroutine hamiltonian_extension_apply_stub
+
+ module subroutine hamiltonian_extension_update_stub(this, time)
+ class(hamiltonian_extension_t), intent(inout) :: this
+ real(real64), optional, intent(in) :: time
+
+ ! Do nothing
+ end subroutine hamiltonian_extension_update_stub
+
+ ! Hamiltonian extension def
+ module subroutine hamiltonian_extension_def_init(this, name, priority, unique)
+ class(hamiltonian_extension_def_t), target, intent(inout) :: this
+ character(*), intent(in) :: name
+ integer, intent(in) :: priority
+ logical, intent(in) :: unique
+
+ ! Call base constructor
+ call this%extension_def_init(name, priority, unique)
+ end subroutine hamiltonian_extension_def_init
+
+ module subroutine hamiltonian_extension_def_end(this)
+ class(hamiltonian_extension_def_t), intent(inout) :: this
+
+ ! Call base destructor
+ call this%extension_def_end()
+ end subroutine hamiltonian_extension_def_end
+end submodule impl
diff --git a/src/hamiltonian/hamiltonian_extensions_h.F90 b/src/hamiltonian/hamiltonian_extensions_h.F90
new file mode 100644
index 0000000000000000000000000000000000000000..319d4faaf7a0baecb5d9d6a4f59b68e6b5a700d2
--- /dev/null
+++ b/src/hamiltonian/hamiltonian_extensions_h.F90
@@ -0,0 +1,137 @@
+module hamiltonian_extensions_oct_m
+ use hamiltonian_abst_oct_m
+ use extension_oct_m
+ use namespace_oct_m
+ use mesh_oct_m
+ use batch_oct_m
+ use, intrinsic :: iso_fortran_env
+ implicit none
+
+ private
+
+ !> Hamiltonian extension
+ !!
+ !! Enables adding functionalities to the hamiltonian non-intrusively.
+ type, extends(extension_t), public :: hamiltonian_extension_t
+ private
+ !> Reference pointer to the hamiltonian where the extension is installed on
+ class(hamiltonian_abst_t), pointer, public :: hamiltonian
+
+ contains
+ ! Fortran limitation: No proper move constructors
+ procedure hamiltonian_extension_init
+ ! TODO: Implement and move to callers of system constructors
+ !> Post initialization. Executed just after hamiltonian is initialized
+ procedure :: post_init => hamiltonian_extension_post_init
+ !> Extension to hamiltonian's dapply. Run before hamiltonian's
+ procedure :: pre_dapply => hamiltonian_extension_apply_stub
+ !> Extension to hamiltonian's dapply. Run after hamiltonian's
+ procedure :: post_dapply => hamiltonian_extension_apply_stub
+ !> Extension to hamiltonian's zapply. Run before hamiltonian's
+ procedure :: pre_zapply => hamiltonian_extension_apply_stub
+ !> Extension to hamiltonian's zapply. Run after hamiltonian's
+ procedure :: post_zapply => hamiltonian_extension_apply_stub
+ !> Extension to hamiltonian's dmagnus_apply. Run before hamiltonian's
+ procedure :: pre_dmagnus_apply => hamiltonian_extension_apply_stub
+ !> Extension to hamiltonian's dmagnus_apply. Run after hamiltonian's
+ procedure :: post_dmagnus_apply => hamiltonian_extension_apply_stub
+ !> Extension to hamiltonian's zmagnus_apply. Run before hamiltonian's
+ procedure :: pre_zmagnus_apply => hamiltonian_extension_apply_stub
+ !> Extension to hamiltonian's zmagnus_apply. Run after hamiltonian's
+ procedure :: post_zmagnus_apply => hamiltonian_extension_apply_stub
+ !> Extension to hamiltonian's update. Run before hamiltonian's
+ procedure :: pre_update => hamiltonian_extension_update_stub
+ !> Extension to hamiltonian's update. Run after hamiltonian's
+ procedure :: post_update => hamiltonian_extension_update_stub
+ !> Extension destructor. Ensures the extension is de-registered
+ final :: hamiltonian_extension_end
+ end type hamiltonian_extension_t
+
+ !> Hamiltonian extension definition
+ !!
+ !! Stores metadata of hamiltonian extension
+ type, extends(extension_def_t), abstract, public :: hamiltonian_extension_def_t
+ private
+ contains
+ private
+ procedure, public :: hamiltonian_extension_def_init
+ procedure, public :: hamiltonian_extension_def_end
+ end type hamiltonian_extension_def_t
+
+ interface
+ !> Default base constructor for hamiltonian_extension
+ !!
+ !! This constructor ensures the extension is registered in the hamiltonian
+ !!
+ !! NOTE: Must only be called ONCE
+ !!
+ !! Due to fortran limitation, no value type constructors can be defined.
+ !! Must use a pointer creator interface instead.
+ !!
+ !! @param this Hamiltonian extension
+ !! @param hm Parent hamiltonian of the extension
+ module subroutine hamiltonian_extension_init(this, def, hm)
+ class(hamiltonian_extension_t), target, intent(inout) :: this
+ class(hamiltonian_extension_def_t), pointer, intent(in) :: def
+ class(hamiltonian_abst_t), pointer, intent(in) :: hm
+ end subroutine hamiltonian_extension_init
+ !> Hamiltonian extension destructor
+ !!
+ !! @param this hamiltonian_extension_t object
+ module subroutine hamiltonian_extension_end(this)
+ type(hamiltonian_extension_t), intent(inout) :: this
+ end subroutine hamiltonian_extension_end
+
+ !> Stub: Do nothing operator
+ !!
+ !! @param this hamiltonian_extension_t object
+ module subroutine hamiltonian_extension_post_init(this)
+ class(hamiltonian_extension_t), target, intent(inout) :: this
+ end subroutine hamiltonian_extension_post_init
+
+ !> Stub: Do nothing operator
+ !!
+ !! @param this hamiltonian_extension_t object
+ module subroutine hamiltonian_extension_apply_stub(this, namespace, mesh, psib, hpsib)
+ class(hamiltonian_extension_t), intent(inout) :: this
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), target, intent(inout) :: psib
+ class(batch_t), target, intent(inout) :: hpsib
+ end subroutine hamiltonian_extension_apply_stub
+
+ !> Stub: Do nothing operator
+ !!
+ !! @param this hamiltonian_extension_t object
+ module subroutine hamiltonian_extension_update_stub(this, time)
+ class(hamiltonian_extension_t), intent(inout) :: this
+ real(real64), optional, intent(in) :: time
+ end subroutine hamiltonian_extension_update_stub
+
+ !> Constructor for the abstract class hamiltonian_extension_def_t
+ !!
+ !! Fortran limitation: Cannot define abstract constructor. Have to use subroutine instead.
+ !!
+ !! IMPORTANT: The actual constructors must call this subroutine exactly ONCE
+ !!
+ !! @param this extension_def_t object
+ !! @param name Value of this%name
+ module subroutine hamiltonian_extension_def_init(this, name, priority, unique)
+ class(hamiltonian_extension_def_t), target, intent(inout) :: this
+ character(*), intent(in) :: name
+ integer, intent(in) :: priority
+ logical, intent(in) :: unique
+ end subroutine hamiltonian_extension_def_init
+
+ !> Destructor for the abstract class hamiltonian_extension_def_t
+ !!
+ !! Fortran limitation: Cannot define abstract destructor. Have to use subroutine instead.
+ !!
+ !! IMPORTANT: The actual destructors must call this subroutine exactly ONCE
+ !!
+ !! @param this extension_def_t object
+ module subroutine hamiltonian_extension_def_end(this)
+ class(hamiltonian_extension_def_t), intent(inout) :: this
+ end subroutine hamiltonian_extension_def_end
+ end interface
+end module hamiltonian_extensions_oct_m
diff --git a/src/main/geom_opt.F90 b/src/main/geom_opt.F90
index 51a13c1c99111e381938a438b82180784f58a224..7d1400c1f267508cef82f4003a2530b8e742bfd5 100644
--- a/src/main/geom_opt.F90
+++ b/src/main/geom_opt.F90
@@ -46,6 +46,7 @@ module geom_opt_oct_m
use profiling_oct_m
use read_coords_oct_m
use restart_oct_m
+ use scf_interface_oct_m
use scf_oct_m
use species_oct_m
use states_elec_oct_m
@@ -76,7 +77,6 @@ module geom_opt_oct_m
integer :: what2minimize
!> shortcuts
- type(scf_t) :: scfv
type(ions_t), pointer :: ions
type(hamiltonian_elec_t), pointer :: hm
type(electrons_t), pointer :: syst
@@ -86,7 +86,6 @@ module geom_opt_oct_m
integer :: periodic_dim
integer :: size !< Size of the minimization problem
integer :: fixed_atom = 0
- type(restart_t) :: restart_dump
real(real64), allocatable :: cell_force(:,:)
logical :: symmetrize = .false.
@@ -136,7 +135,6 @@ contains
real(real64), allocatable :: mass(:)
integer :: iatom, imass
- type(restart_t) :: restart_load
PUSH_SUB(geom_opt_run_legacy)
@@ -159,11 +157,14 @@ contains
! load wavefunctions
if (.not. fromscratch) then
- call restart_init(restart_load, sys%namespace, RESTART_GS, RESTART_TYPE_LOAD, sys%mc, ierr, mesh=sys%gr)
+ allocate(sys%scf%restart_load)
+ call restart_init(sys%scf%restart_load, sys%namespace, RESTART_GS, RESTART_TYPE_LOAD, sys%mc, ierr, mesh=sys%gr)
if (ierr == 0) then
- call states_elec_load(restart_load, sys%namespace, sys%space, sys%st, sys%gr, sys%kpoints, ierr)
+ call states_elec_load(sys%scf%restart_load, sys%namespace, sys%space, sys%st, sys%gr, sys%kpoints, ierr)
end if
- call restart_end(restart_load)
+ ! End and de-allocate to not interfere with scf_run
+ call restart_end(sys%scf%restart_load)
+ deallocate(sys%scf%restart_load)
if (ierr /= 0) then
message(1) = "Unable to read wavefunctions: Starting from scratch."
call messages_warning(1, namespace=sys%namespace)
@@ -171,17 +172,17 @@ contains
end if
end if
- call scf_init(g_opt%scfv, sys%namespace, sys%gr, sys%ions, sys%st, sys%mc, sys%hm, sys%space)
+ call scf_init(sys)
if (bitand(g_opt%type, GO_CELL) /= 0 .or. bitand(g_opt%type, GO_VOLUME) /= 0) then
- if (.not. g_opt%scfv%calc_stress) then
+ if (.not. sys%scf%calc_stress) then
message(1) = "In order to optimize the cell, one needs to set SCFCalculeStress = yes."
call messages_fatal(1, namespace=sys%namespace)
end if
end if
if (fromScratch) then
- call lcao_run(sys%namespace, sys%space, sys%gr, sys%ions, sys%ext_partners, sys%st, sys%ks, sys%hm, lmm_r = g_opt%scfv%lmm_r)
+ call lcao_run(sys%namespace, sys%space, sys%gr, sys%ions, sys%ext_partners, sys%st, sys%ks, sys%hm, lmm_r = sys%scf%lmm_r)
else
! setup Hamiltonian
message(1) = 'Info: Setting up Hamiltonian.'
@@ -246,9 +247,9 @@ contains
call g_opt%ions%write_xyz('./min')
SAFE_DEALLOCATE_A(coords)
- call scf_end(g_opt%scfv)
+ call scf_end(sys)
! Because g_opt has the "save" atribute, we need to explicitly empty the criteria list here, or there will be a memory leak.
- call g_opt%scfv%criterion_list%empty()
+ call sys%scf%criterion_list%empty()
call end_()
POP_SUB(geom_opt_run_legacy)
@@ -694,7 +695,8 @@ contains
! TODO: clean forces directory
end do
- call restart_init(g_opt%restart_dump, sys%namespace, RESTART_GS, RESTART_TYPE_DUMP, sys%mc, ierr, mesh=sys%gr)
+ allocate(sys%scf%restart_dump)
+ call restart_init(sys%scf%restart_dump, sys%namespace, RESTART_GS, RESTART_TYPE_DUMP, sys%mc, ierr, mesh=sys%gr)
POP_SUB(geom_opt_run_legacy.init_)
end subroutine init_
@@ -706,7 +708,7 @@ contains
call states_elec_deallocate_wfns(sys%st)
- call restart_end(g_opt%restart_dump)
+ call restart_end(sys%scf%restart_dump)
nullify(g_opt%mesh)
nullify(g_opt%ions)
@@ -764,7 +766,7 @@ contains
call g_opt%ions%write_xyz('./work-geom', append = .true.)
- call scf_mix_clear(g_opt%scfv)
+ call scf_mix_clear(g_opt%syst)
! Update lattice vectors and regenerate grid
if (bitand(g_opt%type, GO_CELL) /= 0 .or. bitand(g_opt%type, GO_VOLUME) /= 0 ) then
@@ -781,9 +783,7 @@ contains
call energy_calc_total(g_opt%syst%namespace, g_opt%syst%space, g_opt%hm, g_opt%syst%gr, g_opt%st, g_opt%syst%ext_partners)
! do SCF calculation
- call scf_run(g_opt%scfv, g_opt%syst%namespace, g_opt%syst%space, g_opt%syst%mc, g_opt%syst%gr, &
- g_opt%ions, g_opt%syst%ext_partners, &
- g_opt%st, g_opt%syst%ks, g_opt%hm, outp = g_opt%syst%outp, verbosity = VERB_COMPACT, restart_dump=g_opt%restart_dump)
+ call scf_run(g_opt%syst, outp = g_opt%syst%outp, verbosity = VERB_COMPACT)
call scf_print_mem_use(g_opt%syst%namespace)
diff --git a/src/main/ground_state.F90 b/src/main/ground_state.F90
index 8e5adb8ead5c21bf887906d87a36579ec865ef8b..ee17ad0bc6093ac0ed7041f4638694e0185895fb 100644
--- a/src/main/ground_state.F90
+++ b/src/main/ground_state.F90
@@ -95,31 +95,19 @@ contains
message(1) = "Check log of the run in "//trim(system2%namespace%get())//"/log."
message(2) = ""
call messages_info(2, namespace=global_namespace)
- call ground_state_run_legacy(system2, from_scratch)
+ call electrons_ground_state_run(system2, from_scratch)
call messages_print_with_emphasis(namespace=global_namespace)
end select
end do
end if
type is (electrons_t)
- call ground_state_run_legacy(system, from_scratch)
+ call electrons_ground_state_run(system, from_scratch)
end select
POP_SUB(ground_state_run)
end subroutine ground_state_run
- subroutine ground_state_run_legacy(electrons, from_scratch)
- class(electrons_t), intent(inout) :: electrons
- logical, intent(inout) :: from_scratch
-
- PUSH_SUB(ground_state_run_legacy)
-
- call electrons_ground_state_run(electrons%namespace, electrons%mc, electrons%gr, electrons%ions, electrons%ext_partners, &
- electrons%st, electrons%ks, electrons%hm, electrons%outp, electrons%space, from_scratch)
-
- POP_SUB(ground_state_run_legacy)
- end subroutine ground_state_run_legacy
-
end module ground_state_oct_m
!! Local Variables:
diff --git a/src/main/main.F90 b/src/main/main.F90
index 604f3a54c41651c9bbc4dace91b1d222a8e755bb..ee492df1cb6567288bd3b5054b17c3e8acc1ffc8 100644
--- a/src/main/main.F90
+++ b/src/main/main.F90
@@ -121,6 +121,8 @@ program octopus
call parse_variable(global_namespace, 'CalculationMode', OPTION__CALCULATIONMODE__GS, inp_calc_mode)
if (.not. varinfo_valid_option('CalculationMode', inp_calc_mode)) call messages_input_error(global_namespace, 'CalculationMode')
+ call global_options%set('CalculationMode', inp_calc_mode)
+
! Now we can initialize the I/O
call io_init()
diff --git a/src/main/phonons_fd.F90 b/src/main/phonons_fd.F90
index 6eff8e1c605b7f044413a3398290107ca79a7c0e..002957bf4c3ce2570727867123fcbe01da10d54e 100644
--- a/src/main/phonons_fd.F90
+++ b/src/main/phonons_fd.F90
@@ -39,6 +39,7 @@ module phonons_fd_oct_m
use parser_oct_m
use profiling_oct_m
use restart_oct_m
+ use scf_interface_oct_m
use scf_oct_m
use space_oct_m
use states_elec_oct_m
@@ -129,8 +130,7 @@ contains
call parse_variable(sys%namespace, 'Displacement', 0.01_real64, vib%disp, units_inp%length)
! calculate dynamical matrix
- call get_dyn_matrix(sys%gr, sys%namespace, sys%mc, sys%ions, sys%ext_partners, sys%st, sys%ks, &
- sys%hm, sys%outp, vib, sys%space)
+ call get_dyn_matrix(sys, vib)
call vibrations_output(vib)
@@ -143,65 +143,55 @@ contains
! ---------------------------------------------------------
!>@brief Computes the second-order force constant from finite differences
- subroutine get_dyn_matrix(gr, namespace, mc, ions, ext_partners, st, ks, hm, outp, vib, space)
- type(grid_t), target, intent(inout) :: gr
- type(namespace_t), intent(in) :: namespace
- type(multicomm_t), intent(in) :: mc
- type(ions_t), intent(inout) :: ions
- type(partner_list_t), intent(in) :: ext_partners
- type(states_elec_t), intent(inout) :: st
- type(v_ks_t), intent(inout) :: ks
- type(hamiltonian_elec_t), intent(inout) :: hm
- type(output_t), intent(in) :: outp
+ subroutine get_dyn_matrix(sys, vib)
+ type(electrons_t), intent(inout) :: sys
type(vibrations_t), intent(inout) :: vib
- type(electron_space_t), intent(in) :: space
- type(scf_t) :: scf
integer :: iatom, jatom, alpha, beta, imat, jmat
real(real64), allocatable :: forces(:,:), forces0(:,:)
PUSH_SUB(get_dyn_matrix)
- call scf_init(scf, namespace, gr, ions, st, mc, hm, space)
- SAFE_ALLOCATE(forces0(1:space%dim, 1:ions%natoms))
- SAFE_ALLOCATE(forces (1:space%dim, 1:ions%natoms))
+ call scf_init(sys)
+ SAFE_ALLOCATE(forces0(1:sys%space%dim, 1:sys%ions%natoms))
+ SAFE_ALLOCATE(forces (1:sys%space%dim, 1:sys%ions%natoms))
forces = M_ZERO
forces0 = M_ZERO
- do iatom = 1, ions%natoms
- do alpha = 1, space%dim
+ do iatom = 1, sys%ions%natoms
+ do alpha = 1, sys%space%dim
imat = vibrations_get_index(vib, iatom, alpha)
call messages_new_line()
- call messages_print_with_emphasis(namespace=namespace)
+ call messages_print_with_emphasis(namespace=sys%namespace)
write(message(1), '(a,i3,3a)') 'Info: Moving atom ', iatom, ' in the +', index2axis(alpha), '-direction.'
- call messages_info(1, namespace=namespace)
- call messages_print_with_emphasis(namespace=namespace)
+ call messages_info(1, namespace=sys%namespace)
+ call messages_print_with_emphasis(namespace=sys%namespace)
! move atom iatom in direction alpha by dist
- ions%pos(alpha, iatom) = ions%pos(alpha, iatom) + vib%disp
+ sys%ions%pos(alpha, iatom) = sys%ions%pos(alpha, iatom) + vib%disp
! first force
call run_displacement()
- forces0 = ions%tot_force
+ forces0 = sys%ions%tot_force
call messages_new_line()
- call messages_print_with_emphasis(namespace=namespace)
+ call messages_print_with_emphasis(namespace=sys%namespace)
write(message(1), '(a,i3,3a)') 'Info: Moving atom ', iatom, ' in the -', index2axis(alpha), '-direction.'
- call messages_info(1, namespace=namespace)
- call messages_print_with_emphasis(namespace=namespace)
+ call messages_info(1, namespace=sys%namespace)
+ call messages_print_with_emphasis(namespace=sys%namespace)
- ions%pos(alpha, iatom) = ions%pos(alpha, iatom) - M_TWO*vib%disp
+ sys%ions%pos(alpha, iatom) = sys%ions%pos(alpha, iatom) - M_TWO*vib%disp
! second force
call run_displacement()
- forces = ions%tot_force
+ forces = sys%ions%tot_force
- ions%pos(alpha, iatom) = ions%pos(alpha, iatom) + vib%disp
+ sys%ions%pos(alpha, iatom) = sys%ions%pos(alpha, iatom) + vib%disp
- do jatom = 1, ions%natoms
- do beta = 1, space%dim
+ do jatom = 1, sys%ions%natoms
+ do beta = 1, sys%space%dim
jmat = vibrations_get_index(vib, jatom, beta)
vib%dyn_matrix(jmat, imat) = (forces0(beta, jatom) - forces(beta, jatom)) / (M_TWO*vib%disp) &
* vibrations_norm_factor(vib, iatom, jatom)
@@ -213,7 +203,7 @@ contains
end do
SAFE_DEALLOCATE_A(forces0)
SAFE_DEALLOCATE_A(forces)
- call scf_end(scf)
+ call scf_end(sys)
call vibrations_symmetrize_dyn_matrix(vib)
call vibrations_diag_dyn_matrix(vib)
@@ -226,12 +216,12 @@ contains
subroutine run_displacement()
PUSH_SUB(get_dyn_matrix.run_displacement)
- call hamiltonian_elec_epot_generate(hm, namespace, space, gr, ions, ext_partners, st)
- call density_calc(st, gr, st%rho)
- call v_ks_calc(ks, namespace, space, hm, st, ions, ext_partners, calc_eigenval=.true.)
- call energy_calc_total(namespace, space, hm, gr, st, ext_partners)
- call scf_mix_clear(scf)
- call scf_run(scf, namespace, space, mc, gr, ions, ext_partners, st, ks, hm, verbosity = VERB_COMPACT)
+ call hamiltonian_elec_epot_generate(sys%hm, sys%namespace, sys%space, sys%gr, sys%ions, sys%ext_partners, sys%st)
+ call density_calc(sys%st, sys%gr, sys%st%rho)
+ call v_ks_calc(sys%ks, sys%namespace, sys%space, sys%hm, sys%st, sys%ions, sys%ext_partners, calc_eigenval=.true.)
+ call energy_calc_total(sys%namespace, sys%space, sys%hm, sys%gr, sys%st, sys%ext_partners)
+ call scf_mix_clear(sys)
+ call scf_run(sys, verbosity = VERB_COMPACT)
POP_SUB(get_dyn_matrix.run_displacement)
end subroutine run_displacement
diff --git a/src/main/run.F90 b/src/main/run.F90
index 708273bdf962a85e4652618a7cdc00460fa0939a..dc15b4ee4e41e76c8cfdea751f99bce031021469 100644
--- a/src/main/run.F90
+++ b/src/main/run.F90
@@ -55,7 +55,7 @@ module run_oct_m
use static_pol_oct_m
use system_factory_oct_m
use system_oct_m
- use td_oct_m
+ use td_interface_oct_m
use test_oct_m
use time_dependent_oct_m
use unit_system_oct_m
diff --git a/src/main/static_pol.F90 b/src/main/static_pol.F90
index ac404ef5b56f96b30d3a4d4dbfa4b5017c3511eb..265c715d256e0c059f9e6ced330c1e31f1a15a4c 100644
--- a/src/main/static_pol.F90
+++ b/src/main/static_pol.F90
@@ -39,6 +39,7 @@ module static_pol_oct_m
use parser_oct_m
use profiling_oct_m
use restart_oct_m
+ use scf_interface_oct_m
use scf_oct_m
use space_oct_m
use states_abst_oct_m
@@ -82,7 +83,6 @@ contains
type(electrons_t), intent(inout) :: sys
logical, intent(in) :: fromScratch
- type(scf_t) :: scfv
integer :: iunit, ios, i_start, ii, jj, is, isign, ierr, read_count, verbosity
real(real64) :: e_field, e_field_saved
real(real64), allocatable :: Vpsl_save(:), trrho(:), dipole(:, :, :)
@@ -223,7 +223,7 @@ contains
gs_rho = M_ZERO
call output_init_()
- call scf_init(scfv, sys%namespace, sys%gr, sys%ions, sys%st, sys%mc, sys%hm, sys%space)
+ call scf_init(sys)
call born_charges_init(born_charges, sys%namespace, sys%ions%natoms, sys%st%val_charge, &
sys%st%qtot, sys%space%dim)
@@ -235,8 +235,7 @@ contains
write(message(1), '(a)')
write(message(2), '(a)') 'Info: Calculating dipole moment for zero field.'
call messages_info(2, namespace=sys%namespace)
- call scf_run(scfv, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, sys%st, &
- sys%ks, sys%hm, verbosity = verbosity)
+ call scf_run(sys, verbosity = verbosity)
gs_rho(1:sys%gr%np, 1:sys%st%d%nspin) = sys%st%rho(1:sys%gr%np, 1:sys%st%d%nspin)
trrho = M_ZERO
@@ -305,13 +304,12 @@ contains
call v_ks_h_setup(sys%namespace, sys%space, sys%gr, sys%ions, sys%ext_partners, sys%st, sys%ks, sys%hm)
else
call lcao_run(sys%namespace, sys%space, sys%gr, sys%ions, sys%ext_partners, sys%st, sys%ks, &
- sys%hm, lmm_r = scfv%lmm_r)
+ sys%hm, lmm_r = sys%scf%lmm_r)
end if
end if
- call scf_mix_clear(scfv)
- call scf_run(scfv, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, sys%st, &
- sys%ks, sys%hm, verbosity = verbosity)
+ call scf_mix_clear(sys)
+ call scf_run(sys, verbosity = verbosity)
trrho = M_ZERO
do is = 1, sys%st%d%spin_channels
@@ -391,13 +389,12 @@ contains
call v_ks_h_setup(sys%namespace, sys%space, sys%gr, sys%ions, sys%ext_partners, sys%st, sys%ks, sys%hm)
else
call lcao_run(sys%namespace, sys%space, sys%gr, sys%ions, sys%ext_partners, sys%st, sys%ks, &
- sys%hm, lmm_r = scfv%lmm_r)
+ sys%hm, lmm_r = sys%scf%lmm_r)
end if
end if
- call scf_mix_clear(scfv)
- call scf_run(scfv, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, sys%st, &
- sys%ks, sys%hm, verbosity = verbosity)
+ call scf_mix_clear(sys)
+ call scf_run(sys, verbosity = verbosity)
trrho = M_ZERO
do is = 1, sys%st%d%spin_channels
@@ -439,7 +436,7 @@ contains
end if
if (.not. fromScratch) call restart_end(restart_load)
- call scf_end(scfv)
+ call scf_end(sys)
call output_end_()
call born_charges_end(born_charges)
diff --git a/src/main/time_dependent.F90 b/src/main/time_dependent.F90
index 556c733da5d67338f83c60ee3b6fc0e7310985a0..f68bd04787a463039bfe6441875b22405e00d436 100644
--- a/src/main/time_dependent.F90
+++ b/src/main/time_dependent.F90
@@ -30,7 +30,7 @@ module time_dependent_oct_m
use profiling_oct_m
use restart_oct_m
use system_oct_m
- use td_oct_m
+ use td_interface_oct_m
use walltimer_oct_m
implicit none
@@ -132,14 +132,8 @@ contains
PUSH_SUB(time_dependent_run_legacy)
- call td_init(electrons%td, electrons%namespace, electrons%space, electrons%gr, electrons%ions, electrons%st, electrons%ks, &
- electrons%hm, electrons%ext_partners, electrons%outp)
- call td_init_run(electrons%td, electrons%namespace, electrons%mc, electrons%gr, electrons%ions, electrons%st, electrons%ks, &
- electrons%hm, electrons%ext_partners, electrons%outp, electrons%space, from_scratch)
- call td_run(electrons%td, electrons%namespace, electrons%mc, electrons%gr, electrons%ions, electrons%st, electrons%ks, &
- electrons%hm, electrons%ext_partners, electrons%outp, electrons%space, from_scratch)
- call td_end_run(electrons%td, electrons%st, electrons%hm)
- call td_end(electrons%td)
+ call td_init_run(electrons, from_scratch)
+ call td_run(electrons, from_scratch)
POP_SUB(time_dependent_run_legacy)
end subroutine time_dependent_run_legacy
diff --git a/src/maxwell/CMakeLists.txt b/src/maxwell/CMakeLists.txt
index 74a639c24ed05817facf9ae366cbd2854541c665..6a6ffcb669da746dae6914a708a7189de862bf56 100644
--- a/src/maxwell/CMakeLists.txt
+++ b/src/maxwell/CMakeLists.txt
@@ -4,6 +4,7 @@ target_sources(Octopus_lib PRIVATE
external_densities.F90
external_waves.F90
hamiltonian_mxll.F90
+ hamiltonian_mxll_h.F90
linear_medium.F90
maxwell.F90
maxwell_boundary_op.F90
diff --git a/src/maxwell/dispersive_medium.F90 b/src/maxwell/dispersive_medium.F90
index e116d0b016fec40f2ed918696ad9711f827e9d48..bcd6b46943a790d5a2bcb2837510f8244a755805 100644
--- a/src/maxwell/dispersive_medium.F90
+++ b/src/maxwell/dispersive_medium.F90
@@ -735,7 +735,7 @@ contains
type(dispersive_medium_t), intent(inout) :: this
PUSH_SUB(dispersive_medium_finalize)
- call system_end(this)
+ call this%system_end()
SAFE_DEALLOCATE_A(this%current_p)
SAFE_DEALLOCATE_A(this%e_field)
SAFE_DEALLOCATE_A(this%selected_points_coordinate)
diff --git a/src/maxwell/hamiltonian_mxll.F90 b/src/maxwell/hamiltonian_mxll.F90
index 599ff2c43b1ef0b6fa626246c46145b3ee2eef11..1c87265d43b7a78fe6c9cd199095e1d3123a086c 100644
--- a/src/maxwell/hamiltonian_mxll.F90
+++ b/src/maxwell/hamiltonian_mxll.F90
@@ -18,146 +18,28 @@
#include "global.h"
-module hamiltonian_mxll_oct_m
+submodule (hamiltonian_mxll_oct_m) impl
+ use hamiltonian_mxll_oct_m
use accel_oct_m
- use batch_oct_m
use batch_ops_oct_m
use boundaries_oct_m
- use cube_oct_m
use debug_oct_m
- use derivatives_oct_m
- use energy_mxll_oct_m
use global_oct_m
- use grid_oct_m
- use hamiltonian_abst_oct_m
use hamiltonian_elec_oct_m
- use, intrinsic :: iso_fortran_env
- use linear_medium_to_em_field_oct_m
use math_oct_m
- use maxwell_boundary_op_oct_m
- use mesh_cube_parallel_map_oct_m
- use mesh_oct_m
use messages_oct_m
- use namespace_oct_m
- use nl_operator_oct_m
use parser_oct_m
use poisson_oct_m
use profiling_oct_m
use states_elec_dim_oct_m
use states_elec_oct_m
- use states_mxll_oct_m
implicit none
-
- private
- public :: &
- hamiltonian_mxll_t, &
- hamiltonian_mxll_init, &
- hamiltonian_mxll_end, &
- dhamiltonian_mxll_apply, &
- zhamiltonian_mxll_apply, &
- dhamiltonian_mxll_magnus_apply, &
- zhamiltonian_mxll_magnus_apply, &
- hamiltonian_mxll_apply_batch, &
- hamiltonian_mxll_span, &
- hamiltonian_mxll_adjoint, &
- hamiltonian_mxll_not_adjoint, &
- hamiltonian_mxll_hermitian, &
- hamiltonian_mxll_update, &
- hamiltonian_mxll_get_time, &
- hamiltonian_mxll_apply_packed, &
- hamiltonian_mxll_apply_simple, &
- mxll_update_pml_simple, &
- mxll_copy_pml_simple
-
- type, extends(hamiltonian_abst_t) :: hamiltonian_mxll_t
- integer :: dim
- !> absorbing boundaries
- logical :: adjoint = .false.
-
- real(real64) :: current_time
- logical :: apply_packed !< This is initialized by the StatesPack variable.
-
- logical :: time_zero
-
- type(nl_operator_t), pointer :: operators(:)
-
- type(bc_mxll_t) :: bc
- type(derivatives_t), pointer, private :: der !< pointer to derivatives
- type(states_mxll_t), pointer :: st
-
- integer :: rs_sign
-
- logical :: propagation_apply = .false.
-
- integer, pointer :: rs_state_fft_map(:,:,:)
- integer, pointer :: rs_state_fft_map_inv(:,:)
-
- logical :: mx_ma_coupling = .false.
- logical :: mx_ma_coupling_apply = .false.
- integer :: mx_ma_trans_field_calc_method
- logical :: mx_ma_trans_field_calc_corr = .false.
- integer :: mx_ma_coupling_points_number
- real(real64), allocatable :: mx_ma_coupling_points(:,:)
- integer, allocatable :: mx_ma_coupling_points_map(:)
- integer :: mx_ma_coupling_order
- logical :: ma_mx_coupling = .false.
- logical :: ma_mx_coupling_apply = .false.
-
- logical :: bc_add_ab_region = .false.
- logical :: bc_zero = .false.
- logical :: bc_constant = .false.
- logical :: bc_mirror_pec = .false.
- logical :: bc_mirror_pmc = .false.
- logical :: bc_periodic = .false.
- logical :: bc_plane_waves = .false.
- logical :: bc_medium = .false.
-
- logical :: plane_waves = .false.
- logical :: plane_waves_apply = .false.
- logical :: spatial_constant = .false.
- logical :: spatial_constant_apply = .false.
- logical :: spatial_constant_propagate = .false.
-
- logical :: calc_medium_box = .false.
- type(single_medium_box_t), allocatable :: medium_boxes(:)
- logical :: medium_boxes_initialized = .false.
-
- !> maxwell hamiltonian_mxll
- integer :: operator
- logical :: current_density_ext_flag = .false.
- logical :: current_density_from_medium = .false.
-
- type(energy_mxll_t) :: energy
-
- logical :: cpml_hamiltonian = .false.
-
- logical :: diamag_current = .false.
- real(real64) :: c_factor
- real(real64) :: current_factor
-
- type(cube_t) :: cube
- type(mesh_cube_parallel_map_t) :: mesh_cube_map
-
- contains
- procedure :: update_span => hamiltonian_mxll_span
- procedure :: dapply => dhamiltonian_mxll_apply
- procedure :: zapply => zhamiltonian_mxll_apply
- procedure :: dmagnus_apply => dhamiltonian_mxll_magnus_apply
- procedure :: zmagnus_apply => zhamiltonian_mxll_magnus_apply
- procedure :: is_hermitian => hamiltonian_mxll_hermitian
- end type hamiltonian_mxll_t
-
- integer, public, parameter :: &
- FARADAY_AMPERE = 1, &
- FARADAY_AMPERE_MEDIUM = 2, &
- MXLL_SIMPLE = 3
-
contains
! ---------------------------------------------------------
!> Initializing the Maxwell Hamiltonian
- subroutine hamiltonian_mxll_init(hm, namespace, gr, st)
+ module subroutine hamiltonian_mxll_init(hm, namespace, gr, st)
type(hamiltonian_mxll_t), intent(inout) :: hm
type(namespace_t), intent(in) :: namespace
type(grid_t), target, intent(inout) :: gr
@@ -168,6 +50,8 @@ contains
call profiling_in('HAMILTONIAN_INIT')
+ call hm%hamiltonian_abst_init()
+
hm%dim = st%dim
hm%st => st
@@ -258,7 +142,7 @@ contains
! ---------------------------------------------------------
- subroutine hamiltonian_mxll_end(hm)
+ module subroutine hamiltonian_mxll_end(hm)
type(hamiltonian_mxll_t), intent(inout) :: hm
integer :: il
@@ -279,21 +163,24 @@ contains
call profiling_out("HAMILTONIAN_MXLL_END")
+ call hm%hamiltonian_abst_end()
+
POP_SUB(hamiltonian_mxll_end)
end subroutine hamiltonian_mxll_end
! ---------------------------------------------------------
- logical function hamiltonian_mxll_hermitian(hm)
+ module function hamiltonian_mxll_hermitian(hm) result(res)
class(hamiltonian_mxll_t), intent(in) :: hm
+ logical :: res
PUSH_SUB(hamiltonian_mxll_hermitian)
if (any(hm%bc%bc_ab_type == OPTION__MAXWELLABSORBINGBOUNDARIES__CPML)) then
! With PML, the Hamiltonian is not purely Hermitian
- hamiltonian_mxll_hermitian = .false.
+ res = .false.
else
- hamiltonian_mxll_hermitian = .true.
+ res = .true.
end if
POP_SUB(hamiltonian_mxll_hermitian)
@@ -301,7 +188,7 @@ contains
! ---------------------------------------------------------
- subroutine hamiltonian_mxll_span(hm, delta, emin, namespace)
+ module subroutine hamiltonian_mxll_span(hm, delta, emin, namespace)
class(hamiltonian_mxll_t), intent(inout) :: hm
real(real64), intent(in) :: delta(:)
real(real64), intent(in) :: emin
@@ -337,7 +224,7 @@ contains
! ---------------------------------------------------------
- subroutine hamiltonian_mxll_adjoint(hm)
+ module subroutine hamiltonian_mxll_adjoint(hm)
type(hamiltonian_mxll_t), intent(inout) :: hm
PUSH_SUB(hamiltonian_mxll_adjoint)
@@ -351,7 +238,7 @@ contains
! ---------------------------------------------------------
- subroutine hamiltonian_mxll_not_adjoint(hm)
+ module subroutine hamiltonian_mxll_not_adjoint(hm)
type(hamiltonian_mxll_t), intent(inout) :: hm
PUSH_SUB(hamiltonian_mxll_not_adjoint)
@@ -366,7 +253,7 @@ contains
! ---------------------------------------------------------
!> Maxwell Hamiltonian update (here only the time is updated, can maybe be added to another routine)
- subroutine hamiltonian_mxll_update(this, time)
+ module subroutine hamiltonian_mxll_update(this, time)
type(hamiltonian_mxll_t), intent(inout) :: this
real(real64), optional, intent(in) :: time
@@ -380,8 +267,9 @@ contains
! -----------------------------------------------------------------
- real(real64) function hamiltonian_mxll_get_time(this) result(time)
+ module function hamiltonian_mxll_get_time(this) result(time)
type(hamiltonian_mxll_t), intent(inout) :: this
+ real(real64) :: time
time = this%current_time
@@ -389,9 +277,10 @@ contains
! -----------------------------------------------------------------
- logical pure function hamiltonian_mxll_apply_packed(this, mesh) result(apply)
+ pure module function hamiltonian_mxll_apply_packed(this, mesh) result(apply)
type(hamiltonian_mxll_t), intent(in) :: this
class(mesh_t), intent(in) :: mesh
+ logical :: apply
apply = this%apply_packed
if (mesh%use_curvilinear) apply = .false.
@@ -399,7 +288,7 @@ contains
end function hamiltonian_mxll_apply_packed
! ---------------------------------------------------------
- subroutine hamiltonian_mxll_apply_batch(hm, namespace, der, psib, hpsib, time, terms, set_bc)
+ module subroutine hamiltonian_mxll_apply_batch(hm, namespace, der, psib, hpsib, time, terms, set_bc)
type(hamiltonian_mxll_t), intent(in) :: hm
type(namespace_t), intent(in) :: namespace
type(derivatives_t), intent(in) :: der
@@ -680,7 +569,7 @@ contains
end subroutine hamiltonian_mxll_apply_batch
! ---------------------------------------------------------
- subroutine hamiltonian_mxll_apply_simple(hm, namespace, mesh, psib, hpsib, terms, set_bc)
+ module subroutine hamiltonian_mxll_apply_simple(hm, namespace, mesh, psib, hpsib, terms, set_bc)
type(hamiltonian_mxll_t), intent(in) :: hm
type(namespace_t), intent(in) :: namespace
class(mesh_t), intent(in) :: mesh
@@ -722,7 +611,7 @@ contains
end subroutine hamiltonian_mxll_apply_simple
! ---------------------------------------------------------
- subroutine mxll_apply_pml_simple(hm, gradb)
+ module subroutine mxll_apply_pml_simple(hm, gradb)
type(hamiltonian_mxll_t), target, intent(in) :: hm
type(batch_t), intent(inout) :: gradb(1:hm%st%dim)
@@ -779,7 +668,7 @@ contains
end subroutine mxll_apply_pml_simple
! ---------------------------------------------------------
- subroutine mxll_update_pml_simple(hm, rs_stateb)
+ module subroutine mxll_update_pml_simple(hm, rs_stateb)
type(hamiltonian_mxll_t),intent(inout) :: hm
type(batch_t), intent(inout) :: rs_stateb
@@ -838,7 +727,7 @@ contains
end subroutine mxll_update_pml_simple
! ---------------------------------------------------------
- subroutine mxll_copy_pml_simple(hm, rs_stateb)
+ module subroutine mxll_copy_pml_simple(hm, rs_stateb)
type(hamiltonian_mxll_t),intent(inout) :: hm
type(batch_t), intent(inout) :: rs_stateb
@@ -875,7 +764,7 @@ contains
end subroutine mxll_copy_pml_simple
! ---------------------------------------------------------
- subroutine mxll_linear_medium_terms_simple(hm, rs_stateb)
+ module subroutine mxll_linear_medium_terms_simple(hm, rs_stateb)
type(hamiltonian_mxll_t),intent(in) :: hm
type(batch_t), intent(inout) :: rs_stateb
@@ -942,7 +831,7 @@ contains
! --------------------------------------------------------
!> Apply hamiltonian to real states (not possible)
- subroutine dhamiltonian_mxll_apply(hm, namespace, mesh, psib, hpsib, terms, set_bc)
+ module subroutine dhamiltonian_mxll_apply(hm, namespace, mesh, psib, hpsib, terms, set_bc)
class(hamiltonian_mxll_t), intent(in) :: hm
type(namespace_t), intent(in) :: namespace
class(mesh_t), intent(in) :: mesh
@@ -958,7 +847,7 @@ contains
! ---------------------------------------------------------
!> Applying the Maxwell Hamiltonian on Maxwell states
- subroutine zhamiltonian_mxll_apply(hm, namespace, mesh, psib, hpsib, terms, set_bc)
+ module subroutine zhamiltonian_mxll_apply(hm, namespace, mesh, psib, hpsib, terms, set_bc)
class(hamiltonian_mxll_t), intent(in) :: hm
type(namespace_t), intent(in) :: namespace
class(mesh_t), intent(in) :: mesh
@@ -1004,7 +893,7 @@ contains
! ---------------------------------------------------------
!> Applying the Maxwell Hamiltonian on Maxwell states with finite difference
- subroutine maxwell_hamiltonian_apply_fd(hm, der, psi, oppsi)
+ module subroutine maxwell_hamiltonian_apply_fd(hm, der, psi, oppsi)
type(hamiltonian_mxll_t), intent(in) :: hm
type(derivatives_t), intent(in) :: der
complex(real64), intent(inout) :: psi(:,:)
@@ -1152,7 +1041,7 @@ contains
! ---------------------------------------------------------
!> Maxwell Hamiltonian is updated for the PML calculation
- subroutine maxwell_pml_hamiltonian(hm, der, psi, dir1, dir2, tmp)
+ module subroutine maxwell_pml_hamiltonian(hm, der, psi, dir1, dir2, tmp)
type(hamiltonian_mxll_t), intent(in) :: hm
type(derivatives_t), intent(in) :: der
complex(real64), intent(inout) :: psi(:,:)
@@ -1176,7 +1065,7 @@ contains
! ---------------------------------------------------------
!> Maxwell Hamiltonian is updated for the PML calculation
- subroutine maxwell_pml_hamiltonian_medium(hm, der, psi, dir1, dir2, tmp)
+ module subroutine maxwell_pml_hamiltonian_medium(hm, der, psi, dir1, dir2, tmp)
type(hamiltonian_mxll_t), intent(in) :: hm
type(derivatives_t), intent(in) :: der
complex(real64), intent(inout) :: psi(:,:)
@@ -1200,7 +1089,7 @@ contains
! ---------------------------------------------------------
!> Maxwell Hamiltonian is updated for the PML calculation via Riemann-Silberstein vector
- subroutine maxwell_pml_calculation_via_riemann_silberstein(hm, der, psi, pml_dir, field_dir, pml)
+ module subroutine maxwell_pml_calculation_via_riemann_silberstein(hm, der, psi, pml_dir, field_dir, pml)
type(hamiltonian_mxll_t), intent(in) :: hm
type(derivatives_t), intent(in) :: der
integer, intent(in) :: pml_dir
@@ -1245,7 +1134,7 @@ contains
! ---------------------------------------------------------
!> Maxwell Hamiltonian is updated for the PML calculation via Riemann-Silberstein
!> vector with medium inside the box
- subroutine maxwell_pml_calculation_via_riemann_silberstein_medium(hm, der, psi, pml_dir, field_dir, pml)
+ module subroutine maxwell_pml_calculation_via_riemann_silberstein_medium(hm, der, psi, pml_dir, field_dir, pml)
type(hamiltonian_mxll_t), intent(in) :: hm
type(derivatives_t), intent(in) :: der
integer, intent(in) :: pml_dir
@@ -1296,7 +1185,7 @@ contains
! ---------------------------------------------------------
!> Maxwell Hamiltonian for medium boundaries
- subroutine maxwell_medium_boundaries_calculation(hm, psi, oppsi)
+ module subroutine maxwell_medium_boundaries_calculation(hm, psi, oppsi)
type(hamiltonian_mxll_t), intent(in) :: hm
complex(real64), intent(in) :: psi(:,:)
complex(real64), intent(inout) :: oppsi(:,:)
@@ -1358,7 +1247,7 @@ contains
! ---------------------------------------------------------
! > Maxwell Hamiltonian including medium boxes
- subroutine maxwell_medium_boxes_calculation(hm, der, psi, oppsi)
+ module subroutine maxwell_medium_boxes_calculation(hm, der, psi, oppsi)
type(hamiltonian_mxll_t), intent(in) :: hm
type(derivatives_t), intent(in) :: der
complex(real64), intent(in) :: psi(:,:)
@@ -1421,7 +1310,7 @@ contains
! ---------------------------------------------------------
!> Maxwell hamiltonian Magnus (not implemented)
- subroutine dhamiltonian_mxll_magnus_apply(hm, namespace, mesh, psib, hpsib, vmagnus)
+ module subroutine dhamiltonian_mxll_magnus_apply(hm, namespace, mesh, psib, hpsib, vmagnus)
class(hamiltonian_mxll_t), intent(in) :: hm
type(namespace_t), intent(in) :: namespace
class(mesh_t), intent(in) :: mesh
@@ -1435,7 +1324,7 @@ contains
! ---------------------------------------------------------
!> Maxwell hamiltonian Magnus (not implemented)
- subroutine zhamiltonian_mxll_magnus_apply(hm, namespace, mesh, psib, hpsib, vmagnus)
+ module subroutine zhamiltonian_mxll_magnus_apply(hm, namespace, mesh, psib, hpsib, vmagnus)
class(hamiltonian_mxll_t), intent(in) :: hm
type(namespace_t), intent(in) :: namespace
class(mesh_t), intent(in) :: mesh
@@ -1447,7 +1336,7 @@ contains
end subroutine zhamiltonian_mxll_magnus_apply
-end module hamiltonian_mxll_oct_m
+end submodule impl
!! Local Variables:
!! mode: f90
diff --git a/src/maxwell/hamiltonian_mxll_h.F90 b/src/maxwell/hamiltonian_mxll_h.F90
new file mode 100644
index 0000000000000000000000000000000000000000..387c94ece02c3d2a8e60f48afcf197f31a48f06c
--- /dev/null
+++ b/src/maxwell/hamiltonian_mxll_h.F90
@@ -0,0 +1,306 @@
+module hamiltonian_mxll_oct_m
+ use batch_oct_m
+ use cube_oct_m
+ use derivatives_oct_m
+ use energy_mxll_oct_m
+ use global_oct_m
+ use grid_oct_m
+ use hamiltonian_abst_oct_m
+ use linear_medium_to_em_field_oct_m
+ use maxwell_boundary_op_oct_m
+ use mesh_cube_parallel_map_oct_m
+ use mesh_oct_m
+ use namespace_oct_m
+ use nl_operator_oct_m
+ use states_mxll_oct_m
+
+ implicit none
+
+ private
+ public :: &
+ hamiltonian_mxll_t, &
+ hamiltonian_mxll_init, &
+ hamiltonian_mxll_end, &
+ dhamiltonian_mxll_apply, &
+ zhamiltonian_mxll_apply, &
+ dhamiltonian_mxll_magnus_apply, &
+ zhamiltonian_mxll_magnus_apply, &
+ hamiltonian_mxll_apply_batch, &
+ hamiltonian_mxll_span, &
+ hamiltonian_mxll_adjoint, &
+ hamiltonian_mxll_not_adjoint, &
+ hamiltonian_mxll_hermitian, &
+ hamiltonian_mxll_update, &
+ hamiltonian_mxll_get_time, &
+ hamiltonian_mxll_apply_packed, &
+ hamiltonian_mxll_apply_simple, &
+ mxll_update_pml_simple, &
+ mxll_copy_pml_simple
+
+ type, extends(hamiltonian_abst_t) :: hamiltonian_mxll_t
+ integer :: dim
+ !> absorbing boundaries
+ logical :: adjoint = .false.
+
+ real(real64) :: current_time
+ logical :: apply_packed !< This is initialized by the StatesPack variable.
+
+ logical :: time_zero
+
+ type(nl_operator_t), pointer :: operators(:)
+
+ type(bc_mxll_t) :: bc
+ type(derivatives_t), pointer, private :: der !< pointer to derivatives
+ type(states_mxll_t), pointer :: st
+
+ integer :: rs_sign
+
+ logical :: propagation_apply = .false.
+
+ integer, pointer :: rs_state_fft_map(:,:,:)
+ integer, pointer :: rs_state_fft_map_inv(:,:)
+
+ logical :: mx_ma_coupling = .false.
+ logical :: mx_ma_coupling_apply = .false.
+ integer :: mx_ma_trans_field_calc_method
+ logical :: mx_ma_trans_field_calc_corr = .false.
+ integer :: mx_ma_coupling_points_number
+ real(real64), allocatable :: mx_ma_coupling_points(:,:)
+ integer, allocatable :: mx_ma_coupling_points_map(:)
+ integer :: mx_ma_coupling_order
+ logical :: ma_mx_coupling = .false.
+ logical :: ma_mx_coupling_apply = .false.
+
+ logical :: bc_add_ab_region = .false.
+ logical :: bc_zero = .false.
+ logical :: bc_constant = .false.
+ logical :: bc_mirror_pec = .false.
+ logical :: bc_mirror_pmc = .false.
+ logical :: bc_periodic = .false.
+ logical :: bc_plane_waves = .false.
+ logical :: bc_medium = .false.
+
+ logical :: plane_waves = .false.
+ logical :: plane_waves_apply = .false.
+ logical :: spatial_constant = .false.
+ logical :: spatial_constant_apply = .false.
+ logical :: spatial_constant_propagate = .false.
+
+ logical :: calc_medium_box = .false.
+ type(single_medium_box_t), allocatable :: medium_boxes(:)
+ logical :: medium_boxes_initialized = .false.
+
+ !> maxwell hamiltonian_mxll
+ integer :: operator
+ logical :: current_density_ext_flag = .false.
+ logical :: current_density_from_medium = .false.
+
+ type(energy_mxll_t) :: energy
+
+ logical :: cpml_hamiltonian = .false.
+
+ logical :: diamag_current = .false.
+ real(real64) :: c_factor
+ real(real64) :: current_factor
+
+ type(cube_t) :: cube
+ type(mesh_cube_parallel_map_t) :: mesh_cube_map
+
+ contains
+ procedure :: update_span => hamiltonian_mxll_span
+ procedure :: dapply_impl => dhamiltonian_mxll_apply
+ procedure :: zapply_impl => zhamiltonian_mxll_apply
+ procedure :: dmagnus_apply_impl => dhamiltonian_mxll_magnus_apply
+ procedure :: zmagnus_apply_impl => zhamiltonian_mxll_magnus_apply
+ procedure :: is_hermitian => hamiltonian_mxll_hermitian
+ end type hamiltonian_mxll_t
+
+ integer, public, parameter :: &
+ FARADAY_AMPERE = 1, &
+ FARADAY_AMPERE_MEDIUM = 2, &
+ MXLL_SIMPLE = 3
+
+ interface
+ module subroutine hamiltonian_mxll_init(hm, namespace, gr, st)
+ type(hamiltonian_mxll_t), intent(inout) :: hm
+ type(namespace_t), intent(in) :: namespace
+ type(grid_t), target, intent(inout) :: gr
+ type(states_mxll_t), target, intent(inout) :: st
+ end subroutine hamiltonian_mxll_init
+
+ module subroutine hamiltonian_mxll_end(hm)
+ type(hamiltonian_mxll_t), intent(inout) :: hm
+ end subroutine hamiltonian_mxll_end
+
+ module function hamiltonian_mxll_hermitian(hm) result(res)
+ class(hamiltonian_mxll_t), intent(in) :: hm
+ logical :: res
+ end function hamiltonian_mxll_hermitian
+
+ module subroutine hamiltonian_mxll_span(hm, delta, emin, namespace)
+ class(hamiltonian_mxll_t), intent(inout) :: hm
+ real(real64), intent(in) :: delta(:)
+ real(real64), intent(in) :: emin
+ type(namespace_t), intent(in) :: namespace
+ end subroutine hamiltonian_mxll_span
+
+ module subroutine hamiltonian_mxll_adjoint(hm)
+ type(hamiltonian_mxll_t), intent(inout) :: hm
+ end subroutine hamiltonian_mxll_adjoint
+
+ module subroutine hamiltonian_mxll_not_adjoint(hm)
+ type(hamiltonian_mxll_t), intent(inout) :: hm
+ end subroutine hamiltonian_mxll_not_adjoint
+
+ module subroutine hamiltonian_mxll_update(this, time)
+ type(hamiltonian_mxll_t), intent(inout) :: this
+ real(real64), optional, intent(in) :: time
+ end subroutine hamiltonian_mxll_update
+
+ module function hamiltonian_mxll_get_time(this) result(time)
+ type(hamiltonian_mxll_t), intent(inout) :: this
+ real(real64) :: time
+ end function hamiltonian_mxll_get_time
+
+ pure module function hamiltonian_mxll_apply_packed(this, mesh) result(apply)
+ type(hamiltonian_mxll_t), intent(in) :: this
+ class(mesh_t), intent(in) :: mesh
+ logical :: apply
+ end function hamiltonian_mxll_apply_packed
+
+ module subroutine hamiltonian_mxll_apply_batch(hm, namespace, der, psib, hpsib, time, terms, set_bc)
+ type(hamiltonian_mxll_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ type(derivatives_t), intent(in) :: der
+ type(batch_t), target, intent(inout) :: psib
+ type(batch_t), target, intent(inout) :: hpsib
+ real(real64), optional, intent(in) :: time
+ integer, optional, intent(in) :: terms
+ logical, optional, intent(in) :: set_bc
+ end subroutine hamiltonian_mxll_apply_batch
+
+ module subroutine hamiltonian_mxll_apply_simple(hm, namespace, mesh, psib, hpsib, terms, set_bc)
+ type(hamiltonian_mxll_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ type(batch_t), target, intent(inout) :: psib
+ type(batch_t), target, intent(inout) :: hpsib
+ integer, optional, intent(in) :: terms
+ logical, optional, intent(in) :: set_bc
+ end subroutine hamiltonian_mxll_apply_simple
+
+ module subroutine mxll_apply_pml_simple(hm, gradb)
+ type(hamiltonian_mxll_t), target, intent(in) :: hm
+ type(batch_t), intent(inout) :: gradb(1:hm%st%dim)
+ end subroutine mxll_apply_pml_simple
+
+ module subroutine mxll_copy_pml_simple(hm, rs_stateb)
+ type(hamiltonian_mxll_t),intent(inout) :: hm
+ type(batch_t), intent(inout) :: rs_stateb
+ end subroutine mxll_copy_pml_simple
+
+ module subroutine mxll_update_pml_simple(hm, rs_stateb)
+ type(hamiltonian_mxll_t),intent(inout) :: hm
+ type(batch_t), intent(inout) :: rs_stateb
+ end subroutine mxll_update_pml_simple
+
+ module subroutine mxll_linear_medium_terms_simple(hm, rs_stateb)
+ type(hamiltonian_mxll_t),intent(in) :: hm
+ type(batch_t), intent(inout) :: rs_stateb
+ end subroutine mxll_linear_medium_terms_simple
+
+ module subroutine dhamiltonian_mxll_apply(hm, namespace, mesh, psib, hpsib, terms, set_bc)
+ class(hamiltonian_mxll_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), target, intent(inout) :: psib
+ class(batch_t), target, intent(inout) :: hpsib
+ integer, optional, intent(in) :: terms
+ logical, optional, intent(in) :: set_bc
+ end subroutine dhamiltonian_mxll_apply
+
+ module subroutine zhamiltonian_mxll_apply(hm, namespace, mesh, psib, hpsib, terms, set_bc)
+ class(hamiltonian_mxll_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), target, intent(inout) :: psib
+ class(batch_t), target, intent(inout) :: hpsib
+ integer, optional, intent(in) :: terms
+ logical, optional, intent(in) :: set_bc
+ end subroutine zhamiltonian_mxll_apply
+
+ module subroutine maxwell_hamiltonian_apply_fd(hm, der, psi, oppsi)
+ type(hamiltonian_mxll_t), intent(in) :: hm
+ type(derivatives_t), intent(in) :: der
+ complex(real64), intent(inout) :: psi(:,:)
+ complex(real64), intent(inout) :: oppsi(:,:)
+ end subroutine maxwell_hamiltonian_apply_fd
+
+ module subroutine maxwell_pml_hamiltonian(hm, der, psi, dir1, dir2, tmp)
+ type(hamiltonian_mxll_t), intent(in) :: hm
+ type(derivatives_t), intent(in) :: der
+ complex(real64), intent(inout) :: psi(:,:)
+ integer, intent(in) :: dir1
+ integer, intent(in) :: dir2
+ complex(real64), intent(inout) :: tmp(:)
+ end subroutine maxwell_pml_hamiltonian
+
+ module subroutine maxwell_pml_hamiltonian_medium(hm, der, psi, dir1, dir2, tmp)
+ type(hamiltonian_mxll_t), intent(in) :: hm
+ type(derivatives_t), intent(in) :: der
+ complex(real64), intent(inout) :: psi(:,:)
+ integer, intent(in) :: dir1
+ integer, intent(in) :: dir2
+ complex(real64), intent(inout) :: tmp(:,:)
+ end subroutine maxwell_pml_hamiltonian_medium
+
+ module subroutine maxwell_pml_calculation_via_riemann_silberstein(hm, der, psi, pml_dir, field_dir, pml)
+ type(hamiltonian_mxll_t), intent(in) :: hm
+ type(derivatives_t), intent(in) :: der
+ integer, intent(in) :: pml_dir
+ complex(real64), intent(inout) :: psi(:,:)
+ integer, intent(in) :: field_dir
+ complex(real64), intent(inout) :: pml(:)
+ end subroutine maxwell_pml_calculation_via_riemann_silberstein
+
+ module subroutine maxwell_pml_calculation_via_riemann_silberstein_medium(hm, der, psi, pml_dir, field_dir, pml)
+ type(hamiltonian_mxll_t), intent(in) :: hm
+ type(derivatives_t), intent(in) :: der
+ integer, intent(in) :: pml_dir
+ complex(real64), intent(inout) :: psi(:,:)
+ integer, intent(in) :: field_dir
+ complex(real64), intent(inout) :: pml(:,:)
+ end subroutine maxwell_pml_calculation_via_riemann_silberstein_medium
+
+ module subroutine maxwell_medium_boundaries_calculation(hm, psi, oppsi)
+ type(hamiltonian_mxll_t), intent(in) :: hm
+ complex(real64), intent(in) :: psi(:,:)
+ complex(real64), intent(inout) :: oppsi(:,:)
+ end subroutine maxwell_medium_boundaries_calculation
+
+ module subroutine maxwell_medium_boxes_calculation(hm, der, psi, oppsi)
+ type(hamiltonian_mxll_t), intent(in) :: hm
+ type(derivatives_t), intent(in) :: der
+ complex(real64), intent(in) :: psi(:,:)
+ complex(real64), intent(inout) :: oppsi(:,:)
+ end subroutine maxwell_medium_boxes_calculation
+
+ module subroutine dhamiltonian_mxll_magnus_apply(hm, namespace, mesh, psib, hpsib, vmagnus)
+ class(hamiltonian_mxll_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), intent(inout) :: psib
+ class(batch_t), intent(inout) :: hpsib
+ real(real64), intent(in) :: vmagnus(:, :, :)
+ end subroutine dhamiltonian_mxll_magnus_apply
+
+ module subroutine zhamiltonian_mxll_magnus_apply(hm, namespace, mesh, psib, hpsib, vmagnus)
+ class(hamiltonian_mxll_t), intent(in) :: hm
+ type(namespace_t), intent(in) :: namespace
+ class(mesh_t), intent(in) :: mesh
+ class(batch_t), intent(inout) :: psib
+ class(batch_t), intent(inout) :: hpsib
+ real(real64), intent(in) :: vmagnus(:, :, :)
+ end subroutine zhamiltonian_mxll_magnus_apply
+ end interface
+end module hamiltonian_mxll_oct_m
diff --git a/src/maxwell/linear_medium.F90 b/src/maxwell/linear_medium.F90
index 50dddef5d2ac6be419b7bbd7f4272b8ee58b0966..d59bd2c2fc95094235f95e7fdbf174faa8203992 100644
--- a/src/maxwell/linear_medium.F90
+++ b/src/maxwell/linear_medium.F90
@@ -440,7 +440,7 @@ contains
PUSH_SUB(linear_medium_finalize)
call single_medium_box_end(this%medium_box)
- call system_end(this)
+ call this%system_end()
call multicomm_end(this%mc)
call grid_end(this%gr)
diff --git a/src/maxwell/maxwell.F90 b/src/maxwell/maxwell.F90
index 6fe73c62416fe0cb68631fd029c794b48d46ee85..6250d0d742b14b6666f85ddd06187d315f91be76 100644
--- a/src/maxwell/maxwell.F90
+++ b/src/maxwell/maxwell.F90
@@ -1183,7 +1183,7 @@ contains
call profiling_in("MAXWELL_FINALIZE")
- call system_end(this)
+ call this%system_end()
! free memory
SAFE_DEALLOCATE_A(this%rs_state_init)
diff --git a/src/multisystem/CMakeLists.txt b/src/multisystem/CMakeLists.txt
index 51bc99876c3c4ac2002168b06c21330b4df1d421..9442a2f4dbc31e86aa3cbd76b06142d8d0008a63 100644
--- a/src/multisystem/CMakeLists.txt
+++ b/src/multisystem/CMakeLists.txt
@@ -27,5 +27,8 @@ target_sources(Octopus_lib PRIVATE
propagator_verlet.F90
quantity.F90
system.F90
+ system_extension.F90
+ system_extension_h.F90
system_factory_abst.F90
+ system_h.F90
)
diff --git a/src/multisystem/multisystem.F90 b/src/multisystem/multisystem.F90
index 2081322c1ae2c5fbf5a19f984ba653517832b2e2..02b31f1a7753785ac52aebeea5270cc63440b984 100644
--- a/src/multisystem/multisystem.F90
+++ b/src/multisystem/multisystem.F90
@@ -857,7 +857,7 @@ contains
end if
end do
- call system_end(this)
+ call this%system_end()
POP_SUB(multisystem_end)
end subroutine multisystem_end
diff --git a/src/multisystem/propagator_factory.F90 b/src/multisystem/propagator_factory.F90
index 264dca5b5da5b1e5c0cf45dea9619923ec5cdcfb..25a1c6b090398efa0c5c62882b0014c30cc61f08 100644
--- a/src/multisystem/propagator_factory.F90
+++ b/src/multisystem/propagator_factory.F90
@@ -104,7 +104,10 @@ contains
! This variable is also defined (and properly documented) in td/td.F90.
! This is temporary, until all the propagators are moved to the new framework.
call parse_variable(namespace, 'TDPropagationTime', -1.0_real64, factory%final_time, unit = units_inp%time)
- if (factory%final_time <= M_ZERO) then
+
+ ! The check of namespace%len() is to allow legacy electron system to run
+ ! TODO: properly check TDMaxSteps and dt
+ if (factory%final_time <= M_ZERO .and. namespace%len() > 0) then
call messages_input_error(namespace, 'TDPropagationTime', 'must be greater than zero')
end if
call messages_print_var_value('TDPropagationTime', factory%final_time)
diff --git a/src/multisystem/system.F90 b/src/multisystem/system.F90
index 7cd8c44b7da7f511c729981770b398acc3d20e10..3db0df12f609b8885772d65ed28dba7df5e18d06 100644
--- a/src/multisystem/system.F90
+++ b/src/multisystem/system.F90
@@ -20,205 +20,22 @@
#include "global.h"
-!> This module implements the abstract system type.
-!!
-module system_oct_m
- use algorithm_oct_m
- use algorithm_factory_oct_m
+submodule (system_oct_m) impl
+ use system_oct_m
use debug_oct_m
use ghost_interaction_oct_m
use global_oct_m
- use interactions_factory_abst_oct_m
- use interaction_partner_oct_m
- use interaction_oct_m
- use iteration_counter_oct_m
use messages_oct_m
- use mpi_oct_m
use namespace_oct_m
use multisystem_debug_oct_m
- use linked_list_oct_m
use parser_oct_m
use profiling_oct_m
use quantity_oct_m
+ use system_extension_oct_m
use unit_oct_m
use unit_system_oct_m
use varinfo_oct_m
implicit none
-
- private
- public :: &
- system_t, &
- system_execute_algorithm, &
- system_init_parallelization, &
- system_init_algorithm, &
- system_init_iteration_counters, &
- system_reset_iteration_counters, &
- system_create_interactions, &
- system_propagation_start, &
- system_propagation_finish, &
- system_restart_read, &
- system_restart_write, &
- system_update_potential_energy, &
- system_update_total_energy, &
- system_end, &
- system_list_t, &
- system_iterator_t
-
- type :: barrier_t
- logical :: active
- real(real64) :: target_time
- end type barrier_t
-
- integer, parameter, public :: &
- NUMBER_BARRIERS = 1, &
- BARRIER_RESTART = 1
-
- !> @brief Abstract class for systems
- !!
- !! All explicit systems are derived from this class.
- type, extends(interaction_partner_t), abstract :: system_t
- private
- type(iteration_counter_t), public :: iteration
- class(algorithm_t), pointer, public :: algo => null()
-
- integer, allocatable, public :: supported_interactions(:)
- type(interaction_list_t), public :: interactions !< List with all the interactions of this system
-
- type(mpi_grp_t), public :: grp !< mpi group for this system
-
- type(barrier_t) :: barrier(NUMBER_BARRIERS)
- real(real64), public :: kinetic_energy !< Energy not from interactions, like the kinetic energy
- real(real64), public :: potential_energy !< Energy from the interactions with external systems
- real(real64), public :: internal_energy !< Energy from the interactions with itself and for containers the kinetic energy of its constituents
- real(real64), public :: total_energy !< Sum of internal, external, and self energy
-
- contains
- procedure :: execute_algorithm => system_execute_algorithm !< @copydoc system_oct_m::system_execute_algorithm
- procedure :: reset_iteration_counters => system_reset_iteration_counters !< @copydoc system_oct_m::system_reset_iteration_counters
- procedure :: init_algorithm => system_init_algorithm !< @copydoc system_oct_m::system_init_algorithm
- procedure :: algorithm_finished => system_algorithm_finished !< @copydoc system_oct_m::system_algorithm_finished
- procedure :: init_iteration_counters => system_init_iteration_counters !< @copydoc system_oct_m::system_init_iteration_counters
- procedure :: create_interactions => system_create_interactions !< @copydoc system_oct_m::system_create_interactions
- procedure :: init_parallelization => system_init_parallelization !< @copydoc system_oct_m::system_init_parallelization
- procedure :: update_couplings => system_update_couplings !< @copydoc system_oct_m::system_update_couplings
- procedure :: update_interactions => system_update_interactions !< @copydoc system_oct_m::system_update_interactions
- procedure :: update_interactions_start => system_update_interactions_start !< @copydoc system_oct_m::system_update_interactions_start
- procedure :: update_interactions_finish => system_update_interactions_finish !< @copydoc system_oct_m::system_update_interactions_finish
- procedure :: propagation_start => system_propagation_start !< @copydoc system_oct_m::system_propagation_start
- procedure :: propagation_finish => system_propagation_finish !< @copydoc system_oct_m::system_propagation_finish
- procedure :: iteration_info => system_iteration_info !< @copydoc system_oct_m::system_iteration_info
- procedure :: restart_write => system_restart_write !< @copydoc system_oct_m::system_restart_write
- procedure :: restart_read => system_restart_read !< @copydoc system_oct_m::system_restart_read
- procedure :: output_start => system_output_start !< @copydoc system_oct_m::system_output_start
- procedure :: output_write => system_output_write !< @copydoc system_oct_m::system_output_write
- procedure :: output_finish => system_output_finish !< @copydoc system_oct_m::system_output_finish
- procedure :: process_is_slave => system_process_is_slave !< @copydoc system_oct_m::system_process_is_slave
- procedure :: start_barrier => system_start_barrier !< @copydoc system_oct_m::system_start_barrier
- procedure :: end_barrier => system_end_barrier !< @copydoc system_oct_m::system_end_barrier
- procedure :: arrived_at_barrier => system_arrived_at_barrier !< @copydoc system_oct_m::system_arrived_at_barrier
- procedure :: arrived_at_any_barrier => system_arrived_at_any_barrier !< @copydoc system_oct_m::system_arrived_at_any_barrier
- procedure :: update_potential_energy => system_update_potential_energy !< @copydoc system_oct_m::system_update_potential_energy
- procedure :: update_internal_energy => system_update_internal_energy !< @copydoc system_oct_m::system_update_internal_energy
- procedure :: update_total_energy => system_update_total_energy !< @copydoc system_oct_m::system_update_total_energy
- procedure(system_init_interaction), deferred :: init_interaction !< @copydoc system_oct_m::system_init_interaction
- procedure(system_initial_conditions), deferred :: initial_conditions !< @copydoc system_oct_m::system_initial_conditions
- procedure(system_do_algorithmic_operation), deferred :: do_algorithmic_operation !< @copydoc system_oct_m::system_do_algorithmic_operation
- procedure(system_is_tolerance_reached), deferred :: is_tolerance_reached !< @copydoc system_oct_m::system_is_tolerance_reached
- procedure(system_restart_write_data), deferred :: restart_write_data !< @copydoc system_oct_m::system_restart_write_data
- procedure(system_restart_read_data), deferred :: restart_read_data !< @copydoc system_oct_m::system_restart_read_data
- procedure(system_update_kinetic_energy), deferred :: update_kinetic_energy !< @copydoc system_oct_m::system_update_kinetic_energy
- end type system_t
-
- abstract interface
-
- ! ---------------------------------------------------------
- !> @brief initialize a given interaction of the system
- subroutine system_init_interaction(this, interaction)
- import system_t
- import interaction_t
- class(system_t), target, intent(inout) :: this
- class(interaction_t), intent(inout) :: interaction
- end subroutine system_init_interaction
-
- ! ---------------------------------------------------------
- !> set initial conditions for a system
- subroutine system_initial_conditions(this)
- import system_t
- class(system_t), intent(inout) :: this
- end subroutine system_initial_conditions
-
- ! ---------------------------------------------------------
- !> @brief Execute one operation that is part of a larger algorithm. Returns true
- !! if the operation was successfully executed, false otherwise.
- !!
- !! Unsuccessful operations can occur, e.g. of quantities from an interaction
- !! are required, but the interaction is still behind in terms of the iteration counters.
- !!
- !! On output, the routine should also provide a list quantities that were
- !! updated. If no quantitiy was updated, then the corresponding array should
- !! be left unallocated.
- logical function system_do_algorithmic_operation(this, operation, updated_quantities) result(done)
- import system_t
- import algorithmic_operation_t
- class(system_t), intent(inout) :: this
- class(algorithmic_operation_t), intent(in) :: operation
- integer, allocatable, intent(out) :: updated_quantities(:)
- end function system_do_algorithmic_operation
-
- ! ---------------------------------------------------------
- !> @brief check whether a system has reached a given tolerance
- logical function system_is_tolerance_reached(this, tol)
- use, intrinsic :: iso_fortran_env
- import system_t
- class(system_t), intent(in) :: this
- real(real64), intent(in) :: tol
- end function system_is_tolerance_reached
-
- ! ---------------------------------------------------------
- !> @brief For some algorithms it might be necessary to store the status of a system at a given algorithmic step
- !!
- !! This should be implemented by each system in this routine.
- subroutine system_store_current_status(this)
- import system_t
- class(system_t), intent(inout) :: this
- end subroutine system_store_current_status
-
- ! ---------------------------------------------------------
- subroutine system_restart_write_data(this)
- import system_t
- class(system_t), intent(inout) :: this
- end subroutine system_restart_write_data
-
- ! ---------------------------------------------------------
- ! this function returns true if restart data could be read
- logical function system_restart_read_data(this)
- import system_t
- class(system_t), intent(inout) :: this
- end function system_restart_read_data
- subroutine system_update_kinetic_energy(this)
- import system_t
- class(system_t), intent(inout) :: this
- end subroutine system_update_kinetic_energy
-
- end interface
-
- !> @brief These classes extends the list and list iterator to create a system list.
- !!
- !! Since a list of systems is also a list of interaction partners, the system
- !! list is an extension of the partner list.
- type, extends(partner_list_t) :: system_list_t
- private
- contains
- procedure :: add => system_list_add_node !< @copydoc system_oct_m::system_list_add_node
- procedure :: contains => system_list_contains !< @copydoc system_oct_m::system_list_contains
- end type system_list_t
-
- type, extends(linked_list_iterator_t) :: system_iterator_t
- private
- contains
- procedure :: get_next => system_iterator_get_next !< @copydoc system_oct_m::system_iterator_get_next
- end type system_iterator_t
-
contains
! ---------------------------------------------------------
@@ -234,7 +51,7 @@ contains
!! The couplings update is always considered a barrier, even if the update was
!! successful. This is to allow other system to also update their couplings
!! with this system before it moves on to the next operations.
- subroutine system_execute_algorithm(this)
+ module subroutine system_execute_algorithm(this)
class(system_t), intent(inout) :: this
type(algorithmic_operation_t) :: operation
@@ -243,12 +60,27 @@ contains
integer :: iq, iuq
integer, allocatable :: updated_quantities(:)
+ type(extension_iterator_t) :: extension_iter
+ class(extension_t), pointer :: extension
+
PUSH_SUB(system_execute_algorithm)
at_barrier = .false.
do while (.not. at_barrier)
+ ! Run any pre extension hooks
+ call extension_iter%start(this%extensions)
+ do while (extension_iter%has_next())
+ extension => extension_iter%get_next()
+ select type (extension)
+ class is (system_extension_t)
+ call extension%pre_dt_operation()
+ class default
+ ASSERT(.false.)
+ end select
+ end do
+
operation = this%algo%get_current_operation()
debug_handle = multisystem_debug_write_event_in(this%namespace, event_function_call_t("dt_operation", operation), &
@@ -345,6 +177,18 @@ contains
end select
end if
+ ! Run any post extension hooks
+ call extension_iter%start(this%extensions, reverse=.true.)
+ do while (extension_iter%has_next())
+ extension => extension_iter%get_next(reverse=.true.)
+ select type (extension)
+ class is (system_extension_t)
+ call extension%post_dt_operation()
+ class default
+ ASSERT(.false.)
+ end select
+ end do
+
call multisystem_debug_write_event_out(debug_handle, system_iteration=this%iteration, algo_iteration=this%algo%iteration)
end do
@@ -352,7 +196,7 @@ contains
end subroutine system_execute_algorithm
! ---------------------------------------------------------
- subroutine system_reset_iteration_counters(this, accumulated_iterations)
+ module subroutine system_reset_iteration_counters(this, accumulated_iterations)
class(system_t), intent(inout) :: this
integer, intent(in) :: accumulated_iterations
@@ -405,7 +249,7 @@ contains
!! and all available partners. Any class overriding this method must make sure
!! ghost interactions are properly created or the framework might not work
!! correctly.
- recursive subroutine system_create_interactions(this, interaction_factory, available_partners)
+ recursive module subroutine system_create_interactions(this, interaction_factory, available_partners)
class(system_t), intent(inout) :: this !< system for which interactions are created.
class(interactions_factory_abst_t), intent(in) :: interaction_factory !< factory that creates the actual interactions
class(partner_list_t), target, intent(in) :: available_partners !< a list of available partners for the given system.
@@ -556,8 +400,9 @@ contains
!! This function loops over all interactions and the corresponding interaction partners
!! and attempts to update their couplings to the requested iteration. It returns true if all
!! couplings have been successfully updated.
- logical function system_update_couplings(this) result(all_updated)
+ module function system_update_couplings(this) result(all_updated)
class(system_t), intent(inout) :: this
+ logical :: all_updated
class(interaction_t), pointer :: interaction
type(interaction_iterator_t) :: iter
@@ -593,7 +438,7 @@ contains
!!
!! First we try to update the systems own quantities required for the interaction,
!! and then try to update the interaction itself.
- subroutine system_update_interactions(this)
+ module subroutine system_update_interactions(this)
class(system_t), intent(inout) :: this
integer :: iq, q_id, n_quantities
@@ -666,7 +511,7 @@ contains
end subroutine system_update_interactions
! ---------------------------------------------------------
- subroutine system_update_interactions_start(this)
+ module subroutine system_update_interactions_start(this)
class(system_t), intent(inout) :: this
PUSH_SUB(system_update_interactions_start)
@@ -678,7 +523,7 @@ contains
end subroutine system_update_interactions_start
! ---------------------------------------------------------
- subroutine system_update_interactions_finish(this)
+ module subroutine system_update_interactions_finish(this)
class(system_t), intent(inout) :: this
PUSH_SUB(system_update_interactions_finish)
@@ -690,7 +535,7 @@ contains
end subroutine system_update_interactions_finish
! ---------------------------------------------------------
- subroutine system_restart_write(this)
+ module subroutine system_restart_write(this)
class(system_t), intent(inout) :: this
logical :: restart_write
@@ -698,6 +543,9 @@ contains
class(interaction_t), pointer :: interaction
integer :: ii
+ type(extension_iterator_t) :: extension_iter
+ class(extension_t), pointer :: extension
+
PUSH_SUB(system_restart_write)
call parse_variable(this%namespace, 'RestartWrite', .true., restart_write)
@@ -722,6 +570,13 @@ contains
call this%restart_write_data()
message(1) = "Wrote restart data for system "//trim(this%namespace%get())
call messages_info(1, namespace=this%namespace)
+
+ ! Check the restart_read of the extensions
+ call extension_iter%start(this%extensions)
+ do while (extension_iter%has_next())
+ extension => extension_iter%get_next()
+ call extension%restart_write()
+ end do
end if
POP_SUB(system_restart_write)
@@ -729,30 +584,34 @@ contains
! ---------------------------------------------------------
! this function returns true if restart data could be read
- logical function system_restart_read(this)
+ module function system_restart_read(this) result(res)
class(system_t), intent(inout) :: this
+ logical :: res
type(interaction_iterator_t) :: iter
class(interaction_t), pointer :: interaction
integer :: ii
+ type(extension_iterator_t) :: extension_iter
+ class(extension_t), pointer :: extension
+
PUSH_SUB(system_restart_read)
! do some generic restart steps here
! read iteration data
- system_restart_read = this%iteration%restart_read('restart_iteration_system', this%namespace)
- system_restart_read = system_restart_read .and. &
+ res = this%iteration%restart_read('restart_iteration_system', this%namespace)
+ res = res .and. &
this%algo%iteration%restart_read('restart_iteration_propagator', this%namespace)
call iter%start(this%interactions)
do while (iter%has_next())
interaction => iter%get_next()
- system_restart_read = system_restart_read .and. interaction%restart_read(this%namespace)
+ res = res .and. interaction%restart_read(this%namespace)
! reduce by one because of the first UPDATE_INTERACTIONS
interaction%iteration = interaction%iteration - 1
end do
do ii = 1, MAX_QUANTITIES
if (this%quantities(ii)%required) then
- system_restart_read = system_restart_read .and. &
+ res = res .and. &
this%quantities(ii)%iteration%restart_read('restart_iteration_quantity_'//trim(QUANTITY_LABEL(ii)), &
this%namespace)
end if
@@ -762,9 +621,16 @@ contains
end if
end do
! the following call is delegated to the corresponding system
- system_restart_read = system_restart_read .and. this%restart_read_data()
+ res = res .and. this%restart_read_data()
- if (system_restart_read) then
+ ! Check the restart_read of the extensions
+ call extension_iter%start(this%extensions)
+ do while (extension_iter%has_next())
+ extension => extension_iter%get_next()
+ res = res .and. extension%restart_read()
+ end do
+
+ if (res) then
message(1) = "Successfully read restart data for system "//trim(this%namespace%get())
call messages_info(1, namespace=this%namespace)
end if
@@ -773,7 +639,7 @@ contains
end function system_restart_read
! ---------------------------------------------------------
- subroutine system_output_start(this)
+ module subroutine system_output_start(this)
class(system_t), intent(inout) :: this
PUSH_SUB(system_output_start)
@@ -785,19 +651,28 @@ contains
end subroutine system_output_start
! ---------------------------------------------------------
- subroutine system_output_write(this)
+ module subroutine system_output_write(this)
class(system_t), intent(inout) :: this
+ type(extension_iterator_t) :: extension_iter
+ class(extension_t), pointer :: extension
+
PUSH_SUB(system_output_write)
- ! By default nothing is done to regarding output. Child classes that wish
- ! to change this behaviour should override this method.
+ ! Call system extension's output write
+ ! Child classes that wish to change this behaviour should override this method
+ ! and call this base function
+ call extension_iter%start(this%extensions)
+ do while (extension_iter%has_next())
+ extension => extension_iter%get_next()
+ call extension%output()
+ end do
POP_SUB(system_output_write)
end subroutine system_output_write
! ---------------------------------------------------------
- subroutine system_output_finish(this)
+ module subroutine system_output_finish(this)
class(system_t), intent(inout) :: this
PUSH_SUB(system_output_finish)
@@ -809,7 +684,7 @@ contains
end subroutine system_output_finish
! ---------------------------------------------------------
- subroutine system_init_algorithm(this, factory)
+ module subroutine system_init_algorithm(this, factory)
class(system_t), intent(inout) :: this
class(algorithm_factory_t), intent(in) :: factory
@@ -817,7 +692,7 @@ contains
PUSH_SUB(system_init_algorithm)
- call messages_experimental('Multi-system framework')
+! call messages_experimental('Multi-system framework')
this%algo => factory%create(this)
@@ -832,7 +707,7 @@ contains
end subroutine system_init_algorithm
! ---------------------------------------------------------------------------------------
- recursive function system_algorithm_finished(this) result(finished)
+ recursive module function system_algorithm_finished(this) result(finished)
class(system_t), intent(in) :: this
logical :: finished
@@ -847,7 +722,7 @@ contains
!! before the algorithm iteration counter. This is necessary, as the interactions and on-demand quantities
!! first need to be updated.
!
- subroutine system_init_iteration_counters(this)
+ module subroutine system_init_iteration_counters(this)
class(system_t), intent(inout) :: this
type(interaction_iterator_t) :: iter
@@ -880,7 +755,7 @@ contains
end subroutine system_init_iteration_counters
! ---------------------------------------------------------
- subroutine system_propagation_start(this)
+ module subroutine system_propagation_start(this)
class(system_t), intent(inout) :: this
logical :: all_updated
@@ -934,7 +809,7 @@ contains
end subroutine system_propagation_start
! ---------------------------------------------------------
- subroutine system_propagation_finish(this)
+ module subroutine system_propagation_finish(this)
class(system_t), intent(inout) :: this
type(event_handle_t) :: debug_handle
@@ -967,7 +842,7 @@ contains
end subroutine system_propagation_finish
! ---------------------------------------------------------
- subroutine system_iteration_info(this)
+ module subroutine system_iteration_info(this)
class(system_t), intent(in) :: this
real(real64) :: energy
@@ -996,23 +871,26 @@ contains
end subroutine system_iteration_info
! ---------------------------------------------------------
- logical function system_process_is_slave(this)
+ module function system_process_is_slave(this) result(res)
class(system_t), intent(in) :: this
+ logical :: res
PUSH_SUB(system_process_is_slave)
! By default an MPI process is not a slave
- system_process_is_slave = .false.
+ res = .false.
POP_SUB(system_process_is_slave)
end function system_process_is_slave
! ---------------------------------------------------------
- subroutine system_end(this)
+ module subroutine system_end(this)
class(system_t), intent(inout) :: this
- type(interaction_iterator_t) :: iter
- class(interaction_t), pointer :: interaction
+ type(interaction_iterator_t) :: iter_int
+ class(interaction_t), pointer :: interaction
+ type(extension_iterator_t) :: iter_ext
+ class(extension_t), pointer :: extension
PUSH_SUB(system_end)
@@ -1021,19 +899,28 @@ contains
deallocate(this%algo)
end if
- call iter%start(this%interactions)
- do while (iter%has_next())
- interaction => iter%get_next()
+ call iter_int%start(this%interactions)
+ do while (iter_int%has_next())
+ interaction => iter_int%get_next()
if (associated(interaction)) then
deallocate(interaction)
end if
end do
+ call iter_ext%start(this%extensions)
+ do while (iter_ext%has_next())
+ extension => iter_ext%get_next()
+ if (associated(extension)) then
+ deallocate(extension)
+ end if
+ end do
+ call this%extensions%empty()
+
POP_SUB(system_end)
end subroutine system_end
! ---------------------------------------------------------
- subroutine system_list_add_node(this, partner)
+ module subroutine system_list_add_node(this, partner)
class(system_list_t) :: this
class(interaction_partner_t), target :: partner
@@ -1050,9 +937,10 @@ contains
end subroutine system_list_add_node
! ---------------------------------------------------------
- recursive logical function system_list_contains(this, partner) result(contains)
+ recursive module function system_list_contains(this, partner) result(contains)
class(system_list_t) :: this
class(interaction_partner_t), target :: partner
+ logical :: contains
type(partner_iterator_t) :: iterator
class(interaction_partner_t), pointer :: system
@@ -1078,7 +966,7 @@ contains
end function system_list_contains
! ---------------------------------------------------------
- function system_iterator_get_next(this) result(system)
+ module function system_iterator_get_next(this) result(system)
class(system_iterator_t), intent(inout) :: this
class(system_t), pointer :: system
@@ -1098,7 +986,7 @@ contains
!> Basic functionality: copy the MPI group.
!! This function needs to be implemented by extended types
!! that need more initialization for their parallelization.
- subroutine system_init_parallelization(this, grp)
+ module subroutine system_init_parallelization(this, grp)
class(system_t), intent(inout) :: this
type(mpi_grp_t), intent(in) :: grp
@@ -1113,7 +1001,7 @@ contains
! ---------------------------------------------------------
- subroutine system_start_barrier(this, target_time, barrier_index)
+ module subroutine system_start_barrier(this, target_time, barrier_index)
class(system_t), intent(inout) :: this
real(real64), intent(in) :: target_time
integer, intent(in) :: barrier_index
@@ -1127,7 +1015,7 @@ contains
end subroutine system_start_barrier
! ---------------------------------------------------------
- subroutine system_end_barrier(this, barrier_index)
+ module subroutine system_end_barrier(this, barrier_index)
class(system_t), intent(inout) :: this
integer, intent(in) :: barrier_index
@@ -1140,19 +1028,20 @@ contains
end subroutine system_end_barrier
! ---------------------------------------------------------
- logical function system_arrived_at_barrier(this, barrier_index)
+ module function system_arrived_at_barrier(this, barrier_index) result(res)
class(system_t), intent(inout) :: this
integer, intent(in) :: barrier_index
+ logical :: res
type(iteration_counter_t) :: iteration
PUSH_SUB(system_arrived_at_barrier)
- system_arrived_at_barrier = .false.
+ res = .false.
if (this%barrier(barrier_index)%active) then
iteration = this%iteration + 1
if (iteration%value() > this%barrier(barrier_index)%target_time) then
- system_arrived_at_barrier = .true.
+ res = .true.
end if
end if
@@ -1160,16 +1049,17 @@ contains
end function system_arrived_at_barrier
! ---------------------------------------------------------
- logical function system_arrived_at_any_barrier(this)
+ module function system_arrived_at_any_barrier(this) result(res)
class(system_t), intent(inout) :: this
+ logical :: res
integer :: ii
PUSH_SUB(system_arrived_at_any_barrier)
- system_arrived_at_any_barrier = .false.
+ res = .false.
do ii = 1, NUMBER_BARRIERS
- system_arrived_at_any_barrier = system_arrived_at_any_barrier &
+ res = res &
.or. this%arrived_at_barrier(ii)
end do
@@ -1182,7 +1072,7 @@ contains
!! The potential energy is defined as the sum of all energies
!! arising from interactions with external systems.
!! (Note that multisystems override this function)
- subroutine system_update_potential_energy(this)
+ module subroutine system_update_potential_energy(this)
class(system_t), intent(inout) :: this
type(interaction_iterator_t) :: iter
@@ -1209,7 +1099,7 @@ contains
!! The internal energy is defined as the sum of all energies
!! arising from intra-interactions and the entropy terms (if available).
!! (Note that multisystems override this function)
- subroutine system_update_internal_energy(this)
+ module subroutine system_update_internal_energy(this)
class(system_t), intent(inout) :: this
type(interaction_iterator_t) :: iter
@@ -1234,7 +1124,7 @@ contains
!> Calculate the total energy of the system.
!! The total energy is defined as the sum of
!! the kinetic, the internal and the potential energies.
- subroutine system_update_total_energy(this)
+ module subroutine system_update_total_energy(this)
class(system_t), intent(inout) :: this
PUSH_SUB(system_update_total_energy)
@@ -1253,7 +1143,74 @@ contains
POP_SUB(system_update_total_energy)
end subroutine system_update_total_energy
-end module system_oct_m
+ module subroutine system_init(this)
+ class(system_t), target, intent(inout) :: this
+
+ class(*), pointer :: raw_ptr
+ class(*), pointer :: ext_def
+ class(extension_t), pointer :: ext
+
+ type(block_t) :: block
+ integer :: i_ext, n_ext
+ character(256) :: ext_name
+
+ raw_ptr => this
+
+ call this%context%init()
+
+ ! Get the number of extensions requested for the system
+ n_ext = 0
+
+ !%Variable Extensions
+ !%Type block
+ !%Section System::Extensions
+ !%Description
+ !% System extensions
+ !%End
+ if (parse_block(this%namespace, 'Extensions', block) == 0) then
+ n_ext = parse_block_n(block)
+ end if
+
+ ! If there are not extensions requested, finish
+ if (n_ext == 0) then
+ return
+ end if
+
+ ! Otherwise parse the extensions block
+ do i_ext = 1, n_ext
+ call parse_block_string(block, i_ext-1, 0, ext_name)
+ call all_extension_defs%get_raw_ptr(trim(ext_name), ext_def)
+ select type (ext_def)
+ class is (extension_def_t)
+ if ( ext_def%get_unique() ) then
+ if ( this%extensions%has_ext(trim(ext_name)) ) then
+ cycle
+ end if
+ end if
+ ext => ext_def%create_extension(raw_ptr)
+ call ext%parse_block(block, i_ext)
+ class default
+ ASSERT(.false.)
+ end select
+ end do
+ call parse_block_end(block)
+ end subroutine system_init
+
+ module subroutine system_post_init(this)
+ class(system_t), intent(inout) :: this
+
+ type(extension_iterator_t) :: extension_iter
+ class(extension_t), pointer :: extension
+
+ ! Run all post initialization of the extensions
+ call extension_iter%start(this%extensions)
+ do while (extension_iter%has_next())
+ extension => extension_iter%get_next()
+ call extension%post_init()
+ end do
+ end subroutine system_post_init
+
+end submodule impl
!! Local Variables:
!! mode: f90
diff --git a/src/multisystem/system_extension.F90 b/src/multisystem/system_extension.F90
new file mode 100644
index 0000000000000000000000000000000000000000..b71585cd5d265ab65a01cdc7ad068536724c5666
--- /dev/null
+++ b/src/multisystem/system_extension.F90
@@ -0,0 +1,54 @@
+#include "global.h"
+
+submodule (system_extension_oct_m) impl
+ implicit none
+
+contains
+ module subroutine system_extension_def_init(this, name, priority, unique)
+ class(system_extension_def_t), target, intent(inout) :: this
+ character(*), intent(in) :: name
+ integer, intent(in) :: priority
+ logical, intent(in) :: unique
+
+ ! Call base constructor
+ call this%extension_def_init(name, priority, unique)
+ end subroutine system_extension_def_init
+
+ module subroutine system_extension_def_end(this)
+ class(system_extension_def_t), intent(inout) :: this
+
+ ! Call base destructor
+ call this%extension_def_end()
+ end subroutine system_extension_def_end
+
+
+ module subroutine system_extension_init(this, def, sys)
+ class(system_extension_t), target, intent(inout) :: this
+ class(system_extension_def_t), pointer, intent(in) :: def
+ class(system_t), pointer, intent(in) :: sys
+
+ class(extension_def_t), pointer :: ext_def
+
+ ! Intel compiler complains about dummy argument
+ ext_def => def
+ this%system => sys
+ ! Register self to systems's extensions list
+ call this%extension_init(ext_def, sys%extensions)
+ end subroutine system_extension_init
+
+ module subroutine system_extension_end(this)
+ type(system_extension_t), intent(inout) :: this
+
+ end subroutine system_extension_end
+
+ module subroutine system_extension_dt_operation(this)
+ class(system_extension_t), intent(inout) :: this
+ ! Do nothing
+ end subroutine system_extension_dt_operation
+ module subroutine system_extension_post_init(this)
+ class(system_extension_t), target, intent(inout) :: this
+
+ call this%extension_t%post_init()
+ end subroutine system_extension_post_init
+end submodule impl
+
diff --git a/src/multisystem/system_extension_h.F90 b/src/multisystem/system_extension_h.F90
new file mode 100644
index 0000000000000000000000000000000000000000..9d8330b4d66b9aadf848a19597af4e817390fa02
--- /dev/null
+++ b/src/multisystem/system_extension_h.F90
@@ -0,0 +1,113 @@
+module system_extension_oct_m
+ use system_oct_m
+ use linked_list_oct_m
+ use extension_oct_m
+ implicit none
+
+ private
+
+ !!! Classes
+
+ !> System extension
+ !!
+ !! Enables adding functionalities to the systems non-intrusively.
+ type, extends(extension_t), public :: system_extension_t
+ private
+ !> Reference pointer to the system where the extension is installed on
+ class(system_t), pointer, public :: system
+
+ contains
+ ! Fortran limitation: No proper move constructors
+ procedure system_extension_init
+ ! TODO: Implement and move to callers of system constructors
+ !> Post initialization. Executed just after system is initialized
+ procedure :: post_init => system_extension_post_init
+ !> Extension to system's dt_operation. Run before system's
+ procedure :: pre_dt_operation => system_extension_dt_operation
+ !> Extension to system's dt_operation. Run after system's
+ procedure :: post_dt_operation => system_extension_dt_operation
+ !> Extension destructor. Ensures the extension is de-registered
+ final :: system_extension_end
+ end type system_extension_t
+
+ !> System extension definition
+ !!
+ !! Stores metadata of system extension
+ type, extends(extension_def_t), abstract, public :: system_extension_def_t
+ private
+ contains
+ private
+ procedure, public :: system_extension_def_init
+ procedure, public :: system_extension_def_end
+ end type system_extension_def_t
+
+ !!! Getter/Setters
+
+ !!! Subroutine/Functions
+ interface
+ !> Constructor for the abstract class extension_def_t
+ !!
+ !! Fortran limitation: Cannot define abstract constructor. Have to use subroutine instead.
+ !!
+ !! IMPORTANT: The actual constructors must call this subroutine exactly ONCE
+ !!
+ !! @param this extension_def_t object
+ !! @param name Value of this%name
+ module subroutine system_extension_def_init(this, name, priority, unique)
+ class(system_extension_def_t), target, intent(inout) :: this
+ character(*), intent(in) :: name
+ integer, intent(in) :: priority
+ logical, intent(in) :: unique
+ end subroutine system_extension_def_init
+
+ !> Destructor for the abstract class system_extension_def_t
+ !!
+ !! Fortran limitation: Cannot define abstract destructor. Have to use subroutine instead.
+ !!
+ !! IMPORTANT: The actual destructors must call this subroutine exactly ONCE
+ !!
+ !! @param this extension_def_t object
+ module subroutine system_extension_def_end(this)
+ class(system_extension_def_t), intent(inout) :: this
+ end subroutine system_extension_def_end
+ !> Stub: Do nothing operator
+ !!
+ !! @param this system_extension_t object
+ module subroutine system_extension_dt_operation(this)
+ class(system_extension_t), intent(inout) :: this
+ ! Do nothing
+ end subroutine system_extension_dt_operation
+ !> System extension post initializations
+ !!
+ !! @param this system_extension_t object
+ module subroutine system_extension_post_init(this)
+ class(system_extension_t), target, intent(inout) :: this
+ end subroutine system_extension_post_init
+ !> Default base constructor for system_extension
+ !!
+ !! This constructor ensures the extension is registered in the system
+ !!
+ !! NOTE: Must only be called ONCE
+ !!
+ !! Due to fortran limitation, no value type constructors can be defined.
+ !! Must use a pointer creator interface instead.
+ !!
+ !! @param this System extension
+ !! @param system Parent system of the extension
+ module subroutine system_extension_init(this, def, sys)
+ ! Fortran limitation: No proper constructor interface
+ ! Normally this should be handled by the actual constructor, but
+ ! language lacks move constructors. This will register the extension
+ ! to the system twice for both the rvalue and lvalue items.
+ class(system_extension_t), target, intent(inout) :: this
+ class(system_extension_def_t), pointer, intent(in) :: def
+ class(system_t), pointer, intent(in) :: sys
+ end subroutine system_extension_init
+ !> System extension destructor
+ !!
+ !! @param this system_extension_t object
+ module subroutine system_extension_end(this)
+ type(system_extension_t), intent(inout) :: this
+ end subroutine system_extension_end
+ end interface
+end module system_extension_oct_m
diff --git a/src/multisystem/system_h.F90 b/src/multisystem/system_h.F90
new file mode 100644
index 0000000000000000000000000000000000000000..e3c6284e53930e85eb218a7b244e31465e07ec22
--- /dev/null
+++ b/src/multisystem/system_h.F90
@@ -0,0 +1,362 @@
+!> This module implements the abstract system type.
+!!
+module system_oct_m
+ use algorithm_factory_oct_m
+ use algorithm_oct_m
+ use dict_oct_m
+ use extension_oct_m
+ use global_oct_m
+ use interaction_oct_m
+ use interaction_partner_oct_m
+ use interactions_factory_abst_oct_m
+ use iteration_counter_oct_m
+ use linked_list_oct_m
+ use mpi_oct_m
+ implicit none
+
+ private
+ public :: &
+ system_t, &
+ system_execute_algorithm, &
+ system_init_parallelization, &
+ system_init_algorithm, &
+ system_init_iteration_counters, &
+ system_reset_iteration_counters, &
+ system_create_interactions, &
+ system_propagation_start, &
+ system_propagation_finish, &
+ system_restart_read, &
+ system_restart_write, &
+ system_update_potential_energy, &
+ system_update_total_energy, &
+ system_list_t, &
+ system_iterator_t
+
+ type :: barrier_t
+ logical :: active
+ real(real64) :: target_time
+ end type barrier_t
+
+ integer, parameter, public :: &
+ NUMBER_BARRIERS = 1, &
+ BARRIER_RESTART = 1
+
+ !> @brief Abstract class for systems
+ !!
+ !! All explicit systems are derived from this class.
+ type, extends(interaction_partner_t), abstract :: system_t
+ private
+ type(iteration_counter_t), public :: iteration
+ class(algorithm_t), pointer, public :: algo => null()
+ type(extension_list_t), public :: extensions
+ type(dict_t), public :: context
+
+ integer, allocatable, public :: supported_interactions(:)
+ type(interaction_list_t), public :: interactions !< List with all the interactions of this system
+
+ type(mpi_grp_t), public :: grp !< mpi group for this system
+
+ type(barrier_t) :: barrier(NUMBER_BARRIERS)
+ real(real64), public :: kinetic_energy !< Energy not from interactions, like the kinetic energy
+ real(real64), public :: potential_energy !< Energy from the interactions with external systems
+ real(real64), public :: internal_energy !< Energy from the interactions with itself and for containers the kinetic energy of its constituents
+ real(real64), public :: total_energy !< Sum of internal, external, and self energy
+
+ contains
+ procedure :: system_init
+ procedure :: post_init => system_post_init
+ procedure :: system_post_init
+ procedure :: system_end
+ procedure :: execute_algorithm => system_execute_algorithm !< @copydoc system_oct_m::system_execute_algorithm
+ procedure :: reset_iteration_counters => system_reset_iteration_counters !< @copydoc system_oct_m::system_reset_iteration_counters
+ procedure :: init_algorithm => system_init_algorithm !< @copydoc system_oct_m::system_init_algorithm
+ procedure :: algorithm_finished => system_algorithm_finished !< @copydoc system_oct_m::system_algorithm_finished
+ procedure :: init_iteration_counters => system_init_iteration_counters !< @copydoc system_oct_m::system_init_iteration_counters
+ procedure :: create_interactions => system_create_interactions !< @copydoc system_oct_m::system_create_interactions
+ procedure :: init_parallelization => system_init_parallelization !< @copydoc system_oct_m::system_init_parallelization
+ procedure :: update_couplings => system_update_couplings !< @copydoc system_oct_m::system_update_couplings
+ procedure :: update_interactions => system_update_interactions !< @copydoc system_oct_m::system_update_interactions
+ procedure :: update_interactions_start => system_update_interactions_start !< @copydoc system_oct_m::system_update_interactions_start
+ procedure :: update_interactions_finish => system_update_interactions_finish !< @copydoc system_oct_m::system_update_interactions_finish
+ procedure :: propagation_start => system_propagation_start !< @copydoc system_oct_m::system_propagation_start
+ procedure :: propagation_finish => system_propagation_finish !< @copydoc system_oct_m::system_propagation_finish
+ procedure :: iteration_info => system_iteration_info !< @copydoc system_oct_m::system_iteration_info
+ procedure :: restart_write => system_restart_write !< @copydoc system_oct_m::system_restart_write
+ procedure :: restart_read => system_restart_read !< @copydoc system_oct_m::system_restart_read
+ procedure :: output_start => system_output_start !< @copydoc system_oct_m::system_output_start
+ procedure :: output_write => system_output_write !< @copydoc system_oct_m::system_output_write
+ procedure :: output_finish => system_output_finish !< @copydoc system_oct_m::system_output_finish
+ procedure :: process_is_slave => system_process_is_slave !< @copydoc system_oct_m::system_process_is_slave
+ procedure :: start_barrier => system_start_barrier !< @copydoc system_oct_m::system_start_barrier
+ procedure :: end_barrier => system_end_barrier !< @copydoc system_oct_m::system_end_barrier
+ procedure :: arrived_at_barrier => system_arrived_at_barrier !< @copydoc system_oct_m::system_arrived_at_barrier
+ procedure :: arrived_at_any_barrier => system_arrived_at_any_barrier !< @copydoc system_oct_m::system_arrived_at_any_barrier
+ procedure :: update_potential_energy => system_update_potential_energy !< @copydoc system_oct_m::system_update_potential_energy
+ procedure :: update_internal_energy => system_update_internal_energy !< @copydoc system_oct_m::system_update_internal_energy
+ procedure :: update_total_energy => system_update_total_energy !< @copydoc system_oct_m::system_update_total_energy
+ procedure(system_init_interaction), deferred :: init_interaction !< @copydoc system_oct_m::system_init_interaction
+ procedure(system_initial_conditions), deferred :: initial_conditions !< @copydoc system_oct_m::system_initial_conditions
+ procedure(system_do_algorithmic_operation), deferred :: do_algorithmic_operation !< @copydoc system_oct_m::system_do_algorithmic_operation
+ procedure(system_is_tolerance_reached), deferred :: is_tolerance_reached !< @copydoc system_oct_m::system_is_tolerance_reached
+ procedure(system_restart_write_data), deferred :: restart_write_data !< @copydoc system_oct_m::system_restart_write_data
+ procedure(system_restart_read_data), deferred :: restart_read_data !< @copydoc system_oct_m::system_restart_read_data
+ procedure(system_update_kinetic_energy), deferred :: update_kinetic_energy !< @copydoc system_oct_m::system_update_kinetic_energy
+ end type system_t
+
+ abstract interface
+
+ ! ---------------------------------------------------------
+ !> @brief initialize a given interaction of the system
+ subroutine system_init_interaction(this, interaction)
+ import system_t
+ import interaction_t
+ class(system_t), target, intent(inout) :: this
+ class(interaction_t), intent(inout) :: interaction
+ end subroutine system_init_interaction
+
+ ! ---------------------------------------------------------
+ !> set initial conditions for a system
+ subroutine system_initial_conditions(this)
+ import system_t
+ class(system_t), intent(inout) :: this
+ end subroutine system_initial_conditions
+
+ ! ---------------------------------------------------------
+ !> @brief Execute one operation that is part of a larger algorithm. Returns true
+ !! if the operation was successfully executed, false otherwise.
+ !!
+ !! Unsuccessful operations can occur, e.g. of quantities from an interaction
+ !! are required, but the interaction is still behind in terms of the iteration counters.
+ !!
+ !! On output, the routine should also provide a list quantities that were
+ !! updated. If no quantitiy was updated, then the corresponding array should
+ !! be left unallocated.
+ logical function system_do_algorithmic_operation(this, operation, updated_quantities) result(done)
+ import system_t
+ import algorithmic_operation_t
+ class(system_t), intent(inout) :: this
+ class(algorithmic_operation_t), intent(in) :: operation
+ integer, allocatable, intent(out) :: updated_quantities(:)
+ end function system_do_algorithmic_operation
+
+ ! ---------------------------------------------------------
+ !> @brief check whether a system has reached a given tolerance
+ logical function system_is_tolerance_reached(this, tol)
+ use, intrinsic :: iso_fortran_env
+ import system_t
+ class(system_t), intent(in) :: this
+ real(real64), intent(in) :: tol
+ end function system_is_tolerance_reached
+
+ ! ---------------------------------------------------------
+ !> @brief For some algorithms it might be necessary to store the status of a system at a given algorithmic step
+ !!
+ !! This should be implemented by each system in this routine.
+ subroutine system_store_current_status(this)
+ import system_t
+ class(system_t), intent(inout) :: this
+ end subroutine system_store_current_status
+
+ ! ---------------------------------------------------------
+ subroutine system_restart_write_data(this)
+ import system_t
+ class(system_t), intent(inout) :: this
+ end subroutine system_restart_write_data
+
+ ! ---------------------------------------------------------
+ ! this function returns true if restart data could be read
+ logical function system_restart_read_data(this)
+ import system_t
+ class(system_t), intent(inout) :: this
+ end function system_restart_read_data
+ subroutine system_update_kinetic_energy(this)
+ import system_t
+ class(system_t), intent(inout) :: this
+ end subroutine system_update_kinetic_energy
+
+ end interface
+
+ !> @brief These classes extends the list and list iterator to create a system list.
+ !!
+ !! Since a list of systems is also a list of interaction partners, the system
+ !! list is an extension of the partner list.
+ type, extends(partner_list_t) :: system_list_t
+ private
+ contains
+ procedure :: add => system_list_add_node !< @copydoc system_oct_m::system_list_add_node
+ procedure :: contains => system_list_contains !< @copydoc system_oct_m::system_list_contains
+ end type system_list_t
+
+ type, extends(linked_list_iterator_t) :: system_iterator_t
+ private
+ contains
+ procedure :: get_next => system_iterator_get_next !< @copydoc system_oct_m::system_iterator_get_next
+ end type system_iterator_t
+
+ ! Subroutine/Functions
+ interface
+ !> Constructor for the abstract class system_t
+ !!
+ !! Fortran limitation: Cannot define abstract constructor. Have to use subroutine instead.
+ !!
+ !! IMPORTANT: The actual constructors must call this subroutine exactly ONCE
+ !!
+ !! @param this system_t object
+ module subroutine system_init(this)
+ ! TODO: Make sure all constructors call this function
+ ! TODO: Move other constructor functions here
+ class(system_t), target, intent(inout) :: this
+ end subroutine system_init
+ !> Post constructor
+ !!
+ !! Run additional initialization functions right after the system has been loaded from file
+ !!
+ !! @param this system_t object
+ module subroutine system_post_init(this)
+ class(system_t), intent(inout) :: this
+ end subroutine system_post_init
+
+ module subroutine system_execute_algorithm(this)
+ class(system_t), intent(inout) :: this
+ end subroutine system_execute_algorithm
+
+ module subroutine system_reset_iteration_counters(this, accumulated_iterations)
+ class(system_t), intent(inout) :: this
+ integer, intent(in) :: accumulated_iterations
+ end subroutine system_reset_iteration_counters
+
+ recursive module subroutine system_create_interactions(this, interaction_factory, available_partners)
+ class(system_t), intent(inout) :: this
+ class(interactions_factory_abst_t), intent(in) :: interaction_factory
+ class(partner_list_t), target, intent(in) :: available_partners
+ end subroutine system_create_interactions
+
+ module function system_update_couplings(this) result(all_updated)
+ class(system_t), intent(inout) :: this
+ logical :: all_updated
+ end function system_update_couplings
+
+ module subroutine system_update_interactions(this)
+ class(system_t), intent(inout) :: this
+ end subroutine system_update_interactions
+
+ module subroutine system_update_interactions_start(this)
+ class(system_t), intent(inout) :: this
+ end subroutine system_update_interactions_start
+
+ module subroutine system_update_interactions_finish(this)
+ class(system_t), intent(inout) :: this
+ end subroutine system_update_interactions_finish
+
+ module subroutine system_restart_write(this)
+ class(system_t), intent(inout) :: this
+ end subroutine system_restart_write
+
+ module function system_restart_read(this) result(res)
+ class(system_t), intent(inout) :: this
+ logical :: res
+ end function system_restart_read
+
+ module subroutine system_output_start(this)
+ class(system_t), intent(inout) :: this
+ end subroutine system_output_start
+
+ module subroutine system_output_write(this)
+ class(system_t), intent(inout) :: this
+ end subroutine system_output_write
+
+ module subroutine system_output_finish(this)
+ class(system_t), intent(inout) :: this
+ end subroutine system_output_finish
+
+ module subroutine system_init_algorithm(this, factory)
+ class(system_t), intent(inout) :: this
+ class(algorithm_factory_t), intent(in) :: factory
+ end subroutine system_init_algorithm
+
+ recursive module function system_algorithm_finished(this) result(finished)
+ class(system_t), intent(in) :: this
+ logical :: finished
+ end function system_algorithm_finished
+
+ module subroutine system_init_iteration_counters(this)
+ class(system_t), intent(inout) :: this
+ end subroutine system_init_iteration_counters
+
+ module subroutine system_propagation_start(this)
+ class(system_t), intent(inout) :: this
+ end subroutine system_propagation_start
+
+ module subroutine system_propagation_finish(this)
+ class(system_t), intent(inout) :: this
+ end subroutine system_propagation_finish
+
+ module subroutine system_iteration_info(this)
+ class(system_t), intent(in) :: this
+ end subroutine system_iteration_info
+
+ module function system_process_is_slave(this) result(res)
+ class(system_t), intent(in) :: this
+ logical :: res
+ end function system_process_is_slave
+
+ module subroutine system_end(this)
+ class(system_t), intent(inout) :: this
+ end subroutine system_end
+
+ module subroutine system_list_add_node(this, partner)
+ class(system_list_t) :: this
+ class(interaction_partner_t), target :: partner
+ end subroutine system_list_add_node
+
+ recursive module function system_list_contains(this, partner) result(contains)
+ class(system_list_t) :: this
+ class(interaction_partner_t), target :: partner
+ logical contains
+ end function system_list_contains
+
+ module function system_iterator_get_next(this) result(system)
+ class(system_iterator_t), intent(inout) :: this
+ class(system_t), pointer :: system
+ end function system_iterator_get_next
+
+ module subroutine system_init_parallelization(this, grp)
+ class(system_t), intent(inout) :: this
+ type(mpi_grp_t), intent(in) :: grp
+ end subroutine system_init_parallelization
+
+ module subroutine system_start_barrier(this, target_time, barrier_index)
+ class(system_t), intent(inout) :: this
+ real(real64), intent(in) :: target_time
+ integer, intent(in) :: barrier_index
+ end subroutine system_start_barrier
+
+ module subroutine system_end_barrier(this, barrier_index)
+ class(system_t), intent(inout) :: this
+ integer, intent(in) :: barrier_index
+ end subroutine system_end_barrier
+
+ module function system_arrived_at_barrier(this, barrier_index) result(res)
+ class(system_t), intent(inout) :: this
+ integer, intent(in) :: barrier_index
+ logical :: res
+ end function system_arrived_at_barrier
+
+ module function system_arrived_at_any_barrier(this) result(res)
+ class(system_t), intent(inout) :: this
+ logical :: res
+ end function system_arrived_at_any_barrier
+
+ module subroutine system_update_potential_energy(this)
+ class(system_t), intent(inout) :: this
+ end subroutine system_update_potential_energy
+
+ module subroutine system_update_internal_energy(this)
+ class(system_t), intent(inout) :: this
+ end subroutine system_update_internal_energy
+
+ module subroutine system_update_total_energy(this)
+ class(system_t), intent(inout) :: this
+ end subroutine system_update_total_energy
+ end interface
+end module system_oct_m
diff --git a/src/opt_control/opt_control.F90 b/src/opt_control/opt_control.F90
index 4530b3d3c7459f66b4cef85fadf7fe4f5ffb901c..95f4c5e1dec49e35c4d63cdd8f65d58cec21cb45 100644
--- a/src/opt_control/opt_control.F90
+++ b/src/opt_control/opt_control.F90
@@ -58,6 +58,7 @@ module opt_control_oct_m
use electrons_oct_m
use target_oct_m
use td_oct_m
+ use td_interface_oct_m
implicit none
@@ -111,7 +112,6 @@ contains
subroutine opt_control_run_legacy(sys)
type(electrons_t), target, intent(inout) :: sys
- type(td_t), target :: td
type(controlfunction_t) :: par, par_new, par_prev
logical :: stop_loop
real(real64) :: j1
@@ -136,16 +136,16 @@ contains
! Initializes the time propagator. Then, it forces the propagation to be self consistent, in case
! the theory level is not "independent particles".
- call td_init(td, sys%namespace, sys%space, sys%gr, sys%ions, sys%st, sys%ks, sys%hm, sys%ext_partners, sys%outp)
- if (sys%hm%theory_level /= INDEPENDENT_PARTICLES) call propagator_elec_set_scf_prop(td%tr, threshold = 1.0e-14_real64)
+ call td_init(sys)
+ if (sys%hm%theory_level /= INDEPENDENT_PARTICLES) call propagator_elec_set_scf_prop(sys%td%tr, threshold = 1.0e-14_real64)
! Read general information about how the OCT run will be made, from inp file. "oct_read_inp" is
! in the opt_control_global_oct_m module (like the definition of the oct_t data type)
call oct_read_inp(oct, sys%namespace)
! Read info about, and prepare, the control functions
- call controlfunction_mod_init(sys%ext_partners, sys%namespace, td%dt, td%max_iter, oct%mode_fixed_fluence)
- call controlfunction_init(par, td%dt, td%max_iter)
+ call controlfunction_mod_init(sys%ext_partners, sys%namespace, sys%td%dt, sys%td%max_iter, oct%mode_fixed_fluence)
+ call controlfunction_init(par, sys%td%dt, sys%td%max_iter)
call controlfunction_set(par, sys%ext_partners)
! This prints the initial control parameters, exactly as described in the inp file,
! that is, without applying any envelope or filter.
@@ -164,7 +164,7 @@ contains
! Initialization of the propagation_oct_m module.
- call propagation_mod_init(td%max_iter, oct%eta, oct%delta, oct%number_checkpoints, &
+ call propagation_mod_init(sys%td%max_iter, oct%eta, oct%delta, oct%number_checkpoints, &
(oct%algorithm == OPTION__OCTSCHEME__OCT_ZBR98), &
(oct%algorithm == OPTION__OCTSCHEME__OCT_CG) .or. &
(oct%algorithm == OPTION__OCTSCHEME__OCT_BFGS) .or. &
@@ -172,17 +172,17 @@ contains
! If filters are to be used, they also have to be initialized.
- call filter_init(td%max_iter, sys%namespace, td%dt, filter)
+ call filter_init(sys%td%max_iter, sys%namespace, sys%td%dt, filter)
call filter_write(filter, sys%namespace)
! Figure out the starting wavefunction(s), and the target.
call initial_state_init(sys, initial_st)
- call target_init(sys%gr, sys%kpoints, sys%namespace, sys%space, sys%ions, initial_st, td, &
+ call target_init(sys%gr, sys%kpoints, sys%namespace, sys%space, sys%ions, initial_st, sys%td, &
controlfunction_w0(par), oct_target, oct, sys%hm%ep, sys%mc)
! Sanity checks.
- call check_faulty_runmodes(sys, td%tr)
+ call check_faulty_runmodes(sys, sys%td%tr)
! Informative output.
@@ -243,13 +243,13 @@ contains
end select
! do final test run: propagate initial state with optimal field
- call oct_finalcheck(sys, td)
+ call oct_finalcheck(sys, sys%td)
! clean up
call controlfunction_end(par)
call oct_iterator_end(iterator, sys%namespace)
call filter_end(filter)
- call td_end(td)
+ call td_end(sys)
call opt_control_state_end(initial_st)
call target_end(oct_target, oct)
call controlfunction_mod_close()
@@ -267,7 +267,7 @@ contains
call controlfunction_copy(par_new, par)
ctr_loop: do
call controlfunction_copy(par_prev, par)
- call f_striter(sys, td, par, j1)
+ call f_striter(sys, sys%td, par, j1)
stop_loop = iteration_manager(sys%namespace, j1, par_prev, par, iterator)
if (clean_stop(sys%mc%master_comm) .or. stop_loop) exit ctr_loop
end do ctr_loop
@@ -292,7 +292,7 @@ contains
call controlfunction_copy(par_new, par)
ctr_loop: do
call controlfunction_copy(par_prev, par)
- call f_iter(sys, td, psi, par, prop_psi, prop_chi, j1)
+ call f_iter(sys, sys%td, psi, par, prop_psi, prop_chi, j1)
stop_loop = iteration_manager(sys%namespace, j1, par, par_prev, iterator)
if (clean_stop(sys%mc%master_comm) .or. stop_loop) exit ctr_loop
end do ctr_loop
@@ -324,7 +324,7 @@ contains
call controlfunction_copy(par_new, par)
ctr_loop: do
call controlfunction_copy(par_prev, par)
- call f_wg05(sys, td, psi, par, prop_psi, prop_chi, j1)
+ call f_wg05(sys, sys%td, psi, par, prop_psi, prop_chi, j1)
stop_loop = iteration_manager(sys%namespace, j1, par, par_prev, iterator)
if (clean_stop(sys%mc%master_comm) .or. stop_loop) exit ctr_loop
end do ctr_loop
@@ -350,7 +350,7 @@ contains
call oct_prop_init(prop_psi, sys%namespace, "psi", sys%gr, sys%mc)
call controlfunction_copy(par_prev, par)
- call propagate_forward(sys, td, par, oct_target, qcpsi, prop_psi)
+ call propagate_forward(sys, sys%td, par, oct_target, qcpsi, prop_psi)
j1 = target_j1(oct_target, sys%namespace, sys%gr, sys%kpoints, qcpsi)
stop_loop = iteration_manager(sys%namespace, j1, par, par_prev, iterator)
if (clean_stop(sys%mc%master_comm) .or. stop_loop) then
@@ -364,7 +364,7 @@ contains
call controlfunction_copy(par_new, par)
ctr_loop: do
call controlfunction_copy(par_prev, par)
- call f_zbr98(sys, td, qcpsi, prop_psi, prop_chi, par)
+ call f_zbr98(sys, sys%td, qcpsi, prop_psi, prop_chi, par)
j1 = target_j1(oct_target, sys%namespace, sys%gr, sys%kpoints, qcpsi)
stop_loop = iteration_manager(sys%namespace, j1, par, par_prev, iterator)
if (clean_stop(sys%mc%master_comm) .or. stop_loop) exit ctr_loop
@@ -394,7 +394,7 @@ contains
call opt_control_state_null(qcpsi)
call opt_control_state_copy(qcpsi, initial_st)
- call propagate_forward(sys, td, par, oct_target, qcpsi)
+ call propagate_forward(sys, sys%td, par, oct_target, qcpsi)
f = - target_j1(oct_target, sys%namespace, sys%gr, sys%kpoints, qcpsi, sys%ions) - controlfunction_j2(par)
call opt_control_state_end(qcpsi)
call iteration_manager_direct(-f, par, iterator, sys)
@@ -411,7 +411,7 @@ contains
call controlfunction_copy(par_, par)
sys_ => sys
hm_ => sys%hm
- td_ => td
+ td_ => sys%td
dof = controlfunction_dof(par)
SAFE_ALLOCATE(x(1:dof))
@@ -469,7 +469,7 @@ contains
call opt_control_state_null(qcpsi)
call opt_control_state_copy(qcpsi, initial_st)
- call propagate_forward(sys, td, par, oct_target, qcpsi)
+ call propagate_forward(sys, sys%td, par, oct_target, qcpsi)
f = - target_j1(oct_target, sys%namespace, sys%gr, sys%kpoints, qcpsi, sys%ions) - controlfunction_j2(par)
call opt_control_state_end(qcpsi)
call iteration_manager_direct(-f, par, iterator, sys)
@@ -489,7 +489,7 @@ contains
call controlfunction_copy(par_, par)
sys_ => sys
hm_ => sys%hm
- td_ => td
+ td_ => sys%td
! theta may be in single precision, whereas x is always double precision.
call controlfunction_get_theta(par, theta)
@@ -534,7 +534,7 @@ contains
call opt_control_state_null(qcpsi)
call opt_control_state_copy(qcpsi, initial_st)
- call propagate_forward(sys, td, par, oct_target, qcpsi)
+ call propagate_forward(sys, sys%td, par, oct_target, qcpsi)
f = - target_j1(oct_target, sys%namespace, sys%gr, sys%kpoints, qcpsi, sys%ions) - controlfunction_j2(par)
call opt_control_state_end(qcpsi)
call iteration_manager_direct(-f, par, iterator, sys)
@@ -557,7 +557,7 @@ contains
call controlfunction_copy(par_, par)
sys_ => sys
hm_ => sys%hm
- td_ => td
+ td_ => sys%td
call controlfunction_get_theta(par, x)
diff --git a/src/opt_control/propagation.F90 b/src/opt_control/propagation.F90
index 5d5e59344dd5bd58cf416d34a803095036e4162a..d66081e077f109746368f2a1aed2f576e5d50bf9 100644
--- a/src/opt_control/propagation.F90
+++ b/src/opt_control/propagation.F90
@@ -223,7 +223,7 @@ contains
do istep = 1, td%max_iter
! time-iterate wavefunctions
- call propagator_elec_dt(sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, psi, td%tr, istep*td%dt, td%dt, istep, &
+ call propagator_elec_dt(sys, sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, psi, td%tr, istep*td%dt, td%dt, istep, &
td%ions_dyn, sys%ions, sys%ext_partners, sys%outp, td%write_handler)
if (present(prop)) then
@@ -315,7 +315,7 @@ contains
if (mpi_grp_is_root(mpi_world)) call loct_progress_bar(-1, td%max_iter)
do istep = td%max_iter, 1, -1
- call propagator_elec_dt(sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, psi, td%tr, &
+ call propagator_elec_dt(sys, sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, psi, td%tr, &
(istep - 1)*td%dt, -td%dt, istep-1, td%ions_dyn, sys%ions, sys%ext_partners, sys%outp, td%write_handler)
call oct_prop_dump_states(prop, sys%space, istep - 1, psi, sys%gr, sys%kpoints, ierr)
@@ -423,18 +423,18 @@ contains
call update_hamiltonian_elec_chi(i, sys%namespace, sys%space, sys%gr, sys%ks, sys%hm, sys%ext_partners, &
td, tg, par_chi, sys%ions, psi2)
call sys%hm%update(sys%gr, sys%namespace, sys%space, sys%ext_partners, time = (i - 1)*td%dt)
- call propagator_elec_dt(sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, chi, tr_chi, i*td%dt, td%dt, i, &
+ call propagator_elec_dt(sys, sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, chi, tr_chi, i*td%dt, td%dt, i, &
td%ions_dyn, sys%ions, sys%ext_partners, sys%outp, td%write_handler)
if (aux_fwd_propagation) then
call update_hamiltonian_elec_psi(i, sys%namespace, sys%space, sys%gr, sys%ks, sys%hm, sys%ext_partners, &
td, tg, par_prev, psi2, sys%ions)
- call propagator_elec_dt(sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, psi2, tr_psi2, i*td%dt, td%dt, i, &
+ call propagator_elec_dt(sys, sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, psi2, tr_psi2, i*td%dt, td%dt, i, &
td%ions_dyn, sys%ions, sys%ext_partners, sys%outp, td%write_handler)
end if
call update_hamiltonian_elec_psi(i, sys%namespace, sys%space, sys%gr, sys%ks, sys%hm, &
sys%ext_partners, td, tg, par, psi, sys%ions)
call sys%hm%update(sys%gr, sys%namespace, sys%space, sys%ext_partners, time = (i - 1)*td%dt)
- call propagator_elec_dt(sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, psi, td%tr, i*td%dt, td%dt, i, &
+ call propagator_elec_dt(sys, sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, psi, td%tr, i*td%dt, td%dt, i, &
td%ions_dyn, sys%ions, sys%ext_partners, sys%outp, td%write_handler)
call target_tdcalc(tg, sys%namespace, sys%space, sys%hm, sys%gr, sys%ions, sys%ext_partners, psi, i, td%max_iter)
@@ -536,7 +536,7 @@ contains
call update_hamiltonian_elec_chi(i-1, sys%namespace, sys%space, sys%gr, sys%ks, sys%hm, sys%ext_partners, &
td, tg, par_chi, sys%ions, psi)
call sys%hm%update(sys%gr, sys%namespace, sys%space, sys%ext_partners, time = abs(i*td%dt))
- call propagator_elec_dt(sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, chi, tr_chi, abs((i-1)*td%dt), td%dt, &
+ call propagator_elec_dt(sys, sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, chi, tr_chi, abs((i-1)*td%dt), td%dt, &
i-1, td%ions_dyn, sys%ions, sys%ext_partners, sys%outp, td%write_handler)
call oct_prop_dump_states(prop_chi, sys%space, i-1, chi, sys%gr, sys%kpoints, ierr)
if (ierr /= 0) then
@@ -546,7 +546,7 @@ contains
call update_hamiltonian_elec_psi(i-1, sys%namespace, sys%space, sys%gr, sys%ks, sys%hm, sys%ext_partners, &
td, tg, par, psi, sys%ions)
call sys%hm%update(sys%gr, sys%namespace, sys%space, sys%ext_partners, time = abs(i*td%dt))
- call propagator_elec_dt(sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, psi, td%tr, abs((i-1)*td%dt), td%dt, &
+ call propagator_elec_dt(sys, sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, psi, td%tr, abs((i-1)*td%dt), td%dt, &
i-1, td%ions_dyn, sys%ions, sys%ext_partners, sys%outp, td%write_handler)
end do
td%dt = -td%dt
@@ -666,7 +666,7 @@ contains
call update_hamiltonian_elec_psi(i-1, sys%namespace, sys%space, sys%gr, sys%ks, sys%hm, sys%ext_partners, &
td, tg, par, psi, sys%ions)
- call propagator_elec_dt(sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, psi, td%tr, abs((i-1)*td%dt), td%dt, &
+ call propagator_elec_dt(sys, sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, psi, td%tr, abs((i-1)*td%dt), td%dt, &
i-1, td%ions_dyn, sys%ions, sys%ext_partners, sys%outp, td%write_handler, qcchi = qcchi)
case default
@@ -700,7 +700,7 @@ contains
end do
vhxc(:, :) = sys%hm%vhxc(:, :)
- call propagator_elec_dt(sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, psi, td%tr, abs((i-1)*td%dt), td%dt, &
+ call propagator_elec_dt(sys, sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, psi, td%tr, abs((i-1)*td%dt), td%dt, &
i-1, td%ions_dyn, sys%ions, sys%ext_partners, sys%outp, td%write_handler)
if (ion_dynamics_ions_move(td%ions_dyn)) then
@@ -723,7 +723,7 @@ contains
call update_hamiltonian_elec_chi(i-1, sys%namespace, sys%space, sys%gr, sys%ks, sys%hm, sys%ext_partners, &
td, tg, par, sys%ions, st_ref, qtildehalf)
freeze = ion_dynamics_freeze(td%ions_dyn)
- call propagator_elec_dt(sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, chi, tr_chi, abs((i-1)*td%dt), td%dt, &
+ call propagator_elec_dt(sys, sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, chi, tr_chi, abs((i-1)*td%dt), td%dt, &
i-1, td%ions_dyn, sys%ions, sys%ext_partners, sys%outp, td%write_handler)
if (freeze) call ion_dynamics_unfreeze(td%ions_dyn)
diff --git a/src/scf/CMakeLists.txt b/src/scf/CMakeLists.txt
index 75f20d3a9894a4e9f6d690f335bc8fd849d8c657..1bb8cb1b2a712a49d1909bac7f1e8fa99133cbb7 100644
--- a/src/scf/CMakeLists.txt
+++ b/src/scf/CMakeLists.txt
@@ -3,13 +3,16 @@ target_sources(Octopus_lib PRIVATE
density_criterion.F90
eigenval_criterion.F90
electrons_ground_state.F90
+ electrons_ground_state_h.F90
energy_criterion.F90
lcao.F90
lda_u_mixer.F90
mix.F90
mixing_preconditioner.F90
rdmft.F90
- scf.F90
+ scf_h.F90
+ scf_interface.F90
+ scf_interface_h.F90
unocc.F90
)
## Unused sources
diff --git a/src/scf/electrons_ground_state.F90 b/src/scf/electrons_ground_state.F90
index 0e608c8e9c595ad1f257bbac67f108ea7ccf7012..00ea732a780ab377fac7043a4f790044b6ebdf68 100644
--- a/src/scf/electrons_ground_state.F90
+++ b/src/scf/electrons_ground_state.F90
@@ -18,25 +18,20 @@
#include "global.h"
-module electrons_ground_state_oct_m
+submodule (electrons_ground_state_oct_m) impl
+ use electrons_ground_state_oct_m
use debug_oct_m
- use electron_space_oct_m
use global_oct_m
- use grid_oct_m
use hamiltonian_elec_oct_m
- use interaction_partner_oct_m
use io_function_oct_m
- use ions_oct_m
use lcao_oct_m
use math_oct_m
use mesh_oct_m
use messages_oct_m
- use multicomm_oct_m
- use namespace_oct_m
- use output_low_oct_m
use pcm_oct_m
use rdmft_oct_m
use restart_oct_m
+ use scf_interface_oct_m
use scf_oct_m
use space_oct_m
use states_abst_oct_m
@@ -46,28 +41,13 @@ module electrons_ground_state_oct_m
implicit none
- private
- public :: &
- electrons_ground_state_run
-
contains
! ---------------------------------------------------------
- subroutine electrons_ground_state_run(namespace, mc, gr, ions, ext_partners, st, ks, hm, outp, space, fromScratch)
- type(namespace_t), intent(in) :: namespace
- type(multicomm_t), intent(in) :: mc
- type(grid_t), intent(inout) :: gr
- type(ions_t), intent(inout) :: ions
- type(partner_list_t), intent(in) :: ext_partners
- type(states_elec_t), intent(inout) :: st
- type(v_ks_t), intent(inout) :: ks
- type(hamiltonian_elec_t), intent(inout) :: hm
- type(output_t), intent(in) :: outp
- type(electron_space_t), intent(in) :: space
+ module subroutine electrons_ground_state_run(sys, fromScratch)
+ type(electrons_t), intent(inout) :: sys
logical, intent(inout) :: fromScratch
- type(scf_t) :: scfv
- type(restart_t) :: restart_load, restart_dump
integer :: ierr
type(rdm_t) :: rdm
logical :: restart_init_dump
@@ -75,120 +55,115 @@ contains
PUSH_SUB(ground_state_run_legacy)
call messages_write('Info: Allocating ground state wave-functions')
- call messages_info(namespace=namespace)
+ call messages_info(namespace=sys%namespace)
- if (st%parallel_in_states) then
- call messages_experimental('State parallelization for ground state calculations', namespace=namespace)
+ if (sys%st%parallel_in_states) then
+ call messages_experimental('State parallelization for ground state calculations', namespace=sys%namespace)
end if
- if (hm%pcm%run_pcm) then
- if (.not. is_close(hm%pcm%epsilon_infty, hm%pcm%epsilon_0) .and. hm%pcm%tdlevel /= PCM_TD_EQ) then
+ if (sys%hm%pcm%run_pcm) then
+ if (.not. is_close(sys%hm%pcm%epsilon_infty, sys%hm%pcm%epsilon_0) .and. sys%hm%pcm%tdlevel /= PCM_TD_EQ) then
message(1) = 'Non-equilbrium PCM is not active in a time-independent run.'
message(2) = 'You set epsilon_infty /= epsilon_0, but epsilon_infty is not relevant for CalculationMode = gs.'
message(3) = 'By definition, the ground state is in equilibrium with the solvent.'
message(4) = 'Therefore, the only relevant dielectric constant is the static one.'
message(5) = 'Nevertheless, the dynamical PCM response matrix is evaluated for benchamarking purposes.'
- call messages_warning(5, namespace=namespace)
+ call messages_warning(5, namespace=sys%namespace)
end if
end if
- call states_elec_allocate_wfns(st, gr, packed=.true.)
+ call states_elec_allocate_wfns(sys%st, sys%gr, packed=.true.)
! sometimes a deadlock can occur here (if some nodes can allocate and other cannot)
- if (st%dom_st_kpt_mpi_grp%comm > 0) call st%dom_st_kpt_mpi_grp%barrier()
+ if (sys%st%dom_st_kpt_mpi_grp%comm > 0) call sys%st%dom_st_kpt_mpi_grp%barrier()
call messages_write('Info: Ground-state allocation done.')
- call messages_info(namespace=namespace)
+ call messages_info(namespace=sys%namespace)
if (.not. fromScratch) then
! load wavefunctions
! in RDMFT we need the full ground state
- call restart_init(restart_load, namespace, RESTART_GS, RESTART_TYPE_LOAD, mc, ierr, mesh=gr, &
- exact = (ks%theory_level == RDMFT))
+ allocate(sys%scf%restart_load)
+ call restart_init(sys%scf%restart_load, sys%namespace, RESTART_GS, RESTART_TYPE_LOAD, sys%mc, ierr, mesh=sys%gr, &
+ exact = (sys%ks%theory_level == RDMFT))
if (ierr == 0) then
- call states_elec_load(restart_load, namespace, space, st, gr, hm%kpoints, ierr)
+ call states_elec_load(sys%scf%restart_load, sys%namespace, sys%space, sys%st, sys%gr, sys%hm%kpoints, ierr)
end if
if (ierr /= 0) then
call messages_write("Unable to read wavefunctions.")
call messages_new_line()
call messages_write("Starting from scratch!")
- call messages_warning(namespace=namespace)
+ call messages_warning(namespace=sys%namespace)
fromScratch = .true.
end if
end if
- call write_canonicalized_xyz_file("exec", "initial_coordinates", space, ions%latt, ions%pos, ions%atom, &
- gr%box, namespace)
+ call write_canonicalized_xyz_file("exec", "initial_coordinates", sys%space, sys%ions%latt, sys%ions%pos, sys%ions%atom, &
+ sys%gr%box, sys%namespace)
- if (ks%theory_level /= RDMFT) then
- call scf_init(scfv, namespace, gr, ions, st, mc, hm, space)
+ if (sys%ks%theory_level /= RDMFT) then
+ call scf_init(sys)
! only initialize dumping restart files for more than one iteration
- restart_init_dump = scfv%max_iter > 0
+ restart_init_dump = sys%scf%max_iter > 0
else
restart_init_dump = .true.
end if
- if (fromScratch .and. ks%theory_level /= RDMFT) then
- call lcao_run(namespace, space, gr, ions, ext_partners, st, ks, hm, lmm_r = scfv%lmm_r)
+ ! TODO: Maybe this should be after `restart_read` is executed
+ call sys%post_init()
+
+ if (fromScratch .and. sys%ks%theory_level /= RDMFT) then
+ call lcao_run(sys%namespace, sys%space, sys%gr, sys%ions, sys%ext_partners, sys%st, sys%ks, sys%hm, lmm_r = sys%scf%lmm_r)
else
! setup Hamiltonian
call messages_write('Info: Setting up Hamiltonian.')
- call messages_info(namespace=namespace)
- call v_ks_h_setup(namespace, space, gr, ions, ext_partners, st, ks, hm, &
+ call messages_info(namespace=sys%namespace)
+ call v_ks_h_setup(sys%namespace, sys%space, sys%gr, sys%ions, sys%ext_partners, sys%st, sys%ks, sys%hm, &
calc_eigenval = .false., calc_current = .false.)
end if
if (restart_init_dump) then
- call restart_init(restart_dump, namespace, RESTART_GS, RESTART_TYPE_DUMP, mc, ierr, mesh=gr)
+ allocate(sys%scf%restart_dump)
+ call restart_init(sys%scf%restart_dump, sys%namespace, RESTART_GS, RESTART_TYPE_DUMP, sys%mc, ierr, mesh=sys%gr)
end if
! run self-consistency
- call scf_state_info(namespace, st)
+ call scf_state_info(sys)
- if (st%pack_states .and. hm%apply_packed()) then
- call st%pack()
+ if (sys%st%pack_states .and. sys%hm%apply_packed()) then
+ call sys%st%pack()
end if
! self-consistency for occupation numbers and natural orbitals in RDMFT
- if (ks%theory_level == RDMFT) then
- call rdmft_init(rdm, namespace, gr, st, mc, space, fromScratch)
- call scf_rdmft(rdm, namespace, space, gr, ions, ext_partners, st, ks, hm, outp, restart_dump)
+ if (sys%ks%theory_level == RDMFT) then
+ call rdmft_init(rdm, sys%namespace, sys%gr, sys%st, sys%mc, sys%space, fromScratch)
+ call scf_rdmft(rdm, sys%namespace, sys%space, sys%gr, sys%ions, sys%ext_partners, &
+ sys%st, sys%ks, sys%hm, sys%outp, sys%scf%restart_dump)
call rdmft_end(rdm)
else
+ call scf_run(sys, outp=sys%outp)
if (.not. fromScratch) then
- if (restart_init_dump) then
- call scf_run(scfv, namespace, space, mc, gr, ions, ext_partners, st, ks, hm, outp=outp, &
- restart_load=restart_load, restart_dump=restart_dump)
- else
- call scf_run(scfv, namespace, space, mc, gr, ions, ext_partners, st, ks, hm, outp=outp, restart_load=restart_load)
- end if
- call restart_end(restart_load)
- else
- if (restart_init_dump) then
- call scf_run(scfv, namespace, space, mc, gr, ions, ext_partners, st, ks, hm, outp=outp, restart_dump=restart_dump)
- else
- call scf_run(scfv, namespace, space, mc, gr, ions, ext_partners, st, ks, hm, outp=outp)
- end if
+ call restart_end(sys%scf%restart_load)
end if
- call scf_end(scfv)
+ call scf_end(sys)
end if
if (restart_init_dump) then
- call restart_end(restart_dump)
+ call restart_end(sys%scf%restart_dump)
end if
- if (st%pack_states .and. hm%apply_packed()) then
- call st%unpack()
+ if (sys%st%pack_states .and. sys%hm%apply_packed()) then
+ call sys%st%unpack()
end if
! clean up
- call states_elec_deallocate_wfns(st)
+ call states_elec_deallocate_wfns(sys%st)
POP_SUB(ground_state_run_legacy)
end subroutine electrons_ground_state_run
-end module electrons_ground_state_oct_m
+end submodule impl
!! Local Variables:
!! mode: f90
diff --git a/src/scf/electrons_ground_state_h.F90 b/src/scf/electrons_ground_state_h.F90
new file mode 100644
index 0000000000000000000000000000000000000000..25cff7d46a3595832a80b983bacb53bab51ccb63
--- /dev/null
+++ b/src/scf/electrons_ground_state_h.F90
@@ -0,0 +1,16 @@
+module electrons_ground_state_oct_m
+ use electrons_oct_m
+
+ implicit none
+
+ private
+ public :: &
+ electrons_ground_state_run
+
+ interface
+ module subroutine electrons_ground_state_run(sys, fromScratch)
+ type(electrons_t), intent(inout) :: sys
+ logical, intent(inout) :: fromScratch
+ end subroutine electrons_ground_state_run
+ end interface
+end module electrons_ground_state_oct_m
diff --git a/src/scf/scf_h.F90 b/src/scf/scf_h.F90
new file mode 100644
index 0000000000000000000000000000000000000000..60361e04173027561f077ead403e8b51471f6cdd
--- /dev/null
+++ b/src/scf/scf_h.F90
@@ -0,0 +1,51 @@
+module scf_oct_m
+ use berry_oct_m
+ use convergence_criterion_oct_m
+ use eigensolver_oct_m
+ use global_oct_m
+ use lda_u_mixer_oct_m
+ use mix_oct_m
+ use restart_oct_m
+
+ implicit none
+
+ private
+
+ integer, public, parameter :: &
+ VERB_NO = 0, &
+ VERB_COMPACT = 1, &
+ VERB_FULL = 3
+
+ !> some variables used for the SCF cycle
+ type, public :: scf_t
+ private
+ integer, public :: max_iter !< maximum number of SCF iterations
+
+ real(real64), public :: lmm_r
+
+ ! several convergence criteria
+ logical, public :: conv_eigen_error
+ logical, public :: check_conv
+
+ integer, public :: mix_field
+ logical, public :: lcao_restricted
+ logical, public :: calc_force
+ logical, public :: calc_stress
+ logical, public :: calc_dipole
+ logical, public :: calc_partial_charges
+ type(mix_t), public :: smix
+ type(mixfield_t), public, pointer :: mixfield
+ type(eigensolver_t), public :: eigens
+ integer, public :: mixdim1
+ logical, public :: forced_finish !< remember if 'touch stop' was triggered earlier.
+ type(lda_u_mixer_t), public :: lda_u_mix
+ type(berry_t), public :: berry
+ integer, public :: matvec !< number matrix-vector products
+
+ type(criterion_list_t), public :: criterion_list
+ real(real64), public :: energy_in, energy_diff, abs_dens_diff, evsum_in, evsum_out, evsum_diff
+
+ type(restart_t), allocatable, public :: restart_load
+ type(restart_t), allocatable, public :: restart_dump
+ end type scf_t
+end module scf_oct_m
diff --git a/src/scf/scf.F90 b/src/scf/scf_interface.F90
similarity index 56%
rename from src/scf/scf.F90
rename to src/scf/scf_interface.F90
index 2b8eb87c97bdd708c05545cb2037c9e9bc6a662b..facdb32ab7fd80b79de6a6274588ddcf0be05fc5 100644
--- a/src/scf/scf.F90
+++ b/src/scf/scf_interface.F90
@@ -18,56 +18,43 @@
#include "global.h"
-module scf_oct_m
+submodule (scf_interface_oct_m) impl
+ use scf_interface_oct_m
use batch_ops_oct_m
use berry_oct_m
use convergence_criterion_oct_m
use criteria_factory_oct_m
use debug_oct_m
- use density_oct_m
use density_criterion_oct_m
+ use density_oct_m
use eigensolver_oct_m
use eigenval_criterion_oct_m
- use electron_space_oct_m
use energy_calc_oct_m
use energy_criterion_oct_m
use forces_oct_m
- use global_oct_m
- use grid_oct_m
- use hamiltonian_elec_oct_m
- use interaction_partner_oct_m
use io_oct_m
- use ions_oct_m
- use, intrinsic :: iso_fortran_env
use kpoints_oct_m
+ use lalg_basic_oct_m
use lcao_oct_m
- use lda_u_oct_m
use lda_u_io_oct_m
use lda_u_mixer_oct_m
- use lalg_basic_oct_m
+ use lda_u_oct_m
use loct_oct_m
use magnetic_oct_m
use math_oct_m
- use mesh_oct_m
use mesh_function_oct_m
+ use mesh_oct_m
use messages_oct_m
use mix_oct_m
use modelmb_exchange_syms_oct_m
use mpi_oct_m
- use multicomm_oct_m
- use namespace_oct_m
- use output_oct_m
- use output_low_oct_m
use output_modelmb_oct_m
+ use output_oct_m
use parser_oct_m
use partial_charges_oct_m
use profiling_oct_m
- use restart_oct_m
use smear_oct_m
- use space_oct_m
use species_oct_m
- use states_abst_oct_m
- use states_elec_oct_m
use states_elec_io_oct_m
use states_elec_restart_oct_m
use stress_oct_m
@@ -76,76 +63,22 @@ module scf_oct_m
use unit_oct_m
use unit_system_oct_m
use utils_oct_m
- use v_ks_oct_m
use varinfo_oct_m
use vdw_ts_oct_m
use walltimer_oct_m
use wfs_elec_oct_m
- use xc_oct_m
use xc_f03_lib_m
use xc_interaction_oct_m
+ use xc_oct_m
use xc_oep_oct_m
use xc_oep_photon_oct_m
implicit none
-
- private
- public :: &
- scf_t, &
- scf_init, &
- scf_mix_clear, &
- scf_run, &
- scf_end, &
- scf_state_info, &
- scf_print_mem_use
-
- integer, public, parameter :: &
- VERB_NO = 0, &
- VERB_COMPACT = 1, &
- VERB_FULL = 3
-
- !> some variables used for the SCF cycle
- type scf_t
- private
- integer, public :: max_iter !< maximum number of SCF iterations
-
- real(real64), public :: lmm_r
-
- ! several convergence criteria
- logical :: conv_eigen_error
- logical :: check_conv
-
- integer :: mix_field
- logical :: lcao_restricted
- logical :: calc_force
- logical, public :: calc_stress
- logical :: calc_dipole
- logical :: calc_partial_charges
- type(mix_t) :: smix
- type(mixfield_t), pointer :: mixfield
- type(eigensolver_t) :: eigens
- integer :: mixdim1
- logical :: forced_finish !< remember if 'touch stop' was triggered earlier.
- type(lda_u_mixer_t) :: lda_u_mix
- type(berry_t) :: berry
- integer :: matvec !< number matrix-vector products
-
- type(criterion_list_t), public :: criterion_list
- real(real64) :: energy_in, energy_diff, abs_dens_diff, evsum_in, evsum_out, evsum_diff
- end type scf_t
-
contains
! ---------------------------------------------------------
- subroutine scf_init(scf, namespace, gr, ions, st, mc, hm, space)
- type(scf_t), intent(inout) :: scf
- type(grid_t), intent(in) :: gr
- type(namespace_t), intent(in) :: namespace
- type(ions_t), intent(in) :: ions
- type(states_elec_t), intent(in) :: st
- type(multicomm_t), intent(in) :: mc
- type(hamiltonian_elec_t), intent(inout) :: hm
- class(space_t), intent(in) :: space
+ module subroutine scf_init(sys)
+ type(electrons_t), intent(inout) :: sys
real(real64) :: rmin
integer :: mixdefault
@@ -172,32 +105,32 @@ contains
!% where it denotes the maximum number of calls of the eigensolver. In this context, the
!% default value is 50.
!%End
- call parse_variable(namespace, 'MaximumIter', 200, scf%max_iter)
+ call parse_variable(sys%namespace, 'MaximumIter', 200, sys%scf%max_iter)
- if (allocated(hm%vberry)) then
- call berry_init(scf%berry, namespace)
+ if (allocated(sys%hm%vberry)) then
+ call berry_init(sys%scf%berry, sys%namespace)
end if
!Create the list of convergence criteria
- call criteria_factory_init(scf%criterion_list, namespace, scf%check_conv)
+ call criteria_factory_init(sys%scf%criterion_list, sys%namespace, sys%scf%check_conv)
!Setting the pointers
- call iter%start(scf%criterion_list)
+ call iter%start(sys%scf%criterion_list)
do while (iter%has_next())
crit => iter%get_next()
select type (crit)
type is (energy_criterion_t)
- call crit%set_pointers(scf%energy_diff, scf%energy_in)
+ call crit%set_pointers(sys%scf%energy_diff, sys%scf%energy_in)
type is (density_criterion_t)
- call crit%set_pointers(scf%abs_dens_diff, st%qtot)
+ call crit%set_pointers(sys%scf%abs_dens_diff, sys%st%qtot)
type is (eigenval_criterion_t)
- call crit%set_pointers(scf%evsum_diff, scf%evsum_out)
+ call crit%set_pointers(sys%scf%evsum_diff, sys%scf%evsum_out)
class default
ASSERT(.false.)
end select
end do
- if(.not. scf%check_conv .and. scf%max_iter < 0) then
+ if(.not. sys%scf%check_conv .and. sys%scf%max_iter < 0) then
call messages_write("All convergence criteria are disabled. Octopus is cowardly refusing")
call messages_new_line()
call messages_write("to enter an infinite loop.")
@@ -210,7 +143,7 @@ contains
call messages_new_line()
call messages_write(" | ConvAbsEv | ConvRelEv |")
call messages_new_line()
- call messages_fatal(namespace=namespace)
+ call messages_fatal(namespace=sys%namespace)
end if
!%Variable ConvEigenError
@@ -224,11 +157,11 @@ contains
!% If this criterion is used, the SCF loop will only stop once it is
!% fulfilled for two consecutive iterations.
!%End
- call parse_variable(namespace, 'ConvEigenError', .false., scf%conv_eigen_error)
+ call parse_variable(sys%namespace, 'ConvEigenError', .false., sys%scf%conv_eigen_error)
- if(scf%max_iter < 0) scf%max_iter = huge(scf%max_iter)
+ if(sys%scf%max_iter < 0) sys%scf%max_iter = huge(sys%scf%max_iter)
- call messages_obsolete_variable(namespace, 'What2Mix', 'MixField')
+ call messages_obsolete_variable(sys%namespace, 'What2Mix', 'MixField')
!%Variable MixField
!%Type integer
@@ -253,75 +186,75 @@ contains
!%End
mixdefault = OPTION__MIXFIELD__POTENTIAL
- if(hm%theory_level == INDEPENDENT_PARTICLES) mixdefault = OPTION__MIXFIELD__NONE
+ if(sys%hm%theory_level == INDEPENDENT_PARTICLES) mixdefault = OPTION__MIXFIELD__NONE
- call parse_variable(namespace, 'MixField', mixdefault, scf%mix_field)
- if(.not.varinfo_valid_option('MixField', scf%mix_field)) call messages_input_error(namespace, 'MixField')
- call messages_print_var_option('MixField', scf%mix_field, "what to mix during SCF cycles", namespace=namespace)
+ call parse_variable(sys%namespace, 'MixField', mixdefault, sys%scf%mix_field)
+ if(.not.varinfo_valid_option('MixField', sys%scf%mix_field)) call messages_input_error(sys%namespace, 'MixField')
+ call messages_print_var_option('MixField', sys%scf%mix_field, "what to mix during SCF cycles", namespace=sys%namespace)
- if (scf%mix_field == OPTION__MIXFIELD__POTENTIAL .and. hm%theory_level == INDEPENDENT_PARTICLES) then
+ if (sys%scf%mix_field == OPTION__MIXFIELD__POTENTIAL .and. sys%hm%theory_level == INDEPENDENT_PARTICLES) then
call messages_write('Input: Cannot mix the potential for non-interacting particles.')
- call messages_fatal(namespace=namespace)
+ call messages_fatal(namespace=sys%namespace)
end if
- if (scf%mix_field == OPTION__MIXFIELD__POTENTIAL .and. hm%pcm%run_pcm) then
+ if (sys%scf%mix_field == OPTION__MIXFIELD__POTENTIAL .and. sys%hm%pcm%run_pcm) then
call messages_write('Input: You have selected to mix the potential.', new_line = .true.)
call messages_write(' This might produce convergence problems for solvated systems.', new_line = .true.)
call messages_write(' Mix the Density instead.')
- call messages_warning(namespace=namespace)
+ call messages_warning(namespace=sys%namespace)
end if
- if(scf%mix_field == OPTION__MIXFIELD__DENSITY &
- .and. bitand(hm%xc%family, XC_FAMILY_OEP + XC_FAMILY_MGGA + XC_FAMILY_HYB_MGGA) /= 0) then
+ if(sys%scf%mix_field == OPTION__MIXFIELD__DENSITY &
+ .and. bitand(sys%hm%xc%family, XC_FAMILY_OEP + XC_FAMILY_MGGA + XC_FAMILY_HYB_MGGA) /= 0) then
call messages_write('Input: You have selected to mix the density with OEP or MGGA XC functionals.', new_line = .true.)
call messages_write(' This might produce convergence problems. Mix the potential instead.')
- call messages_warning(namespace=namespace)
+ call messages_warning(namespace=sys%namespace)
end if
- if(scf%mix_field == OPTION__MIXFIELD__STATES) then
- call messages_experimental('MixField = states', namespace=namespace)
+ if(sys%scf%mix_field == OPTION__MIXFIELD__STATES) then
+ call messages_experimental('MixField = states', namespace=sys%namespace)
end if
! Handle mixing now...
- select case(scf%mix_field)
+ select case(sys%scf%mix_field)
case (OPTION__MIXFIELD__POTENTIAL, OPTION__MIXFIELD__DENSITY)
- scf%mixdim1 = gr%np
+ sys%scf%mixdim1 = sys%gr%np
case(OPTION__MIXFIELD__STATES)
! we do not really need the mixer, except for the value of the mixing coefficient
- scf%mixdim1 = 1
+ sys%scf%mixdim1 = 1
end select
mix_type = TYPE_FLOAT
- if (scf%mix_field /= OPTION__MIXFIELD__NONE) then
- call mix_init(scf%smix, namespace, space, gr%der, scf%mixdim1, st%d%nspin, func_type_ = mix_type)
+ if (sys%scf%mix_field /= OPTION__MIXFIELD__NONE) then
+ call mix_init(sys%scf%smix, sys%namespace, sys%space, sys%gr%der, sys%scf%mixdim1, sys%st%d%nspin, func_type_ = mix_type)
end if
!If we use DFT+U, we also have do mix it
- if (scf%mix_field /= OPTION__MIXFIELD__STATES .and. scf%mix_field /= OPTION__MIXFIELD__NONE ) then
- call lda_u_mixer_init(hm%lda_u, scf%lda_u_mix, st)
- call lda_u_mixer_init_auxmixer(hm%lda_u, namespace, scf%lda_u_mix, scf%smix, st)
+ if (sys%scf%mix_field /= OPTION__MIXFIELD__STATES .and. sys%scf%mix_field /= OPTION__MIXFIELD__NONE ) then
+ call lda_u_mixer_init(sys%hm%lda_u, sys%scf%lda_u_mix, sys%st)
+ call lda_u_mixer_init_auxmixer(sys%hm%lda_u, sys%namespace, sys%scf%lda_u_mix, sys%scf%smix, sys%st)
end if
- call mix_get_field(scf%smix, scf%mixfield)
+ call mix_get_field(sys%scf%smix, sys%scf%mixfield)
! now the eigensolver stuff
- call eigensolver_init(scf%eigens, namespace, gr, st, mc, space)
+ call eigensolver_init(sys%scf%eigens, sys%namespace, sys%gr, sys%st, sys%mc, sys%space)
!The evolution operator is a very specific propagation that requires a specific
!setting to work in the current framework
- if(scf%eigens%es_type == RS_EVO) then
- if(scf%mix_field /= OPTION__MIXFIELD__DENSITY) then
+ if(sys%scf%eigens%es_type == RS_EVO) then
+ if(sys%scf%mix_field /= OPTION__MIXFIELD__DENSITY) then
message(1) = "Evolution eigensolver is only compatible with MixField = density."
- call messages_fatal(1, namespace=namespace)
+ call messages_fatal(1, namespace=sys%namespace)
end if
- if(.not. is_close(mix_coefficient(scf%smix), M_ONE)) then
+ if(.not. is_close(mix_coefficient(sys%scf%smix), M_ONE)) then
message(1) = "Evolution eigensolver is only compatible with Mixing = 1."
- call messages_fatal(1, namespace=namespace)
+ call messages_fatal(1, namespace=sys%namespace)
end if
- if(mix_scheme(scf%smix) /= OPTION__MIXINGSCHEME__LINEAR) then
+ if(mix_scheme(sys%scf%smix) /= OPTION__MIXINGSCHEME__LINEAR) then
message(1) = "Evolution eigensolver is only compatible with MixingScheme = linear."
- call messages_fatal(1, namespace=namespace)
+ call messages_fatal(1, namespace=sys%namespace)
end if
end if
@@ -335,15 +268,15 @@ contains
!% calculation within the LCAO subspace, then restart from that point for
!% an unrestricted calculation).
!%End
- call parse_variable(namespace, 'SCFinLCAO', .false., scf%lcao_restricted)
- if(scf%lcao_restricted) then
- call messages_experimental('SCFinLCAO', namespace=namespace)
+ call parse_variable(sys%namespace, 'SCFinLCAO', .false., sys%scf%lcao_restricted)
+ if(sys%scf%lcao_restricted) then
+ call messages_experimental('SCFinLCAO', namespace=sys%namespace)
message(1) = 'Info: SCF restricted to LCAO subspace.'
- call messages_info(1, namespace=namespace)
+ call messages_info(1, namespace=sys%namespace)
- if(scf%conv_eigen_error) then
+ if(sys%scf%conv_eigen_error) then
message(1) = "ConvEigenError cannot be used with SCFinLCAO, since error is unknown."
- call messages_fatal(1, namespace=namespace)
+ call messages_fatal(1, namespace=sys%namespace)
end if
end if
@@ -357,19 +290,19 @@ contains
!% default is yes, unless the system only has user-defined
!% species.
!%End
- call parse_variable(namespace, 'SCFCalculateForces', .not. ions%only_user_def, scf%calc_force)
+ call parse_variable(sys%namespace, 'SCFCalculateForces', .not. sys%ions%only_user_def, sys%scf%calc_force)
- if(scf%calc_force .and. gr%der%boundaries%spiralBC) then
+ if(sys%scf%calc_force .and. sys%gr%der%boundaries%spiralBC) then
message(1) = 'Forces cannot be calculated when using spiral boundary conditions.'
write(message(2),'(a)') 'Please use SCFCalculateForces = no.'
- call messages_fatal(2, namespace=namespace)
+ call messages_fatal(2, namespace=sys%namespace)
end if
- if(scf%calc_force) then
- if (allocated(hm%ep%b_field) .or. allocated(hm%ep%a_static)) then
+ if(sys%scf%calc_force) then
+ if (allocated(sys%hm%ep%b_field) .or. allocated(sys%hm%ep%a_static)) then
write(message(1),'(a)') 'The forces are currently not properly calculated if static'
write(message(2),'(a)') 'magnetic fields or static vector potentials are present.'
write(message(3),'(a)') 'Please use SCFCalculateForces = no.'
- call messages_fatal(3, namespace=namespace)
+ call messages_fatal(3, namespace=sys%namespace)
end if
end if
@@ -381,7 +314,7 @@ contains
!% calculated at the end of a self-consistent iteration. The
!% default is no.
!%End
- call parse_variable(namespace, 'SCFCalculateStress', .false. , scf%calc_stress)
+ call parse_variable(sys%namespace, 'SCFCalculateStress', .false. , sys%scf%calc_stress)
!%Variable SCFCalculateDipole
!%Type logical
@@ -395,8 +328,8 @@ contains
!% periodic directions. Ref:
!% E Yaschenko, L Fu, L Resca, and R Resta, Phys. Rev. B 58, 1222-1229 (1998).
!%End
- call parse_variable(namespace, 'SCFCalculateDipole', .not. space%is_periodic(), scf%calc_dipole)
- if (allocated(hm%vberry)) scf%calc_dipole = .true.
+ call parse_variable(sys%namespace, 'SCFCalculateDipole', .not. sys%space%is_periodic(), sys%scf%calc_dipole)
+ if (allocated(sys%hm%vberry)) sys%scf%calc_dipole = .true.
!%Variable SCFCalculatePartialCharges
!%Type logical
@@ -406,10 +339,10 @@ contains
!% (Experimental) This variable controls whether partial charges
!% are calculated at the end of a self-consistent iteration.
!%End
- call parse_variable(namespace, 'SCFCalculatePartialCharges', .false., scf%calc_partial_charges)
- if (scf%calc_partial_charges) call messages_experimental('SCFCalculatePartialCharges', namespace=namespace)
+ call parse_variable(sys%namespace, 'SCFCalculatePartialCharges', .false., sys%scf%calc_partial_charges)
+ if (sys%scf%calc_partial_charges) call messages_experimental('SCFCalculatePartialCharges', namespace=sys%namespace)
- rmin = ions%min_distance()
+ rmin = sys%ions%min_distance()
!%Variable LocalMagneticMomentsSphereRadius
!%Type float
@@ -421,34 +354,34 @@ contains
!% The default is half the minimum distance between two atoms
!% in the input coordinates, or 100 a.u. if there is only one atom (for isolated systems).
!%End
- call parse_variable(namespace, 'LocalMagneticMomentsSphereRadius', min(M_HALF*rmin, 100.0_real64), scf%lmm_r, &
+ call parse_variable(sys%namespace, 'LocalMagneticMomentsSphereRadius', min(M_HALF*rmin, 100.0_real64), sys%scf%lmm_r, &
unit=units_inp%length)
! this variable is also used in td/td_write.F90
- scf%forced_finish = .false.
+ sys%scf%forced_finish = .false.
POP_SUB(scf_init)
end subroutine scf_init
! ---------------------------------------------------------
- subroutine scf_end(scf)
- type(scf_t), intent(inout) :: scf
+ module subroutine scf_end(sys)
+ type(electrons_t), intent(inout) :: sys
class(convergence_criterion_t), pointer :: crit
type(criterion_iterator_t) :: iter
PUSH_SUB(scf_end)
- call eigensolver_end(scf%eigens)
+ call eigensolver_end(sys%scf%eigens)
- if(scf%mix_field /= OPTION__MIXFIELD__NONE) call mix_end(scf%smix)
+ if(sys%scf%mix_field /= OPTION__MIXFIELD__NONE) call mix_end(sys%scf%smix)
- nullify(scf%mixfield)
+ nullify(sys%scf%mixfield)
- if(scf%mix_field /= OPTION__MIXFIELD__STATES) call lda_u_mixer_end(scf%lda_u_mix, scf%smix)
+ if(sys%scf%mix_field /= OPTION__MIXFIELD__STATES) call lda_u_mixer_end(sys%scf%lda_u_mix, sys%scf%smix)
- call iter%start(scf%criterion_list)
+ call iter%start(sys%scf%criterion_list)
do while (iter%has_next())
crit => iter%get_next()
SAFE_DEALLOCATE_P(crit)
@@ -459,37 +392,25 @@ contains
! ---------------------------------------------------------
- subroutine scf_mix_clear(scf)
- type(scf_t), intent(inout) :: scf
+ module subroutine scf_mix_clear(sys)
+ type(electrons_t), intent(inout) :: sys
PUSH_SUB(scf_mix_clear)
- call mix_clear(scf%smix)
+ call mix_clear(sys%scf%smix)
- if(scf%mix_field /= OPTION__MIXFIELD__STATES) call lda_u_mixer_clear(scf%lda_u_mix, scf%smix)
+ if(sys%scf%mix_field /= OPTION__MIXFIELD__STATES) call lda_u_mixer_clear(sys%scf%lda_u_mix, sys%scf%smix)
POP_SUB(scf_mix_clear)
end subroutine scf_mix_clear
! ---------------------------------------------------------
- subroutine scf_run(scf, namespace, space, mc, gr, ions, ext_partners, st, ks, hm, outp, &
- verbosity, iters_done, restart_load, restart_dump)
- type(scf_t), intent(inout) :: scf !< self consistent cycle
- type(namespace_t), intent(in) :: namespace
- type(electron_space_t), intent(in) :: space
- type(multicomm_t), intent(in) :: mc
- type(grid_t), intent(inout) :: gr !< grid
- type(ions_t), intent(inout) :: ions !< geometry
- type(partner_list_t), intent(in) :: ext_partners
- type(states_elec_t), intent(inout) :: st !< States
- type(v_ks_t), intent(inout) :: ks !< Kohn-Sham
- type(hamiltonian_elec_t), intent(inout) :: hm !< Hamiltonian
+ module subroutine scf_run(sys, outp, verbosity, iters_done)
+ type(electrons_t), intent(inout) :: sys
type(output_t), optional, intent(in) :: outp
integer, optional, intent(in) :: verbosity
integer, optional, intent(out) :: iters_done
- type(restart_t), optional, intent(in) :: restart_load
- type(restart_t), optional, intent(in) :: restart_dump
logical :: finish, converged_current, converged_last
integer :: iter, is, nspin, ierr, verbosity_, ib, iqn
@@ -506,9 +427,9 @@ contains
PUSH_SUB(scf_run)
- if(scf%forced_finish) then
+ if(sys%scf%forced_finish) then
message(1) = "Previous clean stop, not doing SCF and quitting."
- call messages_fatal(1, only_root_writes = .true., namespace=namespace)
+ call messages_fatal(1, only_root_writes = .true., namespace=sys%namespace)
end if
verbosity_ = VERB_FULL
@@ -522,78 +443,78 @@ contains
! if the user has activated output=stress but not SCFCalculateStress,
! we assume that is implied
if (outp%what(OPTION__OUTPUT__STRESS)) then
- scf%calc_stress = .true.
+ sys%scf%calc_stress = .true.
end if
output_during_scf = outp%duringscf
- calc_current = output_needs_current(outp, states_are_real(st))
+ calc_current = output_needs_current(outp, states_are_real(sys%st))
if (outp%duringscf .and. outp%what(OPTION__OUTPUT__FORCES)) then
output_forces = .true.
end if
end if
- if(scf%lcao_restricted) then
- call lcao_init(lcao, namespace, space, gr, ions, st)
+ if(sys%scf%lcao_restricted) then
+ call lcao_init(lcao, sys%namespace, sys%space, sys%gr, sys%ions, sys%st)
if(.not. lcao_is_available(lcao)) then
message(1) = 'LCAO is not available. Cannot do SCF in LCAO.'
- call messages_fatal(1, namespace=namespace)
+ call messages_fatal(1, namespace=sys%namespace)
end if
end if
- nspin = st%d%nspin
+ nspin = sys%st%d%nspin
- if (present(restart_load)) then
- if (restart_has_flag(restart_load, RESTART_FLAG_RHO)) then
+ if (allocated(sys%scf%restart_load)) then
+ if (restart_has_flag(sys%scf%restart_load, RESTART_FLAG_RHO)) then
! Load density and used it to recalculated the KS potential.
- call states_elec_load_rho(restart_load, space, st, gr, ierr)
+ call states_elec_load_rho(sys%scf%restart_load, sys%space, sys%st, sys%gr, ierr)
if (ierr /= 0) then
message(1) = 'Unable to read density. Density will be calculated from states.'
- call messages_warning(1, namespace=namespace)
+ call messages_warning(1, namespace=sys%namespace)
else
- if (bitand(ks%xc_family, XC_FAMILY_OEP) == 0) then
- call v_ks_calc(ks, namespace, space, hm, st, ions, ext_partners)
+ if (bitand(sys%ks%xc_family, XC_FAMILY_OEP) == 0) then
+ call v_ks_calc(sys%ks, sys%namespace, sys%space, sys%hm, sys%st, sys%ions, sys%ext_partners)
else
- if (.not. restart_has_flag(restart_load, RESTART_FLAG_VHXC) .and. ks%oep%level /= OEP_LEVEL_FULL) then
- call v_ks_calc(ks, namespace, space, hm, st, ions, ext_partners)
+ if (.not. restart_has_flag(sys%scf%restart_load, RESTART_FLAG_VHXC) .and. sys%ks%oep%level /= OEP_LEVEL_FULL) then
+ call v_ks_calc(sys%ks, sys%namespace, sys%space, sys%hm, sys%st, sys%ions, sys%ext_partners)
end if
end if
end if
end if
- if (restart_has_flag(restart_load, RESTART_FLAG_VHXC)) then
- call hamiltonian_elec_load_vhxc(restart_load, hm, space, gr, ierr)
+ if (restart_has_flag(sys%scf%restart_load, RESTART_FLAG_VHXC)) then
+ call hamiltonian_elec_load_vhxc(sys%scf%restart_load, sys%hm, sys%space, sys%gr, ierr)
if (ierr /= 0) then
message(1) = 'Unable to read Vhxc. Vhxc will be calculated from states.'
- call messages_warning(1, namespace=namespace)
+ call messages_warning(1, namespace=sys%namespace)
else
- call hm%update(gr, namespace, space, ext_partners)
- if (bitand(ks%xc_family, XC_FAMILY_OEP) /= 0) then
- if (ks%oep%level == OEP_LEVEL_FULL) then
- do is = 1, st%d%nspin
- ks%oep%vxc(1:gr%np, is) = hm%vhxc(1:gr%np, is) - hm%vhartree(1:gr%np)
+ call sys%hm%update(sys%gr, sys%namespace, sys%space, sys%ext_partners)
+ if (bitand(sys%ks%xc_family, XC_FAMILY_OEP) /= 0) then
+ if (sys%ks%oep%level == OEP_LEVEL_FULL) then
+ do is = 1, sys%st%d%nspin
+ sys%ks%oep%vxc(1:sys%gr%np, is) = sys%hm%vhxc(1:sys%gr%np, is) - sys%hm%vhartree(1:sys%gr%np)
end do
- call v_ks_calc(ks, namespace, space, hm, st, ions, ext_partners)
+ call v_ks_calc(sys%ks, sys%namespace, sys%space, sys%hm, sys%st, sys%ions, sys%ext_partners)
end if
end if
end if
end if
- if (restart_has_flag(restart_load, RESTART_FLAG_MIX)) then
- if (scf%mix_field == OPTION__MIXFIELD__DENSITY .or. scf%mix_field == OPTION__MIXFIELD__POTENTIAL) then
- call mix_load(namespace, restart_load, scf%smix, space, gr, ierr)
+ if (restart_has_flag(sys%scf%restart_load, RESTART_FLAG_MIX)) then
+ if (sys%scf%mix_field == OPTION__MIXFIELD__DENSITY .or. sys%scf%mix_field == OPTION__MIXFIELD__POTENTIAL) then
+ call mix_load(sys%namespace, sys%scf%restart_load, sys%scf%smix, sys%space, sys%gr, ierr)
end if
if (ierr /= 0) then
message(1) = "Unable to read mixing information. Mixing will start from scratch."
- call messages_warning(1, namespace=namespace)
+ call messages_warning(1, namespace=sys%namespace)
end if
end if
- if(hm%lda_u_level /= DFT_U_NONE) then
- call lda_u_load(restart_load, hm%lda_u, st, hm%energy%dft_u, ierr)
+ if(sys%hm%lda_u_level /= DFT_U_NONE) then
+ call lda_u_load(sys%scf%restart_load, sys%hm%lda_u, sys%st, sys%hm%energy%dft_u, ierr)
if (ierr /= 0) then
message(1) = "Unable to read DFT+U information. DFT+U data will be calculated from states."
- call messages_warning(1, namespace=namespace)
+ call messages_warning(1, namespace=sys%namespace)
end if
end if
else
@@ -602,157 +523,158 @@ contains
end if
end if
- SAFE_ALLOCATE(rhoout(1:gr%np, 1:nspin))
- SAFE_ALLOCATE(rhoin (1:gr%np, 1:nspin))
+ SAFE_ALLOCATE(rhoout(1:sys%gr%np, 1:nspin))
+ SAFE_ALLOCATE(rhoin (1:sys%gr%np, 1:nspin))
- call lalg_copy(gr%np, nspin, st%rho, rhoin)
+ call lalg_copy(sys%gr%np, nspin, sys%st%rho, rhoin)
rhoout = M_ZERO
- if (scf%calc_force .or. output_forces) then
+ if (sys%scf%calc_force .or. output_forces) then
!We store the Hxc potential for the contribution to the forces
- SAFE_ALLOCATE(vhxc_old(1:gr%np, 1:nspin))
- call lalg_copy(gr%np, nspin, hm%vhxc, vhxc_old)
+ SAFE_ALLOCATE(vhxc_old(1:sys%gr%np, 1:nspin))
+ call lalg_copy(sys%gr%np, nspin, sys%hm%vhxc, vhxc_old)
end if
- select case(scf%mix_field)
+ select case(sys%scf%mix_field)
case(OPTION__MIXFIELD__POTENTIAL)
- call mixfield_set_vin(scf%mixfield, hm%vhxc)
+ call mixfield_set_vin(sys%scf%mixfield, sys%hm%vhxc)
case(OPTION__MIXFIELD__DENSITY)
- call mixfield_set_vin(scf%mixfield, rhoin)
+ call mixfield_set_vin(sys%scf%mixfield, rhoin)
case(OPTION__MIXFIELD__STATES)
- SAFE_ALLOCATE_TYPE_ARRAY(wfs_elec_t, psioutb, (st%group%block_start:st%group%block_end, st%d%kpt%start:st%d%kpt%end))
+ SAFE_ALLOCATE_TYPE_ARRAY(wfs_elec_t, psioutb, (sys%st%group%block_start:sys%st%group%block_end, sys%st%d%kpt%start:sys%st%d%kpt%end))
- do iqn = st%d%kpt%start, st%d%kpt%end
- do ib = st%group%block_start, st%group%block_end
- call st%group%psib(ib, iqn)%copy_to(psioutb(ib, iqn))
+ do iqn = sys%st%d%kpt%start, sys%st%d%kpt%end
+ do ib = sys%st%group%block_start, sys%st%group%block_end
+ call sys%st%group%psib(ib, iqn)%copy_to(psioutb(ib, iqn))
end do
end do
end select
- call lda_u_update_occ_matrices(hm%lda_u, namespace, gr, st, hm%hm_base, hm%phase, hm%energy)
+ call lda_u_update_occ_matrices(sys%hm%lda_u, sys%namespace, sys%gr, sys%st, sys%hm%hm_base, sys%hm%phase, sys%hm%energy)
! If we use DFT+U, we also have do mix it
- if (scf%mix_field /= OPTION__MIXFIELD__STATES) call lda_u_mixer_set_vin(hm%lda_u, scf%lda_u_mix)
+ if (sys%scf%mix_field /= OPTION__MIXFIELD__STATES) call lda_u_mixer_set_vin(sys%hm%lda_u, sys%scf%lda_u_mix)
call create_convergence_file(STATIC_DIR, "convergence")
if ( verbosity_ /= VERB_NO ) then
- if(scf%max_iter > 0) then
+ if(sys%scf%max_iter > 0) then
write(message(1),'(a)') 'Info: Starting SCF iteration.'
else
write(message(1),'(a)') 'Info: No SCF iterations will be done.'
! we cannot tell whether it is converged.
finish = .false.
end if
- call messages_info(1, namespace=namespace)
+ call messages_info(1, namespace=sys%namespace)
end if
converged_current = .false.
- scf%matvec = 0
+ sys%scf%matvec = 0
! SCF cycle
itime = loct_clock()
- do iter = 1, scf%max_iter
+ do iter = 1, sys%scf%max_iter
call profiling_in("SCF_CYCLE")
! this initialization seems redundant but avoids improper optimization at -O3 by PGI 7 on chum,
! which would cause a failure of testsuite/linear_response/04-vib_modes.03-vib_modes_fd.inp
- scf%eigens%converged = 0
+ sys%scf%eigens%converged = 0
- !We update the quantities at the begining of the scf cycle
+ !We update the quantities at the begining of the sys%scf cycle
if (iter == 1) then
- scf%evsum_in = states_elec_eigenvalues_sum(st)
+ sys%scf%evsum_in = states_elec_eigenvalues_sum(sys%st)
end if
- call iterator%start(scf%criterion_list)
+ call iterator%start(sys%scf%criterion_list)
do while (iterator%has_next())
crit => iterator%get_next()
- call scf_update_initial_quantity(scf, hm, crit)
+ call scf_update_initial_quantity(sys%scf, sys%hm, crit)
end do
- if (scf%calc_force .or. output_forces) then
+ if (sys%scf%calc_force .or. output_forces) then
!Used for computing the imperfect convegence contribution to the forces
- vhxc_old(1:gr%np, 1:nspin) = hm%vhxc(1:gr%np, 1:nspin)
+ vhxc_old(1:sys%gr%np, 1:nspin) = sys%hm%vhxc(1:sys%gr%np, 1:nspin)
end if
- if(scf%lcao_restricted) then
- call lcao_init_orbitals(lcao, namespace, st, gr, ions)
- call lcao_wf(lcao, st, gr, ions, hm, namespace)
+ if(sys%scf%lcao_restricted) then
+ call lcao_init_orbitals(lcao, sys%namespace, sys%st, sys%gr, sys%ions)
+ call lcao_wf(lcao, sys%st, sys%gr, sys%ions, sys%hm, sys%namespace)
else
!We check if the system is coupled with a partner that requires self-consistency
- ! if(hamiltonian_has_scf_partner(hm)) then
- if (allocated(hm%vberry)) then
+ ! if(hamiltonian_has_scf_partner(sys%hm)) then
+ if (allocated(sys%hm%vberry)) then
!In this case, v_Hxc is frozen and we do an internal SCF loop over the
! partners that require SCF
- ks%frozen_hxc = .true.
+ sys%ks%frozen_hxc = .true.
! call perform_scf_partners()
- call berry_perform_internal_scf(scf%berry, namespace, space, scf%eigens, gr, st, hm, iter, ks, ions, ext_partners)
+ call berry_perform_internal_scf(sys%scf%berry, sys%namespace, sys%space, sys%scf%eigens, &
+ sys%gr, sys%st, sys%hm, iter, sys%ks, sys%ions, sys%ext_partners)
!and we unfreeze the potential once finished
- ks%frozen_hxc = .false.
+ sys%ks%frozen_hxc = .false.
else
- scf%eigens%converged = 0
- call scf%eigens%run(namespace, gr, st, hm, iter)
+ sys%scf%eigens%converged = 0
+ call sys%scf%eigens%run(sys%namespace, sys%gr, sys%st, sys%hm, iter)
end if
end if
- scf%matvec = scf%matvec + scf%eigens%matvec
+ sys%scf%matvec = sys%scf%matvec + sys%scf%eigens%matvec
! occupations
- call states_elec_fermi(st, namespace, gr)
- call lda_u_update_occ_matrices(hm%lda_u, namespace, gr, st, hm%hm_base, hm%phase, hm%energy)
+ call states_elec_fermi(sys%st, sys%namespace, sys%gr)
+ call lda_u_update_occ_matrices(sys%hm%lda_u, sys%namespace, sys%gr, sys%st, sys%hm%hm_base, sys%hm%phase, sys%hm%energy)
! compute output density, potential (if needed) and eigenvalues sum
- call density_calc(st, gr, st%rho)
+ call density_calc(sys%st, sys%gr, sys%st%rho)
- call lalg_copy(gr%np, nspin, st%rho, rhoout)
+ call lalg_copy(sys%gr%np, nspin, sys%st%rho, rhoout)
- select case (scf%mix_field)
+ select case (sys%scf%mix_field)
case (OPTION__MIXFIELD__POTENTIAL)
- call v_ks_calc(ks, namespace, space, hm, st, ions, ext_partners, calc_current=output_during_scf)
- call mixfield_set_vout(scf%mixfield, hm%vhxc)
+ call v_ks_calc(sys%ks, sys%namespace, sys%space, sys%hm, sys%st, sys%ions, sys%ext_partners, calc_current=output_during_scf)
+ call mixfield_set_vout(sys%scf%mixfield, sys%hm%vhxc)
case (OPTION__MIXFIELD__DENSITY)
- call mixfield_set_vout(scf%mixfield, rhoout)
+ call mixfield_set_vout(sys%scf%mixfield, rhoout)
case(OPTION__MIXFIELD__STATES)
- do iqn = st%d%kpt%start, st%d%kpt%end
- do ib = st%group%block_start, st%group%block_end
- call st%group%psib(ib, iqn)%copy_data_to(gr%np, psioutb(ib, iqn))
+ do iqn = sys%st%d%kpt%start, sys%st%d%kpt%end
+ do ib = sys%st%group%block_start, sys%st%group%block_end
+ call sys%st%group%psib(ib, iqn)%copy_data_to(sys%gr%np, psioutb(ib, iqn))
end do
end do
end select
- if (scf%mix_field /= OPTION__MIXFIELD__STATES .and. scf%mix_field /= OPTION__MIXFIELD__NONE) then
- call lda_u_mixer_set_vout(hm%lda_u, scf%lda_u_mix)
+ if (sys%scf%mix_field /= OPTION__MIXFIELD__STATES .and. sys%scf%mix_field /= OPTION__MIXFIELD__NONE) then
+ call lda_u_mixer_set_vout(sys%hm%lda_u, sys%scf%lda_u_mix)
endif
! recalculate total energy
- call energy_calc_total(namespace, space, hm, gr, st, ext_partners, iunit = 0)
+ call energy_calc_total(sys%namespace, sys%space, sys%hm, sys%gr, sys%st, sys%ext_partners, iunit = 0)
if (present(outp)) then
! compute forces only if requested
if (outp%duringscf .and. outp%what_now(OPTION__OUTPUT__FORCES, iter)) then
- call forces_calculate(gr, namespace, ions, hm, ext_partners, st, ks, vhxc_old=vhxc_old)
+ call forces_calculate(sys%gr, sys%namespace, sys%ions, sys%hm, sys%ext_partners, sys%st, sys%ks, vhxc_old=vhxc_old)
end if
end if
!We update the quantities at the end of the scf cycle
- call iterator%start(scf%criterion_list)
+ call iterator%start(sys%scf%criterion_list)
do while (iterator%has_next())
crit => iterator%get_next()
- call scf_update_diff_quantity(scf, hm, st, gr, rhoout, rhoin, crit)
+ call scf_update_diff_quantity(sys%scf, sys%hm, sys%st, sys%gr, rhoout, rhoin, crit)
end do
! are we finished?
converged_last = converged_current
- converged_current = scf%check_conv .and. &
- (.not. scf%conv_eigen_error .or. all(scf%eigens%converged == st%nst))
+ converged_current = sys%scf%check_conv .and. &
+ (.not. sys%scf%conv_eigen_error .or. all(sys%scf%eigens%converged == sys%st%nst))
!Loop over the different criteria
- call iterator%start(scf%criterion_list)
+ call iterator%start(sys%scf%criterion_list)
do while (iterator%has_next())
crit => iterator%get_next()
call crit%is_converged(is_crit_conv)
@@ -765,97 +687,97 @@ contains
etime = loct_clock() - itime
itime = etime + itime
- call scf_write_iter(namespace)
+ call scf_write_iter(sys%namespace)
! mixing
- select case (scf%mix_field)
+ select case (sys%scf%mix_field)
case (OPTION__MIXFIELD__DENSITY)
! mix input and output densities and compute new potential
- call mixing(namespace, scf%smix)
- call mixfield_get_vnew(scf%mixfield, st%rho)
+ call mixing(sys%namespace, sys%scf%smix)
+ call mixfield_get_vnew(sys%scf%mixfield, sys%st%rho)
! for spinors, having components 3 or 4 be negative is not unphysical
- if (minval(st%rho(1:gr%np, 1:st%d%spin_channels)) < -1e-6_real64) then
+ if (minval(sys%st%rho(1:sys%gr%np, 1:sys%st%d%spin_channels)) < -1e-6_real64) then
write(message(1),*) 'Negative density after mixing. Minimum value = ', &
- minval(st%rho(1:gr%np, 1:st%d%spin_channels))
- call messages_warning(1, namespace=namespace)
+ minval(sys%st%rho(1:sys%gr%np, 1:sys%st%d%spin_channels))
+ call messages_warning(1, namespace=sys%namespace)
end if
- call lda_u_mixer_get_vnew(hm%lda_u, scf%lda_u_mix, st)
- call v_ks_calc(ks, namespace, space, hm, st, ions, ext_partners, calc_current=output_during_scf)
+ call lda_u_mixer_get_vnew(sys%hm%lda_u, sys%scf%lda_u_mix, sys%st)
+ call v_ks_calc(sys%ks, sys%namespace, sys%space, sys%hm, sys%st, sys%ions, sys%ext_partners, calc_current=output_during_scf)
case (OPTION__MIXFIELD__POTENTIAL)
! mix input and output potentials
- call mixing(namespace, scf%smix)
- call mixfield_get_vnew(scf%mixfield, hm%vhxc)
- call lda_u_mixer_get_vnew(hm%lda_u, scf%lda_u_mix, st)
- call hamiltonian_elec_update_pot(hm, gr)
+ call mixing(sys%namespace, sys%scf%smix)
+ call mixfield_get_vnew(sys%scf%mixfield, sys%hm%vhxc)
+ call lda_u_mixer_get_vnew(sys%hm%lda_u, sys%scf%lda_u_mix, sys%st)
+ call hamiltonian_elec_update_pot(sys%hm, sys%gr)
case(OPTION__MIXFIELD__STATES)
- do iqn = st%d%kpt%start, st%d%kpt%end
- do ib = st%group%block_start, st%group%block_end
- call batch_scal(gr%np, M_ONE - mix_coefficient(scf%smix), st%group%psib(ib, iqn))
- call batch_axpy(gr%np, mix_coefficient(scf%smix), psioutb(ib, iqn), st%group%psib(ib, iqn))
+ do iqn = sys%st%d%kpt%start, sys%st%d%kpt%end
+ do ib = sys%st%group%block_start, sys%st%group%block_end
+ call batch_scal(sys%gr%np, M_ONE - mix_coefficient(sys%scf%smix), sys%st%group%psib(ib, iqn))
+ call batch_axpy(sys%gr%np, mix_coefficient(sys%scf%smix), psioutb(ib, iqn), sys%st%group%psib(ib, iqn))
end do
end do
- call density_calc(st, gr, st%rho)
- call v_ks_calc(ks, namespace, space, hm, st, ions, ext_partners, calc_current=output_during_scf)
+ call density_calc(sys%st, sys%gr, sys%st%rho)
+ call v_ks_calc(sys%ks, sys%namespace, sys%space, sys%hm, sys%st, sys%ions, sys%ext_partners, calc_current=output_during_scf)
case (OPTION__MIXFIELD__NONE)
- call v_ks_calc(ks, namespace, space, hm, st, ions, ext_partners, calc_current=output_during_scf)
+ call v_ks_calc(sys%ks, sys%namespace, sys%space, sys%hm, sys%st, sys%ions, sys%ext_partners, calc_current=output_during_scf)
end select
! Are we asked to stop? (Whenever Fortran is ready for signals, this should go away)
- scf%forced_finish = clean_stop(mc%master_comm) .or. walltimer_alarm(mc%master_comm)
+ sys%scf%forced_finish = clean_stop(sys%mc%master_comm) .or. walltimer_alarm(sys%mc%master_comm)
- if (finish .and. st%modelmbparticles%nparticle > 0) then
- call modelmb_sym_all_states(space, gr, st)
+ if (finish .and. sys%st%modelmbparticles%nparticle > 0) then
+ call modelmb_sym_all_states(sys%space, sys%gr, sys%st)
end if
- if (present(outp) .and. present(restart_dump)) then
+ if (present(outp) .and. allocated(sys%scf%restart_dump)) then
! save restart information
if ( (finish .or. (modulo(iter, outp%restart_write_interval) == 0) &
- .or. iter == scf%max_iter .or. scf%forced_finish) ) then
+ .or. iter == sys%scf%max_iter .or. sys%scf%forced_finish) ) then
- call states_elec_dump(restart_dump, space, st, gr, hm%kpoints, ierr, iter=iter)
+ call states_elec_dump(sys%scf%restart_dump, sys%space, sys%st, sys%gr, sys%hm%kpoints, ierr, iter=iter)
if (ierr /= 0) then
message(1) = 'Unable to write states wavefunctions.'
- call messages_warning(1, namespace=namespace)
+ call messages_warning(1, namespace=sys%namespace)
end if
- call states_elec_dump_rho(restart_dump, space, st, gr, ierr, iter=iter)
+ call states_elec_dump_rho(sys%scf%restart_dump, sys%space, sys%st, sys%gr, ierr, iter=iter)
if (ierr /= 0) then
message(1) = 'Unable to write density.'
- call messages_warning(1, namespace=namespace)
+ call messages_warning(1, namespace=sys%namespace)
end if
- if(hm%lda_u_level /= DFT_U_NONE) then
- call lda_u_dump(restart_dump, namespace, hm%lda_u, st, gr, ierr)
+ if(sys%hm%lda_u_level /= DFT_U_NONE) then
+ call lda_u_dump(sys%scf%restart_dump, sys%namespace, sys%hm%lda_u, sys%st, sys%gr, ierr)
if (ierr /= 0) then
message(1) = 'Unable to write DFT+U information.'
- call messages_warning(1, namespace=namespace)
+ call messages_warning(1, namespace=sys%namespace)
end if
end if
- select case (scf%mix_field)
+ select case (sys%scf%mix_field)
case (OPTION__MIXFIELD__DENSITY)
- call mix_dump(namespace, restart_dump, scf%smix, space, gr, ierr)
+ call mix_dump(sys%namespace, sys%scf%restart_dump, sys%scf%smix, sys%space, sys%gr, ierr)
if (ierr /= 0) then
message(1) = 'Unable to write mixing information.'
- call messages_warning(1, namespace=namespace)
+ call messages_warning(1, namespace=sys%namespace)
end if
case (OPTION__MIXFIELD__POTENTIAL)
- call hamiltonian_elec_dump_vhxc(restart_dump, hm, space, gr, ierr)
+ call hamiltonian_elec_dump_vhxc(sys%scf%restart_dump, sys%hm, sys%space, sys%gr, ierr)
if (ierr /= 0) then
message(1) = 'Unable to write Vhxc.'
- call messages_warning(1, namespace=namespace)
+ call messages_warning(1, namespace=sys%namespace)
end if
- call mix_dump(namespace, restart_dump, scf%smix, space, gr, ierr)
+ call mix_dump(sys%namespace, sys%scf%restart_dump, sys%scf%smix, sys%space, sys%gr, ierr)
if (ierr /= 0) then
message(1) = 'Unable to write mixing information.'
- call messages_warning(1, namespace=namespace)
+ call messages_warning(1, namespace=sys%namespace)
end if
end select
end if
@@ -868,7 +790,7 @@ contains
if(verbosity_ >= VERB_COMPACT) then
write(message(1), '(a, i4, a)') 'Info: SCF converged in ', iter, ' iterations'
write(message(2), '(a)') ''
- call messages_info(2, namespace=namespace)
+ call messages_info(2, namespace=sys%namespace)
end if
call profiling_out("SCF_CYCLE")
exit
@@ -878,8 +800,8 @@ contains
do what_i = lbound(outp%what, 1), ubound(outp%what, 1)
if (outp%what_now(what_i, iter)) then
write(dirname,'(a,a,i4.4)') trim(outp%iter_dir),"scf.",iter
- call output_all(outp, namespace, space, dirname, gr, ions, iter, st, hm, ks)
- call output_modelmb(outp, namespace, space, dirname, gr, ions, iter, st)
+ call output_all(outp, sys%namespace, sys%space, dirname, sys%gr, sys%ions, iter, sys%st, sys%hm, sys%ks)
+ call output_modelmb(outp, sys%namespace, sys%space, dirname, sys%gr, sys%ions, iter, sys%st)
exit
end if
end do
@@ -887,50 +809,50 @@ contains
end if
! save information for the next iteration
- call lalg_copy(gr%np, nspin, st%rho, rhoin)
+ call lalg_copy(sys%gr%np, nspin, sys%st%rho, rhoin)
! restart mixing
- if (scf%mix_field /= OPTION__MIXFIELD__NONE) then
- if (scf%smix%ns_restart > 0) then
- if (mod(iter, scf%smix%ns_restart) == 0) then
+ if (sys%scf%mix_field /= OPTION__MIXFIELD__NONE) then
+ if (sys%scf%smix%ns_restart > 0) then
+ if (mod(iter, sys%scf%smix%ns_restart) == 0) then
message(1) = "Info: restarting mixing."
- call messages_info(1, namespace=namespace)
- call scf_mix_clear(scf)
+ call messages_info(1, namespace=sys%namespace)
+ call scf_mix_clear(sys)
end if
end if
end if
- select case(scf%mix_field)
+ select case(sys%scf%mix_field)
case(OPTION__MIXFIELD__POTENTIAL)
- call mixfield_set_vin(scf%mixfield, hm%vhxc(1:gr%np, 1:nspin))
+ call mixfield_set_vin(sys%scf%mixfield, sys%hm%vhxc(1:sys%gr%np, 1:nspin))
case (OPTION__MIXFIELD__DENSITY)
- call mixfield_set_vin(scf%mixfield, rhoin)
+ call mixfield_set_vin(sys%scf%mixfield, rhoin)
end select
- if(scf%mix_field /= OPTION__MIXFIELD__STATES) call lda_u_mixer_set_vin(hm%lda_u, scf%lda_u_mix)
+ if(sys%scf%mix_field /= OPTION__MIXFIELD__STATES) call lda_u_mixer_set_vin(sys%hm%lda_u, sys%scf%lda_u_mix)
- if(scf%forced_finish) then
+ if(sys%scf%forced_finish) then
call profiling_out("SCF_CYCLE")
exit
end if
! check if debug mode should be enabled or disabled on the fly
- call io_debug_on_the_fly(namespace)
+ call io_debug_on_the_fly(sys%namespace)
call profiling_out("SCF_CYCLE")
end do !iter
- if(scf%lcao_restricted) call lcao_end(lcao)
+ if(sys%scf%lcao_restricted) call lcao_end(lcao)
- if ((scf%max_iter > 0 .and. scf%mix_field == OPTION__MIXFIELD__POTENTIAL) .or. calc_current) then
- call v_ks_calc(ks, namespace, space, hm, st, ions, ext_partners, &
+ if ((sys%scf%max_iter > 0 .and. sys%scf%mix_field == OPTION__MIXFIELD__POTENTIAL) .or. calc_current) then
+ call v_ks_calc(sys%ks, sys%namespace, sys%space, sys%hm, sys%st, sys%ions, sys%ext_partners, &
calc_current=calc_current)
end if
- select case(scf%mix_field)
+ select case(sys%scf%mix_field)
case(OPTION__MIXFIELD__STATES)
- do iqn = st%d%kpt%start, st%d%kpt%end
- do ib = st%group%block_start, st%group%block_end
+ do iqn = sys%st%d%kpt%start, sys%st%d%kpt%end
+ do ib = sys%st%group%block_start, sys%st%group%block_end
call psioutb(ib, iqn)%end()
end do
end do
@@ -941,48 +863,48 @@ contains
SAFE_DEALLOCATE_A(rhoout)
SAFE_DEALLOCATE_A(rhoin)
- if(scf%max_iter > 0 .and. any(scf%eigens%converged < st%nst) .and. .not. scf%lcao_restricted) then
+ if(sys%scf%max_iter > 0 .and. any(sys%scf%eigens%converged < sys%st%nst) .and. .not. sys%scf%lcao_restricted) then
write(message(1),'(a)') 'Some of the states are not fully converged!'
- call messages_warning(1, namespace=namespace)
+ call messages_warning(1, namespace=sys%namespace)
end if
if(.not.finish) then
write(message(1), '(a,i4,a)') 'SCF *not* converged after ', iter - 1, ' iterations.'
- call messages_warning(1, namespace=namespace)
+ call messages_warning(1, namespace=sys%namespace)
end if
- write(message(1), '(a,i10)') 'Info: Number of matrix-vector products: ', scf%matvec
+ write(message(1), '(a,i10)') 'Info: Number of matrix-vector products: ', sys%scf%matvec
call messages_info(1)
- if (scf%calc_force) then
- call forces_calculate(gr, namespace, ions, hm, ext_partners, st, ks, vhxc_old=vhxc_old)
+ if (sys%scf%calc_force) then
+ call forces_calculate(sys%gr, sys%namespace, sys%ions, sys%hm, sys%ext_partners, sys%st, sys%ks, vhxc_old=vhxc_old)
end if
- if (scf%calc_stress) call stress_calculate(namespace, gr, hm, st, ions, ks, ext_partners)
+ if (sys%scf%calc_stress) call stress_calculate(sys%namespace, sys%gr, sys%hm, sys%st, sys%ions, sys%ks, sys%ext_partners)
- if(scf%max_iter == 0) then
- call energy_calc_eigenvalues(namespace, hm, gr%der, st)
- call states_elec_fermi(st, namespace, gr)
- call states_elec_write_eigenvalues(st%nst, st, space, hm%kpoints, namespace=namespace)
+ if(sys%scf%max_iter == 0) then
+ call energy_calc_eigenvalues(sys%namespace, sys%hm, sys%gr%der, sys%st)
+ call states_elec_fermi(sys%st, sys%namespace, sys%gr)
+ call states_elec_write_eigenvalues(sys%st%nst, sys%st, sys%space, sys%hm%kpoints, namespace=sys%namespace)
end if
if(present(outp)) then
! output final information
call scf_write_static(STATIC_DIR, "info")
- call output_all(outp, namespace, space, STATIC_DIR, gr, ions, -1, st, hm, ks)
- call output_modelmb(outp, namespace, space, STATIC_DIR, gr, ions, -1, st)
+ call output_all(outp, sys%namespace, sys%space, STATIC_DIR, sys%gr, sys%ions, -1, sys%st, sys%hm, sys%ks)
+ call output_modelmb(outp, sys%namespace, sys%space, STATIC_DIR, sys%gr, sys%ions, -1, sys%st)
end if
- if (space%is_periodic() .and. st%nik > st%d%nspin) then
- if (bitand(hm%kpoints%method, KPOINTS_PATH) /= 0) then
- call states_elec_write_bandstructure(STATIC_DIR, namespace, st%nst, st, &
- ions, gr, hm%kpoints, hm%phase, vec_pot = hm%hm_base%uniform_vector_potential, &
- vec_pot_var = hm%hm_base%vector_potential)
+ if (sys%space%is_periodic() .and. sys%st%nik > sys%st%d%nspin) then
+ if (bitand(sys%hm%kpoints%method, KPOINTS_PATH) /= 0) then
+ call states_elec_write_bandstructure(STATIC_DIR, sys%namespace, sys%st%nst, sys%st, &
+ sys%ions, sys%gr, sys%hm%kpoints, sys%hm%phase, vec_pot = sys%hm%hm_base%uniform_vector_potential, &
+ vec_pot_var = sys%hm%hm_base%vector_potential)
end if
end if
- if (ks%vdw%vdw_correction == OPTION__VDWCORRECTION__VDW_TS) then
- call vdw_ts_write_c6ab(ks%vdw%vdw_ts, ions, STATIC_DIR, 'c6ab_eff', namespace)
+ if (sys%ks%vdw%vdw_correction == OPTION__VDWCORRECTION__VDW_TS) then
+ call vdw_ts_write_c6ab(sys%ks%vdw%vdw_ts, sys%ions, STATIC_DIR, 'c6ab_eff', sys%namespace)
end if
SAFE_DEALLOCATE_A(vhxc_old)
@@ -997,7 +919,7 @@ contains
type(namespace_t), intent(in) :: namespace
character(len=50) :: str
- real(real64) :: dipole(1:space%dim)
+ real(real64) :: dipole(1:sys%space%dim)
PUSH_SUB(scf_run.scf_write_iter)
@@ -1005,35 +927,37 @@ contains
write(str, '(a,i5)') 'SCF CYCLE ITER #' ,iter
call messages_print_with_emphasis(msg=trim(str), namespace=namespace)
- write(message(1),'(a,es15.8,2(a,es9.2))') ' etot = ', units_from_atomic(units_out%energy, hm%energy%total), &
- ' abs_ev = ', units_from_atomic(units_out%energy, scf%evsum_diff), &
- ' rel_ev = ', scf%evsum_diff/(abs(scf%evsum_out)+1e-20)
+ write(message(1),'(a,es15.8,2(a,es9.2))') ' etot = ', units_from_atomic(units_out%energy, sys%hm%energy%total), &
+ ' abs_ev = ', units_from_atomic(units_out%energy, sys%scf%evsum_diff), &
+ ' rel_ev = ', sys%scf%evsum_diff/(abs(sys%scf%evsum_out)+1e-20)
write(message(2),'(a,es15.2,2(a,es9.2))') &
- ' ediff = ', scf%energy_diff, ' abs_dens = ', scf%abs_dens_diff, &
- ' rel_dens = ', scf%abs_dens_diff/st%qtot
+ ' ediff = ', sys%scf%energy_diff, ' abs_dens = ', sys%scf%abs_dens_diff, &
+ ' rel_dens = ', sys%scf%abs_dens_diff/sys%st%qtot
call messages_info(2, namespace=namespace)
- if(.not.scf%lcao_restricted) then
- write(message(1),'(a,i6)') 'Matrix vector products: ', scf%eigens%matvec
- write(message(2),'(a,i6)') 'Converged eigenvectors: ', sum(scf%eigens%converged(1:st%nik))
+ if(.not.sys%scf%lcao_restricted) then
+ write(message(1),'(a,i6)') 'Matrix vector products: ', sys%scf%eigens%matvec
+ write(message(2),'(a,i6)') 'Converged eigenvectors: ', sum(sys%scf%eigens%converged(1:sys%st%nik))
call messages_info(2, namespace=namespace)
- call states_elec_write_eigenvalues(st%nst, st, space, hm%kpoints, scf%eigens%diff, compact = .true., namespace=namespace)
+ call states_elec_write_eigenvalues(sys%st%nst, sys%st, sys%space, sys%hm%kpoints, &
+ sys%scf%eigens%diff, compact = .true., namespace=namespace)
else
- call states_elec_write_eigenvalues(st%nst, st, space, hm%kpoints, compact = .true., namespace=namespace)
+ call states_elec_write_eigenvalues(sys%st%nst, sys%st, sys%space, sys%hm%kpoints, &
+ compact = .true., namespace=namespace)
end if
- if (allocated(hm%vberry)) then
- call calc_dipole(dipole, space, gr, st, ions)
+ if (allocated(sys%hm%vberry)) then
+ call calc_dipole(dipole, sys%space, sys%gr, sys%st, sys%ions)
call write_dipole(dipole, namespace=namespace)
end if
- if(st%d%ispin > UNPOLARIZED) then
- call write_magnetic_moments(gr, st, ions, gr%der%boundaries, scf%lmm_r, namespace=namespace)
+ if(sys%st%d%ispin > UNPOLARIZED) then
+ call write_magnetic_moments(sys%gr, sys%st, sys%ions, sys%gr%der%boundaries, sys%scf%lmm_r, namespace=namespace)
end if
- if(hm%lda_u_level == DFT_U_ACBN0) then
- call lda_u_write_U(hm%lda_u, namespace=namespace)
- call lda_u_write_V(hm%lda_u, namespace=namespace)
+ if(sys%hm%lda_u_level == DFT_U_ACBN0) then
+ call lda_u_write_U(sys%hm%lda_u, namespace=namespace)
+ call lda_u_write_V(sys%hm%lda_u, namespace=namespace)
end if
write(message(1),'(a)') ''
@@ -1049,8 +973,8 @@ contains
if ( verbosity_ == VERB_COMPACT ) then
write(message(1),'(a,i4,a,es15.8, a,es9.2, a, f7.1, a)') &
'iter ', iter, &
- ' : etot ', units_from_atomic(units_out%energy, hm%energy%total), &
- ' : abs_dens', scf%abs_dens_diff, &
+ ' : etot ', units_from_atomic(units_out%energy, sys%hm%energy%total), &
+ ' : abs_dens', sys%scf%abs_dens_diff, &
' : etime ', etime, 's'
call messages_info(1, namespace=namespace)
end if
@@ -1065,25 +989,25 @@ contains
integer :: iunit, iatom
real(real64), allocatable :: hirshfeld_charges(:)
- real(real64) :: dipole(1:space%dim)
+ real(real64) :: dipole(1:sys%space%dim)
real(real64) :: ex_virial
PUSH_SUB(scf_run.scf_write_static)
if(mpi_grp_is_root(mpi_world)) then ! this the absolute master writes
- call io_mkdir(dir, namespace)
- iunit = io_open(trim(dir) // "/" // trim(fname), namespace, action='write')
+ call io_mkdir(dir, sys%namespace)
+ iunit = io_open(trim(dir) // "/" // trim(fname), sys%namespace, action='write')
- call grid_write_info(gr, iunit=iunit)
+ call grid_write_info(sys%gr, iunit=iunit)
- call symmetries_write_info(gr%symm, space, iunit=iunit)
+ call symmetries_write_info(sys%gr%symm, sys%space, iunit=iunit)
- if (space%is_periodic()) then
- call hm%kpoints%write_info(iunit=iunit)
+ if (sys%space%is_periodic()) then
+ call sys%hm%kpoints%write_info(iunit=iunit)
write(iunit,'(1x)')
end if
- call v_ks_write_info(ks, iunit=iunit)
+ call v_ks_write_info(sys%ks, iunit=iunit)
! scf information
if(finish) then
@@ -1093,15 +1017,15 @@ contains
end if
write(iunit, '(1x)')
- if(any(scf%eigens%converged < st%nst) .and. .not. scf%lcao_restricted) then
+ if(any(sys%scf%eigens%converged < sys%st%nst) .and. .not. sys%scf%lcao_restricted) then
write(iunit,'(a)') 'Some of the states are not fully converged!'
end if
- call states_elec_write_eigenvalues(st%nst, st, space, hm%kpoints, iunit=iunit)
+ call states_elec_write_eigenvalues(sys%st%nst, sys%st, sys%space, sys%hm%kpoints, iunit=iunit)
write(iunit, '(1x)')
- if (space%is_periodic()) then
- call states_elec_write_gaps(iunit, st, space)
+ if (sys%space%is_periodic()) then
+ call states_elec_write_gaps(iunit, sys%st, sys%space)
write(iunit, '(1x)')
end if
@@ -1110,48 +1034,48 @@ contains
iunit = 0
end if
- call energy_calc_total(namespace, space, hm, gr, st, ext_partners, iunit, full = .true.)
+ call energy_calc_total(sys%namespace, sys%space, sys%hm, sys%gr, sys%st, sys%ext_partners, iunit, full = .true.)
if(mpi_grp_is_root(mpi_world)) write(iunit, '(1x)')
- if(st%d%ispin > UNPOLARIZED) then
- call write_magnetic_moments(gr, st, ions, gr%der%boundaries, scf%lmm_r, iunit=iunit)
+ if(sys%st%d%ispin > UNPOLARIZED) then
+ call write_magnetic_moments(sys%gr, sys%st, sys%ions, sys%gr%der%boundaries, sys%scf%lmm_r, iunit=iunit)
if (mpi_grp_is_root(mpi_world)) write(iunit, '(1x)')
end if
- if(st%d%ispin == SPINORS .and. space%dim == 3 .and. &
- (ks%theory_level == KOHN_SHAM_DFT .or. ks%theory_level == GENERALIZED_KOHN_SHAM_DFT) ) then
- call write_total_xc_torque(iunit, gr, hm%vxc, st)
+ if(sys%st%d%ispin == SPINORS .and. sys%space%dim == 3 .and. &
+ (sys%ks%theory_level == KOHN_SHAM_DFT .or. sys%ks%theory_level == GENERALIZED_KOHN_SHAM_DFT) ) then
+ call write_total_xc_torque(iunit, sys%gr, sys%hm%vxc, sys%st)
if(mpi_grp_is_root(mpi_world)) write(iunit, '(1x)')
end if
- if(hm%lda_u_level == DFT_U_ACBN0) then
- call lda_u_write_U(hm%lda_u, iunit=iunit)
- call lda_u_write_V(hm%lda_u, iunit=iunit)
+ if(sys%hm%lda_u_level == DFT_U_ACBN0) then
+ call lda_u_write_U(sys%hm%lda_u, iunit=iunit)
+ call lda_u_write_V(sys%hm%lda_u, iunit=iunit)
if(mpi_grp_is_root(mpi_world)) write(iunit, '(1x)')
end if
- if(scf%calc_dipole) then
- call calc_dipole(dipole, space, gr, st, ions)
+ if(sys%scf%calc_dipole) then
+ call calc_dipole(dipole, sys%space, sys%gr, sys%st, sys%ions)
call write_dipole(dipole, iunit=iunit)
end if
! This only works when we do not have a correlation part
- if(ks%theory_level == KOHN_SHAM_DFT .and. &
- hm%xc%functional(FUNC_C,1)%family == XC_FAMILY_NONE .and. st%d%ispin /= SPINORS) then
- call energy_calc_virial_ex(gr%der, hm%vxc, st, ex_virial)
+ if(sys%ks%theory_level == KOHN_SHAM_DFT .and. &
+ sys%hm%xc%functional(FUNC_C,1)%family == XC_FAMILY_NONE .and. sys%st%d%ispin /= SPINORS) then
+ call energy_calc_virial_ex(sys%gr%der, sys%hm%vxc, sys%st, ex_virial)
if (mpi_grp_is_root(mpi_world)) then
write(iunit, '(3a)') 'Virial relation for exchange [', trim(units_abbrev(units_out%energy)), ']:'
- write(iunit,'(a,es14.6)') "Energy from the orbitals ", units_from_atomic(units_out%energy, hm%energy%exchange)
+ write(iunit,'(a,es14.6)') "Energy from the orbitals ", units_from_atomic(units_out%energy, sys%hm%energy%exchange)
write(iunit,'(a,es14.6)') "Energy from the potential (virial) ", units_from_atomic(units_out%energy, ex_virial)
write(iunit, '(1x)')
end if
end if
if(mpi_grp_is_root(mpi_world)) then
- if(scf%max_iter > 0) then
+ if(sys%scf%max_iter > 0) then
write(iunit, '(a)') 'Convergence:'
- call iterator%start(scf%criterion_list)
+ call iterator%start(sys%scf%criterion_list)
do while (iterator%has_next())
crit => iterator%get_next()
call crit%write_info(iunit)
@@ -1160,37 +1084,37 @@ contains
end if
! otherwise, these values are uninitialized, and unknown.
- if (bitand(ks%xc_family, XC_FAMILY_OEP) /= 0 .and. ks%theory_level /= HARTREE_FOCK &
- .and. ks%theory_level /= GENERALIZED_KOHN_SHAM_DFT) then
- if ((ks%oep_photon%level == OEP_LEVEL_FULL) .or. (ks%oep_photon%level == OEP_LEVEL_KLI)) then
+ if (bitand(sys%ks%xc_family, XC_FAMILY_OEP) /= 0 .and. sys%ks%theory_level /= HARTREE_FOCK &
+ .and. sys%ks%theory_level /= GENERALIZED_KOHN_SHAM_DFT) then
+ if ((sys%ks%oep_photon%level == OEP_LEVEL_FULL) .or. (sys%ks%oep_photon%level == OEP_LEVEL_KLI)) then
write(iunit, '(a)') 'Photon observables:'
- write(iunit, '(6x, a, es15.8,a,es15.8,a)') 'Photon number = ', ks%oep_photon%pt%number(1)
- write(iunit, '(6x, a, es15.8,a,es15.8,a)') 'Photon ex. = ', ks%oep_photon%pt%ex
+ write(iunit, '(6x, a, es15.8,a,es15.8,a)') 'Photon number = ', sys%ks%oep_photon%pt%number(1)
+ write(iunit, '(6x, a, es15.8,a,es15.8,a)') 'Photon ex. = ', sys%ks%oep_photon%pt%ex
write(iunit,'(1x)')
end if
end if
- if (scf%calc_force) call forces_write_info(iunit, ions, dir, namespace)
+ if (sys%scf%calc_force) call forces_write_info(iunit, sys%ions, dir, sys%namespace)
- if (scf%calc_stress) then
- call output_stress(iunit, space%periodic_dim, st%stress_tensors, all_terms=.false.)
- call output_pressure(iunit, space%periodic_dim, st%stress_tensors%total)
+ if (sys%scf%calc_stress) then
+ call output_stress(iunit, sys%space%periodic_dim, sys%st%stress_tensors, all_terms=.false.)
+ call output_pressure(iunit, sys%space%periodic_dim, sys%st%stress_tensors%total)
end if
end if
- if(scf%calc_partial_charges) then
- SAFE_ALLOCATE(hirshfeld_charges(1:ions%natoms))
+ if(sys%scf%calc_partial_charges) then
+ SAFE_ALLOCATE(hirshfeld_charges(1:sys%ions%natoms))
- call partial_charges_calculate(gr, st, ions, hirshfeld_charges)
+ call partial_charges_calculate(sys%gr, sys%st, sys%ions, hirshfeld_charges)
if(mpi_grp_is_root(mpi_world)) then
write(iunit,'(a)') 'Partial ionic charges'
write(iunit,'(a)') ' Ion Hirshfeld'
- do iatom = 1, ions%natoms
- write(iunit,'(i4,a10,f16.3)') iatom, trim(ions%atom(iatom)%species%get_label()), hirshfeld_charges(iatom)
+ do iatom = 1, sys%ions%natoms
+ write(iunit,'(i4,a10,f16.3)') iatom, trim(sys%ions%atom(iatom)%species%get_label()), hirshfeld_charges(iatom)
end do
@@ -1216,21 +1140,21 @@ contains
PUSH_SUB(scf_run.write_dipole)
if(mpi_grp_is_root(mpi_world)) then
- call output_dipole(dipole, space%dim, iunit=iunit, namespace=namespace)
+ call output_dipole(dipole, sys%space%dim, iunit=iunit, namespace=namespace)
- if (space%is_periodic()) then
+ if (sys%space%is_periodic()) then
message(1) = "Defined only up to quantum of polarization (e * lattice vector)."
message(2) = "Single-point Berry's phase method only accurate for large supercells."
call messages_info(2, iunit=iunit, namespace=namespace)
- if (hm%kpoints%full%npoints > 1) then
+ if (sys%hm%kpoints%full%npoints > 1) then
message(1) = &
"WARNING: Single-point Berry's phase method for dipole should not be used when there is more than one k-point."
message(2) = "Instead, finite differences on k-points (not yet implemented) are needed."
call messages_info(2, iunit=iunit, namespace=namespace)
end if
- if(.not. smear_is_semiconducting(st%smear)) then
+ if(.not. smear_is_semiconducting(sys%st%smear)) then
message(1) = "Single-point Berry's phase dipole calculation not correct without integer occupations."
call messages_info(1, iunit=iunit, namespace=namespace)
end if
@@ -1251,8 +1175,8 @@ contains
integer :: iunit
character(len=12) :: label
if(mpi_grp_is_root(mpi_world)) then ! this the absolute master writes
- call io_mkdir(dir, namespace)
- iunit = io_open(trim(dir) // "/" // trim(fname), namespace, action='write')
+ call io_mkdir(dir, sys%namespace)
+ iunit = io_open(trim(dir) // "/" // trim(fname), sys%namespace, action='write')
write(iunit, '(a)', advance = 'no') '#iter energy '
label = 'energy_diff'
write(iunit, '(1x,a)', advance = 'no') label
@@ -1264,9 +1188,9 @@ contains
write(iunit, '(1x,a)', advance = 'no') label
label = 'rel_ev'
write(iunit, '(1x,a)', advance = 'no') label
- if (bitand(ks%xc_family, XC_FAMILY_OEP) /= 0 .and. ks%theory_level /= HARTREE_FOCK &
- .and. ks%theory_level /= GENERALIZED_KOHN_SHAM_DFT) then
- if (ks%oep%level == OEP_LEVEL_FULL) then
+ if (bitand(sys%ks%xc_family, XC_FAMILY_OEP) /= 0 .and. sys%ks%theory_level /= HARTREE_FOCK &
+ .and. sys%ks%theory_level /= GENERALIZED_KOHN_SHAM_DFT) then
+ if (sys%ks%oep%level == OEP_LEVEL_FULL) then
label = 'OEP norm2ss'
write(iunit, '(1x,a)', advance = 'no') label
end if
@@ -1286,10 +1210,10 @@ contains
integer :: iunit
if(mpi_grp_is_root(mpi_world)) then ! this the absolute master writes
- call io_mkdir(dir, namespace)
- iunit = io_open(trim(dir) // "/" // trim(fname), namespace, action='write', position='append')
- write(iunit, '(i5,es18.8)', advance = 'no') iter, units_from_atomic(units_out%energy, hm%energy%total)
- call iterator%start(scf%criterion_list)
+ call io_mkdir(dir, sys%namespace)
+ iunit = io_open(trim(dir) // "/" // trim(fname), sys%namespace, action='write', position='append')
+ write(iunit, '(i5,es18.8)', advance = 'no') iter, units_from_atomic(units_out%energy, sys%hm%energy%total)
+ call iterator%start(sys%scf%criterion_list)
do while (iterator%has_next())
crit => iterator%get_next()
select type (crit)
@@ -1304,10 +1228,10 @@ contains
ASSERT(.false.)
end select
end do
- if (bitand(ks%xc_family, XC_FAMILY_OEP) /= 0 .and. ks%theory_level /= HARTREE_FOCK &
- .and. ks%theory_level /= GENERALIZED_KOHN_SHAM_DFT) then
- if (ks%oep%level == OEP_LEVEL_FULL) then
- write(iunit, '(es13.5)', advance = 'no') ks%oep%norm2ss
+ if (bitand(sys%ks%xc_family, XC_FAMILY_OEP) /= 0 .and. sys%ks%theory_level /= HARTREE_FOCK &
+ .and. sys%ks%theory_level /= GENERALIZED_KOHN_SHAM_DFT) then
+ if (sys%ks%oep%level == OEP_LEVEL_FULL) then
+ write(iunit, '(es13.5)', advance = 'no') sys%ks%oep%norm2ss
end if
end if
write(iunit,'(a)') ''
@@ -1319,25 +1243,24 @@ contains
end subroutine scf_run
! ---------------------------------------------------------
- subroutine scf_state_info(namespace, st)
- type(namespace_t), intent(in) :: namespace
- class(states_abst_t), intent(in) :: st
+ module subroutine scf_state_info(sys)
+ type(electrons_t), intent(in) :: sys
PUSH_SUB(scf_state_info)
- if (states_are_real(st)) then
+ if (states_are_real(sys%st)) then
call messages_write('Info: SCF using real wavefunctions.')
else
call messages_write('Info: SCF using complex wavefunctions.')
end if
- call messages_info(namespace=namespace)
+ call messages_info(namespace=sys%namespace)
POP_SUB(scf_state_info)
end subroutine scf_state_info
! ---------------------------------------------------------
- subroutine scf_print_mem_use(namespace)
+ module subroutine scf_print_mem_use(namespace)
type(namespace_t), intent(in) :: namespace
real(real64) :: mem
real(real64) :: mem_tmp
@@ -1419,7 +1342,7 @@ contains
end subroutine scf_update_diff_quantity
-end module scf_oct_m
+end submodule impl
!! Local Variables:
diff --git a/src/scf/scf_interface_h.F90 b/src/scf/scf_interface_h.F90
new file mode 100644
index 0000000000000000000000000000000000000000..973a5f4d623d2e7c5e16d52ddb73823051caf81c
--- /dev/null
+++ b/src/scf/scf_interface_h.F90
@@ -0,0 +1,58 @@
+module scf_interface_oct_m
+ use electron_space_oct_m
+ use electrons_oct_m
+ use global_oct_m
+ use grid_oct_m
+ use hamiltonian_elec_oct_m
+ use interaction_partner_oct_m
+ use ions_oct_m
+ use multicomm_oct_m
+ use namespace_oct_m
+ use output_low_oct_m
+ use restart_oct_m
+ use scf_oct_m
+ use space_oct_m
+ use states_abst_oct_m
+ use states_elec_oct_m
+ use v_ks_oct_m
+
+ implicit none
+
+ private
+ public :: &
+ scf_init, &
+ scf_mix_clear, &
+ scf_run, &
+ scf_end, &
+ scf_state_info, &
+ scf_print_mem_use
+
+ interface
+ module subroutine scf_init(sys)
+ type(electrons_t), intent(inout) :: sys
+ end subroutine scf_init
+
+ module subroutine scf_mix_clear(sys)
+ type(electrons_t), intent(inout) :: sys
+ end subroutine scf_mix_clear
+
+ module subroutine scf_run(sys, outp, verbosity, iters_done)
+ type(electrons_t), intent(inout) :: sys
+ type(output_t), optional, intent(in) :: outp
+ integer, optional, intent(in) :: verbosity
+ integer, optional, intent(out) :: iters_done
+ end subroutine scf_run
+
+ module subroutine scf_end(sys)
+ type(electrons_t), intent(inout) :: sys
+ end subroutine scf_end
+
+ module subroutine scf_state_info(sys)
+ type(electrons_t), intent(in) :: sys
+ end subroutine scf_state_info
+
+ module subroutine scf_print_mem_use(namespace)
+ type(namespace_t), intent(in) :: namespace
+ end subroutine scf_print_mem_use
+ end interface
+end module scf_interface_oct_m
diff --git a/src/scf/unocc.F90 b/src/scf/unocc.F90
index 6373a84cd622003b3778379334594cf38fe87650..f5d55f5b33747d8625b1be26ce465bb151579367 100644
--- a/src/scf/unocc.F90
+++ b/src/scf/unocc.F90
@@ -40,6 +40,7 @@ module unocc_oct_m
use parser_oct_m
use profiling_oct_m
use restart_oct_m
+ use scf_interface_oct_m
use scf_oct_m
use space_oct_m
use states_abst_oct_m
@@ -230,7 +231,7 @@ contains
call density_calc(sys%st, sys%gr, sys%st%rho)
end if
- call scf_state_info(sys%namespace, sys%st)
+ call scf_state_info(sys)
if (fromScratch .or. ierr /= 0) then
if (fromScratch) then
diff --git a/src/td/CMakeLists.txt b/src/td/CMakeLists.txt
index 7d266368fd1e19334a5d24526599af309d6f61cf..819f0ca6484e51fb94c066423a30c4e765e13be8 100644
--- a/src/td/CMakeLists.txt
+++ b/src/td/CMakeLists.txt
@@ -9,14 +9,17 @@ target_sources(Octopus_lib PRIVATE
propagator_base.F90
propagator_cn.F90
propagator_elec.F90
+ propagator_elec_h.F90
propagator_etrs.F90
propagator_expmid.F90
propagator_magnus.F90
propagator_qoct.F90
propagator_rk.F90
spectrum.F90
- td.F90
td_calc.F90
+ td_h.F90
+ td_interface.F90
+ td_interface_h.F90
td_write.F90
td_write_low.F90
)
diff --git a/src/td/propagator_elec.F90 b/src/td/propagator_elec.F90
index 68f9f50b48976855ee3ff72042633c7d96817ca2..882cec3d240d768f83685303960f17a06c56e22d 100644
--- a/src/td/propagator_elec.F90
+++ b/src/td/propagator_elec.F90
@@ -18,33 +18,23 @@
#include "global.h"
-module propagator_elec_oct_m
+submodule (propagator_elec_oct_m) impl
+ use propagator_elec_oct_m
use debug_oct_m
- use electron_space_oct_m
+ use electrons_extension_oct_m
+ use extension_oct_m
use energy_calc_oct_m
use exponential_oct_m
use ext_partner_list_oct_m
use forces_oct_m
use gauge_field_oct_m
- use grid_oct_m
- use global_oct_m
- use hamiltonian_elec_oct_m
- use interaction_partner_oct_m
- use ion_dynamics_oct_m
- use ions_oct_m
- use, intrinsic :: iso_fortran_env
use lasers_oct_m
use lda_u_oct_m
use parser_oct_m
use mesh_function_oct_m
use messages_oct_m
- use multicomm_oct_m
- use namespace_oct_m
- use opt_control_state_oct_m
- use output_low_oct_m
use potential_interpolation_oct_m
use profiling_oct_m
- use propagator_base_oct_m
use propagator_cn_oct_m
use propagator_etrs_oct_m
use propagator_expmid_oct_m
@@ -52,34 +42,17 @@ module propagator_elec_oct_m
use propagator_qoct_oct_m
use propagator_rk_oct_m
use propagator_verlet_oct_m
- use scf_oct_m
+ use scf_interface_oct_m
use sparskit_oct_m
- use space_oct_m
- use states_elec_oct_m
use stress_oct_m
- use td_write_oct_m
- use v_ks_oct_m
use varinfo_oct_m
use xc_oct_m
-
implicit none
- private
- public :: &
- propagator_elec_init, &
- propagator_elec_end, &
- propagator_elec_copy, &
- propagator_elec_run_zero_iter, &
- propagator_elec_dt, &
- propagator_elec_set_scf_prop, &
- propagator_elec_remove_scf_prop, &
- propagator_elec_ions_are_propagated, &
- propagator_elec_dt_bo
-
contains
! ---------------------------------------------------------
- subroutine propagator_elec_copy(tro, tri)
+ module subroutine propagator_elec_copy(tro, tri)
type(propagator_base_t), intent(inout) :: tro
type(propagator_base_t), intent(in) :: tri
@@ -117,7 +90,7 @@ contains
! ---------------------------------------------------------
- subroutine propagator_elec_init(gr, namespace, st, tr, have_fields, family_is_mgga_with_exc)
+ module subroutine propagator_elec_init(gr, namespace, st, tr, have_fields, family_is_mgga_with_exc)
type(grid_t), intent(in) :: gr
type(namespace_t), intent(in) :: namespace
type(states_elec_t), intent(in) :: st
@@ -389,7 +362,7 @@ contains
! ---------------------------------------------------------
- subroutine propagator_elec_set_scf_prop(tr, threshold)
+ module subroutine propagator_elec_set_scf_prop(tr, threshold)
type(propagator_base_t), intent(inout) :: tr
real(real64), optional, intent(in) :: threshold
@@ -406,7 +379,7 @@ contains
! ---------------------------------------------------------
- subroutine propagator_elec_remove_scf_prop(tr)
+ module subroutine propagator_elec_remove_scf_prop(tr)
type(propagator_base_t), intent(inout) :: tr
PUSH_SUB(propagator_elec_remove_scf_prop)
@@ -419,7 +392,7 @@ contains
! ---------------------------------------------------------
- subroutine propagator_elec_end(tr)
+ module subroutine propagator_elec_end(tr)
type(propagator_base_t), intent(inout) :: tr
PUSH_SUB(propagator_elec_end)
@@ -442,7 +415,7 @@ contains
! ---------------------------------------------------------
- subroutine propagator_elec_run_zero_iter(hm, gr, tr)
+ module subroutine propagator_elec_run_zero_iter(hm, gr, tr)
type(hamiltonian_elec_t), intent(in) :: hm
type(grid_t), intent(in) :: gr
type(propagator_base_t), intent(inout) :: tr
@@ -459,8 +432,9 @@ contains
!> Propagates st from time - dt to t.
!! If dt<0, it propagates *backwards* from t+|dt| to t
! ---------------------------------------------------------
- subroutine propagator_elec_dt(ks, namespace, space, hm, gr, st, tr, time, dt, nt, &
+ module subroutine propagator_elec_dt(sys, ks, namespace, space, hm, gr, st, tr, time, dt, nt, &
ions_dyn, ions, ext_partners, outp, write_handler, scsteps, update_energy, qcchi)
+ type(electrons_t), intent(inout) :: sys
type(v_ks_t), target, intent(inout) :: ks
type(namespace_t), intent(in) :: namespace
type(electron_space_t), intent(in) :: space
@@ -484,6 +458,9 @@ contains
logical :: generate, update_energy_
real(real64) :: am(space%dim)
+ type(extension_iterator_t) :: extension_iter
+ class(extension_t), pointer :: extension
+
call profiling_in("TD_PROPAGATOR")
PUSH_SUB(propagator_elec_dt)
@@ -493,6 +470,19 @@ contains
if (present(scsteps)) scsteps = 1
+ ! Run any pre propagation extension hooks
+ call extension_iter%start(sys%extensions)
+ do while (extension_iter%has_next())
+ extension => extension_iter%get_next()
+ select type (extension)
+ class is (electrons_extension_t)
+ call extension%pre_propagation_legacy()
+ class default
+ ! Do nothing
+ end select
+ end do
+
+ ! Propagate the electronic system
select case (tr%method)
case (PROP_ETRS)
if (self_consistent_step()) then
@@ -530,6 +520,18 @@ contains
call td_cfmagnus4(ks, namespace, space, hm, gr, st, tr, time, dt, ions_dyn, ions, ext_partners, nt)
end select
+ ! Run any post propagation extension hooks
+ call extension_iter%start(sys%extensions)
+ do while (extension_iter%has_next())
+ extension => extension_iter%get_next()
+ select type (extension)
+ class is (electrons_extension_t)
+ call extension%post_propagation_legacy()
+ class default
+ ! Do nothing
+ end select
+ end do
+
generate = .false.
if (ion_dynamics_ions_move(ions_dyn)) then
if (.not. propagator_elec_ions_are_propagated(tr)) then
@@ -614,8 +616,9 @@ contains
! ---------------------------------------------------------
- logical pure function propagator_elec_ions_are_propagated(tr) result(propagated)
+ pure module function propagator_elec_ions_are_propagated(tr) result(propagated)
type(propagator_base_t), intent(in) :: tr
+ logical :: propagated
select case (tr%method)
case (PROP_ETRS, PROP_AETRS, PROP_CAETRS, PROP_EXPLICIT_RUNGE_KUTTA4)
@@ -630,21 +633,9 @@ contains
! ---------------------------------------------------------
- subroutine propagator_elec_dt_bo(scf, namespace, space, gr, ks, st, hm, ions, ext_partners, mc, outp, iter, dt, ions_dyn, scsteps)
- type(scf_t), intent(inout) :: scf
- type(namespace_t), intent(in) :: namespace
- type(electron_space_t), intent(in) :: space
- type(grid_t), intent(inout) :: gr
- type(v_ks_t), intent(inout) :: ks
- type(states_elec_t), intent(inout) :: st
- type(hamiltonian_elec_t), intent(inout) :: hm
- type(ions_t), intent(inout) :: ions
- type(partner_list_t), intent(in) :: ext_partners
- type(multicomm_t), intent(inout) :: mc !< index and domain communicators
- type(output_t), intent(inout) :: outp
+ module subroutine propagator_elec_dt_bo(sys, iter, scsteps)
+ type(electrons_t), intent(inout) :: sys
integer, intent(in) :: iter
- real(real64), intent(in) :: dt
- type(ion_dynamics_t), intent(inout) :: ions_dyn
integer, intent(inout) :: scsteps
type(gauge_field_t), pointer :: gfield
@@ -652,47 +643,49 @@ contains
PUSH_SUB(propagator_elec_dt_bo)
! move the hamiltonian to time t
- call ion_dynamics_propagate(ions_dyn, ions, iter*dt, dt, namespace)
- call hamiltonian_elec_epot_generate(hm, namespace, space, gr, ions, ext_partners, st, time = iter*dt)
+ call ion_dynamics_propagate(sys%td%ions_dyn, sys%ions, iter*sys%td%dt, sys%td%dt, sys%namespace)
+ call hamiltonian_elec_epot_generate(sys%hm, sys%namespace, sys%space, sys%gr, sys%ions, &
+ sys%ext_partners, sys%st, time = iter*sys%td%dt)
! now calculate the eigenfunctions
- call scf_run(scf, namespace, space, mc, gr, ions, ext_partners, st, ks, hm, &
- verbosity = VERB_COMPACT, iters_done = scsteps)
+ call scf_run(sys, verbosity = VERB_COMPACT, iters_done = scsteps)
- gfield => list_get_gauge_field(ext_partners)
+ gfield => list_get_gauge_field(sys%ext_partners)
if(associated(gfield)) then
if (gauge_field_is_propagated(gfield)) then
- call gauge_field_do_algorithmic_operation(gfield, OP_VERLET_COMPUTE_ACC, dt, iter*dt)
+ call gauge_field_do_algorithmic_operation(gfield, OP_VERLET_COMPUTE_ACC, sys%td%dt, iter*sys%td%dt)
end if
end if
!TODO: we should update the occupation matrices here
- if (hm%lda_u_level /= DFT_U_NONE) then
- call messages_not_implemented("DFT+U with propagator_elec_dt_bo", namespace=namespace)
+ if (sys%hm%lda_u_level /= DFT_U_NONE) then
+ call messages_not_implemented("DFT+U with propagator_elec_dt_bo", namespace=sys%namespace)
end if
- call hamiltonian_elec_epot_generate(hm, namespace, space, gr, ions, ext_partners, st, time = iter*dt)
+ call hamiltonian_elec_epot_generate(sys%hm, sys%namespace, sys%space, sys%gr, sys%ions, &
+ sys%ext_partners, sys%st, time = iter*sys%td%dt)
! update Hamiltonian and eigenvalues (fermi is *not* called)
- call v_ks_calc(ks, namespace, space, hm, st, ions, ext_partners, &
- calc_eigenval = .true., time = iter*dt, calc_energy = .true.)
+ call v_ks_calc(sys%ks, sys%namespace, sys%space, sys%hm, sys%st, sys%ions, sys%ext_partners, &
+ calc_eigenval = .true., time = iter*sys%td%dt, calc_energy = .true.)
! Get the energies.
- call energy_calc_total(namespace, space, hm, gr, st, ext_partners, iunit = -1)
+ call energy_calc_total(sys%namespace, sys%space, sys%hm, sys%gr, sys%st, sys%ext_partners, iunit = -1)
- call ion_dynamics_propagate_vel(ions_dyn, ions)
- call hamiltonian_elec_epot_generate(hm, namespace, space, gr, ions, ext_partners, st, time = iter*dt)
- call ions%update_kinetic_energy()
+ call ion_dynamics_propagate_vel(sys%td%ions_dyn, sys%ions)
+ call hamiltonian_elec_epot_generate(sys%hm, sys%namespace, sys%space, sys%gr, sys%ions, &
+ sys%ext_partners, sys%st, time = iter*sys%td%dt)
+ call sys%ions%update_kinetic_energy()
if(associated(gfield)) then
if (gauge_field_is_propagated(gfield)) then
- call gauge_field_do_algorithmic_operation(gfield, OP_VERLET_COMPUTE_VEL, dt, iter*dt)
+ call gauge_field_do_algorithmic_operation(gfield, OP_VERLET_COMPUTE_VEL, sys%td%dt, iter*sys%td%dt)
end if
end if
POP_SUB(propagator_elec_dt_bo)
end subroutine propagator_elec_dt_bo
-end module propagator_elec_oct_m
+end submodule impl
!! Local Variables:
diff --git a/src/td/propagator_elec_h.F90 b/src/td/propagator_elec_h.F90
new file mode 100644
index 0000000000000000000000000000000000000000..118ea9ee049585b8d5927636cc10328ef97d657f
--- /dev/null
+++ b/src/td/propagator_elec_h.F90
@@ -0,0 +1,103 @@
+module propagator_elec_oct_m
+ use electron_space_oct_m
+ use electrons_oct_m
+ use global_oct_m
+ use grid_oct_m
+ use hamiltonian_elec_oct_m
+ use interaction_partner_oct_m
+ use ion_dynamics_oct_m
+ use ions_oct_m
+ use multicomm_oct_m
+ use namespace_oct_m
+ use opt_control_state_oct_m
+ use output_low_oct_m
+ use propagator_base_oct_m
+ use scf_oct_m
+ use space_oct_m
+ use states_elec_oct_m
+ use td_write_oct_m
+ use v_ks_oct_m
+
+ implicit none
+
+ private
+ public :: &
+ propagator_elec_init, &
+ propagator_elec_end, &
+ propagator_elec_copy, &
+ propagator_elec_run_zero_iter, &
+ propagator_elec_dt, &
+ propagator_elec_set_scf_prop, &
+ propagator_elec_remove_scf_prop, &
+ propagator_elec_ions_are_propagated, &
+ propagator_elec_dt_bo
+
+ interface
+ module subroutine propagator_elec_copy(tro, tri)
+ type(propagator_base_t), intent(inout) :: tro
+ type(propagator_base_t), intent(in) :: tri
+ end subroutine propagator_elec_copy
+
+ module subroutine propagator_elec_init(gr, namespace, st, tr, have_fields, family_is_mgga_with_exc)
+ type(grid_t), intent(in) :: gr
+ type(namespace_t), intent(in) :: namespace
+ type(states_elec_t), intent(in) :: st
+ type(propagator_base_t), intent(inout) :: tr
+ logical, intent(in) :: have_fields
+ logical, intent(in) :: family_is_mgga_with_exc
+ end subroutine propagator_elec_init
+
+ module subroutine propagator_elec_set_scf_prop(tr, threshold)
+ type(propagator_base_t), intent(inout) :: tr
+ real(real64), optional, intent(in) :: threshold
+ end subroutine propagator_elec_set_scf_prop
+
+ module subroutine propagator_elec_remove_scf_prop(tr)
+ type(propagator_base_t), intent(inout) :: tr
+ end subroutine propagator_elec_remove_scf_prop
+
+ module subroutine propagator_elec_end(tr)
+ type(propagator_base_t), intent(inout) :: tr
+ end subroutine propagator_elec_end
+
+ module subroutine propagator_elec_run_zero_iter(hm, gr, tr)
+ type(hamiltonian_elec_t), intent(in) :: hm
+ type(grid_t), intent(in) :: gr
+ type(propagator_base_t), intent(inout) :: tr
+ end subroutine propagator_elec_run_zero_iter
+
+ module subroutine propagator_elec_dt(sys, ks, namespace, space, hm, gr, st, tr, time, dt, nt, &
+ ions_dyn, ions, ext_partners, outp, write_handler, scsteps, update_energy, qcchi)
+ type(electrons_t), intent(inout) :: sys
+ type(v_ks_t), target, intent(inout) :: ks
+ type(namespace_t), intent(in) :: namespace
+ type(electron_space_t), intent(in) :: space
+ type(hamiltonian_elec_t), target, intent(inout) :: hm
+ type(grid_t), target, intent(inout) :: gr
+ type(states_elec_t), target, intent(inout) :: st
+ type(propagator_base_t), target, intent(inout) :: tr
+ real(real64), intent(in) :: time
+ real(real64), intent(in) :: dt
+ integer, intent(in) :: nt
+ type(ion_dynamics_t), intent(inout) :: ions_dyn
+ type(ions_t), intent(inout) :: ions
+ type(partner_list_t), intent(in) :: ext_partners
+ type(output_t), intent(in) :: outp
+ type(td_write_t), intent(in) :: write_handler
+ integer, optional, intent(out) :: scsteps
+ logical, optional, intent(in) :: update_energy
+ type(opt_control_state_t), optional, target, intent(inout) :: qcchi
+ end subroutine propagator_elec_dt
+
+ pure module function propagator_elec_ions_are_propagated(tr) result(propagated)
+ type(propagator_base_t), intent(in) :: tr
+ logical :: propagated
+ end function propagator_elec_ions_are_propagated
+
+ module subroutine propagator_elec_dt_bo(sys, iter, scsteps)
+ type(electrons_t), intent(inout) :: sys
+ integer, intent(in) :: iter
+ integer, intent(inout) :: scsteps
+ end subroutine propagator_elec_dt_bo
+ end interface
+end module propagator_elec_oct_m
diff --git a/src/td/td_h.F90 b/src/td/td_h.F90
new file mode 100644
index 0000000000000000000000000000000000000000..a607b61acd0c887ea384579710e9ac8bacba12d5
--- /dev/null
+++ b/src/td/td_h.F90
@@ -0,0 +1,54 @@
+module td_oct_m
+ use electron_space_oct_m
+ use global_oct_m
+ use grid_oct_m
+ use hamiltonian_elec_oct_m
+ use interaction_partner_oct_m
+ use ion_dynamics_oct_m
+ use ions_oct_m
+ use multicomm_oct_m
+ use namespace_oct_m
+ use output_low_oct_m
+ use pes_oct_m
+ use propagator_base_oct_m
+ use restart_oct_m
+ use space_oct_m
+ use states_elec_oct_m
+ use td_write_oct_m
+ use v_ks_oct_m
+
+ implicit none
+
+ private
+
+ !> Parameters.
+ integer, parameter, public :: &
+ EHRENFEST = 1, &
+ BO = 2
+
+ type, public :: td_t
+ private
+ type(propagator_base_t), public :: tr !< contains the details of the time-evolution
+ type(ion_dynamics_t), public :: ions_dyn
+ real(real64), public :: dt !< time step
+ integer, public :: max_iter !< maximum number of iterations to perform
+ integer, public :: iter !< the actual iteration
+ logical, public :: recalculate_gs !< Recalculate ground-state along the evolution.
+
+ type(pes_t), public :: pesv
+
+ integer, public :: dynamics
+ integer, public :: energy_update_iter
+ real(real64), public :: scissor
+
+ logical :: freeze_occ
+ logical :: freeze_u
+ integer, public :: freeze_orbitals
+
+ logical, public :: from_scratch = .false.
+
+ type(td_write_t), public :: write_handler
+ type(restart_t), public :: restart_load
+ type(restart_t), public :: restart_dump
+ end type td_t
+end module td_oct_m
diff --git a/src/td/td.F90 b/src/td/td_interface.F90
similarity index 58%
rename from src/td/td.F90
rename to src/td/td_interface.F90
index 7f267f0a56d110f35865a393e6ae1c845d1bb52d..b0b02d2aaee986533f4f0977e70cf24ac1609e53 100644
--- a/src/td/td.F90
+++ b/src/td/td_interface.F90
@@ -18,43 +18,35 @@
#include "global.h"
-module td_oct_m
+submodule (td_interface_oct_m) impl
+ use td_interface_oct_m
use absorbing_boundaries_oct_m
use boundaries_oct_m
use calc_mode_par_oct_m
- use current_oct_m
use classical_particle_oct_m
+ use current_oct_m
use debug_oct_m
use density_oct_m
- use energy_calc_oct_m
use electrons_ground_state_oct_m
- use electron_space_oct_m
+ use energy_calc_oct_m
use epot_oct_m
use ext_partner_list_oct_m
use forces_oct_m
use gauge_field_oct_m
use global_oct_m
- use grid_oct_m
- use hamiltonian_elec_oct_m
- use interaction_partner_oct_m
use io_oct_m
use ion_dynamics_oct_m
- use ions_oct_m
use kick_oct_m
- use, intrinsic :: iso_fortran_env
use lasers_oct_m
- use lda_u_oct_m
use lda_u_io_oct_m
+ use lda_u_oct_m
use linked_list_oct_m
use loct_oct_m
use maxwell_boundary_op_oct_m
use mesh_oct_m
use messages_oct_m
use mpi_oct_m
- use multicomm_oct_m
- use namespace_oct_m
use output_oct_m
- use output_low_oct_m
use parser_oct_m
use pes_oct_m
use photon_mode_mf_oct_m
@@ -62,84 +54,29 @@ module td_oct_m
use poisson_oct_m
use potential_interpolation_oct_m
use profiling_oct_m
- use propagator_oct_m
use propagator_elec_oct_m
- use propagator_base_oct_m
+ use propagator_factory_oct_m
+ use propagator_oct_m
use restart_oct_m
+ use scf_interface_oct_m
use scf_oct_m
use scissor_oct_m
- use space_oct_m
use states_abst_oct_m
- use states_elec_oct_m
use states_elec_restart_oct_m
use stress_oct_m
use td_write_oct_m
use types_oct_m
use unit_oct_m
use unit_system_oct_m
- use v_ks_oct_m
use varinfo_oct_m
use walltimer_oct_m
use xc_oct_m
implicit none
- private
- public :: &
- td_t, &
- td_run, &
- td_run_init, &
- td_init, &
- td_init_run, &
- td_end, &
- td_end_run, &
- td_write_iter, &
- td_check_point, &
- td_dump, &
- td_allocate_wavefunctions, &
- td_init_gaugefield, &
- td_load_restart_from_gs, &
- td_load_restart_from_td, &
- td_init_with_wavefunctions,&
- td_get_from_scratch, &
- td_set_from_scratch
-
- !> Parameters.
- integer, parameter, public :: &
- EHRENFEST = 1, &
- BO = 2
-
- type td_t
- private
- type(propagator_base_t), public :: tr !< contains the details of the time-evolution
- type(scf_t), public :: scf
- type(ion_dynamics_t), public :: ions_dyn
- real(real64), public :: dt !< time step
- integer, public :: max_iter !< maximum number of iterations to perform
- integer, public :: iter !< the actual iteration
- logical, public :: recalculate_gs !< Recalculate ground-state along the evolution.
-
- type(pes_t), public :: pesv
-
- integer, public :: dynamics
- integer, public :: energy_update_iter
- real(real64) :: scissor
-
- logical :: freeze_occ
- logical :: freeze_u
- integer :: freeze_orbitals
-
- logical :: from_scratch = .false.
-
- type(td_write_t), public :: write_handler
- type(restart_t) :: restart_load
- type(restart_t) :: restart_dump
- end type td_t
-
-
contains
- subroutine td_run_init()
+ module subroutine td_run_init()
PUSH_SUB(td_run_init)
@@ -150,17 +87,8 @@ contains
! ---------------------------------------------------------
- subroutine td_init(td, namespace, space, gr, ions, st, ks, hm, ext_partners, outp)
- type(td_t), intent(inout) :: td
- type(namespace_t), intent(in) :: namespace
- class(space_t), intent(in) :: space
- type(grid_t), intent(in) :: gr
- type(ions_t), intent(inout) :: ions
- type(states_elec_t), intent(in) :: st
- type(v_ks_t), intent(in) :: ks
- type(hamiltonian_elec_t), intent(in) :: hm
- type(partner_list_t), intent(in) :: ext_partners
- type(output_t), intent(in) :: outp
+ module subroutine td_init(sys)
+ type(electrons_t), intent(inout) :: sys
integer :: default
real(real64) :: spacing, default_dt, propagation_time
@@ -168,24 +96,24 @@ contains
PUSH_SUB(td_init)
- if (hm%pcm%run_pcm) call messages_experimental("PCM for CalculationMode = td", namespace=namespace)
+ if (sys%hm%pcm%run_pcm) call messages_experimental("PCM for CalculationMode = td", namespace=sys%namespace)
- call ion_dynamics_init(td%ions_dyn, namespace, ions)
+ call ion_dynamics_init(sys%td%ions_dyn, sys%namespace, sys%ions)
- if (ion_dynamics_ions_move(td%ions_dyn)) then
- if (hm%kpoints%use_symmetries) then
+ if (ion_dynamics_ions_move(sys%td%ions_dyn)) then
+ if (sys%hm%kpoints%use_symmetries) then
message(1) = "KPoints symmetries cannot be used with moving ions."
message(2) = "Please set KPointsSymmetries = no."
- call messages_fatal(2, namespace=namespace)
+ call messages_fatal(2, namespace=sys%namespace)
end if
- if (st%symmetrize_density) then
+ if (sys%st%symmetrize_density) then
message(1) = "Symmetrization of the density cannot be used with moving ions."
message(2) = "Please set SymmetrizeDensity = no."
- call messages_fatal(2, namespace=namespace)
+ call messages_fatal(2, namespace=sys%namespace)
end if
end if
- td%iter = 0
+ sys%td%iter = 0
!%Variable TDTimeStep
!%Type float
@@ -203,22 +131,22 @@ contains
!% However, you might need to adjust this value.
!%End
- spacing = minval(gr%spacing(1:space%dim))
+ spacing = minval(sys%gr%spacing(1:sys%space%dim))
default_dt = 0.0426_real64 - 0.207_real64*spacing + 0.808_real64*spacing**2
- call parse_variable(namespace, 'TDTimeStep', default_dt, td%dt, unit = units_inp%time)
+ call parse_variable(sys%namespace, 'TDTimeStep', default_dt, sys%td%dt, unit = units_inp%time)
- if (td%dt <= M_ZERO) then
+ if (sys%td%dt <= M_ZERO) then
write(message(1),'(a)') 'Input: TDTimeStep must be positive.'
- call messages_fatal(1, namespace=namespace)
+ call messages_fatal(1, namespace=sys%namespace)
end if
- call messages_print_var_value('TDTimeStep', td%dt, unit = units_out%time, namespace=namespace)
+ call messages_print_var_value('TDTimeStep', sys%td%dt, unit = units_out%time, namespace=sys%namespace)
- if (parse_is_defined(namespace, 'TDMaxSteps') .and. parse_is_defined(namespace, 'TDPropagationTime')) then
+ if (parse_is_defined(sys%namespace, 'TDMaxSteps') .and. parse_is_defined(sys%namespace, 'TDPropagationTime')) then
call messages_write('You cannot set TDMaxSteps and TDPropagationTime at the same time')
- call messages_fatal(namespace=namespace)
+ call messages_fatal(namespace=sys%namespace)
end if
!%Variable TDPropagationTime
@@ -233,9 +161,9 @@ contains
!% selected ev_angstrom as input units). The approximate conversions to
!% femtoseconds are 1 fs = 41.34 /Hartree = 1.52 /eV.
!%End
- call parse_variable(namespace, 'TDPropagationTime', -1.0_real64, propagation_time, unit = units_inp%time)
+ call parse_variable(sys%namespace, 'TDPropagationTime', -1.0_real64, propagation_time, unit = units_inp%time)
- call messages_obsolete_variable(namespace, 'TDMaximumIter', 'TDMaxSteps')
+ call messages_obsolete_variable(sys%namespace, 'TDMaximumIter', 'TDMaxSteps')
!%Variable TDMaxSteps
!%Type integer
@@ -246,29 +174,30 @@ contains
!% cannot use this variable together with TDPropagationTime.
!%End
default = 1500
- if (propagation_time > M_ZERO) default = nint(propagation_time/td%dt)
- call parse_variable(namespace, 'TDMaxSteps', default, td%max_iter)
+ if (propagation_time > M_ZERO) default = nint(propagation_time/sys%td%dt)
+ call parse_variable(sys%namespace, 'TDMaxSteps', default, sys%td%max_iter)
- if (propagation_time <= M_ZERO) propagation_time = td%dt*td%max_iter
+ if (propagation_time <= M_ZERO) propagation_time = sys%td%dt*sys%td%max_iter
- call messages_print_var_value('TDPropagationTime', propagation_time, unit = units_out%time, namespace=namespace)
- call messages_print_var_value('TDMaxSteps', td%max_iter, namespace=namespace)
+ call messages_print_var_value('TDPropagationTime', propagation_time, unit = units_out%time, namespace=sys%namespace)
+ call messages_print_var_value('TDMaxSteps', sys%td%max_iter, namespace=sys%namespace)
- if (td%max_iter < 1) then
- write(message(1), '(a,i6,a)') "Input: '", td%max_iter, "' is not a valid value for TDMaxSteps."
+ if (sys%td%max_iter < 1) then
+ write(message(1), '(a,i6,a)') "Input: '", sys%td%max_iter, "' is not a valid value for TDMaxSteps."
message(2) = '(TDMaxSteps <= 1)'
- call messages_fatal(2, namespace=namespace)
+ call messages_fatal(2, namespace=sys%namespace)
end if
- td%iter = 0
+ sys%td%iter = 0
- td%dt = td%dt
+ sys%td%dt = sys%td%dt
- lasers => list_get_lasers(ext_partners)
+ lasers => list_get_lasers(sys%ext_partners)
! now the photoelectron stuff
- call pes_init(td%pesv, namespace, space, gr, gr%box, st, outp%restart_write_interval, hm%kpoints, &
- hm%abs_boundaries, ext_partners, td%max_iter, td%dt)
+ call pes_init(sys%td%pesv, sys%namespace, sys%space, sys%gr, sys%gr%box, &
+ sys%st, sys%outp%restart_write_interval, sys%hm%kpoints, &
+ sys%hm%abs_boundaries, sys%ext_partners, sys%td%max_iter, sys%td%dt)
!%Variable TDDynamics
!%Type integer
@@ -283,11 +212,11 @@ contains
!% Born-Oppenheimer (Experimental).
!%End
- call parse_variable(namespace, 'TDDynamics', EHRENFEST, td%dynamics)
- if (.not. varinfo_valid_option('TDDynamics', td%dynamics)) call messages_input_error(namespace, 'TDDynamics')
- call messages_print_var_option('TDDynamics', td%dynamics, namespace=namespace)
- if (td%dynamics .ne. EHRENFEST) then
- if (.not. ion_dynamics_ions_move(td%ions_dyn)) call messages_input_error(namespace, 'TDDynamics')
+ call parse_variable(sys%namespace, 'TDDynamics', EHRENFEST, sys%td%dynamics)
+ if (.not. varinfo_valid_option('TDDynamics', sys%td%dynamics)) call messages_input_error(sys%namespace, 'TDDynamics')
+ call messages_print_var_option('TDDynamics', sys%td%dynamics, namespace=sys%namespace)
+ if (sys%td%dynamics .ne. EHRENFEST) then
+ if (.not. ion_dynamics_ions_move(sys%td%ions_dyn)) call messages_input_error(sys%namespace, 'TDDynamics')
end if
!%Variable RecalculateGSDuringEvolution
@@ -306,9 +235,9 @@ contains
!% The recalculation is not done every time step, but only every
!% RestartWriteInterval time steps.
!%End
- call parse_variable(namespace, 'RecalculateGSDuringEvolution', .false., td%recalculate_gs)
- if (hm%lda_u_level /= DFT_U_NONE .and. td%recalculate_gs) then
- call messages_not_implemented("DFT+U with RecalculateGSDuringEvolution=yes", namespace=namespace)
+ call parse_variable(sys%namespace, 'RecalculateGSDuringEvolution', .false., sys%td%recalculate_gs)
+ if (sys%hm%lda_u_level /= DFT_U_NONE .and. sys%td%recalculate_gs) then
+ call messages_not_implemented("DFT+U with RecalculateGSDuringEvolution=yes", namespace=sys%namespace)
end if
!%Variable TDScissor
@@ -320,17 +249,17 @@ contains
!% Hamiltonian, shifting the excitation energies by the amount
!% specified. By default, it is not applied.
!%End
- call parse_variable(namespace, 'TDScissor', M_ZERO, td%scissor)
- td%scissor = units_to_atomic(units_inp%energy, td%scissor)
- call messages_print_var_value('TDScissor', td%scissor, namespace=namespace)
+ call parse_variable(sys%namespace, 'TDScissor', M_ZERO, sys%td%scissor)
+ sys%td%scissor = units_to_atomic(units_inp%energy, sys%td%scissor)
+ call messages_print_var_value('TDScissor', sys%td%scissor, namespace=sys%namespace)
- call propagator_elec_init(gr, namespace, st, td%tr, ion_dynamics_ions_move(td%ions_dyn) .or. &
- list_has_gauge_field(ext_partners), family_is_mgga_with_exc(ks%xc))
+ call propagator_elec_init(sys%gr, sys%namespace, sys%st, sys%td%tr, ion_dynamics_ions_move(sys%td%ions_dyn) .or. &
+ list_has_gauge_field(sys%ext_partners), family_is_mgga_with_exc(sys%ks%xc))
if (associated(lasers) .and. mpi_grp_is_root(mpi_world)) then
- call messages_print_with_emphasis(msg="Time-dependent external fields", namespace=namespace)
- call laser_write_info(lasers%lasers, dt=td%dt, max_iter=td%max_iter, namespace=namespace)
- call messages_print_with_emphasis(namespace=namespace)
+ call messages_print_with_emphasis(msg="Time-dependent external fields", namespace=sys%namespace)
+ call laser_write_info(lasers%lasers, dt=sys%td%dt, max_iter=sys%td%max_iter, namespace=sys%namespace)
+ call messages_print_with_emphasis(namespace=sys%namespace)
end if
!%Variable TDEnergyUpdateIter
@@ -345,17 +274,17 @@ contains
!%End
default = 10
- call parse_variable(namespace, 'TDEnergyUpdateIter', default, td%energy_update_iter)
+ call parse_variable(sys%namespace, 'TDEnergyUpdateIter', default, sys%td%energy_update_iter)
- if (gr%der%boundaries%spiralBC .and. hm%ep%reltype == SPIN_ORBIT) then
+ if (sys%gr%der%boundaries%spiralBC .and. sys%hm%ep%reltype == SPIN_ORBIT) then
message(1) = "Generalized Bloch theorem cannot be used with spin-orbit coupling."
- call messages_fatal(1, namespace=namespace)
+ call messages_fatal(1, namespace=sys%namespace)
end if
- if (gr%der%boundaries%spiralBC) then
- if (any(abs(hm%kick%easy_axis(1:2)) > M_EPSILON)) then
+ if (sys%gr%der%boundaries%spiralBC) then
+ if (any(abs(sys%hm%kick%easy_axis(1:2)) > M_EPSILON)) then
message(1) = "Generalized Bloch theorem cannot be used for an easy axis not along the z direction."
- call messages_fatal(1, namespace=namespace)
+ call messages_fatal(1, namespace=sys%namespace)
end if
end if
@@ -380,13 +309,13 @@ contains
!% It is almost equivalent to setting TDFreezeOrbitals = N-1, where N is the number
!% of orbitals, but not completely.
!%End
- call parse_variable(namespace, 'TDFreezeOrbitals', 0, td%freeze_orbitals)
+ call parse_variable(sys%namespace, 'TDFreezeOrbitals', 0, sys%td%freeze_orbitals)
- if (td%freeze_orbitals /= 0) then
- call messages_experimental('TDFreezeOrbitals', namespace=namespace)
+ if (sys%td%freeze_orbitals /= 0) then
+ call messages_experimental('TDFreezeOrbitals', namespace=sys%namespace)
- if (hm%lda_u_level /= DFT_U_NONE) then
- call messages_not_implemented('TDFreezeOrbitals with DFT+U', namespace=namespace)
+ if (sys%hm%lda_u_level /= DFT_U_NONE) then
+ call messages_not_implemented('TDFreezeOrbitals with DFT+U', namespace=sys%namespace)
end if
end if
@@ -396,93 +325,81 @@ contains
end subroutine td_init
! ---------------------------------------------------------
- subroutine td_init_run(td, namespace, mc, gr, ions, st, ks, hm, ext_partners, outp, space, from_scratch)
- type(td_t), intent(inout) :: td
- type(namespace_t), intent(in) :: namespace
- type(multicomm_t), intent(inout) :: mc
- type(grid_t), intent(inout) :: gr
- type(ions_t), intent(inout) :: ions
- type(states_elec_t), intent(inout) :: st
- type(v_ks_t), intent(inout) :: ks
- type(hamiltonian_elec_t), intent(inout) :: hm
- type(partner_list_t), intent(in) :: ext_partners
- type(output_t), intent(inout) :: outp
- type(electron_space_t), intent(in) :: space
+ module subroutine td_init_run(sys, from_scratch)
+ type(electrons_t), intent(inout) :: sys
logical, intent(inout) :: from_scratch
+
+ logical :: restart_read
+
PUSH_SUB(td_init_run)
! NOTE: please do not change code in this function, but only in functions
! called from here because the logic of this function is replicated in the
! multisystem framework in different places
- call td_allocate_wavefunctions(td, namespace, mc, gr, ions, st, hm, space)
- call td_init_gaugefield(td, namespace, gr, st, ks, hm, ext_partners, space)
+ call sys%init_algorithm(propagator_factory_t(sys%namespace))
- td%from_scratch = from_scratch
+ sys%td%from_scratch = from_scratch
+ restart_read = .false.
- if (.not. td%from_scratch) then
- call td_load_restart_from_td(td, namespace, space, mc, gr, ext_partners, st, ks, hm, td%from_scratch)
- if (td%from_scratch) then
- message(1) = "Unable to read time-dependent restart information: Starting from scratch"
- call messages_warning(1, namespace=namespace)
- end if
+ call sys%init_iteration_counters()
+ if (.not. sys%td%from_scratch) then
+ restart_read = sys%restart_read()
end if
- if (td%iter >= td%max_iter) then
+ if (restart_read) then
+ message(1) = "Successfully read restart data for all system."
+ call messages_info(1, namespace=sys%namespace)
+ else
+ call sys%initial_conditions()
+ end if
+
+ if (sys%td%iter >= sys%td%max_iter) then
message(1) = "All requested iterations have already been done. Use FromScratch = yes if you want to redo them."
- call messages_info(1, namespace=namespace)
- call states_elec_deallocate_wfns(st)
- td%iter = td%iter + 1
- if (ion_dynamics_ions_move(td%ions_dyn) .and. td%recalculate_gs) call restart_end(td%restart_load)
+ call messages_info(1, namespace=sys%namespace)
+ call states_elec_deallocate_wfns(sys%st)
+ sys%td%iter = sys%td%iter + 1
+ if (ion_dynamics_ions_move(sys%td%ions_dyn) .and. sys%td%recalculate_gs) call restart_end(sys%td%restart_load)
POP_SUB(td_init_run)
return
end if
- if (td%from_scratch) then
- call td_load_restart_from_gs(td, namespace, space, mc, gr, ext_partners, st, ks, hm)
- end if
+ call sys%propagation_start()
- call td_init_with_wavefunctions(td, namespace, space, mc, gr, ions, ext_partners, st, ks, hm, outp, td%from_scratch)
+ call sys%post_init()
POP_SUB(td_init_run)
end subroutine td_init_run
! ---------------------------------------------------------
- subroutine td_allocate_wavefunctions(td, namespace, mc, gr, ions, st, hm, space)
- type(td_t), intent(inout) :: td
- type(namespace_t), intent(in) :: namespace
- type(multicomm_t), intent(inout) :: mc
- type(grid_t), intent(inout) :: gr
- type(ions_t), intent(inout) :: ions
- type(states_elec_t), intent(inout) :: st
- type(hamiltonian_elec_t), intent(inout) :: hm
- class(space_t), intent(in) :: space
+ module subroutine td_allocate_wavefunctions(sys)
+ type(electrons_t), intent(inout) :: sys
PUSH_SUB(td_allocate_wavefunctions)
! Allocate wavefunctions during time-propagation
- if (td%dynamics == EHRENFEST) then
+ if (sys%td%dynamics == EHRENFEST) then
!Note: this is not really clean to do this
- if (hm%lda_u_level /= DFT_U_NONE .and. states_are_real(st)) then
- call lda_u_end(hm%lda_u)
+ if (sys%hm%lda_u_level /= DFT_U_NONE .and. states_are_real(sys%st)) then
+ call lda_u_end(sys%hm%lda_u)
!complex wfs are required for Ehrenfest
- call states_elec_allocate_wfns(st, gr, TYPE_CMPLX, packed=.true.)
- call lda_u_init(hm%lda_u, namespace, space, hm%lda_u_level, gr, ions, st, mc, &
- hm%kpoints, hm%phase%is_allocated())
+ call states_elec_allocate_wfns(sys%st, sys%gr, TYPE_CMPLX, packed=.true.)
+ call lda_u_init(sys%hm%lda_u, sys%namespace, sys%space, sys%hm%lda_u_level, sys%gr, sys%ions, sys%st, sys%mc, &
+ sys%hm%kpoints, sys%hm%phase%is_allocated())
else
!complex wfs are required for Ehrenfest
- call states_elec_allocate_wfns(st, gr, TYPE_CMPLX, packed=.true.)
+ call states_elec_allocate_wfns(sys%st, sys%gr, TYPE_CMPLX, packed=.true.)
end if
else
- call states_elec_allocate_wfns(st, gr, packed=.true.)
- call scf_init(td%scf, namespace, gr, ions, st, mc, hm, space)
+ call states_elec_allocate_wfns(sys%st, sys%gr, packed=.true.)
+ call scf_init(sys)
end if
POP_SUB(td_allocate_wavefunctions)
end subroutine td_allocate_wavefunctions
! ---------------------------------------------------------
- subroutine td_init_gaugefield(td, namespace, gr, st, ks, hm, ext_partners, space)
+ module subroutine td_init_gaugefield(td, namespace, gr, st, ks, hm, ext_partners, space)
type(td_t), intent(inout) :: td
type(namespace_t), intent(in) :: namespace
type(grid_t), intent(inout) :: gr
@@ -513,53 +430,41 @@ contains
end subroutine td_init_gaugefield
! ---------------------------------------------------------
- subroutine td_end(td)
- type(td_t), intent(inout) :: td
+ module subroutine td_end(sys)
+ type(electrons_t), intent(inout) :: sys
PUSH_SUB(td_end)
- call pes_end(td%pesv)
- call propagator_elec_end(td%tr) ! clean the evolution method
- call ion_dynamics_end(td%ions_dyn)
+ call pes_end(sys%td%pesv)
+ call propagator_elec_end(sys%td%tr) ! clean the evolution method
+ call ion_dynamics_end(sys%td%ions_dyn)
- if (td%dynamics == BO) call scf_end(td%scf)
+ if (sys%td%dynamics == BO) call scf_end(sys)
POP_SUB(td_end)
end subroutine td_end
! ---------------------------------------------------------
- subroutine td_end_run(td, st, hm)
- type(td_t), intent(inout) :: td
- type(states_elec_t), intent(inout) :: st
- type(hamiltonian_elec_t), intent(inout) :: hm
+ module subroutine td_end_run(sys)
+ type(electrons_t), intent(inout) :: sys
PUSH_SUB(td_end_run)
- if (st%pack_states .and. hm%apply_packed()) call st%unpack()
+ if (sys%st%pack_states .and. sys%hm%apply_packed()) call sys%st%unpack()
- call restart_end(td%restart_dump)
- call td_write_end(td%write_handler)
+ call restart_end(sys%td%restart_dump)
+ call td_write_end(sys%td%write_handler)
! free memory
- call states_elec_deallocate_wfns(st)
- if (ion_dynamics_ions_move(td%ions_dyn) .and. td%recalculate_gs) call restart_end(td%restart_load)
+ call states_elec_deallocate_wfns(sys%st)
+ if (ion_dynamics_ions_move(sys%td%ions_dyn) .and. sys%td%recalculate_gs) call restart_end(sys%td%restart_load)
POP_SUB(td_end_run)
end subroutine td_end_run
! ---------------------------------------------------------
- subroutine td_run(td, namespace, mc, gr, ions, st, ks, hm, ext_partners, outp, space, from_scratch)
- type(td_t), intent(inout) :: td
- type(namespace_t), intent(in) :: namespace
- type(multicomm_t), intent(inout) :: mc
- type(grid_t), intent(inout) :: gr
- type(ions_t), intent(inout) :: ions
- type(states_elec_t), intent(inout) :: st
- type(v_ks_t), intent(inout) :: ks
- type(hamiltonian_elec_t), intent(inout) :: hm
- type(partner_list_t), intent(in) :: ext_partners
- type(output_t), intent(inout) :: outp
- type(electron_space_t), intent(in) :: space
+ module subroutine td_run(sys, from_scratch)
+ type(electrons_t), intent(inout) :: sys
logical, intent(inout) :: from_scratch
logical :: stopping
@@ -570,66 +475,69 @@ contains
etime = loct_clock()
! This is the time-propagation loop. It starts at t=0 and finishes
- ! at td%max_iter*dt. The index i runs from 1 to td%max_iter, and
+ ! at sys%td%max_iter*dt. The index i runs from 1 to sys%td%max_iter, and
! step "iter" means propagation from (iter-1)*dt to iter*dt.
- propagation: do iter = td%iter, td%max_iter
+ propagation: do iter = sys%td%iter, sys%td%max_iter
- stopping = clean_stop(mc%master_comm) .or. walltimer_alarm(mc%master_comm)
+ stopping = clean_stop(sys%mc%master_comm) .or. walltimer_alarm(sys%mc%master_comm)
call profiling_in("TIME_STEP")
if (iter > 1) then
- if (((iter-1)*td%dt <= hm%kick%time) .and. (iter*td%dt > hm%kick%time)) then
- if (.not. hm%pcm%localf) then
- call kick_apply(space, gr, st, td%ions_dyn, ions, hm%kick, hm%psolver, hm%kpoints)
+ if (((iter-1)*sys%td%dt <= sys%hm%kick%time) .and. (iter*sys%td%dt > sys%hm%kick%time)) then
+ if (.not. sys%hm%pcm%localf) then
+ call kick_apply(sys%space, sys%gr, sys%st, sys%td%ions_dyn, sys%ions, &
+ sys%hm%kick, sys%hm%psolver, sys%hm%kpoints)
else
- call kick_apply(space, gr, st, td%ions_dyn, ions, hm%kick, hm%psolver, hm%kpoints, pcm = hm%pcm)
+ call kick_apply(sys%space, sys%gr, sys%st, sys%td%ions_dyn, sys%ions, &
+ sys%hm%kick, sys%hm%psolver, sys%hm%kpoints, pcm = sys%hm%pcm)
end if
- call td_write_kick(outp, namespace, space, gr, hm%kick, ions, iter)
+ call td_write_kick(sys%outp, sys%namespace, sys%space, sys%gr, sys%hm%kick, sys%ions, iter)
!We activate the sprial BC only after the kick,
!to be sure that the first iteration corresponds to the ground state
- if (gr%der%boundaries%spiralBC) gr%der%boundaries%spiral = .true.
+ if (sys%gr%der%boundaries%spiralBC) sys%gr%der%boundaries%spiral = .true.
end if
end if
! time iterate the system, one time step.
- select case (td%dynamics)
+ select case (sys%td%dynamics)
case (EHRENFEST)
- call propagator_elec_dt(ks, namespace, space, hm, gr, st, td%tr, iter*td%dt, td%dt, iter, td%ions_dyn, &
- ions, ext_partners, outp, td%write_handler, scsteps = scsteps, &
- update_energy = (mod(iter, td%energy_update_iter) == 0) .or. (iter == td%max_iter))
+ call propagator_elec_dt(sys, sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, sys%st, sys%td%tr, &
+ iter*sys%td%dt, sys%td%dt, iter, sys%td%ions_dyn, &
+ sys%ions, sys%ext_partners, sys%outp, sys%td%write_handler, scsteps = scsteps, &
+ update_energy = (mod(iter, sys%td%energy_update_iter) == 0) .or. (iter == sys%td%max_iter))
case (BO)
- call propagator_elec_dt_bo(td%scf, namespace, space, gr, ks, st, hm, ions, ext_partners, mc, outp, iter, &
- td%dt, td%ions_dyn, scsteps)
+ call propagator_elec_dt_bo(sys, iter, scsteps)
end select
!Apply mask absorbing boundaries
- if (hm%abs_boundaries%abtype == MASK_ABSORBING) then
- if (states_are_real(st)) then
- call dvmask(gr, hm, st)
+ if (sys%hm%abs_boundaries%abtype == MASK_ABSORBING) then
+ if (states_are_real(sys%st)) then
+ call dvmask(sys%gr, sys%hm, sys%st)
else
- call zvmask(gr, hm, st)
+ call zvmask(sys%gr, sys%hm, sys%st)
end if
end if
!Photoelectron stuff
- if (td%pesv%calc_spm .or. td%pesv%calc_mask .or. td%pesv%calc_flux) then
- call pes_calc(td%pesv, namespace, space, gr, st, td%dt, iter, gr%der, hm%kpoints, ext_partners, stopping)
+ if (sys%td%pesv%calc_spm .or. sys%td%pesv%calc_mask .or. sys%td%pesv%calc_flux) then
+ call pes_calc(sys%td%pesv, sys%namespace, sys%space, sys%gr, sys%st, sys%td%dt, iter, sys%gr%der, &
+ sys%hm%kpoints, sys%ext_partners, stopping)
end if
- call td_write_iter(td%write_handler, namespace, space, outp, gr, st, hm, ions, ext_partners, &
- hm%kick, ks, td%dt, iter, mc, td%recalculate_gs)
+ call sys%output_write()
! write down data
- call td_check_point(td, namespace, mc, gr, ions, st, ks, hm, ext_partners, outp, space, &
- iter, scsteps, etime, stopping, from_scratch)
+ call td_check_point(sys, iter, scsteps, etime, stopping, from_scratch)
! check if debug mode should be enabled or disabled on the fly
- call io_debug_on_the_fly(namespace)
+ call io_debug_on_the_fly(sys%namespace)
call profiling_out("TIME_STEP")
if (stopping) exit
+ sys%iteration = sys%iteration + 1
+
end do propagation
POP_SUB(td_run)
@@ -649,19 +557,8 @@ contains
end subroutine td_print_header
! ---------------------------------------------------------
- subroutine td_check_point(td, namespace, mc, gr, ions, st, ks, hm, ext_partners, outp, space, &
- iter, scsteps, etime, stopping, from_scratch)
- type(td_t), intent(inout) :: td
- type(namespace_t), intent(in) :: namespace
- type(multicomm_t), intent(in) :: mc
- type(grid_t), intent(inout) :: gr
- type(ions_t), intent(inout) :: ions
- type(states_elec_t), intent(inout) :: st
- type(v_ks_t), intent(inout) :: ks
- type(hamiltonian_elec_t), intent(inout) :: hm
- type(partner_list_t), intent(in) :: ext_partners
- type(output_t), intent(in) :: outp
- type(electron_space_t), intent(in) :: space
+ subroutine td_check_point(sys, iter, scsteps, etime, stopping, from_scratch)
+ type(electrons_t), intent(inout) :: sys
integer, intent(in) :: iter
integer, intent(in) :: scsteps
real(real64), intent(inout) :: etime
@@ -672,40 +569,30 @@ contains
PUSH_SUB(td_check_point)
- call td_print_message(td, namespace, ions, hm, iter, scsteps, etime)
-
- if (outp%anything_now(iter)) then ! output
- call td_write_output(namespace, space, gr, st, hm, ks, outp, ions, ext_partners, iter, td%dt)
- end if
-
- if (mod(iter, outp%restart_write_interval) == 0 .or. iter == td%max_iter .or. stopping) then ! restart
- !if (iter == td%max_iter) outp%iter = ii - 1
- call td_write_data(td%write_handler)
- call td_dump(td, namespace, space, gr, st, hm, ks, ext_partners, iter, ierr)
- if (ierr /= 0) then
- message(1) = "Unable to write time-dependent restart information."
- call messages_warning(1, namespace=namespace)
- end if
+ call td_print_message(sys%td, sys%namespace, sys%ions, sys%hm, iter, scsteps, etime)
- call pes_output(td%pesv, namespace, space, gr, st, iter, outp, td%dt, ions)
+ if (mod(iter, sys%outp%restart_write_interval) == 0 .or. iter == sys%td%max_iter .or. stopping) then ! restart
+ call sys%restart_write()
- if (ion_dynamics_ions_move(td%ions_dyn) .and. td%recalculate_gs) then
- call messages_print_with_emphasis(msg='Recalculating the ground state.', namespace=namespace)
+ if (ion_dynamics_ions_move(sys%td%ions_dyn) .and. sys%td%recalculate_gs) then
+ call messages_print_with_emphasis(msg='Recalculating the ground state.', namespace=sys%namespace)
from_scratch = .false.
- call states_elec_deallocate_wfns(st)
- call electrons_ground_state_run(namespace, mc, gr, ions, ext_partners, st, ks, hm, outp, space, from_scratch)
- call states_elec_allocate_wfns(st, gr, packed=.true.)
- call td_load(td%restart_load, namespace, space, gr, st, hm, ext_partners, td, ks, ierr)
+ call states_elec_deallocate_wfns(sys%st)
+ call electrons_ground_state_run(sys, from_scratch)
+ call states_elec_allocate_wfns(sys%st, sys%gr, packed=.true.)
+ call td_load(sys%td%restart_load, sys%namespace, sys%space, sys%gr, sys%st, sys%hm, &
+ sys%ext_partners, sys%td, sys%ks, ierr)
if (ierr /= 0) then
message(1) = "Unable to load TD states."
- call messages_fatal(1, namespace=namespace)
+ call messages_fatal(1, namespace=sys%namespace)
end if
- call density_calc(st, gr, st%rho)
- call v_ks_calc(ks, namespace, space, hm, st, ions, ext_partners, &
- calc_eigenval=.true., time = iter*td%dt, calc_energy=.true.)
- call forces_calculate(gr, namespace, ions, hm, ext_partners, st, ks, t = iter*td%dt, dt = td%dt)
- call messages_print_with_emphasis(msg="Time-dependent simulation proceeds", namespace=namespace)
- call td_print_header(namespace)
+ call density_calc(sys%st, sys%gr, sys%st%rho)
+ call v_ks_calc(sys%ks, sys%namespace, sys%space, sys%hm, sys%st, sys%ions, sys%ext_partners, &
+ calc_eigenval=.true., time = iter*sys%td%dt, calc_energy=.true.)
+ call forces_calculate(sys%gr, sys%namespace, sys%ions, sys%hm, sys%ext_partners, sys%st, &
+ sys%ks, t = iter*sys%td%dt, dt = sys%td%dt)
+ call messages_print_with_emphasis(msg="Time-dependent simulation proceeds", namespace=sys%namespace)
+ call td_print_header(sys%namespace)
end if
end if
@@ -745,23 +632,12 @@ contains
end subroutine td_update_elapsed_time
! ---------------------------------------------------------
- subroutine td_init_with_wavefunctions(td, namespace, space, mc, gr, ions, ext_partners, st, ks, hm, outp, from_scratch)
- type(td_t), intent(inout) :: td
- type(namespace_t), intent(in) :: namespace
- type(electron_space_t), intent(in) :: space
- type(multicomm_t), intent(in) :: mc
- type(grid_t), intent(inout) :: gr
- type(ions_t), intent(inout) :: ions
- type(partner_list_t), intent(in) :: ext_partners
- type(states_elec_t), target, intent(inout) :: st
- type(v_ks_t), intent(inout) :: ks
- type(hamiltonian_elec_t), intent(inout) :: hm
- type(output_t), intent(inout) :: outp
- logical, intent(in) :: from_scratch
+ module subroutine td_init_with_wavefunctions(sys)
+ type(electrons_t), target, intent(inout) :: sys
integer :: ierr
real(real64) :: x
- real(real64) :: ndinitial(space%dim)
+ real(real64) :: ndinitial(sys%space%dim)
logical :: freeze_hxc, freeze_occ, freeze_u
type(restart_t) :: restart, restart_frozen
type(gauge_field_t), pointer :: gfield
@@ -770,64 +646,69 @@ contains
!We activate the sprial BC only after the kick,
!to be sure that the first iteration corresponds to the ground state
- if (gr%der%boundaries%spiralBC) then
- if ((td%iter-1)*td%dt > hm%kick%time) then
- gr%der%boundaries%spiral = .true.
+ if (sys%gr%der%boundaries%spiralBC) then
+ if ((sys%td%iter-1)*sys%td%dt > sys%hm%kick%time) then
+ sys%gr%der%boundaries%spiral = .true.
end if
- hm%vnl%spin => st%spin
- hm%phase%spin => st%spin
+ sys%hm%vnl%spin => sys%st%spin
+ sys%hm%phase%spin => sys%st%spin
!We fill st%spin. In case of restart, we read it in td_load
- if (from_scratch) call states_elec_fermi(st, namespace, gr)
+ if (sys%td%from_scratch) call states_elec_fermi(sys%st, sys%namespace, sys%gr)
end if
- if (from_scratch) then
+ if (sys%td%from_scratch) then
! Initialize the occupation matrices and U for DFT+U
! This must be called before parsing TDFreezeOccupations and TDFreezeU
! in order that the code does properly the initialization.
- call lda_u_update_occ_matrices(hm%lda_u, namespace, gr, st, hm%hm_base, hm%phase, hm%energy)
+ call lda_u_update_occ_matrices(sys%hm%lda_u, sys%namespace, sys%gr, &
+ sys%st, sys%hm%hm_base, sys%hm%phase, sys%hm%energy)
end if
- if (td%freeze_orbitals > 0) then
- if (from_scratch) then
+ if (sys%td%freeze_orbitals > 0) then
+ if (sys%td%from_scratch) then
! In this case, we first freeze the orbitals, then calculate the Hxc potential.
- call states_elec_freeze_orbitals(st, namespace, space, gr, mc, hm%kpoints, &
- td%freeze_orbitals, family_is_mgga(ks%xc_family))
+ call states_elec_freeze_orbitals(sys%st, sys%namespace, sys%space, sys%gr, sys%mc, sys%hm%kpoints, &
+ sys%td%freeze_orbitals, family_is_mgga(sys%ks%xc_family))
else
- call restart_init(restart, namespace, RESTART_TD, RESTART_TYPE_LOAD, mc, ierr, mesh=gr)
+ call restart_init(restart, sys%namespace, RESTART_TD, RESTART_TYPE_LOAD, sys%mc, ierr, mesh=sys%gr)
if (ierr == 0) then
- call td_load_frozen(namespace, restart, space, gr, st, hm, ierr)
+ call td_load_frozen(sys%namespace, restart, sys%space, sys%gr, sys%st, sys%hm, ierr)
end if
if (ierr /= 0) then
- td%iter = 0
+ sys%td%iter = 0
message(1) = "Unable to read frozen restart information."
- call messages_fatal(1, namespace=namespace)
+ call messages_fatal(1, namespace=sys%namespace)
end if
call restart_end(restart)
end if
- write(message(1),'(a,i4,a,i4,a)') 'Info: The lowest', td%freeze_orbitals, &
- ' orbitals have been frozen.', st%nst, ' will be propagated.'
- call messages_info(1, namespace=namespace)
- call states_elec_freeze_adjust_qtot(st)
- call density_calc(st, gr, st%rho)
- call v_ks_calc(ks, namespace, space, hm, st, ions, ext_partners, calc_eigenval=.true., time = td%iter*td%dt)
- else if (td%freeze_orbitals < 0) then
+ write(message(1),'(a,i4,a,i4,a)') 'Info: The lowest', sys%td%freeze_orbitals, &
+ ' orbitals have been frozen.', sys%st%nst, ' will be propagated.'
+ call messages_info(1, namespace=sys%namespace)
+ call states_elec_freeze_adjust_qtot(sys%st)
+ call density_calc(sys%st, sys%gr, sys%st%rho)
+ call v_ks_calc(sys%ks, sys%namespace, sys%space, sys%hm, sys%st, sys%ions, &
+ sys%ext_partners, calc_eigenval=.true., time = sys%td%iter*sys%td%dt)
+ else if (sys%td%freeze_orbitals < 0) then
! This means SAE approximation. We calculate the Hxc first, then freeze all
! orbitals minus one.
write(message(1),'(a)') 'Info: The single-active-electron approximation will be used.'
- call messages_info(1, namespace=namespace)
- call v_ks_calc(ks, namespace, space, hm, st, ions, ext_partners, calc_eigenval=.true., time = td%iter*td%dt)
- if (from_scratch) then
- call states_elec_freeze_orbitals(st, namespace, space, gr, mc, hm%kpoints, st%nst-1, family_is_mgga(ks%xc_family))
+ call messages_info(1, namespace=sys%namespace)
+ call v_ks_calc(sys%ks, sys%namespace, sys%space, sys%hm, sys%st, sys%ions, &
+ sys%ext_partners, calc_eigenval=.true., time = sys%td%iter*sys%td%dt)
+ if (sys%td%from_scratch) then
+ call states_elec_freeze_orbitals(sys%st, sys%namespace, sys%space, sys%gr, &
+ sys%mc, sys%hm%kpoints, sys%st%nst-1, family_is_mgga(sys%ks%xc_family))
else
- call messages_not_implemented("TDFreezeOrbials < 0 with FromScratch=no", namespace=namespace)
+ call messages_not_implemented("TDFreezeOrbials < 0 with FromScratch=no", namespace=sys%namespace)
end if
- call states_elec_freeze_adjust_qtot(st)
- call v_ks_freeze_hxc(ks)
- call density_calc(st, gr, st%rho)
+ call states_elec_freeze_adjust_qtot(sys%st)
+ call v_ks_freeze_hxc(sys%ks)
+ call density_calc(sys%st, sys%gr, sys%st%rho)
else
! Normal run.
- call density_calc(st, gr, st%rho)
- call v_ks_calc(ks, namespace, space, hm, st, ions, ext_partners, calc_eigenval=.true., time = td%iter*td%dt)
+ call density_calc(sys%st, sys%gr, sys%st%rho)
+ call v_ks_calc(sys%ks, sys%namespace, sys%space, sys%hm, sys%st, sys%ions, &
+ sys%ext_partners, calc_eigenval=.true., time = sys%td%iter*sys%td%dt)
end if
!%Variable TDFreezeHXC
@@ -838,40 +719,47 @@ contains
!% The electrons are evolved as independent particles feeling the Hartree and
!% exchange-correlation potentials from the ground-state electronic configuration.
!%End
- call parse_variable(namespace, 'TDFreezeHXC', .false., freeze_hxc)
+ call parse_variable(sys%namespace, 'TDFreezeHXC', .false., freeze_hxc)
if (freeze_hxc) then
write(message(1),'(a)') 'Info: Freezing Hartree and exchange-correlation potentials.'
- call messages_info(1, namespace=namespace)
+ call messages_info(1, namespace=sys%namespace)
- if (.not. from_scratch) then
+ if (.not. sys%td%from_scratch) then
- call restart_init(restart_frozen, namespace, RESTART_GS, RESTART_TYPE_LOAD, mc, ierr, mesh=gr, exact=.true.)
- call states_elec_load(restart_frozen, namespace, space, st, gr, hm%kpoints, ierr, label = ": gs")
- call states_elec_transform(st, namespace, space, restart_frozen, gr, hm%kpoints)
+ call restart_init(restart_frozen, sys%namespace, RESTART_GS, &
+ RESTART_TYPE_LOAD, sys%mc, ierr, mesh=sys%gr, exact=.true.)
+ call states_elec_load(restart_frozen, sys%namespace, sys%space, &
+ sys%st, sys%gr, sys%hm%kpoints, ierr, label = ": gs")
+ call states_elec_transform(sys%st, sys%namespace, sys%space, &
+ restart_frozen, sys%gr, sys%hm%kpoints)
call restart_end(restart_frozen)
- call density_calc(st, gr, st%rho)
- call v_ks_calc(ks, namespace, space, hm, st, ions, ext_partners, calc_eigenval=.true., time = td%iter*td%dt)
+ call density_calc(sys%st, sys%gr, sys%st%rho)
+ call v_ks_calc(sys%ks, sys%namespace, sys%space, sys%hm, sys%st, &
+ sys%ions, sys%ext_partners, calc_eigenval=.true., &
+ time = sys%td%iter*sys%td%dt)
- call restart_init(restart_frozen, namespace, RESTART_TD, RESTART_TYPE_LOAD, mc, ierr, mesh=gr)
- call states_elec_load(restart_frozen, namespace, space, st, gr, hm%kpoints, ierr, iter=td%iter, label = ": td")
+ call restart_init(restart_frozen, sys%namespace, RESTART_TD, &
+ RESTART_TYPE_LOAD, sys%mc, ierr, mesh=sys%gr)
+ call states_elec_load(restart_frozen, sys%namespace, sys%space, &
+ sys%st, sys%gr, sys%hm%kpoints, ierr, iter=sys%td%iter, label = ": td")
call restart_end(restart_frozen)
- call propagator_elec_run_zero_iter(hm, gr, td%tr)
+ call propagator_elec_run_zero_iter(sys%hm, sys%gr, sys%td%tr)
end if
- call v_ks_freeze_hxc(ks)
+ call v_ks_freeze_hxc(sys%ks)
end if
- x = minval(st%eigenval(st%st_start, :))
- if (st%parallel_in_states) then
- call st%mpi_grp%bcast(x, 1, MPI_DOUBLE_PRECISION, 0)
+ x = minval(sys%st%eigenval(sys%st%st_start, :))
+ if (sys%st%parallel_in_states) then
+ call sys%st%mpi_grp%bcast(x, 1, MPI_DOUBLE_PRECISION, 0)
end if
- call hm%update_span(gr%spacing(1:space%dim), x, namespace)
+ call sys%hm%update_span(sys%gr%spacing(1:sys%space%dim), x, sys%namespace)
! initialize Fermi energy
- call states_elec_fermi(st, namespace, gr, compute_spin = .not. gr%der%boundaries%spiralBC)
- call energy_calc_total(namespace, space, hm, gr, st, ext_partners)
+ call states_elec_fermi(sys%st, sys%namespace, sys%gr, compute_spin = .not. sys%gr%der%boundaries%spiralBC)
+ call energy_calc_total(sys%namespace, sys%space, sys%hm, sys%gr, sys%st, sys%ext_partners)
!%Variable TDFreezeDFTUOccupations
!%Type logical
@@ -881,16 +769,16 @@ contains
!% The occupation matrices than enters in the DFT+U potential
!% are not evolved during the time evolution.
!%End
- call parse_variable(namespace, 'TDFreezeDFTUOccupations', .false., freeze_occ)
+ call parse_variable(sys%namespace, 'TDFreezeDFTUOccupations', .false., freeze_occ)
if (freeze_occ) then
write(message(1),'(a)') 'Info: Freezing DFT+U occupation matrices that enters in the DFT+U potential.'
- call messages_info(1, namespace=namespace)
- call lda_u_freeze_occ(hm%lda_u)
+ call messages_info(1, namespace=sys%namespace)
+ call lda_u_freeze_occ(sys%hm%lda_u)
!In this case we should reload GS wavefunctions
- if (hm%lda_u_level /= DFT_U_NONE .and. .not. from_scratch) then
- call restart_init(restart_frozen, namespace, RESTART_GS, RESTART_TYPE_LOAD, mc, ierr, mesh=gr)
- call lda_u_load(restart_frozen, hm%lda_u, st, hm%energy%dft_u, ierr, occ_only = .true.)
+ if (sys%hm%lda_u_level /= DFT_U_NONE .and. .not. sys%td%from_scratch) then
+ call restart_init(restart_frozen, sys%namespace, RESTART_GS, RESTART_TYPE_LOAD, sys%mc, ierr, mesh=sys%gr)
+ call lda_u_load(restart_frozen, sys%hm%lda_u, sys%st, sys%hm%energy%dft_u, ierr, occ_only = .true.)
call restart_end(restart_frozen)
end if
end if
@@ -902,77 +790,82 @@ contains
!%Description
!% The effective U of DFT+U is not evolved during the time evolution.
!%End
- call parse_variable(namespace, 'TDFreezeU', .false., freeze_u)
+ call parse_variable(sys%namespace, 'TDFreezeU', .false., freeze_u)
if (freeze_u) then
write(message(1),'(a)') 'Info: Freezing the effective U of DFT+U.'
- call messages_info(1, namespace=namespace)
- call lda_u_freeze_u(hm%lda_u)
+ call messages_info(1, namespace=sys%namespace)
+ call lda_u_freeze_u(sys%hm%lda_u)
!In this case we should reload GS wavefunctions
- if (hm%lda_u_level == DFT_U_ACBN0 .and. .not. from_scratch) then
- call restart_init(restart_frozen, namespace, RESTART_GS, RESTART_TYPE_LOAD, mc, ierr, mesh=gr)
- call lda_u_load(restart_frozen, hm%lda_u, st, hm%energy%dft_u, ierr, u_only = .true.)
+ if (sys%hm%lda_u_level == DFT_U_ACBN0 .and. .not. sys%td%from_scratch) then
+ call restart_init(restart_frozen, sys%namespace, RESTART_GS, RESTART_TYPE_LOAD, sys%mc, ierr, mesh=sys%gr)
+ call lda_u_load(restart_frozen, sys%hm%lda_u, sys%st, sys%hm%energy%dft_u, ierr, u_only = .true.)
call restart_end(restart_frozen)
write(message(1),'(a)') 'Loaded GS effective U of DFT+U'
- call messages_info(1, namespace=namespace)
- call lda_u_write_u(hm%lda_u, namespace=namespace)
- call lda_u_write_v(hm%lda_u, namespace=namespace)
+ call messages_info(1, namespace=sys%namespace)
+ call lda_u_write_u(sys%hm%lda_u, namespace=sys%namespace)
+ call lda_u_write_v(sys%hm%lda_u, namespace=sys%namespace)
end if
end if
! This needs to be called before the calculation of the forces,
! as we need to test of we output the forces or not
- call td_write_init(td%write_handler, namespace, space, outp, gr, st, hm, ions, ext_partners, &
- ks, ion_dynamics_ions_move(td%ions_dyn), &
- list_has_gauge_field(ext_partners), hm%kick, td%iter, td%max_iter, td%dt, mc)
+ call td_write_init(sys%td%write_handler, sys%namespace, sys%space, &
+ sys%outp, sys%gr, sys%st, sys%hm, sys%ions, sys%ext_partners, &
+ sys%ks, ion_dynamics_ions_move(sys%td%ions_dyn), &
+ list_has_gauge_field(sys%ext_partners), sys%hm%kick, sys%td%iter, &
+ sys%td%max_iter, sys%td%dt, sys%mc)
! Resets the nondipole integration after laser-file has been written.
- lasers => list_get_lasers(ext_partners)
+ lasers => list_get_lasers(sys%ext_partners)
if(associated(lasers)) then
if (lasers_with_nondipole_field(lasers)) then
- ndinitial(1:space%dim)=M_ZERO
+ ndinitial(1:sys%space%dim)=M_ZERO
call lasers_set_nondipole_parameters(lasers,ndinitial,M_ZERO)
end if
end if
nullify(lasers)
- call td_init_ions_and_forces(td, namespace, space, gr, ions, ext_partners, st, ks, hm, outp)
+ call td_init_ions_and_forces(sys%td, sys%namespace, sys%space, sys%gr, &
+ sys%ions, sys%ext_partners, sys%st, sys%ks, sys%hm, sys%outp)
- if (td%scissor > M_EPSILON) then
- call scissor_init(hm%scissor, namespace, space, st, gr, hm%d, hm%kpoints, hm%phase, td%scissor, mc)
+ if (sys%td%scissor > M_EPSILON) then
+ call scissor_init(sys%hm%scissor, sys%namespace, sys%space, sys%st, &
+ sys%gr, sys%hm%d, sys%hm%kpoints, sys%hm%phase, sys%td%scissor, sys%mc)
end if
- if (td%iter == 0) call td_run_zero_iter(td, namespace, space, gr, ions, st, ks, hm, ext_partners, outp, mc)
+ if (sys%td%iter == 0) call td_run_zero_iter(sys)
- gfield => list_get_gauge_field(ext_partners)
+ gfield => list_get_gauge_field(sys%ext_partners)
if(associated(gfield)) then
if (gauge_field_is_propagated(gfield)) then
- if(ks%xc%kernel_lrc_alpha > M_EPSILON) then
- call gauge_field_get_force(gfield, gr, st%d%spin_channels, st%current, ks%xc%kernel_lrc_alpha)
+ if(sys%ks%xc%kernel_lrc_alpha > M_EPSILON) then
+ call gauge_field_get_force(gfield, sys%gr, sys%st%d%spin_channels, &
+ sys%st%current, sys%ks%xc%kernel_lrc_alpha)
call messages_experimental('TD-LRC kernel')
else
- call gauge_field_get_force(gfield, gr, st%d%spin_channels, st%current)
+ call gauge_field_get_force(gfield, sys%gr, sys%st%d%spin_channels, sys%st%current)
endif
endif
end if
- !call td_check_trotter(td, sys, h)
- td%iter = td%iter + 1
+ !call td_check_trotter(sys%td, sys, h)
+! sys%td%iter = sys%td%iter + 1
- call restart_init(td%restart_dump, namespace, RESTART_TD, RESTART_TYPE_DUMP, mc, ierr, mesh=gr)
- if (ion_dynamics_ions_move(td%ions_dyn) .and. td%recalculate_gs) then
+ call restart_init(sys%td%restart_dump, sys%namespace, RESTART_TD, RESTART_TYPE_DUMP, sys%mc, ierr, mesh=sys%gr)
+ if (ion_dynamics_ions_move(sys%td%ions_dyn) .and. sys%td%recalculate_gs) then
! We will also use the TD restart directory as temporary storage during the time propagation
- call restart_init(td%restart_load, namespace, RESTART_TD, RESTART_TYPE_LOAD, mc, ierr, mesh=gr)
+ call restart_init(sys%td%restart_load, sys%namespace, RESTART_TD, RESTART_TYPE_LOAD, sys%mc, ierr, mesh=sys%gr)
end if
- call messages_print_with_emphasis(msg="Time-Dependent Simulation", namespace=namespace)
- call td_print_header(namespace)
+ call messages_print_with_emphasis(msg="Time-Dependent Simulation", namespace=sys%namespace)
+ call td_print_header(sys%namespace)
- if (td%pesv%calc_spm .or. td%pesv%calc_mask .and. from_scratch) then
- call pes_init_write(td%pesv,gr,st, namespace)
+ if (sys%td%pesv%calc_spm .or. sys%td%pesv%calc_mask .and. sys%td%from_scratch) then
+ call pes_init_write(sys%td%pesv,sys%gr,sys%st, sys%namespace)
end if
- if (st%pack_states .and. hm%apply_packed()) call st%pack()
+ if (sys%st%pack_states .and. sys%hm%apply_packed()) call sys%st%pack()
POP_SUB(td_init_with_wavefunctions)
end subroutine td_init_with_wavefunctions
@@ -1021,7 +914,7 @@ contains
end subroutine td_init_ions_and_forces
! ---------------------------------------------------------
- subroutine td_load_restart_from_td(td, namespace, space, mc, gr, ext_partners, st, ks, hm, from_scratch)
+ module subroutine td_load_restart_from_td(td, namespace, space, mc, gr, ext_partners, st, ks, hm, from_scratch)
type(td_t), intent(inout) :: td
type(namespace_t), intent(in) :: namespace
class(space_t), intent(in) :: space
@@ -1057,7 +950,7 @@ contains
end subroutine td_load_restart_from_td
! ---------------------------------------------------------
- subroutine td_load_restart_from_gs(td, namespace, space, mc, gr, ext_partners, st, ks, hm)
+ module subroutine td_load_restart_from_gs(td, namespace, space, mc, gr, ext_partners, st, ks, hm)
type(td_t), intent(inout) :: td
type(namespace_t), intent(in) :: namespace
class(space_t), intent(in) :: space
@@ -1099,43 +992,31 @@ contains
end subroutine td_load_restart_from_gs
! ---------------------------------------------------------
- subroutine td_run_zero_iter(td, namespace, space, gr, ions, st, ks, hm, ext_partners, outp, mc)
- type(td_t), intent(inout) :: td
- type(namespace_t), intent(in) :: namespace
- type(electron_space_t), intent(in) :: space
- type(grid_t), intent(inout) :: gr
- type(ions_t), intent(inout) :: ions
- type(states_elec_t), intent(inout) :: st
- type(v_ks_t), intent(inout) :: ks
- type(hamiltonian_elec_t), intent(inout) :: hm
- type(partner_list_t), intent(in) :: ext_partners
- type(output_t), intent(in) :: outp
- type(multicomm_t), intent(in) :: mc
+ subroutine td_run_zero_iter(sys)
+ type(electrons_t), intent(inout) :: sys
PUSH_SUB(td_run_zero_iter)
- call td_write_iter(td%write_handler, namespace, space, outp, gr, st, hm, ions, ext_partners, &
- hm%kick, ks, td%dt, 0, mc, td%recalculate_gs)
-
! I apply the delta electric field *after* td_write_iter, otherwise the
! dipole matrix elements in write_proj are wrong
- if (abs(hm%kick%time) <= M_EPSILON) then
- if (.not. hm%pcm%localf) then
- call kick_apply(space, gr, st, td%ions_dyn, ions, hm%kick, hm%psolver, hm%kpoints)
+ if (abs(sys%hm%kick%time) <= M_EPSILON) then
+ if (.not. sys%hm%pcm%localf) then
+ call kick_apply(sys%space, sys%gr, sys%st, sys%td%ions_dyn, sys%ions, &
+ sys%hm%kick, sys%hm%psolver, sys%hm%kpoints)
else
- call kick_apply(space, gr, st, td%ions_dyn, ions, hm%kick, hm%psolver, hm%kpoints, pcm = hm%pcm)
+ call kick_apply(sys%space, sys%gr, sys%st, sys%td%ions_dyn, sys%ions, &
+ sys%hm%kick, sys%hm%psolver, sys%hm%kpoints, pcm = sys%hm%pcm)
end if
- call td_write_kick(outp, namespace, space, gr, hm%kick, ions, 0)
+ call td_write_kick(sys%outp, sys%namespace, sys%space, sys%gr, sys%hm%kick, sys%ions, 0)
!We activate the sprial BC only after the kick
- if (gr%der%boundaries%spiralBC) then
- gr%der%boundaries%spiral = .true.
+ if (sys%gr%der%boundaries%spiralBC) then
+ sys%gr%der%boundaries%spiral = .true.
end if
end if
- call propagator_elec_run_zero_iter(hm, gr, td%tr)
- if (any(outp%output_interval > 0)) then
- call td_write_data(td%write_handler)
- call td_write_output(namespace, space, gr, st, hm, ks, outp, ions, ext_partners, 0)
+ call propagator_elec_run_zero_iter(sys%hm, sys%gr, sys%td%tr)
+ if (any(sys%outp%output_interval > 0)) then
+ call td_write_data(sys%td%write_handler)
end if
POP_SUB(td_run_zero_iter)
@@ -1189,7 +1070,7 @@ contains
end subroutine td_read_coordinates
! ---------------------------------------------------------
- subroutine td_dump(td, namespace, space, gr, st, hm, ks, ext_partners, iter, ierr)
+ module subroutine td_dump(td, namespace, space, gr, st, hm, ks, ext_partners, iter, ierr)
type(td_t), intent(in) :: td
type(namespace_t), intent(in) :: namespace
class(space_t), intent(in) :: space
@@ -1413,18 +1294,19 @@ contains
end subroutine td_load_frozen
! ---------------------------------------------------------
- logical function td_get_from_scratch(td)
+ module function td_get_from_scratch(td) result(res)
type(td_t), intent(in) :: td
+ logical :: res
PUSH_SUB(td_get_from_scratch)
- td_get_from_scratch = td%from_scratch
+ res = td%from_scratch
POP_SUB(td_get_from_scratch)
end function td_get_from_scratch
! ---------------------------------------------------------
- subroutine td_set_from_scratch(td, from_scratch)
+ module subroutine td_set_from_scratch(td, from_scratch)
type(td_t), intent(inout) :: td
logical, intent(in) :: from_scratch
@@ -1434,7 +1316,7 @@ contains
POP_SUB(td_set_from_scratch)
end subroutine td_set_from_scratch
-end module td_oct_m
+end submodule impl
!! Local Variables:
!! mode: f90
diff --git a/src/td/td_interface_h.F90 b/src/td/td_interface_h.F90
new file mode 100644
index 0000000000000000000000000000000000000000..2c4abd4ece40a9bafe5656be102474cdec180292
--- /dev/null
+++ b/src/td/td_interface_h.F90
@@ -0,0 +1,128 @@
+module td_interface_oct_m
+ use electrons_oct_m
+ use electron_space_oct_m
+ use grid_oct_m
+ use hamiltonian_elec_oct_m
+ use interaction_partner_oct_m
+ use ions_oct_m
+ use multicomm_oct_m
+ use namespace_oct_m
+ use output_low_oct_m
+ use space_oct_m
+ use states_elec_oct_m
+ use td_oct_m
+ use v_ks_oct_m
+ use, intrinsic :: iso_fortran_env
+
+ private
+ public :: &
+ td_run, &
+ td_run_init, &
+ td_init, &
+ td_init_run, &
+ td_end, &
+ td_end_run, &
+ td_dump, &
+ td_allocate_wavefunctions, &
+ td_init_gaugefield, &
+ td_load_restart_from_gs, &
+ td_load_restart_from_td, &
+ td_init_with_wavefunctions,&
+ td_get_from_scratch, &
+ td_set_from_scratch
+
+ ! Subroutine/Functions
+ interface
+ module subroutine td_run(sys, from_scratch)
+ type(electrons_t), intent(inout) :: sys
+ logical, intent(inout) :: from_scratch
+ end subroutine td_run
+
+ module subroutine td_run_init()
+ end subroutine td_run_init
+
+ module subroutine td_init(sys)
+ type(electrons_t), intent(inout) :: sys
+ end subroutine td_init
+
+ module subroutine td_init_run(sys, from_scratch)
+ type(electrons_t), intent(inout) :: sys
+ logical, intent(inout) :: from_scratch
+ end subroutine td_init_run
+
+ module subroutine td_allocate_wavefunctions(sys)
+ type(electrons_t), intent(inout) :: sys
+ end subroutine td_allocate_wavefunctions
+
+ module subroutine td_init_gaugefield(td, namespace, gr, st, ks, hm, ext_partners, space)
+ type(td_t), intent(inout) :: td
+ type(namespace_t), intent(in) :: namespace
+ type(grid_t), intent(inout) :: gr
+ type(states_elec_t), intent(inout) :: st
+ type(v_ks_t), intent(inout) :: ks
+ type(hamiltonian_elec_t), intent(inout) :: hm
+ type(partner_list_t), intent(in) :: ext_partners
+ class(space_t), intent(in) :: space
+ end subroutine td_init_gaugefield
+
+ module subroutine td_end(sys)
+ type(electrons_t), intent(inout) :: sys
+ end subroutine td_end
+
+ module subroutine td_end_run(sys)
+ type(electrons_t), intent(inout) :: sys
+ end subroutine td_end_run
+
+ module subroutine td_init_with_wavefunctions(sys)
+ type(electrons_t), target, intent(inout) :: sys
+ end subroutine td_init_with_wavefunctions
+
+ module subroutine td_load_restart_from_gs(td, namespace, space, mc, gr, ext_partners, st, ks, hm)
+ type(td_t), intent(inout) :: td
+ type(namespace_t), intent(in) :: namespace
+ class(space_t), intent(in) :: space
+ type(multicomm_t), intent(in) :: mc
+ type(grid_t), intent(inout) :: gr
+ type(partner_list_t), intent(in) :: ext_partners
+ type(states_elec_t), target, intent(inout) :: st
+ type(v_ks_t), intent(inout) :: ks
+ type(hamiltonian_elec_t), intent(inout) :: hm
+ end subroutine td_load_restart_from_gs
+
+ module subroutine td_dump(td, namespace, space, gr, st, hm, ks, ext_partners, iter, ierr)
+ type(td_t), intent(in) :: td
+ type(namespace_t), intent(in) :: namespace
+ class(space_t), intent(in) :: space
+ type(grid_t), intent(in) :: gr
+ type(states_elec_t), intent(in) :: st
+ type(hamiltonian_elec_t), intent(in) :: hm
+ type(v_ks_t), intent(in) :: ks
+ type(partner_list_t), intent(in) :: ext_partners
+ integer, intent(in) :: iter
+ integer, intent(out) :: ierr
+ end subroutine td_dump
+
+ module function td_get_from_scratch(td) result(res)
+ type(td_t), intent(in) :: td
+ logical :: res
+ end function td_get_from_scratch
+
+ module subroutine td_set_from_scratch(td, from_scratch)
+ type(td_t), intent(inout) :: td
+ logical, intent(in) :: from_scratch
+ end subroutine td_set_from_scratch
+
+ module subroutine td_load_restart_from_td(td, namespace, space, mc, gr, ext_partners, st, ks, hm, from_scratch)
+ type(td_t), intent(inout) :: td
+ type(namespace_t), intent(in) :: namespace
+ class(space_t), intent(in) :: space
+ type(multicomm_t), intent(in) :: mc
+ type(grid_t), intent(inout) :: gr
+ type(partner_list_t), intent(in) :: ext_partners
+ type(states_elec_t), target, intent(inout) :: st
+ type(v_ks_t), intent(inout) :: ks
+ type(hamiltonian_elec_t), intent(inout) :: hm
+ logical, intent(inout) :: from_scratch
+ end subroutine td_load_restart_from_td
+ end interface
+end module td_interface_oct_m
diff --git a/third_party/fortran_stdlib b/third_party/fortran_stdlib
new file mode 160000
index 0000000000000000000000000000000000000000..2b7280b7176f90b07a4ce420aaa794a472eaef7c
--- /dev/null
+++ b/third_party/fortran_stdlib
@@ -0,0 +1 @@
+Subproject commit 2b7280b7176f90b07a4ce420aaa794a472eaef7c