From 4767fbd9385171e8fd0d08512300dd86ca78ea53 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Fri, 10 May 2024 18:41:56 +0200 Subject: [PATCH 01/72] Support submodules Signed-off-by: Cristian Le --- src/fdep/fortran_dependencies.pl | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/fdep/fortran_dependencies.pl b/src/fdep/fortran_dependencies.pl index d9644ea6b7..51bf106b39 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 { -- GitLab From de7e8a002fe3c8add5ce6006fca0bfed3c245b17 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 15 Jan 2024 10:33:13 +0100 Subject: [PATCH 02/72] [submodule] `td_oct_m` Signed-off-by: Cristian Le --- src/td/td.F90 | 292 +++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 230 insertions(+), 62 deletions(-) diff --git a/src/td/td.F90 b/src/td/td.F90 index 7f267f0a56..71a40cbaf8 100644 --- a/src/td/td.F90 +++ b/src/td/td.F90 @@ -19,68 +19,24 @@ #include "global.h" module td_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 debug_oct_m - use density_oct_m - use energy_calc_oct_m - use electrons_ground_state_oct_m use electron_space_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 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 - use photon_mode_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 restart_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 @@ -93,7 +49,6 @@ module td_oct_m td_init_run, & td_end, & td_end_run, & - td_write_iter, & td_check_point, & td_dump, & td_allocate_wavefunctions, & @@ -136,10 +91,222 @@ module td_oct_m type(restart_t) :: restart_dump end type td_t + ! Subroutine/Functions + interface + module 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 + logical, intent(inout) :: from_scratch + end subroutine td_run + + module subroutine td_run_init() + end subroutine td_run_init + + module 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 + end subroutine td_init + + module 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 + logical, intent(inout) :: from_scratch + end subroutine td_init_run + + module 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 + 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(td) + type(td_t), intent(inout) :: td + end subroutine td_end + + module 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 + end subroutine td_end_run + + module 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 + integer, intent(in) :: iter + integer, intent(in) :: scsteps + real(real64), intent(inout) :: etime + logical, intent(in) :: stopping + logical, intent(inout) :: from_scratch + end subroutine td_check_point + + module 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 + 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_oct_m + +submodule (td_oct_m) impl + use absorbing_boundaries_oct_m + use boundaries_oct_m + use calc_mode_par_oct_m + use classical_particle_oct_m + use current_oct_m + use debug_oct_m + use density_oct_m + use electrons_ground_state_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 io_oct_m + use kick_oct_m + use lasers_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 output_oct_m + use parser_oct_m + use photon_mode_mf_oct_m + use photon_mode_oct_m + use poisson_oct_m + use potential_interpolation_oct_m + use profiling_oct_m + use propagator_elec_oct_m + use propagator_oct_m + use scissor_oct_m + use states_abst_oct_m + use states_elec_restart_oct_m + use stress_oct_m + use types_oct_m + use unit_oct_m + use unit_system_oct_m + use varinfo_oct_m + use walltimer_oct_m + use xc_oct_m + + implicit none contains - subroutine td_run_init() + module subroutine td_run_init() PUSH_SUB(td_run_init) @@ -150,7 +317,7 @@ contains ! --------------------------------------------------------- - subroutine td_init(td, namespace, space, gr, ions, st, ks, hm, ext_partners, outp) + module 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 @@ -396,7 +563,7 @@ contains end subroutine td_init ! --------------------------------------------------------- - subroutine td_init_run(td, namespace, mc, gr, ions, st, ks, hm, ext_partners, outp, space, from_scratch) + module 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 @@ -448,7 +615,7 @@ contains end subroutine td_init_run ! --------------------------------------------------------- - subroutine td_allocate_wavefunctions(td, namespace, mc, gr, ions, st, hm, space) + module 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 @@ -482,7 +649,7 @@ contains 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,7 +680,7 @@ contains end subroutine td_init_gaugefield ! --------------------------------------------------------- - subroutine td_end(td) + module subroutine td_end(td) type(td_t), intent(inout) :: td PUSH_SUB(td_end) @@ -528,7 +695,7 @@ contains end subroutine td_end ! --------------------------------------------------------- - subroutine td_end_run(td, st, hm) + module 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 @@ -548,7 +715,7 @@ contains end subroutine td_end_run ! --------------------------------------------------------- - subroutine td_run(td, namespace, mc, gr, ions, st, ks, hm, ext_partners, outp, space, from_scratch) + module 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 @@ -649,7 +816,7 @@ contains end subroutine td_print_header ! --------------------------------------------------------- - subroutine td_check_point(td, namespace, mc, gr, ions, st, ks, hm, ext_partners, outp, space, & + module 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 @@ -745,7 +912,7 @@ 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) + module 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 @@ -1021,7 +1188,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 +1224,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 @@ -1189,7 +1356,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 +1580,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 +1602,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 -- GitLab From 53d2bd1aa7dff38f69901151360baf1fad47e04d Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 15 Jan 2024 10:29:11 +0100 Subject: [PATCH 03/72] [submodule] `td_oct_m` (split) Signed-off-by: Cristian Le --- src/Makefile.am | 1 + src/td/CMakeLists.txt | 1 + src/td/td.F90 | 238 ------------------------------------------ src/td/td_h.F90 | 237 +++++++++++++++++++++++++++++++++++++++++ 4 files changed, 239 insertions(+), 238 deletions(-) create mode 100644 src/td/td_h.F90 diff --git a/src/Makefile.am b/src/Makefile.am index 444d68d7da..4891d95552 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -758,6 +758,7 @@ td_f_srcs = \ td/spectrum.F90 \ td/td_calc.F90 \ td/td.F90 \ + td/td_h.F90 \ td/td_write.F90 \ td/td_write_low.F90 \ td/propagation_ops_elec.F90 diff --git a/src/td/CMakeLists.txt b/src/td/CMakeLists.txt index 7d266368fd..ac6890018c 100644 --- a/src/td/CMakeLists.txt +++ b/src/td/CMakeLists.txt @@ -17,6 +17,7 @@ target_sources(Octopus_lib PRIVATE spectrum.F90 td.F90 td_calc.F90 + td_h.F90 td_write.F90 td_write_low.F90 ) diff --git a/src/td/td.F90 b/src/td/td.F90 index 71a40cbaf8..f852b2f0fc 100644 --- a/src/td/td.F90 +++ b/src/td/td.F90 @@ -18,244 +18,6 @@ #include "global.h" -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 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 :: & - td_t, & - td_run, & - td_run_init, & - td_init, & - td_init_run, & - td_end, & - td_end_run, & - 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 - - ! Subroutine/Functions - interface - module 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 - logical, intent(inout) :: from_scratch - end subroutine td_run - - module subroutine td_run_init() - end subroutine td_run_init - - module 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 - end subroutine td_init - - module 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 - logical, intent(inout) :: from_scratch - end subroutine td_init_run - - module 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 - 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(td) - type(td_t), intent(inout) :: td - end subroutine td_end - - module 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 - end subroutine td_end_run - - module 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 - integer, intent(in) :: iter - integer, intent(in) :: scsteps - real(real64), intent(inout) :: etime - logical, intent(in) :: stopping - logical, intent(inout) :: from_scratch - end subroutine td_check_point - - module 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 - 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_oct_m - submodule (td_oct_m) impl use absorbing_boundaries_oct_m use boundaries_oct_m diff --git a/src/td/td_h.F90 b/src/td/td_h.F90 new file mode 100644 index 0000000000..302202313f --- /dev/null +++ b/src/td/td_h.F90 @@ -0,0 +1,237 @@ +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 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 :: & + td_t, & + td_run, & + td_run_init, & + td_init, & + td_init_run, & + td_end, & + td_end_run, & + 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 + + ! Subroutine/Functions + interface + module 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 + logical, intent(inout) :: from_scratch + end subroutine td_run + + module subroutine td_run_init() + end subroutine td_run_init + + module 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 + end subroutine td_init + + module 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 + logical, intent(inout) :: from_scratch + end subroutine td_init_run + + module 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 + 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(td) + type(td_t), intent(inout) :: td + end subroutine td_end + + module 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 + end subroutine td_end_run + + module 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 + integer, intent(in) :: iter + integer, intent(in) :: scsteps + real(real64), intent(inout) :: etime + logical, intent(in) :: stopping + logical, intent(inout) :: from_scratch + end subroutine td_check_point + + module 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 + 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_oct_m -- GitLab From 2b67da7b7cc42a226f4ad0eda246155b118cd5ee Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 30 May 2023 11:52:31 +0200 Subject: [PATCH 04/72] [submodule] `system_oct_m` Signed-off-by: Cristian Le --- src/multisystem/system.F90 | 273 +++++++++++++++++++++++++++++-------- 1 file changed, 215 insertions(+), 58 deletions(-) diff --git a/src/multisystem/system.F90 b/src/multisystem/system.F90 index 7cd8c44b7d..850ef9484b 100644 --- a/src/multisystem/system.F90 +++ b/src/multisystem/system.F90 @@ -23,26 +23,15 @@ !> This module implements the abstract system type. !! module system_oct_m - use algorithm_oct_m use algorithm_factory_oct_m - use debug_oct_m - use ghost_interaction_oct_m + use algorithm_oct_m use global_oct_m - use interactions_factory_abst_oct_m - use interaction_partner_oct_m use interaction_oct_m + use interaction_partner_oct_m + use interactions_factory_abst_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 unit_oct_m - use unit_system_oct_m - use varinfo_oct_m + use mpi_oct_m implicit none private @@ -219,6 +208,168 @@ module system_oct_m procedure :: get_next => system_iterator_get_next !< @copydoc system_oct_m::system_iterator_get_next end type system_iterator_t + ! Subroutine/Functions + interface + 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 + +submodule (system_oct_m) impl + use debug_oct_m + use ghost_interaction_oct_m + use global_oct_m + use interactions_factory_abst_oct_m + use messages_oct_m + use namespace_oct_m + use multisystem_debug_oct_m + use parser_oct_m + use profiling_oct_m + use quantity_oct_m + use unit_oct_m + use unit_system_oct_m + use varinfo_oct_m + implicit none contains ! --------------------------------------------------------- @@ -234,7 +385,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 @@ -352,7 +503,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 +556,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 +707,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 +745,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 +818,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 +830,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 +842,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 @@ -729,8 +881,9 @@ 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 @@ -740,19 +893,19 @@ contains ! 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 +915,9 @@ 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 + 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 +926,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,7 +938,7 @@ contains end subroutine system_output_start ! --------------------------------------------------------- - subroutine system_output_write(this) + module subroutine system_output_write(this) class(system_t), intent(inout) :: this PUSH_SUB(system_output_write) @@ -797,7 +950,7 @@ contains 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 +962,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 @@ -832,7 +985,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 +1000,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 +1033,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 +1087,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 +1120,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,19 +1149,20 @@ 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 @@ -1033,7 +1187,7 @@ contains 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 +1204,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 +1233,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 +1253,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 +1268,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 +1282,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 +1295,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 +1316,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 +1339,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 +1366,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 +1391,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 +1410,7 @@ contains POP_SUB(system_update_total_energy) end subroutine system_update_total_energy -end module system_oct_m +end submodule impl !! Local Variables: !! mode: f90 -- GitLab From d52b101225a0ac8cec179eb38a887a2fb8cf1f5e Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 15 Jan 2024 10:30:40 +0100 Subject: [PATCH 05/72] [submodule] `system_oct_m` (split) Signed-off-by: Cristian Le --- src/Makefile.am | 1 + src/multisystem/CMakeLists.txt | 1 + src/multisystem/system.F90 | 336 --------------------------------- src/multisystem/system_h.F90 | 334 ++++++++++++++++++++++++++++++++ 4 files changed, 336 insertions(+), 336 deletions(-) create mode 100644 src/multisystem/system_h.F90 diff --git a/src/Makefile.am b/src/Makefile.am index 4891d95552..bf1b092c86 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -551,6 +551,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) diff --git a/src/multisystem/CMakeLists.txt b/src/multisystem/CMakeLists.txt index 51bc99876c..1c30e995de 100644 --- a/src/multisystem/CMakeLists.txt +++ b/src/multisystem/CMakeLists.txt @@ -28,4 +28,5 @@ target_sources(Octopus_lib PRIVATE quantity.F90 system.F90 system_factory_abst.F90 + system_h.F90 ) diff --git a/src/multisystem/system.F90 b/src/multisystem/system.F90 index 850ef9484b..cb16c27b6e 100644 --- a/src/multisystem/system.F90 +++ b/src/multisystem/system.F90 @@ -20,346 +20,10 @@ #include "global.h" -!> This module implements the abstract system type. -!! -module system_oct_m - use algorithm_factory_oct_m - use algorithm_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_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 - - ! Subroutine/Functions - interface - 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 - submodule (system_oct_m) impl use debug_oct_m use ghost_interaction_oct_m use global_oct_m - use interactions_factory_abst_oct_m use messages_oct_m use namespace_oct_m use multisystem_debug_oct_m diff --git a/src/multisystem/system_h.F90 b/src/multisystem/system_h.F90 new file mode 100644 index 0000000000..709db1a6bc --- /dev/null +++ b/src/multisystem/system_h.F90 @@ -0,0 +1,334 @@ +!> This module implements the abstract system type. +!! +module system_oct_m + use algorithm_factory_oct_m + use algorithm_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_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 + + ! Subroutine/Functions + interface + 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 -- GitLab From f8af5b3cdccc23e161d6e3aa641e48335e16a7d6 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 30 May 2023 14:06:54 +0200 Subject: [PATCH 06/72] [submodule] `electron_oct_m` Signed-off-by: Cristian Le --- src/electrons/electrons.F90 | 270 +++++++++++++++++++++++++----------- 1 file changed, 189 insertions(+), 81 deletions(-) diff --git a/src/electrons/electrons.F90 b/src/electrons/electrons.F90 index 9d42228f18..8c37b106c9 100644 --- a/src/electrons/electrons.F90 +++ b/src/electrons/electrons.F90 @@ -20,91 +20,33 @@ #include "global.h" - module 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 algorithm_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 - use potential_interpolation_oct_m - use propagator_oct_m - use propagator_base_oct_m - use propagator_bomd_oct_m - use propagator_aetrs_oct_m - use propagator_elec_oct_m - use propagator_exp_mid_oct_m - use propagator_verlet_oct_m - use propagation_ops_elec_oct_m - use profiling_oct_m - use quantity_oct_m - use regridding_oct_m use scf_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_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 @@ -177,10 +119,172 @@ module electrons_oct_m procedure electrons_constructor end interface electrons_t + interface + 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 + +submodule (electrons_oct_m) impl + use accel_oct_m + use absorbing_boundaries_oct_m + use calc_mode_par_oct_m + use classical_particles_oct_m + use current_to_mxll_field_oct_m + use debug_oct_m + use density_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 global_oct_m + use hamiltonian_elec_base_oct_m + use interaction_enum_oct_m + use ion_dynamics_oct_m + use kick_oct_m + use lalg_basic_oct_m + use lattice_vectors_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 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 output_oct_m + use parser_oct_m + use pes_oct_m + use photon_mode_oct_m + use photon_mode_mf_oct_m + use poisson_oct_m + use potential_interpolation_oct_m + use propagator_oct_m + use propagator_base_oct_m + use propagator_bomd_oct_m + use propagator_aetrs_oct_m + use propagator_elec_oct_m + use propagator_exp_mid_oct_m + use propagator_verlet_oct_m + use propagation_ops_elec_oct_m + use profiling_oct_m + use quantity_oct_m + use regridding_oct_m + use space_oct_m + use states_abst_oct_m + use states_elec_dim_oct_m + use stress_oct_m + use sort_oct_m + use td_write_oct_m + use unit_system_oct_m + use xc_oct_m + use xc_f03_lib_m + use xc_oep_oct_m + use xc_oep_photon_oct_m + use xc_functional_oct_m + + implicit none + 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 @@ -268,7 +372,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 +435,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 +628,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 @@ -550,7 +654,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 +670,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) @@ -581,10 +685,11 @@ contains 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 @@ -744,9 +849,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 +862,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 +889,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 +907,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 +929,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 +938,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 @@ -858,7 +964,7 @@ contains 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 +973,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 +1092,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 +1121,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 +1138,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 +1150,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,7 +1207,7 @@ 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 @@ -1158,7 +1266,7 @@ contains POP_SUB(electrons_finalize) end subroutine electrons_finalize -end module electrons_oct_m +end submodule impl !! Local Variables: !! mode: f90 -- GitLab From eaae49c76d704c0666ded3b652c58e5291ba2497 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 23 Apr 2024 19:03:01 +0200 Subject: [PATCH 07/72] [Temp] Avoid a build failure Some combination of `module subroutine` + `final` + some other magical thing causes the compilation to break on `ifx` with: error #6437: A subroutine or function is calling itself recursively. [HAS_NEXT] This offers an innocent fix to avoid this issue Signed-off-by: Cristian Le --- src/electrons/electrons.F90 | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/src/electrons/electrons.F90 b/src/electrons/electrons.F90 index 8c37b106c9..2020ced0ee 100644 --- a/src/electrons/electrons.F90 +++ b/src/electrons/electrons.F90 @@ -1210,9 +1210,6 @@ contains 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 @@ -1227,12 +1224,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) @@ -1264,6 +1256,19 @@ contains call system_end(sys) 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 submodule impl -- GitLab From 0a13509e567b1b1b2af6027e49da4b2243036155 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 15 Jan 2024 10:31:59 +0100 Subject: [PATCH 08/72] [submodule] `electron_oct_m` (split) Signed-off-by: Cristian Le --- src/Makefile.am | 1 + src/electrons/CMakeLists.txt | 1 + src/electrons/electrons.F90 | 199 ---------------------------------- src/electrons/electrons_h.F90 | 198 +++++++++++++++++++++++++++++++++ 4 files changed, 200 insertions(+), 199 deletions(-) create mode 100644 src/electrons/electrons_h.F90 diff --git a/src/Makefile.am b/src/Makefile.am index bf1b092c86..5c414f8980 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -659,6 +659,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 \ diff --git a/src/electrons/CMakeLists.txt b/src/electrons/CMakeLists.txt index f87ba1d062..d602c56ffb 100644 --- a/src/electrons/CMakeLists.txt +++ b/src/electrons/CMakeLists.txt @@ -9,6 +9,7 @@ target_sources(Octopus_lib PRIVATE eigen_rmmdiis.F90 eigensolver.F90 electrons.F90 + electrons_h.F90 electron_space.F90 elf.F90 energy_calc.F90 diff --git a/src/electrons/electrons.F90 b/src/electrons/electrons.F90 index 2020ced0ee..9c75963644 100644 --- a/src/electrons/electrons.F90 +++ b/src/electrons/electrons.F90 @@ -20,205 +20,6 @@ #include "global.h" -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 :: 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 - 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 - submodule (electrons_oct_m) impl use accel_oct_m use absorbing_boundaries_oct_m diff --git a/src/electrons/electrons_h.F90 b/src/electrons/electrons_h.F90 new file mode 100644 index 0000000000..56d8d402d6 --- /dev/null +++ b/src/electrons/electrons_h.F90 @@ -0,0 +1,198 @@ +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 :: 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 + 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 -- GitLab From bd9110983a5fccb951f0b03655a6979c7a634e5d Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 30 May 2023 15:16:09 +0200 Subject: [PATCH 09/72] [submodule] `propagator_elec_oct_m` Signed-off-by: Cristian Le --- src/td/propagator_elec.F90 | 158 ++++++++++++++++++++++++++++--------- 1 file changed, 122 insertions(+), 36 deletions(-) diff --git a/src/td/propagator_elec.F90 b/src/td/propagator_elec.F90 index 68f9f50b48..f18fcc9545 100644 --- a/src/td/propagator_elec.F90 +++ b/src/td/propagator_elec.F90 @@ -19,48 +19,23 @@ #include "global.h" module propagator_elec_oct_m - use debug_oct_m use electron_space_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 grid_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 - use propagator_magnus_oct_m - use propagator_qoct_oct_m - use propagator_rk_oct_m - use propagator_verlet_oct_m use scf_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 @@ -76,10 +51,119 @@ module propagator_elec_oct_m 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(ks, namespace, space, hm, gr, st, tr, time, dt, nt, & + ions_dyn, ions, ext_partners, outp, write_handler, scsteps, update_energy, qcchi) + 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(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 + integer, intent(in) :: iter + real(real64), intent(in) :: dt + type(ion_dynamics_t), intent(inout) :: ions_dyn + integer, intent(inout) :: scsteps + end subroutine propagator_elec_dt_bo + end interface +end module propagator_elec_oct_m + +submodule (propagator_elec_oct_m) impl + use debug_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 lasers_oct_m + use lda_u_oct_m + use parser_oct_m + use mesh_function_oct_m + use messages_oct_m + use potential_interpolation_oct_m + use profiling_oct_m + use propagator_cn_oct_m + use propagator_etrs_oct_m + use propagator_expmid_oct_m + use propagator_magnus_oct_m + use propagator_qoct_oct_m + use propagator_rk_oct_m + use propagator_verlet_oct_m + use sparskit_oct_m + use stress_oct_m + use varinfo_oct_m + use xc_oct_m + implicit none + 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 +201,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 +473,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 +490,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 +503,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 +526,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,7 +543,7 @@ 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(ks, namespace, space, hm, gr, st, tr, time, dt, nt, & ions_dyn, ions, ext_partners, outp, write_handler, scsteps, update_energy, qcchi) type(v_ks_t), target, intent(inout) :: ks type(namespace_t), intent(in) :: namespace @@ -614,8 +698,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,7 +715,8 @@ contains ! --------------------------------------------------------- - subroutine propagator_elec_dt_bo(scf, namespace, space, gr, ks, st, hm, ions, ext_partners, mc, outp, iter, dt, ions_dyn, scsteps) + module 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 @@ -692,7 +778,7 @@ contains POP_SUB(propagator_elec_dt_bo) end subroutine propagator_elec_dt_bo -end module propagator_elec_oct_m +end submodule impl !! Local Variables: -- GitLab From c40c5269948c2a9a292d11e1409574b1c99b6981 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 15 Jan 2024 10:33:13 +0100 Subject: [PATCH 10/72] [submodule] `propagator_elec_oct_m` (split) Signed-off-by: Cristian Le --- src/Makefile.am | 1 + src/td/CMakeLists.txt | 1 + src/td/propagator_elec.F90 | 115 ----------------------------------- src/td/propagator_elec_h.F90 | 114 ++++++++++++++++++++++++++++++++++ 4 files changed, 116 insertions(+), 115 deletions(-) create mode 100644 src/td/propagator_elec_h.F90 diff --git a/src/Makefile.am b/src/Makefile.am index 5c414f8980..b2228811bd 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -752,6 +752,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 \ diff --git a/src/td/CMakeLists.txt b/src/td/CMakeLists.txt index ac6890018c..e68cc3ae4b 100644 --- a/src/td/CMakeLists.txt +++ b/src/td/CMakeLists.txt @@ -9,6 +9,7 @@ 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 diff --git a/src/td/propagator_elec.F90 b/src/td/propagator_elec.F90 index f18fcc9545..9febe7acd3 100644 --- a/src/td/propagator_elec.F90 +++ b/src/td/propagator_elec.F90 @@ -18,121 +18,6 @@ #include "global.h" -module propagator_elec_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 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(ks, namespace, space, hm, gr, st, tr, time, dt, nt, & - ions_dyn, ions, ext_partners, outp, write_handler, scsteps, update_energy, qcchi) - 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(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 - integer, intent(in) :: iter - real(real64), intent(in) :: dt - type(ion_dynamics_t), intent(inout) :: ions_dyn - integer, intent(inout) :: scsteps - end subroutine propagator_elec_dt_bo - end interface -end module propagator_elec_oct_m - submodule (propagator_elec_oct_m) impl use debug_oct_m use energy_calc_oct_m diff --git a/src/td/propagator_elec_h.F90 b/src/td/propagator_elec_h.F90 new file mode 100644 index 0000000000..bc6db9574c --- /dev/null +++ b/src/td/propagator_elec_h.F90 @@ -0,0 +1,114 @@ +module propagator_elec_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 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(ks, namespace, space, hm, gr, st, tr, time, dt, nt, & + ions_dyn, ions, ext_partners, outp, write_handler, scsteps, update_energy, qcchi) + 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(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 + integer, intent(in) :: iter + real(real64), intent(in) :: dt + type(ion_dynamics_t), intent(inout) :: ions_dyn + integer, intent(inout) :: scsteps + end subroutine propagator_elec_dt_bo + end interface +end module propagator_elec_oct_m -- GitLab From d8cf055bc2f53c1f14efdcde6bf3f2e3adefb9c9 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Fri, 2 Jun 2023 20:45:36 +0200 Subject: [PATCH 11/72] [submodule] `global_oct_m` Signed-off-by: Cristian Le --- src/basic/global.F90 | 212 +++++++++++++++++++++++++++++++++---------- 1 file changed, 166 insertions(+), 46 deletions(-) diff --git a/src/basic/global.F90 b/src/basic/global.F90 index 1d610352fe..eb0f3ceea7 100644 --- a/src/basic/global.F90 +++ b/src/basic/global.F90 @@ -19,14 +19,8 @@ #include "global.h" module global_oct_m - use, intrinsic :: iso_fortran_env - use hardware_oct_m - use loct_oct_m use mpi_oct_m - use varinfo_oct_m -#ifdef HAVE_OPENMP - use omp_lib -#endif + use, intrinsic :: iso_fortran_env implicit none @@ -205,10 +199,127 @@ module global_oct_m 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 + +submodule (global_oct_m) impl + use hardware_oct_m + use loct_oct_m + use varinfo_oct_m +#ifdef HAVE_OPENMP + use omp_lib +#endif + + implicit none 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,7 +336,7 @@ 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 @@ -254,7 +365,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,7 +393,7 @@ contains !> @brief Finalise parser varinfo file, and MPI - subroutine global_end() + module subroutine global_end() call varinfo_end() call mpi_mod_end() @@ -290,9 +401,10 @@ contains 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 +412,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 +423,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 +434,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 +445,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 +456,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 +467,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 -- GitLab From e60a455e9ec834525029a4a6a6138e9668013d38 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 15 Jan 2024 10:49:13 +0100 Subject: [PATCH 12/72] [submodule] `global_oct_m` (split) Signed-off-by: Cristian Le --- src/Makefile.am | 1 + src/basic/CMakeLists.txt | 1 + src/basic/global.F90 | 289 -------------------------------------- src/basic/global_h.F90 | 290 +++++++++++++++++++++++++++++++++++++++ 4 files changed, 292 insertions(+), 289 deletions(-) create mode 100644 src/basic/global_h.F90 diff --git a/src/Makefile.am b/src/Makefile.am index b2228811bd..d507c9336b 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 \ diff --git a/src/basic/CMakeLists.txt b/src/basic/CMakeLists.txt index 96efa81094..fdf90ef09c 100644 --- a/src/basic/CMakeLists.txt +++ b/src/basic/CMakeLists.txt @@ -17,6 +17,7 @@ target_sources(Octopus_lib PRIVATE gdlib_f.c getopt_f.c global.F90 + global_h.F90 hardware.F90 heap.F90 iihash.F90 diff --git a/src/basic/global.F90 b/src/basic/global.F90 index eb0f3ceea7..dc588b7f3f 100644 --- a/src/basic/global.F90 +++ b/src/basic/global.F90 @@ -18,295 +18,6 @@ #include "global.h" -module global_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) - - !> 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 - submodule (global_oct_m) impl use hardware_oct_m use loct_oct_m diff --git a/src/basic/global_h.F90 b/src/basic/global_h.F90 new file mode 100644 index 0000000000..fd28c70b26 --- /dev/null +++ b/src/basic/global_h.F90 @@ -0,0 +1,290 @@ +#include "global.h" + +module global_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) + + !> 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 -- GitLab From 17888350494c7e2ec2e7aec373cf5e402c5a3f92 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 20 Jun 2023 16:39:43 +0200 Subject: [PATCH 13/72] [submodule] `hamiltonian_elec_oct_m` Signed-off-by: Cristian Le --- src/hamiltonian/hamiltonian_elec.F90 | 492 +++++++++++++++++++---- src/hamiltonian/hamiltonian_elec_inc.F90 | 18 +- 2 files changed, 433 insertions(+), 77 deletions(-) diff --git a/src/hamiltonian/hamiltonian_elec.F90 b/src/hamiltonian/hamiltonian_elec.F90 index 1a9a97b196..e385434e59 100644 --- a/src/hamiltonian/hamiltonian_elec.F90 +++ b/src/hamiltonian/hamiltonian_elec.F90 @@ -21,75 +21,43 @@ module hamiltonian_elec_oct_m use absorbing_boundaries_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 energy_oct_m use epot_oct_m - use ext_partner_list_oct_m - use gauge_field_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 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 profiling_oct_m - use projector_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_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 types_oct_m - use unit_oct_m - use unit_system_oct_m + use states_elec_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 @@ -236,11 +204,393 @@ module hamiltonian_elec_oct_m 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 + +submodule (hamiltonian_elec_oct_m) impl + use accel_oct_m + use affine_coordinates_oct_m + use batch_ops_oct_m + use boundaries_oct_m + use comm_oct_m + use debug_oct_m + use ext_partner_list_oct_m + use external_potential_oct_m + use gauge_field_oct_m + use global_oct_m + use io_oct_m + use lalg_basic_oct_m + use lasers_oct_m + use linked_list_oct_m + use math_oct_m + use mesh_function_oct_m + use messages_oct_m + use mpi_oct_m + use par_vec_oct_m + use parser_oct_m + use profiling_oct_m + use projector_oct_m + use states_abst_oct_m + use states_elec_parallel_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 xc_f03_lib_m + use xc_functional_oct_m + use xc_interaction_oct_m + implicit none 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 @@ -687,7 +1037,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 @@ -756,11 +1106,12 @@ contains ! --------------------------------------------------------- ! 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 +1119,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 +1156,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 +1180,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 +1194,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 +1211,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 +1229,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 @@ -1108,7 +1460,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 +1580,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 +1663,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 +1682,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 +1712,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 +1808,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 +1878,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 +2074,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 +2090,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 +2109,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 +2158,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 +2210,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 +2230,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 +2267,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 +2305,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_inc.F90 b/src/hamiltonian/hamiltonian_elec_inc.F90 index 898297ed27..a71db78c8c 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) -- GitLab From 496d4fa31caa2472f4852b03d8b30cfb1e2babec Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 15 Jan 2024 10:50:30 +0100 Subject: [PATCH 14/72] [submodule] `hamiltonian_elec_oct_m` (split) Signed-off-by: Cristian Le --- src/Makefile.am | 1 + src/hamiltonian/CMakeLists.txt | 1 + src/hamiltonian/hamiltonian_elec.F90 | 533 ------------------------- src/hamiltonian/hamiltonian_elec_h.F90 | 532 ++++++++++++++++++++++++ 4 files changed, 534 insertions(+), 533 deletions(-) create mode 100644 src/hamiltonian/hamiltonian_elec_h.F90 diff --git a/src/Makefile.am b/src/Makefile.am index d507c9336b..731680a17b 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -470,6 +470,7 @@ hamiltonian_f_srcs = \ hamiltonian/hamiltonian_abst.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 \ diff --git a/src/hamiltonian/CMakeLists.txt b/src/hamiltonian/CMakeLists.txt index 803f9218f5..eba12392e2 100644 --- a/src/hamiltonian/CMakeLists.txt +++ b/src/hamiltonian/CMakeLists.txt @@ -9,6 +9,7 @@ target_sources(Octopus_lib PRIVATE hamiltonian_abst.F90 hamiltonian_elec.F90 hamiltonian_elec_base.F90 + hamiltonian_elec_h.F90 hgh_projector.F90 hirshfeld.F90 ion_interaction.F90 diff --git a/src/hamiltonian/hamiltonian_elec.F90 b/src/hamiltonian/hamiltonian_elec.F90 index e385434e59..ff9d6c813f 100644 --- a/src/hamiltonian/hamiltonian_elec.F90 +++ b/src/hamiltonian/hamiltonian_elec.F90 @@ -19,539 +19,6 @@ #include "global.h" -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 => 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 - - 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 - submodule (hamiltonian_elec_oct_m) impl use accel_oct_m use affine_coordinates_oct_m diff --git a/src/hamiltonian/hamiltonian_elec_h.F90 b/src/hamiltonian/hamiltonian_elec_h.F90 new file mode 100644 index 0000000000..bf15740e4f --- /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 => 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 + + 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 -- GitLab From b385fe14c381d74b584e87d4272186a209e5959c Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 20 Jun 2023 16:41:39 +0200 Subject: [PATCH 15/72] [submodule] `hamiltonian_mxll_oct_m` Signed-off-by: Cristian Le --- src/maxwell/hamiltonian_mxll.F90 | 275 ++++++++++++++++++++++++++----- 1 file changed, 233 insertions(+), 42 deletions(-) diff --git a/src/maxwell/hamiltonian_mxll.F90 b/src/maxwell/hamiltonian_mxll.F90 index 599ff2c43b..3e95a1f201 100644 --- a/src/maxwell/hamiltonian_mxll.F90 +++ b/src/maxwell/hamiltonian_mxll.F90 @@ -19,32 +19,19 @@ #include "global.h" module 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 @@ -153,11 +140,212 @@ module hamiltonian_mxll_oct_m 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 + +submodule (hamiltonian_mxll_oct_m) impl + use accel_oct_m + use batch_ops_oct_m + use boundaries_oct_m + use debug_oct_m + use global_oct_m + use hamiltonian_elec_oct_m + use math_oct_m + use messages_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 + + implicit none 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 @@ -258,7 +446,7 @@ contains ! --------------------------------------------------------- - subroutine hamiltonian_mxll_end(hm) + module subroutine hamiltonian_mxll_end(hm) type(hamiltonian_mxll_t), intent(inout) :: hm integer :: il @@ -284,16 +472,17 @@ contains ! --------------------------------------------------------- - 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 +490,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 +526,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 +540,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 +555,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 +569,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 +579,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 +590,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 +871,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 +913,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 +970,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 +1029,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 +1066,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 +1133,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 +1149,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 +1195,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 +1343,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 +1367,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 +1391,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 +1436,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 +1487,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 +1549,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 +1612,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 +1626,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 +1638,7 @@ contains end subroutine zhamiltonian_mxll_magnus_apply -end module hamiltonian_mxll_oct_m +end submodule impl !! Local Variables: !! mode: f90 -- GitLab From 14320f23621a86ca3a9478d81712688f8b9c18ff Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 15 Jan 2024 11:02:46 +0100 Subject: [PATCH 16/72] [submodule] `hamiltonian_mxll_oct_m` (split) Signed-off-by: Cristian Le --- src/Makefile.am | 1 + src/maxwell/CMakeLists.txt | 1 + src/maxwell/hamiltonian_mxll.F90 | 307 ----------------------------- src/maxwell/hamiltonian_mxll_h.F90 | 306 ++++++++++++++++++++++++++++ 4 files changed, 308 insertions(+), 307 deletions(-) create mode 100644 src/maxwell/hamiltonian_mxll_h.F90 diff --git a/src/Makefile.am b/src/Makefile.am index 731680a17b..530ad5d23c 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -708,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 \ diff --git a/src/maxwell/CMakeLists.txt b/src/maxwell/CMakeLists.txt index 74a639c24e..6a6ffcb669 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/hamiltonian_mxll.F90 b/src/maxwell/hamiltonian_mxll.F90 index 3e95a1f201..ca15634cdb 100644 --- a/src/maxwell/hamiltonian_mxll.F90 +++ b/src/maxwell/hamiltonian_mxll.F90 @@ -18,313 +18,6 @@ #include "global.h" -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 => 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 - - 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 - submodule (hamiltonian_mxll_oct_m) impl use accel_oct_m use batch_ops_oct_m diff --git a/src/maxwell/hamiltonian_mxll_h.F90 b/src/maxwell/hamiltonian_mxll_h.F90 new file mode 100644 index 0000000000..e4b90ec990 --- /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 => 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 + + 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 -- GitLab From 7609927fc08124575976546344578103e17f7e6b Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 15 Jan 2024 15:00:49 +0100 Subject: [PATCH 17/72] [submodule] `hamiltonian_abst_oct_m` Signed-off-by: Cristian Le --- src/Makefile.am | 2 +- src/hamiltonian/CMakeLists.txt | 2 +- .../{hamiltonian_abst.F90 => hamiltonian_abst_h.F90} | 6 +----- 3 files changed, 3 insertions(+), 7 deletions(-) rename src/hamiltonian/{hamiltonian_abst.F90 => hamiltonian_abst_h.F90} (97%) diff --git a/src/Makefile.am b/src/Makefile.am index 530ad5d23c..a01b876c48 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -467,7 +467,7 @@ 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 \ diff --git a/src/hamiltonian/CMakeLists.txt b/src/hamiltonian/CMakeLists.txt index eba12392e2..b72bbeac07 100644 --- a/src/hamiltonian/CMakeLists.txt +++ b/src/hamiltonian/CMakeLists.txt @@ -6,7 +6,7 @@ target_sources(Octopus_lib PRIVATE exchange_operator.F90 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 diff --git a/src/hamiltonian/hamiltonian_abst.F90 b/src/hamiltonian/hamiltonian_abst_h.F90 similarity index 97% rename from src/hamiltonian/hamiltonian_abst.F90 rename to src/hamiltonian/hamiltonian_abst_h.F90 index 7ae72767d5..8e3976d228 100644 --- a/src/hamiltonian/hamiltonian_abst.F90 +++ b/src/hamiltonian/hamiltonian_abst_h.F90 @@ -15,7 +15,6 @@ !! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA !! 02110-1301, USA. !! -#include "global.h" !> @brief This module defines an abstract class for Hamiltonians !! @@ -31,11 +30,8 @@ module hamiltonian_abst_oct_m private - public :: & - hamiltonian_abst_t - !> @brief The abstract Hamiltonian class defines a skeleton for specific implementations - type, abstract :: hamiltonian_abst_t + type, abstract, public :: hamiltonian_abst_t !> Spectral range real(real64) :: spectral_middle_point real(real64) :: spectral_half_span -- GitLab From 6181b9330ab049d7c44fe255848236e12b211f53 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 23 Apr 2024 12:02:14 +0200 Subject: [PATCH 18/72] [submodule] `electrons_ground_state_oct_m` Signed-off-by: Cristian Le --- src/scf/electrons_ground_state.F90 | 50 +++++++++++++++++++++--------- 1 file changed, 36 insertions(+), 14 deletions(-) diff --git a/src/scf/electrons_ground_state.F90 b/src/scf/electrons_ground_state.F90 index 0e608c8e9c..c0a7fba319 100644 --- a/src/scf/electrons_ground_state.F90 +++ b/src/scf/electrons_ground_state.F90 @@ -19,41 +19,63 @@ #include "global.h" module 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 multicomm_oct_m + use namespace_oct_m + use output_low_oct_m + use states_elec_oct_m + use v_ks_oct_m + + implicit none + + private + public :: & + electrons_ground_state_run + + interface + module 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 + logical, intent(inout) :: fromScratch + end subroutine electrons_ground_state_run + end interface +end module electrons_ground_state_oct_m + +submodule (electrons_ground_state_oct_m) impl + use debug_oct_m + use global_oct_m + use hamiltonian_elec_oct_m + use io_function_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_oct_m use space_oct_m use states_abst_oct_m - use states_elec_oct_m use states_elec_restart_oct_m - use v_ks_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) + module 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 @@ -188,7 +210,7 @@ contains 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 -- GitLab From fe30f077925ca5dd422c281dfd8da9ac3fdacb7e Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 23 Apr 2024 12:04:02 +0200 Subject: [PATCH 19/72] [submodule] `electrons_ground_state_oct_m` (split) Signed-off-by: Cristian Le --- src/Makefile.am | 1 + src/scf/CMakeLists.txt | 1 + src/scf/electrons_ground_state.F90 | 35 ---------------------------- src/scf/electrons_ground_state_h.F90 | 34 +++++++++++++++++++++++++++ 4 files changed, 36 insertions(+), 35 deletions(-) create mode 100644 src/scf/electrons_ground_state_h.F90 diff --git a/src/Makefile.am b/src/Makefile.am index a01b876c48..c982e03674 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -727,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 \ diff --git a/src/scf/CMakeLists.txt b/src/scf/CMakeLists.txt index 75f20d3a98..b1e44316e6 100644 --- a/src/scf/CMakeLists.txt +++ b/src/scf/CMakeLists.txt @@ -3,6 +3,7 @@ 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 diff --git a/src/scf/electrons_ground_state.F90 b/src/scf/electrons_ground_state.F90 index c0a7fba319..a12c891ca7 100644 --- a/src/scf/electrons_ground_state.F90 +++ b/src/scf/electrons_ground_state.F90 @@ -18,41 +18,6 @@ #include "global.h" -module electrons_ground_state_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 states_elec_oct_m - use v_ks_oct_m - - implicit none - - private - public :: & - electrons_ground_state_run - - interface - module 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 - logical, intent(inout) :: fromScratch - end subroutine electrons_ground_state_run - end interface -end module electrons_ground_state_oct_m - submodule (electrons_ground_state_oct_m) impl use debug_oct_m use global_oct_m diff --git a/src/scf/electrons_ground_state_h.F90 b/src/scf/electrons_ground_state_h.F90 new file mode 100644 index 0000000000..da0b3ac4e1 --- /dev/null +++ b/src/scf/electrons_ground_state_h.F90 @@ -0,0 +1,34 @@ +module electrons_ground_state_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 states_elec_oct_m + use v_ks_oct_m + + implicit none + + private + public :: & + electrons_ground_state_run + + interface + module 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 + logical, intent(inout) :: fromScratch + end subroutine electrons_ground_state_run + end interface +end module electrons_ground_state_oct_m -- GitLab From 9976fcc2d18e40efe195878c4c963c1b30c96331 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 11 Sep 2023 21:14:42 +0200 Subject: [PATCH 20/72] Move td interface subroutines to `td_interface_oct_m` Signed-off-by: Cristian Le --- src/Makefile.am | 3 +- src/electrons/electrons.F90 | 3 +- src/main/run.F90 | 2 +- src/main/time_dependent.F90 | 2 +- src/opt_control/opt_control.F90 | 1 + src/td/CMakeLists.txt | 3 +- src/td/td_h.F90 | 193 +-------------------------- src/td/{td.F90 => td_interface.F90} | 7 +- src/td/td_interface_h.F90 | 197 ++++++++++++++++++++++++++++ 9 files changed, 218 insertions(+), 193 deletions(-) rename src/td/{td.F90 => td_interface.F90} (99%) create mode 100644 src/td/td_interface_h.F90 diff --git a/src/Makefile.am b/src/Makefile.am index c982e03674..ed101a956a 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -764,7 +764,8 @@ 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 \ diff --git a/src/electrons/electrons.F90 b/src/electrons/electrons.F90 index 9c75963644..d76a94cfaa 100644 --- a/src/electrons/electrons.F90 +++ b/src/electrons/electrons.F90 @@ -72,6 +72,7 @@ submodule (electrons_oct_m) impl use states_elec_dim_oct_m use stress_oct_m use sort_oct_m + use td_interface_oct_m use td_write_oct_m use unit_system_oct_m use xc_oct_m @@ -480,7 +481,7 @@ contains ! 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)) + this%ext_partners, this%st, this%ks, this%hm, this%outp, this%td%from_scratch) POP_SUB(electrons_propagation_start) end subroutine electrons_propagation_start diff --git a/src/main/run.F90 b/src/main/run.F90 index 708273bdf9..dc15b4ee4e 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/time_dependent.F90 b/src/main/time_dependent.F90 index 556c733da5..468f14985f 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 diff --git a/src/opt_control/opt_control.F90 b/src/opt_control/opt_control.F90 index 4530b3d3c7..2953a3d09b 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 diff --git a/src/td/CMakeLists.txt b/src/td/CMakeLists.txt index e68cc3ae4b..819f0ca648 100644 --- a/src/td/CMakeLists.txt +++ b/src/td/CMakeLists.txt @@ -16,9 +16,10 @@ target_sources(Octopus_lib PRIVATE 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/td_h.F90 b/src/td/td_h.F90 index 302202313f..1867f3a53b 100644 --- a/src/td/td_h.F90 +++ b/src/td/td_h.F90 @@ -21,30 +21,13 @@ module td_oct_m implicit none private - public :: & - td_t, & - td_run, & - td_run_init, & - td_init, & - td_init_run, & - td_end, & - td_end_run, & - 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 + type, public :: td_t private type(propagator_base_t), public :: tr !< contains the details of the time-evolution type(scf_t), public :: scf @@ -58,180 +41,16 @@ module td_oct_m integer, public :: dynamics integer, public :: energy_update_iter - real(real64) :: scissor + real(real64), public :: scissor logical :: freeze_occ logical :: freeze_u - integer :: freeze_orbitals + integer, public :: freeze_orbitals - logical :: from_scratch = .false. + logical, public :: from_scratch = .false. type(td_write_t), public :: write_handler - type(restart_t) :: restart_load - type(restart_t) :: restart_dump + type(restart_t), public :: restart_load + type(restart_t), public :: restart_dump end type td_t - - ! Subroutine/Functions - interface - module 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 - logical, intent(inout) :: from_scratch - end subroutine td_run - - module subroutine td_run_init() - end subroutine td_run_init - - module 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 - end subroutine td_init - - module 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 - logical, intent(inout) :: from_scratch - end subroutine td_init_run - - module 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 - 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(td) - type(td_t), intent(inout) :: td - end subroutine td_end - - module 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 - end subroutine td_end_run - - module 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 - integer, intent(in) :: iter - integer, intent(in) :: scsteps - real(real64), intent(inout) :: etime - logical, intent(in) :: stopping - logical, intent(inout) :: from_scratch - end subroutine td_check_point - - module 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 - 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_oct_m diff --git a/src/td/td.F90 b/src/td/td_interface.F90 similarity index 99% rename from src/td/td.F90 rename to src/td/td_interface.F90 index f852b2f0fc..4492e548c6 100644 --- a/src/td/td.F90 +++ b/src/td/td_interface.F90 @@ -18,7 +18,7 @@ #include "global.h" -submodule (td_oct_m) impl +submodule (td_interface_oct_m) impl use absorbing_boundaries_oct_m use boundaries_oct_m use calc_mode_par_oct_m @@ -34,6 +34,7 @@ submodule (td_oct_m) impl use gauge_field_oct_m use global_oct_m use io_oct_m + use ion_dynamics_oct_m use kick_oct_m use lasers_oct_m use lda_u_io_oct_m @@ -46,6 +47,7 @@ submodule (td_oct_m) impl use mpi_oct_m use output_oct_m use parser_oct_m + use pes_oct_m use photon_mode_mf_oct_m use photon_mode_oct_m use poisson_oct_m @@ -53,10 +55,13 @@ submodule (td_oct_m) impl use profiling_oct_m use propagator_elec_oct_m use propagator_oct_m + use restart_oct_m + use scf_oct_m use scissor_oct_m use states_abst_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 diff --git a/src/td/td_interface_h.F90 b/src/td/td_interface_h.F90 new file mode 100644 index 0000000000..86f99e6333 --- /dev/null +++ b/src/td/td_interface_h.F90 @@ -0,0 +1,197 @@ +module td_interface_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_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 + + ! Subroutine/Functions + interface + module 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 + logical, intent(inout) :: from_scratch + end subroutine td_run + + module subroutine td_run_init() + end subroutine td_run_init + + module 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 + end subroutine td_init + + module 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 + logical, intent(inout) :: from_scratch + end subroutine td_init_run + + module 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 + 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(td) + type(td_t), intent(inout) :: td + end subroutine td_end + + module 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 + end subroutine td_end_run + + module 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 + integer, intent(in) :: iter + integer, intent(in) :: scsteps + real(real64), intent(inout) :: etime + logical, intent(in) :: stopping + logical, intent(inout) :: from_scratch + end subroutine td_check_point + + module 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 + 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 -- GitLab From 3fd53d1d62e8b804134274541d8bd68e56f954f2 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 23 Apr 2024 20:29:27 +0200 Subject: [PATCH 21/72] [submodule] `scf_oct_m` Signed-off-by: Cristian Le --- src/scf/scf.F90 | 162 ++++++++++++++++++++++++++++++++---------------- 1 file changed, 107 insertions(+), 55 deletions(-) diff --git a/src/scf/scf.F90 b/src/scf/scf.F90 index 2b8eb87c97..83e2969022 100644 --- a/src/scf/scf.F90 +++ b/src/scf/scf.F90 @@ -19,73 +19,25 @@ #include "global.h" module scf_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 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 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 loct_oct_m - use magnetic_oct_m - use math_oct_m - use mesh_oct_m - use mesh_function_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 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 - use symmetries_oct_m - use types_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_oep_oct_m - use xc_oep_photon_oct_m implicit none @@ -134,10 +86,110 @@ module scf_oct_m real(real64) :: energy_in, energy_diff, abs_dens_diff, evsum_in, evsum_out, evsum_diff end type scf_t + interface + module 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 + end subroutine scf_init + + module subroutine scf_mix_clear(scf) + type(scf_t), intent(inout) :: scf + end subroutine scf_mix_clear + + module 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 + 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 + end subroutine scf_run + + module subroutine scf_end(scf) + type(scf_t), intent(inout) :: scf + end subroutine scf_end + + module subroutine scf_state_info(namespace, st) + type(namespace_t), intent(in) :: namespace + class(states_abst_t), intent(in) :: st + 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_oct_m + +submodule (scf_oct_m) impl + use batch_ops_oct_m + use criteria_factory_oct_m + use debug_oct_m + use density_criterion_oct_m + use density_oct_m + use eigenval_criterion_oct_m + use energy_calc_oct_m + use energy_criterion_oct_m + use forces_oct_m + use io_oct_m + use kpoints_oct_m + use lalg_basic_oct_m + use lcao_oct_m + use lda_u_io_oct_m + use lda_u_oct_m + use loct_oct_m + use magnetic_oct_m + use math_oct_m + use mesh_function_oct_m + use mesh_oct_m + use messages_oct_m + use modelmb_exchange_syms_oct_m + use mpi_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 smear_oct_m + use species_oct_m + use states_elec_io_oct_m + use states_elec_restart_oct_m + use stress_oct_m + use symmetries_oct_m + use types_oct_m + use unit_oct_m + use unit_system_oct_m + use utils_oct_m + use varinfo_oct_m + use vdw_ts_oct_m + use walltimer_oct_m + use wfs_elec_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 contains ! --------------------------------------------------------- - subroutine scf_init(scf, namespace, gr, ions, st, mc, hm, space) + module 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 @@ -432,7 +484,7 @@ contains ! --------------------------------------------------------- - subroutine scf_end(scf) + module subroutine scf_end(scf) type(scf_t), intent(inout) :: scf class(convergence_criterion_t), pointer :: crit @@ -459,7 +511,7 @@ contains ! --------------------------------------------------------- - subroutine scf_mix_clear(scf) + module subroutine scf_mix_clear(scf) type(scf_t), intent(inout) :: scf PUSH_SUB(scf_mix_clear) @@ -473,7 +525,7 @@ contains ! --------------------------------------------------------- - subroutine scf_run(scf, namespace, space, mc, gr, ions, ext_partners, st, ks, hm, outp, & + module 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 @@ -1319,7 +1371,7 @@ contains end subroutine scf_run ! --------------------------------------------------------- - subroutine scf_state_info(namespace, st) + module subroutine scf_state_info(namespace, st) type(namespace_t), intent(in) :: namespace class(states_abst_t), intent(in) :: st @@ -1337,7 +1389,7 @@ contains 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 +1471,7 @@ contains end subroutine scf_update_diff_quantity -end module scf_oct_m +end submodule impl !! Local Variables: -- GitLab From fbcbe558ac70afa2e00fbd0fc4cdd3eb839decb0 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 23 Apr 2024 20:30:55 +0200 Subject: [PATCH 22/72] [submodule] `scf_oct_m` (split) Signed-off-by: Cristian Le --- src/Makefile.am | 1 + src/scf/CMakeLists.txt | 1 + src/scf/scf.F90 | 118 ----------------------------------------- src/scf/scf_h.F90 | 117 ++++++++++++++++++++++++++++++++++++++++ 4 files changed, 119 insertions(+), 118 deletions(-) create mode 100644 src/scf/scf_h.F90 diff --git a/src/Makefile.am b/src/Makefile.am index ed101a956a..9a2b169c26 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -736,6 +736,7 @@ scf_f_srcs = \ scf/mixing_preconditioner.F90 \ scf/rdmft.F90 \ scf/scf.F90 \ + scf/scf_h.F90 \ scf/unocc.F90 scf_srcs = $(scf_f_srcs) diff --git a/src/scf/CMakeLists.txt b/src/scf/CMakeLists.txt index b1e44316e6..50f31a2304 100644 --- a/src/scf/CMakeLists.txt +++ b/src/scf/CMakeLists.txt @@ -11,6 +11,7 @@ target_sources(Octopus_lib PRIVATE mixing_preconditioner.F90 rdmft.F90 scf.F90 + scf_h.F90 unocc.F90 ) ## Unused sources diff --git a/src/scf/scf.F90 b/src/scf/scf.F90 index 83e2969022..cc25a6c198 100644 --- a/src/scf/scf.F90 +++ b/src/scf/scf.F90 @@ -18,124 +18,6 @@ #include "global.h" -module scf_oct_m - use berry_oct_m - use convergence_criterion_oct_m - use eigensolver_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 ions_oct_m - use lda_u_mixer_oct_m - use mix_oct_m - use multicomm_oct_m - use namespace_oct_m - use output_low_oct_m - use restart_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_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 - - interface - module 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 - end subroutine scf_init - - module subroutine scf_mix_clear(scf) - type(scf_t), intent(inout) :: scf - end subroutine scf_mix_clear - - module 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 - 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 - end subroutine scf_run - - module subroutine scf_end(scf) - type(scf_t), intent(inout) :: scf - end subroutine scf_end - - module subroutine scf_state_info(namespace, st) - type(namespace_t), intent(in) :: namespace - class(states_abst_t), intent(in) :: st - 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_oct_m - submodule (scf_oct_m) impl use batch_ops_oct_m use criteria_factory_oct_m diff --git a/src/scf/scf_h.F90 b/src/scf/scf_h.F90 new file mode 100644 index 0000000000..d42d79951d --- /dev/null +++ b/src/scf/scf_h.F90 @@ -0,0 +1,117 @@ +module scf_oct_m + use berry_oct_m + use convergence_criterion_oct_m + use eigensolver_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 ions_oct_m + use lda_u_mixer_oct_m + use mix_oct_m + use multicomm_oct_m + use namespace_oct_m + use output_low_oct_m + use restart_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_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 + + interface + module 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 + end subroutine scf_init + + module subroutine scf_mix_clear(scf) + type(scf_t), intent(inout) :: scf + end subroutine scf_mix_clear + + module 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 + 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 + end subroutine scf_run + + module subroutine scf_end(scf) + type(scf_t), intent(inout) :: scf + end subroutine scf_end + + module subroutine scf_state_info(namespace, st) + type(namespace_t), intent(in) :: namespace + class(states_abst_t), intent(in) :: st + 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_oct_m -- GitLab From 73c8c2927847500cc9b90099500cfc664cceb5bd Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 23 Apr 2024 20:41:36 +0200 Subject: [PATCH 23/72] Move scf interface subroutines to `scf_interface_oct_m` Signed-off-by: Cristian Le --- src/Makefile.am | 3 +- src/electrons/electrons.F90 | 1 + src/main/geom_opt.F90 | 1 + src/main/phonons_fd.F90 | 1 + src/main/static_pol.F90 | 1 + src/scf/CMakeLists.txt | 3 +- src/scf/electrons_ground_state.F90 | 1 + src/scf/scf_h.F90 | 104 ++++--------------------- src/scf/{scf.F90 => scf_interface.F90} | 7 +- src/scf/scf_interface_h.F90 | 77 ++++++++++++++++++ src/scf/unocc.F90 | 1 + src/td/propagator_elec.F90 | 1 + src/td/td_interface.F90 | 1 + 13 files changed, 112 insertions(+), 90 deletions(-) rename src/scf/{scf.F90 => scf_interface.F90} (99%) create mode 100644 src/scf/scf_interface_h.F90 diff --git a/src/Makefile.am b/src/Makefile.am index 9a2b169c26..9b57ede94f 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -735,7 +735,8 @@ 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 diff --git a/src/electrons/electrons.F90 b/src/electrons/electrons.F90 index d76a94cfaa..8ef4bd8a0d 100644 --- a/src/electrons/electrons.F90 +++ b/src/electrons/electrons.F90 @@ -67,6 +67,7 @@ submodule (electrons_oct_m) impl use profiling_oct_m use quantity_oct_m use regridding_oct_m + use scf_interface_oct_m use space_oct_m use states_abst_oct_m use states_elec_dim_oct_m diff --git a/src/main/geom_opt.F90 b/src/main/geom_opt.F90 index 51a13c1c99..1249dddaa6 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 diff --git a/src/main/phonons_fd.F90 b/src/main/phonons_fd.F90 index 6eff8e1c60..92ad4e2715 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 diff --git a/src/main/static_pol.F90 b/src/main/static_pol.F90 index ac404ef5b5..4af6a1b65b 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 diff --git a/src/scf/CMakeLists.txt b/src/scf/CMakeLists.txt index 50f31a2304..1bb8cb1b2a 100644 --- a/src/scf/CMakeLists.txt +++ b/src/scf/CMakeLists.txt @@ -10,8 +10,9 @@ target_sources(Octopus_lib PRIVATE 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 a12c891ca7..1f00a57fcd 100644 --- a/src/scf/electrons_ground_state.F90 +++ b/src/scf/electrons_ground_state.F90 @@ -30,6 +30,7 @@ submodule (electrons_ground_state_oct_m) impl 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 diff --git a/src/scf/scf_h.F90 b/src/scf/scf_h.F90 index d42d79951d..920eda90d0 100644 --- a/src/scf/scf_h.F90 +++ b/src/scf/scf_h.F90 @@ -2,34 +2,13 @@ module scf_oct_m use berry_oct_m use convergence_criterion_oct_m use eigensolver_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 ions_oct_m use lda_u_mixer_oct_m use mix_oct_m - use multicomm_oct_m - use namespace_oct_m - use output_low_oct_m - use restart_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_t, & - scf_init, & - scf_mix_clear, & - scf_run, & - scf_end, & - scf_state_info, & - scf_print_mem_use integer, public, parameter :: & VERB_NO = 0, & @@ -37,81 +16,32 @@ module scf_oct_m VERB_FULL = 3 !> some variables used for the SCF cycle - type scf_t + type, public :: 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 + logical, public :: conv_eigen_error + logical, public :: check_conv - integer :: mix_field - logical :: lcao_restricted - logical :: calc_force + integer, public :: mix_field + logical, public :: lcao_restricted + logical, public :: 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 + 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) :: energy_in, energy_diff, abs_dens_diff, evsum_in, evsum_out, evsum_diff + real(real64), public :: energy_in, energy_diff, abs_dens_diff, evsum_in, evsum_out, evsum_diff end type scf_t - - interface - module 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 - end subroutine scf_init - - module subroutine scf_mix_clear(scf) - type(scf_t), intent(inout) :: scf - end subroutine scf_mix_clear - - module 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 - 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 - end subroutine scf_run - - module subroutine scf_end(scf) - type(scf_t), intent(inout) :: scf - end subroutine scf_end - - module subroutine scf_state_info(namespace, st) - type(namespace_t), intent(in) :: namespace - class(states_abst_t), intent(in) :: st - 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_oct_m diff --git a/src/scf/scf.F90 b/src/scf/scf_interface.F90 similarity index 99% rename from src/scf/scf.F90 rename to src/scf/scf_interface.F90 index cc25a6c198..a4a362586b 100644 --- a/src/scf/scf.F90 +++ b/src/scf/scf_interface.F90 @@ -18,12 +18,15 @@ #include "global.h" -submodule (scf_oct_m) impl +submodule (scf_interface_oct_m) impl 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_criterion_oct_m use density_oct_m + use eigensolver_oct_m use eigenval_criterion_oct_m use energy_calc_oct_m use energy_criterion_oct_m @@ -33,6 +36,7 @@ submodule (scf_oct_m) impl use lalg_basic_oct_m use lcao_oct_m use lda_u_io_oct_m + use lda_u_mixer_oct_m use lda_u_oct_m use loct_oct_m use magnetic_oct_m @@ -40,6 +44,7 @@ submodule (scf_oct_m) impl 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 output_modelmb_oct_m diff --git a/src/scf/scf_interface_h.F90 b/src/scf/scf_interface_h.F90 new file mode 100644 index 0000000000..6da78e0c57 --- /dev/null +++ b/src/scf/scf_interface_h.F90 @@ -0,0 +1,77 @@ +module scf_interface_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 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(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 + end subroutine scf_init + + module subroutine scf_mix_clear(scf) + type(scf_t), intent(inout) :: scf + end subroutine scf_mix_clear + + module 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 + 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 + end subroutine scf_run + + module subroutine scf_end(scf) + type(scf_t), intent(inout) :: scf + end subroutine scf_end + + module subroutine scf_state_info(namespace, st) + type(namespace_t), intent(in) :: namespace + class(states_abst_t), intent(in) :: st + 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 6373a84cd6..9318ddf103 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 diff --git a/src/td/propagator_elec.F90 b/src/td/propagator_elec.F90 index 9febe7acd3..8746360bb4 100644 --- a/src/td/propagator_elec.F90 +++ b/src/td/propagator_elec.F90 @@ -39,6 +39,7 @@ submodule (propagator_elec_oct_m) impl use propagator_qoct_oct_m use propagator_rk_oct_m use propagator_verlet_oct_m + use scf_interface_oct_m use sparskit_oct_m use stress_oct_m use varinfo_oct_m diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index 4492e548c6..f2e954bd1f 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -56,6 +56,7 @@ submodule (td_interface_oct_m) impl use propagator_elec_oct_m use propagator_oct_m use restart_oct_m + use scf_interface_oct_m use scf_oct_m use scissor_oct_m use states_abst_oct_m -- GitLab From b6307bb6bff477edb479263a25d758637fe7b0a6 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Fri, 10 May 2024 19:34:28 +0200 Subject: [PATCH 24/72] Dirty fix for autotools builder Signed-off-by: Cristian Le --- src/basic/global.F90 | 1 + src/electrons/electrons.F90 | 1 + src/hamiltonian/hamiltonian_elec.F90 | 1 + src/maxwell/hamiltonian_mxll.F90 | 1 + src/multisystem/system.F90 | 1 + src/scf/electrons_ground_state.F90 | 1 + src/scf/scf_interface.F90 | 1 + src/td/propagator_elec.F90 | 1 + src/td/td_interface.F90 | 1 + 9 files changed, 9 insertions(+) diff --git a/src/basic/global.F90 b/src/basic/global.F90 index dc588b7f3f..9ffc7fb5fa 100644 --- a/src/basic/global.F90 +++ b/src/basic/global.F90 @@ -19,6 +19,7 @@ #include "global.h" submodule (global_oct_m) impl + use global_oct_m use hardware_oct_m use loct_oct_m use varinfo_oct_m diff --git a/src/electrons/electrons.F90 b/src/electrons/electrons.F90 index 8ef4bd8a0d..862d412607 100644 --- a/src/electrons/electrons.F90 +++ b/src/electrons/electrons.F90 @@ -21,6 +21,7 @@ #include "global.h" submodule (electrons_oct_m) impl + use electrons_oct_m use accel_oct_m use absorbing_boundaries_oct_m use calc_mode_par_oct_m diff --git a/src/hamiltonian/hamiltonian_elec.F90 b/src/hamiltonian/hamiltonian_elec.F90 index ff9d6c813f..3db64544fc 100644 --- a/src/hamiltonian/hamiltonian_elec.F90 +++ b/src/hamiltonian/hamiltonian_elec.F90 @@ -20,6 +20,7 @@ #include "global.h" submodule (hamiltonian_elec_oct_m) impl + use hamiltonian_elec_oct_m use accel_oct_m use affine_coordinates_oct_m use batch_ops_oct_m diff --git a/src/maxwell/hamiltonian_mxll.F90 b/src/maxwell/hamiltonian_mxll.F90 index ca15634cdb..62774d567d 100644 --- a/src/maxwell/hamiltonian_mxll.F90 +++ b/src/maxwell/hamiltonian_mxll.F90 @@ -19,6 +19,7 @@ #include "global.h" submodule (hamiltonian_mxll_oct_m) impl + use hamiltonian_mxll_oct_m use accel_oct_m use batch_ops_oct_m use boundaries_oct_m diff --git a/src/multisystem/system.F90 b/src/multisystem/system.F90 index cb16c27b6e..2c8faaa7de 100644 --- a/src/multisystem/system.F90 +++ b/src/multisystem/system.F90 @@ -21,6 +21,7 @@ #include "global.h" submodule (system_oct_m) impl + use system_oct_m use debug_oct_m use ghost_interaction_oct_m use global_oct_m diff --git a/src/scf/electrons_ground_state.F90 b/src/scf/electrons_ground_state.F90 index 1f00a57fcd..c4a7c70fb1 100644 --- a/src/scf/electrons_ground_state.F90 +++ b/src/scf/electrons_ground_state.F90 @@ -19,6 +19,7 @@ #include "global.h" submodule (electrons_ground_state_oct_m) impl + use electrons_ground_state_oct_m use debug_oct_m use global_oct_m use hamiltonian_elec_oct_m diff --git a/src/scf/scf_interface.F90 b/src/scf/scf_interface.F90 index a4a362586b..0c6fa7cdd4 100644 --- a/src/scf/scf_interface.F90 +++ b/src/scf/scf_interface.F90 @@ -19,6 +19,7 @@ #include "global.h" 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 diff --git a/src/td/propagator_elec.F90 b/src/td/propagator_elec.F90 index 8746360bb4..20cd7a8fc2 100644 --- a/src/td/propagator_elec.F90 +++ b/src/td/propagator_elec.F90 @@ -19,6 +19,7 @@ #include "global.h" submodule (propagator_elec_oct_m) impl + use propagator_elec_oct_m use debug_oct_m use energy_calc_oct_m use exponential_oct_m diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index f2e954bd1f..2a3e95e6ce 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -19,6 +19,7 @@ #include "global.h" 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 -- GitLab From 8dfaf82d5218ea37fc6e5c118088314fe2cafcfb Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 30 May 2023 14:32:17 +0200 Subject: [PATCH 25/72] Change `td_run` signature Signed-off-by: Cristian Le --- src/main/time_dependent.F90 | 3 +- src/td/td_interface.F90 | 70 +++++++++++++++++-------------------- src/td/td_interface_h.F90 | 15 ++------ 3 files changed, 37 insertions(+), 51 deletions(-) diff --git a/src/main/time_dependent.F90 b/src/main/time_dependent.F90 index 468f14985f..3af391c13f 100644 --- a/src/main/time_dependent.F90 +++ b/src/main/time_dependent.F90 @@ -136,8 +136,7 @@ contains 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_run(electrons, from_scratch) call td_end_run(electrons%td, electrons%st, electrons%hm) call td_end(electrons%td) diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index 2a3e95e6ce..3e3b704124 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -484,18 +484,8 @@ contains end subroutine td_end_run ! --------------------------------------------------------- - module 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 @@ -506,62 +496,68 @@ 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%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%td%scf, sys%namespace, sys%space, sys%gr, sys%ks, sys%st, sys%hm, & + sys%ions, sys%ext_partners, sys%mc, sys%outp, iter, & + sys%td%dt, sys%td%ions_dyn, 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 td_write_iter(sys%td%write_handler, sys%namespace, sys%space, sys%outp, sys%gr, sys%st, sys%hm, & + sys%ions, sys%ext_partners, sys%hm%kick, sys%ks, sys%td%dt, iter, sys%mc, sys%td%recalculate_gs) ! write down data - call td_check_point(td, namespace, mc, gr, ions, st, ks, hm, ext_partners, outp, space, & + call td_check_point(sys%td, sys%namespace, sys%mc, sys%gr, sys%ions, sys%st, sys%ks, sys%hm, & + sys%ext_partners, sys%outp, sys%space, & 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 diff --git a/src/td/td_interface_h.F90 b/src/td/td_interface_h.F90 index 86f99e6333..f6adca2a80 100644 --- a/src/td/td_interface_h.F90 +++ b/src/td/td_interface_h.F90 @@ -1,4 +1,5 @@ module td_interface_oct_m + use electrons_oct_m use electron_space_oct_m use grid_oct_m use hamiltonian_elec_oct_m @@ -33,18 +34,8 @@ module td_interface_oct_m ! Subroutine/Functions interface - module 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 end subroutine td_run -- GitLab From 82d341c45aad72c82396a5c510bbdb6369c60e8c Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 20 Jun 2023 16:14:30 +0200 Subject: [PATCH 26/72] td_init: Change signature Signed-off-by: Cristian Le --- src/electrons/electrons.F90 | 3 +- src/main/time_dependent.F90 | 3 +- src/opt_control/opt_control.F90 | 43 ++++++----- src/td/td_interface.F90 | 128 +++++++++++++++----------------- src/td/td_interface_h.F90 | 13 +--- 5 files changed, 85 insertions(+), 105 deletions(-) diff --git a/src/electrons/electrons.F90 b/src/electrons/electrons.F90 index 862d412607..5bdc701f1e 100644 --- a/src/electrons/electrons.F90 +++ b/src/electrons/electrons.F90 @@ -443,8 +443,7 @@ 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, & diff --git a/src/main/time_dependent.F90 b/src/main/time_dependent.F90 index 3af391c13f..efebd98f88 100644 --- a/src/main/time_dependent.F90 +++ b/src/main/time_dependent.F90 @@ -132,8 +132,7 @@ 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(electrons) 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, from_scratch) diff --git a/src/opt_control/opt_control.F90 b/src/opt_control/opt_control.F90 index 2953a3d09b..ba28d650be 100644 --- a/src/opt_control/opt_control.F90 +++ b/src/opt_control/opt_control.F90 @@ -112,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 @@ -137,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. @@ -165,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. & @@ -173,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. @@ -244,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%td) call opt_control_state_end(initial_st) call target_end(oct_target, oct) call controlfunction_mod_close() @@ -268,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 @@ -293,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 @@ -325,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 @@ -351,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 @@ -365,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 @@ -395,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) @@ -412,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)) @@ -470,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) @@ -490,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) @@ -535,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) @@ -558,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/td/td_interface.F90 b/src/td/td_interface.F90 index 3e3b704124..f49e351e75 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -86,17 +86,8 @@ contains ! --------------------------------------------------------- - module 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 @@ -104,24 +95,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 @@ -139,22 +130,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 @@ -169,9 +160,9 @@ contains !% selected ev_angstrom as input units). The approximate conversions to !% femtoseconds are 1 fs = 41.34 \hbar/Hartree = 1.52 \hbar/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 @@ -182,29 +173,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 @@ -219,11 +211,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 @@ -242,9 +234,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 @@ -256,17 +248,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 @@ -281,17 +273,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 @@ -316,13 +308,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 diff --git a/src/td/td_interface_h.F90 b/src/td/td_interface_h.F90 index f6adca2a80..2ddf06cab0 100644 --- a/src/td/td_interface_h.F90 +++ b/src/td/td_interface_h.F90 @@ -42,17 +42,8 @@ module td_interface_oct_m module subroutine td_run_init() end subroutine td_run_init - module 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 end subroutine td_init module subroutine td_init_run(td, namespace, mc, gr, ions, st, ks, hm, ext_partners, outp, space, from_scratch) -- GitLab From cf8ed17392382c557cb89e02db625ff2a4c0dd32 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 20 Jun 2023 16:16:13 +0200 Subject: [PATCH 27/72] td_init_run: Change signature Signed-off-by: Cristian Le --- src/main/time_dependent.F90 | 3 +-- src/td/td_interface.F90 | 44 ++++++++++++++----------------------- src/td/td_interface_h.F90 | 14 ++---------- 3 files changed, 20 insertions(+), 41 deletions(-) diff --git a/src/main/time_dependent.F90 b/src/main/time_dependent.F90 index efebd98f88..8f86398174 100644 --- a/src/main/time_dependent.F90 +++ b/src/main/time_dependent.F90 @@ -133,8 +133,7 @@ contains PUSH_SUB(time_dependent_run_legacy) call td_init(electrons) - 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_init_run(electrons, from_scratch) call td_run(electrons, from_scratch) call td_end_run(electrons%td, electrons%st, electrons%hm) call td_end(electrons%td) diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index f49e351e75..820a128900 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -324,18 +324,8 @@ contains end subroutine td_init ! --------------------------------------------------------- - module 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 PUSH_SUB(td_init_run) @@ -343,34 +333,34 @@ contains ! 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 td_allocate_wavefunctions(sys%td, sys%namespace, sys%mc, sys%gr, sys%ions, sys%st, sys%hm, sys%space) + call td_init_gaugefield(sys%td, sys%namespace, sys%gr, sys%st, sys%ks, sys%hm, sys%ext_partners, sys%space) - td%from_scratch = from_scratch + sys%td%from_scratch = from_scratch - 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 + if (.not. sys%td%from_scratch) then + call td_load_restart_from_td(sys%td, sys%namespace, sys%space, sys%mc, sys%gr, sys%ext_partners, sys%st, sys%ks, sys%hm, sys%td%from_scratch) + if (sys%td%from_scratch) then message(1) = "Unable to read time-dependent restart information: Starting from scratch" - call messages_warning(1, namespace=namespace) + call messages_warning(1, namespace=sys%namespace) end if end if - if (td%iter >= td%max_iter) then + 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) + if (sys%td%from_scratch) then + call td_load_restart_from_gs(sys%td, sys%namespace, sys%space, sys%mc, sys%gr, sys%ext_partners, sys%st, sys%ks, sys%hm) end if - call td_init_with_wavefunctions(td, namespace, space, mc, gr, ions, ext_partners, st, ks, hm, outp, td%from_scratch) + call td_init_with_wavefunctions(sys%td, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, sys%st, sys%ks, sys%hm, sys%outp, sys%td%from_scratch) POP_SUB(td_init_run) end subroutine td_init_run diff --git a/src/td/td_interface_h.F90 b/src/td/td_interface_h.F90 index 2ddf06cab0..7d6395bf29 100644 --- a/src/td/td_interface_h.F90 +++ b/src/td/td_interface_h.F90 @@ -46,18 +46,8 @@ module td_interface_oct_m type(electrons_t), intent(inout) :: sys end subroutine td_init - module 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 end subroutine td_init_run -- GitLab From 35e9d94800b2162b5752e8182173094d4a61f579 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 20 Jun 2023 16:18:23 +0200 Subject: [PATCH 28/72] td_end_run: Change signature Signed-off-by: Cristian Le --- src/electrons/electrons.F90 | 2 +- src/main/time_dependent.F90 | 2 +- src/td/td_interface.F90 | 16 +++++++--------- src/td/td_interface_h.F90 | 6 ++---- 4 files changed, 11 insertions(+), 15 deletions(-) diff --git a/src/electrons/electrons.F90 b/src/electrons/electrons.F90 index 5bdc701f1e..b31cdf6cc2 100644 --- a/src/electrons/electrons.F90 +++ b/src/electrons/electrons.F90 @@ -1018,7 +1018,7 @@ contains 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_run(sys) call td_end(sys%td) end select end if diff --git a/src/main/time_dependent.F90 b/src/main/time_dependent.F90 index 8f86398174..e0c2529492 100644 --- a/src/main/time_dependent.F90 +++ b/src/main/time_dependent.F90 @@ -135,7 +135,7 @@ contains call td_init(electrons) call td_init_run(electrons, from_scratch) call td_run(electrons, from_scratch) - call td_end_run(electrons%td, electrons%st, electrons%hm) + call td_end_run(electrons) call td_end(electrons%td) POP_SUB(time_dependent_run_legacy) diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index 820a128900..80953cffd6 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -446,21 +446,19 @@ contains end subroutine td_end ! --------------------------------------------------------- - module 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 diff --git a/src/td/td_interface_h.F90 b/src/td/td_interface_h.F90 index 7d6395bf29..30a37db39c 100644 --- a/src/td/td_interface_h.F90 +++ b/src/td/td_interface_h.F90 @@ -77,10 +77,8 @@ module td_interface_oct_m type(td_t), intent(inout) :: td end subroutine td_end - module 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 end subroutine td_end_run module subroutine td_check_point(td, namespace, mc, gr, ions, st, ks, hm, ext_partners, outp, space, & -- GitLab From 926d45b57960a22aeb688ca1965ace60157966cb Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 20 Jun 2023 16:20:58 +0200 Subject: [PATCH 29/72] td_end: Change signature Signed-off-by: Cristian Le --- src/electrons/electrons.F90 | 2 +- src/main/time_dependent.F90 | 2 +- src/opt_control/opt_control.F90 | 2 +- src/td/td_interface.F90 | 12 ++++++------ src/td/td_interface_h.F90 | 4 ++-- 5 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/electrons/electrons.F90 b/src/electrons/electrons.F90 index b31cdf6cc2..93623b1f63 100644 --- a/src/electrons/electrons.F90 +++ b/src/electrons/electrons.F90 @@ -1019,7 +1019,7 @@ contains select type (algo => sys%algo) class is (propagator_t) call td_end_run(sys) - call td_end(sys%td) + call td_end(sys) end select end if diff --git a/src/main/time_dependent.F90 b/src/main/time_dependent.F90 index e0c2529492..e2343b86a5 100644 --- a/src/main/time_dependent.F90 +++ b/src/main/time_dependent.F90 @@ -136,7 +136,7 @@ contains call td_init_run(electrons, from_scratch) call td_run(electrons, from_scratch) call td_end_run(electrons) - call td_end(electrons%td) + call td_end(electrons) POP_SUB(time_dependent_run_legacy) end subroutine time_dependent_run_legacy diff --git a/src/opt_control/opt_control.F90 b/src/opt_control/opt_control.F90 index ba28d650be..95f4c5e1de 100644 --- a/src/opt_control/opt_control.F90 +++ b/src/opt_control/opt_control.F90 @@ -249,7 +249,7 @@ contains call controlfunction_end(par) call oct_iterator_end(iterator, sys%namespace) call filter_end(filter) - call td_end(sys%td) + call td_end(sys) call opt_control_state_end(initial_st) call target_end(oct_target, oct) call controlfunction_mod_close() diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index 80953cffd6..7778c03542 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -431,16 +431,16 @@ contains end subroutine td_init_gaugefield ! --------------------------------------------------------- - module 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%td%scf) POP_SUB(td_end) end subroutine td_end diff --git a/src/td/td_interface_h.F90 b/src/td/td_interface_h.F90 index 30a37db39c..0d6999ed36 100644 --- a/src/td/td_interface_h.F90 +++ b/src/td/td_interface_h.F90 @@ -73,8 +73,8 @@ module td_interface_oct_m class(space_t), intent(in) :: space end subroutine td_init_gaugefield - module subroutine td_end(td) - type(td_t), intent(inout) :: td + module subroutine td_end(sys) + type(electrons_t), intent(inout) :: sys end subroutine td_end module subroutine td_end_run(sys) -- GitLab From 84c033caa68eb30a3c845dce81a77994eb853191 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 19 Sep 2023 15:38:40 +0200 Subject: [PATCH 30/72] td_init_with_wavefunctions: Change signature Signed-off-by: Cristian Le --- src/electrons/electrons.F90 | 3 +- src/td/td_interface.F90 | 215 +++++++++++++++++++----------------- src/td/td_interface_h.F90 | 15 +-- 3 files changed, 114 insertions(+), 119 deletions(-) diff --git a/src/electrons/electrons.F90 b/src/electrons/electrons.F90 index 93623b1f63..9ad79166ef 100644 --- a/src/electrons/electrons.F90 +++ b/src/electrons/electrons.F90 @@ -481,8 +481,7 @@ 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, this%td%from_scratch) + call td_init_with_wavefunctions(this) POP_SUB(electrons_propagation_start) end subroutine electrons_propagation_start diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index 7778c03542..006e5c83bc 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -360,7 +360,7 @@ contains call td_load_restart_from_gs(sys%td, sys%namespace, sys%space, sys%mc, sys%gr, sys%ext_partners, sys%st, sys%ks, sys%hm) end if - call td_init_with_wavefunctions(sys%td, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, sys%st, sys%ks, sys%hm, sys%outp, sys%td%from_scratch) + call td_init_with_wavefunctions(sys) POP_SUB(td_init_run) end subroutine td_init_run @@ -657,23 +657,12 @@ contains end subroutine td_update_elapsed_time ! --------------------------------------------------------- - module 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 @@ -682,64 +671,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 @@ -750,40 +744,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 @@ -793,16 +794,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 @@ -814,77 +815,83 @@ 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%td, sys%namespace, & + sys%space, sys%gr, sys%ions, sys%st, sys%ks, sys%hm, sys%ext_partners, sys%outp, sys%mc) - 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 diff --git a/src/td/td_interface_h.F90 b/src/td/td_interface_h.F90 index 0d6999ed36..35f30ad728 100644 --- a/src/td/td_interface_h.F90 +++ b/src/td/td_interface_h.F90 @@ -101,19 +101,8 @@ module td_interface_oct_m logical, intent(inout) :: from_scratch end subroutine td_check_point - module 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 end subroutine td_init_with_wavefunctions module subroutine td_load_restart_from_gs(td, namespace, space, mc, gr, ext_partners, st, ks, hm) -- GitLab From b5f4c40d3d40dd1d273ceed829001f16744bf927 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 19 Sep 2023 15:43:47 +0200 Subject: [PATCH 31/72] td_run_zero_iter: Change signature Signed-off-by: Cristian Le --- src/td/td_interface.F90 | 47 ++++++++++++++++++----------------------- 1 file changed, 20 insertions(+), 27 deletions(-) diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index 006e5c83bc..7541aab5c0 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -859,8 +859,7 @@ contains sys%gr, sys%hm%d, sys%hm%kpoints, sys%hm%phase, sys%td%scissor, sys%mc) end if - if (sys%td%iter == 0) call td_run_zero_iter(sys%td, sys%namespace, & - sys%space, sys%gr, sys%ions, sys%st, sys%ks, sys%hm, sys%ext_partners, sys%outp, sys%mc) + if (sys%td%iter == 0) call td_run_zero_iter(sys) gfield => list_get_gauge_field(sys%ext_partners) if(associated(gfield)) then @@ -1018,43 +1017,37 @@ 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) + call td_write_iter(sys%td%write_handler, sys%namespace, sys%space, & + sys%outp, sys%gr, sys%st, sys%hm, sys%ions, sys%ext_partners, & + sys%hm%kick, sys%ks, sys%td%dt, 0, sys%mc, sys%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) + call td_write_output(sys%namespace, sys%space, sys%gr, sys%st, sys%hm, & + sys%ks, sys%outp, sys%ions, sys%ext_partners, 0) end if POP_SUB(td_run_zero_iter) -- GitLab From 27efa86d222e4c7bbe7f4d95c3094e1935b3c9af Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 19:39:19 +0200 Subject: [PATCH 32/72] td_check_point: Change signature Signed-off-by: Cristian Le --- src/td/td_interface.F90 | 67 ++++++++++++++++++--------------------- src/td/td_interface_h.F90 | 21 ------------ 2 files changed, 30 insertions(+), 58 deletions(-) diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index 7541aab5c0..b0bbc899e4 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -532,9 +532,7 @@ contains sys%ions, sys%ext_partners, sys%hm%kick, sys%ks, sys%td%dt, iter, sys%mc, sys%td%recalculate_gs) ! write down data - call td_check_point(sys%td, sys%namespace, sys%mc, sys%gr, sys%ions, sys%st, sys%ks, sys%hm, & - sys%ext_partners, sys%outp, sys%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(sys%namespace) @@ -561,19 +559,8 @@ contains end subroutine td_print_header ! --------------------------------------------------------- - module 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 @@ -584,40 +571,46 @@ contains PUSH_SUB(td_check_point) - call td_print_message(td, namespace, ions, hm, iter, scsteps, etime) + call td_print_message(sys%td, sys%namespace, sys%ions, sys%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) + call td_write_output(sys%namespace, sys%space, sys%gr, sys%st, sys%hm, sys%ks, & + sys%outp, sys%ions, sys%ext_partners, iter, sys%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 (mod(iter, sys%outp%restart_write_interval) == 0 .or. iter == sys%td%max_iter .or. stopping) then ! restart + !if (iter == sys%td%max_iter) sys%outp%iter = ii - 1 + call td_write_data(sys%td%write_handler) + call td_dump(sys%td, sys%namespace, sys%space, sys%gr, sys%st, sys%hm, sys%ks, & + sys%ext_partners, iter, ierr) if (ierr /= 0) then message(1) = "Unable to write time-dependent restart information." - call messages_warning(1, namespace=namespace) + call messages_warning(1, namespace=sys%namespace) end if - call pes_output(td%pesv, namespace, space, gr, st, iter, outp, td%dt, ions) + call pes_output(sys%td%pesv, sys%namespace, sys%space, sys%gr, sys%st, iter, sys%outp, & + sys%td%dt, sys%ions) - 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%namespace, sys%mc, sys%gr, sys%ions, sys%ext_partners, & + sys%st, sys%ks, sys%hm, sys%outp, sys%space, 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 diff --git a/src/td/td_interface_h.F90 b/src/td/td_interface_h.F90 index 35f30ad728..9c4c32215d 100644 --- a/src/td/td_interface_h.F90 +++ b/src/td/td_interface_h.F90 @@ -22,7 +22,6 @@ module td_interface_oct_m td_init_run, & td_end, & td_end_run, & - td_check_point, & td_dump, & td_allocate_wavefunctions, & td_init_gaugefield, & @@ -81,26 +80,6 @@ module td_interface_oct_m type(electrons_t), intent(inout) :: sys end subroutine td_end_run - module 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 - integer, intent(in) :: iter - integer, intent(in) :: scsteps - real(real64), intent(inout) :: etime - logical, intent(in) :: stopping - logical, intent(inout) :: from_scratch - end subroutine td_check_point - module subroutine td_init_with_wavefunctions(sys) type(electrons_t), target, intent(inout) :: sys end subroutine td_init_with_wavefunctions -- GitLab From 8110f29cc9343d15ac2870d0dfdf842b971d6000 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 23 Apr 2024 21:21:40 +0200 Subject: [PATCH 33/72] td_allocate_wavefunctions: Change signature Signed-off-by: Cristian Le --- src/electrons/electrons.F90 | 3 +-- src/td/td_interface.F90 | 29 +++++++++++------------------ src/td/td_interface_h.F90 | 11 ++--------- 3 files changed, 14 insertions(+), 29 deletions(-) diff --git a/src/electrons/electrons.F90 b/src/electrons/electrons.F90 index 9ad79166ef..9e416f44b8 100644 --- a/src/electrons/electrons.F90 +++ b/src/electrons/electrons.F90 @@ -446,8 +446,7 @@ contains 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) diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index b0bbc899e4..5a6d2d89af 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -366,34 +366,27 @@ contains end subroutine td_init_run ! --------------------------------------------------------- - module 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%td%scf, sys%namespace, sys%gr, sys%ions, sys%st, sys%mc, sys%hm, sys%space) end if POP_SUB(td_allocate_wavefunctions) diff --git a/src/td/td_interface_h.F90 b/src/td/td_interface_h.F90 index 9c4c32215d..2c4abd4ece 100644 --- a/src/td/td_interface_h.F90 +++ b/src/td/td_interface_h.F90 @@ -50,15 +50,8 @@ module td_interface_oct_m logical, intent(inout) :: from_scratch end subroutine td_init_run - module 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 end subroutine td_allocate_wavefunctions module subroutine td_init_gaugefield(td, namespace, gr, st, ks, hm, ext_partners, space) -- GitLab From 8242708fc2f24f89de8ddd670f8a3838be2ae621 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 23 Apr 2024 12:13:30 +0200 Subject: [PATCH 34/72] electrons_ground_state_run: Change signature Signed-off-by: Cristian Le --- src/main/ground_state.F90 | 16 +---- src/scf/electrons_ground_state.F90 | 90 ++++++++++++++-------------- src/scf/electrons_ground_state_h.F90 | 24 +------- src/td/td_interface.F90 | 3 +- 4 files changed, 50 insertions(+), 83 deletions(-) diff --git a/src/main/ground_state.F90 b/src/main/ground_state.F90 index 8e5adb8ead..ee17ad0bc6 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/scf/electrons_ground_state.F90 b/src/scf/electrons_ground_state.F90 index c4a7c70fb1..e58a2cc9b8 100644 --- a/src/scf/electrons_ground_state.F90 +++ b/src/scf/electrons_ground_state.F90 @@ -35,24 +35,17 @@ submodule (electrons_ground_state_oct_m) impl use scf_oct_m use space_oct_m use states_abst_oct_m + use states_elec_oct_m use states_elec_restart_oct_m + use v_ks_oct_m implicit none contains ! --------------------------------------------------------- - module 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 @@ -64,99 +57,104 @@ 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)) + call restart_init(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(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(scfv, sys%namespace, sys%gr, sys%ions, sys%st, sys%mc, sys%hm, sys%space) ! only initialize dumping restart files for more than one iteration restart_init_dump = scfv%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) + 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 = scfv%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) + call restart_init(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%namespace, sys%st) - 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, restart_dump) call rdmft_end(rdm) else 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, & + call scf_run(scfv, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, & + sys%ext_partners, sys%st, sys%ks, sys%hm, outp=sys%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) + call scf_run(scfv, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, & + sys%st, sys%ks, sys%hm, outp=sys%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) + call scf_run(scfv, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, & + sys%st, sys%ks, sys%hm, outp=sys%outp, restart_dump=restart_dump) else - call scf_run(scfv, namespace, space, mc, gr, ions, ext_partners, st, ks, hm, outp=outp) + call scf_run(scfv, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, & + sys%st, sys%ks, sys%hm, outp=sys%outp) end if end if @@ -167,12 +165,12 @@ contains call restart_end(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 diff --git a/src/scf/electrons_ground_state_h.F90 b/src/scf/electrons_ground_state_h.F90 index da0b3ac4e1..25cff7d46a 100644 --- a/src/scf/electrons_ground_state_h.F90 +++ b/src/scf/electrons_ground_state_h.F90 @@ -1,14 +1,5 @@ module electrons_ground_state_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 states_elec_oct_m - use v_ks_oct_m + use electrons_oct_m implicit none @@ -17,17 +8,8 @@ module electrons_ground_state_oct_m electrons_ground_state_run interface - module 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 end subroutine electrons_ground_state_run end interface diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index 5a6d2d89af..3a99634574 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -588,8 +588,7 @@ contains call messages_print_with_emphasis(msg='Recalculating the ground state.', namespace=sys%namespace) from_scratch = .false. call states_elec_deallocate_wfns(sys%st) - call electrons_ground_state_run(sys%namespace, sys%mc, sys%gr, sys%ions, sys%ext_partners, & - sys%st, sys%ks, sys%hm, sys%outp, sys%space, from_scratch) + 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) -- GitLab From 61a5313d20b2ed5f927bfdae9344ed718adeb25a Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 23 Apr 2024 21:16:10 +0200 Subject: [PATCH 35/72] get_dyn_matrix: Change signature Signed-off-by: Cristian Le --- src/main/phonons_fd.F90 | 62 +++++++++++++++++------------------------ 1 file changed, 26 insertions(+), 36 deletions(-) diff --git a/src/main/phonons_fd.F90 b/src/main/phonons_fd.F90 index 92ad4e2715..a0ce151480 100644 --- a/src/main/phonons_fd.F90 +++ b/src/main/phonons_fd.F90 @@ -130,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) @@ -144,18 +143,9 @@ 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 @@ -164,45 +154,45 @@ contains 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(scf, sys%namespace, sys%gr, sys%ions, sys%st, sys%mc, sys%hm, sys%space) + 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) @@ -227,12 +217,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 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(scf) - call scf_run(scf, namespace, space, mc, gr, ions, ext_partners, st, ks, hm, verbosity = VERB_COMPACT) + call scf_run(scf, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, sys%st, sys%ks, sys%hm, verbosity = VERB_COMPACT) POP_SUB(get_dyn_matrix.run_displacement) end subroutine run_displacement -- GitLab From ad9bf34ebe900e31bb0f04d1bf41c35162792d20 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 23 Apr 2024 13:16:12 +0200 Subject: [PATCH 36/72] Use system's scf object Signed-off-by: Cristian Le --- src/main/geom_opt.F90 | 15 +++++++-------- src/main/phonons_fd.F90 | 9 ++++----- src/main/static_pol.F90 | 19 +++++++++---------- src/scf/electrons_ground_state.F90 | 17 ++++++++--------- src/td/td_h.F90 | 2 -- src/td/td_interface.F90 | 6 +++--- 6 files changed, 31 insertions(+), 37 deletions(-) diff --git a/src/main/geom_opt.F90 b/src/main/geom_opt.F90 index 1249dddaa6..b7fa4b3117 100644 --- a/src/main/geom_opt.F90 +++ b/src/main/geom_opt.F90 @@ -77,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 @@ -172,17 +171,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%scf, sys%namespace, sys%gr, sys%ions, sys%st, sys%mc, sys%hm, sys%space) 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.' @@ -247,9 +246,9 @@ contains call g_opt%ions%write_xyz('./min') SAFE_DEALLOCATE_A(coords) - call scf_end(g_opt%scfv) + call scf_end(sys%scf) ! 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) @@ -765,7 +764,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%scf) ! Update lattice vectors and regenerate grid if (bitand(g_opt%type, GO_CELL) /= 0 .or. bitand(g_opt%type, GO_VOLUME) /= 0 ) then @@ -782,7 +781,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, & + call scf_run(g_opt%syst%scf, 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) diff --git a/src/main/phonons_fd.F90 b/src/main/phonons_fd.F90 index a0ce151480..4429011040 100644 --- a/src/main/phonons_fd.F90 +++ b/src/main/phonons_fd.F90 @@ -147,14 +147,13 @@ contains type(electrons_t), intent(inout) :: sys type(vibrations_t), intent(inout) :: vib - 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, sys%namespace, sys%gr, sys%ions, sys%st, sys%mc, sys%hm, sys%space) + call scf_init(sys%scf, sys%namespace, sys%gr, sys%ions, sys%st, sys%mc, sys%hm, sys%space) 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 @@ -204,7 +203,7 @@ contains end do SAFE_DEALLOCATE_A(forces0) SAFE_DEALLOCATE_A(forces) - call scf_end(scf) + call scf_end(sys%scf) call vibrations_symmetrize_dyn_matrix(vib) call vibrations_diag_dyn_matrix(vib) @@ -221,8 +220,8 @@ contains 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(scf) - call scf_run(scf, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, sys%st, sys%ks, sys%hm, verbosity = VERB_COMPACT) + call scf_mix_clear(sys%scf) + call scf_run(sys%scf, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, sys%st, sys%ks, sys%hm, verbosity = VERB_COMPACT) POP_SUB(get_dyn_matrix.run_displacement) end subroutine run_displacement diff --git a/src/main/static_pol.F90 b/src/main/static_pol.F90 index 4af6a1b65b..b50791c905 100644 --- a/src/main/static_pol.F90 +++ b/src/main/static_pol.F90 @@ -83,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(:, :, :) @@ -224,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%scf, sys%namespace, sys%gr, sys%ions, sys%st, sys%mc, sys%hm, sys%space) call born_charges_init(born_charges, sys%namespace, sys%ions%natoms, sys%st%val_charge, & sys%st%qtot, sys%space%dim) @@ -236,7 +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, & + call scf_run(sys%scf, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, sys%st, & sys%ks, sys%hm, 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) @@ -306,12 +305,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, & + call scf_mix_clear(sys%scf) + call scf_run(sys%scf, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, sys%st, & sys%ks, sys%hm, verbosity = verbosity) trrho = M_ZERO @@ -392,12 +391,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, & + call scf_mix_clear(sys%scf) + call scf_run(sys%scf, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, sys%st, & sys%ks, sys%hm, verbosity = verbosity) trrho = M_ZERO @@ -440,7 +439,7 @@ contains end if if (.not. fromScratch) call restart_end(restart_load) - call scf_end(scfv) + call scf_end(sys%scf) call output_end_() call born_charges_end(born_charges) diff --git a/src/scf/electrons_ground_state.F90 b/src/scf/electrons_ground_state.F90 index e58a2cc9b8..f08bebfb1c 100644 --- a/src/scf/electrons_ground_state.F90 +++ b/src/scf/electrons_ground_state.F90 @@ -48,7 +48,6 @@ contains 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 @@ -103,15 +102,15 @@ contains sys%gr%box, sys%namespace) if (sys%ks%theory_level /= RDMFT) then - call scf_init(scfv, sys%namespace, sys%gr, sys%ions, sys%st, sys%mc, sys%hm, sys%space) + call scf_init(sys%scf, sys%namespace, sys%gr, sys%ions, sys%st, sys%mc, sys%hm, sys%space) ! 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. 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 = 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 call messages_write('Info: Setting up Hamiltonian.') @@ -140,25 +139,25 @@ contains else if (.not. fromScratch) then if (restart_init_dump) then - call scf_run(scfv, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, & + call scf_run(sys%scf, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, & sys%ext_partners, sys%st, sys%ks, sys%hm, outp=sys%outp, & restart_load=restart_load, restart_dump=restart_dump) else - call scf_run(scfv, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, & + call scf_run(sys%scf, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, & sys%st, sys%ks, sys%hm, outp=sys%outp, restart_load=restart_load) end if call restart_end(restart_load) else if (restart_init_dump) then - call scf_run(scfv, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, & + call scf_run(sys%scf, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, & sys%st, sys%ks, sys%hm, outp=sys%outp, restart_dump=restart_dump) else - call scf_run(scfv, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, & + call scf_run(sys%scf, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, & sys%st, sys%ks, sys%hm, outp=sys%outp) end if end if - call scf_end(scfv) + call scf_end(sys%scf) end if if (restart_init_dump) then diff --git a/src/td/td_h.F90 b/src/td/td_h.F90 index 1867f3a53b..a607b61acd 100644 --- a/src/td/td_h.F90 +++ b/src/td/td_h.F90 @@ -12,7 +12,6 @@ module td_oct_m use pes_oct_m use propagator_base_oct_m use restart_oct_m - use scf_oct_m use space_oct_m use states_elec_oct_m use td_write_oct_m @@ -30,7 +29,6 @@ module td_oct_m type, public :: 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 diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index 3a99634574..9397ee72f4 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -386,7 +386,7 @@ contains end if else call states_elec_allocate_wfns(sys%st, sys%gr, packed=.true.) - call scf_init(sys%td%scf, sys%namespace, sys%gr, sys%ions, sys%st, sys%mc, sys%hm, sys%space) + call scf_init(sys%scf, sys%namespace, sys%gr, sys%ions, sys%st, sys%mc, sys%hm, sys%space) end if POP_SUB(td_allocate_wavefunctions) @@ -433,7 +433,7 @@ contains call propagator_elec_end(sys%td%tr) ! clean the evolution method call ion_dynamics_end(sys%td%ions_dyn) - if (sys%td%dynamics == BO) call scf_end(sys%td%scf) + if (sys%td%dynamics == BO) call scf_end(sys%scf) POP_SUB(td_end) end subroutine td_end @@ -501,7 +501,7 @@ contains 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(sys%td%scf, sys%namespace, sys%space, sys%gr, sys%ks, sys%st, sys%hm, & + call propagator_elec_dt_bo(sys%scf, sys%namespace, sys%space, sys%gr, sys%ks, sys%st, sys%hm, & sys%ions, sys%ext_partners, sys%mc, sys%outp, iter, & sys%td%dt, sys%td%ions_dyn, scsteps) end select -- GitLab From 5580a823c6e528e32653acb0e70c4575de70370f Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 23 Apr 2024 21:42:35 +0200 Subject: [PATCH 37/72] propagator_elec_dt_bo: Change signature Signed-off-by: Cristian Le --- src/td/propagator_elec.F90 | 51 +++++++++++++++--------------------- src/td/propagator_elec_h.F90 | 18 +++---------- src/td/td_interface.F90 | 4 +-- 3 files changed, 25 insertions(+), 48 deletions(-) diff --git a/src/td/propagator_elec.F90 b/src/td/propagator_elec.F90 index 20cd7a8fc2..51dca2925a 100644 --- a/src/td/propagator_elec.F90 +++ b/src/td/propagator_elec.F90 @@ -602,22 +602,9 @@ contains ! --------------------------------------------------------- - module 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 @@ -625,40 +612,44 @@ 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, & + call scf_run(sys%scf, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, & + sys%st, sys%ks, sys%hm, & 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 diff --git a/src/td/propagator_elec_h.F90 b/src/td/propagator_elec_h.F90 index bc6db9574c..851e46c825 100644 --- a/src/td/propagator_elec_h.F90 +++ b/src/td/propagator_elec_h.F90 @@ -1,5 +1,6 @@ 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 @@ -92,22 +93,9 @@ module propagator_elec_oct_m logical :: propagated end function propagator_elec_ions_are_propagated - module 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 end subroutine propagator_elec_dt_bo end interface diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index 9397ee72f4..29c1133f1e 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -501,9 +501,7 @@ contains 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(sys%scf, sys%namespace, sys%space, sys%gr, sys%ks, sys%st, sys%hm, & - sys%ions, sys%ext_partners, sys%mc, sys%outp, iter, & - sys%td%dt, sys%td%ions_dyn, scsteps) + call propagator_elec_dt_bo(sys, iter, scsteps) end select !Apply mask absorbing boundaries -- GitLab From ab2a8031ec7efd8d812342c474a13f304d8422d2 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 23 Apr 2024 21:33:17 +0200 Subject: [PATCH 38/72] scf_init: Change signature Signed-off-by: Cristian Le --- src/electrons/electrons.F90 | 2 +- src/main/geom_opt.F90 | 2 +- src/main/phonons_fd.F90 | 2 +- src/main/static_pol.F90 | 2 +- src/scf/electrons_ground_state.F90 | 2 +- src/scf/scf_interface.F90 | 137 ++++++++++++++--------------- src/scf/scf_interface_h.F90 | 12 +-- src/td/td_interface.F90 | 2 +- 8 files changed, 74 insertions(+), 87 deletions(-) diff --git a/src/electrons/electrons.F90 b/src/electrons/electrons.F90 index 9e416f44b8..338b71ae4e 100644 --- a/src/electrons/electrons.F90 +++ b/src/electrons/electrons.F90 @@ -588,7 +588,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. diff --git a/src/main/geom_opt.F90 b/src/main/geom_opt.F90 index b7fa4b3117..73e3d2701f 100644 --- a/src/main/geom_opt.F90 +++ b/src/main/geom_opt.F90 @@ -171,7 +171,7 @@ contains end if end if - call scf_init(sys%scf, 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. sys%scf%calc_stress) then diff --git a/src/main/phonons_fd.F90 b/src/main/phonons_fd.F90 index 4429011040..c87f1baa6b 100644 --- a/src/main/phonons_fd.F90 +++ b/src/main/phonons_fd.F90 @@ -153,7 +153,7 @@ contains PUSH_SUB(get_dyn_matrix) - call scf_init(sys%scf, sys%namespace, sys%gr, sys%ions, sys%st, sys%mc, sys%hm, sys%space) + 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 diff --git a/src/main/static_pol.F90 b/src/main/static_pol.F90 index b50791c905..35c38c3c90 100644 --- a/src/main/static_pol.F90 +++ b/src/main/static_pol.F90 @@ -223,7 +223,7 @@ contains gs_rho = M_ZERO call output_init_() - call scf_init(sys%scf, 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) diff --git a/src/scf/electrons_ground_state.F90 b/src/scf/electrons_ground_state.F90 index f08bebfb1c..a35c8dee88 100644 --- a/src/scf/electrons_ground_state.F90 +++ b/src/scf/electrons_ground_state.F90 @@ -102,7 +102,7 @@ contains sys%gr%box, sys%namespace) if (sys%ks%theory_level /= RDMFT) then - call scf_init(sys%scf, sys%namespace, sys%gr, sys%ions, sys%st, sys%mc, sys%hm, sys%space) + call scf_init(sys) ! only initialize dumping restart files for more than one iteration restart_init_dump = sys%scf%max_iter > 0 else diff --git a/src/scf/scf_interface.F90 b/src/scf/scf_interface.F90 index 0c6fa7cdd4..54a2e18541 100644 --- a/src/scf/scf_interface.F90 +++ b/src/scf/scf_interface.F90 @@ -77,15 +77,8 @@ submodule (scf_interface_oct_m) impl contains ! --------------------------------------------------------- - module 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 @@ -112,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.") @@ -150,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 @@ -164,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 @@ -193,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 @@ -275,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 @@ -297,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 @@ -321,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 @@ -335,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 @@ -346,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 @@ -361,11 +354,11 @@ 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 diff --git a/src/scf/scf_interface_h.F90 b/src/scf/scf_interface_h.F90 index 6da78e0c57..9646e148ce 100644 --- a/src/scf/scf_interface_h.F90 +++ b/src/scf/scf_interface_h.F90 @@ -1,5 +1,6 @@ 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 @@ -27,15 +28,8 @@ module scf_interface_oct_m scf_print_mem_use interface - module 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 end subroutine scf_init module subroutine scf_mix_clear(scf) diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index 29c1133f1e..d7181fe444 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -386,7 +386,7 @@ contains end if else call states_elec_allocate_wfns(sys%st, sys%gr, packed=.true.) - call scf_init(sys%scf, sys%namespace, sys%gr, sys%ions, sys%st, sys%mc, sys%hm, sys%space) + call scf_init(sys) end if POP_SUB(td_allocate_wavefunctions) -- GitLab From 26902f51778b1c2f4df0d1375588636728085557 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 23 Apr 2024 22:02:10 +0200 Subject: [PATCH 39/72] scf_run: Change signature Signed-off-by: Cristian Le --- src/electrons/electrons.F90 | 3 +- src/main/geom_opt.F90 | 4 +- src/main/phonons_fd.F90 | 2 +- src/main/static_pol.F90 | 9 +- src/scf/electrons_ground_state.F90 | 13 +- src/scf/scf_interface.F90 | 505 ++++++++++++++--------------- src/scf/scf_interface_h.F90 | 14 +- src/td/propagator_elec.F90 | 4 +- 8 files changed, 262 insertions(+), 292 deletions(-) diff --git a/src/electrons/electrons.F90 b/src/electrons/electrons.F90 index 338b71ae4e..8d5c9ef5be 100644 --- a/src/electrons/electrons.F90 +++ b/src/electrons/electrons.F90 @@ -601,8 +601,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) diff --git a/src/main/geom_opt.F90 b/src/main/geom_opt.F90 index 73e3d2701f..5315e49380 100644 --- a/src/main/geom_opt.F90 +++ b/src/main/geom_opt.F90 @@ -781,9 +781,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%syst%scf, 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, restart_dump=g_opt%restart_dump) call scf_print_mem_use(g_opt%syst%namespace) diff --git a/src/main/phonons_fd.F90 b/src/main/phonons_fd.F90 index c87f1baa6b..69d5693f9b 100644 --- a/src/main/phonons_fd.F90 +++ b/src/main/phonons_fd.F90 @@ -221,7 +221,7 @@ contains 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%scf) - call scf_run(sys%scf, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, sys%st, sys%ks, sys%hm, verbosity = VERB_COMPACT) + call scf_run(sys, verbosity = VERB_COMPACT) POP_SUB(get_dyn_matrix.run_displacement) end subroutine run_displacement diff --git a/src/main/static_pol.F90 b/src/main/static_pol.F90 index 35c38c3c90..d1119e2535 100644 --- a/src/main/static_pol.F90 +++ b/src/main/static_pol.F90 @@ -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(sys%scf, 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 @@ -310,8 +309,7 @@ contains end if call scf_mix_clear(sys%scf) - call scf_run(sys%scf, 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) trrho = M_ZERO do is = 1, sys%st%d%spin_channels @@ -396,8 +394,7 @@ contains end if call scf_mix_clear(sys%scf) - call scf_run(sys%scf, 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) trrho = M_ZERO do is = 1, sys%st%d%spin_channels diff --git a/src/scf/electrons_ground_state.F90 b/src/scf/electrons_ground_state.F90 index a35c8dee88..837b5c9acd 100644 --- a/src/scf/electrons_ground_state.F90 +++ b/src/scf/electrons_ground_state.F90 @@ -139,21 +139,16 @@ contains else if (.not. fromScratch) then if (restart_init_dump) then - call scf_run(sys%scf, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, & - sys%ext_partners, sys%st, sys%ks, sys%hm, outp=sys%outp, & - restart_load=restart_load, restart_dump=restart_dump) + call scf_run(sys, outp=sys%outp, restart_load=restart_load, restart_dump=restart_dump) else - call scf_run(sys%scf, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, & - sys%st, sys%ks, sys%hm, outp=sys%outp, restart_load=restart_load) + call scf_run(sys, outp=sys%outp, restart_load=restart_load) end if call restart_end(restart_load) else if (restart_init_dump) then - call scf_run(sys%scf, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, & - sys%st, sys%ks, sys%hm, outp=sys%outp, restart_dump=restart_dump) + call scf_run(sys, outp=sys%outp, restart_dump=restart_dump) else - call scf_run(sys%scf, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, & - sys%st, sys%ks, sys%hm, outp=sys%outp) + call scf_run(sys, outp=sys%outp) end if end if diff --git a/src/scf/scf_interface.F90 b/src/scf/scf_interface.F90 index 54a2e18541..01de3dae83 100644 --- a/src/scf/scf_interface.F90 +++ b/src/scf/scf_interface.F90 @@ -406,18 +406,8 @@ contains ! --------------------------------------------------------- - module 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, restart_load, restart_dump) + type(electrons_t), intent(inout) :: sys type(output_t), optional, intent(in) :: outp integer, optional, intent(in) :: verbosity integer, optional, intent(out) :: iters_done @@ -439,9 +429,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 @@ -455,78 +445,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 ! 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(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(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) + call hamiltonian_elec_load_vhxc(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 (sys%scf%mix_field == OPTION__MIXFIELD__DENSITY .or. sys%scf%mix_field == OPTION__MIXFIELD__POTENTIAL) then + call mix_load(sys%namespace, 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(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 @@ -535,157 +525,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) @@ -698,97 +689,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 ! 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(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(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(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, 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(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, 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 @@ -801,7 +792,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 @@ -811,8 +802,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 @@ -820,50 +811,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%scf) 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 @@ -874,48 +865,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) @@ -930,7 +921,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) @@ -938,35 +929,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)') '' @@ -982,8 +975,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 @@ -998,25 +991,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 @@ -1026,15 +1019,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 @@ -1043,48 +1036,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) @@ -1093,37 +1086,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 @@ -1149,21 +1142,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 @@ -1184,8 +1177,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 @@ -1197,9 +1190,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 @@ -1219,10 +1212,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) @@ -1237,10 +1230,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)') '' diff --git a/src/scf/scf_interface_h.F90 b/src/scf/scf_interface_h.F90 index 9646e148ce..a1532f383c 100644 --- a/src/scf/scf_interface_h.F90 +++ b/src/scf/scf_interface_h.F90 @@ -36,18 +36,8 @@ module scf_interface_oct_m type(scf_t), intent(inout) :: scf end subroutine scf_mix_clear - module 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, restart_load, restart_dump) + type(electrons_t), intent(inout) :: sys type(output_t), optional, intent(in) :: outp integer, optional, intent(in) :: verbosity integer, optional, intent(out) :: iters_done diff --git a/src/td/propagator_elec.F90 b/src/td/propagator_elec.F90 index 51dca2925a..98631a5d6d 100644 --- a/src/td/propagator_elec.F90 +++ b/src/td/propagator_elec.F90 @@ -616,9 +616,7 @@ contains 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(sys%scf, sys%namespace, sys%space, sys%mc, sys%gr, sys%ions, sys%ext_partners, & - sys%st, sys%ks, sys%hm, & - verbosity = VERB_COMPACT, iters_done = scsteps) + call scf_run(sys, verbosity = VERB_COMPACT, iters_done = scsteps) gfield => list_get_gauge_field(sys%ext_partners) if(associated(gfield)) then -- GitLab From ba54701dcf5786a169ca7039e2d3f4bc4a4736ac Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 23 Apr 2024 21:35:38 +0200 Subject: [PATCH 40/72] scf_mix_clear: Change signature Signed-off-by: Cristian Le --- src/main/geom_opt.F90 | 2 +- src/main/phonons_fd.F90 | 2 +- src/main/static_pol.F90 | 4 ++-- src/scf/scf_interface.F90 | 10 +++++----- src/scf/scf_interface_h.F90 | 4 ++-- 5 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/main/geom_opt.F90 b/src/main/geom_opt.F90 index 5315e49380..136bc42dff 100644 --- a/src/main/geom_opt.F90 +++ b/src/main/geom_opt.F90 @@ -764,7 +764,7 @@ contains call g_opt%ions%write_xyz('./work-geom', append = .true.) - call scf_mix_clear(g_opt%syst%scf) + 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 diff --git a/src/main/phonons_fd.F90 b/src/main/phonons_fd.F90 index 69d5693f9b..c0b247d2d7 100644 --- a/src/main/phonons_fd.F90 +++ b/src/main/phonons_fd.F90 @@ -220,7 +220,7 @@ contains 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%scf) + call scf_mix_clear(sys) call scf_run(sys, verbosity = VERB_COMPACT) POP_SUB(get_dyn_matrix.run_displacement) diff --git a/src/main/static_pol.F90 b/src/main/static_pol.F90 index d1119e2535..00a071fae8 100644 --- a/src/main/static_pol.F90 +++ b/src/main/static_pol.F90 @@ -308,7 +308,7 @@ contains end if end if - call scf_mix_clear(sys%scf) + call scf_mix_clear(sys) call scf_run(sys, verbosity = verbosity) trrho = M_ZERO @@ -393,7 +393,7 @@ contains end if end if - call scf_mix_clear(sys%scf) + call scf_mix_clear(sys) call scf_run(sys, verbosity = verbosity) trrho = M_ZERO diff --git a/src/scf/scf_interface.F90 b/src/scf/scf_interface.F90 index 01de3dae83..100812c226 100644 --- a/src/scf/scf_interface.F90 +++ b/src/scf/scf_interface.F90 @@ -392,14 +392,14 @@ contains ! --------------------------------------------------------- - module 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 @@ -819,7 +819,7 @@ contains if (mod(iter, sys%scf%smix%ns_restart) == 0) then message(1) = "Info: restarting mixing." call messages_info(1, namespace=sys%namespace) - call scf_mix_clear(sys%scf) + call scf_mix_clear(sys) end if end if end if diff --git a/src/scf/scf_interface_h.F90 b/src/scf/scf_interface_h.F90 index a1532f383c..6016e370ed 100644 --- a/src/scf/scf_interface_h.F90 +++ b/src/scf/scf_interface_h.F90 @@ -32,8 +32,8 @@ module scf_interface_oct_m type(electrons_t), intent(inout) :: sys end subroutine scf_init - module subroutine scf_mix_clear(scf) - type(scf_t), intent(inout) :: scf + 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, restart_load, restart_dump) -- GitLab From ae8a7a150eb1daf371867de6713ce4ddec2a1fd7 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 23 Apr 2024 22:10:01 +0200 Subject: [PATCH 41/72] scf_end: Change signature Signed-off-by: Cristian Le --- src/electrons/electrons.F90 | 2 +- src/main/geom_opt.F90 | 2 +- src/main/phonons_fd.F90 | 2 +- src/main/static_pol.F90 | 2 +- src/scf/electrons_ground_state.F90 | 2 +- src/scf/scf_interface.F90 | 14 +++++++------- src/scf/scf_interface_h.F90 | 4 ++-- src/td/td_interface.F90 | 2 +- 8 files changed, 15 insertions(+), 15 deletions(-) diff --git a/src/electrons/electrons.F90 b/src/electrons/electrons.F90 index 8d5c9ef5be..b0c7372b44 100644 --- a/src/electrons/electrons.F90 +++ b/src/electrons/electrons.F90 @@ -635,7 +635,7 @@ contains done = .false. case (BOMD_FINISH) - call scf_end(this%scf) + call scf_end(this) case (EXPMID_FINISH, AETRS_FINISH) case default diff --git a/src/main/geom_opt.F90 b/src/main/geom_opt.F90 index 136bc42dff..ca069abc11 100644 --- a/src/main/geom_opt.F90 +++ b/src/main/geom_opt.F90 @@ -246,7 +246,7 @@ contains call g_opt%ions%write_xyz('./min') SAFE_DEALLOCATE_A(coords) - call scf_end(sys%scf) + 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 sys%scf%criterion_list%empty() call end_() diff --git a/src/main/phonons_fd.F90 b/src/main/phonons_fd.F90 index c0b247d2d7..002957bf4c 100644 --- a/src/main/phonons_fd.F90 +++ b/src/main/phonons_fd.F90 @@ -203,7 +203,7 @@ contains end do SAFE_DEALLOCATE_A(forces0) SAFE_DEALLOCATE_A(forces) - call scf_end(sys%scf) + call scf_end(sys) call vibrations_symmetrize_dyn_matrix(vib) call vibrations_diag_dyn_matrix(vib) diff --git a/src/main/static_pol.F90 b/src/main/static_pol.F90 index 00a071fae8..265c715d25 100644 --- a/src/main/static_pol.F90 +++ b/src/main/static_pol.F90 @@ -436,7 +436,7 @@ contains end if if (.not. fromScratch) call restart_end(restart_load) - call scf_end(sys%scf) + call scf_end(sys) call output_end_() call born_charges_end(born_charges) diff --git a/src/scf/electrons_ground_state.F90 b/src/scf/electrons_ground_state.F90 index 837b5c9acd..c53ab6fdf3 100644 --- a/src/scf/electrons_ground_state.F90 +++ b/src/scf/electrons_ground_state.F90 @@ -152,7 +152,7 @@ contains end if end if - call scf_end(sys%scf) + call scf_end(sys) end if if (restart_init_dump) then diff --git a/src/scf/scf_interface.F90 b/src/scf/scf_interface.F90 index 100812c226..1060fdd6a6 100644 --- a/src/scf/scf_interface.F90 +++ b/src/scf/scf_interface.F90 @@ -365,23 +365,23 @@ contains ! --------------------------------------------------------- - module 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) diff --git a/src/scf/scf_interface_h.F90 b/src/scf/scf_interface_h.F90 index 6016e370ed..38c09e5b87 100644 --- a/src/scf/scf_interface_h.F90 +++ b/src/scf/scf_interface_h.F90 @@ -45,8 +45,8 @@ module scf_interface_oct_m type(restart_t), optional, intent(in) :: restart_dump end subroutine scf_run - module subroutine scf_end(scf) - type(scf_t), intent(inout) :: scf + module subroutine scf_end(sys) + type(electrons_t), intent(inout) :: sys end subroutine scf_end module subroutine scf_state_info(namespace, st) diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index d7181fe444..a53146fc4f 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -433,7 +433,7 @@ contains call propagator_elec_end(sys%td%tr) ! clean the evolution method call ion_dynamics_end(sys%td%ions_dyn) - if (sys%td%dynamics == BO) call scf_end(sys%scf) + if (sys%td%dynamics == BO) call scf_end(sys) POP_SUB(td_end) end subroutine td_end -- GitLab From 9b29acfa917260baee8c73e97900261eebbb5b2d Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Tue, 23 Apr 2024 22:12:13 +0200 Subject: [PATCH 42/72] scf_state_info: Change signature Signed-off-by: Cristian Le --- src/scf/electrons_ground_state.F90 | 2 +- src/scf/scf_interface.F90 | 9 ++++----- src/scf/scf_interface_h.F90 | 5 ++--- src/scf/unocc.F90 | 2 +- 4 files changed, 8 insertions(+), 10 deletions(-) diff --git a/src/scf/electrons_ground_state.F90 b/src/scf/electrons_ground_state.F90 index c53ab6fdf3..af9750665a 100644 --- a/src/scf/electrons_ground_state.F90 +++ b/src/scf/electrons_ground_state.F90 @@ -124,7 +124,7 @@ contains end if ! run self-consistency - call scf_state_info(sys%namespace, sys%st) + call scf_state_info(sys) if (sys%st%pack_states .and. sys%hm%apply_packed()) then call sys%st%pack() diff --git a/src/scf/scf_interface.F90 b/src/scf/scf_interface.F90 index 1060fdd6a6..57a68d9023 100644 --- a/src/scf/scf_interface.F90 +++ b/src/scf/scf_interface.F90 @@ -1245,18 +1245,17 @@ contains end subroutine scf_run ! --------------------------------------------------------- - module 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) diff --git a/src/scf/scf_interface_h.F90 b/src/scf/scf_interface_h.F90 index 38c09e5b87..9188cc8b8b 100644 --- a/src/scf/scf_interface_h.F90 +++ b/src/scf/scf_interface_h.F90 @@ -49,9 +49,8 @@ module scf_interface_oct_m type(electrons_t), intent(inout) :: sys end subroutine scf_end - module 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 end subroutine scf_state_info module subroutine scf_print_mem_use(namespace) diff --git a/src/scf/unocc.F90 b/src/scf/unocc.F90 index 9318ddf103..f5d55f5b33 100644 --- a/src/scf/unocc.F90 +++ b/src/scf/unocc.F90 @@ -231,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 -- GitLab From d4a64370097b4111822902698028f583511f0a70 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Wed, 15 May 2024 18:00:29 +0200 Subject: [PATCH 43/72] [Debug] Avoid experimental message Temporarily disabling in order to run tests Signed-off-by: Cristian Le --- src/multisystem/system.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/multisystem/system.F90 b/src/multisystem/system.F90 index 2c8faaa7de..0356afb771 100644 --- a/src/multisystem/system.F90 +++ b/src/multisystem/system.F90 @@ -635,7 +635,7 @@ contains PUSH_SUB(system_init_algorithm) - call messages_experimental('Multi-system framework') +! call messages_experimental('Multi-system framework') this%algo => factory%create(this) -- GitLab From 19f8ef8954d64c6120fb89d66043d9fb42d13c75 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Wed, 24 Apr 2024 14:46:56 +0200 Subject: [PATCH 44/72] Move restart_load/dump into scf_t Signed-off-by: Cristian Le --- src/main/geom_opt.F90 | 18 ++++++++------- src/scf/electrons_ground_state.F90 | 27 ++++++++-------------- src/scf/scf_h.F90 | 4 ++++ src/scf/scf_interface.F90 | 36 ++++++++++++++---------------- src/scf/scf_interface_h.F90 | 4 +--- 5 files changed, 41 insertions(+), 48 deletions(-) diff --git a/src/main/geom_opt.F90 b/src/main/geom_opt.F90 index ca069abc11..7d1400c1f2 100644 --- a/src/main/geom_opt.F90 +++ b/src/main/geom_opt.F90 @@ -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) @@ -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) @@ -781,7 +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%syst, 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/scf/electrons_ground_state.F90 b/src/scf/electrons_ground_state.F90 index af9750665a..4085679a8b 100644 --- a/src/scf/electrons_ground_state.F90 +++ b/src/scf/electrons_ground_state.F90 @@ -48,7 +48,6 @@ contains type(electrons_t), intent(inout) :: sys logical, intent(inout) :: fromScratch - type(restart_t) :: restart_load, restart_dump integer :: ierr type(rdm_t) :: rdm logical :: restart_init_dump @@ -83,10 +82,11 @@ contains if (.not. fromScratch) then ! load wavefunctions ! in RDMFT we need the full ground state - 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, & exact = (sys%ks%theory_level == RDMFT)) if (ierr == 0) then - call states_elec_load(restart_load, sys%namespace, sys%space, sys%st, sys%gr, sys%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 @@ -120,7 +120,8 @@ contains end if if (restart_init_dump) then - call restart_init(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) end if ! run self-consistency @@ -134,29 +135,19 @@ contains 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, restart_dump) + 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(sys, outp=sys%outp, restart_load=restart_load, restart_dump=restart_dump) - else - call scf_run(sys, outp=sys%outp, restart_load=restart_load) - end if - call restart_end(restart_load) - else - if (restart_init_dump) then - call scf_run(sys, outp=sys%outp, restart_dump=restart_dump) - else - call scf_run(sys, outp=sys%outp) - end if + call restart_end(sys%scf%restart_load) end if 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 (sys%st%pack_states .and. sys%hm%apply_packed()) then diff --git a/src/scf/scf_h.F90 b/src/scf/scf_h.F90 index 920eda90d0..60361e0417 100644 --- a/src/scf/scf_h.F90 +++ b/src/scf/scf_h.F90 @@ -5,6 +5,7 @@ module scf_oct_m use global_oct_m use lda_u_mixer_oct_m use mix_oct_m + use restart_oct_m implicit none @@ -43,5 +44,8 @@ module scf_oct_m 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_interface.F90 b/src/scf/scf_interface.F90 index 57a68d9023..facdb32ab7 100644 --- a/src/scf/scf_interface.F90 +++ b/src/scf/scf_interface.F90 @@ -406,13 +406,11 @@ contains ! --------------------------------------------------------- - module subroutine scf_run(sys, outp, verbosity, iters_done, restart_load, restart_dump) + 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 @@ -466,10 +464,10 @@ contains 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, sys%space, sys%st, sys%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=sys%namespace) @@ -477,15 +475,15 @@ contains 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. sys%ks%oep%level /= OEP_LEVEL_FULL) then + 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, sys%hm, sys%space, sys%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=sys%namespace) @@ -502,9 +500,9 @@ contains end if end if - if (restart_has_flag(restart_load, RESTART_FLAG_MIX)) then + 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, restart_load, sys%scf%smix, sys%space, sys%gr, ierr) + 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." @@ -513,7 +511,7 @@ contains end if if(sys%hm%lda_u_level /= DFT_U_NONE) then - call lda_u_load(restart_load, sys%hm%lda_u, sys%st, sys%hm%energy%dft_u, ierr) + 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=sys%namespace) @@ -736,26 +734,26 @@ contains 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 == sys%scf%max_iter .or. sys%scf%forced_finish) ) then - call states_elec_dump(restart_dump, sys%space, sys%st, sys%gr, sys%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=sys%namespace) end if - call states_elec_dump_rho(restart_dump, sys%space, sys%st, sys%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=sys%namespace) end if if(sys%hm%lda_u_level /= DFT_U_NONE) then - call lda_u_dump(restart_dump, sys%namespace, sys%hm%lda_u, sys%st, sys%gr, ierr) + 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=sys%namespace) @@ -764,19 +762,19 @@ contains select case (sys%scf%mix_field) case (OPTION__MIXFIELD__DENSITY) - call mix_dump(sys%namespace, restart_dump, sys%scf%smix, sys%space, sys%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=sys%namespace) end if case (OPTION__MIXFIELD__POTENTIAL) - call hamiltonian_elec_dump_vhxc(restart_dump, sys%hm, sys%space, sys%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=sys%namespace) end if - call mix_dump(sys%namespace, restart_dump, sys%scf%smix, sys%space, sys%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=sys%namespace) diff --git a/src/scf/scf_interface_h.F90 b/src/scf/scf_interface_h.F90 index 9188cc8b8b..973a5f4d62 100644 --- a/src/scf/scf_interface_h.F90 +++ b/src/scf/scf_interface_h.F90 @@ -36,13 +36,11 @@ module scf_interface_oct_m type(electrons_t), intent(inout) :: sys end subroutine scf_mix_clear - module subroutine scf_run(sys, outp, verbosity, iters_done, restart_load, restart_dump) + 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 end subroutine scf_run module subroutine scf_end(sys) -- GitLab From e58066f5e55a384a99853fa66030ceb127359b16 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 19:30:09 +0200 Subject: [PATCH 45/72] td_interface: use system's output_write Signed-off-by: Cristian Le --- src/td/td_interface.F90 | 18 ++++-------------- 1 file changed, 4 insertions(+), 14 deletions(-) diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index a53146fc4f..a55082f5e6 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -519,8 +519,7 @@ contains sys%hm%kpoints, sys%ext_partners, stopping) end if - call td_write_iter(sys%td%write_handler, sys%namespace, sys%space, sys%outp, sys%gr, sys%st, sys%hm, & - sys%ions, sys%ext_partners, sys%hm%kick, sys%ks, sys%td%dt, iter, sys%mc, sys%td%recalculate_gs) + call sys%output_write() ! write down data call td_check_point(sys, iter, scsteps, etime, stopping, from_scratch) @@ -531,6 +530,8 @@ contains call profiling_out("TIME_STEP") if (stopping) exit + sys%iteration = sys%iteration + 1 + end do propagation POP_SUB(td_run) @@ -564,11 +565,6 @@ contains call td_print_message(sys%td, sys%namespace, sys%ions, sys%hm, iter, scsteps, etime) - if (outp%anything_now(iter)) then ! output - call td_write_output(sys%namespace, sys%space, sys%gr, sys%st, sys%hm, sys%ks, & - sys%outp, sys%ions, sys%ext_partners, iter, sys%td%dt) - end if - if (mod(iter, sys%outp%restart_write_interval) == 0 .or. iter == sys%td%max_iter .or. stopping) then ! restart !if (iter == sys%td%max_iter) sys%outp%iter = ii - 1 call td_write_data(sys%td%write_handler) @@ -858,7 +854,7 @@ contains end if !call td_check_trotter(sys%td, sys, h) - sys%td%iter = sys%td%iter + 1 +! sys%td%iter = sys%td%iter + 1 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 @@ -1005,10 +1001,6 @@ contains PUSH_SUB(td_run_zero_iter) - call td_write_iter(sys%td%write_handler, sys%namespace, sys%space, & - sys%outp, sys%gr, sys%st, sys%hm, sys%ions, sys%ext_partners, & - sys%hm%kick, sys%ks, sys%td%dt, 0, sys%mc, sys%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(sys%hm%kick%time) <= M_EPSILON) then @@ -1029,8 +1021,6 @@ contains 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) - call td_write_output(sys%namespace, sys%space, sys%gr, sys%st, sys%hm, & - sys%ks, sys%outp, sys%ions, sys%ext_partners, 0) end if POP_SUB(td_run_zero_iter) -- GitLab From 32ba53b50d5d040adac97a831c519055b77bb8e9 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 19:42:55 +0200 Subject: [PATCH 46/72] td_interface: use system's restart_write Signed-off-by: Cristian Le --- src/td/td_interface.F90 | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index a55082f5e6..d09e9bf3a5 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -566,17 +566,7 @@ contains call td_print_message(sys%td, sys%namespace, sys%ions, sys%hm, iter, scsteps, etime) if (mod(iter, sys%outp%restart_write_interval) == 0 .or. iter == sys%td%max_iter .or. stopping) then ! restart - !if (iter == sys%td%max_iter) sys%outp%iter = ii - 1 - call td_write_data(sys%td%write_handler) - call td_dump(sys%td, sys%namespace, sys%space, sys%gr, sys%st, sys%hm, sys%ks, & - sys%ext_partners, iter, ierr) - if (ierr /= 0) then - message(1) = "Unable to write time-dependent restart information." - call messages_warning(1, namespace=sys%namespace) - end if - - call pes_output(sys%td%pesv, sys%namespace, sys%space, sys%gr, sys%st, iter, sys%outp, & - sys%td%dt, sys%ions) + call sys%restart_write() 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) -- GitLab From d0a585e5c1844cf9f4e54956d410ba3543657ee3 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 20:52:36 +0200 Subject: [PATCH 47/72] td_interface: use system's restart_read Signed-off-by: Cristian Le --- src/main/time_dependent.F90 | 3 --- src/multisystem/propagator_factory.F90 | 5 ++++- src/td/td_interface.F90 | 28 +++++++++++++++----------- 3 files changed, 20 insertions(+), 16 deletions(-) diff --git a/src/main/time_dependent.F90 b/src/main/time_dependent.F90 index e2343b86a5..f68bd04787 100644 --- a/src/main/time_dependent.F90 +++ b/src/main/time_dependent.F90 @@ -132,11 +132,8 @@ contains PUSH_SUB(time_dependent_run_legacy) - call td_init(electrons) call td_init_run(electrons, from_scratch) call td_run(electrons, from_scratch) - call td_end_run(electrons) - call td_end(electrons) POP_SUB(time_dependent_run_legacy) end subroutine time_dependent_run_legacy diff --git a/src/multisystem/propagator_factory.F90 b/src/multisystem/propagator_factory.F90 index 264dca5b5d..25a1c6b090 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/td/td_interface.F90 b/src/td/td_interface.F90 index d09e9bf3a5..d4d67208a0 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -55,6 +55,7 @@ submodule (td_interface_oct_m) impl use potential_interpolation_oct_m use profiling_oct_m use propagator_elec_oct_m + use propagator_factory_oct_m use propagator_oct_m use restart_oct_m use scf_interface_oct_m @@ -327,23 +328,30 @@ contains 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(sys%td, sys%namespace, sys%mc, sys%gr, sys%ions, sys%st, sys%hm, sys%space) - call td_init_gaugefield(sys%td, sys%namespace, sys%gr, sys%st, sys%ks, sys%hm, sys%ext_partners, sys%space) + call sys%init_algorithm(propagator_factory_t(sys%namespace)) sys%td%from_scratch = from_scratch + restart_read = .false. + call sys%init_iteration_counters() if (.not. sys%td%from_scratch) then - call td_load_restart_from_td(sys%td, sys%namespace, sys%space, sys%mc, sys%gr, sys%ext_partners, sys%st, sys%ks, sys%hm, sys%td%from_scratch) - if (sys%td%from_scratch) then - message(1) = "Unable to read time-dependent restart information: Starting from scratch" - call messages_warning(1, namespace=sys%namespace) - end if + restart_read = sys%restart_read() + end if + + 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 @@ -356,11 +364,7 @@ contains return end if - if (sys%td%from_scratch) then - call td_load_restart_from_gs(sys%td, sys%namespace, sys%space, sys%mc, sys%gr, sys%ext_partners, sys%st, sys%ks, sys%hm) - end if - - call td_init_with_wavefunctions(sys) + call sys%propagation_start() POP_SUB(td_init_run) end subroutine td_init_run -- GitLab From cd4471dd6d12653030872f550d346097d71b2a66 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Wed, 15 May 2024 17:00:02 +0200 Subject: [PATCH 48/72] Call base system_output_write Signed-off-by: Cristian Le --- src/electrons/electrons.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/electrons/electrons.F90 b/src/electrons/electrons.F90 index b0c7372b44..70d444baec 100644 --- a/src/electrons/electrons.F90 +++ b/src/electrons/electrons.F90 @@ -759,6 +759,8 @@ 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 -- GitLab From 4977d778be5384be7d3105a5ddfea76201f9ee7c Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 14:18:03 +0200 Subject: [PATCH 49/72] linked_list: Add more interface Signed-off-by: Cristian Le --- src/basic/linked_list.F90 | 220 +++++++++++++++++++++++++++++++++++--- src/basic/list_node.F90 | 32 +++++- 2 files changed, 232 insertions(+), 20 deletions(-) diff --git a/src/basic/linked_list.F90 b/src/basic/linked_list.F90 index 277a4891c9..8f7501bf02 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 @@ -231,15 +328,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 +372,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 +416,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 8d9459d6ad..7c10655bbe 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 -- GitLab From 2ede360bc6e8397d7e87d5a9f76c23f86b86d444 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 17 Jul 2023 19:07:45 +0200 Subject: [PATCH 50/72] linked_list: Simplify empty deallocation Signed-off-by: Cristian Le --- src/basic/linked_list.F90 | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/basic/linked_list.F90 b/src/basic/linked_list.F90 index 8f7501bf02..cb4a36d00a 100644 --- a/src/basic/linked_list.F90 +++ b/src/basic/linked_list.F90 @@ -303,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 -- GitLab From 083aa92a5b4fbee071901b58f894ce900227c666 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 14:18:39 +0200 Subject: [PATCH 51/72] mest_function: Add more interface Signed-off-by: Cristian Le --- src/grid/mesh_function.F90 | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/grid/mesh_function.F90 b/src/grid/mesh_function.F90 index d1d68f323d..8e04c1d122 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, & @@ -89,6 +90,11 @@ 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 dmf_dotp module procedure dmf_dotp_1, dmf_dotp_2 end interface dmf_dotp @@ -97,6 +103,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 -- GitLab From bc3f6743fe2ae7bedfe8e4dd290dbfafac22c02b Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 14:32:44 +0200 Subject: [PATCH 52/72] system_base: Add more init/end functions Signed-off-by: Cristian Le --- src/classical/classical_particles.F90 | 2 +- src/dftbplus/dftb.F90 | 2 +- src/electrons/electrons.F90 | 4 +++- src/maxwell/dispersive_medium.F90 | 2 +- src/maxwell/linear_medium.F90 | 2 +- src/maxwell/maxwell.F90 | 2 +- src/multisystem/multisystem.F90 | 2 +- src/multisystem/system.F90 | 12 ++++++++++++ src/multisystem/system_h.F90 | 26 +++++++++++++++++++++++++- src/scf/electrons_ground_state.F90 | 3 +++ src/td/td_interface.F90 | 2 ++ 11 files changed, 51 insertions(+), 8 deletions(-) diff --git a/src/classical/classical_particles.F90 b/src/classical/classical_particles.F90 index 877862c21f..3472c06438 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 a962eb7b31..15afa4fa08 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/electrons.F90 b/src/electrons/electrons.F90 index 70d444baec..fbbd85df1a 100644 --- a/src/electrons/electrons.F90 +++ b/src/electrons/electrons.F90 @@ -101,6 +101,8 @@ contains allocate(sys) + call sys%system_init() + sys%namespace = namespace call messages_obsolete_variable(sys%namespace, 'SystemName') @@ -1055,7 +1057,7 @@ contains call grid_end(sys%gr) - call system_end(sys) + call sys%system_end() POP_SUB(electrons_finalize) contains diff --git a/src/maxwell/dispersive_medium.F90 b/src/maxwell/dispersive_medium.F90 index e116d0b016..bcd6b46943 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/linear_medium.F90 b/src/maxwell/linear_medium.F90 index 50dddef5d2..d59bd2c2fc 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 6fe73c6241..6250d0d742 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/multisystem.F90 b/src/multisystem/multisystem.F90 index 2081322c1a..02b31f1a77 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/system.F90 b/src/multisystem/system.F90 index 0356afb771..c95e29c13d 100644 --- a/src/multisystem/system.F90 +++ b/src/multisystem/system.F90 @@ -1075,6 +1075,18 @@ contains POP_SUB(system_update_total_energy) end subroutine system_update_total_energy + module subroutine system_init(this) + class(system_t), target, intent(inout) :: this + + ! Do nothing + end subroutine system_init + + module subroutine system_post_init(this) + class(system_t), intent(inout) :: this + + ! Do nothing + end subroutine system_post_init + end submodule impl !! Local Variables: diff --git a/src/multisystem/system_h.F90 b/src/multisystem/system_h.F90 index 709db1a6bc..e392173f81 100644 --- a/src/multisystem/system_h.F90 +++ b/src/multisystem/system_h.F90 @@ -27,7 +27,6 @@ module system_oct_m system_restart_write, & system_update_potential_energy, & system_update_total_energy, & - system_end, & system_list_t, & system_iterator_t @@ -60,6 +59,10 @@ module system_oct_m 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 @@ -188,6 +191,27 @@ module system_oct_m ! 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 diff --git a/src/scf/electrons_ground_state.F90 b/src/scf/electrons_ground_state.F90 index 4085679a8b..00ea732a78 100644 --- a/src/scf/electrons_ground_state.F90 +++ b/src/scf/electrons_ground_state.F90 @@ -109,6 +109,9 @@ contains restart_init_dump = .true. end if + ! 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 diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index d4d67208a0..d5db830262 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -366,6 +366,8 @@ contains call sys%propagation_start() + call sys%post_init() + POP_SUB(td_init_run) end subroutine td_init_run -- GitLab From 6ca35347a601fbf03ad166f669a8de8a4fa8a353 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 14:38:22 +0200 Subject: [PATCH 53/72] system_base: hamiltonian_abst add constructor/destructors Signed-off-by: Cristian Le --- src/hamiltonian/CMakeLists.txt | 1 + src/hamiltonian/hamiltonian_abst.F90 | 27 ++++++++++++++++++++ src/hamiltonian/hamiltonian_abst_h.F90 | 35 ++++++++++++++++++++------ src/hamiltonian/hamiltonian_elec.F90 | 5 ++++ src/maxwell/hamiltonian_mxll.F90 | 4 +++ 5 files changed, 64 insertions(+), 8 deletions(-) create mode 100644 src/hamiltonian/hamiltonian_abst.F90 diff --git a/src/hamiltonian/CMakeLists.txt b/src/hamiltonian/CMakeLists.txt index b72bbeac07..b58f115986 100644 --- a/src/hamiltonian/CMakeLists.txt +++ b/src/hamiltonian/CMakeLists.txt @@ -6,6 +6,7 @@ target_sources(Octopus_lib PRIVATE exchange_operator.F90 ext_partner_list.F90 gauge_field.F90 + hamiltonian_abst.F90 hamiltonian_abst_h.F90 hamiltonian_elec.F90 hamiltonian_elec_base.F90 diff --git a/src/hamiltonian/hamiltonian_abst.F90 b/src/hamiltonian/hamiltonian_abst.F90 new file mode 100644 index 0000000000..a281a5645c --- /dev/null +++ b/src/hamiltonian/hamiltonian_abst.F90 @@ -0,0 +1,27 @@ +#include "global.h" + +submodule (hamiltonian_abst_oct_m) hamiltonian_abst_impl + use global_oct_m + use messages_oct_m + use profiling_oct_m + implicit none + +contains + module subroutine hamiltonian_abst_init(this) + class(hamiltonian_abst_t), target, intent(inout) :: this + + ! Do nothing + end subroutine + + module subroutine hamiltonian_abst_post_init(this) + class(hamiltonian_abst_t), intent(inout) :: this + + ! Do nothing + end subroutine + + module subroutine hamiltonian_abst_end(this) + class(hamiltonian_abst_t), intent(inout) :: this + + ! Do nothing + end subroutine +end submodule hamiltonian_abst_impl diff --git a/src/hamiltonian/hamiltonian_abst_h.F90 b/src/hamiltonian/hamiltonian_abst_h.F90 index 8e3976d228..dac6dfa6c1 100644 --- a/src/hamiltonian/hamiltonian_abst_h.F90 +++ b/src/hamiltonian/hamiltonian_abst_h.F90 @@ -32,17 +32,22 @@ module hamiltonian_abst_oct_m !> @brief The abstract Hamiltonian class defines a skeleton for specific implementations type, abstract, public :: hamiltonian_abst_t + private !> Spectral range - real(real64) :: spectral_middle_point - real(real64) :: spectral_half_span + real(real64), public :: spectral_middle_point + real(real64), public :: 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 + 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(dhamiltonian_apply), deferred, public :: dapply !< @copydoc dhamiltonian_apply + procedure(zhamiltonian_apply), deferred, public :: zapply !< @copydoc zhamiltonian_apply + procedure(dhamiltonian_magnus_apply), deferred, public :: dmagnus_apply !< @copydoc dhamiltonian_magnus_apply + procedure(zhamiltonian_magnus_apply), deferred, public :: zmagnus_apply !< @copydoc zhamiltonian_magnus_apply end type hamiltonian_abst_t abstract interface @@ -102,6 +107,20 @@ module hamiltonian_abst_oct_m end subroutine zhamiltonian_magnus_apply end interface + interface + 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 diff --git a/src/hamiltonian/hamiltonian_elec.F90 b/src/hamiltonian/hamiltonian_elec.F90 index 3db64544fc..3c1d3da13e 100644 --- a/src/hamiltonian/hamiltonian_elec.F90 +++ b/src/hamiltonian/hamiltonian_elec.F90 @@ -79,8 +79,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 @@ -568,6 +571,8 @@ contains call mxll_coupling_end(hm%mxll) + call hm%hamiltonian_abst_end() + POP_SUB(hamiltonian_elec_end) end subroutine hamiltonian_elec_end diff --git a/src/maxwell/hamiltonian_mxll.F90 b/src/maxwell/hamiltonian_mxll.F90 index 62774d567d..1c87265d43 100644 --- a/src/maxwell/hamiltonian_mxll.F90 +++ b/src/maxwell/hamiltonian_mxll.F90 @@ -50,6 +50,8 @@ contains call profiling_in('HAMILTONIAN_INIT') + call hm%hamiltonian_abst_init() + hm%dim = st%dim hm%st => st @@ -161,6 +163,8 @@ contains call profiling_out("HAMILTONIAN_MXLL_END") + call hm%hamiltonian_abst_end() + POP_SUB(hamiltonian_mxll_end) end subroutine hamiltonian_mxll_end -- GitLab From feed01e73b61c068ca2a0e4793d0b7090b94805e Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 14:48:36 +0200 Subject: [PATCH 54/72] system_base: electrons post_init Signed-off-by: Cristian Le --- src/electrons/electrons.F90 | 7 +++++++ src/electrons/electrons_h.F90 | 6 ++++++ 2 files changed, 13 insertions(+) diff --git a/src/electrons/electrons.F90 b/src/electrons/electrons.F90 index fbbd85df1a..995b967c24 100644 --- a/src/electrons/electrons.F90 +++ b/src/electrons/electrons.F90 @@ -1075,6 +1075,13 @@ contains end subroutine deallocate_ext_partners end subroutine electrons_finalize + 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: diff --git a/src/electrons/electrons_h.F90 b/src/electrons/electrons_h.F90 index 56d8d402d6..bb0157451e 100644 --- a/src/electrons/electrons_h.F90 +++ b/src/electrons/electrons_h.F90 @@ -73,6 +73,7 @@ module electrons_oct_m 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 @@ -98,6 +99,11 @@ module electrons_oct_m 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 -- GitLab From 738f90ab1ba1e83e284255c6ffd903ed6ab1b66a Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 14:50:22 +0200 Subject: [PATCH 55/72] Change propagator_elec_dt interface Signed-off-by: Cristian Le --- src/opt_control/propagation.F90 | 20 ++++++++++---------- src/td/propagator_elec.F90 | 3 ++- src/td/propagator_elec_h.F90 | 3 ++- src/td/td_interface.F90 | 2 +- 4 files changed, 15 insertions(+), 13 deletions(-) diff --git a/src/opt_control/propagation.F90 b/src/opt_control/propagation.F90 index 5d5e59344d..d66081e077 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/td/propagator_elec.F90 b/src/td/propagator_elec.F90 index 98631a5d6d..321e335e2f 100644 --- a/src/td/propagator_elec.F90 +++ b/src/td/propagator_elec.F90 @@ -430,8 +430,9 @@ contains !> Propagates st from time - dt to t. !! If dt<0, it propagates *backwards* from t+|dt| to t ! --------------------------------------------------------- - module 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 diff --git a/src/td/propagator_elec_h.F90 b/src/td/propagator_elec_h.F90 index 851e46c825..118ea9ee04 100644 --- a/src/td/propagator_elec_h.F90 +++ b/src/td/propagator_elec_h.F90 @@ -66,8 +66,9 @@ module propagator_elec_oct_m type(propagator_base_t), intent(inout) :: tr end subroutine propagator_elec_run_zero_iter - module 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 diff --git a/src/td/td_interface.F90 b/src/td/td_interface.F90 index d5db830262..b0b02d2aae 100644 --- a/src/td/td_interface.F90 +++ b/src/td/td_interface.F90 @@ -502,7 +502,7 @@ contains ! time iterate the system, one time step. select case (sys%td%dynamics) case (EHRENFEST) - call propagator_elec_dt(sys%ks, sys%namespace, sys%space, sys%hm, sys%gr, sys%st, sys%td%tr, & + 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)) -- GitLab From e93e7c142fbbedc320afa3c0010b036f096d2cc0 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 14:53:08 +0200 Subject: [PATCH 56/72] system_base: Move hamiltonian apply to abstract interface Signed-off-by: Cristian Le --- src/hamiltonian/hamiltonian_abst.F90 | 46 ++++++++++++++++++++++++++ src/hamiltonian/hamiltonian_abst_h.F90 | 32 +++++++++--------- src/hamiltonian/hamiltonian_elec_h.F90 | 8 ++--- src/maxwell/hamiltonian_mxll_h.F90 | 8 ++--- 4 files changed, 70 insertions(+), 24 deletions(-) diff --git a/src/hamiltonian/hamiltonian_abst.F90 b/src/hamiltonian/hamiltonian_abst.F90 index a281a5645c..148f2695a0 100644 --- a/src/hamiltonian/hamiltonian_abst.F90 +++ b/src/hamiltonian/hamiltonian_abst.F90 @@ -24,4 +24,50 @@ contains ! Do nothing 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 + + call hm%dapply_impl(namespace, mesh, psib, hpsib, terms, 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 + + call hm%zapply_impl(namespace, mesh, psib, hpsib, terms, 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(:, :, :) + + call hm%dmagnus_apply_impl(namespace, mesh, psib, hpsib, 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(:, :, :) + + call hm%zmagnus_apply_impl(namespace, mesh, psib, hpsib, vmagnus) + 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 index dac6dfa6c1..30224581c2 100644 --- a/src/hamiltonian/hamiltonian_abst_h.F90 +++ b/src/hamiltonian/hamiltonian_abst_h.F90 @@ -42,12 +42,16 @@ module hamiltonian_abst_oct_m 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(dhamiltonian_apply), deferred, public :: dapply !< @copydoc dhamiltonian_apply - procedure(zhamiltonian_apply), deferred, public :: zapply !< @copydoc zhamiltonian_apply - procedure(dhamiltonian_magnus_apply), deferred, public :: dmagnus_apply !< @copydoc dhamiltonian_magnus_apply - procedure(zhamiltonian_magnus_apply), deferred, public :: zmagnus_apply !< @copydoc zhamiltonian_magnus_apply + 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 @@ -63,9 +67,10 @@ module hamiltonian_abst_oct_m real(real64), intent(in) :: emin type(namespace_t), intent(in) :: namespace end subroutine hamiltonian_update_span + end interface - subroutine dhamiltonian_apply(hm, namespace, mesh, psib, hpsib, terms, set_bc) - import + 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 @@ -75,8 +80,7 @@ module hamiltonian_abst_oct_m logical, optional, intent(in) :: set_bc end subroutine dhamiltonian_apply - subroutine zhamiltonian_apply(hm, namespace, mesh, psib, hpsib, terms, set_bc) - import + 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 @@ -86,8 +90,7 @@ module hamiltonian_abst_oct_m logical, optional, intent(in) :: set_bc end subroutine zhamiltonian_apply - subroutine dhamiltonian_magnus_apply(hm, namespace, mesh, psib, hpsib, vmagnus) - import + 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 @@ -96,8 +99,7 @@ module hamiltonian_abst_oct_m real(real64), intent(in) :: vmagnus(:, :, :) end subroutine dhamiltonian_magnus_apply - subroutine zhamiltonian_magnus_apply(hm, namespace, mesh, psib, hpsib, vmagnus) - import + 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 @@ -105,9 +107,7 @@ module hamiltonian_abst_oct_m class(batch_t), intent(inout) :: hpsib real(real64), intent(in) :: vmagnus(:, :, :) end subroutine zhamiltonian_magnus_apply - end interface - interface module subroutine hamiltonian_abst_init(this) class(hamiltonian_abst_t), target, intent(inout) :: this end subroutine diff --git a/src/hamiltonian/hamiltonian_elec_h.F90 b/src/hamiltonian/hamiltonian_elec_h.F90 index bf15740e4f..cb59793fc6 100644 --- a/src/hamiltonian/hamiltonian_elec_h.F90 +++ b/src/hamiltonian/hamiltonian_elec_h.F90 @@ -163,10 +163,10 @@ module hamiltonian_elec_oct_m 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 :: 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 diff --git a/src/maxwell/hamiltonian_mxll_h.F90 b/src/maxwell/hamiltonian_mxll_h.F90 index e4b90ec990..387c94ece0 100644 --- a/src/maxwell/hamiltonian_mxll_h.F90 +++ b/src/maxwell/hamiltonian_mxll_h.F90 @@ -108,10 +108,10 @@ module hamiltonian_mxll_oct_m 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 :: 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 -- GitLab From 6a71e1035aa517dca688ab250ace6426306cf909 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 15 Jan 2024 14:25:29 +0100 Subject: [PATCH 57/72] [interface] Add io_function interface Signed-off-by: Cristian Le --- src/grid/io_function.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/grid/io_function.F90 b/src/grid/io_function.F90 index 6ee3531d6e..4fad9f9763 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 -- GitLab From d10d14575693481adab59929e6219b678bc1d925 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 7 Aug 2023 14:38:01 +0200 Subject: [PATCH 58/72] [interface] Add mesh function interface Signed-off-by: Cristian Le --- src/grid/mesh_function.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/grid/mesh_function.F90 b/src/grid/mesh_function.F90 index 8e04c1d122..b20e217612 100644 --- a/src/grid/mesh_function.F90 +++ b/src/grid/mesh_function.F90 @@ -69,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 @@ -95,6 +96,10 @@ module mesh_function_oct_m 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 -- GitLab From 229086225a5fccf102571895146573099f3179df Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 15 Jan 2024 14:26:22 +0100 Subject: [PATCH 59/72] [export] messages_get_unit Signed-off-by: Cristian Le --- src/basic/messages.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/basic/messages.F90 b/src/basic/messages.F90 index f344fa7cbe..f0199bbd84 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, & -- GitLab From 77b2b12adecfc4f1a818394e92e0c3e17b006309 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 14:03:29 +0200 Subject: [PATCH 60/72] Add fortran_stdlib Signed-off-by: Cristian Le --- .gitmodules | 3 +++ CMakeLists.txt | 5 +++++ src/basic/CMakeLists.txt | 1 + third_party/fortran_stdlib | 1 + 4 files changed, 10 insertions(+) create mode 160000 third_party/fortran_stdlib diff --git a/.gitmodules b/.gitmodules index 89c3b98c8c..47e4f90df0 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 9d1b0e5450..2927c1e082 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/basic/CMakeLists.txt b/src/basic/CMakeLists.txt index fdf90ef09c..7526f38680 100644 --- a/src/basic/CMakeLists.txt +++ b/src/basic/CMakeLists.txt @@ -111,6 +111,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/third_party/fortran_stdlib b/third_party/fortran_stdlib new file mode 160000 index 0000000000..2b7280b717 --- /dev/null +++ b/third_party/fortran_stdlib @@ -0,0 +1 @@ +Subproject commit 2b7280b7176f90b07a4ce420aaa794a472eaef7c -- GitLab From c3353ebaa5c38e0c44e5adc65e564f2ad1cea0ac Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 14:03:51 +0200 Subject: [PATCH 61/72] Add dict module Signed-off-by: Cristian Le --- src/basic/CMakeLists.txt | 2 + src/basic/dict.F90 | 170 +++++++++++++++++++++++++++++++++++++++ src/basic/dict_h.F90 | 110 +++++++++++++++++++++++++ 3 files changed, 282 insertions(+) create mode 100644 src/basic/dict.F90 create mode 100644 src/basic/dict_h.F90 diff --git a/src/basic/CMakeLists.txt b/src/basic/CMakeLists.txt index 7526f38680..dbc87ab052 100644 --- a/src/basic/CMakeLists.txt +++ b/src/basic/CMakeLists.txt @@ -13,6 +13,8 @@ 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 diff --git a/src/basic/dict.F90 b/src/basic/dict.F90 new file mode 100644 index 0000000000..ebc7502103 --- /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 0000000000..c82b727fe9 --- /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 -- GitLab From 1df799feb84c159095e3ae79819baaa61c9d04cd Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 15 Jan 2024 14:25:06 +0100 Subject: [PATCH 62/72] Add global_options Signed-off-by: Cristian Le --- src/basic/global.F90 | 2 ++ src/basic/global_h.F90 | 3 +++ src/main/main.F90 | 2 ++ 3 files changed, 7 insertions(+) diff --git a/src/basic/global.F90 b/src/basic/global.F90 index 9ffc7fb5fa..e336461c7e 100644 --- a/src/basic/global.F90 +++ b/src/basic/global.F90 @@ -53,6 +53,8 @@ contains integer :: comm + call global_options%init() + if (present(communicator)) then comm = communicator else diff --git a/src/basic/global_h.F90 b/src/basic/global_h.F90 index fd28c70b26..a452f3bea0 100644 --- a/src/basic/global_h.F90 +++ b/src/basic/global_h.F90 @@ -1,6 +1,7 @@ #include "global.h" module global_oct_m + use dict_oct_m use mpi_oct_m use, intrinsic :: iso_fortran_env @@ -108,6 +109,8 @@ module global_oct_m 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 diff --git a/src/main/main.F90 b/src/main/main.F90 index 604f3a54c4..ee492df1cb 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() -- GitLab From bd86b6a94414399f6e29aad76f49ce24ab4bad32 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 14:19:51 +0200 Subject: [PATCH 63/72] system_extension: add framework Signed-off-by: Cristian Le --- src/CMakeLists.txt | 1 + src/basic/global.F90 | 4 + src/extensions/CMakeLists.txt | 5 + src/extensions/all_system_extensions.F90 | 12 + src/extensions/extension.F90 | 341 +++++++++++++++++++++++ src/extensions/extension_h.F90 | 335 ++++++++++++++++++++++ 6 files changed, 698 insertions(+) create mode 100644 src/extensions/CMakeLists.txt create mode 100644 src/extensions/all_system_extensions.F90 create mode 100644 src/extensions/extension.F90 create mode 100644 src/extensions/extension_h.F90 diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 0fb6035a12..493d12b3b6 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/basic/global.F90 b/src/basic/global.F90 index e336461c7e..1a69fb666f 100644 --- a/src/basic/global.F90 +++ b/src/basic/global.F90 @@ -26,6 +26,7 @@ submodule (global_oct_m) impl #ifdef HAVE_OPENMP use omp_lib #endif + use extension_oct_m implicit none contains @@ -55,6 +56,8 @@ contains call global_options%init() + call init_all_extension_def() + if (present(communicator)) then comm = communicator else @@ -111,6 +114,7 @@ contains call varinfo_end() call mpi_mod_end() + call end_all_extension_def() end subroutine global_end diff --git a/src/extensions/CMakeLists.txt b/src/extensions/CMakeLists.txt new file mode 100644 index 0000000000..96e8b2dfaf --- /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 0000000000..2237805325 --- /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 0000000000..e32c881721 --- /dev/null +++ b/src/extensions/extension.F90 @@ -0,0 +1,341 @@ +#include "global.h" + +submodule (extension_oct_m) impl + 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 + + ! 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 +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 0000000000..095e989865 --- /dev/null +++ b/src/extensions/extension_h.F90 @@ -0,0 +1,335 @@ +module extension_oct_m + use dict_oct_m + 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() + + 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 + !> 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 + 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 -- GitLab From 1d91a807dff232a516b212cbcb2635ea8bd951dd Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 14:54:26 +0200 Subject: [PATCH 64/72] system_extension: Add system extension Signed-off-by: Cristian Le --- src/multisystem/CMakeLists.txt | 2 + src/multisystem/system_extension.F90 | 54 ++++++++++++ src/multisystem/system_extension_h.F90 | 113 +++++++++++++++++++++++++ 3 files changed, 169 insertions(+) create mode 100644 src/multisystem/system_extension.F90 create mode 100644 src/multisystem/system_extension_h.F90 diff --git a/src/multisystem/CMakeLists.txt b/src/multisystem/CMakeLists.txt index 1c30e995de..9442a2f4db 100644 --- a/src/multisystem/CMakeLists.txt +++ b/src/multisystem/CMakeLists.txt @@ -27,6 +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/system_extension.F90 b/src/multisystem/system_extension.F90 new file mode 100644 index 0000000000..b71585cd5d --- /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 0000000000..9d8330b4d6 --- /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 -- GitLab From 79d977f9730514351d169c6416627c805e378f97 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 14:54:52 +0200 Subject: [PATCH 65/72] system_extension: Add hamiltonian extension Signed-off-by: Cristian Le --- src/hamiltonian/CMakeLists.txt | 2 + src/hamiltonian/hamiltonian_extensions.F90 | 58 +++++++++ src/hamiltonian/hamiltonian_extensions_h.F90 | 124 +++++++++++++++++++ 3 files changed, 184 insertions(+) create mode 100644 src/hamiltonian/hamiltonian_extensions.F90 create mode 100644 src/hamiltonian/hamiltonian_extensions_h.F90 diff --git a/src/hamiltonian/CMakeLists.txt b/src/hamiltonian/CMakeLists.txt index b58f115986..869fefb2eb 100644 --- a/src/hamiltonian/CMakeLists.txt +++ b/src/hamiltonian/CMakeLists.txt @@ -11,6 +11,8 @@ target_sources(Octopus_lib PRIVATE 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_extensions.F90 b/src/hamiltonian/hamiltonian_extensions.F90 new file mode 100644 index 0000000000..a6f674a291 --- /dev/null +++ b/src/hamiltonian/hamiltonian_extensions.F90 @@ -0,0 +1,58 @@ +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 + + ! 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 0000000000..908dea2b72 --- /dev/null +++ b/src/hamiltonian/hamiltonian_extensions_h.F90 @@ -0,0 +1,124 @@ +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 + 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 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 + + !> 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 -- GitLab From dbbfc72c09e941e41f19cddba892f713e02ba694 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 14:55:21 +0200 Subject: [PATCH 66/72] system_extension: Add electrons extension Signed-off-by: Cristian Le --- src/electrons/CMakeLists.txt | 2 + src/electrons/electrons_extension.F90 | 56 +++++++++++++++ src/electrons/electrons_extension_h.F90 | 94 +++++++++++++++++++++++++ 3 files changed, 152 insertions(+) create mode 100644 src/electrons/electrons_extension.F90 create mode 100644 src/electrons/electrons_extension_h.F90 diff --git a/src/electrons/CMakeLists.txt b/src/electrons/CMakeLists.txt index d602c56ffb..0ed1f23bf6 100644 --- a/src/electrons/CMakeLists.txt +++ b/src/electrons/CMakeLists.txt @@ -11,6 +11,8 @@ target_sources(Octopus_lib PRIVATE 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_extension.F90 b/src/electrons/electrons_extension.F90 new file mode 100644 index 0000000000..fe30b6b2c7 --- /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 0000000000..3cb3adda76 --- /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 -- GitLab From 1def98d6eba6c33d76a7d1a9f08da578e4710792 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 11 Sep 2023 21:57:14 +0200 Subject: [PATCH 67/72] system_extension: Link system to system_extension Signed-off-by: Cristian Le --- src/multisystem/system.F90 | 108 ++++++++++++++++++++++++++++++++--- src/multisystem/system_h.F90 | 4 ++ 2 files changed, 105 insertions(+), 7 deletions(-) diff --git a/src/multisystem/system.F90 b/src/multisystem/system.F90 index c95e29c13d..10245f24d4 100644 --- a/src/multisystem/system.F90 +++ b/src/multisystem/system.F90 @@ -31,6 +31,7 @@ submodule (system_oct_m) impl 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 @@ -59,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), & @@ -161,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 @@ -830,8 +858,10 @@ contains 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) @@ -840,14 +870,23 @@ 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 @@ -1078,13 +1117,68 @@ contains module subroutine system_init(this) class(system_t), target, intent(inout) :: this - ! Do nothing + 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 - ! Do nothing + 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 diff --git a/src/multisystem/system_h.F90 b/src/multisystem/system_h.F90 index e392173f81..e3c6284e53 100644 --- a/src/multisystem/system_h.F90 +++ b/src/multisystem/system_h.F90 @@ -3,6 +3,8 @@ 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 @@ -46,6 +48,8 @@ module system_oct_m 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 -- GitLab From 48e2511d3728f647e4db3e87a5f4f8adf9b9f583 Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 15:02:43 +0200 Subject: [PATCH 68/72] system_extension: Link hamiltonian_abst to hamiltonian_extension Signed-off-by: Cristian Le --- src/hamiltonian/hamiltonian_abst.F90 | 131 ++++++++++++++++++++++++- src/hamiltonian/hamiltonian_abst_h.F90 | 4 + 2 files changed, 132 insertions(+), 3 deletions(-) diff --git a/src/hamiltonian/hamiltonian_abst.F90 b/src/hamiltonian/hamiltonian_abst.F90 index 148f2695a0..d1da52c32b 100644 --- a/src/hamiltonian/hamiltonian_abst.F90 +++ b/src/hamiltonian/hamiltonian_abst.F90 @@ -2,6 +2,7 @@ submodule (hamiltonian_abst_oct_m) hamiltonian_abst_impl use global_oct_m + use hamiltonian_extensions_oct_m use messages_oct_m use profiling_oct_m implicit none @@ -10,19 +11,35 @@ contains module subroutine hamiltonian_abst_init(this) class(hamiltonian_abst_t), target, intent(inout) :: this - ! Do nothing + call this%context%init() end subroutine module subroutine hamiltonian_abst_post_init(this) class(hamiltonian_abst_t), intent(inout) :: this - ! Do nothing + 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 - ! Do nothing + 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) @@ -34,7 +51,34 @@ contains 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) @@ -46,7 +90,34 @@ contains 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) @@ -57,7 +128,34 @@ contains 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) @@ -68,6 +166,33 @@ contains 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 index 30224581c2..c133396550 100644 --- a/src/hamiltonian/hamiltonian_abst_h.F90 +++ b/src/hamiltonian/hamiltonian_abst_h.F90 @@ -22,6 +22,8 @@ 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 @@ -36,6 +38,8 @@ module hamiltonian_abst_oct_m !> 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 -- GitLab From b01bc5946fbcebe6b313d5c1f3e95301cbec2c3c Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 15:04:52 +0200 Subject: [PATCH 69/72] system_extension: Link propagator_elec to electron_extension Signed-off-by: Cristian Le --- src/td/propagator_elec.F90 | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/src/td/propagator_elec.F90 b/src/td/propagator_elec.F90 index 321e335e2f..882cec3d24 100644 --- a/src/td/propagator_elec.F90 +++ b/src/td/propagator_elec.F90 @@ -21,6 +21,8 @@ submodule (propagator_elec_oct_m) impl use propagator_elec_oct_m use debug_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 @@ -456,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) @@ -465,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 @@ -502,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 -- GitLab From 69f8ba49111f5cc26353bd72fa0d93d531e364df Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 3 Jul 2023 17:40:33 +0200 Subject: [PATCH 70/72] system_extension: Add output and restart interface Signed-off-by: Cristian Le --- src/extensions/extension.F90 | 32 ++++++++++++++++++++++++++++ src/extensions/extension_h.F90 | 39 ++++++++++++++++++++++++++++++++++ 2 files changed, 71 insertions(+) diff --git a/src/extensions/extension.F90 b/src/extensions/extension.F90 index e32c881721..40d5451986 100644 --- a/src/extensions/extension.F90 +++ b/src/extensions/extension.F90 @@ -1,6 +1,7 @@ #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) @@ -127,6 +128,17 @@ contains 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 @@ -144,6 +156,26 @@ contains ! 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 diff --git a/src/extensions/extension_h.F90 b/src/extensions/extension_h.F90 index 095e989865..97d28af4c1 100644 --- a/src/extensions/extension_h.F90 +++ b/src/extensions/extension_h.F90 @@ -1,5 +1,6 @@ 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 @@ -66,6 +67,7 @@ module extension_oct_m private class(extension_def_t), pointer :: def => null() class(extension_list_t), pointer :: list => null() + type(c_ptr), public, allocatable :: output_handles(:) contains private @@ -77,6 +79,12 @@ module extension_oct_m 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 @@ -244,6 +252,37 @@ module extension_oct_m 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 -- GitLab From e73b82c9ba8a30181dc6e9c5023d006de4c2ef2b Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 11 Sep 2023 21:55:09 +0200 Subject: [PATCH 71/72] system_extension: Link output/restart to system extension Signed-off-by: Cristian Le --- src/multisystem/system.F90 | 33 +++++++++++++++++++++++++++++++-- 1 file changed, 31 insertions(+), 2 deletions(-) diff --git a/src/multisystem/system.F90 b/src/multisystem/system.F90 index 10245f24d4..3db0df12f6 100644 --- a/src/multisystem/system.F90 +++ b/src/multisystem/system.F90 @@ -543,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) @@ -567,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) @@ -582,6 +592,9 @@ contains 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 @@ -610,6 +623,13 @@ contains ! the following call is delegated to the corresponding system res = res .and. this%restart_read_data() + ! 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) @@ -634,10 +654,19 @@ contains 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 -- GitLab From d26254240d5516f9b80db59fb69dea9239faa16d Mon Sep 17 00:00:00 2001 From: Cristian Le Date: Mon, 7 Aug 2023 14:39:26 +0200 Subject: [PATCH 72/72] system_extension: Add hamiltonian extension to update method Signed-off-by: Cristian Le --- src/hamiltonian/hamiltonian_elec.F90 | 29 ++++++++++++++++++++ src/hamiltonian/hamiltonian_extensions.F90 | 7 +++++ src/hamiltonian/hamiltonian_extensions_h.F90 | 13 +++++++++ 3 files changed, 49 insertions(+) diff --git a/src/hamiltonian/hamiltonian_elec.F90 b/src/hamiltonian/hamiltonian_elec.F90 index 3c1d3da13e..21c20de09f 100644 --- a/src/hamiltonian/hamiltonian_elec.F90 +++ b/src/hamiltonian/hamiltonian_elec.F90 @@ -53,6 +53,8 @@ submodule (hamiltonian_elec_oct_m) impl use xc_f03_lib_m use xc_functional_oct_m use xc_interaction_oct_m + use extension_oct_m + use hamiltonian_extensions_oct_m implicit none contains @@ -717,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") @@ -725,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) @@ -844,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) diff --git a/src/hamiltonian/hamiltonian_extensions.F90 b/src/hamiltonian/hamiltonian_extensions.F90 index a6f674a291..8331100ed7 100644 --- a/src/hamiltonian/hamiltonian_extensions.F90 +++ b/src/hamiltonian/hamiltonian_extensions.F90 @@ -38,6 +38,13 @@ contains ! 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 diff --git a/src/hamiltonian/hamiltonian_extensions_h.F90 b/src/hamiltonian/hamiltonian_extensions_h.F90 index 908dea2b72..319d4faaf7 100644 --- a/src/hamiltonian/hamiltonian_extensions_h.F90 +++ b/src/hamiltonian/hamiltonian_extensions_h.F90 @@ -4,6 +4,7 @@ module hamiltonian_extensions_oct_m use namespace_oct_m use mesh_oct_m use batch_oct_m + use, intrinsic :: iso_fortran_env implicit none private @@ -38,6 +39,10 @@ module hamiltonian_extensions_oct_m 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 @@ -95,6 +100,14 @@ module hamiltonian_extensions_oct_m 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. -- GitLab